diff options
Diffstat (limited to 'contrib')
236 files changed, 59016 insertions, 0 deletions
diff --git a/contrib/cc/CCSolve.v b/contrib/cc/CCSolve.v new file mode 100644 index 00000000..fab6f775 --- /dev/null +++ b/contrib/cc/CCSolve.v @@ -0,0 +1,22 @@ +(************************************************************************) +(* 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: CCSolve.v,v 1.4.2.1 2004/07/16 19:29:58 herbelin Exp $ *) + +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. diff --git a/contrib/cc/README b/contrib/cc/README new file mode 100644 index 00000000..073b140e --- /dev/null +++ b/contrib/cc/README @@ -0,0 +1,20 @@ + +cctac: congruence-closure for coq + +author: Pierre Corbineau, + Stage de DEA au LSV, ENS Cachan + Thèse au LRI, Université Paris Sud XI + +Files : + +- ccalgo.ml : congruence closure algorithm +- ccproof.ml : proof generation code +- cctac.ml4 : the tactic itself +- CCSolve.v : a small Ltac tactic based on congruence + +Known Bugs : the congruence tactic can fail due to type dependencies. + +Related documents: + Peter J. Downey, Ravi Sethi, and Robert E. Tarjan. + Variations on the common subexpression problem. + JACM, 27(4):758-771, October 1980. diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml new file mode 100644 index 00000000..e73a6221 --- /dev/null +++ b/contrib/cc/ccalgo.ml @@ -0,0 +1,357 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: ccalgo.ml,v 1.6.2.1 2004/07/16 19:29:58 herbelin Exp $ *) + +(* This file implements the basic congruence-closure algorithm by *) +(* Downey,Sethi and Tarjan. *) + +open Util +open Names +open Term + +let init_size=251 + +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 *) + +type rule= + Congruence + | Axiom of identifier + | Injection of int*int*int*int (* terms+head+arg position *) + +type equality = {lhs:int;rhs:int;rule:rule} + +let swap eq= + let swap_rule=match eq.rule with + Congruence -> Congruence + | Injection (i,j,c,a) -> Injection (j,i,c,a) + | Axiom id -> anomaly "no symmetry for axioms" + in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule} + +(* Signature table *) + +module ST=struct + + (* l: sign -> term r: term -> sign *) + + type t = {toterm:(int*int,int) Hashtbl.t; + tosign:(int,int*int) Hashtbl.t} + + let empty ()= + {toterm=Hashtbl.create init_size; + tosign=Hashtbl.create init_size} + + let enter t sign st= + if Hashtbl.mem st.toterm sign then + anomaly "enter: signature already entered" + else + Hashtbl.replace st.toterm sign t; + Hashtbl.replace st.tosign t sign + + let query sign st=Hashtbl.find st.toterm sign + + let delete t st= + 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 + +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 representative= + {mutable nfathers:int; + mutable fathers:int list; + mutable constructors:pa_constructor PacMap.t; + mutable inductives:(int * int) IndMap.t} + + type cl = Rep of representative| Eqto of int*equality + + type vertex = Leaf| Node of (int*int) + + type node = + {clas:cl; + vertex:vertex; + term:term; + mutable node_constr: int PacMap.t} + + type t={mutable size:int; + map:(int,node) Hashtbl.t; + syms:(term,int) Hashtbl.t; + sigtable:ST.t} + + let empty ():t={size=0; + map=Hashtbl.create init_size; + syms=Hashtbl.create init_size; + sigtable=ST.empty ()} + + 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" + + let get_constructor uf i= + match (Hashtbl.find uf.map i).term with + Constructor (cstr,_,_)->cstr + | _ -> anomaly "get_constructor: not a constructor" + + + let fathers uf i= + (get_representative uf i).fathers + + let size uf i= + (get_representative uf i).nfathers + + let add_father uf i t= + let r=get_representative uf i in + r.nfathers<-r.nfathers+1; + r.fathers<-t::r.fathers + + let pac_map uf i= + (get_representative uf i).constructors + + let pac_arity uf i sg= + (PacMap.find sg (get_representative uf i).constructors).arity + + 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 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 new_representative pm im= + {nfathers=0; + fathers=[]; + constructors=pm; + inductives=im} + + let rec add uf t= + 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} + | 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} + in + Hashtbl.add 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 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 join_path uf i j= + assert (find uf i=find uf j); + min_path (down_path uf i [],down_path uf j []) + +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 + 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 + 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 + + diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli new file mode 100644 index 00000000..47cdb3ea --- /dev/null +++ b/contrib/cc/ccalgo.mli @@ -0,0 +1,84 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: ccalgo.mli,v 1.6.2.1 2004/07/16 19:29:58 herbelin Exp $ *) + +type pa_constructor + (*{head: int; arity: int; args: (int * int) list}*) + +module PacMap:Map.S with type key=int * int + +type term = + Symb of Term.constr + | Appli of term * term + | Constructor of Names.constructor*int*int + +type rule = + Congruence + | Axiom of Names.identifier + | Injection of int*int*int*int + +type equality = + {lhs : int; + rhs : int; + rule : rule} + +module ST : +sig + type t + val empty : unit -> t + val enter : int -> int * int -> t -> unit + val query : int * int -> t -> int + val delete : int -> t -> unit + val delete_list : int list -> t -> unit +end + +module UF : +sig + type t + exception Discriminable of int * int * int * int * t + val empty : unit -> t + val find : t -> int -> int + val size : t -> int -> int + val get_constructor : t -> int -> Names.constructor + val pac_arity : t -> int -> int * int -> int + val mem_node_pac : t -> int -> int * int -> int + val add_pacs : t -> int -> pa_constructor PacMap.t -> + int list * equality list + val term : t -> int -> term + val subterms : t -> int -> int * int + val add : t -> term -> int + val union : t -> int -> int -> equality -> int list * equality list + val join_path : t -> int -> int -> + ((int*int)*equality) list* + ((int*int)*equality) list +end + + +val combine_rec : UF.t -> int list -> equality list +val process_rec : UF.t -> equality list -> int list + +val cc : UF.t -> unit + +val make_uf : + (Names.identifier * (term * term)) list -> UF.t + +val add_one_diseq : UF.t -> (term * term) -> int * int + +val add_disaxioms : + UF.t -> (Names.identifier * (term * term)) list -> + (Names.identifier * (int * int)) list + +val check_equal : UF.t -> int * int -> bool + +val find_contradiction : UF.t -> + (Names.identifier * (int * int)) list -> + (Names.identifier * (int * int)) + + + diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml new file mode 100644 index 00000000..fa525e65 --- /dev/null +++ b/contrib/cc/ccproof.ml @@ -0,0 +1,157 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: ccproof.ml,v 1.8.2.1 2004/07/16 19:29:58 herbelin Exp $ *) + +(* This file uses the (non-compressed) union-find structure to generate *) +(* proof-trees that will be transformed into proof-terms in cctac.ml4 *) + +open Util +open Names +open Ccalgo + +type proof= + Ax of identifier + | SymAx of identifier + | Refl of term + | Trans of proof*proof + | Congr of proof*proof + | Inject of proof*constructor*int*int + +let pcongr=function + Refl t1, Refl t2 -> Refl (Appli (t1,t2)) + | p1, p2 -> Congr (p1,p2) + +let rec ptrans=function + Refl _, p ->p + | p, Refl _ ->p + | Trans(p1,p2), p3 ->ptrans(p1,ptrans (p2,p3)) + | Congr(p1,p2), Congr(p3,p4) ->pcongr(ptrans(p1,p3),ptrans(p2,p4)) + | Congr(p1,p2), Trans(Congr(p3,p4),p5) -> + ptrans(pcongr(ptrans(p1,p3),ptrans(p2,p4)),p5) + | p1, p2 ->Trans (p1,p2) + +let rec psym=function + Refl p->Refl p + | SymAx s->Ax s + | Ax s-> SymAx s + | Inject (p,c,n,a)-> Inject (psym p,c,n,a) + | Trans (p1,p2)-> ptrans (psym p2,psym p1) + | Congr (p1,p2)-> pcongr (psym p1,psym p2) + +let pcongr=function + Refl t1, Refl t2 ->Refl (Appli (t1,t2)) + | p1, p2 -> Congr (p1,p2) + +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 + ptrans (path_proof i li,psym (path_proof j lj)) + + and edge_proof ((i,j),eq)= + let pi=equal_proof i eq.lhs in + let pj=psym (equal_proof j eq.rhs) in + let pij= + match eq.rule with + Axiom s->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" + 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 path_proof i=function + [] -> Refl (UF.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 + pcongr (equal_proof i1 j1, equal_proof i2 j2) + + and discr_proof i ci j cj= + let p=equal_proof i j + and p1=constr_proof i i ci 0 + and p2=constr_proof j j cj 0 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 + +let rec nth_arg t n= + match t with + Appli (t1,t2)-> + if n>0 then + nth_arg t1 (n-1) + else t2 + | _ -> anomaly "nth_arg: not enough args" + +let 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) + | Refl t-> t,t + | Trans (p1,p2)-> + let (s1,t1)=type_proof axioms p1 + and (t2,s2)=type_proof axioms p2 in + if t1=t2 then (s1,s2) else anomaly "invalid cc transitivity" + | Congr (p1,p2)-> + let (i1,j1)=type_proof axioms p1 + and (i2,j2)=type_proof axioms p2 in + Appli (i1,i2),Appli (j1,j2) + | Inject (p,c,n,a)-> + 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 new file mode 100644 index 00000000..887ed070 --- /dev/null +++ b/contrib/cc/ccproof.mli @@ -0,0 +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 *) +(************************************************************************) + +(* $Id: ccproof.mli,v 1.6.2.1 2004/07/16 19:29:59 herbelin Exp $ *) + +open Ccalgo +open Names + +type proof = + Ax of identifier + | SymAx of identifier + | Refl of term + | Trans of proof * proof + | Congr of proof * proof + | Inject of proof * constructor * int * int + +val pcongr : proof * proof -> proof +val ptrans : proof * proof -> proof +val psym : proof -> proof +val pcongr : proof * proof -> proof + +val build_proof : + UF.t -> + [ `Discriminate of int * int * int * int + | `Prove_goal of int * int + | `Refute_hyp of int * int ] + -> proof + +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 ] + + diff --git a/contrib/cc/cctac.ml4 b/contrib/cc/cctac.ml4 new file mode 100644 index 00000000..49fe46fe --- /dev/null +++ b/contrib/cc/cctac.ml4 @@ -0,0 +1,247 @@ +(************************************************************************) +(* 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/correctness/ArrayPermut.v b/contrib/correctness/ArrayPermut.v new file mode 100644 index 00000000..b352045a --- /dev/null +++ b/contrib/correctness/ArrayPermut.v @@ -0,0 +1,175 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: ArrayPermut.v,v 1.3.2.1 2004/07/16 19:29:59 herbelin Exp $ *) + +(****************************************************************************) +(* Permutations of elements in arrays *) +(* Definition and properties *) +(****************************************************************************) + +Require Import ProgInt. +Require Import Arrays. +Require Export Exchange. + +Require Import Omega. + +Set Implicit Arguments. + +(* We define "permut" as the smallest equivalence relation which contains + * transpositions i.e. exchange of two elements. + *) + +Inductive permut (n:Z) (A:Set) : array n A -> array n A -> Prop := + | exchange_is_permut : + forall (t t':array n A) (i j:Z), exchange t t' i j -> permut t t' + | permut_refl : forall t:array n A, permut t t + | permut_sym : forall t t':array n A, permut t t' -> permut t' t + | permut_trans : + forall t t' t'':array n A, permut t t' -> permut t' t'' -> permut t t''. + +Hint Resolve exchange_is_permut permut_refl permut_sym permut_trans: v62 + datatypes. + +(* We also define the permutation on a segment of an array, "sub_permut", + * the other parts of the array being unchanged + * + * One again we define it as the smallest equivalence relation containing + * transpositions on the given segment. + *) + +Inductive sub_permut (n:Z) (A:Set) (g d:Z) : +array n A -> array n A -> Prop := + | exchange_is_sub_permut : + forall (t t':array n A) (i j:Z), + (g <= i <= d)%Z -> + (g <= j <= d)%Z -> exchange t t' i j -> sub_permut g d t t' + | sub_permut_refl : forall t:array n A, sub_permut g d t t + | sub_permut_sym : + forall t t':array n A, sub_permut g d t t' -> sub_permut g d t' t + | sub_permut_trans : + forall t t' t'':array n A, + sub_permut g d t t' -> sub_permut g d t' t'' -> sub_permut g d t t''. + +Hint Resolve exchange_is_sub_permut sub_permut_refl sub_permut_sym + sub_permut_trans: v62 datatypes. + +(* To express that some parts of arrays are equal we introduce the + * property "array_id" which says that a segment is the same on two + * arrays. + *) + +Definition array_id (n:Z) (A:Set) (t t':array n A) + (g d:Z) := forall i:Z, (g <= i <= d)%Z -> #t [i] = #t' [i]. + +(* array_id is an equivalence relation *) + +Lemma array_id_refl : + forall (n:Z) (A:Set) (t:array n A) (g d:Z), array_id t t g d. +Proof. +unfold array_id in |- *. +auto with datatypes. +Qed. + +Hint Resolve array_id_refl: v62 datatypes. + +Lemma array_id_sym : + forall (n:Z) (A:Set) (t t':array n A) (g d:Z), + array_id t t' g d -> array_id t' t g d. +Proof. +unfold array_id in |- *. intros. +symmetry in |- *; auto with datatypes. +Qed. + +Hint Resolve array_id_sym: v62 datatypes. + +Lemma array_id_trans : + forall (n:Z) (A:Set) (t t' t'':array n A) (g d:Z), + array_id t t' g d -> array_id t' t'' g d -> array_id t t'' g d. +Proof. +unfold array_id in |- *. intros. +apply trans_eq with (y := #t' [i]); auto with datatypes. +Qed. + +Hint Resolve array_id_trans: v62 datatypes. + +(* Outside the segment [g,d] the elements are equal *) + +Lemma sub_permut_id : + forall (n:Z) (A:Set) (t t':array n A) (g d:Z), + sub_permut g d t t' -> + array_id t t' 0 (g - 1) /\ array_id t t' (d + 1) (n - 1). +Proof. +intros n A t t' g d. simple induction 1; intros. +elim H2; intros. +unfold array_id in |- *; split; intros. +apply H7; omega. +apply H7; omega. +auto with datatypes. +decompose [and] H1; auto with datatypes. +decompose [and] H1; decompose [and] H3; eauto with datatypes. +Qed. + +Hint Resolve sub_permut_id. + +Lemma sub_permut_eq : + forall (n:Z) (A:Set) (t t':array n A) (g d:Z), + sub_permut g d t t' -> + forall i:Z, (0 <= i < g)%Z \/ (d < i < n)%Z -> #t [i] = #t' [i]. +Proof. +intros n A t t' g d Htt' i Hi. +elim (sub_permut_id Htt'). unfold array_id in |- *. +intros. +elim Hi; [ intro; apply H; omega | intro; apply H0; omega ]. +Qed. + +(* sub_permut is a particular case of permutation *) + +Lemma sub_permut_is_permut : + forall (n:Z) (A:Set) (t t':array n A) (g d:Z), + sub_permut g d t t' -> permut t t'. +Proof. +intros n A t t' g d. simple induction 1; intros; eauto with datatypes. +Qed. + +Hint Resolve sub_permut_is_permut. + +(* If we have a sub-permutation on an empty segment, then we have a + * sub-permutation on any segment. + *) + +Lemma sub_permut_void : + forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z), + (d < g)%Z -> sub_permut g d t t' -> sub_permut g' d' t t'. +Proof. +intros N A t t' g g' d d' Hdg. +simple induction 1; intros. +absurd (g <= d)%Z; omega. +auto with datatypes. +auto with datatypes. +eauto with datatypes. +Qed. + +(* A sub-permutation on a segment may be extended to any segment that + * contains the first one. + *) + +Lemma sub_permut_extension : + forall (N:Z) (A:Set) (t t':array N A) (g g' d d':Z), + (g' <= g)%Z -> (d <= d')%Z -> sub_permut g d t t' -> sub_permut g' d' t t'. +Proof. +intros N A t t' g g' d d' Hgg' Hdd'. +simple induction 1; intros. +apply exchange_is_sub_permut with (i := i) (j := j); + [ omega | omega | assumption ]. +auto with datatypes. +auto with datatypes. +eauto with datatypes. +Qed.
\ No newline at end of file diff --git a/contrib/correctness/Arrays.v b/contrib/correctness/Arrays.v new file mode 100644 index 00000000..1659917a --- /dev/null +++ b/contrib/correctness/Arrays.v @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: Arrays.v,v 1.9.2.1 2004/07/16 19:29:59 herbelin Exp $ *) + +(**********************************************) +(* Functional arrays, for use in Correctness. *) +(**********************************************) + +(* This is an axiomatization of arrays. + * + * The type (array N T) is the type of arrays ranging from 0 to N-1 + * which elements are of type T. + * + * Arrays are created with new, accessed with access and modified with store. + * + * Operations of accessing and storing are not guarded, but axioms are. + * So these arrays can be viewed as arrays where accessing and storing + * out of the bounds has no effect. + *) + + +Require Export ProgInt. + +Set Implicit Arguments. + + +(* The type of arrays *) + +Parameter array : Z -> Set -> Set. + + +(* Functions to create, access and modify arrays *) + +Parameter new : forall (n:Z) (T:Set), T -> array n T. + +Parameter access : forall (n:Z) (T:Set), array n T -> Z -> T. + +Parameter store : forall (n:Z) (T:Set), array n T -> Z -> T -> array n T. + + +(* Axioms *) + +Axiom + new_def : + forall (n:Z) (T:Set) (v0:T) (i:Z), + (0 <= i < n)%Z -> access (new n v0) i = v0. + +Axiom + store_def_1 : + forall (n:Z) (T:Set) (t:array n T) (v:T) (i:Z), + (0 <= i < n)%Z -> access (store t i v) i = v. + +Axiom + store_def_2 : + forall (n:Z) (T:Set) (t:array n T) (v:T) (i j:Z), + (0 <= i < n)%Z -> + (0 <= j < n)%Z -> i <> j -> access (store t i v) j = access t j. + +Hint Resolve new_def store_def_1 store_def_2: datatypes v62. + +(* A tactic to simplify access in arrays *) + +Ltac array_access i j H := + elim (Z_eq_dec i j); + [ intro H; rewrite H; rewrite store_def_1 + | intro H; rewrite store_def_2; [ idtac | idtac | idtac | exact H ] ]. + +(* Symbolic notation for access *) + +Notation "# t [ c ]" := (access t c) (at level 0, t at level 0).
\ No newline at end of file diff --git a/contrib/correctness/Arrays_stuff.v b/contrib/correctness/Arrays_stuff.v new file mode 100644 index 00000000..899d7007 --- /dev/null +++ b/contrib/correctness/Arrays_stuff.v @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* 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 $ *) + +Require Export Exchange. +Require Export ArrayPermut. +Require Export Sorted. + diff --git a/contrib/correctness/Correctness.v b/contrib/correctness/Correctness.v new file mode 100644 index 00000000..a2ad2f50 --- /dev/null +++ b/contrib/correctness/Correctness.v @@ -0,0 +1,25 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: Correctness.v,v 1.6.2.1 2004/07/16 19:29:59 herbelin Exp $ *) + +(* Correctness is base on the tactic Refine (developped on purpose) *) + +Require Export Tuples. + +Require Export ProgInt. +Require Export ProgBool. +Require Export Zwf. + +Require Export Arrays. + +(* +Token "'". +*)
\ No newline at end of file diff --git a/contrib/correctness/Exchange.v b/contrib/correctness/Exchange.v new file mode 100644 index 00000000..7dc5218e --- /dev/null +++ b/contrib/correctness/Exchange.v @@ -0,0 +1,95 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: Exchange.v,v 1.4.2.1 2004/07/16 19:30:00 herbelin Exp $ *) + +(****************************************************************************) +(* Exchange of two elements in an array *) +(* Definition and properties *) +(****************************************************************************) + +Require Import ProgInt. +Require Import Arrays. + +Set Implicit Arguments. + +(* Definition *) + +Inductive exchange (n:Z) (A:Set) (t t':array n A) (i j:Z) : Prop := + exchange_c : + (0 <= i < n)%Z -> + (0 <= j < n)%Z -> + #t [i] = #t' [j] -> + #t [j] = #t' [i] -> + (forall k:Z, (0 <= k < n)%Z -> k <> i -> k <> j -> #t [k] = #t' [k]) -> + exchange t t' i j. + +(* Properties about exchanges *) + +Lemma exchange_1 : + forall (n:Z) (A:Set) (t:array n A) (i j:Z), + (0 <= i < n)%Z -> + (0 <= j < n)%Z -> #(store (store t i #t [j]) j #t [i]) [i] = #t [j]. +Proof. +intros n A t i j H_i H_j. +case (dec_eq j i). +intro eq_i_j. rewrite eq_i_j. +auto with datatypes. +intro not_j_i. +rewrite (store_def_2 (store t i #t [j]) #t [i] H_j H_i not_j_i). +auto with datatypes. +Qed. + +Hint Resolve exchange_1: v62 datatypes. + + +Lemma exchange_proof : + forall (n:Z) (A:Set) (t:array n A) (i j:Z), + (0 <= i < n)%Z -> + (0 <= j < n)%Z -> exchange (store (store t i #t [j]) j #t [i]) t i j. +Proof. +intros n A t i j H_i H_j. +apply exchange_c; auto with datatypes. +intros k H_k not_k_i not_k_j. +cut (j <> k); auto with datatypes. intro not_j_k. +rewrite (store_def_2 (store t i #t [j]) #t [i] H_j H_k not_j_k). +auto with datatypes. +Qed. + +Hint Resolve exchange_proof: v62 datatypes. + + +Lemma exchange_sym : + forall (n:Z) (A:Set) (t t':array n A) (i j:Z), + exchange t t' i j -> exchange t' t i j. +Proof. +intros n A t t' i j H1. +elim H1. clear H1. intros. +constructor 1; auto with datatypes. +intros. rewrite (H3 k); auto with datatypes. +Qed. + +Hint Resolve exchange_sym: v62 datatypes. + + +Lemma exchange_id : + forall (n:Z) (A:Set) (t t':array n A) (i j:Z), + exchange t t' i j -> + i = j -> forall k:Z, (0 <= k < n)%Z -> #t [k] = #t' [k]. +Proof. +intros n A t t' i j Hex Heq k Hk. +elim Hex. clear Hex. intros. +rewrite Heq in H1. rewrite Heq in H2. +case (Z_eq_dec k j). + intro Heq'. rewrite Heq'. assumption. + intro Hnoteq. apply (H3 k); auto with datatypes. rewrite Heq. assumption. +Qed. + +Hint Resolve exchange_id: v62 datatypes.
\ No newline at end of file diff --git a/contrib/correctness/ProgBool.v b/contrib/correctness/ProgBool.v new file mode 100644 index 00000000..bce19870 --- /dev/null +++ b/contrib/correctness/ProgBool.v @@ -0,0 +1,66 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: ProgBool.v,v 1.4.2.1 2004/07/16 19:30:00 herbelin Exp $ *) + +Require Import ZArith. +Require Export Bool_nat. +Require Export Sumbool. + +Definition annot_bool : + forall b:bool, {b' : bool | if b' then b = true else b = false}. +Proof. +intro b. +exists b. case b; trivial. +Qed. + + +(* Logical connectives *) + +Definition spec_and (A B C D:Prop) (b:bool) := if b then A /\ C else B \/ D. + +Definition prog_bool_and : + forall Q1 Q2:bool -> Prop, + sig Q1 -> + sig Q2 -> + {b : bool | if b then Q1 true /\ Q2 true else Q1 false \/ Q2 false}. +Proof. +intros Q1 Q2 H1 H2. +elim H1. intro b1. elim H2. intro b2. +case b1; case b2; intros. +exists true; auto. +exists false; auto. exists false; auto. exists false; auto. +Qed. + +Definition spec_or (A B C D:Prop) (b:bool) := if b then A \/ C else B /\ D. + +Definition prog_bool_or : + forall Q1 Q2:bool -> Prop, + sig Q1 -> + sig Q2 -> + {b : bool | if b then Q1 true \/ Q2 true else Q1 false /\ Q2 false}. +Proof. +intros Q1 Q2 H1 H2. +elim H1. intro b1. elim H2. intro b2. +case b1; case b2; intros. +exists true; auto. exists true; auto. exists true; auto. +exists false; auto. +Qed. + +Definition spec_not (A B:Prop) (b:bool) := if b then B else A. + +Definition prog_bool_not : + forall Q:bool -> Prop, sig Q -> {b : bool | if b then Q false else Q true}. +Proof. +intros Q H. +elim H. intro b. +case b; intro. +exists false; auto. exists true; auto. +Qed. diff --git a/contrib/correctness/ProgInt.v b/contrib/correctness/ProgInt.v new file mode 100644 index 00000000..c26e3553 --- /dev/null +++ b/contrib/correctness/ProgInt.v @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: ProgInt.v,v 1.2.2.1 2004/07/16 19:30:00 herbelin Exp $ *) + +Require Export ZArith. +Require Export ZArith_dec. + +Theorem Znotzero : forall x:Z, {x <> 0%Z} + {x = 0%Z}. +Proof. +intro x. elim (Z_eq_dec x 0); auto. +Qed.
\ No newline at end of file diff --git a/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v new file mode 100644 index 00000000..40253f33 --- /dev/null +++ b/contrib/correctness/ProgramsExtraction.v @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: ProgramsExtraction.v,v 1.2.16.1 2004/07/16 19:30:00 herbelin Exp $ *) + +Require Export Extraction. + +Extract Inductive unit => unit [ "()" ]. +Extract Inductive bool => bool [ true false ]. +Extract Inductive sumbool => bool [ true false ]. + +Require Export Correctness. + +Declare ML Module "pextract". + +Grammar vernac vernac : ast := + imperative_ocaml [ "Write" "Caml" "File" stringarg($file) + "[" ne_identarg_list($idl) "]" "." ] + -> [ (IMPERATIVEEXTRACTION $file (VERNACARGLIST ($LIST $idl))) ] + +| initialize [ "Initialize" identarg($id) "with" comarg($c) "." ] + -> [ (INITIALIZE $id $c) ] +. diff --git a/contrib/correctness/Programs_stuff.v b/contrib/correctness/Programs_stuff.v new file mode 100644 index 00000000..1ca4b63e --- /dev/null +++ b/contrib/correctness/Programs_stuff.v @@ -0,0 +1,13 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: Programs_stuff.v,v 1.1.16.1 2004/07/16 19:30:00 herbelin Exp $ *) + +Require Export Arrays_stuff. diff --git a/contrib/correctness/Sorted.v b/contrib/correctness/Sorted.v new file mode 100644 index 00000000..2efe54a4 --- /dev/null +++ b/contrib/correctness/Sorted.v @@ -0,0 +1,202 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Library about sorted (sub-)arrays / Nicolas Magaud, July 1998 *) + +(* $Id: Sorted.v,v 1.7.2.1 2004/07/16 19:30:00 herbelin Exp $ *) + +Require Export Arrays. +Require Import ArrayPermut. + +Require Import ZArithRing. +Require Import Omega. +Open Local Scope Z_scope. + +Set Implicit Arguments. + +(* Definition *) + +Definition sorted_array (N:Z) (A:array N Z) (deb fin:Z) := + deb <= fin -> forall x:Z, x >= deb -> x < fin -> #A [x] <= #A [x + 1]. + +(* Elements of a sorted sub-array are in increasing order *) + +(* one element and the next one *) + +Lemma sorted_elements_1 : + forall (N:Z) (A:array N Z) (n m:Z), + sorted_array A n m -> + forall k:Z, + k >= n -> forall i:Z, 0 <= i -> k + i <= m -> #A [k] <= #A [k + i]. +Proof. +intros N A n m H_sorted k H_k i H_i. +pattern i in |- *. apply natlike_ind. +intro. +replace (k + 0) with k; omega. (*** Ring `k+0` => BUG ***) + +intros. +apply Zle_trans with (m := #A [k + x]). +apply H0; omega. + +unfold Zsucc in |- *. +replace (k + (x + 1)) with (k + x + 1). +unfold sorted_array in H_sorted. +apply H_sorted; omega. + +omega. + +assumption. +Qed. + +(* one element and any of the following *) + +Lemma sorted_elements : + forall (N:Z) (A:array N Z) (n m k l:Z), + sorted_array A n m -> + k >= n -> l < N -> k <= l -> l <= m -> #A [k] <= #A [l]. +Proof. +intros. +replace l with (k + (l - k)). +apply sorted_elements_1 with (n := n) (m := m); + [ assumption | omega | omega | omega ]. +omega. +Qed. + +Hint Resolve sorted_elements: datatypes v62. + +(* A sub-array of a sorted array is sorted *) + +Lemma sub_sorted_array : + forall (N:Z) (A:array N Z) (deb fin i j:Z), + sorted_array A deb fin -> + i >= deb -> j <= fin -> i <= j -> sorted_array A i j. +Proof. +unfold sorted_array in |- *. +intros. +apply H; omega. +Qed. + +Hint Resolve sub_sorted_array: datatypes v62. + +(* Extension on the left of the property of being sorted *) + +Lemma left_extension : + forall (N:Z) (A:array N Z) (i j:Z), + i > 0 -> + j < N -> + sorted_array A i j -> #A [i - 1] <= #A [i] -> sorted_array A (i - 1) j. +Proof. +intros; unfold sorted_array in |- *; intros. +elim (Z_ge_lt_dec x i). (* (`x >= i`) + (`x < i`) *) +intro Hcut. +apply H1; omega. + +intro Hcut. +replace x with (i - 1). +replace (i - 1 + 1) with i; [ assumption | omega ]. + +omega. +Qed. + +(* Extension on the right *) + +Lemma right_extension : + forall (N:Z) (A:array N Z) (i j:Z), + i >= 0 -> + j < N - 1 -> + sorted_array A i j -> #A [j] <= #A [j + 1] -> sorted_array A i (j + 1). +Proof. +intros; unfold sorted_array in |- *; intros. +elim (Z_lt_ge_dec x j). +intro Hcut. +apply H1; omega. + +intro HCut. +replace x with j; [ assumption | omega ]. +Qed. + +(* Substitution of the leftmost value by a smaller value *) + +Lemma left_substitution : + forall (N:Z) (A:array N Z) (i j v:Z), + i >= 0 -> + j < N -> + sorted_array A i j -> v <= #A [i] -> sorted_array (store A i v) i j. +Proof. +intros N A i j v H_i H_j H_sorted H_v. +unfold sorted_array in |- *; intros. + +cut (x = i \/ x > i). +intro Hcut; elim Hcut; clear Hcut; intro. +rewrite H2. +rewrite store_def_1; try omega. +rewrite store_def_2; try omega. +apply Zle_trans with (m := #A [i]); [ assumption | apply H_sorted; omega ]. + +rewrite store_def_2; try omega. +rewrite store_def_2; try omega. +apply H_sorted; omega. +omega. +Qed. + +(* Substitution of the rightmost value by a larger value *) + +Lemma right_substitution : + forall (N:Z) (A:array N Z) (i j v:Z), + i >= 0 -> + j < N -> + sorted_array A i j -> #A [j] <= v -> sorted_array (store A j v) i j. +Proof. +intros N A i j v H_i H_j H_sorted H_v. +unfold sorted_array in |- *; intros. + +cut (x = j - 1 \/ x < j - 1). +intro Hcut; elim Hcut; clear Hcut; intro. +rewrite H2. +replace (j - 1 + 1) with j; [ idtac | omega ]. (*** Ring `j-1+1`. => BUG ***) +rewrite store_def_2; try omega. +rewrite store_def_1; try omega. +apply Zle_trans with (m := #A [j]). +apply sorted_elements with (n := i) (m := j); try omega; assumption. +assumption. + +rewrite store_def_2; try omega. +rewrite store_def_2; try omega. +apply H_sorted; omega. + +omega. +Qed. + +(* Affectation outside of the sorted region *) + +Lemma no_effect : + forall (N:Z) (A:array N Z) (i j k v:Z), + i >= 0 -> + j < N -> + sorted_array A i j -> + 0 <= k < i \/ j < k < N -> sorted_array (store A k v) i j. +Proof. +intros. +unfold sorted_array in |- *; intros. +rewrite store_def_2; try omega. +rewrite store_def_2; try omega. +apply H1; assumption. +Qed. + +Lemma sorted_array_id : + forall (N:Z) (t1 t2:array N Z) (g d:Z), + sorted_array t1 g d -> array_id t1 t2 g d -> sorted_array t2 g d. +Proof. +intros N t1 t2 g d Hsorted Hid. +unfold array_id in Hid. +unfold sorted_array in Hsorted. unfold sorted_array in |- *. +intros Hgd x H1x H2x. +rewrite <- (Hid x); [ idtac | omega ]. +rewrite <- (Hid (x + 1)); [ idtac | omega ]. +apply Hsorted; assumption. +Qed.
\ No newline at end of file diff --git a/contrib/correctness/Tuples.v b/contrib/correctness/Tuples.v new file mode 100644 index 00000000..e3fff08d --- /dev/null +++ b/contrib/correctness/Tuples.v @@ -0,0 +1,98 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: Tuples.v,v 1.2.2.1 2004/07/16 19:30:00 herbelin Exp $ *) + +(* Tuples *) + +Definition tuple_1 (X:Set) := X. +Definition tuple_2 := prod. +Definition Build_tuple_2 := pair. +Definition proj_2_1 := fst. +Definition proj_2_2 := snd. + +Record tuple_3 (T1 T2 T3:Set) : Set := + {proj_3_1 : T1; proj_3_2 : T2; proj_3_3 : T3}. + +Record tuple_4 (T1 T2 T3 T4:Set) : Set := + {proj_4_1 : T1; proj_4_2 : T2; proj_4_3 : T3; proj_4_4 : T4}. + +Record tuple_5 (T1 T2 T3 T4 T5:Set) : Set := + {proj_5_1 : T1; proj_5_2 : T2; proj_5_3 : T3; proj_5_4 : T4; proj_5_5 : T5}. + +Record tuple_6 (T1 T2 T3 T4 T5 T6:Set) : Set := + {proj_6_1 : T1; + proj_6_2 : T2; + proj_6_3 : T3; + proj_6_4 : T4; + proj_6_5 : T5; + proj_6_6 : T6}. + +Record tuple_7 (T1 T2 T3 T4 T5 T6 T7:Set) : Set := + {proj_7_1 : T1; + proj_7_2 : T2; + proj_7_3 : T3; + proj_7_4 : T4; + proj_7_5 : T5; + proj_7_6 : T6; + proj_7_7 : T7}. + + +(* Existentials *) + +Definition sig_1 := sig. +Definition exist_1 := exist. + +Inductive sig_2 (T1 T2:Set) (P:T1 -> T2 -> Prop) : Set := + exist_2 : forall (x1:T1) (x2:T2), P x1 x2 -> sig_2 T1 T2 P. + +Inductive sig_3 (T1 T2 T3:Set) (P:T1 -> T2 -> T3 -> Prop) : Set := + exist_3 : forall (x1:T1) (x2:T2) (x3:T3), P x1 x2 x3 -> sig_3 T1 T2 T3 P. + + +Inductive sig_4 (T1 T2 T3 T4:Set) (P:T1 -> T2 -> T3 -> T4 -> Prop) : Set := + exist_4 : + forall (x1:T1) (x2:T2) (x3:T3) (x4:T4), + P x1 x2 x3 x4 -> sig_4 T1 T2 T3 T4 P. + +Inductive sig_5 (T1 T2 T3 T4 T5:Set) (P:T1 -> T2 -> T3 -> T4 -> T5 -> Prop) : +Set := + exist_5 : + forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5), + P x1 x2 x3 x4 x5 -> sig_5 T1 T2 T3 T4 T5 P. + +Inductive sig_6 (T1 T2 T3 T4 T5 T6:Set) +(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> Prop) : Set := + exist_6 : + forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) + (x6:T6), P x1 x2 x3 x4 x5 x6 -> sig_6 T1 T2 T3 T4 T5 T6 P. + +Inductive sig_7 (T1 T2 T3 T4 T5 T6 T7:Set) +(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> T7 -> Prop) : Set := + exist_7 : + forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) + (x6:T6) (x7:T7), + P x1 x2 x3 x4 x5 x6 x7 -> sig_7 T1 T2 T3 T4 T5 T6 T7 P. + +Inductive sig_8 (T1 T2 T3 T4 T5 T6 T7 T8:Set) +(P:T1 -> T2 -> T3 -> T4 -> T5 -> T6 -> T7 -> T8 -> Prop) : Set := + exist_8 : + forall (x1:T1) (x2:T2) (x3:T3) (x4:T4) (x5:T5) + (x6:T6) (x7:T7) (x8:T8), + P x1 x2 x3 x4 x5 x6 x7 x8 -> sig_8 T1 T2 T3 T4 T5 T6 T7 T8 P. + +Inductive dep_tuple_2 (T1 T2:Set) (P:T1 -> T2 -> Set) : Set := + Build_dep_tuple_2 : + forall (x1:T1) (x2:T2), P x1 x2 -> dep_tuple_2 T1 T2 P. + +Inductive dep_tuple_3 (T1 T2 T3:Set) (P:T1 -> T2 -> T3 -> Set) : Set := + Build_dep_tuple_3 : + forall (x1:T1) (x2:T2) (x3:T3), P x1 x2 x3 -> dep_tuple_3 T1 T2 T3 P. + diff --git a/contrib/correctness/examples/Handbook.v b/contrib/correctness/examples/Handbook.v new file mode 100644 index 00000000..8c983a72 --- /dev/null +++ b/contrib/correctness/examples/Handbook.v @@ -0,0 +1,232 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: Handbook.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *) + +(* This file contains proofs of programs taken from the + * "Handbook of Theoretical Computer Science", volume B, + * chapter "Methods and Logics for Proving Programs", by P. Cousot, + * pp 841--993, Edited by J. van Leeuwen (c) Elsevier Science Publishers B.V. + * 1990. + * + * Programs are refered to by numbers and pages. + *) + +Require Correctness. + +Require Sumbool. +Require Omega. +Require Zcomplements. +Require Zpower. + +(****************************************************************************) + +(* program (2) page 853 to compute x^y (annotated version is (25) page 860) *) + +(* en attendant... *) +Parameter Zdiv2 : Z->Z. + +Parameter Zeven_odd_dec : (x:Z){`x=2*(Zdiv2 x)`}+{`x=2*(Zdiv2 x)+1`}. +Definition Zodd_dec := [z:Z](sumbool_not ? ? (Zeven_odd_dec z)). +Definition Zodd_bool := [z:Z](bool_of_sumbool ? ? (Zodd_dec z)). + +Axiom axiom1 : (x,y:Z) `y>0` -> `x*(Zpower x (Zpred y)) = (Zpower x y)`. +Axiom axiom2 : (x:Z)`x>0` -> `(Zdiv2 x)<x`. +Axiom axiom3 : (x,y:Z) `y>=0` -> `(Zpower (x*x) (Zdiv2 y)) = (Zpower x y)`. + +Global Variable X : Z ref. +Global Variable Y : Z ref. +Global Variable Z_ : Z ref. + +Correctness pgm25 + { `Y >= 0` } + begin + Z_ := 1; + while !Y <> 0 do + { invariant `Y >= 0` /\ `Z_ * (Zpower X Y) = (Zpower X@0 Y@0)` + variant Y } + if (Zodd_bool !Y) then begin + Y := (Zpred !Y); + Z_ := (Zmult !Z_ !X) + end else begin + Y := (Zdiv2 !Y); + X := (Zmult !X !X) + end + done + end + { Z_ = (Zpower X@ Y@) }. +Proof. +Split. +Unfold Zpred; Unfold Zwf; Omega. +Split. +Unfold Zpred; Omega. +Decompose [and] Pre2. +Rewrite <- H0. +Replace `Z_1*X0*(Zpower X0 (Zpred Y0))` with `Z_1*(X0*(Zpower X0 (Zpred Y0)))`. +Apply f_equal with f := (Zmult Z_1). +Apply axiom1. +Omega. + +Auto. +Symmetry. +Apply Zmult_assoc_r. + +Split. +Unfold Zwf. +Repeat (Apply conj). +Omega. + +Omega. + +Apply axiom2. Omega. + +Split. +Omega. + +Decompose [and] Pre2. +Rewrite <- H0. +Apply f_equal with f:=(Zmult Z_1). +Apply axiom3. Omega. + +Omega. + +Decompose [and] Post6. +Rewrite <- H2. +Rewrite H0. +Simpl. +Omega. + +Save. + + +(****************************************************************************) + +(* program (178) page 934 to compute the factorial using global variables + * annotated version is (185) page 939 + *) + +Parameter Zfact : Z -> Z. + +Axiom axiom4 : `(Zfact 0) = 1`. +Axiom axiom5 : (x:Z) `x>0` -> `(Zfact (x-1))*x=(Zfact x)`. + +Correctness pgm178 +let rec F (u:unit) : unit { variant X } = + { `X>=0` } + (if !X = 0 then + Y := 1 + else begin + label L; + X := (Zpred !X); + (F tt); + X := (Zs !X); + Y := (Zmult !Y !X) + end) + { `X=X@` /\ `Y=(Zfact X@)` }. +Proof. +Rewrite Test1. Rewrite axiom4. Auto. +Unfold Zwf. Unfold Zpred. Omega. +Unfold Zpred. Omega. +Unfold Zs. Unfold Zpred in Post3. Split. +Omega. +Decompose [and] Post3. +Rewrite H. +Replace `X0+(-1)+1` with X0. +Rewrite H0. +Replace `X0+(-1)` with `X0-1`. +Apply axiom5. +Omega. +Omega. +Omega. +Save. + + +(****************************************************************************) + +(* program (186) page 939 "showing the usefulness of auxiliary variables" ! *) + +Global Variable N : Z ref. +Global Variable S : Z ref. + +Correctness pgm186 +let rec F (u:unit) : unit { variant N } = + { `N>=0` } + (if !N > 0 then begin + label L; + N := (Zpred !N); + (F tt); + S := (Zs !S); + (F tt); + N := (Zs !N) + end) + { `N=N@` /\ `S=S@+(Zpower 2 N@)-1` }. +Proof. +Unfold Zwf. Unfold Zpred. Omega. +Unfold Zpred. Omega. +Decompose [and] Post5. Rewrite H. Unfold Zwf. Unfold Zpred. Omega. +Decompose [and] Post5. Rewrite H. Unfold Zpred. Omega. +Split. +Unfold Zpred in Post5. Omega. +Decompose [and] Post4. Rewrite H0. +Decompose [and] Post5. Rewrite H2. Rewrite H1. +Replace `(Zpower 2 N0)` with `2*(Zpower 2 (Zpred N0))`. Omega. +Symmetry. +Replace `(Zpower 2 N0)` with `(Zpower 2 (1+(Zpred N0)))`. +Replace `2*(Zpower 2 (Zpred N0))` with `(Zpower 2 1)*(Zpower 2 (Zpred N0))`. +Apply Zpower_exp. +Omega. +Unfold Zpred. Omega. +Auto. +Replace `(1+(Zpred N0))` with N0; [ Auto | Unfold Zpred; Omega ]. +Split. +Auto. +Replace N0 with `0`; Simpl; Omega. +Save. + + +(****************************************************************************) + +(* program (196) page 944 (recursive factorial procedure with value-result + * parameters) + *) + +Correctness pgm196 +let rec F (U:Z) (V:Z ref) : unit { variant U } = + { `U >= 0` } + (if U = 0 then + V := 1 + else begin + (F (Zpred U) V); + V := (Zmult !V U) + end) + { `V = (Zfact U)` }. +Proof. +Symmetry. Rewrite Test1. Apply axiom4. +Unfold Zwf. Unfold Zpred. Omega. +Unfold Zpred. Omega. +Rewrite Post3. +Unfold Zpred. Replace `U0+(-1)` with `U0-1`. Apply axiom5. +Omega. +Omega. +Save. + +(****************************************************************************) + +(* program (197) page 945 (L_4 subset of Pascal) *) + +(* +procedure P(X:Z; procedure Q(Z:Z)); + procedure L(X:Z); begin Q(X-1) end; + begin if X>0 then P(X-1,L) else Q(X) end; + +procedure M(N:Z); + procedure R(X:Z); begin writeln(X) (* => RES := !X *) end; + begin P(N,R) end. +*) diff --git a/contrib/correctness/examples/exp.v b/contrib/correctness/examples/exp.v new file mode 100644 index 00000000..dcfcec87 --- /dev/null +++ b/contrib/correctness/examples/exp.v @@ -0,0 +1,204 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(*i $Id: exp.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ i*) + +(* Efficient computation of X^n using + * + * X^(2n) = (X^n) ^ 2 + * X^(2n+1) = X . (X^n) ^ 2 + * + * Proofs of both fonctional and imperative programs. + *) + +Require Even. +Require Div2. +Require Correctness. +Require ArithRing. +Require ZArithRing. + +(* The specification uses the traditional definition of X^n *) + +Fixpoint power [x,n:nat] : nat := + Cases n of + O => (S O) + | (S n') => (mult x (power x n')) + end. + +Definition square := [n:nat](mult n n). + + +(* Three lemmas are necessary to establish the forthcoming proof obligations *) + +(* n = 2*(n/2) => (x^(n/2))^2 = x^n *) + +Lemma exp_div2_0 : (x,n:nat) + n=(double (div2 n)) + -> (square (power x (div2 n)))=(power x n). +Proof. +Unfold square. +Intros x n. Pattern n. Apply ind_0_1_SS. +Auto. + +Intro. (Absurd (1)=(double (0)); Auto). + +Intros. Simpl. +Cut n0=(double (div2 n0)). +Intro. Rewrite <- (H H1). +Ring. + +Simpl in H0. +Unfold double in H0. +Simpl in H0. +Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0. +(Injection H0; Auto). +Save. + +(* n = 2*(n/2)+1 => x*(x^(n/2))^2 = x^n *) + +Lemma exp_div2_1 : (x,n:nat) + n=(S (double (div2 n))) + -> (mult x (square (power x (div2 n))))=(power x n). +Proof. +Unfold square. +Intros x n. Pattern n. Apply ind_0_1_SS. + +Intro. (Absurd (0)=(S (double (0))); Auto). + +Auto. + +Intros. Simpl. +Cut n0=(S (double (div2 n0))). +Intro. Rewrite <- (H H1). +Ring. + +Simpl in H0. +Unfold double in H0. +Simpl in H0. +Rewrite <- (plus_n_Sm (div2 n0) (div2 n0)) in H0. +(Injection H0; Auto). +Save. + +(* x^(2*n) = (x^2)^n *) + +Lemma power_2n : (x,n:nat)(power x (double n))=(power (square x) n). +Proof. +Unfold double. Unfold square. +Induction n. +Auto. + +Intros. +Simpl. +Rewrite <- H. +Rewrite <- (plus_n_Sm n0 n0). +Simpl. +Auto with arith. +Save. + +Hints Resolve exp_div2_0 exp_div2_1. + + +(* Functional version. + * + * Here we give the functional program as an incomplete CIC term, + * using the tactic Refine. + * + * On this example, it really behaves as the tactic Program. + *) + +(* +Lemma f_exp : (x,n:nat) { y:nat | y=(power x n) }. +Proof. +Refine [x:nat] + (well_founded_induction nat lt lt_wf + [n:nat]{y:nat | y=(power x n) } + [n:nat] + [f:(p:nat)(lt p n)->{y:nat | y=(power x p) }] + Cases (zerop n) of + (left _) => (exist ? ? (S O) ?) + | (right _) => + let (y,H) = (f (div2 n) ?) in + Cases (even_odd_dec n) of + (left _) => (exist ? ? (mult y y) ?) + | (right _) => (exist ? ? (mult x (mult y y)) ?) + end + end). +Proof. +Rewrite a. Auto. +Exact (lt_div2 n a). +Change (square y)=(power x n). Rewrite H. Auto with arith. +Change (mult x (square y))=(power x n). Rewrite H. Auto with arith. +Save. +*) + +(* Imperative version. *) + +Definition even_odd_bool := [x:nat](bool_of_sumbool ? ? (even_odd_dec x)). + +Correctness i_exp + fun (x:nat)(n:nat) -> + let y = ref (S O) in + let m = ref x in + let e = ref n in + begin + while (notzerop_bool !e) do + { invariant (power x n)=(mult y (power m e)) as Inv + variant e for lt } + (if not (even_odd_bool !e) then y := (mult !y !m)) + { (power x n) = (mult y (power m (double (div2 e)))) as Q }; + m := (square !m); + e := (div2 !e) + done; + !y + end + { result=(power x n) } +. +Proof. +Rewrite (odd_double e0 Test1) in Inv. Rewrite Inv. Simpl. Auto with arith. + +Rewrite (even_double e0 Test1) in Inv. Rewrite Inv. Reflexivity. + +Split. +Exact (lt_div2 e0 Test2). + +Rewrite Q. Unfold double. Unfold square. +Simpl. +Change (mult y1 (power m0 (double (div2 e0)))) + = (mult y1 (power (square m0) (div2 e0))). +Rewrite (power_2n m0 (div2 e0)). Reflexivity. + +Auto with arith. + +Decompose [and] Inv. +Rewrite H. Rewrite H0. +Auto with arith. +Save. + + +(* Recursive version. *) + +Correctness r_exp + let rec exp (x:nat) (n:nat) : nat { variant n for lt} = + (if (zerop_bool n) then + (S O) + else + let y = (exp x (div2 n)) in + if (even_odd_bool n) then + (mult y y) + else + (mult x (mult y y)) + ) { result=(power x n) } +. +Proof. +Rewrite Test2. Auto. +Exact (lt_div2 n0 Test2). +Change (square y)=(power x0 n0). Rewrite Post7. Auto with arith. +Change (mult x0 (square y))=(power x0 n0). Rewrite Post7. Auto with arith. +Save. diff --git a/contrib/correctness/examples/exp_int.v b/contrib/correctness/examples/exp_int.v new file mode 100644 index 00000000..accd60c2 --- /dev/null +++ b/contrib/correctness/examples/exp_int.v @@ -0,0 +1,218 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: exp_int.v,v 1.4 2001/04/11 07:56:19 filliatr Exp $ *) + +(* Efficient computation of X^n using + * + * X^(2n) = (X^n) ^ 2 + * X^(2n+1) = X . (X^n) ^ 2 + * + * Proofs of both fonctional and imperative programs. + *) + +Require Zpower. +Require Zcomplements. + +Require Correctness. +Require ZArithRing. +Require Omega. + +Definition Zdouble := [n:Z]`2*n`. + +Definition Zsquare := [n:Z](Zmult n n). + +(* Some auxiliary lemmas about Zdiv2 are necessary *) + +Lemma Zdiv2_ge_0 : (x:Z) `x >= 0` -> `(Zdiv2 x) >= 0`. +Proof. +Destruct x; Auto with zarith. +Destruct p; Auto with zarith. +Simpl. Omega. +Intros. (Absurd `(NEG p) >= 0`; Red; Auto with zarith). +Save. + +Lemma Zdiv2_lt : (x:Z) `x > 0` -> `(Zdiv2 x) < x`. +Proof. +Destruct x. +Intro. Absurd `0 > 0`; [ Omega | Assumption ]. +Destruct p; Auto with zarith. + +Simpl. +Intro p0. +Replace (POS (xI p0)) with `2*(POS p0)+1`. +Omega. +Simpl. Auto with zarith. + +Intro p0. +Simpl. +Replace (POS (xO p0)) with `2*(POS p0)`. +Omega. +Simpl. Auto with zarith. + +Simpl. Omega. + +Intros. +Absurd `(NEG p) > 0`; Red; Auto with zarith. +Elim p; Auto with zarith. +Omega. +Save. + +(* A property of Zpower: x^(2*n) = (x^2)^n *) + +Lemma Zpower_2n : + (x,n:Z)`n >= 0` -> (Zpower x (Zdouble n))=(Zpower (Zsquare x) n). +Proof. +Unfold Zdouble. +Intros x n Hn. +Replace `2*n` with `n+n`. +Rewrite Zpower_exp. +Pattern n. +Apply natlike_ind. + +Simpl. Auto with zarith. + +Intros. +Unfold Zs. +Rewrite Zpower_exp. +Rewrite Zpower_exp. +Replace (Zpower x `1`) with x. +Replace (Zpower (Zsquare x) `1`) with (Zsquare x). +Rewrite <- H0. +Unfold Zsquare. +Ring. + +Unfold Zpower; Unfold Zpower_pos; Simpl. Omega. + +Unfold Zpower; Unfold Zpower_pos; Simpl. Omega. + +Omega. +Omega. +Omega. +Omega. +Omega. +Assumption. +Assumption. +Omega. +Save. + + +(* The program *) + +Correctness i_exp + fun (x:Z)(n:Z) -> + { `n >= 0` } + (let y = ref 1 in + let m = ref x in + let e = ref n in + begin + while !e > 0 do + { invariant (Zpower x n)=(Zmult y (Zpower m e)) /\ `e>=0` as Inv + variant e } + (if not (Zeven_odd_bool !e) then y := (Zmult !y !m)) + { (Zpower x n) = (Zmult y (Zpower m (Zdouble (Zdiv2 e)))) as Q }; + m := (Zsquare !m); + e := (Zdiv2 !e) + done; + !y + end) + { result=(Zpower x n) } +. +Proof. +(* Zodd *) +Decompose [and] Inv. +Rewrite (Zodd_div2 e0 H0 Test1) in H. Rewrite H. +Rewrite Zpower_exp. +Unfold Zdouble. +Replace (Zpower m0 `1`) with m0. +Ring. +Unfold Zpower; Unfold Zpower_pos; Simpl; Ring. +Generalize (Zdiv2_ge_0 e0); Omega. +Omega. +(* Zeven *) +Decompose [and] Inv. +Rewrite (Zeven_div2 e0 Test1) in H. Rewrite H. +Auto with zarith. +Split. +(* Zwf *) +Unfold Zwf. +Repeat Split. +Generalize (Zdiv2_ge_0 e0); Omega. +Omega. +Exact (Zdiv2_lt e0 Test2). +(* invariant *) +Split. +Rewrite Q. Unfold Zdouble. Unfold Zsquare. +Rewrite (Zpower_2n). +Trivial. +Generalize (Zdiv2_ge_0 e0); Omega. +Generalize (Zdiv2_ge_0 e0); Omega. +Split; [ Ring | Assumption ]. +(* exit fo loop *) +Decompose [and] Inv. +Cut `e0 = 0`. Intro. +Rewrite H1. Rewrite H. +Simpl; Ring. +Omega. +Save. + + +(* Recursive version. *) + +Correctness r_exp + let rec exp (x:Z) (n:Z) : Z { variant n } = + { `n >= 0` } + (if n = 0 then + 1 + else + let y = (exp x (Zdiv2 n)) in + (if (Zeven_odd_bool n) then + (Zmult y y) + else + (Zmult x (Zmult y y))) { result=(Zpower x n) as Q } + ) + { result=(Zpower x n) } +. +Proof. +Rewrite Test2. Auto with zarith. +(* w.f. *) +Unfold Zwf. +Repeat Split. +Generalize (Zdiv2_ge_0 n0) ; Omega. +Omega. +Generalize (Zdiv2_lt n0) ; Omega. +(* rec. call *) +Generalize (Zdiv2_ge_0 n0) ; Omega. +(* invariant: case even *) +Generalize (Zeven_div2 n0 Test1). +Intro Heq. Rewrite Heq. +Rewrite Post4. +Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`. +Rewrite Zpower_exp. +Auto with zarith. +Generalize (Zdiv2_ge_0 n0) ; Omega. +Generalize (Zdiv2_ge_0 n0) ; Omega. +Omega. +(* invariant: cas odd *) +Generalize (Zodd_div2 n0 Pre1 Test1). +Intro Heq. Rewrite Heq. +Rewrite Post4. +Rewrite Zpower_exp. +Replace `2*(Zdiv2 n0)` with `(Zdiv2 n0)+(Zdiv2 n0)`. +Rewrite Zpower_exp. +Replace `(Zpower x0 1)` with x0. +Ring. +Unfold Zpower; Unfold Zpower_pos; Simpl. Omega. +Generalize (Zdiv2_ge_0 n0) ; Omega. +Generalize (Zdiv2_ge_0 n0) ; Omega. +Omega. +Generalize (Zdiv2_ge_0 n0) ; Omega. +Omega. +Save. diff --git a/contrib/correctness/examples/extract.v b/contrib/correctness/examples/extract.v new file mode 100644 index 00000000..e225ba18 --- /dev/null +++ b/contrib/correctness/examples/extract.v @@ -0,0 +1,43 @@ + +(* Tests d'extraction *) + +Require ProgramsExtraction. +Save State Ici "test extraction". + +(* exp *) + +Require exp. +Write Caml File "exp" [ i_exp r_exp ]. + +(* exp_int *) + +Restore State Ici. +Require exp_int. +Write Caml File "exp_int" [ i_exp r_exp ]. + +(* fact *) + +Restore State Ici. +Require fact. +Initialize x with (S (S (S O))). +Initialize y with O. +Write Caml File "fact" [ factorielle ]. + +(* fact_int *) + +Restore State Ici. +Require fact_int. +Initialize x with `3`. +Initialize y with `0`. +Write Caml File "fact_int" [ factorielle ]. + +(* Handbook *) + +Restore State Ici. +Require Handbook. +Initialize X with `3`. +Initialize Y with `3`. +Initialize Z with `3`. +Initialize N with `3`. +Initialize S with `3`. +Write Caml File "Handbook" [ pgm178 pgm186 pgm196 ]. diff --git a/contrib/correctness/examples/fact.v b/contrib/correctness/examples/fact.v new file mode 100644 index 00000000..e480c806 --- /dev/null +++ b/contrib/correctness/examples/fact.v @@ -0,0 +1,69 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: fact.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *) + +(* Proof of an imperative program computing the factorial (over type nat) *) + +Require Correctness. +Require Omega. +Require Arith. + +Fixpoint fact [n:nat] : nat := + Cases n of + O => (S O) + | (S p) => (mult n (fact p)) + end. + +(* (x * y) * (x-1)! = y * x! *) + +Lemma fact_rec : (x,y:nat)(lt O x) -> + (mult (mult x y) (fact (pred x))) = (mult y (fact x)). +Proof. +Intros x y H. +Generalize (mult_sym x y). Intro H1. Rewrite H1. +Generalize (mult_assoc_r y x (fact (pred x))). Intro H2. Rewrite H2. +Apply (f_equal nat nat [x:nat](mult y x)). +Generalize H. Elim x; Auto with arith. +Save. + + +(* we declare two variables x and y *) + +Global Variable x : nat ref. +Global Variable y : nat ref. + +(* we give the annotated program *) + +Correctness factorielle + begin + y := (S O); + while (notzerop_bool !x) do + { invariant (mult y (fact x)) = (fact x@0) as I + variant x for lt } + y := (mult !x !y); + x := (pred !x) + done + end + { y = (fact x@0) }. +Proof. +Split. +(* decreasing of the variant *) +Omega. +(* preservation of the invariant *) +Rewrite <- I. Exact (fact_rec x0 y1 Test1). +(* entrance of loop *) +Auto with arith. +(* exit of loop *) +Elim I. Intros H1 H2. +Rewrite H2 in H1. +Rewrite <- H1. +Auto with arith. +Save. diff --git a/contrib/correctness/examples/fact_int.v b/contrib/correctness/examples/fact_int.v new file mode 100644 index 00000000..cb2b0460 --- /dev/null +++ b/contrib/correctness/examples/fact_int.v @@ -0,0 +1,195 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: fact_int.v,v 1.3 2001/04/11 07:56:19 filliatr Exp $ *) + +(* Proof of an imperative program computing the factorial (over type Z) *) + +Require Correctness. +Require Omega. +Require ZArithRing. + +(* We define the factorial as a relation... *) + +Inductive fact : Z -> Z -> Prop := + fact_0 : (fact `0` `1`) + | fact_S : (z,f:Z) (fact z f) -> (fact (Zs z) (Zmult (Zs z) f)). + +(* ...and then we prove that it contains a function *) + +Lemma fact_function : (z:Z) `0 <= z` -> (EX f:Z | (fact z f)). +Proof. +Intros. +Apply natlike_ind with P:=[z:Z](EX f:Z | (fact z f)). +Split with `1`. +Exact fact_0. + +Intros. +Elim H1. +Intros. +Split with `(Zs x)*x0`. +Exact (fact_S x x0 H2). + +Assumption. +Save. + +(* This lemma should belong to the ZArith library *) + +Lemma Z_mult_1 : (x,y:Z)`x>=1`->`y>=1`->`x*y>=1`. +Proof. +Intros. +Generalize H. +Apply natlike_ind with P:=[x:Z]`x >= 1`->`x*y >= 1`. +Omega. + +Intros. +Simpl. +Elim (Z_le_lt_eq_dec `0` x0 H1). +Simpl. +Unfold Zs. +Replace `(x0+1)*y` with `x0*y+y`. +Generalize H2. +Generalize `x0*y`. +Intro. +Intros. +Omega. + +Ring. + +Intros. +Rewrite <- b. +Omega. + +Omega. +Save. + +(* (fact x f) implies x>=0 and f>=1 *) + +Lemma fact_pos : (x,f:Z)(fact x f)-> `x>=0` /\ `f>=1`. +Proof. +Intros. +(Elim H; Auto). +Omega. + +Intros. +(Split; Try Omega). +(Apply Z_mult_1; Try Omega). +Save. + +(* (fact 0 x) implies x=1 *) + +Lemma fact_0_1 : (x:Z)(fact `0` x) -> `x=1`. +Proof. +Intros. +Inversion H. +Reflexivity. + +Elim (fact_pos z f H1). +Intros. +(Absurd `z >= 0`; Omega). +Save. + + +(* We define the loop invariant : y * x! = x0! *) + +Inductive invariant [y,x,x0:Z] : Prop := + c_inv : (f,f0:Z)(fact x f)->(fact x0 f0)->(Zmult y f)=f0 + -> (invariant y x x0). + +(* The following lemma is used to prove the preservation of the invariant *) + +Lemma fact_rec : (x0,x,y:Z)`0 < x` -> + (invariant y x x0) + -> (invariant `x*y` (Zpred x) x0). +Proof. +Intros x0 x y H H0. +Elim H0. +Intros. +Generalize H H0 H3. +Elim H1. +Intros. +Absurd `0 < 0`; Omega. + +Intros. +Apply c_inv with f:=f1 f0:=f0. +Cut `z+1+-1 = z`. Intro eq_z. Rewrite <- eq_z in H4. +Assumption. + +Omega. + +Assumption. + +Rewrite (Zmult_sym (Zs z) y). +Rewrite (Zmult_assoc_r y (Zs z) f1). +Auto. +Save. + + +(* This one is used to prove the proof obligation at the exit of the loop *) + +Lemma invariant_0 : (x,y:Z)(invariant y `0` x)->(fact x y). +Proof. +Intros. +Elim H. +Intros. +Generalize (fact_0_1 f H0). +Intro. +Rewrite H3 in H2. +Simpl in H2. +Replace y with `y*1`. +Rewrite H2. +Assumption. + +Omega. +Save. + + +(* At last we come to the proof itself *************************************) + +(* we declare two variable x and y *) + +Global Variable x : Z ref. +Global Variable y : Z ref. + +(* and we give the annotated program *) + +Correctness factorielle + { `0 <= x` } + begin + y := 1; + while !x <> 0 do + { invariant `0 <= x` /\ (invariant y x x@0) as Inv + variant x for (Zwf ZERO) } + y := (Zmult !x !y); + x := (Zpred !x) + done + end + { (fact x@0 y) }. +Proof. +Split. +(* decreasing *) +Unfold Zwf. Unfold Zpred. Omega. +(* preservation of the invariant *) +Split. + Unfold Zpred; Omega. + Cut `0 < x0`. Intro Hx0. + Decompose [and] Inv. + Exact (fact_rec x x0 y1 Hx0 H0). + Omega. +(* entrance of the loop *) +Split; Auto. +Elim (fact_function x Pre1). Intros. +Apply c_inv with f:=x0 f0:=x0; Auto. +Omega. +(* exit of the loop *) +Decompose [and] Inv. +Rewrite H0 in H2. +Exact (invariant_0 x y1 H2). +Save. diff --git a/contrib/correctness/past.mli b/contrib/correctness/past.mli new file mode 100644 index 00000000..1cc7164e --- /dev/null +++ b/contrib/correctness/past.mli @@ -0,0 +1,97 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: past.mli,v 1.7.6.1 2004/07/16 19:30:00 herbelin Exp $ *) + +(*s Abstract syntax of imperative programs. *) + +open Names +open Ptype +open Topconstr + +type termination = + | RecArg of int + | Wf of constr_expr * constr_expr + +type variable = identifier + +type pattern = + | PatVar of identifier + | PatConstruct of identifier * ((kernel_name * int) * int) + | PatAlias of pattern * identifier + | PatPair of pattern * pattern + | PatApp of pattern list + +type epattern = + | ExnConstant of identifier + | ExnBind of identifier * identifier + +type ('a, 'b) block_st = + | Label of string + | Assert of 'b Ptype.assertion + | Statement of 'a + +type ('a, 'b) block = ('a, 'b) block_st list + +type ('a, 'b) t = { + desc : ('a, 'b) t_desc; + pre : 'b Ptype.precondition list; + post : 'b Ptype.postcondition option; + loc : Util.loc; + info : 'a +} + +and ('a, 'b) t_desc = + | Variable of variable + | Acc of variable + | Aff of variable * ('a, 'b) t + | TabAcc of bool * variable * ('a, 'b) t + | TabAff of bool * variable * ('a, 'b) t * ('a, 'b) t + | Seq of (('a, 'b) t, 'b) block + | While of ('a, 'b) t * 'b Ptype.assertion option * ('b * 'b) * + (('a, 'b) t, 'b) block + | If of ('a, 'b) t * ('a, 'b) t * ('a, 'b) t + | Lam of 'b Ptype.ml_type_v Ptype.binder list * ('a, 'b) t + | Apply of ('a, 'b) t * ('a, 'b) arg list + | SApp of ('a, 'b) t_desc list * ('a, 'b) t list + | LetRef of variable * ('a, 'b) t * ('a, 'b) t + | Let of variable * ('a, 'b) t * ('a, 'b) t + | LetRec of variable * 'b Ptype.ml_type_v Ptype.binder list * + 'b Ptype.ml_type_v * ('b * 'b) * ('a, 'b) t + | PPoint of string * ('a, 'b) t_desc + | Expression of Term.constr + | Debug of string * ('a, 'b) t + +and ('a, 'b) arg = + | Term of ('a, 'b) t + | Refarg of variable + | Type of 'b Ptype.ml_type_v + +type program = (unit, Topconstr.constr_expr) t + +(*s Intermediate type for CC terms. *) + +type cc_type = Term.constr + +type cc_bind_type = + | CC_typed_binder of cc_type + | CC_untyped_binder + +type cc_binder = variable * cc_bind_type + +type cc_term = + | CC_var of variable + | CC_letin of bool * cc_type * cc_binder list * cc_term * cc_term + | CC_lam of cc_binder list * cc_term + | CC_app of cc_term * cc_term list + | CC_tuple of bool * cc_type list * cc_term list + | CC_case of cc_type * cc_term * cc_term list + | CC_expr of Term.constr + | CC_hole of cc_type diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml new file mode 100644 index 00000000..e87ba70c --- /dev/null +++ b/contrib/correctness/pcic.ml @@ -0,0 +1,231 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pcic.ml,v 1.23.2.1 2004/07/16 19:30:00 herbelin Exp $ *) + +open Util +open Names +open Nameops +open Libnames +open Term +open Termops +open Nametab +open Declarations +open Indtypes +open Sign +open Rawterm +open Typeops +open Entries +open Topconstr + +open Pmisc +open Past + + +(* Here we translate intermediates terms (cc_term) into CCI terms (constr) *) + +let make_hole c = mkCast (isevar, c) + +(* Tuples are defined in file Tuples.v + * and their constructors are called Build_tuple_n or exists_n, + * wether they are dependant (last element only) or not. + * If necessary, tuples are generated ``on the fly''. *) + +let tuple_exists id = + try let _ = Nametab.locate (make_short_qualid id) in true + with Not_found -> false + +let ast_set = CSort (dummy_loc,RProp Pos) + +let tuple_n n = + let id = make_ident "tuple_" (Some n) in + let l1n = Util.interval 1 n in + let params = + List.map (fun i -> + (LocalRawAssum ([dummy_loc,Name (make_ident "T" (Some i))], ast_set))) + l1n in + let fields = + List.map + (fun i -> + let id = make_ident ("proj_" ^ string_of_int n ^ "_") (Some i) in + let id' = make_ident "T" (Some i) in + (false, Vernacexpr.AssumExpr ((dummy_loc,Name id), mkIdentC id'))) + l1n + in + let cons = make_ident "Build_tuple_" (Some n) in + Record.definition_structure + ((false, (dummy_loc,id)), params, fields, cons, mk_Set) + +(*s [(sig_n n)] generates the inductive + \begin{verbatim} + Inductive sig_n [T1,...,Tn:Set; P:T1->...->Tn->Prop] : Set := + exist_n : (x1:T1)...(xn:Tn)(P x1 ... xn) -> (sig_n T1 ... Tn P). + \end{verbatim} *) + +let sig_n n = + let id = make_ident "sig_" (Some n) in + let l1n = Util.interval 1 n in + let lT = List.map (fun i -> make_ident "T" (Some i)) l1n in + let lx = List.map (fun i -> make_ident "x" (Some i)) l1n in + let idp = make_ident "P" None in + let params = + let typ = List.fold_right (fun _ c -> mkArrow (mkRel n) c) lT mkProp in + (idp, LocalAssum typ) :: + (List.rev_map (fun id -> (id, LocalAssum mkSet)) lT) + in + let lc = + let app_sig = mkApp(mkRel (2*n+3), + Array.init (n+1) (fun i -> mkRel (2*n+2-i))) in + let app_p = mkApp(mkRel (n+1), + Array.init n (fun i -> mkRel (n-i))) in + let c = mkArrow app_p app_sig in + List.fold_right (fun id c -> mkProd (Name id, mkRel (n+1), c)) lx c + in + let cname = make_ident "exist_" (Some n) in + Declare.declare_mind + { mind_entry_finite = true; + mind_entry_inds = + [ { mind_entry_params = params; + mind_entry_typename = id; + mind_entry_arity = mkSet; + mind_entry_consnames = [ cname ]; + mind_entry_lc = [ lc ] } ] } + +(*s On the fly generation of needed (possibly dependent) tuples. *) + +let check_product_n n = + if n > 2 then + let s = Printf.sprintf "tuple_%d" n in + if not (tuple_exists (id_of_string s)) then tuple_n n + +let check_dep_product_n n = + if n > 1 then + let s = Printf.sprintf "sig_%d" n in + if not (tuple_exists (id_of_string s)) then ignore (sig_n n) + +(*s Constructors for the tuples. *) + +let pair = ConstructRef ((coq_constant ["Init"; "Datatypes"] "prod",0),1) +let exist = ConstructRef ((coq_constant ["Init"; "Specif"] "sig",0),1) + +let tuple_ref dep n = + if n = 2 & not dep then + pair + else + let n = n - (if dep then 1 else 0) in + if dep then + if n = 1 then + exist + else begin + let id = make_ident "exist_" (Some n) in + if not (tuple_exists id) then ignore (sig_n n); + Nametab.locate (make_short_qualid id) + end + else begin + let id = make_ident "Build_tuple_" (Some n) in + if not (tuple_exists id) then tuple_n n; + Nametab.locate (make_short_qualid id) + end + +(* Binders. *) + +let trad_binder avoid nenv id = function + | CC_untyped_binder -> RHole (dummy_loc,BinderType (Name id)) + | CC_typed_binder ty -> Detyping.detype (false,Global.env()) avoid nenv ty + +let rec push_vars avoid nenv = function + | [] -> ([],avoid,nenv) + | (id,b) :: bl -> + let b' = trad_binder avoid nenv id b in + let bl',avoid',nenv' = + push_vars (id :: avoid) (add_name (Name id) nenv) bl + in + ((id,b') :: bl', avoid', nenv') + +let rec raw_lambda bl v = match bl with + | [] -> + v + | (id,ty) :: bl' -> + RLambda (dummy_loc, Name id, ty, raw_lambda bl' v) + +(* The translation itself is quite easy. + letin are translated into Cases constructions *) + +let rawconstr_of_prog p = + let rec trad avoid nenv = function + | CC_var id -> + RVar (dummy_loc, id) + + (*i optimisation : let x = <constr> in e2 => e2[x<-constr] + | CC_letin (_,_,[id,_],CC_expr c,e2) -> + real_subst_in_constr [id,c] (trad e2) + | CC_letin (_,_,([_] as b),CC_expr e1,e2) -> + let (b',avoid',nenv') = push_vars avoid nenv b in + let c1 = Detyping.detype avoid nenv e1 + and c2 = trad avoid' nenv' e2 in + let id = Name (fst (List.hd b')) in + RLetIn (dummy_loc, id, c1, c2) + i*) + + | CC_letin (_,_,([_] as b),e1,e2) -> + let (b',avoid',nenv') = push_vars avoid nenv b in + let c1 = trad avoid nenv e1 + and c2 = trad avoid' nenv' e2 in + RApp (dummy_loc, raw_lambda b' c2, [c1]) + + | CC_letin (dep,ty,bl,e1,e2) -> + let (bl',avoid',nenv') = push_vars avoid nenv bl in + let c1 = trad avoid nenv e1 + and c2 = trad avoid' nenv' e2 in + ROrderedCase (dummy_loc, LetStyle, None, c1, [| raw_lambda bl' c2 |], ref None) + + | CC_lam (bl,e) -> + let bl',avoid',nenv' = push_vars avoid nenv bl in + let c = trad avoid' nenv' e in + raw_lambda bl' c + + | CC_app (f,args) -> + let c = trad avoid nenv f + and cargs = List.map (trad avoid nenv) args in + RApp (dummy_loc, c, cargs) + + | CC_tuple (_,_,[e]) -> + trad avoid nenv e + + | CC_tuple (false,_,[e1;e2]) -> + let c1 = trad avoid nenv e1 + and c2 = trad avoid nenv e2 in + RApp (dummy_loc, RRef (dummy_loc,pair), + [RHole (dummy_loc,ImplicitArg (pair,1)); + RHole (dummy_loc,ImplicitArg (pair,2));c1;c2]) + + | CC_tuple (dep,tyl,l) -> + let n = List.length l in + let cl = List.map (trad avoid nenv) l in + let tuple = tuple_ref dep n in + let tyl = List.map (Detyping.detype (false,Global.env()) avoid nenv) tyl in + let args = tyl @ cl in + RApp (dummy_loc, RRef (dummy_loc, tuple), args) + + | CC_case (ty,b,el) -> + let c = trad avoid nenv b in + let cl = List.map (trad avoid nenv) el in + let ty = Detyping.detype (false,Global.env()) avoid nenv ty in + ROrderedCase (dummy_loc, RegularStyle, Some ty, c, Array.of_list cl, ref None) + + | CC_expr c -> + Detyping.detype (false,Global.env()) avoid nenv c + + | CC_hole c -> + RCast (dummy_loc, RHole (dummy_loc, QuestionMark), + Detyping.detype (false,Global.env()) avoid nenv c) + + in + trad [] empty_names_context p diff --git a/contrib/correctness/pcic.mli b/contrib/correctness/pcic.mli new file mode 100644 index 00000000..89731472 --- /dev/null +++ b/contrib/correctness/pcic.mli @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* 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*) + +open Past +open Rawterm + +(* On-the-fly generation of needed (possibly dependent) tuples. *) + +val check_product_n : int -> unit +val check_dep_product_n : int -> unit + +(* transforms intermediate functional programs into (raw) CIC terms *) + +val rawconstr_of_prog : cc_term -> rawconstr + diff --git a/contrib/correctness/pcicenv.ml b/contrib/correctness/pcicenv.ml new file mode 100644 index 00000000..cc15c8f3 --- /dev/null +++ b/contrib/correctness/pcicenv.ml @@ -0,0 +1,118 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pcicenv.ml,v 1.5.14.1 2004/07/16 19:30:00 herbelin Exp $ *) + +open Names +open Term +open Sign + +open Pmisc +open Putil +open Ptype +open Past + +(* on redéfinit add_sign pour éviter de construire des environnements + * avec des doublons (qui font planter la résolution des implicites !) *) + +(* VERY UGLY!! find some work around *) +let modify_sign id t s = + fold_named_context + (fun ((x,b,ty) as d) sign -> + if x=id then add_named_decl (x,b,t) sign else add_named_decl d sign) + s ~init:empty_named_context + +let add_sign (id,t) s = + try + let _ = lookup_named id s in + modify_sign id t s + with Not_found -> + add_named_decl (id,None,t) s + +let cast_set c = mkCast (c, mkSet) + +let set = mkCast (mkSet, mkType Univ.prop_univ) + +(* [cci_sign_of env] construit un environnement pour CIC ne comprenant que + * les objets fonctionnels de l'environnement de programes [env] + *) + +let cci_sign_of ren env = + Penv.fold_all + (fun (id,v) sign -> + match v with + | Penv.TypeV (Ref _ | Array _) -> sign + | Penv.TypeV v -> + let ty = Pmonad.trad_ml_type_v ren env v in + add_sign (id,cast_set ty) sign + | Penv.Set -> add_sign (id,set) sign) + env (Global.named_context ()) + +(* [sign_meta ren env fadd ini] + * construit un environnement pour CIC qui prend en compte les variables + * de programme. + * pour cela, cette fonction parcours tout l'envrionnement (global puis + * local [env]) et pour chaque déclaration, ajoute ce qu'il faut avec la + * fonction [fadd] s'il s'agit d'un mutable et directement sinon, + * en partant de [ini]. + *) + +let sign_meta ren env fast ini = + Penv.fold_all + (fun (id,v) sign -> + match v with + | Penv.TypeV (Ref _ | Array _ as v) -> + let ty = Pmonad.trad_imp_type ren env v in + fast sign id ty + | Penv.TypeV v -> + let ty = Pmonad.trad_ml_type_v ren env v in + add_sign (id,cast_set ty) sign + | Penv.Set -> add_sign (id,set) sign) + env ini + +let add_sign_d dates (id,c) sign = + let sign = + List.fold_left (fun sign d -> add_sign (at_id id d,c) sign) sign dates + in + add_sign (id,c) sign + +let sign_of add ren env = + sign_meta ren env + (fun sign id c -> let c = cast_set c in add (id,c) sign) + (Global.named_context ()) + +let result_of sign = function + None -> sign + | Some (id,c) -> add_sign (id, cast_set c) sign + +let before_after_result_sign_of res ren env = + let dates = "" :: Prename.all_dates ren in + result_of (sign_of (add_sign_d dates) ren env) res + +let before_after_sign_of ren = + let dates = "" :: Prename.all_dates ren in + sign_of (add_sign_d dates) ren + +let before_sign_of ren = + let dates = Prename.all_dates ren in + sign_of (add_sign_d dates) ren + +let now_sign_of = + sign_of (add_sign_d []) + + +(* environnement après traduction *) + +let trad_sign_of ren = + sign_of + (fun (id,c) sign -> add_sign (Prename.current_var ren id,c) sign) + ren + + diff --git a/contrib/correctness/pcicenv.mli b/contrib/correctness/pcicenv.mli new file mode 100644 index 00000000..fc4fa0b9 --- /dev/null +++ b/contrib/correctness/pcicenv.mli @@ -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 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pcicenv.mli,v 1.2.16.1 2004/07/16 19:30:00 herbelin Exp $ *) + +open Penv +open Names +open Term +open Sign + +(* Translation of local programs environments into Coq signatures. + * It is mainly used to type the pre/post conditions in the good + * environment *) + +(* cci_sign_of: uniquement les objets purement fonctionnels de l'env. *) +val cci_sign_of : Prename.t -> local_env -> named_context + +(* env. Coq avec seulement les variables X de l'env. *) +val now_sign_of : Prename.t -> local_env -> named_context + +(* + les variables X@d pour toutes les dates de l'env. *) +val before_sign_of : Prename.t -> local_env -> named_context + +(* + les variables `avant' X@ *) +val before_after_sign_of : Prename.t -> local_env -> named_context +val before_after_result_sign_of : ((identifier * constr) option) + -> Prename.t -> local_env -> named_context + +(* env. des programmes traduits, avec les variables rennomées *) +val trad_sign_of : Prename.t -> local_env -> named_context + diff --git a/contrib/correctness/pdb.ml b/contrib/correctness/pdb.ml new file mode 100644 index 00000000..302db871 --- /dev/null +++ b/contrib/correctness/pdb.ml @@ -0,0 +1,165 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pdb.ml,v 1.8.2.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Names +open Term +open Termops +open Nametab +open Constrintern + +open Ptype +open Past +open Penv + +let cci_global id = + try + global_reference id + with + _ -> raise Not_found + +let lookup_var ids locop id = + if List.mem id ids then + None + else begin + try Some (cci_global id) + with Not_found -> Perror.unbound_variable id locop + end + +let check_ref idl loc id = + if (not (List.mem id idl)) & (not (Penv.is_global id)) then + Perror.unbound_reference id loc + +(* db types : only check the references for the moment *) + +let rec check_type_v refs = function + | Ref v -> + check_type_v refs v + | Array (c,v) -> + check_type_v refs v + | Arrow (bl,c) -> + check_binder refs c bl + | TypePure _ -> + () + +and check_type_c refs ((_,v),e,_,_) = + check_type_v refs v; + List.iter (check_ref refs None) (Peffect.get_reads e); + List.iter (check_ref refs None) (Peffect.get_writes e) + (* TODO: check_condition on p and q *) + +and check_binder refs c = function + | [] -> + check_type_c refs c + | (id, BindType (Ref _ | Array _ as v)) :: bl -> + check_type_v refs v; + check_binder (id :: refs) c bl + | (_, BindType v) :: bl -> + check_type_v refs v; + check_binder refs c bl + | _ :: bl -> + check_binder refs c bl + +(* db binders *) + +let rec db_binders ((tids,pids,refs) as idl) = function + | [] -> + idl, [] + | (id, BindType (Ref _ | Array _ as v)) as b :: rem -> + check_type_v refs v; + let idl',rem' = db_binders (tids,pids,id::refs) rem in + idl', b :: rem' + | (id, BindType v) as b :: rem -> + check_type_v refs v; + let idl',rem' = db_binders (tids,id::pids,refs) rem in + idl', b :: rem' + | ((id, BindSet) as t) :: rem -> + let idl',rem' = db_binders (id::tids,pids,refs) rem in + idl', t :: rem' + | a :: rem -> + let idl',rem' = db_binders idl rem in idl', a :: rem' + + +(* db programs *) + +let db_prog e = + (* tids = type identifiers, ids = variables, refs = references and arrays *) + let rec db_desc ((tids,ids,refs) as idl) = function + | (Variable x) as t -> + (match lookup_var ids (Some e.loc) x with + None -> t + | Some c -> Expression c) + | (Acc x) as t -> + check_ref refs (Some e.loc) x; + t + | Aff (x,e1) -> + check_ref refs (Some e.loc) x; + Aff (x, db idl e1) + | TabAcc (b,x,e1) -> + check_ref refs (Some e.loc) x; + TabAcc(b,x,db idl e1) + | TabAff (b,x,e1,e2) -> + check_ref refs (Some e.loc) x; + TabAff (b,x, db idl e1, db idl e2) + | Seq bl -> + Seq (List.map (function + Statement p -> Statement (db idl p) + | x -> x) bl) + | If (e1,e2,e3) -> + If (db idl e1, db idl e2, db idl e3) + | While (b,inv,var,bl) -> + let bl' = List.map (function + Statement p -> Statement (db idl p) + | x -> x) bl in + While (db idl b, inv, var, bl') + + | Lam (bl,e) -> + let idl',bl' = db_binders idl bl in Lam(bl', db idl' e) + | Apply (e1,l) -> + Apply (db idl e1, List.map (db_arg idl) l) + | SApp (dl,l) -> + SApp (dl, List.map (db idl) l) + | LetRef (x,e1,e2) -> + LetRef (x, db idl e1, db (tids,ids,x::refs) e2) + | Let (x,e1,e2) -> + Let (x, db idl e1, db (tids,x::ids,refs) e2) + + | LetRec (f,bl,v,var,e) -> + let (tids',ids',refs'),bl' = db_binders idl bl in + check_type_v refs' v; + LetRec (f, bl, v, var, db (tids',f::ids',refs') e) + + | Debug (s,e1) -> + Debug (s, db idl e1) + + | Expression _ as x -> x + | PPoint (s,d) -> PPoint (s, db_desc idl d) + + and db_arg ((tids,_,refs) as idl) = function + | Term ({ desc = Variable id } as t) -> + if List.mem id refs then Refarg id else Term (db idl t) + | Term t -> Term (db idl t) + | Type v as ty -> check_type_v refs v; ty + | Refarg _ -> assert false + + and db idl e = + { desc = db_desc idl e.desc ; + pre = e.pre; post = e.post; + loc = e.loc; info = e.info } + + in + let ids = Termops.ids_of_named_context (Global.named_context ()) in + (* TODO: separer X:Set et x:V:Set + virer le reste (axiomes, etc.) *) + let vars,refs = all_vars (), all_refs () in + db ([],vars@ids,refs) e +;; + diff --git a/contrib/correctness/pdb.mli b/contrib/correctness/pdb.mli new file mode 100644 index 00000000..a0df29bd --- /dev/null +++ b/contrib/correctness/pdb.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pdb.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Ptype +open Past + + +(* Here we separate local and global variables, we check the use of + * references and arrays w.r.t the local and global environments, etc. + * These functions directly raise UserError exceptions on bad programs. + *) + +val check_type_v : Names.identifier list -> 'a ml_type_v -> unit + +val db_prog : program -> program + diff --git a/contrib/correctness/peffect.ml b/contrib/correctness/peffect.ml new file mode 100644 index 00000000..08d6b002 --- /dev/null +++ b/contrib/correctness/peffect.ml @@ -0,0 +1,159 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: peffect.ml,v 1.3.14.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Names +open Nameops +open Pmisc + +(* The type of effects. + * + * An effect is composed of two lists (r,w) of variables. + * The first one is the list of read-only variables + * and the second one is the list of read-write variables. + * + * INVARIANT: 1. each list is sorted in decreasing order for Pervasives.compare + * 2. there are no duplicate elements in each list + * 3. the two lists are disjoint + *) + +type t = identifier list * identifier list + + +(* the empty effect *) + +let bottom = ([], []) + +(* basic operations *) + +let push x l = + let rec push_rec = function + [] -> [x] + | (y::rem) as l -> + if x = y then l else if x > y then x::l else y :: push_rec rem + in + push_rec l + +let basic_remove x l = + let rec rem_rec = function + [] -> [] + | y::l -> if x = y then l else y :: rem_rec l + in + rem_rec l + +let mem x (r,w) = (List.mem x r) or (List.mem x w) + +let rec basic_union = function + [], s2 -> s2 + | s1, [] -> s1 + | ((v1::l1) as s1), ((v2::l2) as s2) -> + if v1 > v2 then + v1 :: basic_union (l1,s2) + else if v1 < v2 then + v2 :: basic_union (s1,l2) + else + v1 :: basic_union (l1,l2) + +(* adds reads and writes variables *) + +let add_read id ((r,w) as e) = + (* if the variable is already a RW it is ok, otherwise adds it as a RO. *) + if List.mem id w then + e + else + push id r, w + +let add_write id (r,w) = + (* if the variable is a RO then removes it from RO. Adds it to RW. *) + if List.mem id r then + basic_remove id r, push id w + else + r, push id w + +(* access *) + +let get_reads = basic_union +let get_writes = snd +let get_repr e = (get_reads e, get_writes e) + +(* tests *) + +let is_read (r,_) id = List.mem id r +let is_write (_,w) id = List.mem id w + +(* union and disjunction *) + +let union (r1,w1) (r2,w2) = basic_union (r1,r2), basic_union (w1,w2) + +let rec diff = function + [], s2 -> [] + | s1, [] -> s1 + | ((v1::l1) as s1), ((v2::l2) as s2) -> + if v1 > v2 then + v1 :: diff (l1,s2) + else if v1 < v2 then + diff (s1,l2) + else + diff (l1,l2) + +let disj (r1,w1) (r2,w2) = + let w1_w2 = diff (w1,w2) and w2_w1 = diff (w2,w1) in + let r = basic_union (basic_union (r1,r2), basic_union (w1_w2,w2_w1)) + and w = basic_union (w1,w2) in + r,w + +(* comparison relation *) + +let le e1 e2 = failwith "effects: le: not yet implemented" + +let inf e1 e2 = failwith "effects: inf: not yet implemented" + +(* composition *) + +let compose (r1,w1) (r2,w2) = + let r = basic_union (r1, diff (r2,w1)) in + let w = basic_union (w1,w2) in + r,w + +(* remove *) + +let remove (r,w) name = basic_remove name r, basic_remove name w + +(* substitution *) + +let subst_list (x,x') l = + if List.mem x l then push x' (basic_remove x l) else l + +let subst_one (r,w) s = subst_list s r, subst_list s w + +let subst s e = List.fold_left subst_one e s + +(* pretty-print *) + +open Pp +open Util +open Himsg + +let pp (r,w) = + hov 0 (if r<>[] then + (str"reads " ++ + prlist_with_sep (fun () -> (str"," ++ spc ())) pr_id r) + else (mt ()) ++ + spc () ++ + if w<>[] then + (str"writes " ++ + prlist_with_sep (fun ()-> (str"," ++ spc ())) pr_id w) + else (mt ()) +) + +let ppr e = + Pp.pp (pp e) + diff --git a/contrib/correctness/peffect.mli b/contrib/correctness/peffect.mli new file mode 100644 index 00000000..d6d0ce22 --- /dev/null +++ b/contrib/correctness/peffect.mli @@ -0,0 +1,42 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: peffect.mli,v 1.1.16.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Names + +(* The abstract type of effects *) + +type t + +val bottom : t +val add_read : identifier -> t -> t +val add_write : identifier -> t -> t + +val get_reads : t -> identifier list +val get_writes : t -> identifier list +val get_repr : t -> (identifier list) * (identifier list) + +val is_read : t -> identifier -> bool (* read-only *) +val is_write : t -> identifier -> bool (* read-write *) + +val compose : t -> t -> t + +val union : t -> t -> t +val disj : t -> t -> t + +val remove : t -> identifier -> t + +val subst : (identifier * identifier) list -> t -> t + + +val pp : t -> Pp.std_ppcmds +val ppr : t -> unit + diff --git a/contrib/correctness/penv.ml b/contrib/correctness/penv.ml new file mode 100644 index 00000000..820d1cf0 --- /dev/null +++ b/contrib/correctness/penv.ml @@ -0,0 +1,240 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: penv.ml,v 1.10.2.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Pmisc +open Past +open Ptype +open Names +open Nameops +open Libobject +open Library +open Term + +(* Environments for imperative programs. + * + * An environment of programs is an association tables + * from identifiers (Names.identifier) to types of values with effects + * (ProgAst.ml_type_v), together with a list of these associations, since + * the order is relevant (we have dependent types e.g. [x:nat; t:(array x T)]) + *) + +module Env = struct + type 'a t = ('a Idmap.t) + * ((identifier * 'a) list) + * ((identifier * (identifier * variant)) list) + let empty = Idmap.empty, [], [] + let add id v (m,l,r) = (Idmap.add id v m, (id,v)::l, r) + let find id (m,_,_) = Idmap.find id m + let fold f (_,l,_) x0 = List.fold_right f l x0 + let add_rec (id,var) (m,l,r) = (m,l,(id,var)::r) + let find_rec id (_,_,r) = List.assoc id r +end + +(* Local environments *) + +type type_info = Set | TypeV of type_v + +type local_env = type_info Env.t + +let empty = (Env.empty : local_env) + +let add (id,v) = Env.add id (TypeV v) + +let add_set id = Env.add id Set + +let find id env = + match Env.find id env with TypeV v -> v | Set -> raise Not_found + +let is_local env id = + try + match Env.find id env with TypeV _ -> true | Set -> false + with + Not_found -> false + +let is_local_set env id = + try + match Env.find id env with TypeV _ -> false | Set -> true + with + Not_found -> false + + +(* typed programs *) + +type typing_info = { + env : local_env; + kappa : constr ml_type_c +} + +type typed_program = (typing_info, constr) t + + +(* The global environment. + * + * We have a global typing environment env + * We also keep a table of programs for extraction purposes + * and a table of initializations (still for extraction) + *) + +let (env : type_info Env.t ref) = ref Env.empty + +let (pgm_table : (typed_program option) Idmap.t ref) = ref Idmap.empty + +let (init_table : constr Idmap.t ref) = ref Idmap.empty + +let freeze () = (!env, !pgm_table, !init_table) +let unfreeze (e,p,i) = env := e; pgm_table := p; init_table := i +let init () = + env := Env.empty; pgm_table := Idmap.empty; init_table := Idmap.empty +;; + +Summary.declare_summary "programs-environment" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init; + Summary.survive_module = false; + Summary.survive_section = false } +;; + +(* Operations on the global environment. *) + +let add_pgm id p = pgm_table := Idmap.add id p !pgm_table + +let cache_global (_,(id,v,p)) = + env := Env.add id v !env; add_pgm id p + +let type_info_app f = function Set -> Set | TypeV v -> TypeV (f v) + +let subst_global (_,s,(id,v,p)) = (id, type_info_app (type_v_knsubst s) v, p) + +let (inProg,outProg) = + declare_object { object_name = "programs-objects"; + cache_function = cache_global; + load_function = (fun _ -> cache_global); + open_function = (fun _ _ -> ()); + classify_function = (fun (_,x) -> Substitute x); + subst_function = subst_global; + export_function = (fun x -> Some x) } + +let is_mutable = function Ref _ | Array _ -> true | _ -> false + +let add_global id v p = + try + let _ = Env.find id !env in + Perror.clash id None + with + Not_found -> begin + let id' = + if is_mutable v then id + else id_of_string ("prog_" ^ (string_of_id id)) + in + Lib.add_leaf id' (inProg (id,TypeV v,p)) + end + +let add_global_set id = + try + let _ = Env.find id !env in + Perror.clash id None + with + Not_found -> Lib.add_leaf id (inProg (id,Set,None)) + +let is_global id = + try + match Env.find id !env with TypeV _ -> true | Set -> false + with + Not_found -> false + +let is_global_set id = + try + match Env.find id !env with TypeV _ -> false | Set -> true + with + Not_found -> false + + +let lookup_global id = + match Env.find id !env with TypeV v -> v | Set -> raise Not_found + +let find_pgm id = Idmap.find id !pgm_table + +let all_vars () = + Env.fold + (fun (id,v) l -> match v with TypeV (Arrow _|TypePure _) -> id::l | _ -> l) + !env [] + +let all_refs () = + Env.fold + (fun (id,v) l -> match v with TypeV (Ref _ | Array _) -> id::l | _ -> l) + !env [] + +(* initializations *) + +let cache_init (_,(id,c)) = + init_table := Idmap.add id c !init_table + +let subst_init (_,s,(id,c)) = (id, subst_mps s c) + +let (inInit,outInit) = + declare_object { object_name = "programs-objects-init"; + cache_function = cache_init; + load_function = (fun _ -> cache_init); + open_function = (fun _ _-> ()); + classify_function = (fun (_,x) -> Substitute x); + subst_function = subst_init; + export_function = (fun x -> Some x) } + +let initialize id c = Lib.add_anonymous_leaf (inInit (id,c)) + +let find_init id = Idmap.find id !init_table + + +(* access in env, local then global *) + +let type_in_env env id = + try find id env with Not_found -> lookup_global id + +let is_in_env env id = + (is_global id) or (is_local env id) + +let fold_all f lenv x0 = + let x1 = Env.fold f !env x0 in + Env.fold f lenv x1 + + +(* recursions *) + +let add_recursion = Env.add_rec + +let find_recursion = Env.find_rec + + +(* We also maintain a table of the currently edited proofs of programs + * in order to add them in the environnement when the user does Save *) + +open Pp +open Himsg + +let (edited : (type_v * typed_program) Idmap.t ref) = ref Idmap.empty + +let new_edited id v = + edited := Idmap.add id v !edited + +let is_edited id = + try let _ = Idmap.find id !edited in true with Not_found -> false + +let register id id' = + try + let (v,p) = Idmap.find id !edited in + let _ = add_global id' v (Some p) in + Options.if_verbose + msgnl (hov 0 (str"Program " ++ pr_id id' ++ spc () ++ str"is defined")); + edited := Idmap.remove id !edited + with Not_found -> () + diff --git a/contrib/correctness/penv.mli b/contrib/correctness/penv.mli new file mode 100644 index 00000000..ef2e4c6e --- /dev/null +++ b/contrib/correctness/penv.mli @@ -0,0 +1,87 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: penv.mli,v 1.3.8.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Ptype +open Past +open Names +open Libnames +open Term + +(* Environment for imperative programs. + * + * Here we manage the global environment, which is imperative, + * and we provide a functional local environment. + * + * The most important functions, is_in_env, type_in_env and fold_all + * first look in the local environment then in the global one. + *) + +(* local environments *) + +type local_env + +val empty : local_env +val add : (identifier * type_v) -> local_env -> local_env +val add_set : identifier -> local_env -> local_env +val is_local : local_env -> identifier -> bool +val is_local_set : local_env -> identifier -> bool + +(* typed programs *) + +type typing_info = { + env : local_env; + kappa : constr ml_type_c +} + +type typed_program = (typing_info, constr) t + +(* global environment *) + +val add_global : identifier -> type_v -> typed_program option -> object_name +val add_global_set : identifier -> object_name +val is_global : identifier -> bool +val is_global_set : identifier -> bool +val lookup_global : identifier -> type_v + +val all_vars : unit -> identifier list +val all_refs : unit -> identifier list + +(* a table keeps the program (for extraction) *) + +val find_pgm : identifier -> typed_program option + +(* a table keeps the initializations of mutable objects *) + +val initialize : identifier -> constr -> unit +val find_init : identifier -> constr + +(* access in env (local then global) *) + +val type_in_env : local_env -> identifier -> type_v +val is_in_env : local_env -> identifier -> bool + +type type_info = Set | TypeV of type_v +val fold_all : (identifier * type_info -> 'a -> 'a) -> local_env -> 'a -> 'a + +(* local environnements also contains a list of recursive functions + * with the associated variant *) + +val add_recursion : identifier * (identifier*variant) -> local_env -> local_env +val find_recursion : identifier -> local_env -> identifier * variant + +(* We also maintain a table of the currently edited proofs of programs + * in order to add them in the environnement when the user does Save *) + +val new_edited : identifier -> type_v * typed_program -> unit +val is_edited : identifier -> bool +val register : identifier -> identifier -> unit + diff --git a/contrib/correctness/perror.ml b/contrib/correctness/perror.ml new file mode 100644 index 00000000..40fe4c98 --- /dev/null +++ b/contrib/correctness/perror.ml @@ -0,0 +1,172 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: perror.ml,v 1.9.2.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Pp +open Util +open Names +open Nameops +open Term +open Himsg + +open Ptype +open Past + +let is_mutable = function Ref _ | Array _ -> true | _ -> false +let is_pure = function TypePure _ -> true | _ -> false + +let raise_with_loc = function + | None -> raise + | Some loc -> Stdpp.raise_with_loc loc + +let unbound_variable id loc = + raise_with_loc loc + (UserError ("Perror.unbound_variable", + (hov 0 (str"Unbound variable" ++ spc () ++ pr_id id ++ fnl ())))) + +let unbound_reference id loc = + raise_with_loc loc + (UserError ("Perror.unbound_reference", + (hov 0 (str"Unbound reference" ++ spc () ++ pr_id id ++ fnl ())))) + +let clash id loc = + raise_with_loc loc + (UserError ("Perror.clash", + (hov 0 (str"Clash with previous constant" ++ spc () ++ + str(string_of_id id) ++ fnl ())))) + +let not_defined id = + raise + (UserError ("Perror.not_defined", + (hov 0 (str"The object" ++ spc () ++ pr_id id ++ spc () ++ + str"is not defined" ++ fnl ())))) + +let check_for_reference loc id = function + Ref _ -> () + | _ -> Stdpp.raise_with_loc loc + (UserError ("Perror.check_for_reference", + hov 0 (pr_id id ++ spc () ++ + str"is not a reference"))) + +let check_for_array loc id = function + Array _ -> () + | _ -> Stdpp.raise_with_loc loc + (UserError ("Perror.check_for_array", + hov 0 (pr_id id ++ spc () ++ + str"is not an array"))) + +let is_constant_type s = function + TypePure c -> + let id = id_of_string s in + let c' = Constrintern.global_reference id in + Reductionops.is_conv (Global.env()) Evd.empty c c' + | _ -> false + +let check_for_index_type loc v = + let is_index = is_constant_type "Z" v in + if not is_index then + Stdpp.raise_with_loc loc + (UserError ("Perror.check_for_index", + hov 0 (str"This expression is an index" ++ spc () ++ + str"and should have type int (Z)"))) + +let check_no_effect loc ef = + if not (Peffect.get_writes ef = []) then + Stdpp.raise_with_loc loc + (UserError ("Perror.check_no_effect", + hov 0 (str"A boolean should not have side effects" +))) + +let should_be_boolean loc = + Stdpp.raise_with_loc loc + (UserError ("Perror.should_be_boolean", + hov 0 (str"This expression is a test:" ++ spc () ++ + str"it should have type bool"))) + +let test_should_be_annotated loc = + Stdpp.raise_with_loc loc + (UserError ("Perror.test_should_be_annotated", + hov 0 (str"This test should be annotated"))) + +let if_branches loc = + Stdpp.raise_with_loc loc + (UserError ("Perror.if_branches", + hov 0 (str"The two branches of an `if' expression" ++ spc () ++ + str"should have the same type"))) + +let check_for_not_mutable loc v = + if is_mutable v then + Stdpp.raise_with_loc loc + (UserError ("Perror.check_for_not_mutable", + hov 0 (str"This expression cannot be a mutable"))) + +let check_for_pure_type loc v = + if not (is_pure v) then + Stdpp.raise_with_loc loc + (UserError ("Perror.check_for_pure_type", + hov 0 (str"This expression must be pure" ++ spc () ++ + str"(neither a mutable nor a function)"))) + +let check_for_let_ref loc v = + if not (is_pure v) then + Stdpp.raise_with_loc loc + (UserError ("Perror.check_for_let_ref", + hov 0 (str"References can only be bound in pure terms"))) + +let informative loc s = + Stdpp.raise_with_loc loc + (UserError ("Perror.variant_informative", + hov 0 (str s ++ spc () ++ str"must be informative"))) + +let variant_informative loc = informative loc "Variant" +let should_be_informative loc = informative loc "This term" + +let app_of_non_function loc = + Stdpp.raise_with_loc loc + (UserError ("Perror.app_of_non_function", + hov 0 (str"This term cannot be applied" ++ spc () ++ + str"(either it is not a function" ++ spc () ++ + str"or it is applied to non pure arguments)"))) + +let partial_app loc = + Stdpp.raise_with_loc loc + (UserError ("Perror.partial_app", + hov 0 (str"This function does not have" ++ + spc () ++ str"the right number of arguments"))) + +let expected_type loc s = + Stdpp.raise_with_loc loc + (UserError ("Perror.expected_type", + hov 0 (str"Argument is expected to have type" ++ spc () ++ s))) + +let expects_a_type id loc = + Stdpp.raise_with_loc loc + (UserError ("Perror.expects_a_type", + hov 0 (str"The argument " ++ pr_id id ++ spc () ++ + str"in this application is supposed to be a type"))) + +let expects_a_term id = + raise + (UserError ("Perror.expects_a_type", + hov 0 (str"The argument " ++ pr_id id ++ spc () ++ + str"in this application is supposed to be a term"))) + +let should_be_a_variable loc = + Stdpp.raise_with_loc loc + (UserError ("Perror.should_be_a_variable", + hov 0 (str"Argument should be a variable"))) + +let should_be_a_reference loc = + Stdpp.raise_with_loc loc + (UserError ("Perror.should_be_a_reference", + hov 0 (str"Argument of function should be a reference"))) + + diff --git a/contrib/correctness/perror.mli b/contrib/correctness/perror.mli new file mode 100644 index 00000000..40b2d25c --- /dev/null +++ b/contrib/correctness/perror.mli @@ -0,0 +1,47 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: perror.mli,v 1.2.6.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Pp +open Util +open Names +open Ptype +open Past + +val unbound_variable : identifier -> loc option -> 'a +val unbound_reference : identifier -> loc option -> 'a + +val clash : identifier -> loc option -> 'a +val not_defined : identifier -> 'a + +val check_for_reference : loc -> identifier -> type_v -> unit +val check_for_array : loc -> identifier -> type_v -> unit + +val check_for_index_type : loc -> type_v -> unit +val check_no_effect : loc -> Peffect.t -> unit +val should_be_boolean : loc -> 'a +val test_should_be_annotated : loc -> 'a +val if_branches : loc -> 'a + +val check_for_not_mutable : loc -> type_v -> unit +val check_for_pure_type : loc -> type_v -> unit +val check_for_let_ref : loc -> type_v -> unit + +val variant_informative : loc -> 'a +val should_be_informative : loc -> 'a + +val app_of_non_function : loc -> 'a +val partial_app : loc -> 'a +val expected_type : loc -> std_ppcmds -> 'a +val expects_a_type : identifier -> loc -> 'a +val expects_a_term : identifier -> 'a +val should_be_a_variable : loc -> 'a +val should_be_a_reference : loc -> 'a diff --git a/contrib/correctness/pextract.ml b/contrib/correctness/pextract.ml new file mode 100644 index 00000000..2a35d471 --- /dev/null +++ b/contrib/correctness/pextract.ml @@ -0,0 +1,473 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pextract.ml,v 1.5.6.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Pp_control +open Pp +open Util +open System +open Names +open Term +open Himsg +open Reduction + +open Putil +open Ptype +open Past +open Penv +open Putil + +let extraction env c = + let ren = initial_renaming env in + let sign = Pcicenv.now_sign_of ren env in + let fsign = Mach.fsign_of_sign (Evd.mt_evd()) sign in + match Mach.infexecute (Evd.mt_evd()) (sign,fsign) c with + | (_,Inf j) -> j._VAL + | (_,Logic) -> failwith "Prog_extract.pp: should be informative" + +(* les tableaux jouent un role particulier, puisqu'ils seront extraits + * vers des tableaux ML *) + +let sp_access = coq_constant ["correctness"; "Arrays"] "access" +let access = ConstRef sp_access + +let has_array = ref false + +let pp_conversions () = + (str"\ +let rec int_of_pos = function + XH -> 1 + | XI p -> 2 * (int_of_pos p) + 1 + | XO p -> 2 * (int_of_pos p) + ++ ++ + +let int_of_z = function + ZERO -> 0 + | POS p -> int_of_pos p + | NEG p -> -(int_of_pos p) + ++ ++ +") (* '"' *) + +(* collect all section-path in a CIC constant *) + +let spset_of_cci env c = + let spl = Fw_env.collect (extraction env c) in + let sps = List.fold_left (fun e x -> SpSet.add x e) SpSet.empty spl in + has_array := !has_array or (SpSet.mem sp_access sps) ++ + SpSet.remove sp_access sps + + +(* collect all Coq constants and all pgms appearing in a given program *) + +let add_id env ((sp,ids) as s) id = + if is_local env id then + s + else if is_global id then + (sp,IdSet.add id ids) + else + try (SpSet.add (Nametab.sp_of_id FW id) sp,ids) with Not_found -> s + +let collect env = + let rec collect_desc env s = function + | Var x -> add_id env s x + | Acc x -> add_id env s x + | Aff (x,e1) -> add_id env (collect_rec env s e1) x + | TabAcc (_,x,e1) -> + has_array := true ++ + add_id env (collect_rec env s e1) x + | TabAff (_,x,e1,e2) -> + has_array := true ++ + add_id env (collect_rec env (collect_rec env s e1) e2) x + | Seq bl -> + List.fold_left (fun s st -> match st with + Statement p -> collect_rec env s p + | _ -> s) s bl + | If (e1,e2,e3) -> + collect_rec env (collect_rec env (collect_rec env s e1) e2) e3 + | While (b,_,_,bl) -> + let s = List.fold_left (fun s st -> match st with + Statement p -> collect_rec env s p + | _ -> s) s bl in + collect_rec env s b + | Lam (bl,e) -> + collect_rec (traverse_binders env bl) s e + | App (e1,l) -> + let s = List.fold_left (fun s a -> match a with + Term t -> collect_rec env s t + | Type _ | Refarg _ -> s) s l in + collect_rec env s e1 + | SApp (_,l) -> + List.fold_left (fun s a -> collect_rec env s a) s l + | LetRef (x,e1,e2) -> + let (_,v),_,_,_ = e1.info.kappa in + collect_rec (add (x,Ref v) env) (collect_rec env s e1) e2 + | LetIn (x,e1,e2) -> + let (_,v),_,_,_ = e1.info.kappa in + collect_rec (add (x,v) env) (collect_rec env s e1) e2 + | LetRec (f,bl,_,_,e) -> + let env' = traverse_binders env bl in + let env'' = add (f,make_arrow bl e.info.kappa) env' in + collect_rec env'' s e + | Debug (_,e1) -> collect_rec env s e1 + | PPoint (_,d) -> collect_desc env s d + | Expression c -> + let (sp,ids) = s in + let sp' = spset_of_cci env c in + SpSet.fold + (fun s (es,ei) -> + let id = basename s in + if is_global id then (*SpSet.add s*)es,IdSet.add id ei + else SpSet.add s es,ei) + sp' (sp,ids) + + and collect_rec env s p = collect_desc env s p.desc + + in + collect_rec env (SpSet.empty,IdSet.empty) + + +(* On a besoin de faire du renommage, tout comme pour l'extraction des + * termes Coq. En ce qui concerne les globaux, on utilise la table de + * Fwtoml. Pour les objects locaux, on introduit la structure de + * renommage rename_struct + *) + +module Ocaml_ren = Ocaml.OCaml_renaming + +let rename_global id = + let id' = Ocaml_ren.rename_global_term !Fwtoml.globals (Name id) in + Fwtoml.add_global_renaming (id,id') ++ + id' + +type rename_struct = { rn_map : identifier IdMap.t; + rn_avoid : identifier list } + +let rn_empty = { rn_map = IdMap.empty; rn_avoid = [] } + +let rename_local rn id = + let id' = Ocaml_ren.rename_term (!Fwtoml.globals@rn.rn_avoid) (Name id) in + { rn_map = IdMap.add id id' rn.rn_map; rn_avoid = id' :: rn.rn_avoid }, + id' + +let get_local_name rn id = IdMap.find id rn.rn_map + +let get_name env rn id = + if is_local env id then + get_local_name rn id + else + Fwtoml.get_global_name id + +let rec rename_binders rn = function + | [] -> rn + | (id,_) :: bl -> let rn',_ = rename_local rn id in rename_binders rn' bl + +(* on a bespoin d'un pretty-printer de constr particulier, qui reconnaisse + * les acces a des references et dans des tableaux, et qui de plus n'imprime + * pas de GENTERM lorsque des identificateurs ne sont pas visibles. + * Il est simplifie dans la mesure ou l'on a ici que des constantes et + * des applications. + *) + +let putpar par s = + if par then (str"(" ++ s ++ str")") else s + +let is_ref env id = + try + (match type_in_env env id with Ref _ -> true | _ -> false) + with + Not_found -> false + +let rec pp_constr env rn = function + | VAR id -> + if is_ref env id then + (str"!" ++ pID (get_name env rn id)) + else + pID (get_name env rn id) + | DOPN((Const _|MutInd _|MutConstruct _) as oper, _) -> + pID (Fwtoml.name_of_oper oper) + | DOPN(AppL,v) -> + if Array.length v = 0 then + (mt ()) + else begin + match v.(0) with + DOPN(Const sp,_) when sp = sp_access -> + (pp_constr env rn v.(3) ++ + str".(int_of_z " ++ pp_constr env rn v.(4) ++ str")") + | _ -> + hov 2 (putpar true (prvect_with_sep (fun () -> (spc ())) + (pp_constr env rn) v)) + end + | DOP2(Cast,c,_) -> pp_constr env rn c + | _ -> failwith "Prog_extract.pp_constr: unexpected constr" + + +(* pretty-print of imperative programs *) + +let collect_lambda = + let rec collect acc p = match p.desc with + | Lam(bl,t) -> collect (bl@acc) t + | x -> acc,p + in + collect [] + +let pr_binding rn = + prlist_with_sep (fun () -> (mt ())) + (function + | (id,(Untyped | BindType _)) -> + (str" " ++ pID (get_local_name rn id)) + | (id,BindSet) -> (mt ())) + +let pp_prog id = + let rec pp_d env rn par = function + | Var x -> pID (get_name env rn x) + | Acc x -> (str"!" ++ pID (get_name env rn x)) + | Aff (x,e1) -> (pID (get_name env rn x) ++ + str" := " ++ hov 0 (pp env rn false e1)) + | TabAcc (_,x,e1) -> + (pID (get_name env rn x) ++ + str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")") + | TabAff (_,x,e1,e2) -> + (pID (get_name env rn x) ++ + str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")" ++ + str" <-" ++ spc () ++ hov 2 (pp env rn false e2)) + | Seq bl -> + (str"begin" ++ fnl () ++ + str" " ++ hov 0 (pp_block env rn bl) ++ fnl () ++ + str"end") + | If (e1,e2,e3) -> + putpar par (str"if " ++ (pp env rn false e1) ++ + str" then" ++ fnl () ++ + str" " ++ hov 0 (pp env rn false e2) ++ fnl () ++ + str"else" ++ fnl () ++ + str" " ++ hov 0 (pp env rn false e3)) + (* optimisations : then begin .... end else begin ... end *) + | While (b,inv,_,bl) -> + (str"while " ++ (pp env rn false b) ++ str" do" ++ fnl () ++ + str" " ++ + hov 0 ((match inv with + None -> (mt ()) + | Some c -> (str"(* invariant: " ++ pTERM c.a_value ++ + str" *)" ++ fnl ())) ++ + pp_block env rn bl) ++ fnl () ++ + str"done") + | Lam (bl,e) -> + let env' = traverse_binders env bl in + let rn' = rename_binders rn bl in + putpar par + (hov 2 (str"fun" ++ pr_binding rn' bl ++ str" ->" ++ + spc () ++ pp env' rn' false e)) + | SApp ((Var id)::_, [e1; e2]) + when id = connective_and or id = connective_or -> + let conn = if id = connective_and then "&" else "or" in + putpar par + (hov 0 (pp env rn true e1 ++ spc () ++ str conn ++ spc () ++ + pp env rn true e2)) + | SApp ((Var id)::_, [e]) when id = connective_not -> + putpar par + (hov 0 (str"not" ++ spc () ++ pp env rn true e)) + | SApp _ -> + invalid_arg "Prog_extract.pp_prog (SApp)" + | App(e1,[]) -> + hov 0 (pp env rn false e1) + | App (e1,l) -> + putpar true + (hov 2 (pp env rn true e1 ++ + prlist (function + Term p -> (spc () ++ pp env rn true p) + | Refarg x -> (spc () ++ pID (get_name env rn x)) + | Type _ -> (mt ())) + l)) + | LetRef (x,e1,e2) -> + let (_,v),_,_,_ = e1.info.kappa in + let env' = add (x,Ref v) env in + let rn',x' = rename_local rn x in + putpar par + (hov 0 (str"let " ++ pID x' ++ str" = ref " ++ pp env rn false e1 ++ + str" in" ++ fnl () ++ pp env' rn' false e2)) + | LetIn (x,e1,e2) -> + let (_,v),_,_,_ = e1.info.kappa in + let env' = add (x,v) env in + let rn',x' = rename_local rn x in + putpar par + (hov 0 (str"let " ++ pID x' ++ str" = " ++ pp env rn false e1 ++ + str" in" ++ fnl () ++ pp env' rn' false e2)) + | LetRec (f,bl,_,_,e) -> + let env' = traverse_binders env bl in + let rn' = rename_binders rn bl in + let env'' = add (f,make_arrow bl e.info.kappa) env' in + let rn'',f' = rename_local rn' f in + putpar par + (hov 0 (str"let rec " ++ pID f' ++ pr_binding rn' bl ++ str" =" ++ fnl () ++ + str" " ++ hov 0 (pp env'' rn'' false e) ++ fnl () ++ + str"in " ++ pID f')) + | Debug (_,e1) -> pp env rn par e1 + | PPoint (_,d) -> pp_d env rn par d + | Expression c -> + pp_constr env rn (extraction env c) + + and pp_block env rn bl = + let bl = + map_succeed (function Statement p -> p | _ -> failwith "caught") bl + in + prlist_with_sep (fun () -> (str";" ++ fnl ())) + (fun p -> hov 0 (pp env rn false p)) bl + + and pp env rn par p = + (pp_d env rn par p.desc) + + and pp_mut v c = match v with + | Ref _ -> + (str"ref " ++ pp_constr empty rn_empty (extraction empty c)) + | Array (n,_) -> + (str"Array.create " ++ cut () ++ + putpar true + (str"int_of_z " ++ + pp_constr empty rn_empty (extraction empty n)) ++ + str" " ++ pp_constr empty rn_empty (extraction empty c)) + | _ -> invalid_arg "pp_mut" + in + let v = lookup_global id in + let id' = rename_global id in + if is_mutable v then + try + let c = find_init id in + hov 0 (str"let " ++ pID id' ++ str" = " ++ pp_mut v c) + with Not_found -> + errorlabstrm "Prog_extract.pp_prog" + (str"The variable " ++ pID id ++ + str" must be initialized first !") + else + match find_pgm id with + | None -> + errorlabstrm "Prog_extract.pp_prog" + (str"The program " ++ pID id ++ + str" must be realized first !") + | Some p -> + let bl,p = collect_lambda p in + let rn = rename_binders rn_empty bl in + let env = traverse_binders empty bl in + hov 0 (str"let " ++ pID id' ++ pr_binding rn bl ++ str" =" ++ fnl () ++ + str" " ++ hov 2 (pp env rn false p)) + +(* extraction des programmes impératifs/fonctionnels vers ocaml *) + +(* Il faut parfois importer des modules non ouverts, sinon + * Ocaml.OCaml_pp_file.pp echoue en disant "machin is not a defined + * informative object". Cela dit, ce n'est pas tres satisfaisant, vu que + * la constante existe quand meme: il vaudrait mieux contourner l'echec + * de ml_import.fwsp_of_id + *) + +let import sp = match repr_path sp with + | [m],_,_ -> + begin + try Library.import_export_module m true + with _ -> () + end + | _ -> () + +let pp_ocaml file prm = + has_array := false ++ + (* on separe objects Coq et programmes *) + let cic,pgms = + List.fold_left + (fun (sp,ids) id -> + if is_global id then (sp,IdSet.add id ids) else (IdSet.add id sp,ids)) + (IdSet.empty,IdSet.empty) prm.needed + in + (* on met les programmes dans l'ordre et pour chacun on recherche les + * objects Coq necessaires, que l'on rajoute a l'ensemble cic *) + let cic,_,pgms = + let o_pgms = fold_all (fun (id,_) l -> id::l) empty [] in + List.fold_left + (fun (cic,pgms,pl) id -> + if IdSet.mem id pgms then + let spl,pgms' = + try + (match find_pgm id with + | Some p -> collect empty p + | None -> + (try + let c = find_init id in + spset_of_cci empty c,IdSet.empty + with Not_found -> + SpSet.empty,IdSet.empty)) + with Not_found -> SpSet.empty,IdSet.empty + in + let cic' = + SpSet.fold + (fun sp cic -> import sp ++ IdSet.add (basename sp) cic) + spl cic + in + (cic',IdSet.union pgms pgms',id::pl) + else + (cic,pgms,pl)) + (cic,pgms,[]) o_pgms + in + let cic = IdSet.elements cic in + (* on pretty-print *) + let prm' = { needed = cic ++ expand = prm.expand ++ + expansion = prm.expansion ++ exact = prm.exact } + in + let strm = (Ocaml.OCaml_pp_file.pp_recursive prm' ++ + fnl () ++ fnl () ++ + if !has_array then pp_conversions() else (mt ()) ++ + prlist (fun p -> (pp_prog p ++ fnl () ++ str";;" ++ fnl () ++ fnl ())) + pgms +) + in + (* puis on ecrit dans le fichier *) + let chan = open_trapping_failure open_out file ".ml" in + let ft = with_output_to chan in + begin + try pP_with ft strm ++ pp_flush_with ft () + with e -> pp_flush_with ft () ++ close_out chan ++ raise e + end ++ + close_out chan + + +(* Initializations of mutable objects *) + +let initialize id com = + let loc = Ast.loc com in + let c = constr_of_com (Evd.mt_evd()) (initial_sign()) com in + let ty = + Reductionops.nf_betaiota (type_of (Evd.mt_evd()) (initial_sign()) c) in + try + let v = lookup_global id in + let ety = match v with + | Ref (TypePure c) -> c | Array (_,TypePure c) -> c + | _ -> raise Not_found + in + if conv (Evd.mt_evd()) ty ety then + initialize id c + else + errorlabstrm "Prog_extract.initialize" + (str"Not the expected type for the mutable " ++ pID id) + with Not_found -> + errorlabstrm "Prog_extract.initialize" + (pr_id id ++ str" is not a mutable") + +(* grammaire *) + +open Vernacinterp + +let _ = vinterp_add "IMPERATIVEEXTRACTION" + (function + | VARG_STRING file :: rem -> + let prm = parse_param rem in (fun () -> pp_ocaml file prm) + | _ -> assert false) + +let _ = vinterp_add "INITIALIZE" + (function + | [VARG_IDENTIFIER id; VARG_COMMAND com] -> + (fun () -> initialize id com) + | _ -> assert false) diff --git a/contrib/correctness/pextract.mli b/contrib/correctness/pextract.mli new file mode 100644 index 00000000..dc5b4124 --- /dev/null +++ b/contrib/correctness/pextract.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pextract.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Names + +val pp_ocaml : string -> unit + + diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml new file mode 100644 index 00000000..aed8c5cb --- /dev/null +++ b/contrib/correctness/pmisc.ml @@ -0,0 +1,222 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pmisc.ml,v 1.18.2.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Pp +open Util +open Names +open Nameops +open Term +open Libnames +open Topconstr + +(* debug *) + +let deb_mess s = + if !Options.debug then begin + msgnl s; pp_flush() + end + +let deb_print f x = + if !Options.debug then begin + msgnl (f x); pp_flush() + end + +let list_of_some = function + None -> [] + | Some x -> [x] + +let difference l1 l2 = + let rec diff = function + [] -> [] + | a::rem -> if List.mem a l2 then diff rem else a::(diff rem) + in + diff l1 + +(* TODO: these functions should be moved in the code of Coq *) + +let reraise_with_loc loc f x = + try f x with Util.UserError (_,_) as e -> Stdpp.raise_with_loc loc e + + +(* functions on names *) + +let at = if !Options.v7 then "@" else "'at'" + +let at_id id d = id_of_string ((string_of_id id) ^ at ^ d) + +let is_at id = + try + let _ = string_index_from (string_of_id id) 0 at in true + with Not_found -> + false + +let un_at id = + let s = string_of_id id in + try + let n = string_index_from s 0 at in + id_of_string (String.sub s 0 n), + String.sub s (n + String.length at) + (String.length s - n - String.length at) + with Not_found -> + invalid_arg "un_at" + +let renaming_of_ids avoid ids = + let rec rename avoid = function + [] -> [], avoid + | x::rem -> + let al,avoid = rename avoid rem in + let x' = next_ident_away x avoid in + (x,x')::al, x'::avoid + in + rename avoid ids + +let result_id = id_of_string "result" + +let adr_id id = id_of_string ("adr_" ^ (string_of_id id)) + +(* hypotheses names *) + +let next s r = function + Anonymous -> incr r; id_of_string (s ^ string_of_int !r) + | Name id -> id + +let reset_names,pre_name,post_name,inv_name, + test_name,bool_name,var_name,phi_name,for_name,label_name = + let pre = ref 0 in + let post = ref 0 in + let inv = ref 0 in + let test = ref 0 in + let bool = ref 0 in + let var = ref 0 in + let phi = ref 0 in + let forr = ref 0 in + let label = ref 0 in + (fun () -> + pre := 0; post := 0; inv := 0; test := 0; + bool := 0; var := 0; phi := 0; label := 0), + (next "Pre" pre), + (next "Post" post), + (next "Inv" inv), + (next "Test" test), + (fun () -> next "Bool" bool Anonymous), + (next "Variant" var), + (fun () -> next "rphi" phi Anonymous), + (fun () -> next "for" forr Anonymous), + (fun () -> string_of_id (next "Label" label Anonymous)) + +let default = id_of_string "x_" +let id_of_name = function Name id -> id | Anonymous -> default + + +(* functions on CIC terms *) + +let isevar = Evarutil.new_evar_in_sign (Global.env ()) + +(* Substitutions of variables by others. *) +let subst_in_constr alist = + let alist' = List.map (fun (id,id') -> (id, mkVar id')) alist in + replace_vars alist' + +(* +let subst_in_ast alist ast = + let rec subst = function + Nvar(l,s) -> Nvar(l,try List.assoc s alist with Not_found -> s) + | Node(l,s,args) -> Node(l,s,List.map subst args) + | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *) + | x -> x + in + subst ast +*) +(* +let subst_ast_in_ast alist ast = + let rec subst = function + Nvar(l,s) as x -> (try List.assoc s alist with Not_found -> x) + | Node(l,s,args) -> Node(l,s,List.map subst args) + | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *) + | x -> x + in + subst ast +*) + +let rec subst_in_ast alist = function + | CRef (Ident (loc,id)) -> + CRef (Ident (loc,(try List.assoc id alist with Not_found -> id))) + | x -> map_constr_expr_with_binders subst_in_ast List.remove_assoc alist x + +let rec subst_ast_in_ast alist = function + | CRef (Ident (_,id)) as x -> (try List.assoc id alist with Not_found -> x) + | x -> + map_constr_expr_with_binders subst_ast_in_ast List.remove_assoc alist x + +(* subst. of variables by constr *) +let real_subst_in_constr = replace_vars + +(* Coq constants *) + +let coq_constant d s = + Libnames.encode_kn + (make_dirpath (List.rev (List.map id_of_string ("Coq"::d)))) + (id_of_string s) + +let bool_sp = coq_constant ["Init"; "Datatypes"] "bool" +let coq_true = mkConstruct ((bool_sp,0),1) +let coq_false = mkConstruct ((bool_sp,0),2) + +let constant s = + let id = Constrextern.id_of_v7_string s in + Constrintern.global_reference id + +let connective_and = id_of_string "prog_bool_and" +let connective_or = id_of_string "prog_bool_or" +let connective_not = id_of_string "prog_bool_not" + +let is_connective id = + id = connective_and or id = connective_or or id = connective_not + +(* [conj i s] constructs the conjunction of two constr *) + +let conj i s = Term.applist (constant "and", [i; s]) + +(* [n_mkNamedProd v [xn,tn;...;x1,t1]] constructs the type + [(x1:t1)...(xn:tn)v] *) + +let rec n_mkNamedProd v = function + | [] -> v + | (id,ty) :: rem -> n_mkNamedProd (Term.mkNamedProd id ty v) rem + +(* [n_lambda v [xn,tn;...;x1,t1]] constructs the type [x1:t1]...[xn:tn]v *) + +let rec n_lambda v = function + | [] -> v + | (id,ty) :: rem -> n_lambda (Term.mkNamedLambda id ty v) rem + +(* [abstract env idl c] constructs [x1]...[xn]c where idl = [x1;...;xn] *) + +let abstract ids c = n_lambda c (List.rev ids) + +(* substitutivity (of kernel names, for modules management) *) + +open Ptype + +let rec type_v_knsubst s = function + | Ref v -> Ref (type_v_knsubst s v) + | Array (c, v) -> Array (subst_mps s c, type_v_knsubst s v) + | Arrow (bl, c) -> Arrow (List.map (binder_knsubst s) bl, type_c_knsubst s c) + | TypePure c -> TypePure (subst_mps s c) + +and type_c_knsubst s ((id,v),e,pl,q) = + ((id, type_v_knsubst s v), e, + List.map (fun p -> { p with p_value = subst_mps s p.p_value }) pl, + option_app (fun q -> { q with a_value = subst_mps s q.a_value }) q) + +and binder_knsubst s (id,b) = + (id, match b with BindType v -> BindType (type_v_knsubst s v) | _ -> b) diff --git a/contrib/correctness/pmisc.mli b/contrib/correctness/pmisc.mli new file mode 100644 index 00000000..ec7521cc --- /dev/null +++ b/contrib/correctness/pmisc.mli @@ -0,0 +1,81 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pmisc.mli,v 1.9.6.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Names +open Term +open Ptype +open Topconstr + +(* Some misc. functions *) + +val reraise_with_loc : Util.loc -> ('a -> 'b) -> 'a -> 'b + +val list_of_some : 'a option -> 'a list +val difference : 'a list -> 'a list -> 'a list + +val at_id : identifier -> string -> identifier +val un_at : identifier -> identifier * string +val is_at : identifier -> bool + +val result_id : identifier +val adr_id : identifier -> identifier + +val renaming_of_ids : identifier list -> identifier list + -> (identifier * identifier) list * identifier list + +val reset_names : unit -> unit +val pre_name : name -> identifier +val post_name : name -> identifier +val inv_name : name -> identifier +val test_name : name -> identifier +val bool_name : unit -> identifier +val var_name : name -> identifier +val phi_name : unit -> identifier +val for_name : unit -> identifier +val label_name : unit -> string + +val id_of_name : name -> identifier + +(* CIC terms *) + +val isevar : constr + +val subst_in_constr : (identifier * identifier) list -> constr -> constr +val subst_in_ast : (identifier * identifier) list -> constr_expr -> constr_expr +val subst_ast_in_ast : + (identifier * constr_expr) list -> constr_expr -> constr_expr +val real_subst_in_constr : (identifier * constr) list -> constr -> constr + +val constant : string -> constr +val coq_constant : string list -> string -> kernel_name +val conj : constr -> constr -> constr + +val coq_true : constr +val coq_false : constr + +val connective_and : identifier +val connective_or : identifier +val connective_not : identifier +val is_connective : identifier -> bool + +val n_mkNamedProd : constr -> (identifier * constr) list -> constr +val n_lambda : constr -> (identifier * constr) list -> constr +val abstract : (identifier * constr) list -> constr -> constr + +val type_v_knsubst : substitution -> type_v -> type_v +val type_c_knsubst : substitution -> type_c -> type_c + +(* for debugging purposes *) + +val deb_mess : Pp.std_ppcmds -> unit +val deb_print : ('a -> Pp.std_ppcmds) -> 'a -> unit + diff --git a/contrib/correctness/pmlize.ml b/contrib/correctness/pmlize.ml new file mode 100644 index 00000000..f899366d --- /dev/null +++ b/contrib/correctness/pmlize.ml @@ -0,0 +1,320 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pmlize.ml,v 1.7.2.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Names +open Term +open Termast +open Pattern +open Matching + +open Pmisc +open Ptype +open Past +open Putil +open Prename +open Penv +open Peffect +open Ptyping +open Pmonad + + +let has_proof_part ren env c = + let sign = Pcicenv.trad_sign_of ren env in + let ty = Typing.type_of (Global.env_of_context sign) Evd.empty c in + Hipattern.is_matching_sigma (Reductionops.nf_betaiota ty) + +(* main part: translation of imperative programs into functional ones. + * + * [env] is the environment + * [ren] is the current renamings of variables + * [t] is the imperative program to translate, annotated with type+effects + * + * we return the translated program in type cc_term + *) + +let rec trad ren t = + let env = t.info.env in + trad_desc ren env t.info.kappa t.desc + +and trad_desc ren env ct d = + let (_,tt),eft,pt,qt = ct in + match d with + + | Expression c -> + let ids = get_reads eft in + let al = current_vars ren ids in + let c' = subst_in_constr al c in + if has_proof_part ren env c' then + CC_expr c' + else + let ty = trad_ml_type_v ren env tt in + make_tuple [ CC_expr c',ty ] qt ren env (current_date ren) + + | Variable id -> + if is_mutable_in_env env id then + invalid_arg "Mlise.trad_desc" + else if is_local env id then + CC_var id + else + CC_expr (constant (string_of_id id)) + + | Acc _ -> + failwith "Mlise.trad: pure terms are supposed to be expressions" + + | TabAcc (check, x, e1) -> + let _,ty_elem,_ = array_info ren env x in + let te1 = trad ren e1 in + let (_,ef1,p1,q1) = e1.info.kappa in + let w = get_writes ef1 in + let ren' = next ren w in + let id = id_of_string "index" in + let access = + make_raw_access ren' env (x,current_var ren' x) (mkVar id) + in + let t,ty = result_tuple ren' (current_date ren) env + (CC_expr access, ty_elem) (eft,qt) in + let t = + if check then + let h = make_pre_access ren env x (mkVar id) in + let_in_pre ty (anonymous_pre true h) t + else + t + in + make_let_in ren env te1 p1 + (current_vars ren' w,q1) (id,constant "Z") (t,ty) + + | Aff (x, e1) -> + let tx = trad_type_in_env ren env x in + let te1 = trad ren e1 in + let (_,ef1,p1,q1) = e1.info.kappa in + let w1 = get_writes ef1 in + let ren' = next ren (x::w1) in + let t_ty = result_tuple ren' (current_date ren) env + (CC_expr (constant "tt"), constant "unit") (eft,qt) + in + make_let_in ren env te1 p1 + (current_vars ren' w1,q1) (current_var ren' x,tx) t_ty + + | TabAff (check, x, e1, e2) -> + let _,ty_elem,ty_array = array_info ren env x in + let te1 = trad ren e1 in + let (_,ef1,p1,q1) = e1.info.kappa in + let w1 = get_writes ef1 in + let ren' = next ren w1 in + let te2 = trad ren' e2 in + let (_,ef2,p2,q2) = e2.info.kappa in + let w2 = get_writes ef2 in + let ren'' = next ren' w2 in + let id1 = id_of_string "index" in + let id2 = id_of_string "v" in + let ren''' = next ren'' [x] in + let t,ty = result_tuple ren''' (current_date ren) env + (CC_expr (constant "tt"), constant "unit") (eft,qt) in + let store = make_raw_store ren'' env (x,current_var ren'' x) (mkVar id1) + (mkVar id2) in + let t = make_let_in ren'' env (CC_expr store) [] ([],None) + (current_var ren''' x,ty_array) (t,ty) in + let t = make_let_in ren' env te2 p2 + (current_vars ren'' w2,q2) (id2,ty_elem) (t,ty) in + let t = + if check then + let h = make_pre_access ren' env x (mkVar id1) in + let_in_pre ty (anonymous_pre true h) t + else + t + in + make_let_in ren env te1 p1 + (current_vars ren' w1,q1) (id1,constant "Z") (t,ty) + + | Seq bl -> + let before = current_date ren in + let finish ren = function + Some (id,ty) -> + result_tuple ren before env (CC_var id, ty) (eft,qt) + | None -> + failwith "a block should contain at least one statement" + in + let bl = trad_block ren env bl in + make_block ren env finish bl + + | If (b, e1, e2) -> + let tb = trad ren b in + let _,efb,_,_ = b.info.kappa in + let ren' = next ren (get_writes efb) in + let te1 = trad ren' e1 in + let te2 = trad ren' e2 in + make_if ren env (tb,b.info.kappa) ren' (te1,e1.info.kappa) + (te2,e2.info.kappa) ct + + (* Translation of the while. *) + + | While (b, inv, var, bl) -> + let ren' = next ren (get_writes eft) in + let tb = trad ren' b in + let tbl = trad_block ren' env bl in + let var' = typed_var ren env var in + make_while ren env var' (tb,b.info.kappa) tbl (inv,ct) + + | Lam (bl, e) -> + let bl' = trad_binders ren env bl in + let env' = traverse_binders env bl in + let ren' = initial_renaming env' in + let te = trans ren' e in + CC_lam (bl', te) + + | SApp ([Variable id; Expression q1; Expression q2], [e1; e2]) + when id = connective_and or id = connective_or -> + let c = constant (string_of_id id) in + let te1 = trad ren e1 + and te2 = trad ren e2 in + let q1' = apply_post ren env (current_date ren) (anonymous q1) + and q2' = apply_post ren env (current_date ren) (anonymous q2) in + CC_app (CC_expr c, [CC_expr q1'.a_value; CC_expr q2'.a_value; te1; te2]) + + | SApp ([Variable id; Expression q], [e]) when id = connective_not -> + let c = constant (string_of_id id) in + let te = trad ren e in + let q' = apply_post ren env (current_date ren) (anonymous q) in + CC_app (CC_expr c, [CC_expr q'.a_value; te]) + + | SApp _ -> + invalid_arg "mlise.trad (SApp)" + + | Apply (f, args) -> + let trad_arg (ren,args) = function + | Term a -> + let ((_,tya),efa,_,_) as ca = a.info.kappa in + let ta = trad ren a in + let w = get_writes efa in + let ren' = next ren w in + ren', ta::args + | Refarg _ -> + ren, args + | Type v -> + let c = trad_ml_type_v ren env v in + ren, (CC_expr c)::args + in + let ren',targs = List.fold_left trad_arg (ren,[]) args in + let tf = trad ren' f in + let cf = f.info.kappa in + let c,(s,_,_),capp = effect_app ren env f args in + let tc_args = + List.combine + (List.rev targs) + (Util.map_succeed + (function + | Term x -> x.info.kappa + | Refarg _ -> failwith "caught" + | Type _ -> + (result_id,TypePure mkSet),Peffect.bottom,[],None) + args) + in + make_app env ren tc_args ren' (tf,cf) (c,s,capp) ct + + | LetRef (x, e1, e2) -> + let (_,v1),ef1,p1,q1 = e1.info.kappa in + let te1 = trad ren e1 in + let tv1 = trad_ml_type_v ren env v1 in + let env' = add (x,Ref v1) env in + let ren' = next ren [x] in + let (_,v2),ef2,p2,q2 = e2.info.kappa in + let tv2 = trad_ml_type_v ren' env' v2 in + let te2 = trad ren' e2 in + let ren'' = next ren' (get_writes ef2) in + let t,ty = result_tuple ren'' (current_date ren) env + (CC_var result_id, tv2) (eft,qt) in + let t = make_let_in ren' env' te2 p2 + (current_vars ren'' (get_writes ef2),q2) + (result_id,tv2) (t,ty) in + let t = make_let_in ren env te1 p1 + (current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty) + in + t + + | Let (x, e1, e2) -> + let (_,v1),ef1,p1,q1 = e1.info.kappa in + let te1 = trad ren e1 in + let tv1 = trad_ml_type_v ren env v1 in + let env' = add (x,v1) env in + let ren' = next ren (get_writes ef1) in + let (_,v2),ef2,p2,q2 = e2.info.kappa in + let tv2 = trad_ml_type_v ren' env' v2 in + let te2 = trad ren' e2 in + let ren'' = next ren' (get_writes ef2) in + let t,ty = result_tuple ren'' (current_date ren) env + (CC_var result_id, tv2) (eft,qt) in + let t = make_let_in ren' env' te2 p2 + (current_vars ren'' (get_writes ef2),q2) + (result_id,tv2) (t,ty) in + let t = make_let_in ren env te1 p1 + (current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty) + in + t + + | LetRec (f,bl,v,var,e) -> + let (_,ef,_,_) as c = + match tt with Arrow(_,c) -> c | _ -> assert false in + let bl' = trad_binders ren env bl in + let env' = traverse_binders env bl in + let ren' = initial_renaming env' in + let (phi0,var') = find_recursion f e.info.env in + let te = trad ren' e in + let t = make_letrec ren' env' (phi0,var') f bl' (te,e.info.kappa) c in + CC_lam (bl', t) + + | PPoint (s,d) -> + let ren' = push_date ren s in + trad_desc ren' env ct d + + | Debug _ -> failwith "Mlise.trad: Debug: not implemented" + + +and trad_binders ren env = function + | [] -> + [] + | (_,BindType (Ref _ | Array _))::bl -> + trad_binders ren env bl + | (id,BindType v)::bl -> + let tt = trad_ml_type_v ren env v in + (id, CC_typed_binder tt) :: (trad_binders ren env bl) + | (id,BindSet)::bl -> + (id, CC_typed_binder mkSet) :: (trad_binders ren env bl) + | (_,Untyped)::_ -> invalid_arg "trad_binders" + + +and trad_block ren env = function + | [] -> + [] + | (Assert c)::block -> + (Assert c)::(trad_block ren env block) + | (Label s)::block -> + let ren' = push_date ren s in + (Label s)::(trad_block ren' env block) + | (Statement e)::block -> + let te = trad ren e in + let _,efe,_,_ = e.info.kappa in + let w = get_writes efe in + let ren' = next ren w in + (Statement (te,e.info.kappa))::(trad_block ren' env block) + + +and trans ren e = + let env = e.info.env in + let _,ef,p,_ = e.info.kappa in + let ty = trad_ml_type_c ren env e.info.kappa in + let ids = get_reads ef in + let al = current_vars ren ids in + let c = trad ren e in + let c = abs_pre ren env (c,ty) p in + let bl = binding_of_alist ren env al in + make_abs (List.rev bl) c + diff --git a/contrib/correctness/pmlize.mli b/contrib/correctness/pmlize.mli new file mode 100644 index 00000000..95f74ef9 --- /dev/null +++ b/contrib/correctness/pmlize.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 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pmlize.mli,v 1.2.16.1 2004/07/16 19:30:01 herbelin Exp $ *) + +open Past +open Penv +open Names + +(* translation of imperative programs into intermediate functional programs *) + +val trans : Prename.t -> typed_program -> cc_term + diff --git a/contrib/correctness/pmonad.ml b/contrib/correctness/pmonad.ml new file mode 100644 index 00000000..b8b39353 --- /dev/null +++ b/contrib/correctness/pmonad.ml @@ -0,0 +1,665 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pmonad.ml,v 1.6.16.1 2004/07/16 19:30:02 herbelin Exp $ *) + +open Util +open Names +open Term +open Termast + +open Pmisc +open Putil +open Ptype +open Past +open Prename +open Penv +open Pcic +open Peffect + + +(* [product ren [y1,z1;...;yk,zk] q] constructs + * the (possibly dependent) tuple type + * + * z1 x ... x zk if no post-condition + * or \exists. y1:z1. ... yk:zk. (Q x1 ... xn) otherwise + * + * where the xi are given by the renaming [ren]. + *) + +let product_name = function + | 2 -> "prod" + | n -> check_product_n n; Printf.sprintf "tuple_%d" n + +let dep_product_name = function + | 1 -> "sig" + | n -> check_dep_product_n n; Printf.sprintf "sig_%d" n + +let product ren env before lo = function + | None -> (* non dependent case *) + begin match lo with + | [_,v] -> v + | _ -> + let s = product_name (List.length lo) in + Term.applist (constant s, List.map snd lo) + end + | Some q -> (* dependent case *) + let s = dep_product_name (List.length lo) in + let a' = apply_post ren env before q in + Term.applist (constant s, (List.map snd lo) @ [a'.a_value]) + +(* [arrow ren v pl] abstracts the term v over the pre-condition if any + * i.e. computes + * + * (P1 x1 ... xn) -> ... -> (Pk x1 ... xn) -> v + * + * where the xi are given by the renaming [ren]. + *) + +let arrow ren env v pl = + List.fold_left + (fun t p -> + if p.p_assert then t else Term.mkArrow (apply_pre ren env p).p_value t) + v pl + +(* [abstract_post ren env (e,q) (res,v)] abstract a post-condition q + * over the write-variables of e *) + +let rec abstract_post ren env (e,q) = + let after_id id = id_of_string ((string_of_id id) ^ "'") in + let (_,go) = Peffect.get_repr e in + let al = List.map (fun id -> (id,after_id id)) go in + let q = option_app (named_app (subst_in_constr al)) q in + let tgo = List.map (fun (id,aid) -> (aid, trad_type_in_env ren env id)) al in + option_app (named_app (abstract tgo)) q + +(* Translation of effects types in cic types. + * + * [trad_ml_type_v] and [trad_ml_type_c] translate types with effects + * into cic types. + *) + +and prod ren env g = + List.map + (fun id -> (current_var ren id, trad_type_in_env ren env id)) + g + +and input ren env e = + let i,_ = Peffect.get_repr e in + prod ren env i + +and output ren env ((id,v),e) = + let tv = trad_ml_type_v ren env v in + let _,o = Peffect.get_repr e in + (prod ren env o) @ [id,tv] + +and input_output ren env c = + let ((res,v),e,_,_) = c in + input ren env e, output ren env ((res,v),e) + +(* The function t -> \barre{t} on V and C. *) + +and trad_ml_type_c ren env c = + let ((res,v),e,p,q) = c in + let q = abstract_post ren env (e,q) in + let lo = output ren env ((res,v),e) in + let ty = product ren env (current_date ren) lo q in + let ty = arrow ren env ty p in + let li = input ren env e in + n_mkNamedProd ty li + +and trad_ml_type_v ren env = function + + | Ref _ | Array _ -> invalid_arg "Monad.trad_ml_type_v" + + | Arrow (bl, c) -> + let bl',ren',env' = + List.fold_left + (fun (bl,ren,env) b -> match b with + | (id,BindType ((Ref _ | Array _) as v)) -> + let env' = add (id,v) env in + let ren' = initial_renaming env' in + (bl,ren',env') + | (id,BindType v) -> + let tt = trad_ml_type_v ren env v in + let env' = add (id,v) env in + let ren' = initial_renaming env' in + (id,tt)::bl,ren',env' + | (id, BindSet) -> + (id,mkSet) :: bl,ren,env + | _ -> failwith "Monad: trad_ml_type_v: not yet implemented" + ) + ([],ren,env) bl + in + n_mkNamedProd (trad_ml_type_c ren' env' c) bl' + + | TypePure c -> + (apply_pre ren env (anonymous_pre false c)).p_value + +and trad_imp_type ren env = function + | Ref v -> trad_ml_type_v ren env v + | Array (c,v) -> Term.applist (constant "array", + [c; trad_ml_type_v ren env v]) + | _ -> invalid_arg "Monad.trad_imp_type" + +and trad_type_in_env ren env id = + let v = type_in_env env id in trad_imp_type ren env v + + + +(* bindings *) + +let binding_of_alist ren env al = + List.map + (fun (id,id') -> (id', CC_typed_binder (trad_type_in_env ren env id))) + al + + +(* [make_abs bl t p] abstracts t w.r.t binding list bl., that is + * [x1:t1]...[xn:tn]t. Returns t if the binding is empty. *) + +let make_abs bl t = match bl with + | [] -> t + | _ -> CC_lam (bl, t) + + +(* [result_tuple ren before env (res,v) (ef,q)] constructs the tuple + * + * (y1,...,yn,res,?::(q/ren y1 ... yn res)) + * + * where the yi are the values of the output of ef. + * if there is no yi and no post-condition, it is simplified in res itself. + *) + +let simple_constr_of_prog = function + | CC_expr c -> c + | CC_var id -> mkVar id + | _ -> assert false + +let make_tuple l q ren env before = match l with + | [e,_] when q = None -> + e + | _ -> + let tl = List.map snd l in + let dep,h,th = match q with + | None -> false,[],[] + | Some c -> + let args = List.map (fun (e,_) -> simple_constr_of_prog e) l in + let c = apply_post ren env before c in + true, + [ CC_hole (Term.applist (c.a_value, args)) ], (* hole *) + [ c.a_value ] (* type of the hole *) + in + CC_tuple (dep, tl @ th, (List.map fst l) @ h) + +let result_tuple ren before env (res,v) (ef,q) = + let ids = get_writes ef in + let lo = + (List.map (fun id -> + let id' = current_var ren id in + CC_var id', trad_type_in_env ren env id) ids) + @ [res,v] + in + let q = abstract_post ren env (ef,q) in + make_tuple lo q ren env before, + product ren env before lo q + + +(* [make_let_in ren env fe p (vo,q) (res,v) t] constructs the term + + [ let h1 = ?:P1 in ... let hn = ?:Pm in ] + let y1,y2,...,yn, res [,q] = fe in + t + + vo=[_,y1;...;_,ym] are list of renamings. + v is the type of res + *) + +let let_in_pre ty p t = + let h = p.p_value in + CC_letin (false, ty, [pre_name p.p_name,CC_typed_binder h], CC_hole h, t) + +let multiple_let_in_pre ty hl t = + List.fold_left (fun t h -> let_in_pre ty h t) t hl + +let make_let_in ren env fe p (vo,q) (res,tyres) (t,ty) = + let b = [res, CC_typed_binder tyres] in + let b',dep = match q with + | None -> [],false + | Some q -> [post_name q.a_name, CC_untyped_binder],true + in + let bl = (binding_of_alist ren env vo) @ b @ b' in + let tyapp = + let n = succ (List.length vo) in + let name = match q with None -> product_name n | _ -> dep_product_name n in + constant name + in + let t = CC_letin (dep, ty, bl, fe, t) in + multiple_let_in_pre ty (List.map (apply_pre ren env) p) t + + +(* [abs_pre ren env (t,ty) pl] abstracts a term t with respect to the + * list of pre-conditions [pl]. Some of them are real pre-conditions + * and others are assertions, according to the boolean field p_assert, + * so we construct the term + * [h1:P1]...[hn:Pn]let h'1 = ?:P'1 in ... let H'm = ?:P'm in t + *) + +let abs_pre ren env (t,ty) pl = + List.fold_left + (fun t p -> + if p.p_assert then + let_in_pre ty (apply_pre ren env p) t + else + let h = pre_name p.p_name in + CC_lam ([h,CC_typed_binder (apply_pre ren env p).p_value],t)) + t pl + + +(* [make_block ren env finish bl] builds the translation of a block + * finish is the function that is applied to the result at the end of the + * block. *) + +let make_block ren env finish bl = + let rec rec_block ren result = function + | [] -> + finish ren result + | (Assert c) :: block -> + let t,ty = rec_block ren result block in + let c = apply_assert ren env c in + let p = { p_assert = true; p_name = c.a_name; p_value = c.a_value } in + let_in_pre ty p t, ty + | (Label s) :: block -> + let ren' = push_date ren s in + rec_block ren' result block + | (Statement (te,info)) :: block -> + let (_,tye),efe,pe,qe = info in + let w = get_writes efe in + let ren' = next ren w in + let id = result_id in + let tye = trad_ml_type_v ren env tye in + let t = rec_block ren' (Some (id,tye)) block in + make_let_in ren env te pe (current_vars ren' w,qe) (id,tye) t, + snd t + in + let t,_ = rec_block ren None bl in + t + + +(* [make_app env ren args ren' (tf,cf) (cb,s,capp) c] + * constructs the application of [tf] to [args]. + * capp is the effect of application, after substitution (s) and cb before + *) + +let eq ty e1 e2 = + Term.applist (constant "eq", [ty; e1; e2]) + +let lt r e1 e2 = + Term.applist (r, [e1; e2]) + +let is_recursive env = function + | CC_var x -> + (try let _ = find_recursion x env in true with Not_found -> false) + | _ -> false + +let if_recursion env f = function + | CC_var x -> + (try let v = find_recursion x env in (f v x) with Not_found -> []) + | _ -> [] + +let dec_phi ren env s svi = + if_recursion env + (fun (phi0,(cphi,r,_)) f -> + let phi = subst_in_constr svi (subst_in_constr s cphi) in + let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in + [CC_expr phi; CC_hole (lt r phi (mkVar phi0))]) + +let eq_phi ren env s svi = + if_recursion env + (fun (phi0,(cphi,_,a)) f -> + let phi = subst_in_constr svi (subst_in_constr s cphi) in + let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in + [CC_hole (eq a phi phi)]) + +let is_ref_binder = function + | (_,BindType (Ref _ | Array _)) -> true + | _ -> false + +let make_app env ren args ren' (tf,cf) ((bl,cb),s,capp) c = + let ((_,tvf),ef,pf,qf) = cf in + let (_,eapp,papp,qapp) = capp in + let ((_,v),e,p,q) = c in + let bl = List.filter (fun b -> not (is_ref_binder b)) bl in + let recur = is_recursive env tf in + let before = current_date ren in + let ren'' = next ren' (get_writes ef) in + let ren''' = next ren'' (get_writes eapp) in + let res = result_id in + let vi,svi = + let ids = List.map fst bl in + let s = fresh (avoid ren ids) ids in + List.map snd s, s + in + let tyres = subst_in_constr svi (trad_ml_type_v ren env v) in + let t,ty = result_tuple ren''' before env (CC_var res, tyres) (e,q) in + let res_f = id_of_string "vf" in + let inf,outf = + let i,o = let _,e,_,_ = cb in get_reads e, get_writes e in + let apply_s = List.map (fun id -> try List.assoc id s with _ -> id) in + apply_s i, apply_s o + in + let fe = + let xi = List.rev (List.map snd (current_vars ren'' inf)) in + let holes = List.map (fun x -> (apply_pre ren'' env x).p_value) + (List.map (pre_app (subst_in_constr svi)) papp) in + CC_app ((if recur then tf else CC_var res_f), + (dec_phi ren'' env s svi tf) + @(List.map (fun id -> CC_var id) (vi @ xi)) + @(eq_phi ren'' env s svi tf) + @(List.map (fun c -> CC_hole c) holes)) + in + let qapp' = option_app (named_app (subst_in_constr svi)) qapp in + let t = + make_let_in ren'' env fe [] (current_vars ren''' outf,qapp') + (res,tyres) (t,ty) + in + let t = + if recur then + t + else + make_let_in ren' env tf pf + (current_vars ren'' (get_writes ef),qf) + (res_f,trad_ml_type_v ren env tvf) (t,ty) + in + let rec eval_args ren = function + | [] -> t + | (vx,(ta,((_,tva),ea,pa,qa)))::args -> + let w = get_writes ea in + let ren' = next ren w in + let t' = eval_args ren' args in + make_let_in ren env ta pa (current_vars ren' (get_writes ea),qa) + (vx,trad_ml_type_v ren env tva) (t',ty) + in + eval_args ren (List.combine vi args) + + +(* [make_if ren env (tb,cb) ren' (t1,c1) (t2,c2)] + * constructs the term corresponding to a if expression, i.e + * + * [p] let o1, b [,q1] = m1 [?::p1] in + * Cases b of + * R => let o2, v2 [,q2] = t1 [?::p2] in + * (proj (o1,o2)), v2 [,?::q] + * | S => let o2, v2 [,q2] = t2 [?::p2] in + * (proj (o1,o2)), v2 [,?::q] + *) + +let make_if_case ren env ty (b,qb) (br1,br2) = + let id_b,ty',ty1,ty2 = match qb with + | Some q -> + let q = apply_post ren env (current_date ren) q in + let (name,t1,t2) = Term.destLambda q.a_value in + q.a_name, + Term.mkLambda (name, t1, mkArrow t2 ty), + Term.mkApp (q.a_value, [| coq_true |]), + Term.mkApp (q.a_value, [| coq_false |]) + | None -> assert false + in + let n = test_name Anonymous in + CC_app (CC_case (ty', b, [CC_lam ([n,CC_typed_binder ty1], br1); + CC_lam ([n,CC_typed_binder ty2], br2)]), + [CC_var (post_name id_b)]) + +let make_if ren env (tb,cb) ren' (t1,c1) (t2,c2) c = + let ((_,tvb),eb,pb,qb) = cb in + let ((_,tv1),e1,p1,q1) = c1 in + let ((_,tv2),e2,p2,q2) = c2 in + let ((_,t),e,p,q) = c in + + let wb = get_writes eb in + let resb = id_of_string "resultb" in + let res = result_id in + let tyb = trad_ml_type_v ren' env tvb in + let tt = trad_ml_type_v ren env t in + + (* une branche de if *) + let branch (tv_br,e_br,p_br,q_br) f_br = + let w_br = get_writes e_br in + let ren'' = next ren' w_br in + let t,ty = result_tuple ren'' (current_date ren') env + (CC_var res,tt) (e,q) in + make_let_in ren' env f_br p_br (current_vars ren'' w_br,q_br) + (res,tt) (t,ty), + ty + in + let t1,ty1 = branch c1 t1 in + let t2,ty2 = branch c2 t2 in + let ty = ty1 in + let qb = force_bool_name qb in + let t = make_if_case ren env ty (CC_var resb,qb) (t1,t2) in + make_let_in ren env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty) + + +(* [make_while ren env (cphi,r,a) (tb,cb) (te,ce) c] + * constructs the term corresponding to the while, i.e. + * + * [h:(I x)](well_founded_induction + * A R ?::(well_founded A R) + * [Phi:A] (x) Phi=phi(x)->(I x)-> \exists x'.res.(I x')/\(S x') + * [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...] + * [x][eq:Phi_0=phi(x)][h:(I x)] + * Cases (b x) of + * (left HH) => (x,?::(IS x)) + * | (right HH) => let x1,_,_ = (e x ?) in + * (w phi(x1) ? x1 ? ?) + * phi(x) x ? ?) + *) + +let id_phi = id_of_string "phi" +let id_phi0 = id_of_string "phi0" + +let make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c) = + let ((_,tvb),eb,pb,qb) = cb in + let (_,ef,_,is) = c in + + let ren' = next ren (get_writes ef) in + let before = current_date ren in + + let ty = + let is = abstract_post ren' env (ef,is) in + let _,lo = input_output ren env c in + product ren env before lo is + in + let resb = id_of_string "resultb" in + let tyb = trad_ml_type_v ren' env tvb in + let wb = get_writes eb in + + (* première branche: le test est vrai => e;w *) + let t1 = + make_block ren' env + (fun ren'' result -> match result with + | Some (id,_) -> + let v = List.rev (current_vars ren'' (get_writes ef)) in + CC_app (CC_var id_w, + [CC_expr (phi_of ren''); + CC_hole (lt r (phi_of ren'') (mkVar id_phi0))] + @(List.map (fun (_,id) -> CC_var id) v) + @(CC_hole (eq a (phi_of ren'') (phi_of ren''))) + ::(match i with + | None -> [] + | Some c -> + [CC_hole (apply_assert ren'' env c).a_value])), + ty + | None -> failwith "a block should contain at least one statement") + tbl + in + + (* deuxième branche: le test est faux => on sort de la boucle *) + let t2,_ = + result_tuple ren' before env + (CC_expr (constant "tt"),constant "unit") (ef,is) + in + + let b_al = current_vars ren' (get_reads eb) in + let qb = force_bool_name qb in + let t = make_if_case ren' env ty (CC_var resb,qb) (t1,t2) in + let t = + make_let_in ren' env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty) + in + let t = + let pl = List.map (pre_of_assert false) (list_of_some i) in + abs_pre ren' env (t,ty) pl + in + let t = + CC_lam ([var_name Anonymous, + CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren'))],t) + in + let bl = binding_of_alist ren env (current_vars ren' (get_writes ef)) in + make_abs (List.rev bl) t + + +let make_while ren env (cphi,r,a) (tb,cb) tbl (i,c) = + let (_,ef,_,is) = c in + let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in + let wf_a_r = Term.applist (constant "well_founded", [a; r]) in + + let before = current_date ren in + let ren' = next ren (get_writes ef) in + let al = current_vars ren' (get_writes ef) in + let v = + let _,lo = input_output ren env c in + let is = abstract_post ren' env (ef,is) in + match i with + | None -> product ren' env before lo is + | Some ci -> + Term.mkArrow (apply_assert ren' env ci).a_value + (product ren' env before lo is) + in + let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren')) v in + let v = + n_mkNamedProd v + (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al) + in + let tw = + Term.mkNamedProd id_phi a + (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v) + in + let id_w = id_of_string "loop" in + let vars = List.rev (current_vars ren (get_writes ef)) in + let body = + make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c) + in + CC_app (CC_expr (constant "well_founded_induction"), + [CC_expr a; CC_expr r; + CC_hole wf_a_r; + CC_expr (Term.mkNamedLambda id_phi a v); + CC_lam ([id_phi0, CC_typed_binder a; + id_w, CC_typed_binder tw], + body); + CC_expr (phi_of ren)] + @(List.map (fun (_,id) -> CC_var id) vars) + @(CC_hole (eq a (phi_of ren) (phi_of ren))) + ::(match i with + | None -> [] + | Some c -> [CC_hole (apply_assert ren env c).a_value])) + + +(* [make_letrec ren env (phi0,(cphi,r,a)) bl (te,ce) c] + * constructs the term corresponding to the let rec i.e. + * + * [x][h:P(x)](well_founded_induction + * A R ?::(well_founded A R) + * [Phi:A] (bl) (x) Phi=phi(x)->(P x)-> \exists x'.res.(Q x x') + * [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...] + * [bl][x][eq:Phi_0=phi(x)][h:(P x)]te + * phi(x) bl x ? ?) + *) + +let make_letrec ren env (id_phi0,(cphi,r,a)) idf bl (te,ce) c = + let (_,ef,p,q) = c in + let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in + let wf_a_r = Term.applist (constant "well_founded", [a; r]) in + + let before = current_date ren in + let al = current_vars ren (get_reads ef) in + let v = + let _,lo = input_output ren env c in + let q = abstract_post ren env (ef,q) in + arrow ren env (product ren env (current_date ren) lo q) p + in + let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren)) v in + let v = + n_mkNamedProd v + (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al) + in + let v = + n_mkNamedProd v + (List.map (function (id,CC_typed_binder c) -> (id,c) + | _ -> assert false) (List.rev bl)) + in + let tw = + Term.mkNamedProd id_phi a + (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v) + in + let vars = List.rev (current_vars ren (get_reads ef)) in + let body = + let al = current_vars ren (get_reads ef) in + let bod = abs_pre ren env (te,v) p in + let bod = CC_lam ([var_name Anonymous, + CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren))], + bod) + in + let bl' = binding_of_alist ren env al in + make_abs (bl@(List.rev bl')) bod + in + let t = + CC_app (CC_expr (constant "well_founded_induction"), + [CC_expr a; CC_expr r; + CC_hole wf_a_r; + CC_expr (Term.mkNamedLambda id_phi a v); + CC_lam ([id_phi0, CC_typed_binder a; + idf, CC_typed_binder tw], + body); + CC_expr (phi_of ren)] + @(List.map (fun (id,_) -> CC_var id) bl) + @(List.map (fun (_,id) -> CC_var id) vars) + @[CC_hole (eq a (phi_of ren) (phi_of ren))] + ) + in + (* on abstrait juste par rapport aux variables de ef *) + let al = current_vars ren (get_reads ef) in + let bl = binding_of_alist ren env al in + make_abs (List.rev bl) t + + +(* [make_access env id c] Access in array id. + * + * Constructs [t:(array s T)](access_g s T t c ?::(lt c s)). + *) + +let array_info ren env id = + let ty = type_in_env env id in + let size,v = dearray_type ty in + let ty_elem = trad_ml_type_v ren env v in + let ty_array = trad_imp_type ren env ty in + size,ty_elem,ty_array + +let make_raw_access ren env (id,id') c = + let size,ty_elem,_ = array_info ren env id in + Term.applist (constant "access", [size; ty_elem; mkVar id'; c]) + +let make_pre_access ren env id c = + let size,_,_ = array_info ren env id in + conj (lt (constant "Zle") (constant "ZERO") c) + (lt (constant "Zlt") c size) + +let make_raw_store ren env (id,id') c1 c2 = + let size,ty_elem,_ = array_info ren env id in + Term.applist (constant "store", [size; ty_elem; mkVar id'; c1; c2]) diff --git a/contrib/correctness/pmonad.mli b/contrib/correctness/pmonad.mli new file mode 100644 index 00000000..e1400fcb --- /dev/null +++ b/contrib/correctness/pmonad.mli @@ -0,0 +1,106 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pmonad.mli,v 1.1.16.1 2004/07/16 19:30:02 herbelin Exp $ *) + +open Names +open Term + +open Ptype +open Past +open Penv + +(* Main part of the translation of imperative programs into functional ones + * (with mlise.ml) *) + +(* Here we translate the specification into a CIC specification *) + +val trad_ml_type_v : Prename.t -> local_env -> type_v -> constr +val trad_ml_type_c : Prename.t -> local_env -> type_c -> constr +val trad_imp_type : Prename.t -> local_env -> type_v -> constr +val trad_type_in_env : Prename.t -> local_env -> identifier -> constr + +val binding_of_alist : Prename.t -> local_env + -> (identifier * identifier) list + -> cc_binder list +val make_abs : cc_binder list -> cc_term -> cc_term +val abs_pre : Prename.t -> local_env -> cc_term * constr -> + constr precondition list -> cc_term + +(* The following functions translate the main constructions *) + +val make_tuple : (cc_term * cc_type) list -> predicate option + -> Prename.t -> local_env -> string + -> cc_term + +val result_tuple : Prename.t -> string -> local_env + -> (cc_term * constr) -> (Peffect.t * predicate option) + -> cc_term * constr + +val let_in_pre : constr -> constr precondition -> cc_term -> cc_term + +val make_let_in : Prename.t -> local_env -> cc_term + -> constr precondition list + -> ((identifier * identifier) list * predicate option) + -> identifier * constr + -> cc_term * constr -> cc_term + +val make_block : Prename.t -> local_env + -> (Prename.t -> (identifier * constr) option -> cc_term * constr) + -> (cc_term * type_c, constr) block + -> cc_term + +val make_app : local_env + -> Prename.t -> (cc_term * type_c) list + -> Prename.t -> cc_term * type_c + -> ((type_v binder list) * type_c) + * ((identifier*identifier) list) + * type_c + -> type_c + -> cc_term + +val make_if : Prename.t -> local_env + -> cc_term * type_c + -> Prename.t + -> cc_term * type_c + -> cc_term * type_c + -> type_c + -> cc_term + +val make_while : Prename.t -> local_env + -> (constr * constr * constr) (* typed variant *) + -> cc_term * type_c + -> (cc_term * type_c, constr) block + -> constr assertion option * type_c + -> cc_term + +val make_letrec : Prename.t -> local_env + -> (identifier * (constr * constr * constr)) (* typed variant *) + -> identifier (* the name of the function *) + -> (cc_binder list) + -> (cc_term * type_c) + -> type_c + -> cc_term + +(* Functions to translate array operations *) + +val array_info : + Prename.t -> local_env -> identifier -> constr * constr * constr + +val make_raw_access : + Prename.t -> local_env -> identifier * identifier -> constr -> constr + +val make_raw_store : + Prename.t -> local_env -> identifier * identifier + -> constr -> constr -> constr + +val make_pre_access : + Prename.t -> local_env -> identifier -> constr -> constr + diff --git a/contrib/correctness/pred.ml b/contrib/correctness/pred.ml new file mode 100644 index 00000000..732dcf08 --- /dev/null +++ b/contrib/correctness/pred.ml @@ -0,0 +1,115 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pred.ml,v 1.6.14.1 2004/07/16 19:30:05 herbelin Exp $ *) + +open Pp +open Past +open Pmisc + +let rec cc_subst subst = function + | CC_var id as c -> + (try CC_expr (List.assoc id subst) with Not_found -> c) + | CC_letin (b,ty,bl,c1,c2) -> + CC_letin (b, real_subst_in_constr subst ty, cc_subst_binders subst bl, + cc_subst subst c1, cc_subst (cc_cross_binders subst bl) c2) + | CC_lam (bl, c) -> + CC_lam (cc_subst_binders subst bl, + cc_subst (cc_cross_binders subst bl) c) + | CC_app (c, cl) -> + CC_app (cc_subst subst c, List.map (cc_subst subst) cl) + | CC_tuple (b, tl, cl) -> + CC_tuple (b, List.map (real_subst_in_constr subst) tl, + List.map (cc_subst subst) cl) + | CC_case (ty, c, cl) -> + CC_case (real_subst_in_constr subst ty, cc_subst subst c, + List.map (cc_subst subst) cl) + | CC_expr c -> + CC_expr (real_subst_in_constr subst c) + | CC_hole ty -> + CC_hole (real_subst_in_constr subst ty) + +and cc_subst_binders subst = List.map (cc_subst_binder subst) + +and cc_subst_binder subst = function + | id,CC_typed_binder c -> id,CC_typed_binder (real_subst_in_constr subst c) + | b -> b + +and cc_cross_binders subst = function + | [] -> subst + | (id,_) :: bl -> cc_cross_binders (List.remove_assoc id subst) bl + +(* here we only perform eta-reductions on programs to eliminate + * redexes of the kind + * + * let (x1,...,xn) = e in (x1,...,xn) --> e + * + *) + +let is_eta_redex bl al = + try + List.for_all2 + (fun (id,_) t -> match t with CC_var id' -> id=id' | _ -> false) + bl al + with + Invalid_argument("List.for_all2") -> false + +let rec red = function + | CC_letin (_, _, [id,_], CC_expr c1, e2) -> + red (cc_subst [id,c1] e2) + | CC_letin (dep, ty, bl, e1, e2) -> + begin match red e2 with + | CC_tuple (false,tl,al) -> + if is_eta_redex bl al then + red e1 + else + CC_letin (dep, ty, bl, red e1, + CC_tuple (false,tl,List.map red al)) + | e -> CC_letin (dep, ty, bl, red e1, e) + end + | CC_lam (bl, e) -> + CC_lam (bl, red e) + | CC_app (e, al) -> + CC_app (red e, List.map red al) + | CC_case (ty, e1, el) -> + CC_case (ty, red e1, List.map red el) + | CC_tuple (dep, tl, al) -> + CC_tuple (dep, tl, List.map red al) + | e -> e + + +(* How to reduce uncomplete proof terms when they have become constr *) + +open Term +open Reductionops + +(* Il ne faut pas reduire de redexe (beta/iota) qui impliquerait + * la substitution d'une métavariable. + * + * On commence par rendre toutes les applications binaire (strong bin_app) + * puis on applique la reduction spéciale programmes définie dans + * typing/reduction *) + +(*i +let bin_app = function + | DOPN(AppL,v) as c -> + (match Array.length v with + | 1 -> v.(0) + | 2 -> c + | n -> + let f = DOPN(AppL,Array.sub v 0 (pred n)) in + DOPN(AppL,[|f;v.(pred n)|])) + | c -> c +i*) + +let red_cci c = + (*i let c = strong bin_app c in i*) + strong whd_programs (Global.env ()) Evd.empty c + diff --git a/contrib/correctness/pred.mli b/contrib/correctness/pred.mli new file mode 100644 index 00000000..2f43f4ad --- /dev/null +++ b/contrib/correctness/pred.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 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pred.mli,v 1.1.16.1 2004/07/16 19:30:05 herbelin Exp $ *) + +open Term +open Past + +(* reduction on intermediate programs + * get rid of redexes of the kind let (x1,...,xn) = e in (x1,...,xn) *) + +val red : cc_term -> cc_term + + +(* Ad-hoc reduction on partial proof terms *) + +val red_cci : constr -> constr + + diff --git a/contrib/correctness/prename.ml b/contrib/correctness/prename.ml new file mode 100644 index 00000000..864f6abd --- /dev/null +++ b/contrib/correctness/prename.ml @@ -0,0 +1,139 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: prename.ml,v 1.3.14.1 2004/07/16 19:30:05 herbelin Exp $ *) + +open Names +open Nameops +open Util +open Pp +open Himsg +open Pmisc + +(* Variables names management *) + +type date = string + +(* The following data structure keeps the successive names of the variables + * as we traverse the program. A each step a ``date'' and a + * collection of new names is (possibly) given, and updates the + * previous renaming. + * + * Then, we can ask for the name of a variable, at current date or + * at a given date. + * + * It is easily represented by a list of date x assoc list, most recent coming + * first i.e. as follows: + * + * [ date (= current), [ (x,xi); ... ]; + * date , [ (z,zk); ... ]; + * ... + * date (= initial), [ (x,xj); (y,yi); ... ] + * + * We also keep a list of all names already introduced, in order to + * quickly get fresh names. + *) + +type t = + { levels : (date * (identifier * identifier) list) list; + avoid : identifier list; + cpt : int } + + +let empty_ren = { levels = []; avoid = []; cpt = 0 } + +let update r d ids = + let al,av = renaming_of_ids r.avoid ids in + { levels = (d,al) :: r.levels; avoid = av; cpt = r.cpt } + +let push_date r d = update r d [] + +let next r ids = + let al,av = renaming_of_ids r.avoid ids in + let n = succ r.cpt in + let d = string_of_int n in + { levels = (d,al) :: r.levels; avoid = av; cpt = n } + + +let find r x = + let rec find_in_one = function + [] -> raise Not_found + | (y,v)::rem -> if y = x then v else find_in_one rem + in + let rec find_in_all = function + [] -> raise Not_found + | (_,l)::rem -> try find_in_one l with Not_found -> find_in_all rem + in + find_in_all r.levels + + +let current_var = find + +let current_vars r ids = List.map (fun id -> id,current_var r id) ids + + +let avoid r ids = { levels = r.levels; avoid = r.avoid @ ids; cpt = r.cpt } + +let fresh r ids = fst (renaming_of_ids r.avoid ids) + + +let current_date r = + match r.levels with + [] -> invalid_arg "Renamings.current_date" + | (d,_)::_ -> d + +let all_dates r = List.map fst r.levels + +let rec valid_date da r = + let rec valid = function + [] -> false + | (d,_)::rem -> (d=da) or (valid rem) + in + valid r.levels + +(* [until d r] selects the part of the renaming [r] starting from date [d] *) +let rec until da r = + let rec cut = function + [] -> invalid_arg "Renamings.until" + | (d,_)::rem as r -> if d=da then r else cut rem + in + { avoid = r.avoid; levels = cut r.levels; cpt = r.cpt } + +let var_at_date r d id = + try + find (until d r) id + with Not_found -> + raise (UserError ("Renamings.var_at_date", + hov 0 (str"Variable " ++ pr_id id ++ str" is unknown" ++ spc () ++ + str"at date " ++ str d))) + +let vars_at_date r d ids = + let r' = until d r in List.map (fun id -> id,find r' id) ids + + +(* pretty-printers *) + +open Pp +open Util +open Himsg + +let pp r = + hov 2 (prlist_with_sep (fun () -> (fnl ())) + (fun (d,l) -> + (str d ++ str": " ++ + prlist_with_sep (fun () -> (spc ())) + (fun (id,id') -> + (str"(" ++ pr_id id ++ str"," ++ pr_id id' ++ str")")) + l)) + r.levels) + +let ppr e = + Pp.pp (pp e) + diff --git a/contrib/correctness/prename.mli b/contrib/correctness/prename.mli new file mode 100644 index 00000000..88b49d2c --- /dev/null +++ b/contrib/correctness/prename.mli @@ -0,0 +1,57 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: prename.mli,v 1.1.16.1 2004/07/16 19:30:05 herbelin Exp $ *) + +open Names + +(* Abstract type for renamings + * + * Records the names of the mutables objets (ref, arrays) at the different + * moments of the evaluation, called dates + *) + +type t + +type date = string + + +val empty_ren : t +val update : t -> date -> identifier list -> t + (* assign new names for the given variables, associated to a new date *) +val next : t -> identifier list -> t + (* assign new names for the given variables, associated to a new + * date which is generated from an internal counter *) +val push_date : t -> date -> t + (* put a new date on top of the stack *) + +val valid_date : date -> t -> bool +val current_date : t -> date +val all_dates : t -> date list + +val current_var : t -> identifier -> identifier +val current_vars : t -> identifier list -> (identifier * identifier) list + (* gives the current names of some variables *) + +val avoid : t -> identifier list -> t +val fresh : t -> identifier list -> (identifier * identifier) list + (* introduces new names to avoid and renames some given variables *) + +val var_at_date : t -> date -> identifier -> identifier + (* gives the name of a variable at a given date *) +val vars_at_date : t -> date -> identifier list + -> (identifier * identifier) list + (* idem for a list of variables *) + +(* pretty-printers *) + +val pp : t -> Pp.std_ppcmds +val ppr : t -> unit + diff --git a/contrib/correctness/preuves.v b/contrib/correctness/preuves.v new file mode 100644 index 00000000..33659b43 --- /dev/null +++ b/contrib/correctness/preuves.v @@ -0,0 +1,128 @@ + +(* Quelques preuves sur des programmes simples, + * juste histoire d'avoir un petit bench. + *) + +Require Correctness. +Require Omega. + +Global Variable x : Z ref. +Global Variable y : Z ref. +Global Variable z : Z ref. +Global Variable i : Z ref. +Global Variable j : Z ref. +Global Variable n : Z ref. +Global Variable m : Z ref. +Variable r : Z. +Variable N : Z. +Global Variable t : array N of Z. + +(**********************************************************************) + +Require Exchange. +Require ArrayPermut. + +Correctness swap + fun (N:Z)(t:array N of Z)(i,j:Z) -> + { `0 <= i < N` /\ `0 <= j < N` } + (let v = t[i] in + begin + t[i] := t[j]; + t[j] := v + end) + { (exchange t t@ i j) }. +Proof. +Auto with datatypes. +Save. + +Correctness downheap + let rec downheap (N:Z)(t:array N of Z) : unit { variant `0` } = + (swap N t 0 0) { True } +. + +(**********************************************************************) + +Global Variable x : Z ref. +Debug on. +Correctness assign0 (x := 0) { `x=0` }. +Save. + +(**********************************************************************) + +Global Variable i : Z ref. +Debug on. +Correctness assign1 { `0 <= i` } (i := !i + 1) { `0 < i` }. +Omega. +Save. + +(**********************************************************************) + +Global Variable i : Z ref. +Debug on. +Correctness if0 { `0 <= i` } (if !i>0 then i:=!i-1 else tt) { `0 <= i` }. +Omega. +Save. + +(**********************************************************************) + +Global Variable i : Z ref. +Debug on. +Correctness assert0 { `0 <= i` } begin assert { `i=2` }; i:=!i-1 end { `i=1` }. + +(**********************************************************************) + +Correctness echange + { `0 <= i < N` /\ `0 <= j < N` } + begin + label B; + x := t[!i]; t[!i] := t[!j]; t[!j] := !x; + assert { #t[i] = #t@B[j] /\ #t[j] = #t@B[i] } + end. +Proof. +Auto with datatypes. +Save. + + +(**********************************************************************) + +(* + * while x <= y do x := x+1 done { y < x } + *) + +Correctness incrementation + while !x < !y do + { invariant True variant `(Zs y)-x` } + x := !x + 1 + done + { `y < x` }. +Proof. +Exact (Zwf_well_founded `0`). +Unfold Zwf. Omega. +Exact I. +Save. + + +(************************************************************************) + +Correctness pivot1 + begin + while (Z_lt_ge_dec !i r) do + { invariant True variant (Zminus (Zs r) i) } i := (Zs !i) + done; + while (Z_lt_ge_dec r !j) do + { invariant True variant (Zminus (Zs j) r) } j := (Zpred !j) + done + end + { `j <= r` /\ `r <= i` }. +Proof. +Exact (Zwf_well_founded `0`). +Unfold Zwf. Omega. +Exact I. +Exact (Zwf_well_founded `0`). +Unfold Zwf. Unfold Zpred. Omega. +Exact I. +Omega. +Save. + + + diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4 new file mode 100644 index 00000000..c1f00a3d --- /dev/null +++ b/contrib/correctness/psyntax.ml4 @@ -0,0 +1,1058 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: psyntax.ml4,v 1.29.2.1 2004/07/16 19:30:05 herbelin Exp $ *) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +open Options +open Util +open Names +open Nameops +open Vernacentries +open Reduction +open Term +open Libnames +open Topconstr + +open Prename +open Pmisc +open Putil +open Ptype +open Past +open Penv +open Pmonad +open Vernacexpr + + +(* We define new entries for programs, with the use of this module + * Programs. These entries are named Programs.<foo> + *) + +module Gram = Pcoq.Gram +module Constr = Pcoq.Constr +module Tactic = Pcoq.Tactic + +module Programs = + struct + let gec s = Gram.Entry.create ("Programs."^s) + (* types *) + let type_v = gec "type_v" + let type_v0 = gec "type_v0" + let type_v1 = gec "type_v1" + let type_v2 = gec "type_v2" + let type_v3 = gec "type_v3" + let type_v_app = gec "type_v_app" + let type_c = gec "type_c" + let effects = gec "effects" + let reads = gec "reads" + let writes = gec "writes" + let pre_condition = gec "pre_condition" + let post_condition = gec "post_condition" + (* binders *) + let binder = gec "binder" + let binder_type = gec "binder_type" + let binders = gec "binders" + (* programs *) + let program = gec "program" + let prog1 = gec "prog1" + let prog2 = gec "prog2" + let prog3 = gec "prog3" + let prog4 = gec "prog4" + let prog5 = gec "prog5" + let prog6 = gec "prog6" + let prog7 = gec "prog7" + let ast1 = gec "ast1" + let ast2 = gec "ast2" + let ast3 = gec "ast3" + let ast4 = gec "ast4" + let ast5 = gec "ast5" + let ast6 = gec "ast6" + let ast7 = gec "ast7" + let arg = gec "arg" + let block = gec "block" + let block_statement = gec "block_statement" + let relation = gec "relation" + let variable = gec "variable" + let invariant = gec "invariant" + let variant = gec "variant" + let assertion = gec "assertion" + let precondition = gec "precondition" + let postcondition = gec "postcondition" + let predicate = gec "predicate" + let name = gec "name" + end + +open Programs + +let ast_of_int n = + CDelimiters + (dummy_loc, "Z", CNumeral (dummy_loc, Bignat.POS (Bignat.of_string n))) + +let constr_of_int n = + Constrintern.interp_constr Evd.empty (Global.env ()) (ast_of_int n) + +open Util +open Coqast + +let mk_id loc id = mkRefC (Ident (loc, id)) +let mk_ref loc s = mk_id loc (Constrextern.id_of_v7_string s) +let mk_appl loc1 loc2 f args = + CApp (join_loc loc1 loc2, (None,mk_ref loc1 f), List.map (fun a -> a,None) args) + +let conj_assert {a_name=n;a_value=a} {a_value=b} = + let loc1 = constr_loc a in + let loc2 = constr_loc a in + { a_value = mk_appl loc1 loc2 "and" [a;b]; a_name = n } + +let conj = function + None,None -> None + | None,b -> b + | a,None -> a + | Some a,Some b -> Some (conj_assert a b) + +let without_effect loc d = + { desc = d; pre = []; post = None; loc = loc; info = () } + +let isevar = Expression isevar + +let bin_op op loc e1 e2 = + without_effect loc + (Apply (without_effect loc (Expression (constant op)), + [ Term e1; Term e2 ])) + +let un_op op loc e = + without_effect loc + (Apply (without_effect loc (Expression (constant op)), [Term e])) + +let bool_bin op loc a1 a2 = + let w = without_effect loc in + let d = SApp ( [Variable op], [a1; a2]) in + w d + +let bool_or loc = bool_bin connective_or loc +let bool_and loc = bool_bin connective_and loc + +let bool_not loc a = + let w = without_effect loc in + let d = SApp ( [Variable connective_not ], [a]) in + w d + +let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "ZERO"] + +(* program -> Coq AST *) + +let bdize c = + let env = + Global.env_of_context (Pcicenv.cci_sign_of Prename.empty_ren Penv.empty) + in + Constrextern.extern_constr true env c + +let rec coqast_of_program loc = function + | Variable id -> mk_id loc id + | Acc id -> mk_id loc id + | Apply (f,l) -> + let f = coqast_of_program f.loc f.desc in + let args = List.map + (function Term t -> (coqast_of_program t.loc t.desc,None) + | _ -> invalid_arg "coqast_of_program") l + in + CApp (dummy_loc, (None,f), args) + | Expression c -> bdize c + | _ -> invalid_arg "coqast_of_program" + +(* The construction `for' is syntactic sugar. + * + * for i = v1 to v2 do { invariant Inv } block done + * + * ==> (let rec f i { variant v2+1-i } = + * { i <= v2+1 /\ Inv(i) } + * (if i > v2 then tt else begin block; (f (i+1)) end) + * { Inv(v2+1) } + * in (f v1)) { Inv(v2+1) } + *) + +let ast_plus_un loc ast = + let un = ast_of_int "1" in + mk_appl loc loc "Zplus" [ast;un] + +let make_ast_for loc i v1 v2 inv block = + let f = for_name() in + let id_i = id_of_string i in + let var_i = without_effect loc (Variable id_i) in + let var_f = without_effect loc (Variable f) in + let succ_v2 = + let a_v2 = coqast_of_program v2.loc v2.desc in + ast_plus_un loc a_v2 in + let post = named_app (subst_ast_in_ast [ id_i, succ_v2 ]) inv in + let e1 = + let test = bin_op "Z_gt_le_bool" loc var_i v2 in + let br_t = without_effect loc (Expression (constant "tt")) in + let br_f = + let un = without_effect loc (Expression (constr_of_int "1")) in + let succ_i = bin_op "Zplus" loc var_i un in + let f_succ_i = without_effect loc (Apply (var_f, [Term succ_i])) in + without_effect loc (Seq (block @ [Statement f_succ_i])) + in + let inv' = + let i_le_sv2 = mk_appl loc loc "Zle" [mk_ref loc i; succ_v2] in + conj_assert {a_value=i_le_sv2;a_name=inv.a_name} inv + in + { desc = If(test,br_t,br_f); loc = loc; + pre = [pre_of_assert false inv']; post = Some post; info = () } + in + let bl = + let typez = mk_ref loc "Z" in + [(id_of_string i, BindType (TypePure typez))] + in + let fv1 = without_effect loc (Apply (var_f, [Term v1])) in + let v = TypePure (mk_ref loc "unit") in + let var = + let a = mk_appl loc loc "Zminus" [succ_v2;mk_ref loc i] in + (a, ast_zwf_zero loc) + in + Let (f, without_effect loc (LetRec (f,bl,v,var,e1)), fv1) + +let mk_prog loc p pre post = + { desc = p.desc; + pre = p.pre @ pre; + post = conj (p.post,post); + loc = loc; + info = () } + +if !Options.v7 then +GEXTEND Gram + + (* Types ******************************************************************) + type_v: + [ [ t = type_v0 -> t ] ] + ; + type_v0: + [ [ t = type_v1 -> t ] ] + ; + type_v1: + [ [ t = type_v2 -> t ] ] + ; + type_v2: + [ LEFTA + [ v = type_v2; IDENT "ref" -> Ref v + | t = type_v3 -> t ] ] + ; + type_v3: + [ [ IDENT "array"; size = Constr.constr; "of"; v = type_v0 -> + Array (size,v) + | IDENT "fun"; bl = binders; c = type_c -> make_arrow bl c + | c = Constr.constr -> TypePure c + ] ] + ; + type_c: + [ [ IDENT "returns"; id = IDENT; ":"; v = type_v; + e = effects; p = OPT pre_condition; q = OPT post_condition; "end" -> + ((id_of_string id, v), e, list_of_some p, q) + ] ] + ; + effects: + [ [ r = OPT reads; w = OPT writes -> + let r' = match r with Some l -> l | _ -> [] in + let w' = match w with Some l -> l | _ -> [] in + List.fold_left (fun e x -> Peffect.add_write x e) + (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r') + w' + ] ] + ; + reads: + [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ] + ; + writes: + [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ] + ; + pre_condition: + [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ] + ; + post_condition: + [ [ IDENT "post"; c = predicate -> c ] ] + ; + + (* Binders (for both types and programs) **********************************) + binder: + [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" -> + List.map (fun s -> (id_of_string s, t)) sl + ] ] + ; + binder_type: + [ [ "Set" -> BindSet + | v = type_v -> BindType v + ] ] + ; + binders: + [ [ bl = LIST0 binder -> List.flatten bl ] ] + ; + + (* annotations *) + predicate: + [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ] + ; + name: + [ [ "as"; s = IDENT -> Name (id_of_string s) + | -> Anonymous + ] ] + ; + + (* Programs ***************************************************************) + variable: + [ [ s = IDENT -> id_of_string s ] ] + ; + assertion: + [ [ "{"; c = predicate; "}" -> c ] ] + ; + precondition: + [ [ "{"; c = predicate; "}" -> pre_of_assert false c ] ] + ; + postcondition: + [ [ "{"; c = predicate; "}" -> c ] ] + ; + program: + [ [ p = prog1 -> p ] ] + ; + prog1: + [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog2: + [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog3: + [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog4: + [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog5: + [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog6: + [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + + ast1: + [ [ x = prog2; IDENT "or"; y = prog1 -> bool_or loc x y + | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y + | x = prog2 -> x + ] ] + ; + ast2: + [ [ IDENT "not"; x = prog3 -> bool_not loc x + | x = prog3 -> x + ] ] + ; + ast3: + [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y + | x = prog4 -> x + ] ] + ; + ast4: + [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y + | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y + | x = prog5 -> x + ] ] + ; + ast5: + [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y + | x = prog6 -> x + ] ] + ; + ast6: + [ [ "-"; x = prog6 -> un_op "Zopp" loc x + | x = ast7 -> without_effect loc x + ] ] + ; + ast7: + [ [ v = variable -> + Variable v + | n = INT -> + Expression (constr_of_int n) + | "!"; v = variable -> + Acc v + | "?" -> + isevar + | v = variable; ":="; p = program -> + Aff (v,p) + | v = variable; "["; e = program; "]" -> TabAcc (true,v,e) + | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e) + | v = variable; "["; e = program; "]"; ":="; p = program -> + TabAff (true,v,e,p) + | v = variable; "#"; "["; e = program; "]"; ":="; p = program -> + TabAff (true,v,e,p) + | IDENT "if"; e1 = program; IDENT "then"; e2 = program; + IDENT "else"; e3 = program -> + If (e1,e2,e3) + | IDENT "if"; e1 = program; IDENT "then"; e2 = program -> + If (e1,e2,without_effect loc (Expression (constant "tt"))) + | IDENT "while"; b = program; IDENT "do"; + "{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}"; + bl = block; IDENT "done" -> + While (b, inv, wf, bl) + | IDENT "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program; + IDENT "do"; "{"; inv = invariant; "}"; + bl = block; IDENT "done" -> + make_ast_for loc i v1 v2 inv bl + | IDENT "let"; v = variable; "="; IDENT "ref"; p1 = program; + "in"; p2 = program -> + LetRef (v, p1, p2) + | IDENT "let"; v = variable; "="; p1 = program; "in"; p2 = program -> + Let (v, p1, p2) + | IDENT "begin"; b = block; "end" -> + Seq b + | IDENT "fun"; bl = binders; "->"; p = program -> + Lam (bl,p) + | IDENT "let"; IDENT "rec"; f = variable; + bl = binders; ":"; v = type_v; + "{"; IDENT "variant"; var = variant; "}"; "="; p = program -> + LetRec (f,bl,v,var,p) + | IDENT "let"; IDENT "rec"; f = variable; + bl = binders; ":"; v = type_v; + "{"; IDENT "variant"; var = variant; "}"; "="; p = program; + "in"; p2 = program -> + Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2) + + | "@"; s = STRING; p = program -> + Debug (s,p) + + | "("; p = program; args = LIST0 arg; ")" -> + match args with + [] -> + if p.pre<>[] or p.post<>None then + Pp.warning "Some annotations are lost"; + p.desc + | _ -> + Apply(p,args) + ] ] + ; + arg: + [ [ "'"; t = type_v -> Type t + | p = program -> Term p + ] ] + ; + block: + [ [ s = block_statement; ";"; b = block -> s::b + | s = block_statement -> [s] ] ] + ; + block_statement: + [ [ IDENT "label"; s = IDENT -> Label s + | IDENT "assert"; c = assertion -> Assert c + | p = program -> Statement p ] ] + ; + relation: + [ [ "<" -> "Z_lt_ge_bool" + | "<=" -> "Z_le_gt_bool" + | ">" -> "Z_gt_le_bool" + | ">=" -> "Z_ge_lt_bool" + | "=" -> "Z_eq_bool" + | "<>" -> "Z_noteq_bool" ] ] + ; + + (* Other entries (invariants, etc.) ***************************************) + invariant: + [ [ IDENT "invariant"; c = predicate -> c ] ] + ; + variant: + [ [ c = Constr.constr; IDENT "for"; r = Constr.constr -> (c, r) + | c = Constr.constr -> (c, ast_zwf_zero loc) ] ] + ; + END +else +GEXTEND Gram + GLOBAL: type_v program; + + (* Types ******************************************************************) + type_v: + [ [ t = type_v0 -> t ] ] + ; + type_v0: + [ [ t = type_v1 -> t ] ] + ; + type_v1: + [ [ t = type_v2 -> t ] ] + ; + type_v2: + [ LEFTA + [ v = type_v2; IDENT "ref" -> Ref v + | t = type_v3 -> t ] ] + ; + type_v3: + [ [ IDENT "array"; size = Constr.constr; IDENT "of"; v = type_v0 -> + Array (size,v) + | "fun"; bl = binders; c = type_c -> make_arrow bl c + | c = Constr.constr -> TypePure c + ] ] + ; + type_c: + [ [ IDENT "returns"; id = IDENT; ":"; v = type_v; + e = effects; p = OPT pre_condition; q = OPT post_condition; "end" -> + ((id_of_string id, v), e, list_of_some p, q) + ] ] + ; + effects: + [ [ r = OPT reads; w = OPT writes -> + let r' = match r with Some l -> l | _ -> [] in + let w' = match w with Some l -> l | _ -> [] in + List.fold_left (fun e x -> Peffect.add_write x e) + (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r') + w' + ] ] + ; + reads: + [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ] + ; + writes: + [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ] + ; + pre_condition: + [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ] + ; + post_condition: + [ [ IDENT "post"; c = predicate -> c ] ] + ; + + (* Binders (for both types and programs) **********************************) + binder: + [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" -> + List.map (fun s -> (id_of_string s, t)) sl + ] ] + ; + binder_type: + [ [ "Set" -> BindSet + | v = type_v -> BindType v + ] ] + ; + binders: + [ [ bl = LIST0 binder -> List.flatten bl ] ] + ; + + (* annotations *) + predicate: + [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ] + ; + dpredicate: + [ [ c = Constr.lconstr; n = name -> { a_name = n; a_value = c } ] ] + ; + name: + [ [ "as"; s = IDENT -> Name (id_of_string s) + | -> Anonymous + ] ] + ; + + (* Programs ***************************************************************) + variable: + [ [ s = IDENT -> id_of_string s ] ] + ; + assertion: + [ [ "{"; c = dpredicate; "}" -> c ] ] + ; + precondition: + [ [ "{"; c = dpredicate; "}" -> pre_of_assert false c ] ] + ; + postcondition: + [ [ "{"; c = dpredicate; "}" -> c ] ] + ; + program: + [ [ p = prog1 -> p ] ] + ; + prog1: + [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog2: + [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog3: + [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog4: + [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog5: + [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + prog6: + [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition -> + mk_prog loc ast pre post ] ] + ; + + ast1: + [ [ x = prog2; IDENT "or"; y = prog1 -> bool_or loc x y + | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y + | x = prog2 -> x + ] ] + ; + ast2: + [ [ IDENT "not"; x = prog3 -> bool_not loc x + | x = prog3 -> x + ] ] + ; + ast3: + [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y + | x = prog4 -> x + ] ] + ; + ast4: + [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y + | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y + | x = prog5 -> x + ] ] + ; + ast5: + [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y + | x = prog6 -> x + ] ] + ; + ast6: + [ [ "-"; x = prog6 -> un_op "Zopp" loc x + | x = ast7 -> without_effect loc x + ] ] + ; + ast7: + [ [ v = variable -> + Variable v + | n = INT -> + Expression (constr_of_int n) + | "!"; v = variable -> + Acc v + | "?" -> + isevar + | v = variable; ":="; p = program -> + Aff (v,p) + | v = variable; "["; e = program; "]" -> TabAcc (true,v,e) + | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e) + | v = variable; "["; e = program; "]"; ":="; p = program -> + TabAff (true,v,e,p) + | v = variable; "#"; "["; e = program; "]"; ":="; p = program -> + TabAff (true,v,e,p) + | "if"; e1 = program; "then"; e2 = program; "else"; e3 = program -> + If (e1,e2,e3) + | "if"; e1 = program; "then"; e2 = program -> + If (e1,e2,without_effect loc (Expression (constant "tt"))) + | IDENT "while"; b = program; IDENT "do"; + "{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}"; + bl = block; IDENT "done" -> + While (b, inv, wf, bl) + | "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program; + IDENT "do"; "{"; inv = invariant; "}"; + bl = block; IDENT "done" -> + make_ast_for loc i v1 v2 inv bl + | "let"; v = variable; "="; IDENT "ref"; p1 = program; + "in"; p2 = program -> + LetRef (v, p1, p2) + | "let"; v = variable; "="; p1 = program; "in"; p2 = program -> + Let (v, p1, p2) + | IDENT "begin"; b = block; "end" -> + Seq b + | "fun"; bl = binders; "=>"; p = program -> + Lam (bl,p) + | "let"; IDENT "rec"; f = variable; + bl = binders; ":"; v = type_v; + "{"; IDENT "variant"; var = variant; "}"; "="; p = program -> + LetRec (f,bl,v,var,p) + | "let"; IDENT "rec"; f = variable; + bl = binders; ":"; v = type_v; + "{"; IDENT "variant"; var = variant; "}"; "="; p = program; + "in"; p2 = program -> + Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2) + + | "@"; s = STRING; p = program -> + Debug (s,p) + + | "("; p = program; args = LIST0 arg; ")" -> + match args with + [] -> + if p.pre<>[] or p.post<>None then + Pp.warning "Some annotations are lost"; + p.desc + | _ -> + Apply(p,args) + ] ] + ; + arg: + [ [ "'"; t = type_v -> Type t + | p = program -> Term p + ] ] + ; + block: + [ [ s = block_statement; ";"; b = block -> s::b + | s = block_statement -> [s] ] ] + ; + block_statement: + [ [ IDENT "label"; s = IDENT -> Label s + | IDENT "assert"; c = assertion -> Assert c + | p = program -> Statement p ] ] + ; + relation: + [ [ "<" -> "Z_lt_ge_bool" + | "<=" -> "Z_le_gt_bool" + | ">" -> "Z_gt_le_bool" + | ">=" -> "Z_ge_lt_bool" + | "=" -> "Z_eq_bool" + | "<>" -> "Z_noteq_bool" ] ] + ; + + (* Other entries (invariants, etc.) ***************************************) + invariant: + [ [ IDENT "invariant"; c = predicate -> c ] ] + ; + variant: + [ [ c = Constr.constr; "for"; r = Constr.constr -> (c, r) + | c = Constr.constr -> (c, ast_zwf_zero loc) ] ] + ; + END +;; + +let wit_program, globwit_program, rawwit_program = + Genarg.create_arg "program" +let wit_type_v, globwit_type_v, rawwit_type_v = + Genarg.create_arg "type_v" + +open Pp +open Util +open Himsg +open Vernacinterp +open Vernacexpr +open Declare + +let is_assumed global ids = + if List.length ids = 1 then + msgnl (str (if global then "A global variable " else "") ++ + pr_id (List.hd ids) ++ str " is assumed") + else + msgnl (str (if global then "Some global variables " else "") ++ + prlist_with_sep (fun () -> (str ", ")) pr_id ids ++ + str " are assumed") + +open Pcoq + +(* Variables *) + +let wit_variables, globwit_variables, rawwit_variables = + Genarg.create_arg "variables" + +let variables = Gram.Entry.create "Variables" + +GEXTEND Gram + variables: [ [ l = LIST1 Prim.ident SEP "," -> l ] ]; +END + +let pr_variables _prc _prtac l = spc() ++ prlist_with_sep pr_coma pr_id l + +let _ = + Pptactic.declare_extra_genarg_pprule true + (rawwit_variables, pr_variables) + (globwit_variables, pr_variables) + (wit_variables, pr_variables) + +(* then_tac *) + +open Genarg +open Tacinterp + +let pr_then_tac _ prt = function + | None -> mt () + | Some t -> pr_semicolon () ++ prt t + +ARGUMENT EXTEND then_tac + TYPED AS tactic_opt + PRINTED BY pr_then_tac + INTERPRETED BY interp_genarg + GLOBALIZED BY intern_genarg +| [ ";" tactic(t) ] -> [ Some t ] +| [ ] -> [ None ] +END + +(* Correctness *) + +VERNAC COMMAND EXTEND Correctness + [ "Correctness" preident(str) program(pgm) then_tac(tac) ] + -> [ Ptactic.correctness str pgm (option_app Tacinterp.interp tac) ] +END + +(* Show Programs *) + +let show_programs () = + fold_all + (fun (id,v) _ -> + msgnl (pr_id id ++ str " : " ++ + hov 2 (match v with TypeV v -> pp_type_v v + | Set -> (str "Set")) ++ + fnl ())) + Penv.empty () + +VERNAC COMMAND EXTEND ShowPrograms + [ "Show" "Programs" ] -> [ show_programs () ] +END + +(* Global Variable *) + +let global_variable ids v = + List.iter + (fun id -> if Penv.is_global id then + Util.errorlabstrm "PROGVARIABLE" + (str"Clash with previous constant " ++ pr_id id)) + ids; + Pdb.check_type_v (all_refs ()) v; + let env = empty in + let ren = update empty_ren "" [] in + let v = Ptyping.cic_type_v env ren v in + if not (is_mutable v) then begin + let c = + Entries.ParameterEntry (trad_ml_type_v ren env v), + Decl_kinds.IsAssumption Decl_kinds.Definitional in + List.iter + (fun id -> ignore (Declare.declare_constant id c)) ids; + if_verbose (is_assumed false) ids + end; + if not (is_pure v) then begin + List.iter (fun id -> ignore (Penv.add_global id v None)) ids; + if_verbose (is_assumed true) ids + end + +VERNAC COMMAND EXTEND ProgVariable + [ "Global" "Variable" variables(ids) ":" type_v(t) ] + -> [ global_variable ids t] +END + +let pr_id id = pr_id (Constrextern.v7_to_v8_id id) + +(* Type printer *) + +let pr_reads = function + | [] -> mt () + | l -> spc () ++ + hov 0 (str "reads" ++ spc () ++ prlist_with_sep pr_coma pr_id l) + +let pr_writes = function + | [] -> mt () + | l -> spc () ++ + hov 0 (str "writes" ++ spc () ++ prlist_with_sep pr_coma pr_id l) + +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 ++ + (match n with Name id -> spc () ++ str "as " ++ pr_id id | Anonymous -> mt()) + +let pr_assert b { p_name = x; p_value = v } = + pr_predicate b { a_name = x; a_value = v } + +let pr_pre_condition_list = function + | [] -> mt () + | [pre] -> spc() ++ hov 0 (str "pre" ++ spc () ++ pr_assert false pre) + | _ -> assert false + +let pr_post_condition_opt = function + | None -> mt () + | Some post -> + spc() ++ hov 0 (str "post" ++ spc () ++ pr_predicate false post) + +let rec pr_type_v_v8 = function + | Array (a,v) -> + str "array" ++ spc() ++ Ppconstrnew.pr_constr a ++ spc() ++ str "of " ++ + pr_type_v_v8 v + | v -> pr_type_v3 v + +and pr_type_v3 = function + | Ref v -> pr_type_v3 v ++ spc () ++ str "ref" + | Arrow (bl,((id,v),e,prel,postl)) -> + str "fun" ++ spc() ++ hov 0 (prlist_with_sep cut pr_binder bl) ++ + spc () ++ str "returns" ++ spc () ++ pr_id id ++ str ":" ++ + 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 + | v -> str "(" ++ pr_type_v_v8 v ++ str ")" + +and pr_binder = function + | (id,BindType c) -> + str "(" ++ pr_id id ++ str ":" ++ pr_type_v_v8 c ++ str ")" + | (id,BindSet) -> + str "(" ++ pr_id id ++ str ":" ++ str "Set" ++ str ")" + | (id,Untyped) -> + str "<<<<< TODO: Untyped binder >>>>" + +let _ = + Pptactic.declare_extra_genarg_pprule true + (rawwit_type_v, fun _ _ -> pr_type_v_v8) + (globwit_type_v, fun _ -> raise Not_found) + (wit_type_v, fun _ -> raise Not_found) + +(* Program printer *) + +let pr_precondition pred = str "{" ++ pr_assert true pred ++ str "}" ++ spc () + +let pr_postcondition pred = str "{" ++ pr_predicate true pred ++ str "}" + +let pr_invariant = function + | None -> mt () + | Some c -> hov 2 (str "invariant" ++ spc () ++ pr_predicate false c) + +let pr_variant (c1,c2) = + Ppconstrnew.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)) + +let rec pr_desc = function + | Variable id -> + (* Unsafe: should distinguish global names and bound vars *) + let vars = (* TODO *) Idset.empty in + let id = try + snd (repr_qualid + (snd (qualid_of_reference + (Constrextern.extern_reference + dummy_loc vars (Nametab.locate (make_short_qualid id)))))) + with _ -> id in + pr_id id + | Acc id -> str "!" ++ pr_id id + | Aff (id,p) -> pr_id id ++ spc() ++ str ":=" ++ spc() ++ pr_prog p + | TabAcc (b,id,p) -> pr_id id ++ str "[" ++ pr_prog p ++ str "]" + | TabAff (b,id,p1,p2) -> + pr_id id ++ str "[" ++ pr_prog p1 ++ str "]" ++ + str ":=" ++ pr_prog p2 + | Seq bll -> + hv 0 (str "begin" ++ spc () ++ pr_block bll ++ spc () ++ str "end") + | While (p1,inv,var,bll) -> + hv 0 ( + hov 0 (str "while" ++ spc () ++ pr_prog p1 ++ spc () ++ str "do") ++ + brk (1,2) ++ + hv 2 ( + str "{ " ++ + pr_invariant inv ++ spc() ++ + hov 0 (str "variant" ++ spc () ++ pr_variant var) + ++ str " }") ++ cut () ++ + hov 0 (pr_block bll) ++ cut () ++ + str "done") + | If (p1,p2,p3) -> + hov 1 (str "if " ++ pr_prog p1) ++ spc () ++ + hov 0 (str "then" ++ spc () ++ pr_prog p2) ++ spc () ++ + hov 0 (str "else" ++ spc () ++ pr_prog p3) + | Lam (bl,p) -> + hov 0 + (str "fun" ++ spc () ++ hov 0 (prlist_with_sep cut pr_binder bl) ++ + spc () ++ str "=>") ++ + pr_prog p + | Apply ({desc=Expression e; pre=[]; post=None} as p,args) when isConst e -> + begin match + string_of_id (snd (repr_path (Nametab.sp_of_global (ConstRef (destConst e))))), + args + with + | "Zmult", [a1;a2] -> + str "(" ++ pr_arg a1 ++ str"*" ++ pr_arg a2 ++ str ")" + | "Zplus", [a1;a2] -> + str "(" ++ pr_arg a1 ++ str"+" ++ pr_arg a2 ++ str ")" + | "Zminus", [a1;a2] -> + str "(" ++ pr_arg a1 ++ str"-" ++ pr_arg a2 ++ str ")" + | "Zopp", [a] -> + str "( -" ++ pr_arg a ++ str ")" + | "Z_lt_ge_bool", [a1;a2] -> + str "(" ++ pr_arg a1 ++ str"<" ++ pr_arg a2 ++ str ")" + | "Z_le_gt_bool", [a1;a2] -> + str "(" ++ pr_arg a1 ++ str"<=" ++ pr_arg a2 ++ str ")" + | "Z_gt_le_bool", [a1;a2] -> + str "(" ++ pr_arg a1 ++ str">" ++ pr_arg a2 ++ str ")" + | "Z_ge_lt_bool", [a1;a2] -> + str "(" ++ pr_arg a1 ++ str">=" ++ pr_arg a2 ++ str ")" + | "Z_eq_bool", [a1;a2] -> + str "(" ++ pr_arg a1 ++ str"=" ++ pr_arg a2 ++ str ")" + | "Z_noteq_bool", [a1;a2] -> + str "(" ++ pr_arg a1 ++ str"<> " ++ pr_arg a2 ++ str ")" + | _ -> + str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++ + str ")" + end + | Apply (p,args) -> + str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++ + str ")" + | SApp ([Variable v], args) -> + begin match string_of_id v, args with + | "prog_bool_and", [a1;a2] -> + str"(" ++ pr_prog a1 ++ spc() ++ str"and " ++ pr_prog a2 ++str")" + | "prog_bool_or", [a1;a2] -> + str"(" ++ pr_prog a1 ++ spc() ++ str"or " ++ pr_prog a2 ++ str")" + | "prog_bool_not", [a] -> + str "(not " ++ pr_prog a ++ str ")" + | _ -> failwith "Correctness printer: TODO" + end + | SApp _ -> failwith "Correctness printer: TODO" + | LetRef (v,p1,p2) -> + hov 2 ( + str "let " ++ pr_id v ++ str " =" ++ spc () ++ str "ref" ++ spc () ++ + pr_prog p1 ++ str " in") ++ + spc () ++ pr_prog p2 + | Let (id, {desc=LetRec (f,bl,v,var,p); pre=[]; post=None },p2) when f=id -> + hov 2 ( + str "let rec " ++ pr_id f ++ spc () ++ + hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++ + str ":" ++ pr_type_v_v8 v ++ spc () ++ + hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++ + spc() ++ str "=" ++ spc () ++ pr_prog p ++ + str " in") ++ + spc () ++ pr_prog p2 + | Let (v,p1,p2) -> + hov 2 ( + str "let " ++ pr_id v ++ str " =" ++ spc () ++ pr_prog p1 ++ str" in") + ++ spc () ++ pr_prog p2 + | LetRec (f,bl,v,var,p) -> + str "let rec " ++ pr_id f ++ spc () ++ + hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++ + str ":" ++ pr_type_v_v8 v ++ spc () ++ + hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++ + spc () ++ str "=" ++ spc () ++ pr_prog p + | PPoint _ -> str "TODO: Ppoint" (* Internal use only *) + | Expression c -> + (* 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 + +and pr_block_st = function + | Label s -> hov 0 (str "label" ++ spc() ++ str s) + | Assert pred -> + hov 0 (str "assert" ++ spc() ++ hov 0 (pr_postcondition pred)) + | Statement p -> pr_prog p + +and pr_block bl = prlist_with_sep pr_semicolon pr_block_st bl + +and pr_arg = function + | Past.Term p -> pr_prog p + | Past.Type t -> str "'" ++ pr_type_v_v8 t + | Refarg _ -> str "TODO: Refarg" (* Internal use only *) + +and pr_prog0 b { desc = desc; pre = pre; post = post } = + hv 0 ( + prlist pr_precondition pre ++ + hov 0 + (if b & post<>None then str"(" ++ pr_desc desc ++ str")" + else pr_desc desc) + ++ Ppconstrnew.pr_opt pr_postcondition post) + +and pr_prog x = pr_prog0 true x + +let _ = + Pptactic.declare_extra_genarg_pprule true + (rawwit_program, fun _ _ a -> spc () ++ pr_prog0 false a) + (globwit_program, fun _ -> raise Not_found) + (wit_program, fun _ -> raise Not_found) + diff --git a/contrib/correctness/psyntax.mli b/contrib/correctness/psyntax.mli new file mode 100644 index 00000000..18912548 --- /dev/null +++ b/contrib/correctness/psyntax.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: psyntax.mli,v 1.3.2.1 2004/07/16 19:30:06 herbelin Exp $ *) + +open Pcoq +open Ptype +open Past +open Topconstr + +(* Grammar for the programs and the tactic Correctness *) + +module Programs : + sig + val program : program Gram.Entry.e + val type_v : constr_expr ml_type_v Gram.Entry.e + val type_c : constr_expr ml_type_c Gram.Entry.e + end diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml new file mode 100644 index 00000000..4b22954e --- /dev/null +++ b/contrib/correctness/ptactic.ml @@ -0,0 +1,258 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: ptactic.ml,v 1.30.2.1 2004/07/16 19:30:06 herbelin Exp $ *) + +open Pp +open Options +open Names +open Libnames +open Term +open Pretyping +open Pfedit +open Decl_kinds +open Vernacentries + +open Pmisc +open Putil +open Past +open Penv +open Prename +open Peffect +open Pmonad + +(* [coqast_of_prog: program -> constr * constr] + * Traduction d'un programme impératif en un but (second constr) + * et un terme de preuve partiel pour ce but (premier constr) + *) + +let coqast_of_prog p = + (* 1. db : séparation dB/var/const *) + let p = Pdb.db_prog p in + + (* 2. typage avec effets *) + deb_mess (str"Ptyping.states: Typing with effects..." ++ fnl ()); + let env = Penv.empty in + let ren = initial_renaming env in + let p = Ptyping.states ren env p in + let ((_,v),_,_,_) as c = p.info.kappa in + Perror.check_for_not_mutable p.loc v; + deb_print pp_type_c c; + + (* 3. propagation annotations *) + let p = Pwp.propagate ren p in + + (* 4a. traduction type *) + let ty = Pmonad.trad_ml_type_c ren env c in + deb_print (Printer.prterm_env (Global.env())) ty; + + (* 4b. traduction terme (terme intermédiaire de type cc_term) *) + deb_mess + (fnl () ++ str"Mlize.trad: Translation program -> cc_term..." ++ fnl ()); + let cc = Pmlize.trans ren p in + let cc = Pred.red cc in + deb_print Putil.pp_cc_term cc; + + (* 5. traduction en constr *) + deb_mess + (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; + + (* 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); + + p,oc,ty,v + +(* [automatic : tactic] + * + * Certains buts engendrés par "correctness" (ci-dessous) + * sont réellement triviaux. On peut les résoudre aisément, sans pour autant + * tomber dans la solution trop lourde qui consiste à faire "; Auto." + * + * Cette tactique fait les choses suivantes : + * o elle élimine les hypothèses de nom loop<i> + * o sur G |- (well_founded nat lt) ==> Exact lt_wf. + * o sur G |- (well_founded Z (Zwf c)) ==> Exact (Zwf_well_founded c) + * o sur G |- e = e' ==> Reflexivity. (arg. de decr. des boucles) + * sinon Try Assumption. + * o sur G |- P /\ Q ==> Try (Split; Assumption). (sortie de boucle) + * o sinon, Try AssumptionBis (= Assumption + décomposition /\ dans hyp.) + * (pour entrée dans corps de boucle par ex.) + *) + +open Pattern +open Tacmach +open Tactics +open Tacticals +open Equality +open Nametab + +let nat = IndRef (coq_constant ["Init";"Datatypes"] "nat", 0) +let lt = ConstRef (coq_constant ["Init";"Peano"] "lt") +let well_founded = ConstRef (coq_constant ["Init";"Wf"] "well_founded") +let z = IndRef (coq_constant ["ZArith";"BinInt"] "Z", 0) +let and_ = IndRef (coq_constant ["Init";"Logic"] "and", 0) +let eq = IndRef (coq_constant ["Init";"Logic"] "eq", 0) + +let mkmeta n = Nameops.make_ident "X" (Some n) +let mkPMeta n = PMeta (Some (mkmeta n)) + +(* ["(well_founded nat lt)"] *) +let wf_nat_pattern = + PApp (PRef well_founded, [| PRef nat; PRef lt |]) +(* ["((well_founded Z (Zwf ?1))"] *) +let wf_z_pattern = + let zwf = ConstRef (coq_constant ["ZArith";"Zwf"] "Zwf") in + PApp (PRef well_founded, [| PRef z; PApp (PRef zwf, [| mkPMeta 1 |]) |]) +(* ["(and ?1 ?2)"] *) +let and_pattern = + PApp (PRef and_, [| mkPMeta 1; mkPMeta 2 |]) +(* ["(eq ?1 ?2 ?3)"] *) +let eq_pattern = + PApp (PRef eq, [| mkPMeta 1; mkPMeta 2; mkPMeta 3 |]) + +(* loop_ids: remove loop<i> hypotheses from the context, and rewrite + * using Variant<i> hypotheses when needed. *) + +let (loop_ids : tactic) = fun gl -> + let rec arec hyps gl = + let env = pf_env gl in + let concl = pf_concl gl in + match hyps with + | [] -> tclIDTAC gl + | (id,a) :: al -> + let s = string_of_id id in + let n = String.length s in + if n >= 4 & (let su = String.sub s 0 4 in su="loop" or su="Bool") + then + tclTHEN (clear [id]) (arec al) gl + else if n >= 7 & String.sub s 0 7 = "Variant" then begin + match pf_matches gl eq_pattern (body_of_type a) with + | [_; _,varphi; _] when isVar varphi -> + let phi = destVar varphi in + if Termops.occur_var env phi concl then + tclTHEN (rewriteLR (mkVar id)) (arec al) gl + else + arec al gl + | _ -> assert false end + else + arec al gl + in + arec (pf_hyps_types gl) gl + +(* assumption_bis: like assumption, but also solves ... h:A/\B ... |- A + * (resp. B) *) + +let (assumption_bis : tactic) = fun gl -> + let concl = pf_concl gl in + let rec arec = function + | [] -> Util.error "No such assumption" + | (s,a) :: al -> + let a = body_of_type a in + if pf_conv_x_leq gl a concl then + refine (mkVar s) gl + else if pf_is_matching gl and_pattern a then + match pf_matches gl and_pattern a with + | [_,c1; _,c2] -> + if pf_conv_x_leq gl c1 concl then + exact_check (applistc (constant "proj1") [c1;c2;mkVar s]) gl + else if pf_conv_x_leq gl c2 concl then + exact_check (applistc (constant "proj2") [c1;c2;mkVar s]) gl + else + arec al + | _ -> assert false + else + arec al + in + arec (pf_hyps_types gl) + +(* automatic: see above *) + +let (automatic : tactic) = + tclTHEN + loop_ids + (fun gl -> + let c = pf_concl gl in + if pf_is_matching gl wf_nat_pattern c then + exact_check (constant "lt_wf") gl + else if pf_is_matching gl wf_z_pattern c then + let (_,z) = List.hd (pf_matches gl wf_z_pattern c) in + exact_check (Term.applist (constant "Zwf_well_founded",[z])) gl + else if pf_is_matching gl and_pattern c then + (tclORELSE assumption_bis + (tclTRY (tclTHEN simplest_split assumption))) gl + else if pf_is_matching gl eq_pattern c then + (tclORELSE reflexivity (tclTRY assumption_bis)) gl + else + tclTRY assumption_bis gl) + +(* [correctness s p] : string -> program -> tactic option -> unit + * + * Vernac: Correctness <string> <program> [; <tactic>]. + *) + +let reduce_open_constr (em0,c) = + let existential_map_of_constr = + let rec collect em c = match kind_of_term c with + | Cast (c',t) -> + (match kind_of_term c' with + | Evar (ev,_) -> + if not (Evd.in_dom em ev) then + Evd.add em ev (Evd.map em0 ev) + else + em + | _ -> fold_constr collect em c) + | Evar _ -> + assert false (* all existentials should be casted *) + | _ -> + fold_constr collect em c + in + collect Evd.empty + in + let c = Pred.red_cci c in + let em = existential_map_of_constr c in + (em,c) + +let register id n = + let id' = match n with None -> id | Some id' -> id' in + Penv.register id id' + + (* On dit à la commande "Save" d'enregistrer les nouveaux programmes *) +let correctness_hook _ ref = + let pf_id = Nametab.id_of_global ref in + register pf_id None + +let correctness s p opttac = + Library.check_required_library ["Coq";"correctness";"Correctness"]; + Pmisc.reset_names(); + let p,oc,cty,v = coqast_of_prog p in + let env = Global.env () in + let sign = Global.named_context () in + let sigma = Evd.empty in + let cty = Reduction.nf_betaiota cty in + let id = id_of_string s in + start_proof id (IsGlobal (Proof Lemma)) sign cty correctness_hook; + Penv.new_edited id (v,p); + if !debug then msg (Pfedit.pr_open_subgoals()); + 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); + let tac = (tclTHEN (Extratactics.refine_tac oc) automatic) in + let tac = match opttac with + | None -> tac + | Some t -> tclTHEN tac t + in + solve_nth 1 tac; + if_verbose msg (pr_open_subgoals ()) diff --git a/contrib/correctness/ptactic.mli b/contrib/correctness/ptactic.mli new file mode 100644 index 00000000..875e0780 --- /dev/null +++ b/contrib/correctness/ptactic.mli @@ -0,0 +1,22 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: ptactic.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *) + +(* 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 + * tactic with the partial proof term obtained by the translation of + * P into a functional program. + * + * Then an ad-hoc automatic tactic is applied on each subgoal to solve the + * trivial proof obligations *) + +val correctness : string -> Past.program -> Tacmach.tactic option -> unit + diff --git a/contrib/correctness/ptype.mli b/contrib/correctness/ptype.mli new file mode 100644 index 00000000..f2dc85e3 --- /dev/null +++ b/contrib/correctness/ptype.mli @@ -0,0 +1,73 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: ptype.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *) + +open Term + +(* Types des valeurs (V) et des calculs (C). + * + * On a C = r:V,E,P,Q + * + * et V = (x1:V1)...(xn:Vn)C | V ref | V array | <type pur> + * + * INVARIANT: l'effet E contient toutes les variables apparaissant dans + * le programme ET les annotations P et Q + * Si E = { x1,...,xn | y1,...,ym }, les variables x sont les + * variables en lecture seule et y1 les variables modifiées + * les xi sont libres dans P et Q, et les yi,result liées dans Q + * i.e. P = p(x) + * et Q = [y1]...[yn][res]q(x,y,res) + *) + +(* pre and post conditions *) + +type 'a precondition = { p_assert : bool; p_name : Names.name; p_value : 'a } + +type 'a assertion = { a_name : Names.name; a_value : 'a } + +type 'a postcondition = 'a assertion + +type predicate = constr assertion + +(* binders *) + +type 'a binder_type = + BindType of 'a + | BindSet + | Untyped + +type 'a binder = Names.identifier * 'a binder_type + +(* variant *) + +type variant = constr * constr * constr (* phi, R, A *) + +(* types des valeurs *) + +type 'a ml_type_v = + Ref of 'a ml_type_v + | Array of 'a * 'a ml_type_v (* size x type *) + | Arrow of 'a ml_type_v binder list * 'a ml_type_c + + | TypePure of 'a + +(* et type des calculs *) + +and 'a ml_type_c = + (Names.identifier * 'a ml_type_v) + * Peffect.t + * ('a precondition list) * ('a postcondition option) + +(* at beginning they contain Coq AST but they become constr after typing *) +type type_v = constr ml_type_v +type type_c = constr ml_type_c + + diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml new file mode 100644 index 00000000..9047a925 --- /dev/null +++ b/contrib/correctness/ptyping.ml @@ -0,0 +1,600 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: ptyping.ml,v 1.7.6.1 2004/07/16 19:30:06 herbelin Exp $ *) + +open Pp +open Util +open Names +open Term +open Termops +open Environ +open Constrintern +open Himsg +open Proof_trees +open Topconstr + +open Pmisc +open Putil +open Prename +open Ptype +open Past +open Penv +open Peffect +open Pcicenv + +(* Ce module implante le jugement Gamma |-a e : kappa de la thèse. + * Les annotations passent du type CoqAst.t au type Term.constr ici. + * Les post-conditions sont abstraites par rapport au résultat. *) + +let simplify_type_of env sigma t = + Reductionops.nf_betaiota (Typing.type_of env sigma t) + +let just_reads e = + difference (get_reads e) (get_writes e) + +let type_v_sup loc t1 t2 = + if t1 = t2 then + t1 + else + Perror.if_branches loc + +let typed_var ren env (phi,r) = + let sign = Pcicenv.before_after_sign_of ren env in + let a = simplify_type_of (Global.env_of_context sign) Evd.empty phi in + (phi,r,a) + +(* Application de fonction *) + +let rec convert = function + | (TypePure c1, TypePure c2) -> + Reductionops.is_conv (Global.env ()) Evd.empty c1 c2 + | (Ref v1, Ref v2) -> + convert (v1,v2) + | (Array (s1,v1), Array (s2,v2)) -> + (Reductionops.is_conv (Global.env ()) Evd.empty s1 s2) && (convert (v1,v2)) + | (v1,v2) -> v1 = v2 + +let effect_app ren env f args = + let n = List.length args in + let tf = + let ((_,v),_,_,_) = f.info.kappa in + match v with TypePure c -> v_of_constr c | _ -> v + in + let bl,c = + match tf with + Arrow (bl, c) -> + if List.length bl <> n then Perror.partial_app f.loc; + bl,c + | _ -> Perror.app_of_non_function f.loc + in + let check_type loc v t so = + let v' = type_v_rsubst so v in + if not (convert (v',t)) then Perror.expected_type loc (pp_type_v v') + in + let s,so,ok = + (* s est la substitution des références, so celle des autres arg. + * ok nous dit si les arguments sont sans effet i.e. des expressions *) + List.fold_left + (fun (s,so,ok) (b,a) -> + match b,a with + (id,BindType (Ref _ | Array _ as v)), Refarg id' -> + let ta = type_in_env env id' in + check_type f.loc v ta so; + (id,id')::s, so, ok + | _, Refarg _ -> Perror.should_be_a_variable f.loc + | (id,BindType v), Term t -> + let ((_,ta),_,_,_) = t.info.kappa in + check_type t.loc v ta so; + (match t.desc with + Expression c -> s, (id,c)::so, ok + | _ -> s,so,false) + | (id,BindSet), Type v -> + let c = Pmonad.trad_ml_type_v ren env v in + s, (id,c)::so, ok + | (id,BindSet), Term t -> Perror.expects_a_type id t.loc + | (id,BindType _), Type _ -> Perror.expects_a_term id + | (_,Untyped), _ -> invalid_arg "effects_app") + ([],[],true) + (List.combine bl args) + in + let (id,v),ef,pre,post = type_c_subst s c in + (bl,c), (s,so,ok), ((id,type_v_rsubst so v),ef,pre,post) + +(* Execution of a Coq AST. Returns value and type. + * Also returns its variables *) + +let state_coq_ast sign a = + let env = Global.env_of_context sign in + let j = + reraise_with_loc (constr_loc a) (judgment_of_rawconstr Evd.empty env) a in + let ids = global_vars env j.uj_val in + j.uj_val, j.uj_type, ids + +(* [is_pure p] tests wether the program p is an expression or not. *) + +let type_of_expression ren env c = + let sign = now_sign_of ren env in + simplify_type_of (Global.env_of_context sign) Evd.empty c + +let rec is_pure_type_v = function + TypePure _ -> true + | Arrow (bl,c) -> List.for_all is_pure_arg bl & is_pure_type_c c + | Ref _ | Array _ -> false +and is_pure_arg = function + (_,BindType v) -> is_pure_type_v v + | (_,BindSet) -> true + | (_,Untyped) -> false +and is_pure_type_c = function + (_,v),_,[],None -> is_pure_type_v v + | _ -> false + +let rec is_pure_desc ren env = function + Variable id -> + not (is_in_env env id) or (is_pure_type_v (type_in_env env id)) + | Expression c -> + (c = isevar) or (is_pure_cci (type_of_expression ren env c)) + | Acc _ -> true + | TabAcc (_,_,p) -> is_pure ren env p + | Apply (p,args) -> + is_pure ren env p & List.for_all (is_pure_arg ren env) args + | SApp _ | Aff _ | TabAff _ | Seq _ | While _ | If _ + | Lam _ | LetRef _ | Let _ | LetRec _ -> false + | Debug (_,p) -> is_pure ren env p + | PPoint (_,d) -> is_pure_desc ren env d +and is_pure ren env p = + p.pre = [] & p.post = None & is_pure_desc ren env p.desc +and is_pure_arg ren env = function + Term p -> is_pure ren env p + | Type _ -> true + | Refarg _ -> false + +(* [state_var ren env (phi,r)] returns a tuple (e,(phi',r')) + * where e is the effect of the variant phi and phi',r' the corresponding + * constr of phi and r. + *) + +let state_var ren env (phi,r) = + let sign = Pcicenv.before_after_sign_of ren env in + let phi',_,ids = state_coq_ast sign phi in + let ef = List.fold_left + (fun e id -> + if is_mutable_in_env env id then Peffect.add_read id e else e) + Peffect.bottom ids in + let r',_,_ = state_coq_ast (Global.named_context ()) r in + ef,(phi',r') + +(* [state_pre ren env pl] returns a pair (e,c) where e is the effect of the + * pre-conditions list pl and cl the corresponding constrs not yet abstracted + * over the variables xi (i.e. c NOT [x1]...[xn]c !) + *) + +let state_pre ren env pl = + let state e p = + let sign = Pcicenv.before_sign_of ren env in + let cc,_,ids = state_coq_ast sign p.p_value in + let ef = List.fold_left + (fun e id -> + if is_mutable_in_env env id then + Peffect.add_read id e + else if is_at id then + let uid,_ = un_at id in + if is_mutable_in_env env uid then + Peffect.add_read uid e + else + e + else + e) + e ids + in + ef,{ p_assert = p.p_assert; p_name = p.p_name; p_value = cc } + in + List.fold_left + (fun (e,cl) p -> let ef,c = state e p in (ef,c::cl)) + (Peffect.bottom,[]) pl + +let state_assert ren env a = + let p = pre_of_assert true a in + let e,l = state_pre ren env [p] in + e,assert_of_pre (List.hd l) + +let state_inv ren env = function + None -> Peffect.bottom, None + | Some i -> let e,p = state_assert ren env i in e,Some p + +(* [state_post ren env (id,v,ef) q] returns a pair (e,c) + * where e is the effect of the + * post-condition q and c the corresponding constr not yet abstracted + * over the variables xi, yi and result. + * Moreover the RW variables not appearing in ef have been replaced by + * RO variables, and (id,v) is the result + *) + +let state_post ren env (id,v,ef) = function + None -> Peffect.bottom, None + | Some q -> + let v' = Pmonad.trad_ml_type_v ren env v in + let sign = Pcicenv.before_after_result_sign_of (Some (id,v')) ren env in + let cc,_,ids = state_coq_ast sign q.a_value in + let ef,c = + List.fold_left + (fun (e,c) id -> + if is_mutable_in_env env id then + if is_write ef id then + Peffect.add_write id e, c + else + Peffect.add_read id e, + subst_in_constr [id,at_id id ""] c + else if is_at id then + let uid,_ = un_at id in + if is_mutable_in_env env uid then + Peffect.add_read uid e, c + else + e,c + else + e,c) + (Peffect.bottom,cc) ids + in + let c = abstract [id,v'] c in + ef, Some { a_name = q.a_name; a_value = c } + +(* transformation of AST into constr in types V and C *) + +let rec cic_type_v env ren = function + | Ref v -> Ref (cic_type_v env ren v) + | Array (com,v) -> + let sign = Pcicenv.now_sign_of ren env in + let c = interp_constr Evd.empty (Global.env_of_context sign) com in + Array (c, cic_type_v env ren v) + | Arrow (bl,c) -> + let bl',ren',env' = + List.fold_left + (fun (bl,ren,env) b -> + let b' = cic_binder env ren b in + let env' = traverse_binders env [b'] in + let ren' = initial_renaming env' in + b'::bl,ren',env') + ([],ren,env) bl + in + let c' = cic_type_c env' ren' c in + Arrow (List.rev bl',c') + | TypePure com -> + let sign = Pcicenv.cci_sign_of ren env in + let c = interp_constr Evd.empty (Global.env_of_context sign) com in + TypePure c + +and cic_type_c env ren ((id,v),e,p,q) = + let v' = cic_type_v env ren v in + let cv = Pmonad.trad_ml_type_v ren env v' in + let efp,p' = state_pre ren env p in + let efq,q' = state_post ren env (id,v',e) q in + let ef = Peffect.union e (Peffect.union efp efq) in + ((id,v'),ef,p',q') + +and cic_binder env ren = function + | (id,BindType v) -> + let v' = cic_type_v env ren v in + let env' = add (id,v') env in + let ren' = initial_renaming env' in + (id, BindType v') + | (id,BindSet) -> (id,BindSet) + | (id,Untyped) -> (id,Untyped) + +and cic_binders env ren = function + [] -> [] + | b::bl -> + let b' = cic_binder env ren b in + let env' = traverse_binders env [b'] in + let ren' = initial_renaming env' in + b' :: (cic_binders env' ren' bl) + + +(* The case of expressions. + * + * Expressions are programs without neither effects nor pre/post conditions. + * But access to variables are allowed. + * + * Here we transform an expression into the corresponding constr, + * the variables still appearing as VAR (they will be abstracted in + * Mlise.trad) + * We collect the pre-conditions (e<N for t[e]) as we traverse the term. + * We also return the effect, which does contain only *read* variables. + *) + +let states_expression ren env expr = + let rec effect pl = function + | Variable id -> + (if is_global id then constant (string_of_id id) else mkVar id), + pl, Peffect.bottom + | Expression c -> c, pl, Peffect.bottom + | Acc id -> mkVar id, pl, Peffect.add_read id Peffect.bottom + | TabAcc (_,id,p) -> + let c,pl,ef = effect pl p.desc in + let pre = Pmonad.make_pre_access ren env id c in + Pmonad.make_raw_access ren env (id,id) c, + (anonymous_pre true pre)::pl, Peffect.add_read id ef + | Apply (p,args) -> + let a,pl,e = effect pl p.desc in + let args,pl,e = + List.fold_right + (fun arg (l,pl,e) -> + match arg with + Term p -> + let carg,pl,earg = effect pl p.desc in + carg::l,pl,Peffect.union e earg + | Type v -> + let v' = cic_type_v env ren v in + (Pmonad.trad_ml_type_v ren env v')::l,pl,e + | Refarg _ -> assert false) + args ([],pl,e) + in + Term.applist (a,args),pl,e + | _ -> invalid_arg "Ptyping.states_expression" + in + let e0,pl0 = state_pre ren env expr.pre in + let c,pl,e = effect [] expr.desc in + let sign = Pcicenv.before_sign_of ren env in + (*i WAS + let c = (Trad.ise_resolve true empty_evd [] (gLOB sign) c)._VAL in + i*) + let ty = simplify_type_of (Global.env_of_context sign) Evd.empty c in + let v = TypePure ty in + let ef = Peffect.union e0 e in + Expression c, (v,ef), pl0@pl + + +(* We infer here the type with effects. + * The type of types with effects (ml_type_c) is defined in the module ProgAst. + * + * A program of the shape {P} e {Q} has a type + * + * V, E, {None|Some P}, {None|Some Q} + * + * where - V is the type of e + * - E = (I,O) is the effect; the input I contains + * all the input variables appearing in P,e and Q; + * the output O contains variables possibly modified in e + * - P is NOT abstracted + * - Q = [y'1]...[y'k][result]Q where O = {y'j} + * i.e. Q is only abstracted over the output and the result + * the other variables now refer to value BEFORE + *) + +let verbose_fix = ref false + +let rec states_desc ren env loc = function + + Expression c -> + let ty = type_of_expression ren env c in + let v = v_of_constr ty in + Expression c, (v,Peffect.bottom) + + | Acc _ -> + failwith "Ptyping.states: term is supposed not to be pure" + + | Variable id -> + let v = type_in_env env id in + let ef = Peffect.bottom in + Variable id, (v,ef) + + | Aff (x, e1) -> + Perror.check_for_reference loc x (type_in_env env x); + let s_e1 = states ren env e1 in + let _,e,_,_ = s_e1.info.kappa in + let ef = add_write x e in + let v = constant_unit () in + Aff (x, s_e1), (v, ef) + + | TabAcc (check, x, e) -> + let s_e = states ren env e in + let _,efe,_,_ = s_e.info.kappa in + let ef = Peffect.add_read x efe in + let _,ty = dearray_type (type_in_env env x) in + TabAcc (check, x, s_e), (ty, ef) + + | TabAff (check, x, e1, e2) -> + let s_e1 = states ren env e1 in + let s_e2 = states ren env e2 in + let _,ef1,_,_ = s_e1.info.kappa in + let _,ef2,_,_ = s_e2.info.kappa in + let ef = Peffect.add_write x (Peffect.union ef1 ef2) in + let v = constant_unit () in + TabAff (check, x, s_e1, s_e2), (v,ef) + + | Seq bl -> + let bl,v,ef,_ = states_block ren env bl in + Seq bl, (v,ef) + + | While(b, invopt, var, bl) -> + let efphi,(cvar,r') = state_var ren env var in + let ren' = next ren [] in + let s_b = states ren' env b in + let s_bl,_,ef_bl,_ = states_block ren' env bl in + let cb = s_b.info.kappa in + let efinv,inv = state_inv ren env invopt in + let _,efb,_,_ = s_b.info.kappa in + let ef = + Peffect.union (Peffect.union ef_bl efb) (Peffect.union efinv efphi) + in + let v = constant_unit () in + let cvar = + let al = List.map (fun id -> (id,at_id id "")) (just_reads ef) in + subst_in_constr al cvar + in + While (s_b,inv,(cvar,r'),s_bl), (v,ef) + + | Lam ([],_) -> + failwith "Ptyping.states: abs. should have almost one binder" + + | Lam (bl, e) -> + let bl' = cic_binders env ren bl in + let env' = traverse_binders env bl' in + let ren' = initial_renaming env' in + let s_e = states ren' env' e in + let v = make_arrow bl' s_e.info.kappa in + let ef = Peffect.bottom in + Lam(bl',s_e), (v,ef) + + (* Connectives AND and OR *) + | SApp ([Variable id], [e1;e2]) -> + let s_e1 = states ren env e1 + and s_e2 = states ren env e2 in + let (_,ef1,_,_) = s_e1.info.kappa + and (_,ef2,_,_) = s_e2.info.kappa in + let ef = Peffect.union ef1 ef2 in + SApp ([Variable id], [s_e1; s_e2]), + (TypePure (constant "bool"), ef) + + (* Connective NOT *) + | SApp ([Variable id], [e]) -> + let s_e = states ren env e in + let (_,ef,_,_) = s_e.info.kappa in + SApp ([Variable id], [s_e]), + (TypePure (constant "bool"), ef) + + | SApp _ -> invalid_arg "Ptyping.states (SApp)" + + (* ATTENTION: + Si un argument réel de type ref. correspond à une ref. globale + modifiée par la fonction alors la traduction ne sera pas correcte. + Exemple: + f=[x:ref Int]( r := !r+1 ; x := !x+1) modifie r et son argument x + donc si on l'applique à r justement, elle ne modifiera que r + mais le séquencement ne sera pas correct. *) + + | Apply (f, args) -> + let s_f = states ren env f in + let _,eff,_,_ = s_f.info.kappa in + let s_args = List.map (states_arg ren env) args in + let ef_args = + List.map + (function Term t -> let (_,e,_,_) = t.info.kappa in e + | _ -> Peffect.bottom) + s_args + in + let _,_,((_,tapp),efapp,_,_) = effect_app ren env s_f s_args in + let ef = + Peffect.compose (List.fold_left Peffect.compose eff ef_args) efapp + in + Apply (s_f, s_args), (tapp, ef) + + | LetRef (x, e1, e2) -> + let s_e1 = states ren env e1 in + let (_,v1),ef1,_,_ = s_e1.info.kappa in + let env' = add (x,Ref v1) env in + let ren' = next ren [x] in + let s_e2 = states ren' env' e2 in + let (_,v2),ef2,_,_ = s_e2.info.kappa in + Perror.check_for_let_ref loc v2; + let ef = Peffect.compose ef1 (Peffect.remove ef2 x) in + LetRef (x, s_e1, s_e2), (v2,ef) + + | Let (x, e1, e2) -> + let s_e1 = states ren env e1 in + let (_,v1),ef1,_,_ = s_e1.info.kappa in + Perror.check_for_not_mutable e1.loc v1; + let env' = add (x,v1) env in + let s_e2 = states ren env' e2 in + let (_,v2),ef2,_,_ = s_e2.info.kappa in + let ef = Peffect.compose ef1 ef2 in + Let (x, s_e1, s_e2), (v2,ef) + + | If (b, e1, e2) -> + let s_b = states ren env b in + let s_e1 = states ren env e1 + and s_e2 = states ren env e2 in + let (_,tb),efb,_,_ = s_b.info.kappa in + let (_,t1),ef1,_,_ = s_e1.info.kappa in + let (_,t2),ef2,_,_ = s_e2.info.kappa in + let ef = Peffect.compose efb (disj ef1 ef2) in + let v = type_v_sup loc t1 t2 in + If (s_b, s_e1, s_e2), (v,ef) + + | LetRec (f,bl,v,var,e) -> + let bl' = cic_binders env ren bl in + let env' = traverse_binders env bl' in + let ren' = initial_renaming env' in + let v' = cic_type_v env' ren' v in + let efvar,var' = state_var ren' env' var in + let phi0 = phi_name () in + let tvar = typed_var ren env' var' in + (* effect for a let/rec construct is computed as a fixpoint *) + let rec state_rec c = + let tf = make_arrow bl' c in + let env'' = add_recursion (f,(phi0,tvar)) (add (f,tf) env') in + let s_e = states ren' env'' e in + if s_e.info.kappa = c then + s_e + else begin + if !verbose_fix then begin msgnl (pp_type_c s_e.info.kappa) end ; + state_rec s_e.info.kappa + end + in + let s_e = state_rec ((result_id,v'),efvar,[],None) in + let tf = make_arrow bl' s_e.info.kappa in + LetRec (f,bl',v',var',s_e), (tf,Peffect.bottom) + + | PPoint (s,d) -> + let ren' = push_date ren s in + states_desc ren' env loc d + + | Debug _ -> failwith "Ptyping.states: Debug: TODO" + + +and states_arg ren env = function + Term a -> let s_a = states ren env a in Term s_a + | Refarg id -> Refarg id + | Type v -> let v' = cic_type_v env ren v in Type v' + + +and states ren env expr = + (* Here we deal with the pre- and post- conditions: + * we add their effects to the effects of the program *) + let (d,(v,e),p1) = + if is_pure_desc ren env expr.desc then + states_expression ren env expr + else + let (d,ve) = states_desc ren env expr.loc expr.desc in (d,ve,[]) + in + let (ep,p) = state_pre ren env expr.pre in + let (eq,q) = state_post ren env (result_id,v,e) expr.post in + let e' = Peffect.union e (Peffect.union ep eq) in + let p' = p1 @ p in + let tinfo = { env = env; kappa = ((result_id,v),e',p',q) } in + { desc = d; + loc = expr.loc; + pre = p'; post = q; (* on les conserve aussi ici pour prog_wp *) + info = tinfo } + + +and states_block ren env bl = + let rec ef_block ren tyres = function + [] -> + begin match tyres with + Some ty -> [],ty,Peffect.bottom,ren + | None -> failwith "a block should contain at least one statement" + end + | (Assert p)::block -> + let ep,c = state_assert ren env p in + let bl,t,ef,ren' = ef_block ren tyres block in + (Assert c)::bl,t,Peffect.union ep ef,ren' + | (Label s)::block -> + let ren' = push_date ren s in + let bl,t,ef,ren'' = ef_block ren' tyres block in + (Label s)::bl,t,ef,ren'' + | (Statement e)::block -> + let s_e = states ren env e in + let (_,t),efe,_,_ = s_e.info.kappa in + let ren' = next ren (get_writes efe) in + let bl,t,ef,ren'' = ef_block ren' (Some t) block in + (Statement s_e)::bl,t,Peffect.compose efe ef,ren'' + in + ef_block ren None bl + diff --git a/contrib/correctness/ptyping.mli b/contrib/correctness/ptyping.mli new file mode 100644 index 00000000..0c0d5905 --- /dev/null +++ b/contrib/correctness/ptyping.mli @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: ptyping.mli,v 1.3.6.1 2004/07/16 19:30:06 herbelin Exp $ *) + +open Names +open Term +open Topconstr + +open Ptype +open Past +open Penv + +(* This module realizes type and effect inference *) + +val cic_type_v : local_env -> Prename.t -> constr_expr ml_type_v -> type_v + +val effect_app : Prename.t -> local_env + -> (typing_info,'b) Past.t + -> (typing_info,constr) arg list + -> (type_v binder list * type_c) + * ((identifier*identifier) list * (identifier*constr) list * bool) + * type_c + +val typed_var : Prename.t -> local_env -> constr * constr -> variant + +val type_of_expression : Prename.t -> local_env -> constr -> constr + +val states : Prename.t -> local_env -> program -> typed_program diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml new file mode 100644 index 00000000..48f0781a --- /dev/null +++ b/contrib/correctness/putil.ml @@ -0,0 +1,303 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: putil.ml,v 1.10.2.1 2004/07/16 19:30:06 herbelin Exp $ *) + +open Util +open Names +open Nameops +open Term +open Termops +open Pattern +open Matching +open Hipattern +open Environ + +open Pmisc +open Ptype +open Past +open Penv +open Prename + +let is_mutable = function Ref _ | Array _ -> true | _ -> false +let is_pure = function TypePure _ -> true | _ -> false + +let named_app f x = { a_name = x.a_name; a_value = (f x.a_value) } + +let pre_app f x = + { p_assert = x.p_assert; p_name = x.p_name; p_value = f x.p_value } + +let post_app = named_app + +let anonymous x = { a_name = Anonymous; a_value = x } + +let anonymous_pre b x = { p_assert = b; p_name = Anonymous; p_value = x } + +let force_name f x = + option_app (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x + +let force_post_name x = force_name post_name x + +let force_bool_name x = + force_name (function Name id -> id | Anonymous -> bool_name()) x + +let out_post = function + Some { a_value = x } -> x + | None -> invalid_arg "out_post" + +let pre_of_assert b x = + { p_assert = b; p_name = x.a_name; p_value = x.a_value } + +let assert_of_pre x = + { a_name = x.p_name; a_value = x.p_value } + +(* Some generic functions on programs *) + +let is_mutable_in_env env id = + (is_in_env env id) & (is_mutable (type_in_env env id)) + +let now_vars env c = + Util.map_succeed + (function id -> if is_mutable_in_env env id then id else failwith "caught") + (global_vars (Global.env()) c) + +let make_before_after c = + let ids = global_vars (Global.env()) c in + let al = + Util.map_succeed + (function id -> + if is_at id then + match un_at id with (uid,"") -> (id,uid) | _ -> failwith "caught" + else failwith "caught") + ids + in + subst_in_constr al c + +(* [apply_pre] and [apply_post] instantiate pre- and post- conditions + * according to a given renaming of variables (and a date that means + * `before' in the case of the post-condition). + *) + +let make_assoc_list ren env on_prime ids = + List.fold_left + (fun al id -> + if is_mutable_in_env env id then + (id,current_var ren id)::al + else if is_at id then + let uid,d = un_at id in + if is_mutable_in_env env uid then + (match d with + "" -> (id,on_prime ren uid) + | _ -> (id,var_at_date ren d uid))::al + else + al + else + al) + [] ids + +let apply_pre ren env c = + let ids = global_vars (Global.env()) c.p_value in + let al = make_assoc_list ren env current_var ids in + { p_assert = c.p_assert; p_name = c.p_name; + p_value = subst_in_constr al c.p_value } + +let apply_assert ren env c = + let ids = global_vars (Global.env()) c.a_value in + let al = make_assoc_list ren env current_var ids in + { a_name = c.a_name; a_value = subst_in_constr al c.a_value } + +let apply_post ren env before c = + let ids = global_vars (Global.env()) c.a_value in + let al = + make_assoc_list ren env (fun r uid -> var_at_date r before uid) ids in + { a_name = c.a_name; a_value = subst_in_constr al c.a_value } + +(* [traverse_binder ren env bl] updates renaming [ren] and environment [env] + * as we cross the binders [bl] + *) + +let rec traverse_binders env = function + [] -> env + | (id,BindType v)::rem -> + traverse_binders (add (id,v) env) rem + | (id,BindSet)::rem -> + traverse_binders (add_set id env) rem + | (_,Untyped)::_ -> + invalid_arg "traverse_binders" + +let initial_renaming env = + let ids = Penv.fold_all (fun (id,_) l -> id::l) env [] in + update empty_ren "0" ids + + +(* Substitutions *) + +let rec type_c_subst s ((id,t),e,p,q) = + let s' = s @ List.map (fun (x,x') -> (at_id x "", at_id x' "")) s in + (id, type_v_subst s t), Peffect.subst s e, + List.map (pre_app (subst_in_constr s)) p, + option_app (post_app (subst_in_constr s')) q + +and type_v_subst s = function + Ref v -> Ref (type_v_subst s v) + | Array (n,v) -> Array (n,type_v_subst s v) + | Arrow (bl,c) -> Arrow(List.map (binder_subst s) bl, type_c_subst s c) + | (TypePure _) as v -> v + +and binder_subst s = function + (n, BindType v) -> (n, BindType (type_v_subst s v)) + | b -> b + +(* substitution of constr by others *) + +let rec type_c_rsubst s ((id,t),e,p,q) = + (id, type_v_rsubst s t), e, + List.map (pre_app (real_subst_in_constr s)) p, + option_app (post_app (real_subst_in_constr s)) q + +and type_v_rsubst s = function + Ref v -> Ref (type_v_rsubst s v) + | Array (n,v) -> Array (real_subst_in_constr s n,type_v_rsubst s v) + | Arrow (bl,c) -> Arrow(List.map (binder_rsubst s) bl, type_c_rsubst s c) + | TypePure c -> TypePure (real_subst_in_constr s c) + +and binder_rsubst s = function + | (n, BindType v) -> (n, BindType (type_v_rsubst s v)) + | b -> b + +(* make_arrow bl c = (x1:V1)...(xn:Vn)c *) + +let make_arrow bl c = match bl with + | [] -> invalid_arg "make_arrow: no binder" + | _ -> Arrow (bl,c) + +(* misc. functions *) + +let deref_type = function + | Ref v -> v + | _ -> invalid_arg "deref_type" + +let dearray_type = function + | Array (size,v) -> size,v + | _ -> invalid_arg "dearray_type" + +let constant_unit () = TypePure (constant "unit") + +let id_from_name = function Name id -> id | Anonymous -> (id_of_string "X") + +(* v_of_constr : traduit un type CCI en un type ML *) + +(* TODO: faire un test plus serieux sur le type des objets Coq *) +let rec is_pure_cci c = match kind_of_term c with + | Cast (c,_) -> is_pure_cci c + | Prod(_,_,c') -> is_pure_cci c' + | Rel _ | Ind _ | Const _ -> true (* heu... *) + | App _ -> not (is_matching_sigma c) + | _ -> Util.error "CCI term not acceptable in programs" + +let rec v_of_constr c = match kind_of_term c with + | Cast (c,_) -> v_of_constr c + | Prod _ -> + let revbl,t2 = Term.decompose_prod c in + let bl = + List.map + (fun (name,t1) -> (id_from_name name, BindType (v_of_constr t1))) + (List.rev revbl) + in + let vars = List.rev (List.map (fun (id,_) -> mkVar id) bl) in + Arrow (bl, c_of_constr (substl vars t2)) + | Ind _ | Const _ | App _ -> + TypePure c + | _ -> + failwith "v_of_constr: TODO" + +and c_of_constr c = + if is_matching_sigma c then + let (a,q) = match_sigma c in + (result_id, v_of_constr a), Peffect.bottom, [], Some (anonymous q) + else + (result_id, v_of_constr c), Peffect.bottom, [], None + + +(* pretty printers (for debugging purposes) *) + +open Pp +open Util + +let prterm x = Printer.prterm_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) + +let pp_post = function + None -> (mt ()) + | Some c -> hov 0 (str"post " ++ prterm 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) + | Arrow (b,c) -> + hov 0 (prlist_with_sep (fun () -> (mt ())) pp_binder b ++ + pp_type_c c) + | TypePure c -> prterm c + +and pp_type_c ((id,v),e,p,q) = + hov 0 (str"returns " ++ pr_id id ++ str":" ++ pp_type_v v ++ spc () ++ + Peffect.pp e ++ spc () ++ pp_pre p ++ spc () ++ pp_post q ++ + spc () ++ str"end") + +and pp_binder = function + id,BindType v -> (str"(" ++ pr_id id ++ str":" ++ pp_type_v v ++ str")") + | id,BindSet -> (str"(" ++ pr_id id ++ str":Set)") + | id,Untyped -> (str"(" ++ pr_id id ++ str")") + +(* pretty-print of cc-terms (intermediate terms) *) + +let rec pp_cc_term = function + CC_var id -> pr_id id + | CC_letin (_,_,bl,c,c1) -> + hov 0 (hov 2 (str"let " ++ + prlist_with_sep (fun () -> (str",")) + (fun (id,_) -> pr_id id) bl ++ + str" =" ++ spc () ++ + pp_cc_term c ++ + str " in") ++ + fnl () ++ + pp_cc_term c1) + | CC_lam (bl,c) -> + hov 2 (prlist (fun (id,_) -> (str"[" ++ pr_id id ++ str"]")) bl ++ + cut () ++ + pp_cc_term c) + | CC_app (f,args) -> + hov 2 (str"(" ++ + pp_cc_term f ++ spc () ++ + prlist_with_sep (fun () -> (spc ())) pp_cc_term args ++ + str")") + | CC_tuple (_,_,cl) -> + hov 2 (str"(" ++ + prlist_with_sep (fun () -> (str"," ++ cut ())) + pp_cc_term cl ++ + str")") + | CC_case (_,b,[e1;e2]) -> + hov 0 (str"if " ++ pp_cc_term b ++ str" then" ++ fnl () ++ + str" " ++ hov 0 (pp_cc_term e1) ++ fnl () ++ + str"else" ++ fnl () ++ + str" " ++ hov 0 (pp_cc_term e2)) + | CC_case _ -> + hov 0 (str"<Case: not yet implemented>") + | CC_expr c -> + hov 0 (prterm c) + | CC_hole c -> + (str"(?::" ++ prterm c ++ str")") + diff --git a/contrib/correctness/putil.mli b/contrib/correctness/putil.mli new file mode 100644 index 00000000..b44774ae --- /dev/null +++ b/contrib/correctness/putil.mli @@ -0,0 +1,72 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: putil.mli,v 1.3.2.1 2004/07/16 19:30:06 herbelin Exp $ *) + +open Pp +open Names +open Term +open Pmisc +open Ptype +open Past +open Penv + +val is_mutable : 'a ml_type_v -> bool +val is_pure : 'a ml_type_v -> bool + +val named_app : ('a -> 'b) -> 'a assertion -> 'b assertion +val pre_app : ('a -> 'b) -> 'a precondition -> 'b precondition +val post_app : ('a -> 'b) -> 'a postcondition -> 'b postcondition + +val anonymous : 'a -> 'a assertion +val anonymous_pre : bool -> 'a -> 'a precondition +val out_post : 'a postcondition option -> 'a +val pre_of_assert : bool -> 'a assertion -> 'a precondition +val assert_of_pre : 'a precondition -> 'a assertion + +val force_post_name : 'a postcondition option -> 'a postcondition option +val force_bool_name : 'a postcondition option -> 'a postcondition option + +val make_before_after : constr -> constr + +val traverse_binders : local_env -> (type_v binder) list -> local_env +val initial_renaming : local_env -> Prename.t + +val apply_pre : Prename.t -> local_env -> constr precondition -> + constr precondition +val apply_post : Prename.t -> local_env -> string -> constr postcondition -> + constr postcondition +val apply_assert : Prename.t -> local_env -> constr assertion -> + constr assertion + +val type_v_subst : (identifier * identifier) list -> type_v -> type_v +val type_c_subst : (identifier * identifier) list -> type_c -> type_c + +val type_v_rsubst : (identifier * constr) list -> type_v -> type_v +val type_c_rsubst : (identifier * constr) list -> type_c -> type_c + +val make_arrow : ('a ml_type_v binder) list -> 'a ml_type_c -> 'a ml_type_v + +val is_mutable_in_env : local_env -> identifier -> bool +val now_vars : local_env -> constr -> identifier list + +val deref_type : 'a ml_type_v -> 'a ml_type_v +val dearray_type : 'a ml_type_v -> 'a * 'a ml_type_v +val constant_unit : unit -> constr ml_type_v +val v_of_constr : constr -> constr ml_type_v +val c_of_constr : constr -> constr ml_type_c +val is_pure_cci : constr -> bool + +(* pretty printers *) + +val pp_type_v : type_v -> std_ppcmds +val pp_type_c : type_c -> std_ppcmds +val pp_cc_term : cc_term -> std_ppcmds + diff --git a/contrib/correctness/pwp.ml b/contrib/correctness/pwp.ml new file mode 100644 index 00000000..58bef673 --- /dev/null +++ b/contrib/correctness/pwp.ml @@ -0,0 +1,347 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pwp.ml,v 1.8.2.1 2004/07/16 19:30:06 herbelin Exp $ *) + +open Util +open Names +open Libnames +open Term +open Termops +open Environ +open Nametab + +open Pmisc +open Ptype +open Past +open Putil +open Penv +open Peffect +open Ptyping +open Prename + +(* In this module: + * - we try to insert more annotations to achieve a greater completeness; + * - we recursively propagate annotations inside programs; + * - we normalize boolean expressions. + * + * The propagation schemas are the following: + * + * 1. (f a1 ... an) -> (f a1 ... an) {Qf} if the ai are functional + * + * 2. (if e1 then e2 else e3) {Q} -> (if e1 then e2 {Q} else e3 {Q}) {Q} + * + * 3. (let x = e1 in e2) {Q} -> (let x = e1 in e2 {Q}) {Q} + *) + +(* force a post-condition *) +let update_post env top ef c = + let i,o = Peffect.get_repr ef in + let al = + List.fold_left + (fun l id -> + if is_mutable_in_env env id then + if is_write ef id then l else (id,at_id id "")::l + else if is_at id then + let (uid,d) = un_at id in + if is_mutable_in_env env uid & d="" then + (id,at_id uid top)::l + else + l + else + l) + [] (global_vars (Global.env()) c) + in + subst_in_constr al c + +let force_post up env top q e = + let (res,ef,p,_) = e.info.kappa in + let q' = + if up then option_app (named_app (update_post env top ef)) q else q + in + let i = { env = e.info.env; kappa = (res,ef,p,q') } in + { desc = e.desc; pre = e.pre; post = q'; loc = e.loc; info = i } + +(* put a post-condition if none is present *) +let post_if_none_up env top q = function + | { post = None } as p -> force_post true env top q p + | p -> p + +let post_if_none env q = function + | { post = None } as p -> force_post false env "" q p + | p -> p + +(* [annotation_candidate p] determines if p is a candidate for a + * post-condition *) + +let annotation_candidate = function + | { desc = If _ | Let _ | LetRef _ ; post = None } -> true + | _ -> false + +(* [extract_pre p] erase the pre-condition of p and returns it *) +let extract_pre pr = + let (v,e,p,q) = pr.info.kappa in + { desc = pr.desc; pre = []; post = pr.post; loc = pr.loc; + info = { env = pr.info.env; kappa = (v,e,[],q) } }, + p + +(* adds some pre-conditions *) +let add_pre p1 pr = + let (v,e,p,q) = pr.info.kappa in + let p' = p1 @ p in + { desc = pr.desc; pre = p'; post = pr.post; loc = pr.loc; + info = { env = pr.info.env; kappa = (v,e,p',q) } } + +(* change the statement *) +let change_desc p d = + { desc = d; pre = p.pre; post = p.post; loc = p.loc; info = p.info } + +let create_bool_post c = + Some { a_value = c; a_name = Name (bool_name()) } + +(* [normalize_boolean b] checks if the boolean expression b (of type bool) is + * annotated, and if it is not the case tries to add the annotation + * (if result then c=true else c=false) if b is an expression c. + *) + +let is_bool = function + | TypePure c -> + (match kind_of_term (strip_outer_cast c) with + | Ind op -> + string_of_id (id_of_global (IndRef op)) = "bool" + | _ -> false) + | _ -> false + +let normalize_boolean ren env b = + let ((res,v),ef,p,q) = b.info.kappa in + Perror.check_no_effect b.loc ef; + if is_bool v then + match q with + | Some _ -> + (* il y a une annotation : on se contente de lui forcer un nom *) + let q = force_bool_name q in + { desc = b.desc; pre = b.pre; post = q; loc = b.loc; + info = { env = b.info.env; kappa = ((res,v),ef,p,q) } } + | None -> begin + (* il n'y a pas d'annotation : on cherche à en mettre une *) + match b.desc with + Expression c -> + let c' = Term.applist (constant "annot_bool",[c]) in + let ty = type_of_expression ren env c' in + let (_,q') = Hipattern.match_sigma ty in + let q' = Some { a_value = q'; a_name = Name (bool_name()) } in + { desc = Expression c'; + pre = b.pre; post = q'; loc = b.loc; + info = { env = b.info.env; kappa = ((res, v),ef,p,q') } } + | _ -> b + end + else + Perror.should_be_boolean b.loc + +(* [decomp_boolean c] returns the specs R and S of a boolean expression *) + +let decomp_boolean = function + | Some { a_value = q } -> + Reductionops.whd_betaiota (Term.applist (q, [constant "true"])), + Reductionops.whd_betaiota (Term.applist (q, [constant "false"])) + | _ -> invalid_arg "Ptyping.decomp_boolean" + +(* top point of a program *) + +let top_point = function + | PPoint (s,_) as p -> s,p + | p -> let s = label_name() in s,PPoint(s,p) + +let top_point_block = function + | (Label s :: _) as b -> s,b + | b -> let s = label_name() in s,(Label s)::b + +let abstract_unit q = abstract [result_id,constant "unit"] q + +(* [add_decreasing env ren ren' phi r bl] adds the decreasing condition + * phi(ren') r phi(ren) + * to the last assertion of the block [bl], which is created if needed + *) + +let add_decreasing env inv (var,r) lab bl = + let ids = now_vars env var in + let al = List.map (fun id -> (id,at_id id lab)) ids in + let var_lab = subst_in_constr al var in + let dec = Term.applist (r, [var;var_lab]) in + let post = match inv with + None -> anonymous dec + | Some i -> { a_value = conj dec i.a_value; a_name = i.a_name } + in + bl @ [ Assert post ] + +(* [post_last_statement env top q bl] annotates the last statement of the + * sequence bl with q if necessary *) + +let post_last_statement env top q bl = + match List.rev bl with + | Statement e :: rem when annotation_candidate e -> + List.rev ((Statement (post_if_none_up env top q e)) :: rem) + | _ -> bl + +(* [propagate_desc] moves the annotations inside the program + * info is the typing information coming from the outside annotations *) +let rec propagate_desc ren info d = + let env = info.env in + let (_,_,p,q) = info.kappa in + match d with + | If (e1,e2,e3) -> + (* propagation number 2 *) + let e1' = normalize_boolean ren env (propagate ren e1) in + if e2.post = None or e3.post = None then + let top = label_name() in + let ren' = push_date ren top in + PPoint (top, If (e1', + propagate ren' (post_if_none_up env top q e2), + propagate ren' (post_if_none_up env top q e3))) + else + If (e1', propagate ren e2, propagate ren e3) + | Aff (x,e) -> + Aff (x, propagate ren e) + | TabAcc (ch,x,e) -> + TabAcc (ch, x, propagate ren e) + | TabAff (ch,x,({desc=Expression c} as e1),e2) -> + let p = Pmonad.make_pre_access ren env x c in + let e1' = add_pre [(anonymous_pre true p)] e1 in + TabAff (false, x, propagate ren e1', propagate ren e2) + | TabAff (ch,x,e1,e2) -> + TabAff (ch, x, propagate ren e1, propagate ren e2) + | Apply (f,l) -> + Apply (propagate ren f, List.map (propagate_arg ren) l) + | SApp (f,l) -> + let l = + List.map (fun e -> normalize_boolean ren env (propagate ren e)) l + in + SApp (f, l) + | Lam (bl,e) -> + Lam (bl, propagate ren e) + | Seq bl -> + let top,bl = top_point_block bl in + let bl = post_last_statement env top q bl in + Seq (propagate_block ren env bl) + | While (b,inv,var,bl) -> + let b = normalize_boolean ren env (propagate ren b) in + let lab,bl = top_point_block bl in + let bl = add_decreasing env inv var lab bl in + While (b,inv,var,propagate_block ren env bl) + | LetRef (x,e1,e2) -> + let top = label_name() in + let ren' = push_date ren top in + PPoint (top, LetRef (x, propagate ren' e1, + propagate ren' (post_if_none_up env top q e2))) + | Let (x,e1,e2) -> + let top = label_name() in + let ren' = push_date ren top in + PPoint (top, Let (x, propagate ren' e1, + propagate ren' (post_if_none_up env top q e2))) + | LetRec (f,bl,v,var,e) -> + LetRec (f, bl, v, var, propagate ren e) + | PPoint (s,d) -> + PPoint (s, propagate_desc ren info d) + | Debug _ | Variable _ + | Acc _ | Expression _ as d -> d + + +(* [propagate] adds new annotations if possible *) +and propagate ren p = + let env = p.info.env in + let p = match p.desc with + | Apply (f,l) -> + let _,(_,so,ok),(_,_,_,qapp) = effect_app ren env f l in + if ok then + let q = option_app (named_app (real_subst_in_constr so)) qapp in + post_if_none env q p + else + p + | _ -> p + in + let d = propagate_desc ren p.info p.desc in + let p = change_desc p d in + match d with + | Aff (x,e) -> + let e1,p1 = extract_pre e in + change_desc (add_pre p1 p) (Aff (x,e1)) + + | TabAff (check, x, ({ desc = Expression _ } as e1), e2) -> + let e1',p1 = extract_pre e1 in + let e2',p2 = extract_pre e2 in + change_desc (add_pre (p1@p2) p) (TabAff (check,x,e1',e2')) + + | While (b,inv,_,_) -> + let _,s = decomp_boolean b.post in + let s = make_before_after s in + let q = match inv with + None -> Some (anonymous s) + | Some i -> Some { a_value = conj i.a_value s; a_name = i.a_name } + in + let q = option_app (named_app abstract_unit) q in + post_if_none env q p + + | SApp ([Variable id], [e1;e2]) + when id = connective_and or id = connective_or -> + let (_,_,_,q1) = e1.info.kappa + and (_,_,_,q2) = e2.info.kappa in + let (r1,s1) = decomp_boolean q1 + and (r2,s2) = decomp_boolean q2 in + let q = + let conn = if id = connective_and then "spec_and" else "spec_or" in + let c = Term.applist (constant conn, [r1; s1; r2; s2]) in + let c = Reduction.whd_betadeltaiota (Global.env()) c in + create_bool_post c + in + let d = + SApp ([Variable id; + Expression (out_post q1); + Expression (out_post q2)], + [e1; e2] ) + in + post_if_none env q (change_desc p d) + + | SApp ([Variable id], [e1]) when id = connective_not -> + let (_,_,_,q1) = e1.info.kappa in + let (r1,s1) = decomp_boolean q1 in + let q = + let c = Term.applist (constant "spec_not", [r1; s1]) in + let c = Reduction.whd_betadeltaiota (Global.env ()) c in + create_bool_post c + in + let d = SApp ([Variable id; Expression (out_post q1)], [ e1 ]) in + post_if_none env q (change_desc p d) + + | _ -> p + +and propagate_arg ren = function + | Type _ | Refarg _ as a -> a + | Term e -> Term (propagate ren e) + + +and propagate_block ren env = function + | [] -> + [] + | (Statement p) :: (Assert q) :: rem when annotation_candidate p -> + (* TODO: plutot p.post = None ? *) + let q' = + let ((id,v),_,_,_) = p.info.kappa in + let tv = Pmonad.trad_ml_type_v ren env v in + named_app (abstract [id,tv]) q + in + let p' = post_if_none env (Some q') p in + (Statement (propagate ren p')) :: (Assert q) + :: (propagate_block ren env rem) + | (Statement p) :: rem -> + (Statement (propagate ren p)) :: (propagate_block ren env rem) + | (Label s as x) :: rem -> + x :: propagate_block (push_date ren s) env rem + | x :: rem -> + x :: propagate_block ren env rem diff --git a/contrib/correctness/pwp.mli b/contrib/correctness/pwp.mli new file mode 100644 index 00000000..015031a0 --- /dev/null +++ b/contrib/correctness/pwp.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Certification of Imperative Programs / Jean-Christophe Filliâtre *) + +(* $Id: pwp.mli,v 1.2.16.1 2004/07/16 19:30:06 herbelin Exp $ *) + +open Term +open Penv + +val update_post : local_env -> string -> Peffect.t -> constr -> constr + +val propagate : Prename.t -> typed_program -> typed_program diff --git a/contrib/extraction/BUGS b/contrib/extraction/BUGS new file mode 100644 index 00000000..7f3f59c1 --- /dev/null +++ b/contrib/extraction/BUGS @@ -0,0 +1,2 @@ +It's not a bug, it's a lack of feature !! +Cf TODO. diff --git a/contrib/extraction/CHANGES b/contrib/extraction/CHANGES new file mode 100644 index 00000000..83ea4910 --- /dev/null +++ b/contrib/extraction/CHANGES @@ -0,0 +1,409 @@ +7.4 -> 8.0 + +No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes, +but also a few steps toward a more user-friendly extraction: + +* syntax of extraction: +- The old (Recursive) Extraction Module M. + is now (Recursive) Extraction Library M. + The old name was misleading since this command only works with M being a + library M.v, and not a module produced by interactive command Module M. +- The other commands + Extraction foo. + Recursive Extraction foo bar. + Extraction "myfile.ml" foo bar. + now accept that foo can be a module name instead of just a constant name. + +* Support of type scheme axioms (i.e. axiom whose type is an arity + (x1:X1)...(xn:Xn)s with s a sort). For example: + + Axiom myprod : Set -> Set -> Set. + Extract Constant myprod "'a" "'b" => "'a * 'b". + Recursive Extraction myprod. + -------> type ('a,'b) myprod = 'a * 'b + +* More flexible support of axioms. When an axiom isn't realized via Extract + Constant before extraction, a warning is produced (instead of an error), + and the extracted code must be completed later by hand. To find what + needs to be completed, search for the following string: AXIOM TO BE REALIZED + +* Cosmetics: When extraction produces a file, it tells it. + +* (Experimental) It is allowed to extract under a opened interactive module + (but still outside sections). Feature to be used with caution. + +* A problem has been identified concerning .v files used as normal interactive + modules, like in + + <file A.v> + Definition foo :=O. + <End file A.v> + + <at toplevel> + Require A. + Module M:=A + Extraction M. + + I might try to support that in the future. In the meanwhile, the + current behaviour of extraction is to forbid this. + +* bug fixes: +- many concerning Records. +- a Stack Overflow with mutual inductive (PR#320) +- some optimizations have been removed since they were not type-safe: + For example if e has type: type 'x a = A + Then: match e with A -> A -----X----> e + To be investigated further. + + +7.3 -> 7.4 + +* The two main new features: + - Automatic generation of Obj.magic when the extracted code + in Ocaml is not directly typable. + - An experimental extraction of Coq's new modules to Ocaml modules. + +* Concerning those Obj.magic: + - The extraction now computes the expected type of any terms. Then + it compares it with the actual type of the produced code. And when + a mismatch is found, a Obj.magic is inserted. + + - As a rule, any extracted development that was compiling out of the box + should not contain any Obj.magic. At the other hand, generation of + Obj.magic is not optimized yet: there might be several of them at a place + were one would have been enough. + + - Examples of code needing those Obj.magic: + * contrib/extraction/test_extraction.v in the Coq source + * in the users' contributions: + Lannion + Lyon/CIRCUITS + Rocq/HIGMAN + + - As a side-effect of this Obj.magic feature, we now print the types + of the extracted terms, both in .ml files as commented documentation + and in interfaces .mli files + + - This feature hasn't been ported yet to Haskell. We are aware of + some unsafe casting functions like "unsafeCoerce" on some Haskell implems. + So it will eventually be done. + +* Concerning the extraction of Coq's new modules: + - Taking in account the new Coq's modules system has implied a *huge* + rewrite of most of the extraction code. + + - The extraction core (translation from Coq to an abstract mini-ML) + is now complete and fairly stable, and supports modules, modules type + and functors and all that stuff. + + - The ocaml pretty-print part, especially the renaming issue, is + clearly weaker, and certainly still contains bugs. + + - Nothing done for translating these Coq Modules to Haskell. + + - A temporary drawback of this module extraction implementation is that + efficiency (especially extraction speed) has been somehow neglected. + To improve ... + + - As an interesting side-effect, definitions are now printed according to + the user's original order. No more of this "dependency-correct but weird" + order. In particular realized axioms via Extract Constant are now at their + right place, and not at the beginning. + +* Other news: + + - Records are now printed using the Ocaml record syntax + + - Syntax output toward Scheme. Quite funny, but quite experimental and + not documented. I recommend using the bigloo compiler since it contains + natively some pattern matching. + + - the dummy constant "__" have changed. see README + + - a few bug-fixes (#191 and others) + +7.2 -> 7.3 + +* Improved documentation in the Reference Manual. + +* Theoretical bad news: +- a naughty example (see the end of test_extraction.v) +forced me to stop eliminating lambdas and arguments corresponding to +so-called "arity" in the general case. + +- The dummy constant used in extraction ( let prop = () in ocaml ) +may in some cases be applied to arguments. This problem is dealt by +generating sufficient abstraction before the (). + + +* Theoretical good news: +- there is now a mechanism that remove useless prop/arity lambdas at the +top of function declarations. If your function had signature +nat -> prop -> nat in the previous extraction, it will now be nat -> nat. +So the extractions of common terms should look very much like the old +V6.2 one, except in some particular cases (functions as parameters, partial +applications, etc). In particular the bad news above have nearly no +impact... + + +* By the way there is no more "let prop = ()" in ocaml. Those () are +directly inlined. And in Haskell the dummy constant is now __ (two +underscore) and is defined by +__ = Prelude.error "Logical or arity value used" +This dummy constant should never be evaluated when computing an +informative value, thanks to the lazy strategy. Hence the error message. + + +* Syntax changes, see Documentation for details: + +Extraction Language Ocaml. +Extraction Language Haskell. +Extraction Language Toplevel. + +That fixes the target language of extraction. Default is Ocaml, even in the +coq toplevel: you can now do copy-paste from the coq toplevel without +renaming problems. Toplevel language is the ocaml pseudo-language used +previously used inside the coq toplevel: coq names are printed with the coq +way, i.e. with no renaming. + +So there is no more particular commands for Haskell, like +Haskell Extraction "file" id. Just set your favourite language and go... + + +* Haskell extraction has been tested at last (and corrected...). +See specificities in Documentation. + + +* Extraction of CoInductive in Ocaml language is now correct: it uses the +Lazy.force and lazy features of Ocaml. + + +* Modular extraction in Ocaml is now far more readable: +instead of qualifying everywhere (A.foo), there are now some "open" at the +beginning of files. Possible clashes are dealt with. + + +* By default, any recursive function associated with an inductive type +(foo_rec and foo_rect when foo is inductive type) will now be inlined +in extracted code. + + +* A few constants are explicitely declared to be inlined in extracted code. +For the moment there are: + Wf.Acc_rec + Wf.Acc_rect + Wf.well_founded_induction + Wf.well_founded_induction_type +Those constants does not match the auto-inlining criterion based on strictness. +Of course, you can still overide this behaviour via some Extraction NoInline. + +* There is now a web page showing the extraction of all standard theories: +http://www.lri.fr/~letouzey/extraction + + +7.1 -> 7.2 : + +* Syntax changes, see Documentation for more details: + +Set/Unset Extraction Optimize. + +Default is Set. This control all optimizations made on the ML terms +(mostly reduction of dummy beta/iota redexes, but also simplications on +Cases, etc). Put this option to Unset if you what a ML term as close as +possible to the Coq term. + +Set/Unset Extraction AutoInline. + +Default in Set, so by default, the extraction mechanism feels free to +inline the bodies of some defined constants, according to some heuristics +like size of bodies, useness of some arguments, etc. Those heuristics are +not always perfect, you may want to disable this feature, do it by Unset. + +Extraction Inline toto foo. +Extraction NoInline titi faa bor. + +In addition to the automatic inline feature, you can now tell precisely to +inline some more constants by the Extraction Inline command. Conversely, +you can forbid the inlining of some specific constants by automatic inlining. +Those two commands enable a precise control of what is inlined and what is not. + +Print Extraction Inline. + +Sum up the current state of the table recording the custom inlings +(Extraction (No)Inline). + +Reset Extraction Inline. + +Put the table recording the custom inlings back to empty. + +As a consequence, there is no more need for options inside the commands of +extraction: + +Extraction foo. +Recursive Extraction foo bar. +Extraction "file" foo bar. +Extraction Module Mymodule. +Recursive Extraction Module Mymodule. + +New: The last syntax extracts the module Mymodule and all the modules +it depends on. + +You can also try the Haskell versions (not tested yet): + +Haskell Extraction foo. +Haskell Recursive Extraction foo bar. +Haskell Extraction "file" foo bar. +Haskell Extraction Module Mymodule. +Haskell Recursive Extraction Module Mymodule. + +And there's still the realization syntax: + +Extract Constant coq_bla => "caml_bla". +Extract Inlined Constant coq_bla => "caml_bla". +Extract Inductive myinductive => mycamlind [my_caml_constr1 ... ]. + +Note that now, the Extract Inlined Constant command is sugar for an Extract +Constant followed by a Extraction Inline. So be careful with +Reset Extraction Inline. + + + +* Lot of works around optimization of produced code. Should make code more +readable. + +- fixpoint definitions : there should be no more stupid printings like + +let foo x = + let rec f x = + .... (f y) .... + in f x + +but rather + +let rec foo x = + .... (foo y) .... + +- generalized iota (in particular iota and permutation cases/cases): + +A generalized iota redex is a "Cases e of ...." where e is ok. +And the recursive predicate "ok" is given by: +e is ok if e is a Constructor or a Cases where all branches are ok. +In the case of generalized iota redex, it might be good idea to reduce it, +so we do it. +Example: + +match (match t with + O -> Left + | S n -> match n with + O -> Right + | S m -> Left) with + Left -> blabla +| Right -> bloblo + +After simplification, that gives: + +match t with + O -> blabla +| S n -> match n with + O -> bloblo + | S n -> blabla + +As shown on the example, code duplication can occur. In practice +it seems not to happen frequently. + +- "constant" case: +In V7.1 we used to simplify cases where all branches are the same. +In V7.2 we can simplify in addition terms like + cases e of + C1 x y -> f (C x y) + | C2 z -> f (C2 z) +If x y z don't occur in f, we can produce (f e). + +- permutation cases/fun: +extracted code has frequenty functions in branches of cases: + +let foo x = match x with + O -> fun _ -> .... + | S y -> fun _ -> .... + +the optimization consist in lifting the common "fun _ ->", and that gives + +let foo x _ = match x with + O -> ..... + | S y -> .... + + +* Some bug corrections (many thanks in particular to Michel Levy). + +* Testing in coq contributions: +If you are interested in extraction, you can look at the extraction tests +I'have put in the following coq contributions + +Bordeaux/Additions computation of fibonacci(2000) +Bordeaux/EXCEPTIONS multiplication using exception. +Bordeaux/SearchTrees list -> binary tree. maximum. +Dyade/BDDS boolean tautology checker. +Lyon/CIRCUITS multiplication via a modelization of a circuit. +Lyon/FIRING-SQUAD print the states of the firing squad. +Marseille/CIRCUITS compares integers via a modelization of a circuit. +Nancy/FOUnify unification of two first-orderde deux termes. +Rocq/ARITH/Chinese computation of the chinese remaindering. +Rocq/COC small coc typechecker. (test by B. Barras, not by me) +Rocq/HIGMAN run the proof on one example. +Rocq/GRAPHS linear constraints checker in Z. +Sophia-Antipolis/Stalmarck boolean tautology checker. +Suresnes/BDD boolean tautology checker. + +Just do "make" in those contributions, the extraction test is integrated. +More tests will follow on more contributions. + + + +7.0 -> 7.1 : mostly bug corrections. No theoretical problems dealed with. + +* The semantics of Extract Constant changed: If you provide a extraction +for p by Extract Constant p => "0", your generated ML file will begin by +a let p = 0. The old semantics, which was to replace p everywhere by the +provided terms, is still available via the Extract Inlined Constant p => +"0" syntax. + + +* There are more optimizations applied to the generated code: +- identity cases: match e with P x y -> P x y | Q z -> Q z | ... +is simplified into e. Especially interesting with the sumbool terms: +there will be no more match ... with Left -> Left | Right -> Right + +- constant cases: match e with P x y -> c | Q z -> c | ... +is simplified into c as soon as x, y, z do not occur in c. +So no more match ... with Left -> Left | Right -> Left. + + +* the extraction at Toplevel (Extraction foo and Recursive Extraction foo), +which was only a development tool at the beginning, is now closer to +the real extraction to a file. In particular optimizations are done, +and constants like recursors ( ..._rec ) are expanded. + + +* the singleton optimization is now protected against circular type. +( Remind : this optimization is the one that simplify +type 'a sig = Exists of 'a into type 'a sig = 'a and +match e with (Exists c) -> d into let c = e in d ) + + +* Fixed one bug concerning casted code + + +* The inductives generated should now have always correct type-var list +('a,'b,'c...) + + +* Code cleanup until three days before release. Messing-up code +in the last three days before release. + + + + + + + +6.x -> 7.0 : Everything changed. See README diff --git a/contrib/extraction/README b/contrib/extraction/README new file mode 100644 index 00000000..7350365e --- /dev/null +++ b/contrib/extraction/README @@ -0,0 +1,139 @@ + +Status of Extraction in Coq version 7.x +====================================== + +(* 22 jan 2003 : Updated for version 7.4 *) + + +J.C. Filliâtre +P. Letouzey + + + +Extraction code has been completely rewritten since version V6.3. +This work is still not finished, but most parts of it are already usable. +In consequence it is included in the Coq V7.0 final release. +But don't be mistaken: + + THIS WORK IS STILL EXPERIMENTAL ! + +1) Principles + +The main goal of the new extraction is to handle any Coq term, even +those upon sort Type, and to produce code that always compiles. +Thus it will never answer something like "Not an ML type", but rather +a dummy term like the ML unit. + +Translation between Coq and ML is based upon the following principles: + +- Terms of sort Prop don't have any computational meaning, so they are +merged into one ML term "__". This part is done according to P. Letouzey's +works (*) and (**). + +This dummy constant "__" used to be implemented by the unit (), but +we recently found that this constant might be applied in some cases. +So "__" is now in Ocaml a fixpoint that forgets its arguments: + + let __ = let rec f _ = Obj.repr f in Obj.repr f + + +- Terms that are type schemes (i.e. something of type ( : )( : )...s with +s a sort ) don't have any ML counterpart at the term level, since they +are types transformers. In fact they do not have any computational +meaning either. So we also merge them into that dummy term "__". + +- A Coq term gives a ML term or a ML type depending of its type: +type schemes will (try to) give ML types, and all other terms give ML terms. + +And the rest of the translation is (almost) straightforward: an inductive +gives an inductive, etc... + +This gives ML code that have no special reason to typecheck, due +to the incompatibilities between Coq and ML typing systems. In fact +most of the time everything goes right. For example, it is sufficient +to extract and compile everything in the "theories" directory +(cf test subdirectory). + +We now verify during extraction that the produced code is typecheckable, +and if it is not we insert unsafe type casting at critical points in the +code. For the moment, it is an Ocaml-only feature, using the "Obj.magic" +function, but the same kind of trick will be soon made in Haskell. + + +2) Differences with previous extraction (V6.3 and before) + +2.a) The pros + +The ability to extract every Coq term, as explain in the previous +paragraph. + +The ability to extract from a file an ML module (cf Extraction Module in the +documentation) + +You can have a taste of extraction directly at the toplevel by +using the "Extraction <ident>" or the "Recursive Extraction <ident>". +This toplevel extraction was already there in V6.3, but was printing +Fw terms. It now prints in the language of your choice: +Ocaml, Haskell, Scheme, or an Ocaml-like with Coq namings. + +The optimization done on extracted code has been ported between +V6.3 and V7 and enhanced, and in particular the mechanism of automatic +expansion. + +2.b) The cons + +The presence of some parasite "__" as dummy arguments +in functions. This denotes the rests of a proof part. The previous +extraction was able to remove them totally. The current implementation +removes a good deal of them (more that in 7.0), but not all. + +This problem is due to extraction upon Type. +For example, let's take this pathological term: + (if b then Set else Prop) : Type +The only way to know if this is an Set (to keep) or a Prop (to remove) +is to compute the boolean b, and we do not want to do that during +extraction. + +There is no more "ML import" feature. You can compensate by using +Axioms, and then "Extract Constant ..." + +3) Examples + +The file "test-extraction.v" is made of some examples used while debugging. + +In the subdirectory "test", you can test extraction on the Coq theories. +Go there. +"make tree" to make a local copy of the "theories" tree +"make" to extract & compile most of the theories file in Ocaml +"make -f Makefile.haskell" to extract & compile in Haskell + +See also Reference Manual for explanation of extraction syntaxes +and more examples. + + +(*): +Exécution de termes de preuves: une nouvelle méthode d'extraction +pour le Calcul des Constructions Inductives, Pierre Letouzey, +DEA thesis, 2000, +http://www.lri.fr/~letouzey/download/rapport_dea.ps.gz + +(**) +A New Extraction for Coq, Pierre Letouzey, +Types 2002 Post-Workshop Proceedings, to appear, +draft at http://www.lri.fr/~letouzey/download/extraction2002.ps.gz + + +Any feedback is welcome: +Pierre.Letouzey@lri.fr +Jean.Christophe.Filliatre@lri.fr + + + + + + + + + + + diff --git a/contrib/extraction/TODO b/contrib/extraction/TODO new file mode 100644 index 00000000..174be06e --- /dev/null +++ b/contrib/extraction/TODO @@ -0,0 +1,31 @@ + + 16. Haskell : + - equivalent of Obj.magic (unsafeCoerce ?) + - look again at the syntax (make it independant of layout ...) + - producing .hi files + - modules/modules types/functors in Haskell ? + + 17. Scheme : + - modular Scheme ? + + 18. Improve speed (profiling) + + 19. Look again at those hugly renamings functions. + Especially get rid of ML clashes like + + let t = 0 + module M = struct + let t = 1 + let u = The.External.t (* ?? *) + end + + 20. Support the .v-as-internal-module, like in + + <file A.v> + Definition foo :=O. + <End file A.v> + + <at toplevel> + Require A. + Module M:=A + Extraction M.
\ No newline at end of file diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml new file mode 100644 index 00000000..53a2631e --- /dev/null +++ b/contrib/extraction/common.ml @@ -0,0 +1,441 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: common.ml,v 1.51.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) + +open Pp +open Util +open Names +open Term +open Declarations +open Nameops +open Libnames +open Table +open Miniml +open Modutil +open Ocaml + +(*S Renamings. *) + +(*s Tables of global renamings *) + +let keywords = ref Idset.empty +let global_ids = ref Idset.empty +let modular = ref false + +(* For each [global_reference], this table will contain the different parts + of its renamings, in [string list] form. *) +let renamings = Hashtbl.create 97 +let rename r l = Hashtbl.add renamings r l +let get_renamings r = Hashtbl.find renamings r + +(* Idem for [module_path]. *) +let mp_renamings = Hashtbl.create 97 +let mp_rename mp l = Hashtbl.add mp_renamings mp l +let mp_get_renamings mp = Hashtbl.find mp_renamings mp + +let modvisited = ref MPset.empty +let modcontents = ref Gset.empty +let add_module_contents mp s = modcontents := Gset.add (mp,s) !modcontents +let module_contents mp s = Gset.mem (mp,s) !modcontents + +let to_qualify = ref Refset.empty + +let mod_1st_level = ref Idmap.empty + +(*s Uppercase/lowercase renamings. *) + +let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false + +let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false + +(* This function creates from [id] a correct uppercase/lowercase identifier. + This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes + with previous [Coq_id] variable, these prefixes are duplicated if already + existing. *) + +let modular_rename up id = + let s = string_of_id id in + let prefix = if up then "Coq_" else "coq_" in + let check = if up then is_upper else is_lower in + if not (check s) || + (Idset.mem id !keywords) || + (String.length s >= 4 && String.sub s 0 4 = prefix) + then prefix ^ s + else s + +let rename_module = modular_rename true + +(* [clash mp0 l s mpl] checks if [mp0-l-s] can be printed as [l-s] when + [mpl] is the context of visible modules. More precisely, we check if + there exists a mp1, module (sub-)path of an element of [mpl], such as + module [mp1-l] contains [s]. + The verification stops if we encounter [mp1=mp0]. *) + +exception Stop + +let clash mp0 l s mpl = + let rec clash_one mp = match mp with + | _ when mp = mp0 -> raise Stop + | MPdot (mp',_) -> + (module_contents (add_labels_mp mp l) s) || (clash_one mp') + | mp when is_toplevel mp -> false + | _ -> module_contents (add_labels_mp mp l) s + in + let rec clash_list = function + | [] -> false + | mp :: mpl -> (clash_one mp) || (clash_list mpl) + in try clash_list mpl with Stop -> false + +(*s [contents_first_level mp] finds the names of the first-level objects + exported by module [mp]. Nota: it might fail if [mp] isn't a directly + visible module. Ex: [MPself] under functor, [MPbound], etc ... *) + +let contents_first_level mp = + if not (MPset.mem mp !modvisited) then begin + modvisited := MPset.add mp !modvisited; + match (Global.lookup_module mp).mod_type with + | MTBsig (msid,msb) -> + let add b id = add_module_contents mp (modular_rename b id) in + let upper_type = (lang () = Haskell) in + List.iter + (function + | (l, SPBconst cb) -> + (match Extraction.constant_kind (Global.env ()) cb with + | Extraction.Logical -> () + | Extraction.Type -> add upper_type (id_of_label l) + | Extraction.Term -> add false (id_of_label l)) + | (_, SPBmind mib) -> + Array.iter + (fun mip -> if mip.mind_sort <> (Prop Null) then begin + add upper_type mip.mind_typename; + Array.iter (add true) mip.mind_consnames + end) + mib.mind_packets + | _ -> ()) + (Modops.subst_signature_msid msid mp msb) + | _ -> () + end + +(*s Initial renamings creation, for modular extraction. *) + +let rec mp_create_modular_renamings mp = + try mp_get_renamings mp + with Not_found -> + let ren = match mp with + | MPdot (mp,l) -> + (rename_module (id_of_label l)) :: (mp_create_modular_renamings mp) + | MPself msid -> [rename_module (id_of_msid msid)] + | MPbound mbid -> [rename_module (id_of_mbid mbid)] + | MPfile f -> [String.capitalize (string_of_id (List.hd (repr_dirpath f)))] + in mp_rename mp ren; ren + + +let create_modular_renamings struc = + let current_module = fst (List.hd struc) in + let modfiles = ref MPset.empty in + let { up = u ; down = d } = struct_get_references_set struc + in + (* 1) creates renamings of objects *) + let add upper r = + let mp = modpath (kn_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; + rename r (s::l); + begin try + let mp = modfile_of_mp mp in + if mp <> current_module then modfiles := MPset.add mp !modfiles + with Not_found -> () + end; + in + Refset.iter (add true) u; + Refset.iter (add false) d; + + (* 2) determines the opened libraries. *) + let used_modules = MPset.elements !modfiles in + + (* [s] will contain all first-level sub-modules of [cur_mp] *) + let s = ref Stringset.empty in + begin + let add l = s := Stringset.add (rename_module (id_of_label l)) !s in + match (Global.lookup_module current_module).mod_type with + | MTBsig (_,msb) -> + List.iter (function (l,SPBmodule _) -> add l | _ -> ()) msb + | _ -> () + end; + (* We now compare [s] with the modules coming from [used_modules]. *) + List.iter + (function + | MPfile d -> + let s_mp = + String.capitalize (string_of_id (List.hd (repr_dirpath d))) in + if Stringset.mem s_mp !s then error_module_clash s_mp + else s:= Stringset.add s_mp !s + | _ -> assert false) + used_modules; + + (* 3) determines the potential clashes *) + 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 + if (is_modfile mp) && mp <> current_module && + (clash mp [] (List.hd (get_renamings r)) used_modules') + then to_qualify := Refset.add r !to_qualify + in + Refset.iter needs_qualify u; + Refset.iter needs_qualify d; + used_modules + +(*s Initial renamings creation, for monolithic extraction. *) + +let begins_with_CoqXX s = + (String.length s >= 4) && + (String.sub s 0 3 = "Coq") && + (try + for i = 4 to (String.index s '_')-1 do + match s.[i] with + | '0'..'9' -> () + | _ -> raise Not_found + done; + true + with Not_found -> false) + +let mod_1st_level_rename l = + let coqid = id_of_string "Coq" in + let id = id_of_label l in + try + let coqset = Idmap.find id !mod_1st_level in + let nextcoq = next_ident_away coqid coqset in + mod_1st_level := Idmap.add id (nextcoq::coqset) !mod_1st_level; + (string_of_id nextcoq)^"_"^(string_of_id id) + with Not_found -> + let s = string_of_id id in + if is_lower s || begins_with_CoqXX s then + (mod_1st_level := Idmap.add id [coqid] !mod_1st_level; "Coq_"^s) + else + (mod_1st_level := Idmap.add id [] !mod_1st_level; s) + +let rec mp_create_mono_renamings mp = + try mp_get_renamings mp + with Not_found -> + let ren = match mp with + | _ when (at_toplevel mp) -> [""] + | MPdot (mp,l) -> + let lmp = mp_create_mono_renamings mp in + if lmp = [""] then (mod_1st_level_rename l)::lmp + else (rename_module (id_of_label l))::lmp + | MPself msid -> [rename_module (id_of_msid msid)] + | MPbound mbid -> [rename_module (id_of_mbid mbid)] + | _ -> assert false + in mp_rename mp ren; ren + +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 l = mp_create_mono_renamings mp in + let mycase = if upper then uppercase_id else lowercase_id in + let id = + if l = [""] then + next_ident_away (mycase (id_of_global r)) (Idset.elements !global_ids) + else id_of_string (modular_rename upper (id_of_global r)) + in + global_ids := Idset.add id !global_ids; + rename r ((string_of_id id)::l) + in + List.iter (add true) (List.rev u); + List.iter (add false) (List.rev d) + +(*s Renaming issues at toplevel *) + +module TopParams = struct + let globals () = Idset.empty + let pp_global _ r = pr_id (id_of_global r) + let pp_module _ mp = str (string_of_mp mp) +end + +(*s Renaming issues for a monolithic or modular extraction. *) + +module StdParams = struct + + let globals () = !global_ids + + (* TODO: remettre des conditions [lang () = Haskell] disant de qualifier. *) + + let rec dottify = function + | [] -> assert false + | [s] -> s + | s::[""] -> s + | s::l -> (dottify l)^"."^s + + 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 ls = + if mp = List.hd mpl then [s] (* simpliest situation *) + else + try (* has [mp] something in common with one of those in [mpl] ? *) + let pref = common_prefix_from_list mp mpl in + (*i TODO: possibilité de clash i*) + list_firstn ((mp_length mp)-(mp_length pref)+1) ls + with Not_found -> (* [mp] is othogonal with every element of [mp]. *) + let base = base_mp mp in + if !modular && + (at_toplevel mp) && + not (Refset.mem r !to_qualify) && + not (clash base [] s mpl) + then snd (list_sep_last ls) + else ls + in + add_module_contents mp s; (* update the visible environment *) + str (dottify ls) + + let pp_module mpl mp = + let ls = + if !modular + then mp_create_modular_renamings mp + else mp_create_mono_renamings mp + in + let ls = + try (* has [mp] something in common with one of those in [mpl] ? *) + let pref = common_prefix_from_list mp mpl in + (*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 + in str (dottify ls) + +end + +module ToplevelPp = Ocaml.Make(TopParams) +module OcamlPp = Ocaml.Make(StdParams) +module HaskellPp = Haskell.Make(StdParams) +module SchemePp = Scheme.Make(StdParams) + +let pp_decl mp d = match lang () with + | Ocaml -> OcamlPp.pp_decl mp d + | Haskell -> HaskellPp.pp_decl mp d + | Scheme -> SchemePp.pp_decl mp d + | Toplevel -> ToplevelPp.pp_decl mp d + +let pp_struct s = match lang () with + | Ocaml -> OcamlPp.pp_struct s + | Haskell -> HaskellPp.pp_struct s + | Scheme -> SchemePp.pp_struct s + | Toplevel -> ToplevelPp.pp_struct s + +let pp_signature s = match lang () with + | Ocaml -> OcamlPp.pp_signature s + | Haskell -> HaskellPp.pp_signature s + | _ -> assert false + +let set_keywords () = + (match lang () with + | Ocaml -> keywords := Ocaml.keywords + | Haskell -> keywords := Haskell.keywords + | Scheme -> keywords := Scheme.keywords + | Toplevel -> keywords := Idset.empty); + global_ids := !keywords; + to_qualify := Refset.empty + +let preamble prm = match lang () with + | Ocaml -> Ocaml.preamble prm + | Haskell -> Haskell.preamble prm + | Scheme -> Scheme.preamble prm + | Toplevel -> (fun _ _ -> mt ()) + +let preamble_sig prm = match lang () with + | Ocaml -> Ocaml.preamble_sig prm + | _ -> assert false + +(*S Extraction of one decl to stdout. *) + +let print_one_decl struc mp decl = + set_keywords (); + modular := false; + create_mono_renamings struc; + msgnl (pp_decl [mp] decl) + +(*S Extraction to a file. *) + +let info f = + Options.if_verbose msgnl + (str ("The file "^f^" has been created by extraction.")) + +let print_structure_to_file f prm struc = + cons_cofix := Refset.empty; + Hashtbl.clear renamings; + mod_1st_level := Idmap.empty; + modcontents := Gset.empty; + modvisited := MPset.empty; + set_keywords (); + modular := prm.modular; + let used_modules = + if lang () = Toplevel then [] + else if prm.modular then create_modular_renamings struc + else (create_mono_renamings struc; []) + in + let print_dummys = + (struct_ast_search MLdummy struc, + struct_type_search Tdummy struc, + struct_type_search Tunknown struc) + in + (* print the implementation *) + let cout = option_app (fun (f,_) -> open_out f) f in + let ft = match cout with + | None -> !Pp_control.std_ft + | Some cout -> Pp_control.with_output_to cout in + begin try + msg_with ft (preamble prm used_modules print_dummys); + msg_with ft (pp_struct struc); + option_iter close_out cout; + with e -> + option_iter close_out cout; raise e + end; + option_iter (fun (f,_) -> info f) f; + (* print the signature *) + match f with + | Some (_,f) when lang () = Ocaml -> + let cout = open_out f in + let ft = Pp_control.with_output_to cout in + begin try + msg_with ft (preamble_sig prm used_modules print_dummys); + msg_with ft (pp_signature (signature_of_structure struc)); + close_out cout; + with e -> + close_out cout; raise e + end; + info f + | _ -> () + + +(*i + (* DO NOT REMOVE: used when making names resolution *) + let cout = open_out (f^".ren") in + let ft = Pp_control.with_output_to cout in + Hashtbl.iter + (fun r id -> + if short_module r = !current_module then + msgnl_with ft (pr_id id ++ str " " ++ pr_sp (sp_of_r r))) + renamings; + pp_flush_with ft (); + close_out cout; +i*) + + + + + + + diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli new file mode 100644 index 00000000..3e5efa0c --- /dev/null +++ b/contrib/extraction/common.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: common.mli,v 1.19.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) + +open Names +open Miniml +open Mlutil + +val print_one_decl : + ml_structure -> module_path -> ml_decl -> unit + +val print_structure_to_file : + (string * string) option -> extraction_params -> ml_structure -> unit + + diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml new file mode 100644 index 00000000..d725a1d7 --- /dev/null +++ b/contrib/extraction/extract_env.ml @@ -0,0 +1,382 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: extract_env.ml,v 1.74.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) + +open Term +open Declarations +open Names +open Libnames +open Pp +open Util +open Miniml +open Table +open Extraction +open Modutil +open Common + +(*s Obtaining Coq environment. *) + +let toplevel_env () = + let seg = Lib.contents_after None in + let get_reference = function + | (_,kn), Lib.Leaf o -> + let mp,_,l = repr_kn kn in + let seb = match Libobject.object_tag o with + | "CONSTANT" -> SEBconst (Global.lookup_constant kn) + | "INDUCTIVE" -> SEBmind (Global.lookup_mind kn) + | "MODULE" -> SEBmodule (Global.lookup_module (MPdot (mp,l))) + | "MODULE TYPE" -> SEBmodtype (Global.lookup_modtype kn) + | _ -> failwith "caught" + in l,seb + | _ -> failwith "caught" + in + match current_toplevel () with + | MPself msid -> MEBstruct (msid, List.rev (map_succeed get_reference seg)) + | _ -> assert false + +let environment_until dir_opt = + let rec parse = function + | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()] + | [] -> [] + | d :: l -> + match (Global.lookup_module (MPfile d)).mod_expr with + | Some meb -> + if dir_opt = Some d then [MPfile d, meb] + else (MPfile d, meb) :: (parse l) + | _ -> assert false + in parse (Library.loaded_libraries ()) + +type visit = { mutable kn : KNset.t; mutable mp : MPset.t } + +let in_kn v kn = KNset.mem kn v.kn +let in_mp v mp = MPset.mem mp v.mp + +let visit_mp v mp = v.mp <- MPset.union (prefixes_mp mp) v.mp +let visit_kn v kn = v.kn <- KNset.add kn v.kn; visit_mp v (modpath kn) +let visit_ref v r = visit_kn v (kn_of_r r) + +exception Impossible + +let check_arity env cb = + if Reduction.is_arity env cb.const_type then raise Impossible + +let check_fix env cb i = + match cb.const_body with + | None -> raise Impossible + | Some lbody -> + match kind_of_term (Declarations.force lbody) with + | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd) + | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd) + | _ -> raise Impossible + +let factor_fix env l cb msb = + let _,recd as check = check_fix env cb 0 in + let n = Array.length (let fi,_,_ = recd in fi) in + if n = 1 then [|l|], recd, msb + else begin + if List.length msb < n-1 then raise Impossible; + let msb', msb'' = list_chop (n-1) msb in + let labels = Array.make n l in + list_iter_i + (fun j -> + function + | (l,SEBconst cb') -> + if check <> check_fix env cb' (j+1) then raise Impossible; + labels.(j+1) <- l; + | _ -> raise Impossible) msb'; + labels, recd, msb'' + end + +let get_decl_references v d = + let f = visit_ref v in decl_iter_references f f f d + +let get_spec_references v s = + let f = visit_ref v in spec_iter_references f f f s + +let rec extract_msig env v mp = function + | [] -> [] + | (l,SPBconst cb) :: msig -> + let kn = make_kn 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 + get_spec_references v s; + (l,Spec s) :: (extract_msig env v mp msig) + end + | (l,SPBmind cb) :: msig -> + let kn = make_kn mp empty_dirpath l in + let s = Sind (kn, extract_inductive env kn) in + if logical_spec s then extract_msig env v mp msig + else begin + get_spec_references v s; + (l,Spec s) :: (extract_msig env v mp msig) + end + | (l,SPBmodule {msb_modtype=mtb}) :: msig -> +(*i let mpo = Some (MPdot (mp,l)) in i*) + (l,Smodule (extract_mtb env v None (*i mpo i*) mtb)) :: (extract_msig env v mp msig) + | (l,SPBmodtype mtb) :: msig -> + (l,Smodtype (extract_mtb env v None mtb)) :: (extract_msig env v mp msig) + +and extract_mtb env v mpo = function + | MTBident kn -> visit_kn v kn; MTident kn + | MTBfunsig (mbid, mtb, mtb') -> + let mp = MPbound mbid in + let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in + MTfunsig (mbid, extract_mtb env v None mtb, + extract_mtb env' v None mtb') + | MTBsig (msid, msig) -> + let mp, msig = match mpo with + | None -> MPself msid, msig + | Some mp -> mp, Modops.subst_signature_msid msid mp msig + in + let env' = Modops.add_signature mp msig env in + MTsig (msid, extract_msig env' v mp msig) + +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 ms = extract_msb env v mp all msb in + let b = array_exists (in_kn v) vkn in + if all || b then + let d = extract_fixpoint env vkn recd in + if (not b) && (logical_decl d) then ms + else begin get_decl_references v d; (l,SEdecl d) :: ms end + else ms + with Impossible -> + let ms = extract_msb env v mp all msb in + let kn = make_kn mp empty_dirpath l in + let b = in_kn v kn in + if all || b then + let d = extract_constant env kn cb in + if (not b) && (logical_decl d) then ms + else begin get_decl_references v d; (l,SEdecl d) :: ms end + else ms) + | (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 + if all || b then + let d = Dind (kn, extract_inductive env kn) in + if (not b) && (logical_decl d) then ms + else begin get_decl_references v d; (l,SEdecl d) :: ms end + else ms + | (l,SEBmodule mb) :: msb -> + let ms = extract_msb env v mp all msb in + let mp = MPdot (mp,l) in + if all || in_mp v mp then + (l,SEmodule (extract_module env v mp true mb)) :: ms + else ms + | (l,SEBmodtype mtb) :: msb -> + let ms = extract_msb env v mp all msb in + let kn = make_kn mp empty_dirpath l in + if all || in_kn v kn then + (l,SEmodtype (extract_mtb env v None mtb)) :: ms + else ms + +and extract_meb env v mpo all = function + | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *) + | MEBident mp -> visit_mp v mp; MEident mp + | MEBapply (meb, meb',_) -> + MEapply (extract_meb env v None true meb, + extract_meb env v None true meb') + | MEBfunctor (mbid, mtb, meb) -> + let mp = MPbound mbid in + let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in + MEfunctor (mbid, extract_mtb env v None mtb, + extract_meb env' v None true meb) + | MEBstruct (msid, msb) -> + let mp,msb = match mpo with + | None -> MPself msid, msb + | Some mp -> mp, subst_msb (map_msid msid mp) msb + in + let env' = add_structure mp msb env in + MEstruct (msid, extract_msb env' v mp all msb) + +and extract_module env v mp all mb = + (* [mb.mod_expr <> None ], since we look at modules from outside. *) + (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *) + let meb = out_some mb.mod_expr in + let mtb = match mb.mod_user_type with None -> mb.mod_type | Some mt -> mt in + (* Because of the "with" construct, the module type can be [MTBsig] with *) + (* a msid different from the one of the module. Here is the patch. *) + let mtb = replicate_msid meb mtb in + { ml_mod_expr = extract_meb env v (Some mp) all meb; + ml_mod_type = extract_mtb env v None mtb } + +let unpack = function MEstruct (_,sel) -> sel | _ -> assert false + +let mono_environment refs mpl = + let l = environment_until None in + let v = + let add_kn r = KNset.add (kn_of_r r) in + let kns = List.fold_right add_kn refs KNset.empty in + let add_mp mp = MPset.union (prefixes_mp mp) in + let mps = List.fold_right add_mp mpl MPset.empty in + let mps = KNset.fold (fun k -> add_mp (modpath k)) kns mps in + { kn = kns; mp = mps } + in + let env = Global.env () in + List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) false m)) + (List.rev l) + +(*s Recursive extraction in the Coq toplevel. The vernacular command is + \verb!Recursive Extraction! [qualid1] ... [qualidn]. We use [extract_env] + to get the saturated environment to extract. *) + +let mono_extraction (f,m) qualids = + check_inside_section (); + check_inside_module (); + let rec find = function + | [] -> [],[] + | q::l -> + let refs,mps = find l in + try + let mp = Nametab.locate_module (snd (qualid_of_reference q)) + in refs,(mp::mps) + with Not_found -> (Nametab.global q)::refs, mps + in + let refs,mps = find qualids in + let prm = {modular=false; mod_name = m; to_appear= refs} in + let struc = optimize_struct prm None (mono_environment refs mps) in + print_structure_to_file f prm struc; + reset_tables () + +let extraction_rec = mono_extraction (None,id_of_string "Main") + +(*s Extraction in the Coq toplevel. We display the extracted term in + Ocaml syntax and we use the Coq printers for globals. The + vernacular command is \verb!Extraction! [qualid]. *) + +let extraction qid = + check_inside_section (); + check_inside_module (); + try + let _ = Nametab.locate_module (snd (qualid_of_reference qid)) in + extraction_rec [qid] + with Not_found -> + let r = Nametab.global qid in + if is_custom r then + msgnl (str "User defined extraction:" ++ spc () ++ + str (find_custom r) ++ fnl ()) + 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; + reset_tables () + end + +(*s Extraction to a file (necessarily recursive). + The vernacular command is + \verb!Extraction "file"! [qualid1] ... [qualidn].*) + +let lang_suffix () = match lang () with + | Ocaml -> ".ml",".mli" + | Haskell -> ".hs",".hi" + | Scheme -> ".scm",".scm" + | Toplevel -> assert false + +let filename f = + let s,s' = lang_suffix () in + if Filename.check_suffix f s then + let f' = Filename.chop_suffix f s in + Some (f,f'^s'),id_of_string f' + else Some (f^s,f^s'),id_of_string f + +let extraction_file f vl = + if lang () = Toplevel then error_toplevel () + else mono_extraction (filename f) vl + +(*s Extraction of a module at the toplevel. *) + +let extraction_module m = + check_inside_section (); + check_inside_module (); + match lang () with + | Toplevel -> error_toplevel () + | Scheme -> error_scheme () + | _ -> + let q = snd (qualid_of_reference m) in + let mp = + try Nametab.locate_module q + with Not_found -> error_unknown_module q + in + let b = is_modfile mp in + let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in + let l = environment_until None in + let v = { kn = KNset.empty ; mp = prefixes_mp mp } in + let env = Global.env () in + let struc = + List.rev_map + (fun (mp,m) -> mp, unpack (extract_meb env v (Some mp) b m)) + (List.rev l) + in + let struc = optimize_struct prm None struc in + let struc = + let bmp = base_mp mp in + try [bmp, List.assoc bmp struc] with Not_found -> assert false + in + print_structure_to_file None prm struc; + reset_tables () + +(*s (Recursive) Extraction of a library. The vernacular command is + \verb!(Recursive) Extraction Library! [M]. *) + +let module_file_name m = match lang () with + | Ocaml -> let f = String.uncapitalize (string_of_id m) in f^".ml", f^".mli" + | Haskell -> let f = String.capitalize (string_of_id m) in f^".hs", f^".hi" + | _ -> assert false + +let dir_module_of_id m = + let q = make_short_qualid m in + try Nametab.full_name_module q with Not_found -> error_unknown_module q + +let extraction_library is_rec m = + check_inside_section (); + check_inside_module (); + match lang () with + | Toplevel -> error_toplevel () + | Scheme -> error_scheme () + | _ -> + let dir_m = dir_module_of_id m in + let v = { kn = KNset.empty; mp = MPset.singleton (MPfile dir_m) } in + let l = environment_until (Some dir_m) in + let struc = + let env = Global.env () in + let select l (mp,meb) = + if in_mp v mp (* [mp] est long -> [in_mp] peut etre sans [long_mp] *) + then (mp, unpack (extract_meb env v (Some mp) true meb)) :: l + else l + in + List.fold_left select [] (List.rev l) + in + let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in + let struc = optimize_struct dummy_prm None struc in + let rec print = function + | [] -> () + | (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l + | (MPfile dir, sel) as e :: l -> + let short_m = snd (split_dirpath dir) in + let f = module_file_name short_m in + let prm = {modular=true;mod_name=short_m;to_appear=[]} in + print_structure_to_file (Some f) prm [e]; + print l + | _ -> assert false + in print struc; + reset_tables () + + + + + diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli new file mode 100644 index 00000000..8ce64342 --- /dev/null +++ b/contrib/extraction/extract_env.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: extract_env.mli,v 1.13.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) + +(*s This module declares the extraction commands. *) + +open Names +open Libnames + +val extraction : reference -> unit +val extraction_rec : reference list -> unit +val extraction_file : string -> reference list -> unit +val extraction_module : reference -> unit +val extraction_library : bool -> identifier -> unit diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml new file mode 100644 index 00000000..46bf06dd --- /dev/null +++ b/contrib/extraction/extraction.ml @@ -0,0 +1,855 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: extraction.ml,v 1.136.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) + +(*i*) +open Util +open Names +open Term +open Declarations +open Environ +open Reduction +open Reductionops +open Inductive +open Termops +open Inductiveops +open Recordops +open Nameops +open Summary +open Libnames +open Nametab +open Miniml +open Table +open Mlutil +(*i*) + +exception I of inductive_info + +(* A set of all inductive currently being computed, + to avoid loops in [extract_inductive] *) +let internal_call = ref KNset.empty + +let none = Evd.empty + +let type_of env c = Retyping.get_type_of env none (strip_outer_cast c) + +let sort_of env c = Retyping.get_sort_family_of env none (strip_outer_cast c) + +let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None + +(*S Generation of flags and signatures. *) + +(* The type [flag] gives us information about any Coq term: + \begin{itemize} + \item [TypeScheme] denotes a type scheme, that is + something that will become a type after enough applications. + More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with + [s = Set], [Prop] or [Type] + \item [Default] denotes the other cases. It may be inexact after + instanciation. For example [(X:Type)X] is [Default] and may give [Set] + after instanciation, which is rather [TypeScheme] + \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop] + \item [Info] is the opposite. The same example [(X:Type)X] shows + that an [Info] term might in fact be [Logic] later on. + \end{itemize} *) + +type info = Logic | Info + +type scheme = TypeScheme | Default + +type flag = info * scheme + +(*s [flag_of_type] transforms a type [t] into a [flag]. + Really important function. *) + +let rec flag_of_type env t = + let t = whd_betadeltaiota env none t in + match kind_of_term t with + | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c + | Sort (Prop Null) -> (Logic,TypeScheme) + | Sort _ -> (Info,TypeScheme) + | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default) + +(*s Two particular cases of [flag_of_type]. *) + +let is_default env t = (flag_of_type env t = (Info, Default)) + +let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme)) + +(*s [type_sign] gernerates a signature aimed at treating a type application. *) + +let rec type_sign env c = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + (is_info_scheme env t)::(type_sign (push_rel_assum (n,t) env) d) + | _ -> [] + +let rec type_scheme_nb_args env c = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in + if is_info_scheme env t then n+1 else n + | _ -> 0 + +let _ = register_type_scheme_nb_args type_scheme_nb_args + +(*s [type_sign_vl] does the same, plus a type var list. *) + +let rec type_sign_vl env c = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in + if not (is_info_scheme env t) then false::s, vl + else true::s, (next_ident_away (id_of_name n) vl) :: vl + | _ -> [],[] + +let rec nb_default_params env c = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + let n = nb_default_params (push_rel_assum (n,t) env) d in + if is_default env t then n+1 else n + | _ -> 0 + +(*S Management of type variable contexts. *) + +(* A De Bruijn variable context (db) is a context for translating Coq [Rel] + into ML type [Tvar]. *) + +(*s From a type signature toward a type variable context (db). *) + +let db_from_sign s = + let rec make i acc = function + | [] -> acc + | true :: l -> make (i+1) (i::acc) l + | false :: l -> make i (0::acc) l + in make 1 [] s + +(*s Create a type variable context from indications taken from + an inductive type (see just below). *) + +let rec db_from_ind dbmap i = + if i = 0 then [] + else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1)) + +(*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument + of a constructor corresponds to the j-th type var of the ML inductive. *) + +(* \begin{itemize} + \item [si] : signature of the inductive + \item [i] : counter of Coq args for [(I args)] + \item [j] : counter of ML type vars + \item [relmax] : total args number of the constructor + \end{itemize} *) + +let parse_ind_args si args relmax = + let rec parse i j = function + | [] -> Intmap.empty + | false :: s -> parse (i+1) j s + | true :: s -> + (match kind_of_term args.(i-1) with + | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s) + | _ -> parse (i+1) (j+1) s) + in parse 1 1 si + +(*S Extraction of a type. *) + +(* [extract_type env db c args] is used to produce an ML type from the + coq term [(c args)], which is supposed to be a Coq type. *) + +(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) + +(* [j] stands for the next ML type var. [j=0] means we do not + generate ML type var anymore (in subterms for example). *) + +let rec extract_type env db j c args = + match kind_of_term (whd_betaiotazeta c) with + | App (d, args') -> + (* We just accumulate the arguments. *) + extract_type env db j d (Array.to_list args' @ args) + | Lambda (_,_,d) -> + (match args with + | [] -> assert false (* otherwise the lambda would be reductible. *) + | a :: args -> extract_type env db j (subst1 a d) args) + | Prod (n,t,d) -> + assert (args = []); + let env' = push_rel_assum (n,t) env in + (match flag_of_type env t with + | (Info, Default) -> + (* Standard case: two [extract_type] ... *) + let mld = extract_type env' (0::db) j d [] in + if mld = Tdummy then Tdummy + else Tarr (extract_type env db 0 t [], mld) + | (Info, TypeScheme) when j > 0 -> + (* A new type var. *) + let mld = extract_type env' (j::db) (j+1) d [] in + if mld = Tdummy then Tdummy else Tarr (Tdummy, mld) + | _ -> + let mld = extract_type env' (0::db) j d [] in + if mld = Tdummy then Tdummy else Tarr (Tdummy, mld)) + | Sort _ -> Tdummy (* The two logical cases. *) + | _ when sort_of env (applist (c, args)) = InProp -> Tdummy + | Rel n -> + (match lookup_rel n env with + | (_,Some t,_) -> extract_type env db j (lift n t) args + | _ -> + (* Asks [db] a translation for [n]. *) + if n > List.length db then Tunknown + else let n' = List.nth db (n-1) in + if n' = 0 then Tunknown else Tvar n') + | Const kn -> + let r = ConstRef kn in + let cb = lookup_constant kn env in + let typ = cb.const_type in + (match flag_of_type env typ with + | (Info, TypeScheme) -> + let mlt = extract_type_app env db (r, type_sign env typ) args in + (match cb.const_body with + | None -> mlt + | Some _ when is_custom r -> mlt + | Some lbody -> + let newc = applist (Declarations.force lbody, args) in + let mlt' = extract_type env db j newc [] in + (* ML type abbreviations interact badly with Coq *) + (* reduction, so [mlt] and [mlt'] might be different: *) + (* The more precise is [mlt'], extracted after reduction *) + (* The shortest is [mlt], which use abbreviations *) + (* If possible, we take [mlt], otherwise [mlt']. *) + if type_eq (mlt_env env) mlt mlt' then mlt else mlt') + | _ -> (* only other case here: Info, Default, i.e. not an ML type *) + (match cb.const_body with + | None -> Tunknown (* Brutal approximation ... *) + | Some lbody -> + (* We try to reduce. *) + let newc = applist (Declarations.force lbody, args) in + extract_type env db j newc [])) + | Ind ((kn,i) as ip) -> + let s = (extract_ind env kn).ind_packets.(i).ip_sign in + extract_type_app env db (IndRef (kn,i),s) args + | Case _ | Fix _ | CoFix _ -> Tunknown + | _ -> assert false + +(* [extract_maybe_type] calls [extract_type] when used on a Coq type, + and otherwise returns [Tdummy] or [Tunknown] *) + +and extract_maybe_type env db c = + let t = whd_betadeltaiota env none (type_of env c) in + if isSort t then extract_type env db 0 c [] + else if sort_of env t = InProp then Tdummy else Tunknown + +(*s Auxiliary function dealing with type application. + Precondition: [r] is a type scheme represented by the signature [s], + and is completely applied: [List.length args = List.length s]. *) + +and extract_type_app env db (r,s) args = + let ml_args = + List.fold_right + (fun (b,c) a -> if b then + let p = List.length (fst (splay_prod env none (type_of env c))) in + let db = iterate (fun l -> 0 :: l) p db in + (extract_type_scheme env db c p) :: a + else a) + (List.combine s args) [] + in Tglob (r, ml_args) + +(*S Extraction of a type scheme. *) + +(* [extract_type_scheme env db c p] works on a Coq term [c] which is + an informative type scheme. It means that [c] is not a Coq type, but will + be when applied to sufficiently many arguments ([p] in fact). + This function decomposes p lambdas, with eta-expansion if needed. *) + +(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *) + +and extract_type_scheme env db c p = + if p=0 then extract_type env db 0 c [] + else + let c = whd_betaiotazeta c in + match kind_of_term c with + | Lambda (n,t,d) -> + extract_type_scheme (push_rel_assum (n,t) env) db d (p-1) + | _ -> + let rels = fst (splay_prod env none (type_of env c)) in + let env = push_rels_assum rels env in + let eta_args = List.rev_map mkRel (interval 1 p) in + extract_type env db 0 (lift p c) eta_args + + +(*S Extraction of an inductive type. *) + +and extract_ind env kn = (* kn is supposed to be in long form *) + try + if KNset.mem kn !internal_call then lookup_ind kn (* Already started. *) + else if visible_kn kn then lookup_ind kn (* Standard situation. *) + else raise Not_found (* Never trust the table for a internal kn. *) + with Not_found -> + internal_call := KNset.add kn !internal_call; + let mib = Environ.lookup_mind kn env in + (* 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 + (* First pass: we store inductive signatures together with *) + (* their type var list. *) + let packets = + Array.map + (fun mip -> + let b = mip.mind_sort <> (Prop Null) in + let s,v = if b then type_sign_vl env mip.mind_nf_arity else [],[] in + let t = Array.make (Array.length mip.mind_nf_lc) [] in + { ip_typename = mip.mind_typename; + ip_consnames = mip.mind_consnames; + ip_logical = (not b); + ip_sign = s; + ip_vars = v; + ip_types = t }) + mib.mind_packets + in + add_ind kn {ind_info = Standard; ind_nparams = npar; ind_packets = packets}; + (* Second pass: we extract constructors *) + for i = 0 to mib.mind_ntypes - 1 do + let p = packets.(i) in + if not p.ip_logical then + let types = arities_of_constructors env (kn,i) in + for j = 0 to Array.length types - 1 do + let t = snd (decompose_prod_n npar types.(j)) in + let prods,head = dest_prod epar t in + let nprods = List.length prods in + let args = match kind_of_term head with + | App (f,args) -> args (* [kind_of_term f = Ind ip] *) + | _ -> [||] + in + let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in + let db = db_from_ind dbmap npar in + p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1) + done + done; + (* Third pass: we determine special cases. *) + let ind_info = + try + if not mib.mind_finite then raise (I Coinductive); + if mib.mind_ntypes <> 1 then raise (I Standard); + let p = packets.(0) in + if p.ip_logical then raise (I Standard); + if Array.length p.ip_types <> 1 then raise (I Standard); + let typ = p.ip_types.(0) in + let l = List.filter (type_neq (mlt_env env) Tdummy) typ in + if List.length l = 1 && not (type_mem_kn kn (List.hd l)) + then raise (I Singleton); + if l = [] then raise (I Standard); + let ip = (kn, 0) in + if is_custom (IndRef ip) then raise (I Standard); + let projs = + try (find_structure ip).s_PROJ + with Not_found -> raise (I Standard); + in + let n = nb_default_params env mip0.mind_nf_arity in + let projs = try List.map out_some projs with _ -> raise (I Standard) in + let is_true_proj kn = + let (_,body) = Sign.decompose_lam_assum (constant_value env kn) in + match kind_of_term body with + | Rel _ -> false + | Case _ -> true + | _ -> assert false + in + let projs = List.filter is_true_proj projs in + let rec check = function + | [] -> [],[] + | (typ, kn) :: l -> + let l1,l2 = check l in + if type_eq (mlt_env env) Tdummy typ then l1,l2 + else + let r = ConstRef kn in + if List.mem false (type_to_sign (mlt_env env) typ) + then r :: l1, l2 + else r :: l1, r :: l2 + in + add_record kn n (check (List.combine typ projs)); + raise (I Record) + with (I info) -> info + in + let i = {ind_info = ind_info; ind_nparams = npar; ind_packets = packets} in + add_ind kn i; + internal_call := KNset.remove kn !internal_call; + i + +(*s [extract_type_cons] extracts the type of an inductive + constructor toward the corresponding list of ML types. *) + +(* \begin{itemize} + \item [db] is a context for translating Coq [Rel] into ML type [Tvar] + \item [dbmap] is a translation map (produced by a call to [parse_in_args]) + \item [i] is the rank of the current product (initially [params_nb+1]) + \end{itemize} *) + +and extract_type_cons env db dbmap c i = + match kind_of_term (whd_betadeltaiota env none c) with + | Prod (n,t,d) -> + let env' = push_rel_assum (n,t) env in + let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in + let l = extract_type_cons env' db' dbmap d (i+1) in + (extract_type env db 0 t []) :: l + | _ -> [] + +(*s Recording the ML type abbreviation of a Coq type scheme constant. *) + +and mlt_env env r = match r with + | ConstRef kn -> + (try + if not (visible_kn kn) then raise Not_found; + match lookup_term kn with + | Dtype (_,vl,mlt) -> Some mlt + | _ -> None + with Not_found -> + let cb = Environ.lookup_constant kn env in + let typ = cb.const_type in + match cb.const_body with + | None -> None + | Some l_body -> + (match flag_of_type env typ with + | Info,TypeScheme -> + let body = Declarations.force l_body in + let s,vl = type_sign_vl env typ in + let db = db_from_sign s in + let t = extract_type_scheme env db body (List.length s) + in add_term kn (Dtype (r, vl, t)); Some t + | _ -> None)) + | _ -> None + +let type_expand env = type_expand (mlt_env env) +let type_neq env = type_neq (mlt_env env) +let type_to_sign env = type_to_sign (mlt_env env) +let type_expunge env = type_expunge (mlt_env env) + +(*s Extraction of the type of a constant. *) + +let record_constant_type env kn opt_typ = + try + if not (visible_kn kn) then raise Not_found; + lookup_type kn + with Not_found -> + let typ = match opt_typ with + | None -> constant_type env kn + | Some typ -> typ + in let mlt = extract_type env [] 1 typ [] + in let schema = (type_maxvar mlt, mlt) + in add_type kn schema; schema + +(*S Extraction of a term. *) + +(* Precondition: [(c args)] is not a type scheme, and is informative. *) + +(* [mle] is a ML environment [Mlenv.t]. *) +(* [mlt] is the ML type we want our extraction of [(c args)] to have. *) + +let rec extract_term env mle mlt c args = + match kind_of_term c with + | App (f,a) -> + extract_term env mle mlt f (Array.to_list a @ args) + | Lambda (n, t, d) -> + let id = id_of_name n in + (match args with + | a :: l -> + (* We make as many [LetIn] as possible. *) + let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l)) + in extract_term env mle mlt d' [] + | [] -> + let env' = push_rel_assum (Name id, t) env in + let id, a = + if is_default env t + then id, new_meta () + else dummy_name, Tdummy in + let b = new_meta () in + (* If [mlt] cannot be unified with an arrow type, then magic! *) + let magic = needs_magic (mlt, Tarr (a, b)) in + let d' = extract_term env' (Mlenv.push_type mle a) b d [] in + put_magic_if magic (MLlam (id, d'))) + | LetIn (n, c1, t1, c2) -> + let id = id_of_name n in + let env' = push_rel (Name id, Some c1, t1) env in + let args' = List.map (lift 1) args in + if is_default env t1 then + let a = new_meta () in + let c1' = extract_term env mle a c1 [] in + (* The type of [c1'] is generalized and stored in [mle]. *) + let mle' = Mlenv.push_gen mle a in + MLletin (id, c1', extract_term env' mle' mlt c2 args') + else + let mle' = Mlenv.push_std_type mle Tdummy in + ast_pop (extract_term env' mle' mlt c2 args') + | Const kn -> + extract_cst_app env mle mlt kn args + | Construct cp -> + extract_cons_app env mle mlt cp args + | Rel n -> + (* As soon as the expected [mlt] for the head is known, *) + (* we unify it with an fresh copy of the stored type of [Rel n]. *) + let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n) + in extract_app env mle mlt extract_rel args + | Case ({ci_ind=ip},_,c0,br) -> + extract_app env mle mlt (extract_case env mle (ip,c0,br)) args + | Fix ((_,i),recd) -> + extract_app env mle mlt (extract_fix env mle i recd) args + | CoFix (i,recd) -> + extract_app env mle mlt (extract_fix env mle i recd) args + | Cast (c, _) -> extract_term env mle mlt c args + | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false + +(*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) + +and extract_maybe_term env mle mlt c = + if is_default env (type_of env c) then extract_term env mle mlt c [] + else put_magic (mlt, Tdummy) MLdummy + +(*s Generic way to deal with an application. *) + +(* We first type all arguments starting with unknown meta types. + This gives us the expected type of the head. Then we use the + [mk_head] to produce the ML head from this type. *) + +and extract_app env mle mlt mk_head args = + let metas = List.map new_meta args in + let type_head = type_recomp (metas, mlt) in + let mlargs = List.map2 (extract_maybe_term env mle) metas args in + if mlargs = [] then mk_head type_head else MLapp (mk_head type_head, mlargs) + +(*s Auxiliary function used to extract arguments of constant or constructor. *) + +and make_mlargs env e s args typs = + let l = ref s in + let keep () = match !l with [] -> true | b :: s -> l:=s; b in + let rec f = function + | [], [] -> [] + | a::la, t::lt when keep() -> extract_maybe_term env e t a :: (f (la,lt)) + | _::la, _::lt -> f (la,lt) + | _ -> assert false + in f (args,typs) + +(*s Extraction of a constant applied to arguments. *) + +and extract_cst_app env mle mlt kn args = + (* First, the [ml_schema] of the constant, in expanded version. *) + let nb,t = record_constant_type env kn None in + let schema = nb, type_expand env t in + (* Then the expected type of this constant. *) + let metas = List.map new_meta args in + (* We compare stored and expected types in two steps. *) + (* First, can [kn] be applied to all args ? *) + let a = new_meta () in + let magic1 = needs_magic (type_recomp (metas, a), instantiation schema) in + (* Second, is the resulting type compatible with the expected type [mlt] ? *) + let magic2 = needs_magic (a, mlt) in + (* The internal head receives a magic if [magic1] *) + let head = put_magic_if magic1 (MLglob (ConstRef kn)) in + (* Now, the extraction of the arguments. *) + let s = type_to_sign env (snd schema) in + let ls = List.length s in + let la = List.length args in + let mla = make_mlargs env mle s args metas in + let mla = + if not magic1 then + try + let l,l' = list_chop (projection_arity (ConstRef kn)) mla in + if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' + else mla + with _ -> mla + else mla + in + (* Different situations depending of the number of arguments: *) + if ls = 0 then put_magic_if magic2 head + else if List.mem true s then + if la >= ls then put_magic_if (magic2 && not magic1) (MLapp (head, mla)) + else + (* Not enough arguments. We complete via eta-expansion. *) + let ls' = ls-la in + let s' = list_lastn ls' s in + let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in + put_magic_if magic2 (anonym_or_dummy_lams (MLapp (head, mla)) s') + else + (* In the special case of always false signature, one dummy lam is left. *) + (* So a [MLdummy] is left accordingly. *) + if la >= ls + then put_magic_if (magic2 && not magic1) (MLapp (head, MLdummy :: mla)) + else put_magic_if magic2 (dummy_lams head (ls-la-1)) + +(*s Extraction of an inductive constructor applied to arguments. *) + +(* \begin{itemize} + \item In ML, contructor arguments are uncurryfied. + \item We managed to suppress logical parts inside inductive definitions, + but they must appears outside (for partial applications for instance) + \item We also suppressed all Coq parameters to the inductives, since + they are fixed, and thus are not used for the computation. + \end{itemize} *) + +and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = + (* First, we build the type of the constructor, stored in small pieces. *) + let mi = extract_ind env kn in + let params_nb = mi.ind_nparams in + let oi = mi.ind_packets.(i) in + let nb_tvars = List.length oi.ip_vars + and types = List.map (type_expand env) oi.ip_types.(j-1) in + let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in + let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in + let type_cons = instantiation (nb_tvars, type_cons) in + (* Then, the usual variables [s], [ls], [la], ... *) + let s = List.map ((<>) Tdummy) types in + let ls = List.length s in + let la = List.length args in + assert (la <= ls + params_nb); + let la' = max 0 (la - params_nb) in + let args' = list_lastn la' args in + (* Now, we build the expected type of the constructor *) + let metas = List.map new_meta args' in + (* If stored and expected types differ, then magic! *) + let a = new_meta () in + let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in + let magic2 = needs_magic (a, mlt) in + let head mla = + if mi.ind_info = Singleton then + put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *) + else put_magic_if magic1 (MLcons (ConstructRef cp, mla)) + in + (* Different situations depending of the number of arguments: *) + if la < params_nb then + let head' = head (eta_args_sign ls s) in + put_magic_if magic2 + (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la)) + else + let mla = make_mlargs env mle s args' metas in + if la = ls + params_nb + then put_magic_if (magic2 && not magic1) (head mla) + else (* [ params_nb <= la <= ls + params_nb ] *) + let ls' = params_nb + ls - la in + let s' = list_lastn ls' s in + let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in + put_magic_if magic2 (anonym_or_dummy_lams (head mla) s') + +(*S Extraction of a case. *) + +and extract_case env mle ((kn,i) as ip,c,br) mlt = + (* [br]: bodies of each branch (in functional form) *) + (* [ni]: number of arguments without parameters in each branch *) + let ni = mis_constr_nargs_env env ip in + let br_size = Array.length br in + assert (Array.length ni = br_size); + if br_size = 0 then begin + add_recursors env kn; (* May have passed unseen if logical ... *) + MLexn "absurd case" + end else + (* [c] has an inductive type, and is not a type scheme type. *) + let t = type_of env c in + (* The only non-informative case: [c] is of sort [Prop] *) + if (sort_of env t) = InProp then + begin + add_recursors env kn; (* May have passed unseen if logical ... *) + (* Logical singleton case: *) + (* [match c with C i j k -> t] becomes [t'] *) + assert (br_size = 1); + let s = iterate (fun l -> false :: l) ni.(0) [] in + let mlt = iterate (fun t -> Tarr (Tdummy, t)) ni.(0) mlt in + let e = extract_maybe_term env mle mlt br.(0) in + snd (case_expunge s e) + end + else + let mi = extract_ind env kn in + let params_nb = mi.ind_nparams in + let oi = mi.ind_packets.(i) in + let metas = Array.init (List.length oi.ip_vars) new_meta in + (* The extraction of the head. *) + let type_head = Tglob (IndRef ip, Array.to_list metas) in + let a = extract_term env mle type_head c [] in + (* The extraction of each branch. *) + let extract_branch i = + (* The types of the arguments of the corresponding constructor. *) + let f t = type_subst_vect metas (type_expand env t) in + let l = List.map f oi.ip_types.(i) in + (* Extraction of the branch (in functional form). *) + let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in + (* We suppress dummy arguments according to signature. *) + let ids,e = case_expunge (List.map ((<>) Tdummy) l) e in + (ConstructRef (ip,i+1), List.rev ids, e) + in + if mi.ind_info = Singleton then + begin + (* Informative singleton case: *) + (* [match c with C i -> t] becomes [let i = c' in t'] *) + assert (br_size = 1); + let (_,ids,e') = extract_branch 0 in + assert (List.length ids = 1); + MLletin (List.hd ids,a,e') + end + else + (* Standard case: we apply [extract_branch]. *) + MLcase (a, Array.init br_size extract_branch) + +(*s Extraction of a (co)-fixpoint. *) + +and extract_fix env mle i (fi,ti,ci as recd) mlt = + let env = push_rec_types recd env in + let metas = Array.map new_meta fi in + metas.(i) <- mlt; + let mle = Array.fold_left Mlenv.push_type mle metas in + let ei = array_map2 (extract_maybe_term env mle) metas ci in + MLfix (i, Array.map id_of_name fi, ei) + +(*S ML declarations. *) + +(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t], + and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *) + +let rec decomp_lams_eta_n n env c t = + let rels = fst (decomp_n_prod env none n t) in + let rels = List.map (fun (id,_,c) -> (id,c)) rels in + let m = nb_lam c in + if m >= n then decompose_lam_n n c + else + let rels',c = decompose_lam c in + let d = n - m in + (* we'd better keep rels' as long as possible. *) + let rels = (list_firstn d rels) @ rels' in + let eta_args = List.rev_map mkRel (interval 1 d) in + rels, applist (lift d c,eta_args) + +(*s From a constant to a ML declaration. *) + +let extract_std_constant env kn body typ = + reset_meta_count (); + (* The short type [t] (i.e. possibly with abbreviations). *) + let t = snd (record_constant_type env kn (Some typ)) in + (* The real type [t']: without head lambdas, expanded, *) + (* and with [Tvar] translated to [Tvar'] (not instantiable). *) + let l,t' = type_decomp (type_expand env (var2var' t)) in + let s = List.map ((<>) Tdummy) l in + (* The initial ML environment. *) + let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in + (* Decomposing the top level lambdas of [body]. *) + let rels,c = decomp_lams_eta_n (List.length s) env body typ in + (* The lambdas names. *) + let ids = List.map (fun (n,_) -> id_of_name n) rels in + (* The according Coq environment. *) + let env = push_rels_assum rels env in + (* The real extraction: *) + let e = extract_term env mle t' c [] in + (* Expunging term and type from dummy lambdas. *) + term_expunge s (ids,e), type_expunge env t + +let extract_fixpoint env vkn (fi,ti,ci) = + let n = Array.length vkn in + let types = Array.make n Tdummy + and terms = Array.make n MLdummy in + (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) + let sub = List.rev_map mkConst (Array.to_list vkn) in + for i = 0 to n-1 do + if sort_of env ti.(i) <> InProp then begin + let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in + terms.(i) <- e; + types.(i) <- t; + end + done; + Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) + +let extract_constant env kn cb = + let r = ConstRef kn in + let typ = cb.const_type in + match cb.const_body with + | None -> (* A logical axiom is risky, an informative one is fatal. *) + (match flag_of_type env typ with + | (Info,TypeScheme) -> + if not (is_custom r) then warning_info_ax r; + let n = type_scheme_nb_args env typ in + let ids = iterate (fun l -> anonymous::l) n [] in + Dtype (r, ids, Taxiom) + | (Info,Default) -> + if not (is_custom r) then warning_info_ax r; + let t = snd (record_constant_type env kn (Some typ)) in + Dterm (r, MLaxiom, type_expunge env t) + | (Logic,TypeScheme) -> warning_log_ax r; Dtype (r, [], Tdummy) + | (Logic,Default) -> warning_log_ax r; Dterm (r, MLdummy, Tdummy)) + | Some body -> + (match flag_of_type env typ with + | (Logic, Default) -> Dterm (r, MLdummy, Tdummy) + | (Logic, TypeScheme) -> Dtype (r, [], Tdummy) + | (Info, Default) -> + let e,t = extract_std_constant env kn (force body) typ in + Dterm (r,e,t) + | (Info, TypeScheme) -> + let s,vl = type_sign_vl env typ in + let db = db_from_sign s in + let t = extract_type_scheme env db (force body) (List.length s) + in Dtype (r, vl, t)) + +let extract_constant_spec env kn cb = + let r = ConstRef kn in + let typ = cb.const_type in + match flag_of_type env typ with + | (Logic, TypeScheme) -> Stype (r, [], Some Tdummy) + | (Logic, Default) -> Sval (r, Tdummy) + | (Info, TypeScheme) -> + let s,vl = type_sign_vl env typ in + (match cb.const_body with + | None -> Stype (r, vl, None) + | Some body -> + let db = db_from_sign s in + let t = extract_type_scheme env db (force body) (List.length s) + in Stype (r, vl, Some t)) + | (Info, Default) -> + let t = snd (record_constant_type env kn (Some typ)) in + Sval (r, type_expunge env t) + +let extract_inductive env kn = + let ind = extract_ind env kn in + add_recursors env kn; + let f l = List.filter (type_neq env Tdummy) l in + let packets = + Array.map (fun p -> { p with ip_types = Array.map f p.ip_types }) + ind.ind_packets + in { ind with ind_packets = packets } + +(*s From a global reference to a ML declaration. *) + +let extract_declaration env r = match r with + | ConstRef kn -> extract_constant env kn (Environ.lookup_constant kn env) + | IndRef (kn,_) -> Dind (kn, extract_inductive env kn) + | ConstructRef ((kn,_),_) -> Dind (kn, extract_inductive env kn) + | VarRef kn -> assert false + +(*s Without doing complete extraction, just guess what a constant would be. *) + +type kind = Logical | Term | Type + +let constant_kind env cb = + match flag_of_type env cb.const_type with + | (Logic,_) -> Logical + | (Info,TypeScheme) -> Type + | (Info,Default) -> Term + +(*s Is a [ml_decl] logical ? *) + +let logical_decl = function + | Dterm (_,MLdummy,Tdummy) -> true + | Dtype (_,[],Tdummy) -> true + | Dfix (_,av,tv) -> + (array_for_all ((=) MLdummy) av) && (array_for_all ((=) Tdummy) tv) + | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets + | _ -> false + +(*s Is a [ml_spec] logical ? *) + +let logical_spec = function + | Stype (_, [], Some Tdummy) -> true + | Sval (_,Tdummy) -> true + | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets + | _ -> false + + + + + + diff --git a/contrib/extraction/extraction.mli b/contrib/extraction/extraction.mli new file mode 100644 index 00000000..fc5782c9 --- /dev/null +++ b/contrib/extraction/extraction.mli @@ -0,0 +1,42 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: extraction.mli,v 1.27.2.1 2004/07/16 19:30:07 herbelin Exp $ i*) + +(*s Extraction from Coq terms to Miniml. *) + +open Names +open Term +open Declarations +open Environ +open Libnames +open Miniml + +val extract_constant : env -> kernel_name -> constant_body -> ml_decl + +val extract_constant_spec : env -> kernel_name -> constant_body -> ml_spec + +val extract_fixpoint : + env -> kernel_name array -> (constr, types) prec_declaration -> ml_decl + +val extract_inductive : env -> kernel_name -> ml_ind + +(*s ML declaration corresponding to a Coq reference. *) + +val extract_declaration : env -> global_reference -> ml_decl + +(*s Without doing complete extraction, just guess what a constant would be. *) + +type kind = Logical | Term | Type + +val constant_kind : env -> constant_body -> kind + +(*s Is a [ml_decl] or a [ml_spec] logical ? *) + +val logical_decl : ml_decl -> bool +val logical_spec : ml_spec -> bool diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4 new file mode 100644 index 00000000..33a6117d --- /dev/null +++ b/contrib/extraction/g_extraction.ml4 @@ -0,0 +1,119 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* ML names *) + +open Vernacexpr +open Pcoq +open Genarg +open Pp + +let pr_mlname _ _ s = + spc () ++ + (if !Options.v7 && not (Options.do_translate()) then qs s + else Pptacticnew.qsnew s) + +ARGUMENT EXTEND mlname + TYPED AS string + PRINTED BY pr_mlname +| [ preident(id) ] -> [ id ] +| [ string(s) ] -> [ s ] +END + +open Table +open Extract_env + +VERNAC ARGUMENT EXTEND language +| [ "Ocaml" ] -> [ Ocaml ] +| [ "Haskell" ] -> [ Haskell ] +| [ "Scheme" ] -> [ Scheme ] +| [ "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 +(* Extraction in the Coq toplevel *) +| [ "Extraction" global(x) ] -> [ extraction x ] +| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ extraction_rec l ] + +(* Monolithic extraction to a file *) +| [ "Extraction" string(f) ne_global_list(l) ] + -> [ extraction_file f l ] +END + +(* Modular extraction (one Coq library = one ML module) *) +VERNAC COMMAND EXTEND ExtractionLibrary +| [ "Extraction" "Library" ident(m) ] + -> [ extraction_library false m ] +END + +VERNAC COMMAND EXTEND RecursiveExtractionLibrary +| [ "Recursive" "Extraction" "Library" ident(m) ] + -> [ extraction_library true m ] +END + +(* Target Language *) +VERNAC COMMAND EXTEND ExtractionLanguage +| [ "Extraction" "Language" language(l) ] + -> [ extraction_language l ] +END + +VERNAC COMMAND EXTEND ExtractionInline +(* Custom inlining directives *) +| [ "Extraction" "Inline" ne_global_list(l) ] + -> [ extraction_inline true l ] +END + +VERNAC COMMAND EXTEND ExtractionNoInline +| [ "Extraction" "NoInline" ne_global_list(l) ] + -> [ extraction_inline false l ] +END + +VERNAC COMMAND EXTEND PrintExtractionInline +| [ "Print" "Extraction" "Inline" ] + -> [ print_extraction_inline () ] +END + +VERNAC COMMAND EXTEND ResetExtractionInline +| [ "Reset" "Extraction" "Inline" ] + -> [ reset_extraction_inline () ] +END + +(* Overriding of a Coq object by an ML one *) +VERNAC COMMAND EXTEND ExtractionConstant +| [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] + -> [ extract_constant_inline false x idl y ] +END + +VERNAC COMMAND EXTEND ExtractionInlinedConstant +| [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ] + -> [ extract_constant_inline true x [] y ] +END + +VERNAC COMMAND EXTEND ExtractionInductive +| [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" ] + -> [ extract_inductive x (id,idl) ] +END diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml new file mode 100644 index 00000000..29c8cd18 --- /dev/null +++ b/contrib/extraction/haskell.ml @@ -0,0 +1,280 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: haskell.ml,v 1.40.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +(*s Production of Haskell syntax. *) + +open Pp +open Util +open Names +open Nameops +open Libnames +open Table +open Miniml +open Mlutil +open Ocaml + +(*s Haskell renaming issues. *) + +let keywords = + List.fold_right (fun s -> Idset.add (id_of_string s)) + [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else"; + "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance"; + "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__"; + "as"; "qualified"; "hiding" ; "unit" ] + Idset.empty + +let preamble prm used_modules (mldummy,tdummy,tunknown) = + let pp_mp = function + | MPfile d -> pr_upper_id (List.hd (repr_dirpath d)) + | _ -> assert false + in + str "module " ++ pr_upper_id prm.mod_name ++ str " where" ++ fnl () + ++ fnl() ++ + str "import qualified Prelude" ++ fnl() ++ + prlist (fun mp -> str "import qualified " ++ pp_mp mp ++ fnl ()) used_modules + ++ fnl () ++ + (if mldummy then + str "__ = Prelude.error \"Logical or arity value used\"" + ++ fnl () ++ fnl() + else mt()) + +let preamble_sig prm used_modules (mldummy,tdummy,tunknown) = failwith "TODO" + +let pp_abst = function + | [] -> (mt ()) + | l -> (str "\\" ++ + prlist_with_sep (fun () -> (str " ")) pr_id l ++ + str " ->" ++ spc ()) + +let pr_lower_id id = pr_id (lowercase_id id) + +(*s The pretty-printing functor. *) + +module Make = functor(P : Mlpp_param) -> struct + +let local_mpl = ref ([] : module_path list) + +let pp_global r = P.pp_global !local_mpl r +let empty_env () = [], P.globals() + +(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses + are needed or not. *) + +let rec pp_type par vl t = + let rec pp_rec par = function + | Tmeta _ | Tvar' _ -> assert false + | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i)) + | Tglob (r,[]) -> pp_global r + | Tglob (r,l) -> + pp_par par + (pp_global r ++ spc () ++ prlist_with_sep spc (pp_type true vl) l) + | Tarr (t1,t2) -> + pp_par par + (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) + | Tdummy -> str "()" + | Tunknown -> str "()" + | Taxiom -> str "() -- AXIOM TO BE REALIZED\n" + | Tcustom s -> str s + in + hov 0 (pp_rec par t) + +(*s Pretty-printing of expressions. [par] indicates whether + parentheses are needed or not. [env] is the list of names for the + de Bruijn variables. [args] is the list of collected arguments + (already pretty-printed). *) + +let expr_needs_par = function + | MLlam _ -> true + | MLcase _ -> true + | _ -> false + + +let rec pp_expr par env args = + let par' = args <> [] || par + and apply st = pp_apply st par args in + function + | MLrel n -> + let id = get_db_name n env in apply (pr_id id) + | MLapp (f,args') -> + let stl = List.map (pp_expr true env []) args' in + pp_expr par env (stl @ args) f + | MLlam _ as a -> + let fl,a' = collect_lams a in + let fl,env' = push_vars fl env in + let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in + apply (pp_par par' st) + | MLletin (id,a1,a2) -> + let i,env' = push_vars [id] env in + let pp_id = pr_id (List.hd i) + and pp_a1 = pp_expr false env [] a1 + and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in + hv 0 + (apply + (pp_par par' + (hv 0 + (hov 5 + (str "let" ++ spc () ++ pp_id ++ str " = " ++ pp_a1) ++ + spc () ++ str "in") ++ + spc () ++ hov 0 pp_a2))) + | MLglob r -> + apply (pp_global r) + | MLcons (r,[]) -> + assert (args=[]); pp_global r + | MLcons (r,[a]) -> + assert (args=[]); + pp_par par (pp_global r ++ spc () ++ pp_expr true env [] a) + | MLcons (r,args') -> + assert (args=[]); + pp_par par (pp_global r ++ spc () ++ + prlist_with_sep spc (pp_expr true env []) args') + | MLcase (t, pv) -> + apply (pp_par par' + (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++ + fnl () ++ str " " ++ pp_pat env pv))) + | MLfix (i,ids,defs) -> + let ids',env' = push_vars (List.rev (Array.to_list ids)) env in + pp_fix par env' i (Array.of_list (List.rev ids'),defs) args + | MLexn s -> + (* An [MLexn] may be applied, but I don't really care. *) + pp_par par (str "Prelude.error" ++ spc () ++ qs s) + | MLdummy -> + str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLmagic a -> pp_expr par env args a + | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") + +and pp_pat env pv = + let pp_one_pat (name,ids,t) = + let ids,env' = push_vars (List.rev ids) env in + let par = expr_needs_par t in + hov 2 (pp_global name ++ + (match ids with + | [] -> mt () + | _ -> (str " " ++ + prlist_with_sep + (fun () -> (spc ())) pr_id (List.rev ids))) ++ + str " ->" ++ spc () ++ pp_expr par env' [] t) + in + (prvect_with_sep (fun () -> (fnl () ++ str " ")) pp_one_pat pv) + +(*s names of the functions ([ids]) are already pushed in [env], + and passed here just for convenience. *) + +and pp_fix par env i (ids,bl) args = + pp_par par + (v 0 + (v 2 (str "let" ++ fnl () ++ + prvect_with_sep fnl + (fun (fi,ti) -> pp_function env (pr_id fi) ti) + (array_map2 (fun a b -> a,b) ids bl)) ++ + fnl () ++ + hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) + +and pp_function env f t = + let bl,t' = collect_lams t in + let bl,env' = push_vars bl env in + (f ++ pr_binding (List.rev bl) ++ + str " =" ++ fnl () ++ str " " ++ + hov 2 (pp_expr false env' [] t')) + +(*s Pretty-printing of inductive types declaration. *) + +let pp_comment s = str "-- " ++ s ++ fnl () + +let pp_logical_ind packet = + pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ + pp_comment (str "with constructors : " ++ + prvect_with_sep spc pr_id packet.ip_consnames) + +let pp_singleton kn packet = + let l = rename_tvars keywords packet.ip_vars in + let l' = List.rev l in + hov 2 (str "type " ++ pp_global (IndRef (kn,0)) ++ spc () ++ + prlist_with_sep spc pr_id l ++ + (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++ + pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++ + pp_comment (str "singleton inductive, whose constructor was " ++ + pr_id packet.ip_consnames.(0))) + +let pp_one_ind ip pl cv = + let pl = rename_tvars keywords pl in + let pp_constructor (r,l) = + (pp_global r ++ + match l with + | [] -> (mt ()) + | _ -> (str " " ++ + prlist_with_sep + (fun () -> (str " ")) (pp_type true (List.rev pl)) l)) + in + str (if cv = [||] 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" + else + (v 0 (str "= " ++ + prvect_with_sep (fun () -> fnl () ++ str " | ") pp_constructor + (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv))) + +let rec pp_ind first kn i ind = + if i >= Array.length ind.ind_packets then + if first then mt () else fnl () + else + let ip = (kn,i) in + let p = ind.ind_packets.(i) in + if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind + else + if p.ip_logical then + pp_logical_ind p ++ pp_ind first kn (i+1) ind + else + pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++ + pp_ind false kn (i+1) ind + + +(*s Pretty-printing of a declaration. *) + +let pp_decl mpl = + local_mpl := mpl; + function + | Dind (kn,i) when i.ind_info = Singleton -> + pp_singleton kn i.ind_packets.(0) ++ fnl () + | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i) + | Dtype (r, l, t) -> + if is_inline_custom r then mt () + else + let l = rename_tvars keywords l in + let l' = List.rev l in + hov 2 (str "type " ++ pp_global r ++ spc () ++ + prlist (fun id -> pr_id id ++ str " ") l ++ + str "=" ++ spc () ++ pp_type false l' t) ++ fnl () ++ fnl () + | Dfix (rv, defs,_) -> + let ppv = Array.map pp_global rv in + prlist_with_sep (fun () -> fnl () ++ fnl ()) + (fun (pi,ti) -> pp_function (empty_env ()) pi ti) + (List.combine (Array.to_list ppv) (Array.to_list defs)) + ++ fnl () ++ fnl () + | Dterm (r, a, _) -> + if is_inline_custom r then mt () + else + hov 0 (pp_function (empty_env ()) (pp_global r) a ++ fnl () ++ fnl ()) + +let pp_structure_elem mpl = function + | (l,SEdecl d) -> pp_decl mpl d + | (l,SEmodule m) -> + failwith "TODO: Haskell extraction of modules not implemented yet" + | (l,SEmodtype m) -> + failwith "TODO: Haskell extraction of modules not implemented yet" + +let pp_struct = + prlist (fun (mp,sel) -> prlist (pp_structure_elem [mp]) sel) + +let pp_signature s = failwith "TODO" + +end + diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli new file mode 100644 index 00000000..4da5db0c --- /dev/null +++ b/contrib/extraction/haskell.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: haskell.mli,v 1.15.6.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +open Pp +open Names +open Miniml + +val keywords : Idset.t + +val preamble : + extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds + +module Make : functor(P : Mlpp_param) -> Mlpp diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli new file mode 100644 index 00000000..866ff847 --- /dev/null +++ b/contrib/extraction/miniml.mli @@ -0,0 +1,159 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: miniml.mli,v 1.46.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +(*s Target language for extraction: a core ML called MiniML. *) + +open Pp +open Util +open Names +open Libnames + +(* The [signature] type is used to know how many arguments a CIC + object expects, and what these arguments will become in the ML + object. *) + +(* Convention: outmost lambda/product gives the head of the list, + and [true] means that the argument is to be kept. *) + +type signature = bool list + +(*s ML type expressions. *) + +type ml_type = + | Tarr of ml_type * ml_type + | Tglob of global_reference * ml_type list + | Tvar of int + | Tvar' of int (* same as Tvar, used to avoid clash *) + | Tmeta of ml_meta (* used during ML type reconstruction *) + | Tdummy + | Tunknown + | Taxiom + | Tcustom of string + +and ml_meta = { id : int; mutable contents : ml_type option } + +(* ML type schema. + The integer is the number of variable in the schema. *) + +type ml_schema = int * ml_type + +(*s ML inductive types. *) + +type inductive_info = Record | Singleton | Coinductive | Standard + +(* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body]. + If the inductive is logical ([ip_logical = false]), then all other fields + are unused. Otherwise, + [ip_sign] is a signature concerning the arguments of the inductive, + [ip_vars] contains the names of the type variables surviving in ML, + [ip_types] contains the ML types of all constructors. +*) + +type ml_ind_packet = { + ip_typename : identifier; + ip_consnames : identifier array; + ip_logical : bool; + ip_sign : signature; + ip_vars : identifier list; + ip_types : (ml_type list) array } + +(* [ip_nparams] contains the number of parameters. *) + +type ml_ind = { + ind_info : inductive_info; + ind_nparams : int; + ind_packets : ml_ind_packet array } + +(*s ML terms. *) + +type ml_ast = + | MLrel of int + | MLapp of ml_ast * ml_ast list + | MLlam of identifier * ml_ast + | MLletin of identifier * ml_ast * ml_ast + | MLglob of global_reference + | MLcons of global_reference * ml_ast list + | MLcase of ml_ast * (global_reference * identifier list * ml_ast) array + | MLfix of int * identifier array * ml_ast array + | MLexn of string + | MLdummy + | MLaxiom + | MLmagic of ml_ast + +(*s ML declarations. *) + +type ml_decl = + | Dind of kernel_name * ml_ind + | Dtype of global_reference * identifier list * ml_type + | Dterm of global_reference * ml_ast * ml_type + | Dfix of global_reference array * ml_ast array * ml_type array + +type ml_spec = + | Sind of kernel_name * ml_ind + | Stype of global_reference * identifier list * ml_type option + | Sval of global_reference * ml_type + +type ml_specif = + | Spec of ml_spec + | Smodule of ml_module_type + | Smodtype of ml_module_type + +and ml_module_type = + | MTident of kernel_name + | MTfunsig of mod_bound_id * ml_module_type * ml_module_type + | MTsig of mod_self_id * ml_module_sig + +and ml_module_sig = (label * ml_specif) list + +type ml_structure_elem = + | SEdecl of ml_decl + | SEmodule of ml_module + | SEmodtype of ml_module_type + +and ml_module_expr = + | MEident of module_path + | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr + | MEstruct of mod_self_id * ml_module_structure + | MEapply of ml_module_expr * ml_module_expr + +and ml_module_structure = (label * ml_structure_elem) list + +and ml_module = + { ml_mod_expr : ml_module_expr; + ml_mod_type : ml_module_type } + +(* NB: we do not translate the [mod_equiv] field, since [mod_equiv = mp] + implies that [mod_expr = MEBident mp]. Same with [msb_equiv]. *) + +type ml_structure = (module_path * ml_module_structure) list + +type ml_signature = (module_path * ml_module_sig) list + +(*s Pretty-printing of MiniML in a given concrete syntax is parameterized + by a function [pp_global] that pretty-prints global references. + The resulting pretty-printer is a module of type [Mlpp] providing + functions to print types, terms and declarations. *) + +module type Mlpp_param = sig + val globals : unit -> Idset.t + val pp_global : module_path list -> global_reference -> std_ppcmds + val pp_module : module_path list -> module_path -> std_ppcmds +end + +module type Mlpp = sig + val pp_decl : module_path list -> ml_decl -> std_ppcmds + val pp_struct : ml_structure -> std_ppcmds + val pp_signature : ml_signature -> std_ppcmds +end + +type extraction_params = + { modular : bool; + mod_name : identifier; + to_appear : global_reference list } diff --git a/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml new file mode 100644 index 00000000..fbe423a7 --- /dev/null +++ b/contrib/extraction/mlutil.ml @@ -0,0 +1,1136 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: mlutil.ml,v 1.104.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +(*i*) +open Pp +open Util +open Names +open Libnames +open Nametab +open Table +open Miniml +(*i*) + +(*s Exceptions. *) + +exception Found +exception Impossible + +(*S Names operations. *) + +let anonymous = id_of_string "x" +let dummy_name = id_of_string "_" + +let id_of_name = function + | Anonymous -> anonymous + | Name id when id = dummy_name -> anonymous + | Name id -> id + +(*S Operations upon ML types (with meta). *) + +let meta_count = ref 0 + +let reset_meta_count () = meta_count := 0 + +let new_meta _ = + incr meta_count; + Tmeta {id = !meta_count; contents = None} + +(*s Sustitution of [Tvar i] by [t] in a ML type. *) + +let type_subst i t0 t = + let rec subst t = match t with + | Tvar j when i = j -> t0 + | Tmeta {contents=None} -> t + | Tmeta {contents=Some u} -> subst u + | Tarr (a,b) -> Tarr (subst a, subst b) + | Tglob (r, l) -> Tglob (r, List.map subst l) + | a -> a + in subst t + +(* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *) + +let type_subst_list l t = + let rec subst t = match t with + | Tvar j -> List.nth l (j-1) + | Tmeta {contents=None} -> t + | Tmeta {contents=Some u} -> subst u + | Tarr (a,b) -> Tarr (subst a, subst b) + | Tglob (r, l) -> Tglob (r, List.map subst l) + | a -> a + in subst t + +(* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *) + +let type_subst_vect v t = + let rec subst t = match t with + | Tvar j -> v.(j-1) + | Tmeta {contents=None} -> t + | Tmeta {contents=Some u} -> subst u + | Tarr (a,b) -> Tarr (subst a, subst b) + | Tglob (r, l) -> Tglob (r, List.map subst l) + | a -> a + in subst t + +(*s From a type schema to a type. All [Tvar] become fresh [Tmeta]. *) + +let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t + +(*s Occur-check of a free meta in a type *) + +let rec type_occurs alpha t = + match t with + | Tmeta {id=beta; contents=None} -> alpha = beta + | Tmeta {contents=Some u} -> type_occurs alpha u + | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2 + | Tglob (r,l) -> List.exists (type_occurs alpha) l + | _ -> false + +(*s Most General Unificator *) + +let rec mgu = function + | Tmeta m, Tmeta m' when m.id = m'.id -> () + | Tmeta m, t when m.contents=None -> + if type_occurs m.id t then raise Impossible + else m.contents <- Some t + | t, Tmeta m when m.contents=None -> + if type_occurs m.id t then raise Impossible + else m.contents <- Some t + | Tmeta {contents=Some u}, t -> mgu (u, t) + | t, Tmeta {contents=Some u} -> mgu (t, u) + | Tarr(a, b), Tarr(a', b') -> + mgu (a, a'); mgu (b, b') + | Tglob (r,l), Tglob (r',l') when r = r' -> + List.iter mgu (List.combine l l') + | Tvar i, Tvar j when i = j -> () + | Tvar' i, Tvar' j when i = j -> () + | Tdummy, Tdummy -> () + | Tunknown, Tunknown -> () + | _ -> raise Impossible + +let needs_magic p = try mgu p; false with Impossible -> true + +let put_magic_if b a = if b then MLmagic a else a + +let put_magic p a = if needs_magic p then MLmagic a else a + + +(*S ML type env. *) + +module Mlenv = struct + + let meta_cmp m m' = compare m.id m'.id + module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end) + + (* Main MLenv type. [env] is the real environment, whereas [free] + (tries to) record the free meta variables occurring in [env]. *) + + type t = { env : ml_schema list; mutable free : Metaset.t} + + (* Empty environment. *) + + let empty = { env = []; free = Metaset.empty } + + (* [get] returns a instantiated copy of the n-th most recently added + type in the environment. *) + + let get mle n = + assert (List.length mle.env >= n); + instantiation (List.nth mle.env (n-1)) + + (* [find_free] finds the free meta in a type. *) + + let rec find_free set = function + | Tmeta m when m.contents = None -> Metaset.add m set + | Tmeta {contents = Some t} -> find_free set t + | Tarr (a,b) -> find_free (find_free set a) b + | Tglob (_,l) -> List.fold_left find_free set l + | _ -> set + + (* The [free] set of an environment can be outdate after + some unifications. [clean_free] takes care of that. *) + + let clean_free mle = + let rem = ref Metaset.empty + and add = ref Metaset.empty in + let clean m = match m.contents with + | None -> () + | Some u -> rem := Metaset.add m !rem; add := find_free !add u + in + Metaset.iter clean mle.free; + mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add + + (* From a type to a type schema. If a [Tmeta] is still uninstantiated + and does appears in the [mle], then it becomes a [Tvar]. *) + + let generalization mle t = + let c = ref 0 in + let map = ref (Intmap.empty : int Intmap.t) in + let add_new i = incr c; map := Intmap.add i !c !map; !c in + let rec meta2var t = match t with + | Tmeta {contents=Some u} -> meta2var u + | Tmeta ({id=i} as m) -> + (try Tvar (Intmap.find i !map) + with Not_found -> + if Metaset.mem m mle.free then t + else Tvar (add_new i)) + | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2) + | Tglob (r,l) -> Tglob (r, List.map meta2var l) + | t -> t + in !c, meta2var t + + (* Adding a type in an environment, after generalizing. *) + + let push_gen mle t = + clean_free mle; + { env = generalization mle t :: mle.env; free = mle.free } + + (* Adding a type with no [Tvar], hence no generalization needed. *) + + let push_type {env=e;free=f} t = + { env = (0,t) :: e; free = find_free f t} + + (* Adding a type with no [Tvar] nor [Tmeta]. *) + + let push_std_type {env=e;free=f} t = + { env = (0,t) :: e; free = f} + +end + +(*S Operations upon ML types (without meta). *) + +(*s Does a section path occur in a ML type ? *) + +let rec type_mem_kn kn = function + | Tmeta _ -> assert false + | Tglob (r,l) -> (kn_of_r r) = kn || List.exists (type_mem_kn kn) l + | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b) + | _ -> false + +(*s Greatest variable occurring in [t]. *) + +let type_maxvar t = + let rec parse n = function + | Tmeta _ -> assert false + | Tvar i -> max i n + | Tarr (a,b) -> parse (parse n a) b + | Tglob (_,l) -> List.fold_left parse n l + | _ -> n + in parse 0 t + +(*s From [a -> b -> c] to [[a;b],c]. *) + +let rec type_decomp = function + | Tmeta _ -> assert false + | Tarr (a,b) -> let l,h = type_decomp b in a::l, h + | a -> [],a + +(*s The converse: From [[a;b],c] to [a -> b -> c]. *) + +let rec type_recomp (l,t) = match l with + | [] -> t + | a::l -> Tarr (a, type_recomp (l,t)) + +(*s Translating [Tvar] to [Tvar'] to avoid clash. *) + +let rec var2var' = function + | Tmeta _ -> assert false + | Tvar i -> Tvar' i + | Tarr (a,b) -> Tarr (var2var' a, var2var' b) + | Tglob (r,l) -> Tglob (r, List.map var2var' l) + | a -> a + +type abbrev_map = global_reference -> ml_type option + +(*s Delta-reduction of type constants everywhere in a ML type [t]. + [env] is a function of type [ml_type_env]. *) + +let type_expand env t = + let rec expand = function + | Tmeta _ -> assert false + | Tglob (r,l) as t -> + (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 + +(*s Idem, but only at the top level of implications. *) + +let is_arrow = function Tarr _ -> true | _ -> false + +let type_weak_expand env t = + let rec expand = function + | Tmeta _ -> assert false + | Tglob (r,l) as t -> + (match env r with + | Some mlt -> + let u = expand (type_subst_list l mlt) in + if is_arrow u then u else t + | None -> t) + | Tarr (a,b) -> Tarr (a, expand b) + | a -> a + in expand t + +(*s Equality over ML types modulo delta-reduction *) + +let type_eq env t t' = (type_expand env t = type_expand env t') + +let type_neq env t t' = (type_expand env t <> type_expand env t') + +(*s Generating a signature from a ML type. *) + +let type_to_sign env t = + let rec f = function + | Tmeta _ -> assert false + | Tarr (a,b) -> (Tdummy <> a) :: (f b) + | _ -> [] + in f (type_expand env t) + +(*s Removing [Tdummy] from the top level of a ML type. *) + +let type_expunge env t = + let s = type_to_sign env t in + if s = [] then t + else if List.mem true s then + let rec f t s = + if List.mem false s then + match t with + | Tmeta _ -> assert false + | Tarr (a,b) -> + let t = f b (List.tl s) in + if List.hd s then Tarr (a, t) else t + | Tglob (r,l) -> + (match env r with + | Some mlt -> f (type_subst_list l mlt) s + | None -> assert false) + | _ -> assert false + else t + in f t s + else Tarr (Tdummy, snd (type_decomp (type_weak_expand env t))) + +(*S Generic functions over ML ast terms. *) + +(*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care + of the number of bingings crossed before reaching the [MLrel]. *) + +let ast_iter_rel f = + let rec iter n = function + | MLrel i -> f (i-n) + | MLlam (_,a) -> iter (n+1) a + | MLletin (_,a,b) -> iter n a; iter (n+1) b + | MLcase (a,v) -> + iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v + | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v + | MLapp (a,l) -> iter n a; List.iter (iter n) l + | MLcons (_,l) -> List.iter (iter n) l + | MLmagic a -> iter n a + | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () + in iter 0 + +(*s Map over asts. *) + +let ast_map_case f (c,ids,a) = (c,ids,f a) + +let ast_map f = function + | MLlam (i,a) -> MLlam (i, f a) + | MLletin (i,a,b) -> MLletin (i, f a, f b) + | MLcase (a,v) -> MLcase (f a, Array.map (ast_map_case f) v) + | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v) + | MLapp (a,l) -> MLapp (f a, List.map f l) + | MLcons (c,l) -> MLcons (c, List.map f l) + | MLmagic a -> MLmagic (f a) + | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + +(*s Map over asts, with binding depth as parameter. *) + +let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a) + +let ast_map_lift f n = function + | MLlam (i,a) -> MLlam (i, f (n+1) a) + | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b) + | MLcase (a,v) -> MLcase (f n a,Array.map (ast_map_lift_case f n) v) + | MLfix (i,ids,v) -> + let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v) + | MLapp (a,l) -> MLapp (f n a, List.map (f n) l) + | MLcons (c,l) -> MLcons (c, List.map (f n) l) + | MLmagic a -> MLmagic (f n a) + | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a + +(*s Iter over asts. *) + +let ast_iter_case f (c,ids,a) = f a + +let ast_iter f = function + | MLlam (i,a) -> f a + | MLletin (i,a,b) -> f a; f b + | MLcase (a,v) -> f a; Array.iter (ast_iter_case f) v + | MLfix (i,ids,v) -> Array.iter f v + | MLapp (a,l) -> f a; List.iter f l + | MLcons (c,l) -> List.iter f l + | MLmagic a -> f a + | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> () + +(*S Operations concerning De Bruijn indices. *) + +(*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *) + +let ast_occurs k t = + try + ast_iter_rel (fun i -> if i = k then raise Found) t; false + with Found -> true + +(*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)] + in [t] with [k<=i<=k'] *) + +let ast_occurs_itvl k k' t = + try + ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false + with Found -> true + +(*s Number of occurences of [Rel k] and [Rel 1] in [t]. *) + +let nb_occur_k k t = + let cpt = ref 0 in + ast_iter_rel (fun i -> if i = k then incr cpt) t; + !cpt + +let nb_occur t = nb_occur_k 1 t + +(* Number of occurences of [Rel 1] in [t], with special treatment of match: + occurences in different branches aren't added, but we rather use max. *) + +let nb_occur_match = + let rec nb k = function + | MLrel i -> if i = k then 1 else 0 + | MLcase(a,v) -> + (nb k a) + + Array.fold_left + (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v + | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) + | MLfix (_,ids,v) -> let k = k+(Array.length ids) in + Array.fold_left (fun r a -> r+(nb k a)) 0 v + | MLlam (_,a) -> nb (k+1) a + | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l + | MLcons (_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l + | MLmagic a -> nb k a + | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0 + in nb 1 + +(*s Lifting on terms. + [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *) + +let ast_lift k t = + let rec liftrec n = function + | MLrel i as a -> if i-n < 1 then a else MLrel (i+k) + | a -> ast_map_lift liftrec n a + in if k = 0 then t else liftrec 0 t + +let ast_pop t = ast_lift (-1) t + +(*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ... + Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *) + +let permut_rels k k' = + let rec permut n = function + | MLrel i as a -> + let i' = i-n in + if i'<1 || i'>k+k' then a + else if i'<=k then MLrel (i+k') + else MLrel (i-k) + | a -> ast_map_lift permut n a + in permut 0 + +(*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t]. + Lifting (of one binder) is done at the same time. *) + +let ast_subst e = + let rec subst n = function + | MLrel i as a -> + let i' = i-n in + if i'=1 then ast_lift n e + else if i'<1 then a + else MLrel (i-1) + | a -> ast_map_lift subst n a + in subst 0 + +(*s Generalized substitution. + [gen_subst v d t] applies to [t] the substitution coded in the + [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies + to [Rel] greater than [Array.length v]. *) + +let gen_subst v d t = + let rec subst n = function + | MLrel i as a -> + let i'= i-n in + if i' < 1 then a + else if i' <= Array.length v then + ast_lift n v.(i'-1) + else MLrel (i+d) + | a -> ast_map_lift subst n a + in subst 0 t + +(*S Operations concerning lambdas. *) + +(*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns + [[idn;...;id1]] and the term [t]. *) + +let collect_lams = + let rec collect acc = function + | MLlam(id,t) -> collect (id::acc) t + | x -> acc,x + in collect [] + +(*s [collect_n_lams] does the same for a precise number of [MLlam]. *) + +let collect_n_lams = + let rec collect acc n t = + if n = 0 then acc,t + else match t with + | MLlam(id,t) -> collect (id::acc) (n-1) t + | _ -> assert false + in collect [] + +(*s [remove_n_lams] just removes some [MLlam]. *) + +let rec remove_n_lams n t = + if n = 0 then t + else match t with + | MLlam(_,t) -> remove_n_lams (n-1) t + | _ -> assert false + +(*s [nb_lams] gives the number of head [MLlam]. *) + +let rec nb_lams = function + | MLlam(_,t) -> succ (nb_lams t) + | _ -> 0 + +(*s [named_lams] does the converse of [collect_lams]. *) + +let rec named_lams ids a = match ids with + | [] -> a + | id :: ids -> named_lams ids (MLlam (id,a)) + +(*s The same in anonymous version. *) + +let rec anonym_lams a = function + | 0 -> a + | n -> anonym_lams (MLlam (anonymous,a)) (pred n) + +(*s Idem for [dummy_name]. *) + +let rec dummy_lams a = function + | 0 -> a + | n -> dummy_lams (MLlam (dummy_name,a)) (pred n) + +(*s mixed according to a signature. *) + +let rec anonym_or_dummy_lams a = function + | [] -> a + | true :: s -> MLlam(anonymous, anonym_or_dummy_lams a s) + | false :: s -> MLlam(dummy_name, anonym_or_dummy_lams a s) + +(*S Operations concerning eta. *) + +(*s The following function creates [MLrel n;...;MLrel 1] *) + +let rec eta_args n = + if n = 0 then [] else (MLrel n)::(eta_args (pred n)) + +(*s Same, but filtered by a signature. *) + +let rec eta_args_sign n = function + | [] -> [] + | true :: s -> (MLrel n) :: (eta_args_sign (n-1) s) + | false :: s -> eta_args_sign (n-1) s + +(*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *) + +let rec test_eta_args_lift k n = function + | [] -> n=0 + | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q) + +(*s Computes an eta-reduction. *) + +let eta_red e = + let ids,t = collect_lams e in + let n = List.length ids in + if n = 0 then e + else match t with + | MLapp (f,a) -> + let m = (List.length a) - n in + if m < 0 then e + else + let a1,a2 = list_chop m a in + let f = if m = 0 then f else MLapp (f,a1) in + if test_eta_args_lift 0 n a2 && not (ast_occurs_itvl 1 n f) + then ast_lift (-n) f + else e + | _ -> e + +(*s Computes all head linear beta-reductions possible in [(t a)]. + Non-linear head beta-redex become let-in. *) + +let rec linear_beta_red a t = match a,t with + | [], _ -> t + | a0::a, MLlam (id,t) -> + (match nb_occur_match t with + | 0 -> linear_beta_red a (ast_pop t) + | 1 -> linear_beta_red a (ast_subst a0 t) + | _ -> + let a = List.map (ast_lift 1) a in + MLletin (id, a0, linear_beta_red a t)) + | _ -> MLapp (t, a) + +(*s Applies a substitution [s] of constants by their body, plus + linear beta reductions at modified positions. *) + +let rec ast_glob_subst s t = match t with + | MLapp ((MLglob (ConstRef kn)) as f, a) -> + let a = List.map (ast_glob_subst s) a in + (try linear_beta_red a (KNmap.find kn s) + with Not_found -> MLapp (f, a)) + | MLglob (ConstRef kn) -> (try KNmap.find kn s with Not_found -> t) + | _ -> ast_map (ast_glob_subst s) t + + +(*S Auxiliary functions used in simplification of ML cases. *) + +(*s [check_and_generalize (r0,l,c)] transforms any [MLcons(r0,l)] in [MLrel 1] + and raises [Impossible] if any variable in [l] occurs outside such a + [MLcons] *) + +let check_and_generalize (r0,l,c) = + let nargs = List.length l in + let rec genrec n = function + | MLrel i as c -> + let i' = i-n in + if i'<1 then c + else if i'>nargs then MLrel (i-nargs+1) + else raise Impossible + | MLcons(r,args) when r=r0 && (test_eta_args_lift n nargs args) -> + MLrel (n+1) + | a -> ast_map_lift genrec n a + in genrec 0 c + +(*s [check_generalizable_case] checks if all branches can be seen as the + same function [f] applied to the term matched. It is a generalized version + of the identity case optimization. *) + +(* CAVEAT: this optimization breaks typing in some special case. example: + [type 'x a = A]. Then [let f = function A -> A] has type ['x a -> 'y a], + which is incompatible with the type of [let f x = x]. + By default, we brutally disable this optim except for some known types: + [bool], [sumbool], [sumor] *) + +let generalizable_list = + let datatypes = MPfile (dirpath_of_string "Coq.Init.Datatypes") + and specif = MPfile (dirpath_of_string "Coq.Init.Specif") + in + [ make_kn datatypes empty_dirpath (mk_label "bool"); + make_kn specif empty_dirpath (mk_label "sumbool"); + make_kn specif empty_dirpath (mk_label "sumor") ] + +let check_generalizable_case unsafe br = + if not unsafe then + (match br.(0) with + | ConstructRef ((kn,_),_), _, _ -> + if not (List.mem kn generalizable_list) then raise Impossible + | _ -> assert false); + let f = check_and_generalize br.(0) in + for i = 1 to Array.length br - 1 do + if check_and_generalize br.(i) <> f then raise Impossible + done; f + +(*s Do all branches correspond to the same thing? *) + +let check_constant_case br = + if br = [||] 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; + let cst = ast_lift (-n) t in + for i = 1 to Array.length br - 1 do + let (r,l,t) = br.(i) in + let n = List.length l in + if (ast_occurs_itvl 1 n t) || (cst <> (ast_lift (-n) t)) + then raise Impossible + done; cst + +(*s If all branches are functions, try to permut the case and the functions. *) + +let rec merge_ids ids ids' = match ids,ids' with + | [],l -> l + | l,[] -> l + | i::ids, i'::ids' -> + (if i = dummy_name then i' else i) :: (merge_ids ids ids') + +let is_exn = function MLexn _ -> true | _ -> false + +let rec permut_case_fun br acc = + let nb = ref max_int in + Array.iter (fun (_,_,t) -> + let ids, c = collect_lams t in + let n = List.length ids in + if (n < !nb) && (not (is_exn c)) then nb := n) br; + if !nb = max_int || !nb = 0 then ([],br) + else begin + let br = Array.copy br in + let ids = ref [] in + for i = 0 to Array.length br - 1 do + let (r,l,t) = br.(i) in + let local_nb = nb_lams t in + if local_nb < !nb then (* t = MLexn ... *) + br.(i) <- (r,l,remove_n_lams local_nb t) + else begin + let local_ids,t = collect_n_lams !nb t in + ids := merge_ids !ids local_ids; + br.(i) <- (r,l,permut_rels !nb (List.length l) t) + end + done; + (!ids,br) + end + +(*S Generalized iota-reduction. *) + +(* Definition of a generalized iota-redex: it's a [MLcase(e,_)] + with [(is_iota_gen e)=true]. Any generalized iota-redex is + transformed into beta-redexes. *) + +let rec is_iota_gen = function + | MLcons _ -> true + | MLcase(_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br + | _ -> false + +let constructor_index = function + | ConstructRef (_,j) -> pred j + | _ -> assert false + +let iota_gen br = + let rec iota k = function + | MLcons (r,a) -> + let (_,ids,c) = br.(constructor_index r) in + let c = List.fold_right (fun id t -> MLlam (id,t)) ids c in + let c = ast_lift k c in + MLapp (c,a) + | MLcase(e,br') -> + let new_br = + Array.map (fun (n,i,c)->(n,i,iota (k+(List.length i)) c)) br' + in MLcase(e, new_br) + | _ -> assert false + in iota 0 + +let is_atomic = function + | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true + | _ -> false + +(*S The main simplification function. *) + +(* Some beta-iota reductions + simplifications. *) + +let rec simpl o = function + | MLapp (f, []) -> + simpl o f + | MLapp (f, a) -> + simpl_app o (List.map (simpl o) a) (simpl o f) + | MLcase (e,br) -> + let br = Array.map (fun (n,l,t) -> (n,l,simpl o t)) br in + simpl_case o br (simpl o e) + | MLletin(id,c,e) when + (id = dummy_name) || (is_atomic c) || (is_atomic e) || + (let n = nb_occur_match e in n = 0 || (n=1 && o.opt_lin_let)) -> + simpl o (ast_subst c e) + | MLfix(i,ids,c) -> + let n = Array.length ids in + if ast_occurs_itvl 1 n c.(i) then + MLfix (i, ids, Array.map (simpl o) c) + else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *) + | a -> ast_map (simpl o) a + +and simpl_app o a = function + | MLapp (f',a') -> simpl_app o (a'@a) f' + | MLlam (id,t) when id = dummy_name -> + simpl o (MLapp (ast_pop t, List.tl a)) + | MLlam (id,t) -> (* Beta redex *) + (match nb_occur_match t with + | 0 -> simpl o (MLapp (ast_pop t, List.tl a)) + | 1 when o.opt_lin_beta -> + simpl o (MLapp (ast_subst (List.hd a) t, List.tl a)) + | _ -> + let a' = List.map (ast_lift 1) (List.tl a) in + simpl o (MLletin (id, List.hd a, MLapp (t, a')))) + | MLletin (id,e1,e2) when o.opt_let_app -> + (* Application of a letin: we push arguments inside *) + MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) + | MLcase (e,br) when o.opt_case_app -> + (* Application of a case: we push arguments inside *) + let br' = + Array.map + (fun (n,l,t) -> + let k = List.length l in + let a' = List.map (ast_lift k) a in + (n, l, simpl o (MLapp (t,a')))) br + in simpl o (MLcase (e,br')) + | (MLdummy | MLexn _) as e -> e + (* We just discard arguments in those cases. *) + | f -> MLapp (f,a) + +and simpl_case o br e = + if o.opt_case_iot && (is_iota_gen e) then (* Generalized iota-redex *) + simpl o (iota_gen br e) + else + try (* Does a term [f] exist such as each branch is [(f e)] ? *) + if not o.opt_case_idr then raise Impossible; + let f = check_generalizable_case o.opt_case_idg br in + simpl o (MLapp (MLlam (anonymous,f),[e])) + with Impossible -> + try (* Is each branch independant of [e] ? *) + if not o.opt_case_cst then raise Impossible; + check_constant_case br + with Impossible -> + (* Swap the case and the lam if possible *) + if o.opt_case_fun + then + let ids,br = permut_case_fun br [] in + let n = List.length ids in + if n <> 0 then named_lams ids (MLcase (ast_lift n e, br)) + else MLcase (e, br) + else MLcase (e,br) + +let rec post_simpl = function + | MLletin(_,c,e) when (is_atomic (eta_red c)) -> + post_simpl (ast_subst (eta_red c) e) + | a -> ast_map post_simpl a + +(*S Local prop elimination. *) +(* We try to eliminate as many [prop] as possible inside an [ml_ast]. *) + +(*s In a list, it selects only the elements corresponding to a [true] + in the boolean list [l]. *) + +let rec select_via_bl l args = match l,args with + | [],_ -> args + | true::l,a::args -> a :: (select_via_bl l args) + | false::l,a::args -> select_via_bl l args + | _ -> assert false + +(*s [kill_some_lams] removes some head lambdas according to the bool list [bl]. + This list is build on the identifier list model: outermost lambda + is on the right. [true] means "to keep" and [false] means "to eliminate". + [Rels] corresponding to removed lambdas are supposed not to occur, and + the other [Rels] are made correct via a [gen_subst]. + Output is not directly a [ml_ast], compose with [named_lams] if needed. *) + +let kill_some_lams bl (ids,c) = + let n = List.length bl in + let n' = List.fold_left (fun n b -> if b then (n+1) else n) 0 bl in + if n = n' then ids,c + else if n' = 0 then [],ast_lift (-n) c + else begin + let v = Array.make n MLdummy in + let rec parse_ids i j = function + | [] -> () + | true :: l -> v.(i) <- MLrel j; parse_ids (i+1) (j+1) l + | false :: l -> parse_ids (i+1) j l + in parse_ids 0 1 bl ; + select_via_bl bl ids, gen_subst v (n'-n) c + end + +(*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding + to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or + if there is no lambda left at all. *) + +let kill_dummy_lams c = + let ids,c = collect_lams c in + let bl = List.map ((<>) dummy_name) ids in + if (List.mem true bl) && (List.mem false bl) then + let ids',c = kill_some_lams bl (ids,c) in + ids, named_lams ids' c + else raise Impossible + +(*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c] + and a signature [s] and builds a eta-long version. *) + +(* For example, if [s = [true;true;false;true]] then the output is : + [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)] with [c' = lift 4 c] *) + +let eta_expansion_sign s (ids,c) = + let rec abs ids rels i = function + | [] -> + let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels + in ids, MLapp (ast_lift (i-1) c, a) + | true :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l + | false :: l -> abs (dummy_name :: ids) (MLdummy :: rels) (i+1) l + in abs ids [] 1 s + +(*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e] + in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas + corresponding to [false] in [s]. *) + +let case_expunge s e = + let m = List.length s in + let n = nb_lams e in + let p = if m <= n then collect_n_lams m e + else eta_expansion_sign (list_skipn n s) (collect_lams e) in + kill_some_lams (List.rev s) p + +(*s [term_expunge] takes a function [fun idn ... id1 -> c] + and a signature [s] and remove dummy lams. The difference + with [case_expunge] is that we here leave one dummy lambda + if all lambdas are dummy. *) + +let term_expunge s (ids,c) = + if s = [] then c + else + let ids,c = kill_some_lams (List.rev s) (ids,c) in + if ids = [] then MLlam (dummy_name, ast_lift 1 c) + else named_lams ids c + +(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and + purge the args of [t0] corresponding to a [dummy_name]. + It makes eta-expansion if needed. *) + +let kill_dummy_args ids t0 t = + let m = List.length ids in + let bl = List.rev_map ((<>) dummy_name) ids in + let rec killrec n = function + | MLapp(e, a) when e = ast_lift n t0 -> + let k = max 0 (m - (List.length a)) in + let a = List.map (killrec n) a in + let a = List.map (ast_lift k) a in + let a = select_via_bl bl (a @ (eta_args k)) in + named_lams (list_firstn k ids) (MLapp (ast_lift k e, a)) + | e when e = ast_lift n t0 -> + let a = select_via_bl bl (eta_args m) in + named_lams ids (MLapp (ast_lift m e, a)) + | e -> ast_map_lift killrec n e + in killrec 0 t + +(*s The main function for local [dummy] elimination. *) + +let rec kill_dummy = function + | MLfix(i,fi,c) -> + (try + let ids,c = kill_dummy_fix i fi c in + ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids (MLrel 1) (MLrel 1)) + with Impossible -> MLfix (i,fi,Array.map kill_dummy c)) + | MLapp (MLfix (i,fi,c),a) -> + (try + let ids,c = kill_dummy_fix i fi c in + let a = List.map (fun t -> ast_lift 1 (kill_dummy t)) a in + let e = kill_dummy_args ids (MLrel 1) (MLapp (MLrel 1,a)) in + ast_subst (MLfix (i,fi,c)) e + with Impossible -> + MLapp(MLfix(i,fi,Array.map kill_dummy c),List.map kill_dummy a)) + | MLletin(id, MLfix (i,fi,c),e) -> + (try + let ids,c = kill_dummy_fix i fi c in + let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in + MLletin(id, MLfix(i,fi,c),e) + with Impossible -> + MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e)) + | MLletin(id,c,e) -> + (try + let ids,c = kill_dummy_lams c in + let e = kill_dummy_args ids (MLrel 1) e in + MLletin (id, kill_dummy c,kill_dummy e) + with Impossible -> MLletin(id,kill_dummy c,kill_dummy e)) + | a -> ast_map kill_dummy a + +and kill_dummy_fix i fi c = + let n = Array.length fi in + let ids,ci = kill_dummy_lams c.(i) in + let c = Array.copy c in c.(i) <- ci; + for j = 0 to (n-1) do + c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j)) + done; + ids,c + +(*s Putting things together. *) + +let normalize a = + let o = optims () in + let a = simpl o a in + if o.opt_kill_dum then post_simpl (kill_dummy a) else a + +(*S Special treatment of fixpoint for pretty-printing purpose. *) + +let general_optimize_fix f ids n args m c = + let v = Array.make n 0 in + for i=0 to (n-1) do v.(i)<-i done; + let aux i = function + | MLrel j when v.(j-1)>=0 -> v.(j-1)<-(-i-1) + | _ -> raise Impossible + in list_iter_i aux args; + let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in + let new_f = anonym_lams (MLapp (MLrel (n+m+1),args_f)) m in + let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in + MLfix(0,[|f|],[|new_c|]) + +let optimize_fix a = + if not (optims()).opt_fix_fun then a + else + let ids,a' = collect_lams a in + let n = List.length ids in + if n = 0 then a + else match a' with + | MLfix(_,[|f|],[|c|]) -> + let new_f = MLapp (MLrel (n+1),eta_args n) in + let new_c = named_lams ids (normalize (ast_subst new_f c)) + in MLfix(0,[|f|],[|new_c|]) + | MLapp(a',args) -> + let m = List.length args in + (match a' with + | MLfix(_,_,_) when + (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a') + -> a' + | MLfix(_,[|f|],[|c|]) -> + (try general_optimize_fix f ids n args m c + with Impossible -> + named_lams ids (MLapp (MLfix (0,[|f|],[|c|]),args))) + | _ -> a) + | _ -> a + +(*S Inlining. *) + +(* Utility functions used in the decision of inlining. *) + +let rec ml_size = function + | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l + | MLlam(_,t) -> 1 + ml_size t + | MLcons(_,l) -> ml_size_list l + | MLcase(t,pv) -> + 1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0) + | MLfix(_,_,f) -> ml_size_array f + | MLletin (_,_,t) -> ml_size t + | MLmagic t -> ml_size t + | _ -> 0 + +and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l + +and ml_size_array l = Array.fold_left (fun a t -> a + ml_size t) 0 l + +let is_fix = function MLfix _ -> true | _ -> false + +let rec is_constr = function + | MLcons _ -> true + | MLlam(_,t) -> is_constr t + | _ -> false + +(*s Strictness *) + +(* A variable is strict if the evaluation of the whole term implies + the evaluation of this variable. Non-strict variables can be found + behind Match, for example. Expanding a term [t] is a good idea when + it begins by at least one non-strict lambda, since the corresponding + argument to [t] might be unevaluated in the expanded code. *) + +exception Toplevel + +let lift n l = List.map ((+) n) l + +let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l + +(* This function returns a list of de Bruijn indices of non-strict variables, + or raises [Toplevel] if it has an internal non-strict variable. + In fact, not all variables are checked for strictness, only the ones which + de Bruijn index is in the candidates list [cand]. The flag [add] controls + the behaviour when going through a lambda: should we add the corresponding + variable to the candidates? We use this flag to check only the external + lambdas, those that will correspond to arguments. *) + +let rec non_stricts add cand = function + | MLlam (id,t) -> + let cand = lift 1 cand in + let cand = if add then 1::cand else cand in + pop 1 (non_stricts add cand t) + | MLrel n -> + List.filter ((<>) n) cand + | MLapp (MLrel n, _) -> + List.filter ((<>) n) cand + (* In [(x y)] we say that only x is strict. Cf [sig_rec]. We may *) + (* gain something if x is replaced by a function like a projection *) + | MLapp (t,l)-> + let cand = non_stricts false cand t in + List.fold_left (non_stricts false) cand l + | MLcons (_,l) -> + List.fold_left (non_stricts false) cand l + | MLletin (_,t1,t2) -> + let cand = non_stricts false cand t1 in + pop 1 (non_stricts add (lift 1 cand) t2) + | MLfix (_,i,f)-> + let n = Array.length i in + let cand = lift n cand in + let cand = Array.fold_left (non_stricts false) cand f in + pop n cand + | MLcase (t,v) -> + (* The only interesting case: for a variable to be non-strict, *) + (* it is sufficient that it appears non-strict in at least one branch, *) + (* so we make an union (in fact a merge). *) + let cand = non_stricts false cand t in + Array.fold_left + (fun c (_,i,t)-> + let n = List.length i in + let cand = lift n cand in + let cand = pop n (non_stricts add cand t) in + Sort.merge (<=) cand c) [] v + (* [merge] may duplicates some indices, but I don't mind. *) + | MLmagic t -> + non_stricts add cand t + | _ -> + cand + +(* The real test: we are looking for internal non-strict variables, so we start + with no candidates, and the only positive answer is via the [Toplevel] + exception. *) + +let is_not_strict t = + try let _ = non_stricts true [] t in false + with Toplevel -> true + +(*s Inlining decision *) + +(* [inline_test] answers the following question: + If we could inline [t] (the user said nothing special), + should we inline ? + + We expand small terms with at least one non-strict + variable (i.e. a variable that may not be evaluated). + + Futhermore we don't expand fixpoints. *) + +let inline_test t = + not (is_fix (eta_red t)) && (ml_size t < 12 && is_not_strict t) + +let manual_inline_list = + let mp = MPfile (dirpath_of_string "Coq.Init.Wf") in + List.map (fun s -> (make_kn mp empty_dirpath (mk_label s))) + [ "well_founded_induction_type"; "well_founded_induction"; + "Acc_rect"; "Acc_rec" ; "Acc_iter" ] + +let manual_inline = function + | ConstRef c -> List.mem c manual_inline_list + | _ -> false + +(* If the user doesn't say he wants to keep [t], we inline in two cases: + \begin{itemize} + \item the user explicitly requests it + \item [expansion_test] answers that the inlining is a good idea, and + we are free to act (AutoInline is set) + \end{itemize} *) + +let inline r t = + not (to_keep r) (* The user DOES want to keep it *) + && not (is_inline_custom r) + && (to_inline r (* The user DOES want to inline it *) + || (auto_inline () && lang () <> Haskell && not (is_projection r) + && (is_recursor r || manual_inline r || inline_test t))) + diff --git a/contrib/extraction/mlutil.mli b/contrib/extraction/mlutil.mli new file mode 100644 index 00000000..eaf38778 --- /dev/null +++ b/contrib/extraction/mlutil.mli @@ -0,0 +1,111 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: mlutil.mli,v 1.47.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +open Util +open Names +open Term +open Libnames +open Miniml + +(*s Utility functions over ML types with meta. *) + +val reset_meta_count : unit -> unit +val new_meta : 'a -> ml_type + +val type_subst : int -> ml_type -> ml_type -> ml_type +val type_subst_list : ml_type list -> ml_type -> ml_type +val type_subst_vect : ml_type array -> ml_type -> ml_type + +val instantiation : ml_schema -> ml_type + +val needs_magic : ml_type * ml_type -> bool +val put_magic_if : bool -> ml_ast -> ml_ast +val put_magic : ml_type * ml_type -> ml_ast -> ml_ast + +(*s ML type environment. *) + +module Mlenv : sig + type t + val empty : t + + (* get the n-th more recently entered schema and instantiate it. *) + val get : t -> int -> ml_type + + (* Adding a type in an environment, after generalizing free meta *) + val push_gen : t -> ml_type -> t + + (* Adding a type with no [Tvar] *) + val push_type : t -> ml_type -> t + + (* Adding a type with no [Tvar] nor [Tmeta] *) + val push_std_type : t -> ml_type -> t +end + +(*s Utility functions over ML types without meta *) + +val type_mem_kn : kernel_name -> ml_type -> bool + +val type_maxvar : ml_type -> int + +val type_decomp : ml_type -> ml_type list * ml_type +val type_recomp : ml_type list * ml_type -> ml_type + +val var2var' : ml_type -> ml_type + +type abbrev_map = global_reference -> ml_type option + +val type_expand : abbrev_map -> ml_type -> ml_type +val type_eq : abbrev_map -> ml_type -> ml_type -> bool +val type_neq : abbrev_map -> ml_type -> ml_type -> bool +val type_to_sign : abbrev_map -> ml_type -> bool list +val type_expunge : abbrev_map -> ml_type -> ml_type + +val case_expunge : bool list -> ml_ast -> identifier list * ml_ast +val term_expunge : bool list -> identifier list * ml_ast -> ml_ast + + +(*s Special identifiers. [dummy_name] is to be used for dead code + and will be printed as [_] in concrete (Caml) code. *) + +val anonymous : identifier +val dummy_name : identifier +val id_of_name : name -> identifier + +(*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns + the list [idn;...;id1] and the term [t]. *) + +val collect_lams : ml_ast -> identifier list * ml_ast +val collect_n_lams : int -> ml_ast -> identifier list * ml_ast +val nb_lams : ml_ast -> int + +val dummy_lams : ml_ast -> int -> ml_ast +val anonym_or_dummy_lams : ml_ast -> bool list -> ml_ast + +val eta_args_sign : int -> bool list -> ml_ast list + +(*s Utility functions over ML terms. *) + +val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast +val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast +val ast_iter : (ml_ast -> unit) -> ml_ast -> unit +val ast_occurs : int -> ml_ast -> bool +val ast_occurs_itvl : int -> int -> ml_ast -> bool +val ast_lift : int -> ml_ast -> ml_ast +val ast_pop : ml_ast -> ml_ast +val ast_subst : ml_ast -> ml_ast -> ml_ast + +val ast_glob_subst : ml_ast KNmap.t -> ml_ast -> ml_ast + +val normalize : ml_ast -> ml_ast +val optimize_fix : ml_ast -> ml_ast +val inline : global_reference -> ml_ast -> bool + + + diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml new file mode 100644 index 00000000..feb9e54e --- /dev/null +++ b/contrib/extraction/modutil.ml @@ -0,0 +1,405 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: modutil.ml,v 1.7.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +open Names +open Declarations +open Environ +open Libnames +open Util +open Miniml +open Table +open Mlutil + +(*S Functions upon modules missing in [Modops]. *) + +(*s Add _all_ direct subobjects of a module, not only those exported. + Build on the [Modops.add_signature] model. *) + +let add_structure mp msb env = + let add_one env (l,elem) = + let kn = make_kn mp empty_dirpath l in + match elem with + | SEBconst cb -> Environ.add_constant kn 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 + in List.fold_left add_one env msb + +(*s Apply a module path substitution on a module. + Build on the [Modops.subst_modtype] model. *) + +let rec subst_module sub mb = + let mtb' = Modops.subst_modtype sub mb.mod_type + and meb' = option_smartmap (subst_meb sub) mb.mod_expr + and mtb'' = option_smartmap (Modops.subst_modtype sub) mb.mod_user_type + and mpo' = option_smartmap (subst_mp sub) mb.mod_equiv in + if (mtb'==mb.mod_type) && (meb'==mb.mod_expr) && + (mtb''==mb.mod_user_type) && (mpo'==mb.mod_equiv) + then mb + else { mod_expr= meb'; + mod_type=mtb'; + mod_user_type=mtb''; + mod_equiv=mpo'; + mod_constraints=mb.mod_constraints } + +and subst_meb sub = function + | MEBident mp -> MEBident (subst_mp sub mp) + | MEBfunctor (mbid, mtb, meb) -> + assert (not (occur_mbid mbid sub)); + MEBfunctor (mbid, Modops.subst_modtype sub mtb, subst_meb sub meb) + | MEBstruct (msid, msb) -> + assert (not (occur_msid msid sub)); + MEBstruct (msid, subst_msb sub msb) + | MEBapply (meb, meb', c) -> + MEBapply (subst_meb sub meb, subst_meb sub meb', c) + +and subst_msb sub msb = + let subst_body = function + | SEBconst cb -> SEBconst (subst_const_body sub cb) + | SEBmind mib -> SEBmind (subst_mind sub mib) + | SEBmodule mb -> SEBmodule (subst_module sub mb) + | SEBmodtype mtb -> SEBmodtype (Modops.subst_modtype sub mtb) + in List.map (fun (l,b) -> (l,subst_body b)) msb + +(*s Change a msid in a module type, to follow a module expr. + Because of the "with" construct, the module type of a module can be a + [MTBsig] with a msid different from the one of the module. *) + +let rec replicate_msid meb mtb = match meb,mtb with + | MEBfunctor (_, _, meb), MTBfunsig (mbid, mtb1, mtb2) -> + let mtb' = replicate_msid meb mtb2 in + if mtb' == mtb2 then mtb else MTBfunsig (mbid, mtb1, mtb') + | MEBstruct (msid, _), MTBsig (msid1, msig) when msid <> msid1 -> + let msig' = Modops.subst_signature_msid msid1 (MPself msid) msig in + if msig' == msig then MTBsig (msid, msig) else MTBsig (msid, msig') + | _ -> mtb + + +(*S More functions concerning [module_path]. *) + +let rec mp_length = function + | MPdot (mp, _) -> 1 + (mp_length mp) + | _ -> 1 + +let rec prefixes_mp mp = match mp with + | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp') + | _ -> MPset.singleton mp + +let rec common_prefix prefixes_mp1 mp2 = + if MPset.mem mp2 prefixes_mp1 then mp2 + else match mp2 with + | MPdot (mp,_) -> common_prefix prefixes_mp1 mp + | _ -> raise Not_found + +let common_prefix_from_list mp0 mpl = + let prefixes_mp0 = prefixes_mp mp0 in + let rec f = function + | [] -> raise Not_found + | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l + in f mpl + +let rec modfile_of_mp mp = match mp with + | MPfile _ -> mp + | MPdot (mp,_) -> modfile_of_mp mp + | _ -> raise Not_found + +let rec parse_labels ll = function + | MPdot (mp,l) -> parse_labels (l::ll) mp + | mp -> mp,ll + +let labels_of_mp mp = parse_labels [] mp + +let labels_of_kn kn = + let mp,_,l = repr_kn kn in parse_labels [l] mp + +let rec add_labels_mp mp = function + | [] -> mp + | l :: ll -> add_labels_mp (MPdot (mp,l)) ll + + +(*S Functions upon ML modules. *) + +(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a + [ml_structure]. *) + +let struct_iter do_decl do_spec s = + let rec mt_iter = function + | MTident _ -> () + | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' + | MTsig (_, sign) -> List.iter spec_iter sign + and spec_iter = function + | (_,Spec s) -> do_spec s + | (_,Smodule mt) -> mt_iter mt + | (_,Smodtype mt) -> mt_iter mt + in + let rec se_iter = function + | (_,SEdecl d) -> do_decl d + | (_,SEmodule m) -> + me_iter m.ml_mod_expr; mt_iter m.ml_mod_type + | (_,SEmodtype m) -> mt_iter m + and me_iter = function + | MEident _ -> () + | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt + | MEapply (me,me') -> me_iter me; me_iter me' + | MEstruct (msid, sel) -> List.iter se_iter sel + in + List.iter (function (_,sel) -> List.iter se_iter sel) s + +(*s Apply some fonctions upon all references in [ml_type], [ml_ast], + [ml_decl], [ml_spec] and [ml_structure]. *) + +type do_ref = global_reference -> unit + +let type_iter_references do_type t = + let rec iter = function + | Tglob (r,l) -> do_type r; List.iter iter l + | Tarr (a,b) -> iter a; iter b + | _ -> () + in iter t + +let ast_iter_references do_term do_cons do_type a = + let rec iter a = + ast_iter iter a; + match a with + | MLglob r -> do_term r + | MLcons (r,_) -> do_cons r + | MLcase (_,v) as a -> Array.iter (fun (r,_,_) -> do_cons r) v + | _ -> () + in iter a + +let ind_iter_references do_term do_cons do_type kn ind = + let type_iter = type_iter_references do_type in + let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in + let packet_iter ip p = + do_type (IndRef ip); Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types + in + if ind.ind_info = Record then List.iter do_term (find_projections kn); + Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets + +let decl_iter_references do_term do_cons do_type = + let type_iter = type_iter_references do_type + and ast_iter = ast_iter_references do_term do_cons do_type in + function + | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind + | Dtype (r,_,t) -> do_type r; type_iter t + | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t + | Dfix(rv,c,t) -> + Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t + +let spec_iter_references do_term do_cons do_type = function + | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind + | Stype (r,_,ot) -> do_type r; option_iter (type_iter_references do_type) ot + | Sval (r,t) -> do_term r; type_iter_references do_type t + +let struct_iter_references do_term do_cons do_type = + struct_iter + (decl_iter_references do_term do_cons do_type) + (spec_iter_references do_term do_cons do_type) + +(*s Get all references used in one [ml_structure], either in [list] or [set]. *) + +type 'a updown = { mutable up : 'a ; mutable down : 'a } + +let struct_get_references empty add struc = + let o = { up = empty ; down = empty } in + let do_term r = o.down <- add r o.down in + let do_cons r = o.up <- add r o.up in + let do_type = if lang () = Haskell then do_cons else do_term in + struct_iter_references do_term do_cons do_type struc; o + +let struct_get_references_set = struct_get_references Refset.empty Refset.add + +module Orefset = struct + type t = { set : Refset.t ; list : global_reference list } + let empty = { set = Refset.empty ; list = [] } + let add r o = + if Refset.mem r o.set then o + else { set = Refset.add r o.set ; list = r :: o.list } + let set o = o.set + let list o = o.list +end + +let struct_get_references_list struc = + let o = struct_get_references Orefset.empty Orefset.add struc in + { up = Orefset.list o.up; down = Orefset.list o.down } + + +(*s Searching occurrences of a particular term (no lifting done). *) + +exception Found + +let rec ast_search t a = + if t = a then raise Found else ast_iter (ast_search t) a + +let decl_ast_search t = function + | Dterm (_,a,_) -> ast_search t a + | Dfix (_,c,_) -> Array.iter (ast_search t) c + | _ -> () + +let struct_ast_search t s = + try struct_iter (decl_ast_search t) (fun _ -> ()) s; false + with Found -> true + +let rec type_search t = function + | Tarr (a,b) -> type_search t a; type_search t b + | Tglob (r,l) -> List.iter (type_search t) l + | u -> if t = u then raise Found + +let decl_type_search t = function + | Dind (_,{ind_packets=p}) -> + Array.iter + (fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p + | Dterm (_,_,u) -> type_search t u + | Dfix (_,_,v) -> Array.iter (type_search t) v + | Dtype (_,_,u) -> type_search t u + +let spec_type_search t = function + | Sind (_,{ind_packets=p}) -> + Array.iter + (fun {ip_types=v} -> Array.iter (List.iter (type_search t)) v) p + | Stype (_,_,ot) -> option_iter (type_search t) ot + | Sval (_,u) -> type_search t u + +let struct_type_search t s = + try struct_iter (decl_type_search t) (spec_type_search t) s; false + with Found -> true + + +(*s Generating the signature. *) + +let rec msig_of_ms = function + | [] -> [] + | (l,SEdecl (Dind (kn,i))) :: ms -> + (l,Spec (Sind (kn,i))) :: (msig_of_ms ms) + | (l,SEdecl (Dterm (r,_,t))) :: ms -> + (l,Spec (Sval (r,t))) :: (msig_of_ms ms) + | (l,SEdecl (Dtype (r,v,t))) :: ms -> + (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms) + | (l,SEdecl (Dfix (rv,_,tv))) :: ms -> + let msig = ref (msig_of_ms ms) in + for i = Array.length rv - 1 downto 0 do + msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig + done; + !msig + | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms) + | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms) + +let signature_of_structure s = + List.map (fun (mp,ms) -> mp,msig_of_ms ms) s + + +(*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *) + +let get_decl_in_structure r struc = + try + let kn = kn_of_r r in + let base_mp,ll = labels_of_kn kn in + if not (at_toplevel base_mp) then error_not_visible r; + let sel = List.assoc base_mp struc in + let rec go ll sel = match ll with + | [] -> assert false + | l :: ll -> + match List.assoc l sel with + | SEdecl d -> d + | SEmodtype m -> assert false + | SEmodule m -> + match m.ml_mod_expr with + | MEstruct (_,sel) -> go ll sel + | _ -> error_not_visible r + in go ll sel + with Not_found -> assert false + + +(*s Optimization of a [ml_structure]. *) + +(* Some transformations of ML terms. [optimize_struct] simplify + all beta redexes (when the argument does not occur, it is just + thrown away; when it occurs exactly once it is substituted; otherwise + a let-in redex is created for clarity) and iota redexes, plus some other + optimizations. *) + +let dfix_to_mlfix rv av i = + let rec make_subst n s = + if n < 0 then s + else make_subst (n-1) (KNmap.add (kn_of_r rv.(n)) (n+1) s) + in + let s = make_subst (Array.length rv - 1) KNmap.empty + in + let rec subst n t = match t with + | MLglob (ConstRef kn) -> + (try MLrel (n + (KNmap.find kn 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 c = Array.map (subst 0) av + in MLfix(i, ids, c) + +let rec optim prm s = function + | [] -> [] + | (Dtype (r,_,Tdummy) | Dterm(r,MLdummy,_)) as d :: l -> + if List.mem r prm.to_appear then d :: (optim prm s l) else optim prm s l + | Dterm (r,t,typ) :: l -> + let t = normalize (ast_glob_subst !s t) in + let i = inline r t in + if i then s := KNmap.add (kn_of_r r) t !s; + if not i || prm.modular || List.mem r prm.to_appear + then + let d = match optimize_fix t with + | MLfix (0, _, [|c|]) -> + Dfix ([|r|], [|ast_subst (MLglob r) c|], [|typ|]) + | t -> Dterm (r, t, typ) + in d :: (optim prm s l) + else optim prm s l + | d :: l -> d :: (optim prm s l) + +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 top && i && not prm.modular && not (List.mem r prm.to_appear) + then optim_se top prm s lse + else + let d = match optimize_fix a with + | MLfix (0, _, [|c|]) -> + Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) + | a -> Dterm (r, a, t) + in (l,SEdecl d) :: (optim_se top prm s lse) + | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> + let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in + let all = ref true in + (* This fake body ensures that no fixpoint will be auto-inlined. *) + let fake_body = MLfix (0,[||],[||]) in + for i = 0 to Array.length rv - 1 do + if inline rv.(i) fake_body + then s := KNmap.add (kn_of_r rv.(i)) (dfix_to_mlfix rv av i) !s + else all := false + done; + if !all && top && not prm.modular + && (array_for_all (fun r -> not (List.mem r prm.to_appear)) rv) + then optim_se top prm s lse + else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top prm s lse) + | (l,SEmodule m) :: lse -> + let m = { m with ml_mod_expr = optim_me prm s m.ml_mod_expr} + in (l,SEmodule m) :: (optim_se top prm s lse) + | se :: lse -> se :: (optim_se top prm s lse) + +and optim_me prm s = function + | MEstruct (msid, lse) -> MEstruct (msid, optim_se false prm s lse) + | MEident mp as me -> me + | MEapply (me, me') -> MEapply (optim_me prm s me, optim_me prm s me') + | 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 + 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 new file mode 100644 index 00000000..f73e18f7 --- /dev/null +++ b/contrib/extraction/modutil.mli @@ -0,0 +1,70 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: modutil.mli,v 1.2.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +open Names +open Declarations +open Environ +open Libnames +open Miniml + +(*s Functions upon modules missing in [Modops]. *) + +(* Add _all_ direct subobjects of a module, not only those exported. + Build on the [Modops.add_signature] model. *) + +val add_structure : module_path -> module_structure_body -> env -> env + +(* Apply a module path substitution on a module. + Build on the [Modops.subst_modtype] model. *) + +val subst_module : substitution -> module_body -> module_body +val subst_meb : substitution -> module_expr_body -> module_expr_body +val subst_msb : substitution -> module_structure_body -> module_structure_body + +(* Change a msid in a module type, to follow a module expr. *) + +val replicate_msid : module_expr_body -> module_type_body -> module_type_body + +(*s More utilities concerning [module_path]. *) + +val mp_length : module_path -> int +val prefixes_mp : module_path -> MPset.t +val modfile_of_mp : module_path -> module_path +val common_prefix_from_list : module_path -> module_path list -> module_path +val add_labels_mp : module_path -> label list -> module_path + +(*s Functions upon ML modules. *) + +val struct_ast_search : ml_ast -> ml_structure -> bool +val struct_type_search : ml_type -> ml_structure -> bool + +type do_ref = global_reference -> unit + +val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit +val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit +val struct_iter_references : do_ref -> do_ref -> do_ref -> ml_structure -> unit + +type 'a updown = { mutable up : 'a ; mutable down : 'a } + +val struct_get_references_set : ml_structure -> Refset.t updown +val struct_get_references_list : ml_structure -> global_reference list updown + +val signature_of_structure : ml_structure -> ml_signature + +val get_decl_in_structure : global_reference -> ml_structure -> ml_decl + +(* Some transformations of ML terms. [optimize_struct] simplify + all beta redexes (when the argument does not occur, it is just + thrown away; when it occurs exactly once it is substituted; otherwise + a let-in redex is created for clarity) and iota redexes, plus some other + optimizations. *) + +val optimize_struct : + extraction_params -> ml_decl list option -> ml_structure -> ml_structure diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml new file mode 100644 index 00000000..707ef94f --- /dev/null +++ b/contrib/extraction/ocaml.ml @@ -0,0 +1,627 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: ocaml.ml,v 1.100.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +(*s Production of Ocaml syntax. *) + +open Pp +open Util +open Names +open Nameops +open Libnames +open Table +open Miniml +open Mlutil +open Modutil + +let cons_cofix = ref Refset.empty + +(*s Some utility functions. *) + +let pp_par par st = if par then str "(" ++ st ++ str ")" else st + +let pp_tvar id = + let s = string_of_id id in + if String.length s < 2 || s.[1]<>'\'' + then str ("'"^s) + else str ("' "^s) + +let pp_tuple_light f = function + | [] -> mt () + | [x] -> f true x + | l -> + pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l) + +let pp_tuple f = function + | [] -> mt () + | [x] -> f x + | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l) + +let pp_boxed_tuple f = function + | [] -> mt () + | [x] -> f x + | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l)) + +let pp_abst = function + | [] -> mt () + | l -> + str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++ + str " ->" ++ spc () + +let pp_apply st par args = match args with + | [] -> st + | _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args)) + +let pr_binding = function + | [] -> mt () + | l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l + +let space_if = function true -> str " " | false -> mt () + +let sec_space_if = function true -> spc () | false -> mt () + +let fnl2 () = fnl () ++ fnl () + +(*s Generic renaming issues. *) + +let rec rename_id id avoid = + if Idset.mem id avoid then rename_id (lift_ident id) avoid else id + +let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id)) +let uppercase_id id = id_of_string (String.capitalize (string_of_id id)) + +(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *) +let pr_upper_id id = str (String.capitalize (string_of_id id)) + +(*s de Bruijn environments for programs *) + +type env = identifier list * Idset.t + +let rec rename_vars avoid = function + | [] -> + [], avoid + | id :: idl when id == dummy_name -> + (* we don't rename dummy binders *) + let (idl', avoid') = rename_vars avoid idl in + (id :: idl', avoid') + | id :: idl -> + let (idl, avoid) = rename_vars avoid idl in + let id = rename_id (lowercase_id id) avoid in + (id :: idl, Idset.add id avoid) + +let rename_tvars avoid l = + let rec rename avoid = function + | [] -> [],avoid + | id :: idl -> + let id = rename_id (lowercase_id id) avoid in + let idl, avoid = rename (Idset.add id avoid) idl in + (id :: idl, avoid) in + fst (rename avoid l) + +let push_vars ids (db,avoid) = + let ids',avoid' = rename_vars avoid ids in + ids', (ids' @ db, avoid') + +let get_db_name n (db,_) = + let id = List.nth db (pred n) in + if id = dummy_name then id_of_string "__" else id + +(*s Ocaml renaming issues. *) + +let keywords = + List.fold_right (fun s -> Idset.add (id_of_string s)) + [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; + "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; + "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; + "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; + "module"; "mutable"; "new"; "object"; "of"; "open"; "or"; + "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; + "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod"; + "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ] + Idset.empty + +let preamble _ used_modules (mldummy,tdummy,tunknown) = + let pp_mp = function + | MPfile d -> pr_upper_id (List.hd (repr_dirpath d)) + | _ -> assert false + in + prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules + ++ + (if used_modules = [] then mt () else fnl ()) + ++ + (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() else mt()) + ++ + (if mldummy then + str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl () + else mt ()) + ++ + (if tdummy || tunknown || mldummy then fnl () else mt ()) + +let preamble_sig _ used_modules (_,tdummy,tunknown) = + let pp_mp = function + | MPfile d -> pr_upper_id (List.hd (repr_dirpath d)) + | _ -> assert false + in + prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules + ++ + (if used_modules = [] then mt () else fnl ()) + ++ + (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() ++ fnl () + else mt()) + +(*s The pretty-printing functor. *) + +module Make = functor(P : Mlpp_param) -> struct + +let local_mpl = ref ([] : module_path list) + +let pp_global r = + if is_inline_custom r then str (find_custom r) + else P.pp_global !local_mpl r + +let empty_env () = [], P.globals () + +(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses + are needed or not. *) + +let rec pp_type par vl t = + let rec pp_rec par = function + | Tmeta _ | Tvar' _ | Taxiom -> assert false + | Tvar i -> (try pp_tvar (List.nth vl (pred i)) + with _ -> (str "'a" ++ int i)) + | Tglob (r,[]) -> pp_global r + | Tglob (r,l) -> pp_tuple_light pp_rec l ++ spc () ++ pp_global r + | Tarr (t1,t2) -> + pp_par par + (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2) + | Tdummy -> str "__" + | Tunknown -> str "__" + | Tcustom s -> str s + in + hov 0 (pp_rec par t) + +(*s Pretty-printing of expressions. [par] indicates whether + parentheses are needed or not. [env] is the list of names for the + de Bruijn variables. [args] is the list of collected arguments + (already pretty-printed). *) + +let expr_needs_par = function + | MLlam _ -> true + | MLcase (_,[|_|]) -> false + | MLcase _ -> true + | _ -> false + + +let rec pp_expr par env args = + let par' = args <> [] || par + and apply st = pp_apply st par args in + function + | MLrel n -> + let id = get_db_name n env in apply (pr_id id) + | MLapp (f,args') -> + let stl = List.map (pp_expr true env []) args' in + pp_expr par env (stl @ args) f + | MLlam _ as a -> + let fl,a' = collect_lams a in + let fl,env' = push_vars fl env in + let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in + apply (pp_par par' st) + | MLletin (id,a1,a2) -> + let i,env' = push_vars [id] env in + let pp_id = pr_id (List.hd i) + and pp_a1 = pp_expr false env [] a1 + and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in + hv 0 + (apply + (pp_par par' + (hv 0 + (hov 2 + (str "let " ++ pp_id ++ str " =" ++ spc () ++ pp_a1) ++ + spc () ++ str "in") ++ + spc () ++ hov 0 pp_a2))) + | MLglob r -> + (try + let args = list_skipn (projection_arity r) args in + let record = List.hd args in + pp_apply (record ++ str "." ++ pp_global r) par (List.tl args) + with _ -> apply (pp_global r)) + | MLcons (r,[]) -> + assert (args=[]); + if Refset.mem r !cons_cofix then + pp_par par (str "lazy " ++ pp_global r) + else pp_global r + | MLcons (r,args') -> + (try + let projs = find_projections (kn_of_r r) in + pp_record_pat (projs, List.map (pp_expr true env []) args') + with Not_found -> + assert (args=[]); + let tuple = pp_tuple (pp_expr true env []) args' in + if Refset.mem r !cons_cofix then + pp_par par (str "lazy (" ++ pp_global r ++ spc() ++ tuple ++str ")") + else pp_par par (pp_global r ++ spc () ++ tuple)) + | MLcase (t, pv) -> + let r,_,_ = pv.(0) in + let expr = if Refset.mem r !cons_cofix then + (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) + else + (pp_expr false env [] t) + in + (try + let projs = find_projections (kn_of_r r) in + let (_, ids, c) = pv.(0) in + let n = List.length ids in + match c with + | MLrel i when i <= n -> + apply (pp_par par' (pp_expr true env [] t ++ str "." ++ + pp_global (List.nth projs (n-i)))) + | MLapp (MLrel i, a) when i <= n -> + if List.exists (ast_occurs_itvl 1 n) a + then raise Not_found + else + let ids,env' = push_vars (List.rev ids) env in + (pp_apply + (pp_expr true env [] t ++ str "." ++ + pp_global (List.nth projs (n-i))) + par ((List.map (pp_expr true env' []) a) @ args)) + | _ -> raise Not_found + with Not_found -> + if Array.length pv = 1 then + let s1,s2 = pp_one_pat env pv.(0) in + apply + (hv 0 + (pp_par par' + (hv 0 + (hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) + ++ spc () ++ str "in") ++ + spc () ++ hov 0 s2))) + else + apply + (pp_par par' + (v 0 (str "match " ++ expr ++ str " with" ++ + fnl () ++ str " | " ++ pp_pat env pv)))) + | MLfix (i,ids,defs) -> + let ids',env' = push_vars (List.rev (Array.to_list ids)) env in + pp_fix par env' i (Array.of_list (List.rev ids'),defs) args + | MLexn s -> + (* An [MLexn] may be applied, but I don't really care. *) + pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) + | MLdummy -> + str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLmagic a -> + pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) + | MLaxiom -> + pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") + + +and pp_record_pat (projs, args) = + str "{ " ++ + prlist_with_sep (fun () -> str ";" ++ spc ()) + (fun (r,a) -> pp_global r ++ str " =" ++ spc () ++ a) + (List.combine projs args) ++ + str " }" + +and pp_one_pat env (r,ids,t) = + let ids,env' = push_vars (List.rev ids) env in + let expr = pp_expr (expr_needs_par t) env' [] t in + try + let projs = find_projections (kn_of_r r) in + pp_record_pat (projs, List.rev_map pr_id ids), expr + with Not_found -> + let args = + if ids = [] then (mt ()) + else str " " ++ pp_boxed_tuple pr_id (List.rev ids) in + pp_global r ++ args, expr + +and pp_pat env pv = + prvect_with_sep (fun () -> (fnl () ++ str " | ")) + (fun x -> let s1,s2 = pp_one_pat env x in + hov 2 (s1 ++ str " ->" ++ spc () ++ s2)) pv + +and pp_function env f t = + let bl,t' = collect_lams t in + let bl,env' = push_vars bl env in + let is_function pv = + let ktl = array_map_to_list (fun (_,l,t0) -> (List.length l,t0)) pv in + not (List.exists (fun (k,t0) -> ast_occurs (k+1) t0) ktl) + in + let is_not_cofix pv = + let (r,_,_) = pv.(0) in not (Refset.mem r !cons_cofix) + in + match t' with + | MLcase(MLrel 1,pv) when is_not_cofix pv -> + if is_function pv then + (f ++ pr_binding (List.rev (List.tl bl)) ++ + str " = function" ++ fnl () ++ + v 0 (str " | " ++ pp_pat env' pv)) + else + (f ++ pr_binding (List.rev bl) ++ + str " = match " ++ + pr_id (List.hd bl) ++ str " with" ++ fnl () ++ + v 0 (str " | " ++ pp_pat env' pv)) + + | _ -> (f ++ pr_binding (List.rev bl) ++ + str " =" ++ fnl () ++ str " " ++ + hov 2 (pp_expr false env' [] t')) + +(*s names of the functions ([ids]) are already pushed in [env], + and passed here just for convenience. *) + +and pp_fix par env i (ids,bl) args = + pp_par par + (v 0 (str "let rec " ++ + prvect_with_sep + (fun () -> fnl () ++ str "and ") + (fun (fi,ti) -> pp_function env (pr_id fi) ti) + (array_map2 (fun id b -> (id,b)) ids bl) ++ + fnl () ++ + hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args))) + +let pp_val e typ = + str "(** val " ++ e ++ str " : " ++ pp_type false [] typ ++ + str " **)" ++ fnl2 () + +(*s Pretty-printing of [Dfix] *) + +let rec pp_Dfix init i ((rv,c,t) as fix) = + if i >= Array.length rv then mt () + else + if is_inline_custom rv.(i) then pp_Dfix init (i+1) fix + else + let e = pp_global rv.(i) in + (if init then mt () else fnl2 ()) ++ + pp_val e t.(i) ++ + str (if init then "let rec " else "and ") ++ + (if is_custom rv.(i) then e ++ str " = " ++ str (find_custom rv.(i)) + else pp_function (empty_env ()) e c.(i)) ++ + pp_Dfix false (i+1) fix + +(*s Pretty-printing of inductive types declaration. *) + +let pp_parameters l = + (pp_boxed_tuple pp_tvar l ++ space_if (l<>[])) + +let pp_string_parameters l = + (pp_boxed_tuple str l ++ space_if (l<>[])) + +let pp_one_ind prefix ip pl cv = + let pl = rename_tvars keywords pl in + let pp_constructor (r,l) = + hov 2 (str " | " ++ pp_global r ++ + match l with + | [] -> mt () + | _ -> (str " of " ++ + prlist_with_sep + (fun () -> spc () ++ str "* ") (pp_type true pl) l)) + in + pp_parameters pl ++ str prefix ++ pp_global (IndRef ip) ++ str " =" ++ + if cv = [||] then str " unit (* empty inductive *)" + else fnl () ++ v 0 (prvect_with_sep fnl pp_constructor + (Array.mapi (fun i c -> ConstructRef (ip,i+1), c) cv)) + +let pp_comment s = str "(* " ++ s ++ str " *)" + +let pp_logical_ind packet = + pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++ + fnl () ++ pp_comment (str "with constructors : " ++ + prvect_with_sep spc pr_id packet.ip_consnames) + +let pp_singleton kn packet = + let l = rename_tvars keywords packet.ip_vars in + hov 2 (str "type " ++ pp_parameters l ++ + pp_global (IndRef (kn,0)) ++ str " =" ++ spc () ++ + pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ + pp_comment (str "singleton inductive, whose constructor was " ++ + pr_id packet.ip_consnames.(0))) + +let pp_record kn packet = + let l = List.combine (find_projections kn) packet.ip_types.(0) in + let projs = find_projections kn in + let pl = rename_tvars keywords packet.ip_vars in + str "type " ++ pp_parameters pl ++ pp_global (IndRef (kn,0)) ++ str " = { "++ + hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ()) + (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l) + ++ str " }" + +let pp_coind ip pl = + let r = IndRef ip in + let pl = rename_tvars keywords pl in + pp_parameters pl ++ pp_global r ++ str " = " ++ + pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t" + +let pp_ind co kn ind = + let some = ref false in + let init= ref (str "type ") in + let rec pp i = + if i >= Array.length ind.ind_packets then mt () + else + let ip = (kn,i) in + let p = ind.ind_packets.(i) in + if is_custom (IndRef (kn,i)) then pp (i+1) + else begin + some := true; + if p.ip_logical then pp_logical_ind p ++ pp (i+1) + else + let s = !init in + begin + init := (fnl () ++ str "and "); + s ++ + (if co then pp_coind ip p.ip_vars ++ fnl () ++ str "and " else mt ()) + ++ pp_one_ind (if co then "__" else "") ip p.ip_vars p.ip_types ++ + pp (i+1) + end + end + in + let st = pp 0 in if !some then st else failwith "empty phrase" + + +(*s Pretty-printing of a declaration. *) + +let pp_mind kn i = + match i.ind_info with + | Singleton -> pp_singleton kn i.ind_packets.(0) + | Coinductive -> + let nop _ = () + and add r = cons_cofix := Refset.add r !cons_cofix in + decl_iter_references nop add nop (Dind (kn,i)); + pp_ind true kn i + | Record -> pp_record kn i.ind_packets.(0) + | _ -> pp_ind false kn i + +let pp_decl mpl = + local_mpl := mpl; + function + | Dind (kn,i) as d -> pp_mind kn i + | Dtype (r, l, t) -> + if is_inline_custom r then failwith "empty phrase" + else + let l = rename_tvars keywords l in + let ids, def = try + let ids,s = find_type_custom r in + pp_string_parameters ids, str "=" ++ spc () ++ str s + with not_found -> + pp_parameters l, + if t = Taxiom then str "(* AXIOM TO BE REALIZED *)" + else str "=" ++ spc () ++ pp_type false l t + in + hov 2 (str "type" ++ spc () ++ ids ++ pp_global r ++ + spc () ++ def) + | Dterm (r, a, t) -> + if is_inline_custom r then failwith "empty phrase" + else + let e = pp_global r in + pp_val e t ++ + hov 0 + (str "let " ++ + if is_custom r then + e ++ str " = " ++ str (find_custom r) + else if is_projection r then + let s = prvecti (fun _ -> str) + (Array.make (projection_arity r) " _") in + e ++ s ++ str " x = x." ++ e + else pp_function (empty_env ()) e a) + | Dfix (rv,defs,typs) -> + pp_Dfix true 0 (rv,defs,typs) + +let pp_spec mpl = + local_mpl := mpl; + function + | Sind (kn,i) -> pp_mind kn i + | Sval (r,t) -> + if is_inline_custom r then failwith "empty phrase" + else + hov 2 (str "val" ++ spc () ++ pp_global r ++ str " :" ++ spc () ++ + pp_type false [] t) + | Stype (r,vl,ot) -> + if is_inline_custom r then failwith "empty phrase" + else + let l = rename_tvars keywords vl in + let ids, def = + try + let ids, s = find_type_custom r in + pp_string_parameters ids, str "= " ++ str s + with not_found -> + let ids = pp_parameters l in + match ot with + | None -> ids, mt () + | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)" + | Some t -> ids, str "=" ++ spc () ++ pp_type false l t + in + hov 2 (str "type" ++ spc () ++ ids ++ pp_global r ++ spc () ++ def) + +let rec pp_specif mpl = function + | (_,Spec s) -> pp_spec mpl s + | (l,Smodule mt) -> + hov 1 + (str "module " ++ + P.pp_module mpl (MPdot (List.hd mpl, l)) ++ + str " : " ++ fnl () ++ pp_module_type mpl None (* (Some l) *) mt) + | (l,Smodtype mt) -> + hov 1 + (str "module type " ++ + P.pp_module mpl (MPdot (List.hd mpl, l)) ++ + str " = " ++ fnl () ++ pp_module_type mpl None mt) + +and pp_module_type mpl ol = function + | MTident kn -> + let mp,_,l = repr_kn kn in P.pp_module mpl (MPdot (mp,l)) + | MTfunsig (mbid, mt, mt') -> + str "functor (" ++ + P.pp_module mpl (MPbound mbid) ++ + str ":" ++ + pp_module_type mpl None mt ++ + str ") ->" ++ fnl () ++ + pp_module_type mpl None mt' + | MTsig (msid, sign) -> + let mpl = match ol, mpl with + | None, _ -> (MPself msid) :: mpl + | Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl + | _ -> assert false + in + let l = map_succeed (pp_specif mpl) sign in + str "sig " ++ fnl () ++ + v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + fnl () ++ str "end" + +let is_short = function MEident _ | MEapply _ -> true | _ -> false + +let rec pp_structure_elem mpl = function + | (_,SEdecl d) -> pp_decl mpl d + | (l,SEmodule m) -> + hov 1 + (str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ + (* if you want signatures everywhere: *) + (*i str " :" ++ fnl () ++ i*) + (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*) + str " = " ++ + (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ + pp_module_expr mpl (Some l) m.ml_mod_expr) + | (l,SEmodtype m) -> + hov 1 + (str "module type " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++ + str " = " ++ fnl () ++ pp_module_type mpl None m) + +and pp_module_expr mpl ol = function + | MEident mp' -> P.pp_module mpl mp' + | MEfunctor (mbid, mt, me) -> + str "functor (" ++ + P.pp_module mpl (MPbound mbid) ++ + str ":" ++ + pp_module_type mpl None mt ++ + str ") ->" ++ fnl () ++ + pp_module_expr mpl None me + | MEapply (me, me') -> + pp_module_expr mpl None me ++ str "(" ++ + pp_module_expr mpl None me' ++ str ")" + | MEstruct (msid, sel) -> + let mpl = match ol, mpl with + | None, _ -> (MPself msid) :: mpl + | Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl + | _ -> assert false + in + let l = map_succeed (pp_structure_elem mpl) sel in + str "struct " ++ fnl () ++ + v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++ + fnl () ++ str "end" + +let pp_struct s = + let pp mp s = pp_structure_elem [mp] s ++ fnl2 () in + prlist (fun (mp,sel) -> prlist identity (map_succeed (pp mp) sel)) s + +let pp_signature s = + let pp mp s = pp_specif [mp] s ++ fnl2 () in + prlist (fun (mp,sign) -> prlist identity (map_succeed (pp mp) sign)) s + +let pp_decl mpl d = + try pp_decl mpl d with Failure "empty phrase" -> mt () + +end + + + diff --git a/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli new file mode 100644 index 00000000..711c15da --- /dev/null +++ b/contrib/extraction/ocaml.mli @@ -0,0 +1,56 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: ocaml.mli,v 1.26.6.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +(*s Some utility functions to be reused in module [Haskell]. *) + +open Pp +open Names +open Libnames +open Miniml + +val cons_cofix : Refset.t ref + +val pp_par : bool -> std_ppcmds -> std_ppcmds +val pp_abst : identifier list -> std_ppcmds +val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds +val pr_binding : identifier list -> std_ppcmds + +val rename_id : identifier -> Idset.t -> identifier + +val lowercase_id : identifier -> identifier +val uppercase_id : identifier -> identifier + +val pr_upper_id : identifier -> std_ppcmds + +type env = identifier list * Idset.t + +val rename_vars: Idset.t -> identifier list -> env +val rename_tvars: Idset.t -> identifier list -> identifier list +val push_vars : identifier list -> env -> identifier list * env +val get_db_name : int -> env -> identifier + +val keywords : Idset.t + +val preamble : + extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds + +val preamble_sig : + extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds + +(*s Production of Ocaml syntax. We export both a functor to be used for + extraction in the Coq toplevel and a function to extract some + declarations to a file. *) + +module Make : functor(P : Mlpp_param) -> Mlpp + + + + + diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml new file mode 100644 index 00000000..61045304 --- /dev/null +++ b/contrib/extraction/scheme.ml @@ -0,0 +1,175 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: scheme.ml,v 1.9.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +(*s Production of Scheme syntax. *) + +open Pp +open Util +open Names +open Nameops +open Libnames +open Miniml +open Mlutil +open Table +open Ocaml + +(*s Scheme renaming issues. *) + +let keywords = + List.fold_right (fun s -> Idset.add (id_of_string s)) + [ "define"; "let"; "lambda"; "lambdas"; "match-case"; + "apply"; "car"; "cdr"; + "error"; "delay"; "force"; "_"; "__"] + Idset.empty + +let preamble _ _ (mldummy,_,_) = + (if mldummy then + str "(define __ (lambda (_) __))" + ++ fnl () ++ fnl() + else mt ()) + +let paren = pp_par true + +let pp_abst st = function + | [] -> assert false + | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st) + | l -> paren + (str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st) + +(*s The pretty-printing functor. *) + +module Make = functor(P : Mlpp_param) -> struct + +let pp_global r = P.pp_global [initial_path] r +let empty_env () = [], P.globals() + +(*s Pretty-printing of expressions. *) + +let rec pp_expr env args = + let apply st = pp_apply st true args in + function + | MLrel n -> + let id = get_db_name n env in apply (pr_id id) + | MLapp (f,args') -> + let stl = List.map (pp_expr env []) args' in + pp_expr env (stl @ args) f + | MLlam _ as a -> + let fl,a' = collect_lams a in + let fl,env' = push_vars fl env in + pp_abst (pp_expr env' [] a') (List.rev fl) + | MLletin (id,a1,a2) -> + let i,env' = push_vars [id] env in + apply + (hv 0 + (hov 2 + (paren + (str "let " ++ + paren + (paren + (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1)) + ++ spc () ++ hov 0 (pp_expr env' [] a2))))) + | MLglob r -> + apply (pp_global r) + | MLcons (r,args') -> + assert (args=[]); + let st = + str "`" ++ + paren (pp_global r ++ + (if args' = [] then mt () else (spc () ++ str ",")) ++ + prlist_with_sep + (fun () -> spc () ++ str ",") + (pp_expr env []) args') + in + if Refset.mem r !cons_cofix then + paren (str "delay " ++ st) + else st + | MLcase (t, pv) -> + let r,_,_ = pv.(0) in + let e = if Refset.mem r !cons_cofix then + paren (str "force" ++ spc () ++ pp_expr env [] t) + else + pp_expr env [] t + in apply (v 3 (paren + (str "match-case " ++ e ++ fnl () ++ pp_pat env pv))) + | MLfix (i,ids,defs) -> + let ids',env' = push_vars (List.rev (Array.to_list ids)) env in + pp_fix env' i (Array.of_list (List.rev ids'),defs) args + | MLexn s -> + (* An [MLexn] may be applied, but I don't really care. *) + paren (str "absurd") + | MLdummy -> + str "__" (* An [MLdummy] may be applied, but I don't really care. *) + | MLmagic a -> + pp_expr env args a + | MLaxiom -> paren (str "absurd ;;AXIOM TO BE REALIZED\n") + + +and pp_one_pat env (r,ids,t) = + let pp_arg id = str "?" ++ pr_id id in + let ids,env' = push_vars (List.rev ids) env in + let args = + if ids = [] then mt () + else (str " " ++ prlist_with_sep spc pp_arg (List.rev ids)) + in + (pp_global r ++ args), (pp_expr env' [] t) + +and pp_pat env pv = + prvect_with_sep fnl + (fun x -> let s1,s2 = pp_one_pat env x in + hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv + +(*s names of the functions ([ids]) are already pushed in [env], + and passed here just for convenience. *) + +and pp_fix env j (ids,bl) args = + paren + (str "letrec " ++ + (v 0 (paren + (prvect_with_sep fnl + (fun (fi,ti) -> paren ((pr_id fi) ++ (pp_expr env [] ti))) + (array_map2 (fun id b -> (id,b)) ids bl)) ++ + fnl () ++ + hov 2 (pp_apply (pr_id (ids.(j))) true args)))) + +(*s Pretty-printing of a declaration. *) + +let pp_decl _ = function + | Dind _ -> mt () + | Dtype _ -> mt () + | Dfix (rv, defs,_) -> + let ppv = Array.map pp_global rv in + prvect_with_sep fnl + (fun (pi,ti) -> + hov 2 + (paren (str "define " ++ pi ++ spc () ++ + (pp_expr (empty_env ()) [] ti)) + ++ fnl ())) + (array_map2 (fun p b -> (p,b)) ppv defs) ++ + fnl () + | Dterm (r, a, _) -> + if is_inline_custom r then mt () + else + hov 2 (paren (str "define " ++ pp_global r ++ spc () ++ + pp_expr (empty_env ()) [] a)) ++ fnl () ++ fnl () + +let pp_structure_elem mp = function + | (l,SEdecl d) -> pp_decl mp d + | (l,SEmodule m) -> + failwith "TODO: Scheme extraction of modules not implemented yet" + | (l,SEmodtype m) -> + failwith "TODO: Scheme extraction of modules not implemented yet" + +let pp_struct = + prlist (fun (mp,sel) -> prlist (pp_structure_elem mp) sel) + +let pp_signature s = assert false + +end + diff --git a/contrib/extraction/scheme.mli b/contrib/extraction/scheme.mli new file mode 100644 index 00000000..6e689a47 --- /dev/null +++ b/contrib/extraction/scheme.mli @@ -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 *) +(************************************************************************) + +(*i $Id: scheme.mli,v 1.6.6.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +(*s Some utility functions to be reused in module [Haskell]. *) + +open Pp +open Miniml +open Names + +val keywords : Idset.t + +val preamble : + extraction_params -> module_path list -> bool * bool * bool -> std_ppcmds + +module Make : functor(P : Mlpp_param) -> Mlpp + + + + + diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml new file mode 100644 index 00000000..a65c51a4 --- /dev/null +++ b/contrib/extraction/table.ml @@ -0,0 +1,446 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: table.ml,v 1.35.2.1 2004/07/16 19:30:08 herbelin Exp $ i*) + +open Names +open Term +open Declarations +open Nameops +open Summary +open Libobject +open Goptions +open Libnames +open Util +open Pp +open Miniml + +(*S Utilities concerning [module_path] and [kernel_names] *) + +let kn_of_r r = match r with + | ConstRef kn -> kn + | IndRef (kn,_) -> kn + | ConstructRef ((kn,_),_) -> kn + | VarRef _ -> assert false + +let current_toplevel () = fst (Lib.current_prefix ()) + +let rec base_mp = function + | MPdot (mp,l) -> base_mp mp + | mp -> mp + +let is_modfile = function + | MPfile _ -> true + | _ -> false + +let is_toplevel mp = + mp = initial_path || mp = current_toplevel () + +let at_toplevel mp = + is_modfile mp || is_toplevel mp + +let visible_kn kn = at_toplevel (base_mp (modpath kn)) + + +(*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 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 + +(*s Inductives table. *) + +let inductives = ref (KNmap.empty : ml_ind KNmap.t) +let init_inductives () = inductives := KNmap.empty +let add_ind kn m = inductives := KNmap.add kn m !inductives +let lookup_ind kn = KNmap.find kn !inductives + +(*s Recursors table. *) + +let recursors = ref KNset.empty +let init_recursors () = recursors := KNset.empty + +let add_recursors env kn = + let make_kn id = make_kn (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)) + mib.mind_packets + +let is_recursor = function + | ConstRef kn -> KNset.mem kn !recursors + | _ -> false + +(*s Record tables. *) + +let records = ref (KNmap.empty : global_reference list KNmap.t) +let init_records () = records := KNmap.empty + +let projs = ref (Refmap.empty : int Refmap.t) +let init_projs () = projs := Refmap.empty + +let add_record kn n (l1,l2) = + records := KNmap.add kn l1 !records; + projs := List.fold_right (fun r -> Refmap.add r n) l2 !projs + +let find_projections kn = KNmap.find kn !records +let is_projection r = Refmap.mem r !projs +let projection_arity r = Refmap.find r !projs + +(*s Tables synchronization. *) + +let reset_tables () = + init_terms (); init_types (); init_inductives (); init_recursors (); + init_records (); init_projs () + +(*s Printing. *) + +(* The following functions work even on objects not in [Global.env ()]. + WARNING: for inductive objects, an extract_inductive must have been + done before. *) + +let id_of_global = function + | ConstRef kn -> let _,_,l = repr_kn 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 + +let pr_global r = pr_id (id_of_global r) + +(*S Warning and Error messages. *) + +let err s = errorlabstrm "Extraction" s + +let error_axiom_scheme r i = + err (str "The type scheme axiom " ++ spc () ++ + pr_global r ++ spc () ++ str "needs " ++ pr_int i ++ + str " type variable(s).") + +let warning_info_ax r = + Options.if_verbose msg_warning + (str "You must realize axiom " ++ + pr_global r ++ str " in the extracted code.") + +let warning_log_ax r = + Options.if_verbose msg_warning + (str "This extraction depends on logical axiom" ++ spc () ++ + pr_global r ++ str "." ++ spc() ++ + str "Having false logical axiom in the environment when extracting" ++ + spc () ++ str "may lead to incorrect or non-terminating ML terms.") + +let check_inside_module () = + try + ignore (Lib.what_is_opened ()); + Options.if_verbose warning + ("Extraction inside an opened module is experimental.\n"^ + "In case of problem, close it first.\n"); + Pp.flush_all () + with Not_found -> () + +let check_inside_section () = + if Lib.sections_are_opened () then + err (str "You can't do that within a section." ++ fnl () ++ + str "Close it and try again.") + +let error_constant r = + err (Printer.pr_global r ++ str " is not a constant.") + +let error_inductive r = + err (Printer.pr_global r ++ spc () ++ str "is not an inductive type.") + +let error_nb_cons () = + err (str "Not the right number of constructors.") + +let error_module_clash s = + err (str ("There are two Coq modules with ML name " ^ s ^".\n") ++ + str "This is not allowed in ML. Please do some renaming first.") + +let error_unknown_module m = + err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.") + +let error_toplevel () = + err (str "Toplevel pseudo-ML language can be used only at Coq toplevel.\n" ++ + str "You should use Extraction Language Ocaml or Haskell before.") + +let error_scheme () = + err (str "No Scheme modular extraction available yet.") + +let error_not_visible r = + err (Printer.pr_global r ++ str " is not directly visible.\n" ++ + str "For example, it may be inside an applied functor." ++ + str "Use Recursive Extraction to get the whole environment.") + +let error_unqualified_name s1 s2 = + err (str (s1 ^ " is used in " ^ s2 ^ " where it cannot be disambiguated\n" ^ + "in ML from another name sharing the same basename.\n" ^ + "Please do some renaming.\n")) + +let error_MPfile_as_mod d = + err (str ("The whole file "^(string_of_dirpath d)^".v is used somewhere as a module.\n"^ + "Extraction cannot currently deal with this situation.\n")) + +(*S The Extraction auxiliary commands *) + +(*s Extraction AutoInline *) + +let auto_inline_ref = ref true + +let auto_inline () = !auto_inline_ref + +let _ = declare_bool_option + {optsync = true; + optname = "Extraction AutoInline"; + optkey = SecondaryTable ("Extraction", "AutoInline"); + optread = auto_inline; + optwrite = (:=) auto_inline_ref} + + +(*s Extraction Optimize *) + +type opt_flag = + { opt_kill_dum : bool; (* 1 *) + opt_fix_fun : bool; (* 2 *) + opt_case_iot : bool; (* 4 *) + opt_case_idr : bool; (* 8 *) + opt_case_idg : bool; (* 16 *) + opt_case_cst : bool; (* 32 *) + opt_case_fun : bool; (* 64 *) + opt_case_app : bool; (* 128 *) + opt_let_app : bool; (* 256 *) + opt_lin_let : bool; (* 512 *) + opt_lin_beta : bool } (* 1024 *) + +let kth_digit n k = (n land (1 lsl k) <> 0) + +let flag_of_int n = + { opt_kill_dum = kth_digit n 0; + opt_fix_fun = kth_digit n 1; + opt_case_iot = kth_digit n 2; + opt_case_idr = kth_digit n 3; + opt_case_idg = kth_digit n 4; + opt_case_cst = kth_digit n 5; + opt_case_fun = kth_digit n 6; + opt_case_app = kth_digit n 7; + opt_let_app = kth_digit n 8; + opt_lin_let = kth_digit n 9; + opt_lin_beta = kth_digit n 10 } + +(* For the moment, we allow by default everything except the type-unsafe + optimization [opt_case_idg]. *) + +let int_flag_init = 1 + 2 + 4 + 8 + 32 + 64 + 128 + 256 + 512 + 1024 + +let int_flag_ref = ref int_flag_init +let opt_flag_ref = ref (flag_of_int int_flag_init) + +let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n + +let optims () = !opt_flag_ref + +let _ = declare_bool_option + {optsync = true; + optname = "Extraction Optimize"; + optkey = SecondaryTable ("Extraction", "Optimize"); + optread = (fun () -> !int_flag_ref <> 0); + optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} + +let _ = declare_int_option + { optsync = true; + optname = "Extraction Flag"; + optkey = SecondaryTable("Extraction","Flag"); + optread = (fun _ -> Some !int_flag_ref); + optwrite = (function + | None -> chg_flag 0 + | Some i -> chg_flag (max i 0))} + + +(*s Extraction Lang *) + +type lang = Ocaml | Haskell | Scheme | Toplevel + +let lang_ref = ref Ocaml + +let lang () = !lang_ref + +let (extr_lang,_) = + declare_object + {(default_object "Extraction Lang") with + cache_function = (fun (_,l) -> lang_ref := l); + load_function = (fun _ (_,l) -> lang_ref := l); + export_function = (fun x -> Some x)} + +let _ = declare_summary "Extraction Lang" + { freeze_function = (fun () -> !lang_ref); + unfreeze_function = ((:=) lang_ref); + init_function = (fun () -> lang_ref := Ocaml); + survive_module = false; + survive_section = true } + +let extraction_language x = Lib.add_anonymous_leaf (extr_lang x) + + +(*s Extraction Inline/NoInline *) + +let empty_inline_table = (Refset.empty,Refset.empty) + +let inline_table = ref empty_inline_table + +let to_inline r = Refset.mem r (fst !inline_table) + +let to_keep r = Refset.mem r (snd !inline_table) + +let add_inline_entries b l = + let f b = if b then Refset.add else Refset.remove in + let i,k = !inline_table in + inline_table := + (List.fold_right (f b) l i), + (List.fold_right (f (not b)) l k) + +(* Registration of operations for rollback. *) + +let (inline_extraction,_) = + declare_object + {(default_object "Extraction Inline") with + cache_function = (fun (_,(b,l)) -> add_inline_entries b l); + load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); + export_function = (fun x -> Some x); + classify_function = (fun (_,o) -> Substitute o); + subst_function = (fun (_,s,(b,l)) -> (b,(List.map (subst_global s) l))) } + +let _ = declare_summary "Extraction Inline" + { freeze_function = (fun () -> !inline_table); + unfreeze_function = ((:=) inline_table); + init_function = (fun () -> inline_table := empty_inline_table); + survive_module = false; + survive_section = true } + +(* Grammar entries. *) + +let extraction_inline b l = + check_inside_section (); + check_inside_module (); + let refs = List.map Nametab.global l in + List.iter + (fun r -> match r with + | ConstRef _ -> () + | _ -> error_constant r) refs; + Lib.add_anonymous_leaf (inline_extraction (b,refs)) + +(* Printing part *) + +let print_extraction_inline () = + let (i,n)= !inline_table in + let i'= Refset.filter (function ConstRef _ -> true | _ -> false) i in + msg + (str "Extraction Inline:" ++ fnl () ++ + Refset.fold + (fun r p -> + (p ++ str " " ++ Printer.pr_global r ++ fnl ())) i' (mt ()) ++ + str "Extraction NoInline:" ++ fnl () ++ + Refset.fold + (fun r p -> + (p ++ str " " ++ Printer.pr_global r ++ fnl ())) n (mt ())) + +(* Reset part *) + +let (reset_inline,_) = + declare_object + {(default_object "Reset Extraction Inline") with + cache_function = (fun (_,_)-> inline_table := empty_inline_table); + load_function = (fun _ (_,_)-> inline_table := empty_inline_table); + export_function = (fun x -> Some x)} + +let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ()) + + +(*s Extract Constant/Inductive. *) + +(* UGLY HACK: to be defined in [extraction.ml] *) +let use_type_scheme_nb_args, register_type_scheme_nb_args = + let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r + +let customs = ref Refmap.empty + +let add_custom r ids s = customs := Refmap.add r (ids,s) !customs + +let is_custom r = Refmap.mem r !customs + +let is_inline_custom r = (is_custom r) && (to_inline r) + +let find_custom r = snd (Refmap.find r !customs) + +let find_type_custom r = Refmap.find r !customs + +(* Registration of operations for rollback. *) + +let (in_customs,_) = + declare_object + {(default_object "ML extractions") with + cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); + load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s); + export_function = (fun x -> Some x)} + +let _ = declare_summary "ML extractions" + { freeze_function = (fun () -> !customs); + unfreeze_function = ((:=) customs); + init_function = (fun () -> customs := Refmap.empty); + survive_module = false; + survive_section = true } + +(* Grammar entries. *) + +let extract_constant_inline inline r ids s = + check_inside_section (); + check_inside_module (); + let g = Nametab.global r in + match g with + | ConstRef kn -> + let env = Global.env () in + let typ = Environ.constant_type env kn in + let typ = Reduction.whd_betadeltaiota env typ in + if Reduction.is_arity env typ + then begin + let nargs = use_type_scheme_nb_args env typ in + if List.length ids <> nargs then error_axiom_scheme g nargs + end; + Lib.add_anonymous_leaf (inline_extraction (inline,[g])); + Lib.add_anonymous_leaf (in_customs (g,ids,s)) + | _ -> error_constant g + + +let extract_inductive r (s,l) = + check_inside_section (); + check_inside_module (); + let g = Nametab.global r in + match g with + | IndRef ((kn,i) as ip) -> + let mib = Global.lookup_mind kn in + let n = Array.length mib.mind_packets.(i).mind_consnames in + if n <> List.length l then error_nb_cons (); + Lib.add_anonymous_leaf (inline_extraction (true,[g])); + Lib.add_anonymous_leaf (in_customs (g,[],s)); + list_iter_i + (fun j s -> + let g = ConstructRef (ip,succ j) in + Lib.add_anonymous_leaf (inline_extraction (true,[g])); + Lib.add_anonymous_leaf (in_customs (g,[],s))) l + | _ -> error_inductive g + + diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli new file mode 100644 index 00000000..680638e5 --- /dev/null +++ b/contrib/extraction/table.mli @@ -0,0 +1,122 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: table.mli,v 1.25.2.1 2004/07/16 19:30:09 herbelin Exp $ i*) + +open Names +open Libnames +open Miniml + +val id_of_global : global_reference -> identifier + +(*s Warning and Error messages. *) + +val error_axiom_scheme : global_reference -> int -> 'a +val warning_info_ax : global_reference -> unit +val warning_log_ax : global_reference -> unit +val error_constant : global_reference -> 'a +val error_inductive : global_reference -> 'a +val error_nb_cons : unit -> 'a +val error_module_clash : string -> 'a +val error_unknown_module : qualid -> 'a +val error_toplevel : unit -> 'a +val error_scheme : unit -> 'a +val error_not_visible : global_reference -> 'a +val error_unqualified_name : string -> string -> 'a +val error_MPfile_as_mod : dir_path -> 'a + +val check_inside_module : unit -> unit +val check_inside_section : unit -> unit + +(*s utilities concerning [module_path]. *) + +val kn_of_r : global_reference -> kernel_name + +val current_toplevel : unit -> module_path +val base_mp : module_path -> module_path +val is_modfile : module_path -> bool +val is_toplevel : module_path -> bool +val at_toplevel : module_path -> bool +val visible_kn : kernel_name -> bool + +(*s Some table-related operations *) + +val add_term : kernel_name -> ml_decl -> unit +val lookup_term : kernel_name -> ml_decl + +val add_type : kernel_name -> ml_schema -> unit +val lookup_type : kernel_name -> ml_schema + +val add_ind : kernel_name -> ml_ind -> unit +val lookup_ind : kernel_name -> ml_ind + +val add_recursors : Environ.env -> kernel_name -> unit +val is_recursor : global_reference -> bool + +val add_record : + kernel_name -> int -> global_reference list * global_reference list -> unit +val find_projections : kernel_name -> global_reference list +val is_projection : global_reference -> bool +val projection_arity : global_reference -> int + +val reset_tables : unit -> unit + +(*s AutoInline parameter *) + +val auto_inline : unit -> bool + +(*s Optimize parameter *) + +type opt_flag = + { opt_kill_dum : bool; (* 1 *) + opt_fix_fun : bool; (* 2 *) + opt_case_iot : bool; (* 4 *) + opt_case_idr : bool; (* 8 *) + opt_case_idg : bool; (* 16 *) + opt_case_cst : bool; (* 32 *) + opt_case_fun : bool; (* 64 *) + opt_case_app : bool; (* 128 *) + opt_let_app : bool; (* 256 *) + opt_lin_let : bool; (* 512 *) + opt_lin_beta : bool } (* 1024 *) + +val optims : unit -> opt_flag + +(*s Target language. *) + +type lang = Ocaml | Haskell | Scheme | Toplevel +val lang : unit -> lang + +(*s Table for custom inlining *) + +val to_inline : global_reference -> bool +val to_keep : global_reference -> bool + +(*s Table for user-given custom ML extractions. *) + +(* UGLY HACK: registration of a function defined in [extraction.ml] *) +val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit + +val is_custom : global_reference -> bool +val is_inline_custom : global_reference -> bool +val find_custom : global_reference -> string +val find_type_custom : global_reference -> string list * string + +(*s Extraction commands. *) + +val extraction_language : lang -> unit +val extraction_inline : bool -> reference list -> unit +val print_extraction_inline : unit -> unit +val reset_extraction_inline : unit -> unit +val extract_constant_inline : + bool -> reference -> string list -> string -> unit +val extract_inductive : reference -> string * string list -> unit + + + + diff --git a/contrib/extraction/test/.depend b/contrib/extraction/test/.depend new file mode 100644 index 00000000..641b50a7 --- /dev/null +++ b/contrib/extraction/test/.depend @@ -0,0 +1,713 @@ +theories/Arith/arith.cmo: theories/Arith/arith.cmi +theories/Arith/arith.cmx: theories/Arith/arith.cmi +theories/Arith/between.cmo: theories/Arith/between.cmi +theories/Arith/between.cmx: theories/Arith/between.cmi +theories/Arith/bool_nat.cmo: theories/Arith/compare_dec.cmi \ + theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi \ + theories/Arith/bool_nat.cmi +theories/Arith/bool_nat.cmx: theories/Arith/compare_dec.cmx \ + theories/Init/datatypes.cmx theories/Arith/peano_dec.cmx \ + theories/Init/specif.cmx theories/Bool/sumbool.cmx \ + theories/Arith/bool_nat.cmi +theories/Arith/compare_dec.cmo: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/Arith/compare_dec.cmi +theories/Arith/compare_dec.cmx: theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/Arith/compare_dec.cmi +theories/Arith/compare.cmo: theories/Arith/compare_dec.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Arith/compare.cmi +theories/Arith/compare.cmx: theories/Arith/compare_dec.cmx \ + theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Arith/compare.cmi +theories/Arith/div2.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi \ + theories/Init/specif.cmi theories/Arith/div2.cmi +theories/Arith/div2.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmx \ + theories/Init/specif.cmx theories/Arith/div2.cmi +theories/Arith/eqNat.cmo: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/Arith/eqNat.cmi +theories/Arith/eqNat.cmx: theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/Arith/eqNat.cmi +theories/Arith/euclid.cmo: theories/Arith/compare_dec.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Arith/euclid.cmi +theories/Arith/euclid.cmx: theories/Arith/compare_dec.cmx \ + theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Arith/euclid.cmi +theories/Arith/even.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Arith/even.cmi +theories/Arith/even.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Arith/even.cmi +theories/Arith/factorial.cmo: theories/Init/datatypes.cmi \ + theories/Init/peano.cmi theories/Arith/factorial.cmi +theories/Arith/factorial.cmx: theories/Init/datatypes.cmx \ + theories/Init/peano.cmx theories/Arith/factorial.cmi +theories/Arith/gt.cmo: theories/Arith/gt.cmi +theories/Arith/gt.cmx: theories/Arith/gt.cmi +theories/Arith/le.cmo: theories/Arith/le.cmi +theories/Arith/le.cmx: theories/Arith/le.cmi +theories/Arith/lt.cmo: theories/Arith/lt.cmi +theories/Arith/lt.cmx: theories/Arith/lt.cmi +theories/Arith/max.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Arith/max.cmi +theories/Arith/max.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Arith/max.cmi +theories/Arith/min.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Arith/min.cmi +theories/Arith/min.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Arith/min.cmi +theories/Arith/minus.cmo: theories/Arith/minus.cmi +theories/Arith/minus.cmx: theories/Arith/minus.cmi +theories/Arith/mult.cmo: theories/Init/datatypes.cmi theories/Arith/plus.cmi \ + theories/Arith/mult.cmi +theories/Arith/mult.cmx: theories/Init/datatypes.cmx theories/Arith/plus.cmx \ + theories/Arith/mult.cmi +theories/Arith/peano_dec.cmo: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/Arith/peano_dec.cmi +theories/Arith/peano_dec.cmx: theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/Arith/peano_dec.cmi +theories/Arith/plus.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Arith/plus.cmi +theories/Arith/plus.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Arith/plus.cmi +theories/Arith/wf_nat.cmo: theories/Init/datatypes.cmi \ + theories/Arith/wf_nat.cmi +theories/Arith/wf_nat.cmx: theories/Init/datatypes.cmx \ + theories/Arith/wf_nat.cmi +theories/Bool/boolEq.cmo: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/Bool/boolEq.cmi +theories/Bool/boolEq.cmx: theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/Bool/boolEq.cmi +theories/Bool/bool.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Bool/bool.cmi +theories/Bool/bool.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Bool/bool.cmi +theories/Bool/bvector.cmo: theories/Bool/bool.cmi theories/Init/datatypes.cmi \ + theories/Init/peano.cmi theories/Bool/bvector.cmi +theories/Bool/bvector.cmx: theories/Bool/bool.cmx theories/Init/datatypes.cmx \ + theories/Init/peano.cmx theories/Bool/bvector.cmi +theories/Bool/decBool.cmo: theories/Init/specif.cmi theories/Bool/decBool.cmi +theories/Bool/decBool.cmx: theories/Init/specif.cmx theories/Bool/decBool.cmi +theories/Bool/ifProp.cmo: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/Bool/ifProp.cmi +theories/Bool/ifProp.cmx: theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/Bool/ifProp.cmi +theories/Bool/sumbool.cmo: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi +theories/Bool/sumbool.cmx: theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/Bool/sumbool.cmi +theories/Bool/zerob.cmo: theories/Init/datatypes.cmi theories/Bool/zerob.cmi +theories/Bool/zerob.cmx: theories/Init/datatypes.cmx theories/Bool/zerob.cmi +theories/Init/datatypes.cmo: theories/Init/datatypes.cmi +theories/Init/datatypes.cmx: theories/Init/datatypes.cmi +theories/Init/logic.cmo: theories/Init/logic.cmi +theories/Init/logic.cmx: theories/Init/logic.cmi +theories/Init/logic_Type.cmo: theories/Init/datatypes.cmi \ + theories/Init/logic_Type.cmi +theories/Init/logic_Type.cmx: theories/Init/datatypes.cmx \ + theories/Init/logic_Type.cmi +theories/Init/notations.cmo: theories/Init/notations.cmi +theories/Init/notations.cmx: theories/Init/notations.cmi +theories/Init/peano.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi +theories/Init/peano.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmi +theories/Init/prelude.cmo: theories/Init/prelude.cmi +theories/Init/prelude.cmx: theories/Init/prelude.cmi +theories/Init/specif.cmo: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi +theories/Init/specif.cmx: theories/Init/datatypes.cmx \ + theories/Init/specif.cmi +theories/Init/wf.cmo: theories/Init/wf.cmi +theories/Init/wf.cmx: theories/Init/wf.cmi +theories/IntMap/adalloc.cmo: theories/IntMap/addec.cmi \ + theories/IntMap/addr.cmi theories/NArith/binPos.cmi \ + theories/Init/datatypes.cmi theories/IntMap/map.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi \ + theories/IntMap/adalloc.cmi +theories/IntMap/adalloc.cmx: theories/IntMap/addec.cmx \ + theories/IntMap/addr.cmx theories/NArith/binPos.cmx \ + theories/Init/datatypes.cmx theories/IntMap/map.cmx \ + theories/Init/specif.cmx theories/Bool/sumbool.cmx \ + theories/IntMap/adalloc.cmi +theories/IntMap/addec.cmo: theories/IntMap/addr.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi \ + theories/IntMap/addec.cmi +theories/IntMap/addec.cmx: theories/IntMap/addr.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/Bool/sumbool.cmx \ + theories/IntMap/addec.cmi +theories/IntMap/addr.cmo: theories/NArith/binPos.cmi theories/Bool/bool.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/IntMap/addr.cmi +theories/IntMap/addr.cmx: theories/NArith/binPos.cmx theories/Bool/bool.cmx \ + theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/IntMap/addr.cmi +theories/IntMap/adist.cmo: theories/IntMap/addr.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/IntMap/adist.cmi +theories/IntMap/adist.cmx: theories/IntMap/addr.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/IntMap/adist.cmi +theories/IntMap/allmaps.cmo: theories/IntMap/allmaps.cmi +theories/IntMap/allmaps.cmx: theories/IntMap/allmaps.cmi +theories/IntMap/fset.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ + theories/Init/datatypes.cmi theories/IntMap/map.cmi \ + theories/Init/specif.cmi theories/IntMap/fset.cmi +theories/IntMap/fset.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \ + theories/Init/datatypes.cmx theories/IntMap/map.cmx \ + theories/Init/specif.cmx theories/IntMap/fset.cmi +theories/IntMap/lsort.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ + theories/NArith/binPos.cmi theories/Bool/bool.cmi \ + theories/Init/datatypes.cmi theories/Lists/list.cmi \ + theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi \ + theories/IntMap/lsort.cmi +theories/IntMap/lsort.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \ + theories/NArith/binPos.cmx theories/Bool/bool.cmx \ + theories/Init/datatypes.cmx theories/Lists/list.cmx \ + theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \ + theories/Init/specif.cmx theories/Bool/sumbool.cmx \ + theories/IntMap/lsort.cmi +theories/IntMap/mapaxioms.cmo: theories/IntMap/mapaxioms.cmi +theories/IntMap/mapaxioms.cmx: theories/IntMap/mapaxioms.cmi +theories/IntMap/mapcanon.cmo: theories/IntMap/map.cmi \ + theories/Init/specif.cmi theories/IntMap/mapcanon.cmi +theories/IntMap/mapcanon.cmx: theories/IntMap/map.cmx \ + theories/Init/specif.cmx theories/IntMap/mapcanon.cmi +theories/IntMap/mapcard.cmo: theories/IntMap/addec.cmi \ + theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ + theories/IntMap/map.cmi theories/Init/peano.cmi \ + theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi \ + theories/IntMap/mapcard.cmi +theories/IntMap/mapcard.cmx: theories/IntMap/addec.cmx \ + theories/IntMap/addr.cmx theories/Init/datatypes.cmx \ + theories/IntMap/map.cmx theories/Init/peano.cmx \ + theories/Arith/peano_dec.cmx theories/Arith/plus.cmx \ + theories/Init/specif.cmx theories/Bool/sumbool.cmx \ + theories/IntMap/mapcard.cmi +theories/IntMap/mapc.cmo: theories/IntMap/mapc.cmi +theories/IntMap/mapc.cmx: theories/IntMap/mapc.cmi +theories/IntMap/mapfold.cmo: theories/IntMap/addr.cmi \ + theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ + theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ + theories/Init/specif.cmi theories/IntMap/mapfold.cmi +theories/IntMap/mapfold.cmx: theories/IntMap/addr.cmx \ + theories/Init/datatypes.cmx theories/IntMap/fset.cmx \ + theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \ + theories/Init/specif.cmx theories/IntMap/mapfold.cmi +theories/IntMap/mapiter.cmo: theories/IntMap/addec.cmi \ + theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi theories/IntMap/mapiter.cmi +theories/IntMap/mapiter.cmx: theories/IntMap/addec.cmx \ + theories/IntMap/addr.cmx theories/Init/datatypes.cmx \ + theories/Lists/list.cmx theories/IntMap/map.cmx theories/Init/specif.cmx \ + theories/Bool/sumbool.cmx theories/IntMap/mapiter.cmi +theories/IntMap/maplists.cmo: theories/IntMap/addec.cmi \ + theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ + theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \ + theories/IntMap/mapiter.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi theories/IntMap/maplists.cmi +theories/IntMap/maplists.cmx: theories/IntMap/addec.cmx \ + theories/IntMap/addr.cmx theories/Init/datatypes.cmx \ + theories/IntMap/fset.cmx theories/Lists/list.cmx theories/IntMap/map.cmx \ + theories/IntMap/mapiter.cmx theories/Init/specif.cmx \ + theories/Bool/sumbool.cmx theories/IntMap/maplists.cmi +theories/IntMap/map.cmo: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/peano.cmi theories/Init/specif.cmi theories/IntMap/map.cmi +theories/IntMap/map.cmx: theories/IntMap/addec.cmx theories/IntMap/addr.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/Init/peano.cmx theories/Init/specif.cmx theories/IntMap/map.cmi +theories/IntMap/mapsubset.cmo: theories/Bool/bool.cmi \ + theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ + theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ + theories/IntMap/mapsubset.cmi +theories/IntMap/mapsubset.cmx: theories/Bool/bool.cmx \ + theories/Init/datatypes.cmx theories/IntMap/fset.cmx \ + theories/IntMap/map.cmx theories/IntMap/mapiter.cmx \ + theories/IntMap/mapsubset.cmi +theories/Lists/list.cmo: theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Lists/list.cmi +theories/Lists/list.cmx: theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Lists/list.cmi +theories/Lists/listSet.cmo: theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Init/specif.cmi \ + theories/Lists/listSet.cmi +theories/Lists/listSet.cmx: theories/Init/datatypes.cmx \ + theories/Lists/list.cmx theories/Init/specif.cmx \ + theories/Lists/listSet.cmi +theories/Lists/monoList.cmo: theories/Init/datatypes.cmi \ + theories/Lists/monoList.cmi +theories/Lists/monoList.cmx: theories/Init/datatypes.cmx \ + theories/Lists/monoList.cmi +theories/Lists/streams.cmo: theories/Init/datatypes.cmi \ + theories/Lists/streams.cmi +theories/Lists/streams.cmx: theories/Init/datatypes.cmx \ + theories/Lists/streams.cmi +theories/Lists/theoryList.cmo: theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Init/specif.cmi \ + theories/Lists/theoryList.cmi +theories/Lists/theoryList.cmx: theories/Init/datatypes.cmx \ + theories/Lists/list.cmx theories/Init/specif.cmx \ + theories/Lists/theoryList.cmi +theories/Logic/berardi.cmo: theories/Logic/berardi.cmi +theories/Logic/berardi.cmx: theories/Logic/berardi.cmi +theories/Logic/choiceFacts.cmo: theories/Logic/choiceFacts.cmi +theories/Logic/choiceFacts.cmx: theories/Logic/choiceFacts.cmi +theories/Logic/classicalChoice.cmo: theories/Logic/classicalChoice.cmi +theories/Logic/classicalChoice.cmx: theories/Logic/classicalChoice.cmi +theories/Logic/classicalDescription.cmo: \ + theories/Logic/classicalDescription.cmi +theories/Logic/classicalDescription.cmx: \ + theories/Logic/classicalDescription.cmi +theories/Logic/classicalFacts.cmo: theories/Logic/classicalFacts.cmi +theories/Logic/classicalFacts.cmx: theories/Logic/classicalFacts.cmi +theories/Logic/classical.cmo: theories/Logic/classical.cmi +theories/Logic/classical.cmx: theories/Logic/classical.cmi +theories/Logic/classical_Pred_Set.cmo: theories/Logic/classical_Pred_Set.cmi +theories/Logic/classical_Pred_Set.cmx: theories/Logic/classical_Pred_Set.cmi +theories/Logic/classical_Pred_Type.cmo: \ + theories/Logic/classical_Pred_Type.cmi +theories/Logic/classical_Pred_Type.cmx: \ + theories/Logic/classical_Pred_Type.cmi +theories/Logic/classical_Prop.cmo: theories/Logic/classical_Prop.cmi +theories/Logic/classical_Prop.cmx: theories/Logic/classical_Prop.cmi +theories/Logic/classical_Type.cmo: theories/Logic/classical_Type.cmi +theories/Logic/classical_Type.cmx: theories/Logic/classical_Type.cmi +theories/Logic/decidable.cmo: theories/Logic/decidable.cmi +theories/Logic/decidable.cmx: theories/Logic/decidable.cmi +theories/Logic/diaconescu.cmo: theories/Logic/diaconescu.cmi +theories/Logic/diaconescu.cmx: theories/Logic/diaconescu.cmi +theories/Logic/eqdep_dec.cmo: theories/Logic/eqdep_dec.cmi +theories/Logic/eqdep_dec.cmx: theories/Logic/eqdep_dec.cmi +theories/Logic/eqdep.cmo: theories/Logic/eqdep.cmi +theories/Logic/eqdep.cmx: theories/Logic/eqdep.cmi +theories/Logic/hurkens.cmo: theories/Logic/hurkens.cmi +theories/Logic/hurkens.cmx: theories/Logic/hurkens.cmi +theories/Logic/jMeq.cmo: theories/Logic/jMeq.cmi +theories/Logic/jMeq.cmx: theories/Logic/jMeq.cmi +theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevance.cmi +theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevance.cmi +theories/Logic/relationalChoice.cmo: theories/Logic/relationalChoice.cmi +theories/Logic/relationalChoice.cmx: theories/Logic/relationalChoice.cmi +theories/NArith/binNat.cmo: theories/NArith/binPos.cmi \ + theories/Init/datatypes.cmi theories/NArith/binNat.cmi +theories/NArith/binNat.cmx: theories/NArith/binPos.cmx \ + theories/Init/datatypes.cmx theories/NArith/binNat.cmi +theories/NArith/binPos.cmo: theories/Init/datatypes.cmi \ + theories/Init/peano.cmi theories/NArith/binPos.cmi +theories/NArith/binPos.cmx: theories/Init/datatypes.cmx \ + theories/Init/peano.cmx theories/NArith/binPos.cmi +theories/NArith/nArith.cmo: theories/NArith/nArith.cmi +theories/NArith/nArith.cmx: theories/NArith/nArith.cmi +theories/NArith/pnat.cmo: theories/NArith/pnat.cmi +theories/NArith/pnat.cmx: theories/NArith/pnat.cmi +theories/Relations/newman.cmo: theories/Relations/newman.cmi +theories/Relations/newman.cmx: theories/Relations/newman.cmi +theories/Relations/operators_Properties.cmo: \ + theories/Relations/operators_Properties.cmi +theories/Relations/operators_Properties.cmx: \ + theories/Relations/operators_Properties.cmi +theories/Relations/relation_Definitions.cmo: \ + theories/Relations/relation_Definitions.cmi +theories/Relations/relation_Definitions.cmx: \ + theories/Relations/relation_Definitions.cmi +theories/Relations/relation_Operators.cmo: theories/Lists/list.cmi \ + theories/Init/specif.cmi theories/Relations/relation_Operators.cmi +theories/Relations/relation_Operators.cmx: theories/Lists/list.cmx \ + theories/Init/specif.cmx theories/Relations/relation_Operators.cmi +theories/Relations/relations.cmo: theories/Relations/relations.cmi +theories/Relations/relations.cmx: theories/Relations/relations.cmi +theories/Relations/rstar.cmo: theories/Relations/rstar.cmi +theories/Relations/rstar.cmx: theories/Relations/rstar.cmi +theories/Setoids/setoid.cmo: theories/Setoids/setoid.cmi +theories/Setoids/setoid.cmx: theories/Setoids/setoid.cmi +theories/Sets/classical_sets.cmo: theories/Sets/classical_sets.cmi +theories/Sets/classical_sets.cmx: theories/Sets/classical_sets.cmi +theories/Sets/constructive_sets.cmo: theories/Sets/constructive_sets.cmi +theories/Sets/constructive_sets.cmx: theories/Sets/constructive_sets.cmi +theories/Sets/cpo.cmo: theories/Sets/partial_Order.cmi theories/Sets/cpo.cmi +theories/Sets/cpo.cmx: theories/Sets/partial_Order.cmx theories/Sets/cpo.cmi +theories/Sets/ensembles.cmo: theories/Sets/ensembles.cmi +theories/Sets/ensembles.cmx: theories/Sets/ensembles.cmi +theories/Sets/finite_sets_facts.cmo: theories/Sets/finite_sets_facts.cmi +theories/Sets/finite_sets_facts.cmx: theories/Sets/finite_sets_facts.cmi +theories/Sets/finite_sets.cmo: theories/Sets/finite_sets.cmi +theories/Sets/finite_sets.cmx: theories/Sets/finite_sets.cmi +theories/Sets/image.cmo: theories/Sets/image.cmi +theories/Sets/image.cmx: theories/Sets/image.cmi +theories/Sets/infinite_sets.cmo: theories/Sets/infinite_sets.cmi +theories/Sets/infinite_sets.cmx: theories/Sets/infinite_sets.cmi +theories/Sets/integers.cmo: theories/Init/datatypes.cmi \ + theories/Sets/partial_Order.cmi theories/Sets/integers.cmi +theories/Sets/integers.cmx: theories/Init/datatypes.cmx \ + theories/Sets/partial_Order.cmx theories/Sets/integers.cmi +theories/Sets/multiset.cmo: theories/Init/datatypes.cmi \ + theories/Init/peano.cmi theories/Init/specif.cmi \ + theories/Sets/multiset.cmi +theories/Sets/multiset.cmx: theories/Init/datatypes.cmx \ + theories/Init/peano.cmx theories/Init/specif.cmx \ + theories/Sets/multiset.cmi +theories/Sets/partial_Order.cmo: theories/Sets/ensembles.cmi \ + theories/Sets/relations_1.cmi theories/Sets/partial_Order.cmi +theories/Sets/partial_Order.cmx: theories/Sets/ensembles.cmx \ + theories/Sets/relations_1.cmx theories/Sets/partial_Order.cmi +theories/Sets/permut.cmo: theories/Sets/permut.cmi +theories/Sets/permut.cmx: theories/Sets/permut.cmi +theories/Sets/powerset_Classical_facts.cmo: \ + theories/Sets/powerset_Classical_facts.cmi +theories/Sets/powerset_Classical_facts.cmx: \ + theories/Sets/powerset_Classical_facts.cmi +theories/Sets/powerset_facts.cmo: theories/Sets/powerset_facts.cmi +theories/Sets/powerset_facts.cmx: theories/Sets/powerset_facts.cmi +theories/Sets/powerset.cmo: theories/Sets/ensembles.cmi \ + theories/Sets/partial_Order.cmi theories/Sets/powerset.cmi +theories/Sets/powerset.cmx: theories/Sets/ensembles.cmx \ + theories/Sets/partial_Order.cmx theories/Sets/powerset.cmi +theories/Sets/relations_1_facts.cmo: theories/Sets/relations_1_facts.cmi +theories/Sets/relations_1_facts.cmx: theories/Sets/relations_1_facts.cmi +theories/Sets/relations_1.cmo: theories/Sets/relations_1.cmi +theories/Sets/relations_1.cmx: theories/Sets/relations_1.cmi +theories/Sets/relations_2_facts.cmo: theories/Sets/relations_2_facts.cmi +theories/Sets/relations_2_facts.cmx: theories/Sets/relations_2_facts.cmi +theories/Sets/relations_2.cmo: theories/Sets/relations_2.cmi +theories/Sets/relations_2.cmx: theories/Sets/relations_2.cmi +theories/Sets/relations_3_facts.cmo: theories/Sets/relations_3_facts.cmi +theories/Sets/relations_3_facts.cmx: theories/Sets/relations_3_facts.cmi +theories/Sets/relations_3.cmo: theories/Sets/relations_3.cmi +theories/Sets/relations_3.cmx: theories/Sets/relations_3.cmi +theories/Sets/uniset.cmo: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/Sets/uniset.cmi +theories/Sets/uniset.cmx: theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/Sets/uniset.cmi +theories/Sorting/heap.cmo: theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Sets/multiset.cmi \ + theories/Init/peano.cmi theories/Sorting/sorting.cmi \ + theories/Init/specif.cmi theories/Sorting/heap.cmi +theories/Sorting/heap.cmx: theories/Init/datatypes.cmx \ + theories/Lists/list.cmx theories/Sets/multiset.cmx \ + theories/Init/peano.cmx theories/Sorting/sorting.cmx \ + theories/Init/specif.cmx theories/Sorting/heap.cmi +theories/Sorting/permutation.cmo: theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Sets/multiset.cmi \ + theories/Init/peano.cmi theories/Init/specif.cmi \ + theories/Sorting/permutation.cmi +theories/Sorting/permutation.cmx: theories/Init/datatypes.cmx \ + theories/Lists/list.cmx theories/Sets/multiset.cmx \ + theories/Init/peano.cmx theories/Init/specif.cmx \ + theories/Sorting/permutation.cmi +theories/Sorting/sorting.cmo: theories/Lists/list.cmi \ + theories/Init/specif.cmi theories/Sorting/sorting.cmi +theories/Sorting/sorting.cmx: theories/Lists/list.cmx \ + theories/Init/specif.cmx theories/Sorting/sorting.cmi +theories/Wellfounded/disjoint_Union.cmo: \ + theories/Wellfounded/disjoint_Union.cmi +theories/Wellfounded/disjoint_Union.cmx: \ + theories/Wellfounded/disjoint_Union.cmi +theories/Wellfounded/inclusion.cmo: theories/Wellfounded/inclusion.cmi +theories/Wellfounded/inclusion.cmx: theories/Wellfounded/inclusion.cmi +theories/Wellfounded/inverse_Image.cmo: \ + theories/Wellfounded/inverse_Image.cmi +theories/Wellfounded/inverse_Image.cmx: \ + theories/Wellfounded/inverse_Image.cmi +theories/Wellfounded/lexicographic_Exponentiation.cmo: \ + theories/Wellfounded/lexicographic_Exponentiation.cmi +theories/Wellfounded/lexicographic_Exponentiation.cmx: \ + theories/Wellfounded/lexicographic_Exponentiation.cmi +theories/Wellfounded/lexicographic_Product.cmo: \ + theories/Wellfounded/lexicographic_Product.cmi +theories/Wellfounded/lexicographic_Product.cmx: \ + theories/Wellfounded/lexicographic_Product.cmi +theories/Wellfounded/transitive_Closure.cmo: \ + theories/Wellfounded/transitive_Closure.cmi +theories/Wellfounded/transitive_Closure.cmx: \ + theories/Wellfounded/transitive_Closure.cmi +theories/Wellfounded/union.cmo: theories/Wellfounded/union.cmi +theories/Wellfounded/union.cmx: theories/Wellfounded/union.cmi +theories/Wellfounded/wellfounded.cmo: theories/Wellfounded/wellfounded.cmi +theories/Wellfounded/wellfounded.cmx: theories/Wellfounded/wellfounded.cmi +theories/Wellfounded/well_Ordering.cmo: theories/Init/specif.cmi \ + theories/Wellfounded/well_Ordering.cmi +theories/Wellfounded/well_Ordering.cmx: theories/Init/specif.cmx \ + theories/Wellfounded/well_Ordering.cmi +theories/ZArith/auxiliary.cmo: theories/ZArith/auxiliary.cmi +theories/ZArith/auxiliary.cmx: theories/ZArith/auxiliary.cmi +theories/ZArith/binInt.cmo: theories/NArith/binNat.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/ZArith/binInt.cmi +theories/ZArith/binInt.cmx: theories/NArith/binNat.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/ZArith/binInt.cmi +theories/ZArith/wf_Z.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/peano.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi +theories/ZArith/wf_Z.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/Init/peano.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmi +theories/ZArith/zabs.cmo: theories/ZArith/binInt.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi theories/ZArith/zabs.cmi +theories/ZArith/zabs.cmx: theories/ZArith/binInt.cmx theories/Init/specif.cmx \ + theories/Bool/sumbool.cmx theories/ZArith/zabs.cmi +theories/ZArith/zArith_base.cmo: theories/ZArith/zArith_base.cmi +theories/ZArith/zArith_base.cmx: theories/ZArith/zArith_base.cmi +theories/ZArith/zArith_dec.cmo: theories/ZArith/binInt.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi +theories/ZArith/zArith_dec.cmx: theories/ZArith/binInt.cmx \ + theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmi +theories/ZArith/zArith.cmo: theories/ZArith/zArith.cmi +theories/ZArith/zArith.cmx: theories/ZArith/zArith.cmi +theories/ZArith/zbinary.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Bool/bvector.cmi \ + theories/Init/datatypes.cmi theories/ZArith/zeven.cmi \ + theories/ZArith/zbinary.cmi +theories/ZArith/zbinary.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/Bool/bvector.cmx \ + theories/Init/datatypes.cmx theories/ZArith/zeven.cmx \ + theories/ZArith/zbinary.cmi +theories/ZArith/zbool.cmo: theories/ZArith/binInt.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \ + theories/ZArith/zeven.cmi theories/ZArith/zbool.cmi +theories/ZArith/zbool.cmx: theories/ZArith/binInt.cmx \ + theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/Bool/sumbool.cmx theories/ZArith/zArith_dec.cmx \ + theories/ZArith/zeven.cmx theories/ZArith/zbool.cmi +theories/ZArith/zcompare.cmo: theories/ZArith/zcompare.cmi +theories/ZArith/zcompare.cmx: theories/ZArith/zcompare.cmi +theories/ZArith/zcomplements.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ + theories/ZArith/zabs.cmi theories/ZArith/zcomplements.cmi +theories/ZArith/zcomplements.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/Lists/list.cmx theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \ + theories/ZArith/zabs.cmx theories/ZArith/zcomplements.cmi +theories/ZArith/zdiv.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \ + theories/ZArith/zbool.cmi theories/ZArith/zdiv.cmi +theories/ZArith/zdiv.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/ZArith/zArith_dec.cmx \ + theories/ZArith/zbool.cmx theories/ZArith/zdiv.cmi +theories/ZArith/zeven.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/ZArith/zeven.cmi +theories/ZArith/zeven.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/ZArith/zeven.cmi +theories/ZArith/zhints.cmo: theories/ZArith/zhints.cmi +theories/ZArith/zhints.cmx: theories/ZArith/zhints.cmi +theories/ZArith/zlogarithm.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/ZArith/zlogarithm.cmi +theories/ZArith/zlogarithm.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/ZArith/zlogarithm.cmi +theories/ZArith/zmin.cmo: theories/ZArith/binInt.cmi \ + theories/Init/datatypes.cmi theories/ZArith/zmin.cmi +theories/ZArith/zmin.cmx: theories/ZArith/binInt.cmx \ + theories/Init/datatypes.cmx theories/ZArith/zmin.cmi +theories/ZArith/zmisc.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/ZArith/zmisc.cmi +theories/ZArith/zmisc.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/ZArith/zmisc.cmi +theories/ZArith/znat.cmo: theories/ZArith/znat.cmi +theories/ZArith/znat.cmx: theories/ZArith/znat.cmi +theories/ZArith/znumtheory.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ + theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \ + theories/ZArith/zorder.cmi theories/ZArith/znumtheory.cmi +theories/ZArith/znumtheory.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/Init/specif.cmx theories/ZArith/wf_Z.cmx \ + theories/ZArith/zArith_dec.cmx theories/ZArith/zdiv.cmx \ + theories/ZArith/zorder.cmx theories/ZArith/znumtheory.cmi +theories/ZArith/zorder.cmo: theories/ZArith/binInt.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/ZArith/zorder.cmi +theories/ZArith/zorder.cmx: theories/ZArith/binInt.cmx \ + theories/Init/datatypes.cmx theories/Init/specif.cmx \ + theories/ZArith/zorder.cmi +theories/ZArith/zpower.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/ZArith/zmisc.cmi theories/ZArith/zpower.cmi +theories/ZArith/zpower.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/Init/datatypes.cmx \ + theories/ZArith/zmisc.cmx theories/ZArith/zpower.cmi +theories/ZArith/zsqrt.cmo: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/specif.cmi \ + theories/ZArith/zArith_dec.cmi theories/ZArith/zsqrt.cmi +theories/ZArith/zsqrt.cmx: theories/ZArith/binInt.cmx \ + theories/NArith/binPos.cmx theories/Init/specif.cmx \ + theories/ZArith/zArith_dec.cmx theories/ZArith/zsqrt.cmi +theories/ZArith/zwf.cmo: theories/ZArith/zwf.cmi +theories/ZArith/zwf.cmx: theories/ZArith/zwf.cmi +theories/Arith/bool_nat.cmi: theories/Arith/compare_dec.cmi \ + theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi +theories/Arith/compare_dec.cmi: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi +theories/Arith/compare.cmi: theories/Arith/compare_dec.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Arith/div2.cmi: theories/Init/datatypes.cmi theories/Init/peano.cmi \ + theories/Init/specif.cmi +theories/Arith/eqNat.cmi: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi +theories/Arith/euclid.cmi: theories/Arith/compare_dec.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Arith/even.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Arith/factorial.cmi: theories/Init/datatypes.cmi \ + theories/Init/peano.cmi +theories/Arith/max.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Arith/min.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Arith/mult.cmi: theories/Init/datatypes.cmi theories/Arith/plus.cmi +theories/Arith/peano_dec.cmi: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi +theories/Arith/plus.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Arith/wf_nat.cmi: theories/Init/datatypes.cmi +theories/Bool/boolEq.cmi: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi +theories/Bool/bool.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Bool/bvector.cmi: theories/Bool/bool.cmi theories/Init/datatypes.cmi \ + theories/Init/peano.cmi +theories/Bool/decBool.cmi: theories/Init/specif.cmi +theories/Bool/ifProp.cmi: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi +theories/Bool/sumbool.cmi: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi +theories/Bool/zerob.cmi: theories/Init/datatypes.cmi +theories/Init/logic_Type.cmi: theories/Init/datatypes.cmi +theories/Init/peano.cmi: theories/Init/datatypes.cmi +theories/Init/specif.cmi: theories/Init/datatypes.cmi +theories/IntMap/adalloc.cmi: theories/IntMap/addec.cmi \ + theories/IntMap/addr.cmi theories/NArith/binPos.cmi \ + theories/Init/datatypes.cmi theories/IntMap/map.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi +theories/IntMap/addec.cmi: theories/IntMap/addr.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi +theories/IntMap/addr.cmi: theories/NArith/binPos.cmi theories/Bool/bool.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/IntMap/adist.cmi: theories/IntMap/addr.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi +theories/IntMap/fset.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ + theories/Init/datatypes.cmi theories/IntMap/map.cmi \ + theories/Init/specif.cmi +theories/IntMap/lsort.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ + theories/NArith/binPos.cmi theories/Bool/bool.cmi \ + theories/Init/datatypes.cmi theories/Lists/list.cmi \ + theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi +theories/IntMap/mapcanon.cmi: theories/IntMap/map.cmi \ + theories/Init/specif.cmi +theories/IntMap/mapcard.cmi: theories/IntMap/addec.cmi \ + theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ + theories/IntMap/map.cmi theories/Init/peano.cmi \ + theories/Arith/peano_dec.cmi theories/Arith/plus.cmi \ + theories/Init/specif.cmi theories/Bool/sumbool.cmi +theories/IntMap/mapfold.cmi: theories/IntMap/addr.cmi \ + theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ + theories/IntMap/map.cmi theories/IntMap/mapiter.cmi \ + theories/Init/specif.cmi +theories/IntMap/mapiter.cmi: theories/IntMap/addec.cmi \ + theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/IntMap/map.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi +theories/IntMap/maplists.cmi: theories/IntMap/addec.cmi \ + theories/IntMap/addr.cmi theories/Init/datatypes.cmi \ + theories/IntMap/fset.cmi theories/Lists/list.cmi theories/IntMap/map.cmi \ + theories/IntMap/mapiter.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi +theories/IntMap/map.cmi: theories/IntMap/addec.cmi theories/IntMap/addr.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/peano.cmi theories/Init/specif.cmi +theories/IntMap/mapsubset.cmi: theories/Bool/bool.cmi \ + theories/Init/datatypes.cmi theories/IntMap/fset.cmi \ + theories/IntMap/map.cmi theories/IntMap/mapiter.cmi +theories/Lists/list.cmi: theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/Lists/listSet.cmi: theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Init/specif.cmi +theories/Lists/monoList.cmi: theories/Init/datatypes.cmi +theories/Lists/streams.cmi: theories/Init/datatypes.cmi +theories/Lists/theoryList.cmi: theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Init/specif.cmi +theories/NArith/binNat.cmi: theories/NArith/binPos.cmi \ + theories/Init/datatypes.cmi +theories/NArith/binPos.cmi: theories/Init/datatypes.cmi \ + theories/Init/peano.cmi +theories/Relations/relation_Operators.cmi: theories/Lists/list.cmi \ + theories/Init/specif.cmi +theories/Sets/cpo.cmi: theories/Sets/partial_Order.cmi +theories/Sets/integers.cmi: theories/Init/datatypes.cmi \ + theories/Sets/partial_Order.cmi +theories/Sets/multiset.cmi: theories/Init/datatypes.cmi \ + theories/Init/peano.cmi theories/Init/specif.cmi +theories/Sets/partial_Order.cmi: theories/Sets/ensembles.cmi \ + theories/Sets/relations_1.cmi +theories/Sets/powerset.cmi: theories/Sets/ensembles.cmi \ + theories/Sets/partial_Order.cmi +theories/Sets/uniset.cmi: theories/Init/datatypes.cmi \ + theories/Init/specif.cmi +theories/Sorting/heap.cmi: theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Sets/multiset.cmi \ + theories/Init/peano.cmi theories/Sorting/sorting.cmi \ + theories/Init/specif.cmi +theories/Sorting/permutation.cmi: theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Sets/multiset.cmi \ + theories/Init/peano.cmi theories/Init/specif.cmi +theories/Sorting/sorting.cmi: theories/Lists/list.cmi \ + theories/Init/specif.cmi +theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi +theories/ZArith/binInt.cmi: theories/NArith/binNat.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi +theories/ZArith/wf_Z.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/peano.cmi theories/Init/specif.cmi +theories/ZArith/zabs.cmi: theories/ZArith/binInt.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi +theories/ZArith/zArith_dec.cmi: theories/ZArith/binInt.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi +theories/ZArith/zbinary.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Bool/bvector.cmi \ + theories/Init/datatypes.cmi theories/ZArith/zeven.cmi +theories/ZArith/zbool.cmi: theories/ZArith/binInt.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi \ + theories/Bool/sumbool.cmi theories/ZArith/zArith_dec.cmi \ + theories/ZArith/zeven.cmi +theories/ZArith/zcomplements.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Lists/list.cmi theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ + theories/ZArith/zabs.cmi +theories/ZArith/zdiv.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/ZArith/zArith_dec.cmi \ + theories/ZArith/zbool.cmi +theories/ZArith/zeven.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/specif.cmi +theories/ZArith/zlogarithm.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi +theories/ZArith/zmin.cmi: theories/ZArith/binInt.cmi \ + theories/Init/datatypes.cmi +theories/ZArith/zmisc.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi +theories/ZArith/znumtheory.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/Init/specif.cmi theories/ZArith/wf_Z.cmi \ + theories/ZArith/zArith_dec.cmi theories/ZArith/zdiv.cmi \ + theories/ZArith/zorder.cmi +theories/ZArith/zorder.cmi: theories/ZArith/binInt.cmi \ + theories/Init/datatypes.cmi theories/Init/specif.cmi +theories/ZArith/zpower.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/datatypes.cmi \ + theories/ZArith/zmisc.cmi +theories/ZArith/zsqrt.cmi: theories/ZArith/binInt.cmi \ + theories/NArith/binPos.cmi theories/Init/specif.cmi \ + theories/ZArith/zArith_dec.cmi diff --git a/contrib/extraction/test/Makefile b/contrib/extraction/test/Makefile new file mode 100644 index 00000000..c9bb5623 --- /dev/null +++ b/contrib/extraction/test/Makefile @@ -0,0 +1,109 @@ +# +# General variables +# + +TOPDIR=../../.. + +# Files with axioms to be realized: can't be extracted directly + +AXIOMSVO:= \ +theories/Reals/% \ +theories/Num/% + +DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS)) + +INCL:= $(patsubst %,-I %,$(DIRS)) + +VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo)) + +VO:= $(filter-out $(AXIOMSVO),$(VO)) + +ML:= $(shell test -x v2ml && ./v2ml $(VO)) + +MLI:= $(patsubst %.ml,%.mli,$(ML)) + +CMO:= $(patsubst %.ml,%.cmo,$(ML)) + +OSTDLIB:=$(shell (ocamlc -where)) + +# +# General rules +# + +all: v2ml ml $(MLI) $(CMO) + +ml: $(ML) + +depend: $(ML) + rm -f .depend; ocamldep $(INCL) theories/*/*.ml theories/*/*.mli > .depend + +tree: + mkdir -p $(DIRS) + cp $(OSTDLIB)/pervasives.cmi $(OSTDLIB)/obj.cmi $(OSTDLIB)/lazy.cmi theories + +#%.mli:%.ml +# ./make_mli $< > $@ + +%.cmi:%.mli + ocamlc -c $(INCL) -nostdlib $< + +%.cmo:%.ml + ocamlc -c $(INCL) -nostdlib $< + +$(ML): ml2v + ./extract $@ + +clean: + rm -f theories/*/*.ml* theories/*/*.cm* + + +# +# Utilities +# + +open: + find theories -name "*".ml -exec ./qualify2open \{\} \; + +undo_open: + find theories -name "*".ml -exec mv \{\}.orig \{\} \; + +ml2v: ml2v.ml + ocamlopt -o $@ $< + +v2ml: v2ml.ml + ocamlopt -o $@ $< + $(MAKE) + +# +# Extraction of Reals +# + + +REALSAXIOMSVO:=theories/Reals/Rsyntax.vo + +REALSALLVO:=$(shell cd $(TOPDIR); ls -tr theories/Reals/*.vo) +REALSVO:=$(filter-out $(REALSAXIOMSVO),$(REALSALLVO)) +REALSML:=$(shell test -x v2ml && ./v2ml $(REALSVO)) +REALSCMO:= $(patsubst %.ml,%.cmo,$(REALSML)) + +reals: all realsml theories/Reals/addReals.cmo $(REALSCMO) + +realsml: $(REALSML) + +theories/Reals/addReals.ml: + cp -f addReals theories/Reals/addReals.ml + +$(REALSML): + ./extract $@ + + +# +# The End +# + +.PHONY: all tree clean reals realsml depend + +include .depend + + + diff --git a/contrib/extraction/test/Makefile.haskell b/contrib/extraction/test/Makefile.haskell new file mode 100644 index 00000000..6e1e15d1 --- /dev/null +++ b/contrib/extraction/test/Makefile.haskell @@ -0,0 +1,416 @@ +# +# General variables +# + +TOPDIR=../../.. + +# Files with axioms to be realized: can't be extracted directly + +AXIOMSVO:= \ +theories/Init/Prelude.vo \ +theories/Reals/% \ +theories/Num/% + +DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS)) + +INCL:= $(patsubst %,-i%,$(DIRS)) + +VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo)) + +VO:= $(filter-out $(AXIOMSVO),$(VO)) + +HS:= $(shell test -x v2hs && ./v2hs $(VO)) + +O:= $(patsubst %.hs,%.o,$(HS)) + +# +# General rules +# + +all: v2hs hs $(O) + +hs: $(HS) + +tree: + mkdir -p $(DIRS) + +%.o:%.hs + ghc $(INCL) -c $< + +$(HS): hs2v + ./extract.haskell $@ + +clean: + rm -f theories/*/*.h* theories/*/*.o + + +# +# Utilities +# + +hs2v: hs2v.ml + ocamlc -o $@ $< + +v2hs: v2hs.ml + ocamlc -o $@ $< + $(MAKE) -f Makefile.haskell + + +# +# The End +# + +.PHONY: all tree clean depend + +# DO NOT DELETE: Beginning of Haskell dependencies +theories/Arith/Between.o : theories/Arith/Between.hs +theories/Arith/Bool_nat.o : theories/Arith/Bool_nat.hs +theories/Arith/Bool_nat.o : theories/Bool/Sumbool.o +theories/Arith/Bool_nat.o : theories/Init/Specif.o +theories/Arith/Bool_nat.o : theories/Arith/Peano_dec.o +theories/Arith/Bool_nat.o : theories/Init/Datatypes.o +theories/Arith/Bool_nat.o : theories/Arith/Compare_dec.o +theories/Arith/Compare_dec.o : theories/Arith/Compare_dec.hs +theories/Arith/Compare_dec.o : theories/Init/Specif.o +theories/Arith/Compare_dec.o : theories/Init/Logic.o +theories/Arith/Compare_dec.o : theories/Init/Datatypes.o +theories/Arith/Compare.o : theories/Arith/Compare.hs +theories/Arith/Compare.o : theories/Init/Specif.o +theories/Arith/Compare.o : theories/Init/Datatypes.o +theories/Arith/Compare.o : theories/Arith/Compare_dec.o +theories/Arith/Div2.o : theories/Arith/Div2.hs +theories/Arith/Div2.o : theories/Init/Specif.o +theories/Arith/Div2.o : theories/Init/Peano.o +theories/Arith/Div2.o : theories/Init/Datatypes.o +theories/Arith/EqNat.o : theories/Arith/EqNat.hs +theories/Arith/EqNat.o : theories/Init/Specif.o +theories/Arith/EqNat.o : theories/Init/Datatypes.o +theories/Arith/Euclid.o : theories/Arith/Euclid.hs +theories/Arith/Euclid.o : theories/Arith/Wf_nat.o +theories/Arith/Euclid.o : theories/Init/Specif.o +theories/Arith/Euclid.o : theories/Arith/Minus.o +theories/Arith/Euclid.o : theories/Init/Datatypes.o +theories/Arith/Euclid.o : theories/Arith/Compare_dec.o +theories/Arith/Even.o : theories/Arith/Even.hs +theories/Arith/Even.o : theories/Init/Specif.o +theories/Arith/Even.o : theories/Init/Datatypes.o +theories/Arith/Gt.o : theories/Arith/Gt.hs +theories/Arith/Le.o : theories/Arith/Le.hs +theories/Arith/Lt.o : theories/Arith/Lt.hs +theories/Arith/Max.o : theories/Arith/Max.hs +theories/Arith/Max.o : theories/Init/Specif.o +theories/Arith/Max.o : theories/Init/Logic.o +theories/Arith/Max.o : theories/Init/Datatypes.o +theories/Arith/Min.o : theories/Arith/Min.hs +theories/Arith/Min.o : theories/Init/Specif.o +theories/Arith/Min.o : theories/Init/Logic.o +theories/Arith/Min.o : theories/Init/Datatypes.o +theories/Arith/Minus.o : theories/Arith/Minus.hs +theories/Arith/Minus.o : theories/Init/Datatypes.o +theories/Arith/Mult.o : theories/Arith/Mult.hs +theories/Arith/Mult.o : theories/Arith/Plus.o +theories/Arith/Mult.o : theories/Init/Datatypes.o +theories/Arith/Peano_dec.o : theories/Arith/Peano_dec.hs +theories/Arith/Peano_dec.o : theories/Init/Specif.o +theories/Arith/Peano_dec.o : theories/Init/Datatypes.o +theories/Arith/Plus.o : theories/Arith/Plus.hs +theories/Arith/Plus.o : theories/Init/Specif.o +theories/Arith/Plus.o : theories/Init/Logic.o +theories/Arith/Plus.o : theories/Init/Datatypes.o +theories/Arith/Wf_nat.o : theories/Arith/Wf_nat.hs +theories/Arith/Wf_nat.o : theories/Init/Wf.o +theories/Arith/Wf_nat.o : theories/Init/Logic.o +theories/Arith/Wf_nat.o : theories/Init/Datatypes.o +theories/Bool/BoolEq.o : theories/Bool/BoolEq.hs +theories/Bool/BoolEq.o : theories/Init/Specif.o +theories/Bool/BoolEq.o : theories/Init/Datatypes.o +theories/Bool/Bool.o : theories/Bool/Bool.hs +theories/Bool/Bool.o : theories/Init/Specif.o +theories/Bool/Bool.o : theories/Init/Datatypes.o +theories/Bool/DecBool.o : theories/Bool/DecBool.hs +theories/Bool/DecBool.o : theories/Init/Specif.o +theories/Bool/IfProp.o : theories/Bool/IfProp.hs +theories/Bool/IfProp.o : theories/Init/Specif.o +theories/Bool/IfProp.o : theories/Init/Datatypes.o +theories/Bool/Sumbool.o : theories/Bool/Sumbool.hs +theories/Bool/Sumbool.o : theories/Init/Specif.o +theories/Bool/Sumbool.o : theories/Init/Datatypes.o +theories/Bool/Zerob.o : theories/Bool/Zerob.hs +theories/Bool/Zerob.o : theories/Init/Datatypes.o +theories/Init/Datatypes.o : theories/Init/Datatypes.hs +theories/Init/DatatypesSyntax.o : theories/Init/DatatypesSyntax.hs +theories/Init/Logic.o : theories/Init/Logic.hs +theories/Init/LogicSyntax.o : theories/Init/LogicSyntax.hs +theories/Init/Logic_Type.o : theories/Init/Logic_Type.hs +theories/Init/Logic_TypeSyntax.o : theories/Init/Logic_TypeSyntax.hs +theories/Init/Peano.o : theories/Init/Peano.hs +theories/Init/Peano.o : theories/Init/Datatypes.o +theories/Init/Specif.o : theories/Init/Specif.hs +theories/Init/Specif.o : theories/Init/Logic.o +theories/Init/Specif.o : theories/Init/Datatypes.o +theories/Init/SpecifSyntax.o : theories/Init/SpecifSyntax.hs +theories/Init/Wf.o : theories/Init/Wf.hs +theories/IntMap/Adalloc.o : theories/IntMap/Adalloc.hs +theories/IntMap/Adalloc.o : theories/ZArith/Fast_integer.o +theories/IntMap/Adalloc.o : theories/Bool/Sumbool.o +theories/IntMap/Adalloc.o : theories/Init/Specif.o +theories/IntMap/Adalloc.o : theories/IntMap/Map.o +theories/IntMap/Adalloc.o : theories/Init/Logic.o +theories/IntMap/Adalloc.o : theories/Init/Datatypes.o +theories/IntMap/Adalloc.o : theories/IntMap/Addr.o +theories/IntMap/Adalloc.o : theories/IntMap/Addec.o +theories/IntMap/Addec.o : theories/IntMap/Addec.hs +theories/IntMap/Addec.o : theories/ZArith/Fast_integer.o +theories/IntMap/Addec.o : theories/Bool/Sumbool.o +theories/IntMap/Addec.o : theories/Init/Specif.o +theories/IntMap/Addec.o : theories/Init/Datatypes.o +theories/IntMap/Addec.o : theories/IntMap/Addr.o +theories/IntMap/Addr.o : theories/IntMap/Addr.hs +theories/IntMap/Addr.o : theories/ZArith/Fast_integer.o +theories/IntMap/Addr.o : theories/Init/Specif.o +theories/IntMap/Addr.o : theories/Init/Datatypes.o +theories/IntMap/Addr.o : theories/Bool/Bool.o +theories/IntMap/Adist.o : theories/IntMap/Adist.hs +theories/IntMap/Adist.o : theories/ZArith/Fast_integer.o +theories/IntMap/Adist.o : theories/Arith/Min.o +theories/IntMap/Adist.o : theories/Init/Datatypes.o +theories/IntMap/Adist.o : theories/IntMap/Addr.o +theories/IntMap/Allmaps.o : theories/IntMap/Allmaps.hs +theories/IntMap/Fset.o : theories/IntMap/Fset.hs +theories/IntMap/Fset.o : theories/Init/Specif.o +theories/IntMap/Fset.o : theories/IntMap/Map.o +theories/IntMap/Fset.o : theories/Init/Logic.o +theories/IntMap/Fset.o : theories/Init/Datatypes.o +theories/IntMap/Fset.o : theories/IntMap/Addr.o +theories/IntMap/Fset.o : theories/IntMap/Addec.o +theories/IntMap/Lsort.o : theories/IntMap/Lsort.hs +theories/IntMap/Lsort.o : theories/ZArith/Fast_integer.o +theories/IntMap/Lsort.o : theories/Bool/Sumbool.o +theories/IntMap/Lsort.o : theories/Init/Specif.o +theories/IntMap/Lsort.o : theories/Lists/PolyList.o +theories/IntMap/Lsort.o : theories/IntMap/Mapiter.o +theories/IntMap/Lsort.o : theories/IntMap/Map.o +theories/IntMap/Lsort.o : theories/Init/Logic.o +theories/IntMap/Lsort.o : theories/Init/Datatypes.o +theories/IntMap/Lsort.o : theories/Bool/Bool.o +theories/IntMap/Lsort.o : theories/IntMap/Addr.o +theories/IntMap/Lsort.o : theories/IntMap/Addec.o +theories/IntMap/Mapaxioms.o : theories/IntMap/Mapaxioms.hs +theories/IntMap/Mapcanon.o : theories/IntMap/Mapcanon.hs +theories/IntMap/Mapcanon.o : theories/Init/Specif.o +theories/IntMap/Mapcanon.o : theories/IntMap/Map.o +theories/IntMap/Mapcard.o : theories/IntMap/Mapcard.hs +theories/IntMap/Mapcard.o : theories/Bool/Sumbool.o +theories/IntMap/Mapcard.o : theories/Init/Specif.o +theories/IntMap/Mapcard.o : theories/Arith/Plus.o +theories/IntMap/Mapcard.o : theories/Arith/Peano_dec.o +theories/IntMap/Mapcard.o : theories/Init/Peano.o +theories/IntMap/Mapcard.o : theories/IntMap/Map.o +theories/IntMap/Mapcard.o : theories/Init/Logic.o +theories/IntMap/Mapcard.o : theories/Init/Datatypes.o +theories/IntMap/Mapcard.o : theories/IntMap/Addr.o +theories/IntMap/Mapcard.o : theories/IntMap/Addec.o +theories/IntMap/Mapc.o : theories/IntMap/Mapc.hs +theories/IntMap/Mapfold.o : theories/IntMap/Mapfold.hs +theories/IntMap/Mapfold.o : theories/Init/Specif.o +theories/IntMap/Mapfold.o : theories/IntMap/Mapiter.o +theories/IntMap/Mapfold.o : theories/IntMap/Map.o +theories/IntMap/Mapfold.o : theories/Init/Logic.o +theories/IntMap/Mapfold.o : theories/IntMap/Fset.o +theories/IntMap/Mapfold.o : theories/Init/Datatypes.o +theories/IntMap/Mapfold.o : theories/IntMap/Addr.o +theories/IntMap/Map.o : theories/IntMap/Map.hs +theories/IntMap/Map.o : theories/ZArith/Fast_integer.o +theories/IntMap/Map.o : theories/Init/Specif.o +theories/IntMap/Map.o : theories/Init/Peano.o +theories/IntMap/Map.o : theories/Init/Datatypes.o +theories/IntMap/Map.o : theories/IntMap/Addr.o +theories/IntMap/Map.o : theories/IntMap/Addec.o +theories/IntMap/Mapiter.o : theories/IntMap/Mapiter.hs +theories/IntMap/Mapiter.o : theories/Bool/Sumbool.o +theories/IntMap/Mapiter.o : theories/Init/Specif.o +theories/IntMap/Mapiter.o : theories/Lists/PolyList.o +theories/IntMap/Mapiter.o : theories/IntMap/Map.o +theories/IntMap/Mapiter.o : theories/Init/Logic.o +theories/IntMap/Mapiter.o : theories/Init/Datatypes.o +theories/IntMap/Mapiter.o : theories/IntMap/Addr.o +theories/IntMap/Mapiter.o : theories/IntMap/Addec.o +theories/IntMap/Maplists.o : theories/IntMap/Maplists.hs +theories/IntMap/Maplists.o : theories/Bool/Sumbool.o +theories/IntMap/Maplists.o : theories/Init/Specif.o +theories/IntMap/Maplists.o : theories/Lists/PolyList.o +theories/IntMap/Maplists.o : theories/IntMap/Mapiter.o +theories/IntMap/Maplists.o : theories/IntMap/Map.o +theories/IntMap/Maplists.o : theories/Init/Logic.o +theories/IntMap/Maplists.o : theories/IntMap/Fset.o +theories/IntMap/Maplists.o : theories/Init/Datatypes.o +theories/IntMap/Maplists.o : theories/Bool/Bool.o +theories/IntMap/Maplists.o : theories/IntMap/Addr.o +theories/IntMap/Maplists.o : theories/IntMap/Addec.o +theories/IntMap/Mapsubset.o : theories/IntMap/Mapsubset.hs +theories/IntMap/Mapsubset.o : theories/IntMap/Mapiter.o +theories/IntMap/Mapsubset.o : theories/IntMap/Map.o +theories/IntMap/Mapsubset.o : theories/IntMap/Fset.o +theories/IntMap/Mapsubset.o : theories/Init/Datatypes.o +theories/IntMap/Mapsubset.o : theories/Bool/Bool.o +theories/Lists/ListSet.o : theories/Lists/ListSet.hs +theories/Lists/ListSet.o : theories/Init/Specif.o +theories/Lists/ListSet.o : theories/Lists/PolyList.o +theories/Lists/ListSet.o : theories/Init/Logic.o +theories/Lists/ListSet.o : theories/Init/Datatypes.o +theories/Lists/PolyList.o : theories/Lists/PolyList.hs +theories/Lists/PolyList.o : theories/Init/Specif.o +theories/Lists/PolyList.o : theories/Init/Datatypes.o +theories/Lists/PolyListSyntax.o : theories/Lists/PolyListSyntax.hs +theories/Lists/Streams.o : theories/Lists/Streams.hs +theories/Lists/Streams.o : theories/Init/Datatypes.o +theories/Lists/TheoryList.o : theories/Lists/TheoryList.hs +theories/Lists/TheoryList.o : theories/Init/Specif.o +theories/Lists/TheoryList.o : theories/Lists/PolyList.o +theories/Lists/TheoryList.o : theories/Bool/DecBool.o +theories/Lists/TheoryList.o : theories/Init/Datatypes.o +theories/Logic/Berardi.o : theories/Logic/Berardi.hs +theories/Logic/ClassicalFacts.o : theories/Logic/ClassicalFacts.hs +theories/Logic/Classical.o : theories/Logic/Classical.hs +theories/Logic/Classical_Pred_Set.o : theories/Logic/Classical_Pred_Set.hs +theories/Logic/Classical_Pred_Type.o : theories/Logic/Classical_Pred_Type.hs +theories/Logic/Classical_Prop.o : theories/Logic/Classical_Prop.hs +theories/Logic/Classical_Type.o : theories/Logic/Classical_Type.hs +theories/Logic/Decidable.o : theories/Logic/Decidable.hs +theories/Logic/Eqdep_dec.o : theories/Logic/Eqdep_dec.hs +theories/Logic/Eqdep.o : theories/Logic/Eqdep.hs +theories/Logic/Hurkens.o : theories/Logic/Hurkens.hs +theories/Logic/JMeq.o : theories/Logic/JMeq.hs +theories/Logic/ProofIrrelevance.o : theories/Logic/ProofIrrelevance.hs +theories/Relations/Newman.o : theories/Relations/Newman.hs +theories/Relations/Operators_Properties.o : theories/Relations/Operators_Properties.hs +theories/Relations/Relation_Definitions.o : theories/Relations/Relation_Definitions.hs +theories/Relations/Relation_Operators.o : theories/Relations/Relation_Operators.hs +theories/Relations/Relation_Operators.o : theories/Init/Specif.o +theories/Relations/Relation_Operators.o : theories/Lists/PolyList.o +theories/Relations/Relations.o : theories/Relations/Relations.hs +theories/Relations/Rstar.o : theories/Relations/Rstar.hs +theories/Setoids/Setoid.o : theories/Setoids/Setoid.hs +theories/Sets/Classical_sets.o : theories/Sets/Classical_sets.hs +theories/Sets/Constructive_sets.o : theories/Sets/Constructive_sets.hs +theories/Sets/Cpo.o : theories/Sets/Cpo.hs +theories/Sets/Cpo.o : theories/Sets/Partial_Order.o +theories/Sets/Ensembles.o : theories/Sets/Ensembles.hs +theories/Sets/Finite_sets_facts.o : theories/Sets/Finite_sets_facts.hs +theories/Sets/Finite_sets.o : theories/Sets/Finite_sets.hs +theories/Sets/Image.o : theories/Sets/Image.hs +theories/Sets/Infinite_sets.o : theories/Sets/Infinite_sets.hs +theories/Sets/Integers.o : theories/Sets/Integers.hs +theories/Sets/Integers.o : theories/Sets/Partial_Order.o +theories/Sets/Integers.o : theories/Init/Datatypes.o +theories/Sets/Multiset.o : theories/Sets/Multiset.hs +theories/Sets/Multiset.o : theories/Init/Specif.o +theories/Sets/Multiset.o : theories/Init/Peano.o +theories/Sets/Multiset.o : theories/Init/Datatypes.o +theories/Sets/Partial_Order.o : theories/Sets/Partial_Order.hs +theories/Sets/Permut.o : theories/Sets/Permut.hs +theories/Sets/Powerset_Classical_facts.o : theories/Sets/Powerset_Classical_facts.hs +theories/Sets/Powerset_facts.o : theories/Sets/Powerset_facts.hs +theories/Sets/Powerset.o : theories/Sets/Powerset.hs +theories/Sets/Powerset.o : theories/Sets/Partial_Order.o +theories/Sets/Relations_1_facts.o : theories/Sets/Relations_1_facts.hs +theories/Sets/Relations_1.o : theories/Sets/Relations_1.hs +theories/Sets/Relations_2_facts.o : theories/Sets/Relations_2_facts.hs +theories/Sets/Relations_2.o : theories/Sets/Relations_2.hs +theories/Sets/Relations_3_facts.o : theories/Sets/Relations_3_facts.hs +theories/Sets/Relations_3.o : theories/Sets/Relations_3.hs +theories/Sets/Uniset.o : theories/Sets/Uniset.hs +theories/Sets/Uniset.o : theories/Init/Specif.o +theories/Sets/Uniset.o : theories/Init/Datatypes.o +theories/Sets/Uniset.o : theories/Bool/Bool.o +theories/Sorting/Heap.o : theories/Sorting/Heap.hs +theories/Sorting/Heap.o : theories/Init/Specif.o +theories/Sorting/Heap.o : theories/Sorting/Sorting.o +theories/Sorting/Heap.o : theories/Lists/PolyList.o +theories/Sorting/Heap.o : theories/Sets/Multiset.o +theories/Sorting/Heap.o : theories/Init/Logic.o +theories/Sorting/Permutation.o : theories/Sorting/Permutation.hs +theories/Sorting/Permutation.o : theories/Init/Specif.o +theories/Sorting/Permutation.o : theories/Lists/PolyList.o +theories/Sorting/Permutation.o : theories/Sets/Multiset.o +theories/Sorting/Sorting.o : theories/Sorting/Sorting.hs +theories/Sorting/Sorting.o : theories/Init/Specif.o +theories/Sorting/Sorting.o : theories/Lists/PolyList.o +theories/Sorting/Sorting.o : theories/Init/Logic.o +theories/Wellfounded/Disjoint_Union.o : theories/Wellfounded/Disjoint_Union.hs +theories/Wellfounded/Inclusion.o : theories/Wellfounded/Inclusion.hs +theories/Wellfounded/Inverse_Image.o : theories/Wellfounded/Inverse_Image.hs +theories/Wellfounded/Lexicographic_Exponentiation.o : theories/Wellfounded/Lexicographic_Exponentiation.hs +theories/Wellfounded/Lexicographic_Product.o : theories/Wellfounded/Lexicographic_Product.hs +theories/Wellfounded/Transitive_Closure.o : theories/Wellfounded/Transitive_Closure.hs +theories/Wellfounded/Union.o : theories/Wellfounded/Union.hs +theories/Wellfounded/Wellfounded.o : theories/Wellfounded/Wellfounded.hs +theories/Wellfounded/Well_Ordering.o : theories/Wellfounded/Well_Ordering.hs +theories/Wellfounded/Well_Ordering.o : theories/Init/Wf.o +theories/Wellfounded/Well_Ordering.o : theories/Init/Specif.o +theories/ZArith/Auxiliary.o : theories/ZArith/Auxiliary.hs +theories/ZArith/Fast_integer.o : theories/ZArith/Fast_integer.hs +theories/ZArith/Fast_integer.o : theories/Init/Peano.o +theories/ZArith/Fast_integer.o : theories/Init/Datatypes.o +theories/ZArith/Wf_Z.o : theories/ZArith/Wf_Z.hs +theories/ZArith/Wf_Z.o : theories/ZArith/Zarith_aux.o +theories/ZArith/Wf_Z.o : theories/ZArith/Fast_integer.o +theories/ZArith/Wf_Z.o : theories/Init/Specif.o +theories/ZArith/Wf_Z.o : theories/Init/Peano.o +theories/ZArith/Wf_Z.o : theories/Init/Logic.o +theories/ZArith/Wf_Z.o : theories/Init/Datatypes.o +theories/ZArith/Zarith_aux.o : theories/ZArith/Zarith_aux.hs +theories/ZArith/Zarith_aux.o : theories/ZArith/Fast_integer.o +theories/ZArith/Zarith_aux.o : theories/Init/Specif.o +theories/ZArith/Zarith_aux.o : theories/Init/Datatypes.o +theories/ZArith/ZArith_base.o : theories/ZArith/ZArith_base.hs +theories/ZArith/ZArith_dec.o : theories/ZArith/ZArith_dec.hs +theories/ZArith/ZArith_dec.o : theories/ZArith/Fast_integer.o +theories/ZArith/ZArith_dec.o : theories/Bool/Sumbool.o +theories/ZArith/ZArith_dec.o : theories/Init/Specif.o +theories/ZArith/ZArith_dec.o : theories/Init/Logic.o +theories/ZArith/ZArith.o : theories/ZArith/ZArith.hs +theories/ZArith/Zbool.o : theories/ZArith/Zbool.hs +theories/ZArith/Zbool.o : theories/ZArith/Fast_integer.o +theories/ZArith/Zbool.o : theories/ZArith/Zmisc.o +theories/ZArith/Zbool.o : theories/ZArith/ZArith_dec.o +theories/ZArith/Zbool.o : theories/Bool/Sumbool.o +theories/ZArith/Zbool.o : theories/Init/Specif.o +theories/ZArith/Zbool.o : theories/Init/Datatypes.o +theories/ZArith/Zcomplements.o : theories/ZArith/Zcomplements.hs +theories/ZArith/Zcomplements.o : theories/ZArith/Zarith_aux.o +theories/ZArith/Zcomplements.o : theories/ZArith/Fast_integer.o +theories/ZArith/Zcomplements.o : theories/ZArith/Wf_Z.o +theories/ZArith/Zcomplements.o : theories/Init/Specif.o +theories/ZArith/Zcomplements.o : theories/Init/Logic.o +theories/ZArith/Zcomplements.o : theories/Init/Datatypes.o +theories/ZArith/Zdiv.o : theories/ZArith/Zdiv.hs +theories/ZArith/Zdiv.o : theories/ZArith/Zarith_aux.o +theories/ZArith/Zdiv.o : theories/ZArith/Fast_integer.o +theories/ZArith/Zdiv.o : theories/ZArith/Zmisc.o +theories/ZArith/Zdiv.o : theories/ZArith/ZArith_dec.o +theories/ZArith/Zdiv.o : theories/Init/Specif.o +theories/ZArith/Zdiv.o : theories/Init/Logic.o +theories/ZArith/Zdiv.o : theories/Init/Datatypes.o +theories/ZArith/Zhints.o : theories/ZArith/Zhints.hs +theories/ZArith/Zlogarithm.o : theories/ZArith/Zlogarithm.hs +theories/ZArith/Zlogarithm.o : theories/ZArith/Zarith_aux.o +theories/ZArith/Zlogarithm.o : theories/ZArith/Fast_integer.o +theories/ZArith/Zmisc.o : theories/ZArith/Zmisc.hs +theories/ZArith/Zmisc.o : theories/ZArith/Fast_integer.o +theories/ZArith/Zmisc.o : theories/Init/Specif.o +theories/ZArith/Zmisc.o : theories/Init/Datatypes.o +theories/ZArith/Zpower.o : theories/ZArith/Zpower.hs +theories/ZArith/Zpower.o : theories/ZArith/Zarith_aux.o +theories/ZArith/Zpower.o : theories/ZArith/Fast_integer.o +theories/ZArith/Zpower.o : theories/ZArith/Zmisc.o +theories/ZArith/Zpower.o : theories/Init/Logic.o +theories/ZArith/Zpower.o : theories/Init/Datatypes.o +theories/ZArith/Zsqrt.o : theories/ZArith/Zsqrt.hs +theories/ZArith/Zsqrt.o : theories/ZArith/Zarith_aux.o +theories/ZArith/Zsqrt.o : theories/ZArith/Fast_integer.o +theories/ZArith/Zsqrt.o : theories/ZArith/ZArith_dec.o +theories/ZArith/Zsqrt.o : theories/Init/Specif.o +theories/ZArith/Zsqrt.o : theories/Init/Logic.o +theories/ZArith/Zwf.o : theories/ZArith/Zwf.hs +# DO NOT DELETE: End of Haskell dependencies diff --git a/contrib/extraction/test/addReals b/contrib/extraction/test/addReals new file mode 100644 index 00000000..fb73d47b --- /dev/null +++ b/contrib/extraction/test/addReals @@ -0,0 +1,21 @@ +open TypeSyntax +open Fast_integer + + +let total_order_T x y = +if x = y then InleftT RightT +else if x < y then InleftT LeftT +else InrightT + +let rec int_to_positive i = + if i = 1 then XH + else + if (i mod 2) = 0 then XO (int_to_positive (i/2)) + else XI (int_to_positive (i/2)) + +let rec int_to_Z i = + if i = 0 then ZERO + else if i > 0 then POS (int_to_positive i) + else NEG (int_to_positive (-i)) + +let my_ceil x = int_to_Z (succ (int_of_float (floor x))) diff --git a/contrib/extraction/test/custom/Adalloc b/contrib/extraction/test/custom/Adalloc new file mode 100644 index 00000000..0fb556aa --- /dev/null +++ b/contrib/extraction/test/custom/Adalloc @@ -0,0 +1,2 @@ +Require Import Addr. +Extraction NoInline ad_double ad_double_plus_un. diff --git a/contrib/extraction/test/custom/Euclid b/contrib/extraction/test/custom/Euclid new file mode 100644 index 00000000..a58e3940 --- /dev/null +++ b/contrib/extraction/test/custom/Euclid @@ -0,0 +1 @@ +Extraction Inline Wf_nat.gt_wf_rec Wf_nat.lt_wf_rec. diff --git a/contrib/extraction/test/custom/List b/contrib/extraction/test/custom/List new file mode 100644 index 00000000..ffee7dc9 --- /dev/null +++ b/contrib/extraction/test/custom/List @@ -0,0 +1 @@ +Extraction NoInline map. diff --git a/contrib/extraction/test/custom/ListSet b/contrib/extraction/test/custom/ListSet new file mode 100644 index 00000000..c9bea52a --- /dev/null +++ b/contrib/extraction/test/custom/ListSet @@ -0,0 +1 @@ +Extraction NoInline set_add set_mem. diff --git a/contrib/extraction/test/custom/Lsort b/contrib/extraction/test/custom/Lsort new file mode 100644 index 00000000..6a185683 --- /dev/null +++ b/contrib/extraction/test/custom/Lsort @@ -0,0 +1,2 @@ +Require Import Addr. +Extraction NoInline ad_double ad_double_plus_un. diff --git a/contrib/extraction/test/custom/Map b/contrib/extraction/test/custom/Map new file mode 100644 index 00000000..3e464e39 --- /dev/null +++ b/contrib/extraction/test/custom/Map @@ -0,0 +1,3 @@ +Require Import Addr. +Extraction NoInline ad_double ad_double_plus_un. + diff --git a/contrib/extraction/test/custom/Mapcard b/contrib/extraction/test/custom/Mapcard new file mode 100644 index 00000000..ca555aa3 --- /dev/null +++ b/contrib/extraction/test/custom/Mapcard @@ -0,0 +1,4 @@ +Require Import Plus. +Extraction NoInline plus_is_one. +Require Import Addr. +Extraction NoInline ad_double ad_double_plus_un. diff --git a/contrib/extraction/test/custom/Mapiter b/contrib/extraction/test/custom/Mapiter new file mode 100644 index 00000000..6a185683 --- /dev/null +++ b/contrib/extraction/test/custom/Mapiter @@ -0,0 +1,2 @@ +Require Import Addr. +Extraction NoInline ad_double ad_double_plus_un. diff --git a/contrib/extraction/test/custom/R_Ifp b/contrib/extraction/test/custom/R_Ifp new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/R_Ifp @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/R_sqr b/contrib/extraction/test/custom/R_sqr new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/R_sqr @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Ranalysis b/contrib/extraction/test/custom/Ranalysis new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Ranalysis @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Raxioms b/contrib/extraction/test/custom/Raxioms new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Raxioms @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Rbase b/contrib/extraction/test/custom/Rbase new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Rbase @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Rbasic_fun b/contrib/extraction/test/custom/Rbasic_fun new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Rbasic_fun @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Rdefinitions b/contrib/extraction/test/custom/Rdefinitions new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Rdefinitions @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Reals.v b/contrib/extraction/test/custom/Reals.v new file mode 100644 index 00000000..45d0a224 --- /dev/null +++ b/contrib/extraction/test/custom/Reals.v @@ -0,0 +1,17 @@ +Require Import Reals. +Extract Inlined Constant R => float. +Extract Inlined Constant R0 => "0.0". +Extract Inlined Constant R1 => "1.0". +Extract Inlined Constant Rplus => "(+.)". +Extract Inlined Constant Rmult => "( *.)". +Extract Inlined Constant Ropp => "(~-.)". +Extract Inlined Constant Rinv => "(fun x -> 1.0 /. x)". +Extract Inlined Constant Rlt => "(<)". +Extract Inlined Constant up => "AddReals.my_ceil". +Extract Inlined Constant total_order_T => "AddReals.total_order_T". +Extract Inlined Constant sqrt => "sqrt". +Extract Inlined Constant sigma => "(fun l h -> sigma_aux l h (Minus.minus h l))". +Extract Inlined Constant PI => "3.141593". +Extract Inlined Constant cos => cos. +Extract Inlined Constant sin => sin. +Extract Inlined Constant derive_pt => "(fun f x -> ((f (x+.1E-5))-.(f x))*.1E5)". diff --git a/contrib/extraction/test/custom/Rfunctions b/contrib/extraction/test/custom/Rfunctions new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Rfunctions @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Rgeom b/contrib/extraction/test/custom/Rgeom new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Rgeom @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Rlimit b/contrib/extraction/test/custom/Rlimit new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Rlimit @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Rseries b/contrib/extraction/test/custom/Rseries new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Rseries @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Rsigma b/contrib/extraction/test/custom/Rsigma new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Rsigma @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/Rtrigo b/contrib/extraction/test/custom/Rtrigo new file mode 100644 index 00000000..d8f1b3e7 --- /dev/null +++ b/contrib/extraction/test/custom/Rtrigo @@ -0,0 +1,2 @@ +Load "custom/Reals". + diff --git a/contrib/extraction/test/custom/ZArith_dec b/contrib/extraction/test/custom/ZArith_dec new file mode 100644 index 00000000..2201419e --- /dev/null +++ b/contrib/extraction/test/custom/ZArith_dec @@ -0,0 +1 @@ +Extraction Inline Dcompare_inf Zcompare_rec. diff --git a/contrib/extraction/test/custom/fast_integer b/contrib/extraction/test/custom/fast_integer new file mode 100644 index 00000000..e2b24953 --- /dev/null +++ b/contrib/extraction/test/custom/fast_integer @@ -0,0 +1 @@ +Extraction NoInline Zero_suivi_de Un_suivi_de. diff --git a/contrib/extraction/test/e b/contrib/extraction/test/e new file mode 100644 index 00000000..88b6c90b --- /dev/null +++ b/contrib/extraction/test/e @@ -0,0 +1,17 @@ + +(* To trace Extraction, you can use this file via: *) +(* Drop. #use "e";; *) +(* *) + +#use "include";; +open Extraction;; +open Miniml;; +#trace extract_declaration;; +go();; + + + + + + + diff --git a/contrib/extraction/test/extract b/contrib/extraction/test/extract new file mode 100755 index 00000000..83444be3 --- /dev/null +++ b/contrib/extraction/test/extract @@ -0,0 +1,12 @@ +#!/bin/sh +rm -f /tmp/extr$$.v +vfile=`./ml2v $1` +d=`dirname $vfile` +n=`basename $vfile .v` +if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi +echo "Cd \"$d\". Extraction Library $n. " >> /tmp/extr$$.v +../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v +out=$? +rm -f /tmp/extr$$.v +exit $out + diff --git a/contrib/extraction/test/extract.haskell b/contrib/extraction/test/extract.haskell new file mode 100755 index 00000000..d11bc706 --- /dev/null +++ b/contrib/extraction/test/extract.haskell @@ -0,0 +1,12 @@ +#!/bin/sh +rm -f /tmp/extr$$.v +vfile=`./hs2v $1` +d=`dirname $vfile` +n=`basename $vfile .v` +if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi +echo "Cd \"$d\". Extraction Language Haskell. Extraction Library $n. " >> /tmp/extr$$.v +../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v +out=$? +rm -f /tmp/extr$$.v +exit $out + diff --git a/contrib/extraction/test/hs2v.ml b/contrib/extraction/test/hs2v.ml new file mode 100644 index 00000000..fd8b9b26 --- /dev/null +++ b/contrib/extraction/test/hs2v.ml @@ -0,0 +1,14 @@ +let _ = + for j = 1 to ((Array.length Sys.argv)-1) do + let fml = Sys.argv.(j) in + let f = Filename.chop_extension fml in + let fv = f ^ ".v" in + if Sys.file_exists ("../../../" ^ fv) then + print_string (fv^" ") + else + let d = Filename.dirname f in + let b = String.uncapitalize (Filename.basename f) in + let fv = Filename.concat d (b ^ ".v ") in + print_string fv + done; + print_newline() diff --git a/contrib/extraction/test/make_mli b/contrib/extraction/test/make_mli new file mode 100755 index 00000000..40ee496e --- /dev/null +++ b/contrib/extraction/test/make_mli @@ -0,0 +1,17 @@ +#!/usr/bin/awk -We $0 + +{ match($0,"^open") + if (RLENGTH>0) state=1 + match($0,"^type") + if (RLENGTH>0) state=1 + match($0,"^\(\*\* ") + if (RLENGTH>0) state=2 + match($0,"^let") + if (RLENGTH>0) state=0 + match($0,"^and") + if ((RLENGTH>0) && (state==2)) state=0 + if ((RLENGTH>0) && (state==1)) state=1 + gsub("\(\*\* ","") + gsub("\*\*\)","") + if (state>0) print +} diff --git a/contrib/extraction/test/ml2v.ml b/contrib/extraction/test/ml2v.ml new file mode 100644 index 00000000..363ea642 --- /dev/null +++ b/contrib/extraction/test/ml2v.ml @@ -0,0 +1,14 @@ +let _ = + for j = 1 to ((Array.length Sys.argv)-1) do + let fml = Sys.argv.(j) in + let f = Filename.chop_extension fml in + let fv = f ^ ".v" in + if Sys.file_exists ("../../../" ^ fv) then + print_string (fv^" ") + else + let d = Filename.dirname f in + let b = String.capitalize (Filename.basename f) in + let fv = Filename.concat d (b ^ ".v ") in + print_string fv + done; + print_newline() diff --git a/contrib/extraction/test/v2hs.ml b/contrib/extraction/test/v2hs.ml new file mode 100644 index 00000000..88632875 --- /dev/null +++ b/contrib/extraction/test/v2hs.ml @@ -0,0 +1,9 @@ +let _ = + for j = 1 to ((Array.length Sys.argv) -1) do + let s = Sys.argv.(j) in + let b = Filename.chop_extension (Filename.basename s) in + let b = String.capitalize b in + let d = Filename.dirname s in + print_string (Filename.concat d (b ^ ".hs ")) + done; + print_newline() diff --git a/contrib/extraction/test/v2ml.ml b/contrib/extraction/test/v2ml.ml new file mode 100644 index 00000000..245a1b1e --- /dev/null +++ b/contrib/extraction/test/v2ml.ml @@ -0,0 +1,9 @@ +let _ = + for j = 1 to ((Array.length Sys.argv) -1) do + let s = Sys.argv.(j) in + let b = Filename.chop_extension (Filename.basename s) in + let b = String.uncapitalize b in + let d = Filename.dirname s in + print_string (Filename.concat d (b ^ ".ml ")) + done; + print_newline() diff --git a/contrib/extraction/test_extraction.v b/contrib/extraction/test_extraction.v new file mode 100644 index 00000000..0745f62d --- /dev/null +++ b/contrib/extraction/test_extraction.v @@ -0,0 +1,552 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Arith. +Require Import List. + +(*** STANDARD EXAMPLES *) + +(** Functions. *) + +Definition idnat (x:nat) := x. +Extraction idnat. +(* let idnat x = x *) + +Definition id (X:Type) (x:X) := x. +Extraction id. (* let id x = x *) +Definition id' := id Set nat. +Extraction id'. (* type id' = nat *) + +Definition test2 (f:nat -> nat) (x:nat) := f x. +Extraction test2. +(* let test2 f x = f x *) + +Definition test3 (f:nat -> Set -> nat) (x:nat) := f x nat. +Extraction test3. +(* let test3 f x = f x __ *) + +Definition test4 (f:(nat -> nat) -> nat) (x:nat) (g:nat -> nat) := f g. +Extraction test4. +(* let test4 f x g = f g *) + +Definition test5 := (1, 0). +Extraction test5. +(* let test5 = Pair ((S O), O) *) + +Definition cf (x:nat) (_:x <= 0) := S x. +Extraction NoInline cf. +Definition test6 := cf 0 (le_n 0). +Extraction test6. +(* let test6 = cf O *) + +Definition test7 := (fun (X:Set) (x:X) => x) nat. +Extraction test7. +(* let test7 x = x *) + +Definition d (X:Type) := X. +Extraction d. (* type 'x d = 'x *) +Definition d2 := d Set. +Extraction d2. (* type d2 = __ d *) +Definition d3 (x:d Set) := 0. +Extraction d3. (* let d3 _ = O *) +Definition d4 := d nat. +Extraction d4. (* type d4 = nat d *) +Definition d5 := (fun x:d Type => 0) Type. +Extraction d5. (* let d5 = O *) +Definition d6 (x:d Type) := x. +Extraction d6. (* type 'x d6 = 'x *) + +Definition test8 := (fun (X:Type) (x:X) => x) Set nat. +Extraction test8. (* type test8 = nat *) + +Definition test9 := let t := nat in id Set t. +Extraction test9. (* type test9 = nat *) + +Definition test10 := (fun (X:Type) (x:X) => 0) Type Type. +Extraction test10. (* let test10 = O *) + +Definition test11 := let n := 0 in let p := S n in S p. +Extraction test11. (* let test11 = S (S O) *) + +Definition test12 := forall x:forall X:Type, X -> X, x Type Type. +Extraction test12. +(* type test12 = (__ -> __ -> __) -> __ *) + + +Definition test13 := match left True I with + | left x => 1 + | right x => 0 + end. +Extraction test13. (* let test13 = S O *) + + +(** example with more arguments that given by the type *) + +Definition test19 := + nat_rec (fun n:nat => nat -> nat) (fun n:nat => 0) + (fun (n:nat) (f:nat -> nat) => f) 0 0. +Extraction test19. +(* let test19 = + let rec f = function + | O -> (fun n0 -> O) + | S n0 -> f n0 + in f O O +*) + + +(** casts *) + +Definition test20 := True:Type. +Extraction test20. +(* type test20 = __ *) + + +(** Simple inductive type and recursor. *) + +Extraction nat. +(* +type nat = + | O + | S of nat +*) + +Extraction sumbool_rect. +(* +let sumbool_rect f f0 = function + | Left -> f __ + | Right -> f0 __ +*) + +(** Less simple inductive type. *) + +Inductive c (x:nat) : nat -> Set := + | refl : c x x + | trans : forall y z:nat, c x y -> y <= z -> c x z. +Extraction c. +(* +type c = + | Refl + | Trans of nat * nat * c +*) + +Definition Ensemble (U:Type) := U -> Prop. +Definition Empty_set (U:Type) (x:U) := False. +Definition Add (U:Type) (A:Ensemble U) (x y:U) := A y \/ x = y. + +Inductive Finite (U:Type) : Ensemble U -> Set := + | Empty_is_finite : Finite U (Empty_set U) + | Union_is_finite : + forall A:Ensemble U, + Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x). +Extraction Finite. +(* +type 'u finite = + | Empty_is_finite + | Union_is_finite of 'u finite * 'u +*) + + +(** Mutual Inductive *) + +Inductive tree : Set := + Node : nat -> forest -> tree +with forest : Set := + | Leaf : nat -> forest + | Cons : tree -> forest -> forest. + +Extraction tree. +(* +type tree = + | Node of nat * forest +and forest = + | Leaf of nat + | Cons of tree * forest +*) + +Fixpoint tree_size (t:tree) : nat := + match t with + | Node a f => S (forest_size f) + end + + with forest_size (f:forest) : nat := + match f with + | Leaf b => 1 + | Cons t f' => tree_size t + forest_size f' + end. + +Extraction tree_size. +(* +let rec tree_size = function + | Node (a, f) -> S (forest_size f) +and forest_size = function + | Leaf b -> S O + | Cons (t, f') -> plus (tree_size t) (forest_size f') +*) + + +(** Eta-expansions of inductive constructor *) + +Inductive titi : Set := + tata : nat -> nat -> nat -> nat -> titi. +Definition test14 := tata 0. +Extraction test14. +(* let test14 x x0 x1 = Tata (O, x, x0, x1) *) +Definition test15 := tata 0 1. +Extraction test15. +(* let test15 x x0 = Tata (O, (S O), x, x0) *) + +Inductive eta : Set := + eta_c : nat -> Prop -> nat -> Prop -> eta. +Extraction eta_c. +(* +type eta = + | Eta_c of nat * nat +*) +Definition test16 := eta_c 0. +Extraction test16. +(* let test16 x = Eta_c (O, x) *) +Definition test17 := eta_c 0 True. +Extraction test17. +(* let test17 x = Eta_c (O, x) *) +Definition test18 := eta_c 0 True 0. +Extraction test18. +(* let test18 _ = Eta_c (O, O) *) + + +(** Example of singleton inductive type *) + +Inductive bidon (A:Prop) (B:Type) : Set := + tb : forall (x:A) (y:B), bidon A B. +Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) + (x:A) (y:B) := f x y. +Extraction bidon. +(* type 'b bidon = 'b *) +Extraction tb. +(* tb : singleton inductive constructor *) +Extraction fbidon. +(* let fbidon f x y = + f x y +*) + +Definition fbidon2 := fbidon True nat (tb True nat). +Extraction fbidon2. (* let fbidon2 y = y *) +Extraction NoInline fbidon. +Extraction fbidon2. +(* let fbidon2 y = fbidon (fun _ x -> x) __ y *) + +(* NB: first argument of fbidon2 has type [True], so it disappears. *) + +(** mutual inductive on many sorts *) + +Inductive test_0 : Prop := + ctest0 : test_0 +with test_1 : Set := + ctest1 : test_0 -> test_1. +Extraction test_0. +(* test0 : logical inductive *) +Extraction test_1. +(* +type test1 = + | Ctest1 +*) + +(** logical singleton *) + +Extraction eq. +(* eq : logical inductive *) +Extraction eq_rect. +(* let eq_rect x f y = + f +*) + +(** No more propagation of type parameters. Obj.t instead. *) + +Inductive tp1 : Set := + T : forall (C:Set) (c:C), tp2 -> tp1 +with tp2 : Set := + T' : tp1 -> tp2. +Extraction tp1. +(* +type tp1 = + | T of __ * tp2 +and tp2 = + | T' of tp1 +*) + +Inductive tp1bis : Set := + Tbis : tp2bis -> tp1bis +with tp2bis : Set := + T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis. +Extraction tp1bis. +(* +type tp1bis = + | Tbis of tp2bis +and tp2bis = + | T'bis of __ * tp1bis +*) + + +(** Strange inductive type. *) + +Inductive Truc : Set -> Set := + | chose : forall A:Set, Truc A + | machin : forall A:Set, A -> Truc bool -> Truc A. +Extraction Truc. +(* +type 'x truc = + | Chose + | Machin of 'x * bool truc +*) + + +(** Dependant type over Type *) + +Definition test24 := sigT (fun a:Set => option a). +Extraction test24. +(* type test24 = (__, __ option) sigT *) + + +(** Coq term non strongly-normalizable after extraction *) + +Require Import Gt. +Definition loop (Ax:Acc gt 0) := + (fix F (a:nat) (b:Acc gt a) {struct b} : nat := + F (S a) (Acc_inv b (S a) (gt_Sn_n a))) 0 Ax. +Extraction loop. +(* let loop _ = + let rec f a = + f (S a) + in f O +*) + +(*** EXAMPLES NEEDING OBJ.MAGIC *) + +(** False conversion of type: *) + +Lemma oups : forall H:nat = list nat, nat -> nat. +intros. +generalize H0; intros. +rewrite H in H1. +case H1. +exact H0. +intros. +exact n. +Qed. +Extraction oups. +(* +let oups h0 = + match Obj.magic h0 with + | Nil -> h0 + | Cons0 (n, l) -> n +*) + + +(** hybrids *) + +Definition horibilis (b:bool) := + if b as b return (if b then Type else nat) then Set else 0. +Extraction horibilis. +(* +let horibilis = function + | True -> Obj.magic __ + | False -> Obj.magic O +*) + +Definition PropSet (b:bool) := if b then Prop else Set. +Extraction PropSet. (* type propSet = __ *) + +Definition natbool (b:bool) := if b then nat else bool. +Extraction natbool. (* type natbool = __ *) + +Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true. +Extraction zerotrue. +(* +let zerotrue = function + | True -> Obj.magic O + | False -> Obj.magic True +*) + +Definition natProp (b:bool) := if b return Type then nat else Prop. + +Definition natTrue (b:bool) := if b return Type then nat else True. + +Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True. +Extraction zeroTrue. +(* +let zeroTrue = function + | True -> Obj.magic O + | False -> Obj.magic __ +*) + +Definition natTrue2 (b:bool) := if b return Type then nat else True. + +Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I. +Extraction zeroprop. +(* +let zeroprop = function + | True -> Obj.magic O + | False -> Obj.magic __ +*) + +(** polymorphic f applied several times *) + +Definition test21 := (id nat 0, id bool true). +Extraction test21. +(* let test21 = Pair ((id O), (id True)) *) + +(** ok *) + +Definition test22 := + (fun f:forall X:Type, X -> X => (f nat 0, f bool true)) + (fun (X:Type) (x:X) => x). +Extraction test22. +(* let test22 = + let f = fun x -> x in Pair ((f O), (f True)) *) + +(* still ok via optim beta -> let *) + +Definition test23 (f:forall X:Type, X -> X) := (f nat 0, f bool true). +Extraction test23. +(* let test23 f = Pair ((Obj.magic f __ O), (Obj.magic f __ True)) *) + +(* problem: fun f -> (f 0, f true) not legal in ocaml *) +(* solution: magic ... *) + + +(** Dummy constant __ can be applied.... *) + +Definition f (X:Type) (x:nat -> X) (y:X -> bool) : bool := y (x 0). +Extraction f. +(* let f x y = + y (x O) +*) + +Definition f_prop := f (0 = 0) (fun _ => refl_equal 0) (fun _ => true). +Extraction NoInline f. +Extraction f_prop. +(* let f_prop = + f (Obj.magic __) (fun _ -> True) +*) + +Definition f_arity := f Set (fun _:nat => nat) (fun _:Set => true). +Extraction f_arity. +(* let f_arity = + f (Obj.magic __) (fun _ -> True) +*) + +Definition f_normal := + f nat (fun x => x) (fun x => match x with + | O => true + | _ => false + end). +Extraction f_normal. +(* let f_normal = + f (fun x -> x) (fun x -> match x with + | O -> True + | S n -> False) +*) + + +(* inductive with magic needed *) + +Inductive Boite : Set := + boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. +Extraction Boite. +(* +type boite = + | Boite of bool * __ +*) + + +Definition boite1 := boite true 0. +Extraction boite1. +(* let boite1 = Boite (True, (Obj.magic O)) *) + +Definition boite2 := boite false (0, 0). +Extraction boite2. +(* let boite2 = Boite (False, (Obj.magic (Pair (O, O)))) *) + +Definition test_boite (B:Boite) := + match B return nat with + | boite true n => n + | boite false n => fst n + snd n + end. +Extraction test_boite. +(* +let test_boite = function + | Boite (b0, n) -> + (match b0 with + | True -> Obj.magic n + | False -> plus (fst (Obj.magic n)) (snd (Obj.magic n))) +*) + +(* singleton inductive with magic needed *) + +Inductive Box : Set := + box : forall A:Set, A -> Box. +Extraction Box. +(* type box = __ *) + +Definition box1 := box nat 0. +Extraction box1. (* let box1 = Obj.magic O *) + +(* applied constant, magic needed *) + +Definition idzarb (b:bool) (x:if b then nat else bool) := x. +Definition zarb := idzarb true 0. +Extraction NoInline idzarb. +Extraction zarb. +(* let zarb = Obj.magic idzarb True (Obj.magic O) *) + +(** function of variable arity. *) +(** Fun n = nat -> nat -> ... -> nat *) + +Fixpoint Fun (n:nat) : Set := + match n with + | O => nat + | S n => nat -> Fun n + end. + +Fixpoint Const (k n:nat) {struct n} : Fun n := + match n as x return Fun x with + | O => k + | S n => fun p:nat => Const k n + end. + +Fixpoint proj (k n:nat) {struct n} : Fun n := + match n as x return Fun x with + | O => 0 (* ou assert false ....*) + | S n => + match k with + | O => fun x => Const x n + | S k => fun x => proj k n + end + end. + +Definition test_proj := proj 2 4 0 1 2 3. + +Eval compute in test_proj. + +Recursive Extraction test_proj. + + + +(*** TO SUM UP: ***) + + +Extraction + "test_extraction.ml" idnat id id' test2 test3 test4 test5 test6 test7 d d2 + d3 d4 d5 d6 test8 id id' test9 test10 test11 test12 + test13 test19 test20 nat sumbool_rect c Finite tree + tree_size test14 test15 eta_c test16 test17 test18 bidon + tb fbidon fbidon2 fbidon2 test_0 test_1 eq eq_rect tp1 + tp1bis Truc oups test24 loop horibilis PropSet natbool + zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop + f_arity f_normal Boite boite1 boite2 test_boite Box box1 + zarb test_proj. + diff --git a/contrib/field/Field.v b/contrib/field/Field.v new file mode 100644 index 00000000..7b48e275 --- /dev/null +++ b/contrib/field/Field.v @@ -0,0 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Field.v,v 1.6.2.1 2004/07/16 19:30:09 herbelin Exp $ *) + +Require Export Field_Compl. +Require Export Field_Theory. +Require Export Field_Tactic. + +(* Command declarations are moved to the ML side *)
\ No newline at end of file diff --git a/contrib/field/Field_Compl.v b/contrib/field/Field_Compl.v new file mode 100644 index 00000000..cba921f7 --- /dev/null +++ b/contrib/field/Field_Compl.v @@ -0,0 +1,61 @@ +(************************************************************************) +(* 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: Field_Compl.v,v 1.8.2.1 2004/07/16 19:30:09 herbelin Exp $ *) + +Inductive listT (A:Type) : Type := + | nilT : listT A + | consT : A -> listT A -> listT A. + +Fixpoint appT (A:Type) (l m:listT A) {struct l} : listT A := + match l with + | nilT => m + | consT a l1 => consT A a (appT A l1 m) + end. + +Inductive prodT (A B:Type) : Type := + pairT : A -> B -> prodT A B. + +Definition assoc_2nd := + (fix assoc_2nd_rec (A:Type) (B:Set) + (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2}) + (lst:listT (prodT A B)) {struct lst} : + B -> A -> A := + fun (key:B) (default:A) => + match lst with + | nilT => default + | consT (pairT v e) l => + match eq_dec e key with + | left _ => v + | right _ => assoc_2nd_rec A B eq_dec l key default + end + end). + +Definition fstT (A B:Type) (c:prodT A B) := match c with + | pairT a _ => a + end. + +Definition sndT (A B:Type) (c:prodT A B) := match c with + | pairT _ a => a + end. + +Definition mem := + (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) + (a:A) (l:listT A) {struct l} : bool := + match l with + | nilT => false + | consT a1 l1 => + match eq_dec a a1 with + | left _ => true + | right _ => mem A eq_dec a l1 + end + end). + +Inductive field_rel_option (A:Type) : Type := + | Field_None : field_rel_option A + | Field_Some : (A -> A -> A) -> field_rel_option A.
\ No newline at end of file diff --git a/contrib/field/Field_Tactic.v b/contrib/field/Field_Tactic.v new file mode 100644 index 00000000..c5c06547 --- /dev/null +++ b/contrib/field/Field_Tactic.v @@ -0,0 +1,432 @@ +(************************************************************************) +(* 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: Field_Tactic.v,v 1.20.2.1 2004/07/16 19:30:09 herbelin Exp $ *) + +Require Import Ring. +Require Export Field_Compl. +Require Export Field_Theory. + +(**** Interpretation A --> ExprA ****) + +Ltac mem_assoc var lvar := + match constr:lvar with + | (nilT _) => constr:false + | (consT _ ?X1 ?X2) => + match constr:(X1 = var) with + | (?X1 = ?X1) => constr:true + | _ => mem_assoc var X2 + end + end. + +Ltac seek_var_aux FT lvar trm := + let AT := eval cbv beta iota delta [A] in (A FT) + with AzeroT := eval cbv beta iota delta [Azero] in (Azero FT) + with AoneT := eval cbv beta iota delta [Aone] in (Aone FT) + with AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) + with AmultT := eval cbv beta iota delta [Amult] in (Amult FT) + with AoppT := eval cbv beta iota delta [Aopp] in (Aopp FT) + with AinvT := eval cbv beta iota delta [Ainv] in (Ainv FT) in + match constr:trm with + | AzeroT => lvar + | AoneT => lvar + | (AplusT ?X1 ?X2) => + let l1 := seek_var_aux FT lvar X1 in + seek_var_aux FT l1 X2 + | (AmultT ?X1 ?X2) => + let l1 := seek_var_aux FT lvar X1 in + seek_var_aux FT l1 X2 + | (AoppT ?X1) => seek_var_aux FT lvar X1 + | (AinvT ?X1) => seek_var_aux FT lvar X1 + | ?X1 => + let res := mem_assoc X1 lvar in + match constr:res with + | true => lvar + | false => constr:(consT AT X1 lvar) + end + end. + +Ltac seek_var FT trm := + let AT := eval cbv beta iota delta [A] in (A FT) in + seek_var_aux FT (nilT AT) trm. + +Ltac number_aux lvar cpt := + match constr:lvar with + | (nilT ?X1) => constr:(nilT (prodT X1 nat)) + | (consT ?X1 ?X2 ?X3) => + let l2 := number_aux X3 (S cpt) in + constr:(consT (prodT X1 nat) (pairT X1 nat X2 cpt) l2) + end. + +Ltac number lvar := number_aux lvar 0. + +Ltac build_varlist FT trm := let lvar := seek_var FT trm in + number lvar. + +Ltac assoc elt lst := + match constr:lst with + | (nilT _) => fail + | (consT (prodT _ nat) (pairT _ nat ?X1 ?X2) ?X3) => + match constr:(elt = X1) with + | (?X1 = ?X1) => constr:X2 + | _ => assoc elt X3 + end + end. + +Ltac interp_A FT lvar trm := + let AT := 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 => constr:EAzero + | AoneT => constr:EAone + | (AplusT ?X1 ?X2) => + let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in + constr:(EAplus e1 e2) + | (AmultT ?X1 ?X2) => + let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in + constr:(EAmult e1 e2) + | (AoppT ?X1) => + let e := interp_A FT lvar X1 in + constr:(EAopp e) + | (AinvT ?X1) => let e := interp_A FT lvar X1 in + constr:(EAinv e) + | ?X1 => let idx := assoc X1 lvar in + constr:(EAvar idx) + end. + +(************************) +(* Simplification *) +(************************) + +(**** Generation of the multiplier ****) + +Ltac remove e l := + match constr:l with + | (nilT _) => l + | (consT ?X1 e ?X2) => constr:X2 + | (consT ?X1 ?X2 ?X3) => let nl := remove e X3 in + constr:(consT X1 X2 nl) + end. + +Ltac union l1 l2 := + match constr:l1 with + | (nilT _) => l2 + | (consT ?X1 ?X2 ?X3) => + let nl2 := remove X2 l2 in + let nl := union X3 nl2 in + constr:(consT X1 X2 nl) + end. + +Ltac raw_give_mult trm := + match constr:trm with + | (EAinv ?X1) => constr:(consT ExprA X1 (nilT ExprA)) + | (EAopp ?X1) => raw_give_mult X1 + | (EAplus ?X1 ?X2) => + let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in + union l1 l2 + | (EAmult ?X1 ?X2) => + let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in + eval compute in (appT ExprA l1 l2) + | _ => constr:(nilT ExprA) + end. + +Ltac give_mult trm := + let ltrm := raw_give_mult trm in + constr:(mult_of_list ltrm). + +(**** Associativity ****) + +Ltac apply_assoc FT lvar trm := + let t := eval compute in (assoc trm) in + match constr:(t = trm) with + | (?X1 = ?X1) => idtac + | _ => + rewrite <- (assoc_correct FT trm); change (assoc trm) with t in |- * + end. + +(**** Distribution *****) + +Ltac apply_distrib FT lvar trm := + let t := eval compute in (distrib trm) in + match constr:(t = trm) with + | (?X1 = ?X1) => idtac + | _ => + rewrite <- (distrib_correct FT trm); + change (distrib trm) with t in |- * + end. + +(**** Multiplication by the inverse product ****) + +Ltac grep_mult := match goal with + | id:(interp_ExprA _ _ _ <> _) |- _ => id + end. + +Ltac weak_reduce := + match goal with + | |- context [(interp_ExprA ?X1 ?X2 _)] => + cbv beta iota zeta + delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero + Aone Aplus Amult Aopp Ainv] in |- * + end. + +Ltac multiply mul := + match goal with + | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA ?X1 ?X2 ?X4) => + let AzeroT := eval cbv beta iota delta [Azero X1] in (Azero X1) in + (cut (interp_ExprA X1 X2 mul <> AzeroT); + [ intro; let id := grep_mult in + apply (mult_eq X1 X3 X4 mul X2 id) + | weak_reduce; + let AoneT := eval cbv beta iota delta [Aone X1] in (Aone X1) + with AmultT := eval cbv beta iota delta [Amult X1] in (Amult X1) in + (try + match goal with + | |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r X1) + end; clear X1 X2) ]) + end. + +Ltac apply_multiply FT lvar trm := + let t := eval compute in (multiply trm) in + match constr:(t = trm) with + | (?X1 = ?X1) => idtac + | _ => + rewrite <- (multiply_correct FT trm); + change (multiply trm) with t in |- * + end. + +(**** Permutations and simplification ****) + +Ltac apply_inverse mul FT lvar trm := + let t := eval compute in (inverse_simplif mul trm) in + match constr:(t = trm) with + | (?X1 = ?X1) => idtac + | _ => + rewrite <- (inverse_correct FT trm mul); + [ change (inverse_simplif mul trm) with t in |- * | assumption ] + end. +(**** Inverse test ****) + +Ltac strong_fail tac := first [ tac | fail 2 ]. + +Ltac inverse_test_aux FT trm := + let AplusT := 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 + | (AinvT _) => fail 1 + | (AoppT ?X1) => + strong_fail ltac:(inverse_test_aux FT X1; idtac) + | (AplusT ?X1 ?X2) => + strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2) + | (AmultT ?X1 ?X2) => + strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2) + | _ => idtac + end. + +Ltac inverse_test FT := + let AplusT := eval cbv beta iota delta [Aplus] in (Aplus FT) in + match goal with + | |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2) + end. + +(**** Field itself ****) + +Ltac apply_simplif sfun := + match goal with + | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => + sfun X1 X2 X3 + end; + match goal with + | |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => + sfun X1 X2 X3 + end. + +Ltac unfolds FT := + match eval cbv beta iota delta [Aminus] in (Aminus FT) with + | (Field_Some _ ?X1) => unfold X1 in |- * + | _ => idtac + end; + match eval cbv beta iota delta [Adiv] in (Adiv FT) with + | (Field_Some _ ?X1) => unfold X1 in |- * + | _ => idtac + end. + +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 + (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 + match goal with + | |- (?X1 = ?X2) => + let lvar := build_varlist FT (AplusT X1 X2) in + let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in + let mul := give_mult (EAplus trm1 trm2) in + (cut + (let ft := FT in + let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2); + [ compute in |- *; auto + | intros ft vm; apply_simplif apply_distrib; + apply_simplif apply_assoc; multiply mul; + [ apply_simplif apply_multiply; + apply_simplif ltac:(apply_inverse mul); + let id := grep_mult in + clear id; weak_reduce; clear ft vm; first + [ inverse_test FT; ring | field_gen_aux FT ] + | idtac ] ]) + end. + +Ltac field_gen FT := unfolds FT; (inverse_test FT; ring) || field_gen_aux FT. + +(*****************************) +(* Term Simplification *) +(*****************************) + +(**** Minus and division expansions ****) + +Ltac init_exp FT trm := + let e := + (match eval cbv beta iota delta [Aminus] in (Aminus FT) with + | (Field_Some _ ?X1) => eval cbv beta delta [X1] in trm + | _ => trm + end) in + match eval cbv beta iota delta [Adiv] in (Adiv FT) with + | (Field_Some _ ?X1) => eval cbv beta delta [X1] in e + | _ => e + end. + +(**** Inverses simplification ****) + +Ltac simpl_inv trm := + match constr:trm with + | (EAplus ?X1 ?X2) => + let e1 := simpl_inv X1 with e2 := simpl_inv X2 in + constr:(EAplus e1 e2) + | (EAmult ?X1 ?X2) => + let e1 := simpl_inv X1 with e2 := simpl_inv X2 in + constr:(EAmult e1 e2) + | (EAopp ?X1) => let e := simpl_inv X1 in + constr:(EAopp e) + | (EAinv ?X1) => SimplInvAux X1 + | ?X1 => constr:X1 + end + with SimplInvAux trm := + match constr:trm with + | (EAinv ?X1) => simpl_inv X1 + | (EAmult ?X1 ?X2) => + let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in + constr:(EAmult e1 e2) + | ?X1 => let e := simpl_inv X1 in + constr:(EAinv e) + end. + +(**** Monom simplification ****) + +Ltac map_tactic fcn lst := + match constr:lst with + | (nilT _) => lst + | (consT ?X1 ?X2 ?X3) => + let r := fcn X2 with t := map_tactic fcn X3 in + constr:(consT X1 r t) + end. + +Ltac build_monom_aux lst trm := + match constr:lst with + | (nilT _) => eval compute in (assoc trm) + | (consT _ ?X1 ?X2) => build_monom_aux X2 (EAmult trm X1) + end. + +Ltac build_monom lnum lden := + let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in + let ltot := eval compute in (appT ExprA lnum ildn) in + let trm := build_monom_aux ltot EAone in + match constr:trm with + | (EAmult _ ?X1) => constr:X1 + | ?X1 => constr:X1 + end. + +Ltac simpl_monom_aux lnum lden trm := + match constr:trm with + | (EAmult (EAinv ?X1) ?X2) => + let mma := mem_assoc X1 lnum in + match constr:mma with + | true => + let newlnum := remove X1 lnum in + simpl_monom_aux newlnum lden X2 + | false => simpl_monom_aux lnum (consT ExprA X1 lden) X2 + end + | (EAmult ?X1 ?X2) => + let mma := mem_assoc X1 lden in + match constr:mma with + | true => + let newlden := remove X1 lden in + simpl_monom_aux lnum newlden X2 + | false => simpl_monom_aux (consT ExprA X1 lnum) lden X2 + end + | (EAinv ?X1) => + let mma := mem_assoc X1 lnum in + match constr:mma with + | true => + let newlnum := remove X1 lnum in + build_monom newlnum lden + | false => build_monom lnum (consT ExprA X1 lden) + end + | ?X1 => + let mma := mem_assoc X1 lden in + match constr:mma with + | true => + let newlden := remove X1 lden in + build_monom lnum newlden + | false => build_monom (consT ExprA X1 lnum) lden + end + end. + +Ltac simpl_monom trm := simpl_monom_aux (nilT ExprA) (nilT ExprA) trm. + +Ltac simpl_all_monomials trm := + match constr:trm with + | (EAplus ?X1 ?X2) => + let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in + constr:(EAplus e1 e2) + | ?X1 => simpl_monom X1 + end. + +(**** Associativity and distribution ****) + +Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)). + +(**** The tactic Field_Term ****) + +Ltac eval_weak_reduce trm := + eval + cbv beta iota zeta + delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus + Amult Aopp Ainv] in trm. + +Ltac field_term FT exp := + let newexp := init_exp FT exp in + let lvar := build_varlist FT newexp in + let trm := interp_A FT lvar newexp in + let tma := eval compute in (assoc trm) in + let tsmp := + simpl_all_monomials + ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in + let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in + (replace exp with trep; [ ring trep | field_gen FT ]).
\ No newline at end of file diff --git a/contrib/field/Field_Theory.v b/contrib/field/Field_Theory.v new file mode 100644 index 00000000..8737fd79 --- /dev/null +++ b/contrib/field/Field_Theory.v @@ -0,0 +1,645 @@ +(************************************************************************) +(* 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: Field_Theory.v,v 1.12.2.1 2004/07/16 19:30:09 herbelin Exp $ *) + +Require Import Peano_dec. +Require Import Ring. +Require Import Field_Compl. + +Record Field_Theory : Type := + {A : Type; + Aplus : A -> A -> A; + Amult : A -> A -> A; + Aone : A; + Azero : A; + Aopp : A -> A; + Aeq : A -> A -> bool; + Ainv : A -> A; + Aminus : field_rel_option A; + Adiv : field_rel_option A; + RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq; + Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}. + +(* The reflexion structure *) +Inductive ExprA : Set := + | EAzero : ExprA + | EAone : ExprA + | EAplus : ExprA -> ExprA -> ExprA + | EAmult : ExprA -> ExprA -> ExprA + | EAopp : ExprA -> ExprA + | EAinv : ExprA -> ExprA + | EAvar : nat -> ExprA. + +(**** Decidability of equality ****) + +Lemma eqExprA_O : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}. +Proof. + double induction e1 e2; try intros; + try (left; reflexivity) || (try (right; discriminate)). + elim (H1 e0); intro y; elim (H2 e); intro y0; + try + (left; rewrite y; rewrite y0; auto) || + (right; red in |- *; intro; inversion H3; auto). + elim (H1 e0); intro y; elim (H2 e); intro y0; + try + (left; rewrite y; rewrite y0; auto) || + (right; red in |- *; intro; inversion H3; auto). + elim (H0 e); intro y. + left; rewrite y; auto. + right; red in |- *; intro; inversion H1; auto. + elim (H0 e); intro y. + left; rewrite y; auto. + right; red in |- *; intro; inversion H1; auto. + elim (eq_nat_dec n n0); intro y. + left; rewrite y; auto. + right; red in |- *; intro; inversion H; auto. +Defined. + +Definition eq_nat_dec := Eval compute in eq_nat_dec. +Definition eqExprA := Eval compute in eqExprA_O. + +(**** Generation of the multiplier ****) + +Fixpoint mult_of_list (e:listT ExprA) : ExprA := + match e with + | nilT => EAone + | consT e1 l1 => EAmult e1 (mult_of_list l1) + end. + +Section Theory_of_fields. + +Variable T : Field_Theory. + +Let AT := A T. +Let AplusT := Aplus T. +Let AmultT := Amult T. +Let AoneT := Aone T. +Let AzeroT := Azero T. +Let AoppT := Aopp T. +Let AeqT := Aeq T. +Let AinvT := Ainv T. +Let RTT := RT T. +Let Th_inv_defT := Th_inv_def T. + +Add Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) ( + Azero T) (Aopp T) (Aeq T) (RT T). + +Add Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT. + +(***************************) +(* Lemmas to be used *) +(***************************) + +Lemma AplusT_sym : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1. +Proof. + intros; ring. +Qed. + +Lemma AplusT_assoc : + forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3). +Proof. + intros; ring. +Qed. + +Lemma AmultT_sym : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1. +Proof. + intros; ring. +Qed. + +Lemma AmultT_assoc : + forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3). +Proof. + intros; ring. +Qed. + +Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r. +Proof. + intros; ring. +Qed. + +Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r. +Proof. + intros; ring. +Qed. + +Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT. +Proof. + intros; ring. +Qed. + +Lemma AmultT_AplusT_distr : + forall r1 r2 r3:AT, + AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3). +Proof. + intros; ring. +Qed. + +Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2. +Proof. + intros; transitivity (AplusT (AplusT (AoppT r) r) r1). + ring. + transitivity (AplusT (AplusT (AoppT r) r) r2). + repeat rewrite AplusT_assoc; rewrite <- H; reflexivity. + ring. +Qed. + +Lemma r_AmultT_mult : + forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2. +Proof. + intros; transitivity (AmultT (AmultT (AinvT r) r) r1). + rewrite Th_inv_defT; [ symmetry in |- *; apply AmultT_1l; auto | auto ]. + transitivity (AmultT (AmultT (AinvT r) r) r2). + repeat rewrite AmultT_assoc; rewrite H; trivial. + rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ]. +Qed. + +Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT. +Proof. + intro; ring. +Qed. + +Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT. +Proof. + intro; ring. +Qed. + +Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r. +Proof. + intro; ring. +Qed. + +Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT. +Proof. + intros; rewrite AmultT_sym; apply Th_inv_defT; auto. +Qed. + +Lemma Rmult_neq_0_reg : + forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT. +Proof. + intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; ring. +Qed. + +(************************) +(* Interpretation *) +(************************) + +(**** ExprA --> A ****) + +Fixpoint interp_ExprA (lvar:listT (prodT AT nat)) (e:ExprA) {struct e} : + AT := + match e with + | EAzero => AzeroT + | EAone => AoneT + | EAplus e1 e2 => AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2) + | EAmult e1 e2 => AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2) + | EAopp e => Aopp T (interp_ExprA lvar e) + | EAinv e => Ainv T (interp_ExprA lvar e) + | EAvar n => assoc_2nd AT nat eq_nat_dec lvar n AzeroT + end. + +(************************) +(* Simplification *) +(************************) + +(**** Associativity ****) + +Definition merge_mult := + (fix merge_mult (e1:ExprA) : ExprA -> ExprA := + fun e2:ExprA => + match e1 with + | EAmult t1 t2 => + match t2 with + | EAmult t2 t3 => EAmult t1 (EAmult t2 (merge_mult t3 e2)) + | _ => EAmult t1 (EAmult t2 e2) + end + | _ => EAmult e1 e2 + end). + +Fixpoint assoc_mult (e:ExprA) : ExprA := + match e with + | EAmult e1 e3 => + match e1 with + | EAmult e1 e2 => + merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2)) + (assoc_mult e3) + | _ => EAmult e1 (assoc_mult e3) + end + | _ => e + end. + +Definition merge_plus := + (fix merge_plus (e1:ExprA) : ExprA -> ExprA := + fun e2:ExprA => + match e1 with + | EAplus t1 t2 => + match t2 with + | EAplus t2 t3 => EAplus t1 (EAplus t2 (merge_plus t3 e2)) + | _ => EAplus t1 (EAplus t2 e2) + end + | _ => EAplus e1 e2 + end). + +Fixpoint assoc (e:ExprA) : ExprA := + match e with + | EAplus e1 e3 => + match e1 with + | EAplus e1 e2 => + merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3) + | _ => EAplus (assoc_mult e1) (assoc e3) + end + | _ => assoc_mult e + end. + +Lemma merge_mult_correct1 : + forall (e1 e2 e3:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) = + interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)). +Proof. +intros e1 e2; generalize e1; generalize e2; clear e1 e2. +simple induction e2; auto; intros. +unfold merge_mult at 1 in |- *; fold merge_mult in |- *; + unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *; + rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *; + fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *; + fold interp_ExprA in |- *; auto. +Qed. + +Lemma merge_mult_correct : + forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2). +Proof. +simple induction e1; auto; intros. +elim e0; try (intros; simpl in |- *; ring). +unfold interp_ExprA in H2; fold interp_ExprA in H2; + cut + (AmultT (interp_ExprA lvar e2) + (AmultT (interp_ExprA lvar e4) + (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))) = + AmultT + (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4)) + (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). +intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1; + simpl in |- *; ring. +ring. +Qed. + +Lemma assoc_mult_correct1 : + forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + AmultT (interp_ExprA lvar (assoc_mult e1)) + (interp_ExprA lvar (assoc_mult e2)) = + interp_ExprA lvar (assoc_mult (EAmult e1 e2)). +Proof. +simple induction e1; auto; intros. +rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct; + simpl in |- *; rewrite merge_mult_correct; simpl in |- *; + auto. +Qed. + +Lemma assoc_mult_correct : + forall (e:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e. +Proof. +simple induction e; auto; intros. +elim e0; intros. +intros; simpl in |- *; ring. +simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1))); + rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite merge_mult_correct; simpl in |- *; + rewrite merge_mult_correct; simpl in |- *; rewrite AmultT_assoc; + rewrite assoc_mult_correct1; rewrite H2; simpl in |- *; + rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1; + fold interp_ExprA in H1; rewrite (H0 lvar) in H1; + rewrite (AmultT_sym (interp_ExprA lvar e3) (interp_ExprA lvar e1)); + rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; + ring. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +Qed. + +Lemma merge_plus_correct1 : + forall (e1 e2 e3:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) = + interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)). +Proof. +intros e1 e2; generalize e1; generalize e2; clear e1 e2. +simple induction e2; auto; intros. +unfold merge_plus at 1 in |- *; fold merge_plus in |- *; + unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *; + rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *; + fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *; + fold interp_ExprA in |- *; auto. +Qed. + +Lemma merge_plus_correct : + forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2). +Proof. +simple induction e1; auto; intros. +elim e0; try intros; try (simpl in |- *; ring). +unfold interp_ExprA in H2; fold interp_ExprA in H2; + cut + (AplusT (interp_ExprA lvar e2) + (AplusT (interp_ExprA lvar e4) + (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))) = + AplusT + (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4)) + (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). +intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1; + simpl in |- *; ring. +ring. +Qed. + +Lemma assoc_plus_correct : + forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) = + interp_ExprA lvar (assoc (EAplus e1 e2)). +Proof. +simple induction e1; auto; intros. +rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct; + simpl in |- *; rewrite merge_plus_correct; simpl in |- *; + auto. +Qed. + +Lemma assoc_correct : + forall (e:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (assoc e) = interp_ExprA lvar e. +Proof. +simple induction e; auto; intros. +elim e0; intros. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite merge_plus_correct; simpl in |- *; + rewrite merge_plus_correct; simpl in |- *; rewrite AplusT_assoc; + rewrite assoc_plus_correct; rewrite H2; simpl in |- *; + apply + (r_AplusT_plus (interp_ExprA lvar (assoc e1)) + (AplusT (interp_ExprA lvar (assoc e2)) + (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1))) + (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3)) + (interp_ExprA lvar e1))); rewrite <- AplusT_assoc; + rewrite + (AplusT_sym (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) + ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; + rewrite (H0 lvar); + rewrite <- + (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1)) + (interp_ExprA lvar e3) (interp_ExprA lvar e1)) + ; + rewrite + (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1) + (interp_ExprA lvar e3)); + rewrite (AplusT_sym (interp_ExprA lvar e1) (interp_ExprA lvar e3)); + rewrite <- + (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3) + (interp_ExprA lvar e1)); apply AplusT_sym. +unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; + fold interp_ExprA in |- *; rewrite assoc_mult_correct; + rewrite (H0 lvar); simpl in |- *; auto. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +simpl in |- *; rewrite (H0 lvar); auto. +unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; + fold interp_ExprA in |- *; rewrite assoc_mult_correct; + simpl in |- *; auto. +Qed. + +(**** Distribution *****) + +Fixpoint distrib_EAopp (e:ExprA) : ExprA := + match e with + | EAplus e1 e2 => EAplus (distrib_EAopp e1) (distrib_EAopp e2) + | EAmult e1 e2 => EAmult (distrib_EAopp e1) (distrib_EAopp e2) + | EAopp e => EAmult (EAopp EAone) (distrib_EAopp e) + | e => e + end. + +Definition distrib_mult_right := + (fix distrib_mult_right (e1:ExprA) : ExprA -> ExprA := + fun e2:ExprA => + match e1 with + | EAplus t1 t2 => + EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2) + | _ => EAmult e1 e2 + end). + +Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA := + match e1 with + | EAplus t1 t2 => + EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2) + | _ => distrib_mult_right e2 e1 + end. + +Fixpoint distrib_main (e:ExprA) : ExprA := + match e with + | EAmult e1 e2 => distrib_mult_left (distrib_main e1) (distrib_main e2) + | EAplus e1 e2 => EAplus (distrib_main e1) (distrib_main e2) + | EAopp e => EAopp (distrib_main e) + | _ => e + end. + +Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e). + +Lemma distrib_mult_right_correct : + forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (distrib_mult_right e1 e2) = + AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). +Proof. +simple induction e1; try intros; simpl in |- *; auto. +rewrite AmultT_sym; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar); + rewrite (H0 e2 lvar); ring. +Qed. + +Lemma distrib_mult_left_correct : + forall (e1 e2:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (distrib_mult_left e1 e2) = + AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). +Proof. +simple induction e1; try intros; simpl in |- *. +rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *; + apply AmultT_Or. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. +rewrite AmultT_sym; + rewrite + (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e) + (interp_ExprA lvar e0)); + rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e)); + rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e0)); + rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. +Qed. + +Lemma distrib_correct : + forall (e:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (distrib e) = interp_ExprA lvar e. +Proof. +simple induction e; intros; auto. +simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar); + unfold distrib in |- *; simpl in |- *; auto. +simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar); + unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct. +simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar); + unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct; + simpl in |- *; fold AoppT in |- *; ring. +Qed. + +(**** Multiplication by the inverse product ****) + +Lemma mult_eq : + forall (e1 e2 a:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) -> + interp_ExprA lvar e1 = interp_ExprA lvar e2. +Proof. + simpl in |- *; intros; + apply + (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1) + (interp_ExprA lvar e2)); assumption. +Qed. + +Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA := + match e with + | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2) + | _ => EAmult a e + end. + +Definition multiply (e:ExprA) : ExprA := + match e with + | EAmult a e1 => multiply_aux a e1 + | _ => e + end. + +Lemma multiply_aux_correct : + forall (a e:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (multiply_aux a e) = + AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). +Proof. +simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct; + auto. + simpl in |- *; rewrite (H0 lvar); ring. +Qed. + +Lemma multiply_correct : + forall (e:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar (multiply e) = interp_ExprA lvar e. +Proof. + simple induction e; simpl in |- *; auto. + intros; apply multiply_aux_correct. +Qed. + +(**** Permutations and simplification ****) + +Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA := + match m with + | EAmult m0 m1 => + match eqExprA m0 (EAinv a) with + | left _ => m1 + | right _ => EAmult m0 (monom_remove a m1) + end + | _ => + match eqExprA m (EAinv a) with + | left _ => EAone + | right _ => EAmult a m + end + end. + +Definition monom_simplif_rem := + (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA := + fun m:ExprA => + match a with + | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m) + | _ => monom_remove a m + end). + +Definition monom_simplif (a m:ExprA) : ExprA := + match m with + | EAmult a' m' => + match eqExprA a a' with + | left _ => monom_simplif_rem a m' + | right _ => m + end + | _ => m + end. + +Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA := + match e with + | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2) + | _ => monom_simplif a e + end. + +Lemma monom_remove_correct : + forall (e a:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (monom_remove a e) = + AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). +Proof. +simple induction e; intros. +simpl in |- *; case (eqExprA EAzero (EAinv a)); intros; + [ inversion e0 | simpl in |- *; trivial ]. +simpl in |- *; case (eqExprA EAone (EAinv a)); intros; + [ inversion e0 | simpl in |- *; trivial ]. +simpl in |- *; case (eqExprA (EAplus e0 e1) (EAinv a)); intros; + [ inversion e2 | simpl in |- *; trivial ]. +simpl in |- *; case (eqExprA e0 (EAinv a)); intros. +rewrite e2; simpl in |- *; fold AinvT in |- *. +rewrite <- + (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a)) + (interp_ExprA lvar e1)); rewrite AinvT_r; [ ring | assumption ]. +simpl in |- *; rewrite H0; auto; ring. +simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a)); + intros; [ inversion e1 | simpl in |- *; trivial ]. +unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros. +case (eqExprA e0 a); intros. +rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto. +inversion e1; simpl in |- *; elimtype False; auto. +simpl in |- *; trivial. +unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros; + [ inversion e0 | simpl in |- *; trivial ]. +Qed. + +Lemma monom_simplif_rem_correct : + forall (a e:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (monom_simplif_rem a e) = + AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). +Proof. +simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct; + auto. +elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1); + intros. +rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto. +ring. +Qed. + +Lemma monom_simplif_correct : + forall (e a:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e. +Proof. +simple induction e; intros; auto. +simpl in |- *; case (eqExprA a e0); intros. +rewrite <- e2; apply monom_simplif_rem_correct; auto. +simpl in |- *; trivial. +Qed. + +Lemma inverse_correct : + forall (e a:ExprA) (lvar:listT (prodT AT nat)), + interp_ExprA lvar a <> AzeroT -> + interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e. +Proof. +simple induction e; intros; auto. +simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto. +unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto. +Qed. + +End Theory_of_fields.
\ No newline at end of file diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4 new file mode 100644 index 00000000..32adec66 --- /dev/null +++ b/contrib/field/field.ml4 @@ -0,0 +1,190 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* $Id: field.ml4,v 1.33.2.1 2004/07/16 19:30:09 herbelin Exp $ *) + +open Names +open Pp +open Proof_type +open Tacinterp +open Tacmach +open Term +open Typing +open Util +open Vernacinterp +open Vernacexpr +open Tacexpr + +(* Interpretation of constr's *) +let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c + +(* Construction of constants *) +let constant dir s = Coqlib.gen_constant "Field" ("field"::dir) s + +(* To deal with the optional arguments *) +let constr_of_opt a opt = + let ac = constr_of a in + match opt with + | None -> mkApp ((constant ["Field_Compl"] "Field_None"),[|ac|]) + | Some f -> mkApp ((constant ["Field_Compl"] "Field_Some"),[|ac;constr_of f|]) + +(* Table of theories *) +let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t) + +let lookup env typ = + try Gmap.find typ !th_tab + with Not_found -> + errorlabstrm "field" + (str "No field is declared for type" ++ spc() ++ + Printer.prterm_env env typ) + +let _ = + let init () = th_tab := Gmap.empty in + let freeze () = !th_tab in + let unfreeze fs = th_tab := fs in + Summary.declare_summary "field" + { Summary.freeze_function = freeze; + Summary.unfreeze_function = unfreeze; + Summary.init_function = init; + Summary.survive_module = false; + Summary.survive_section = false } + +let load_addfield _ = () +let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab +let subst_addfield (_,subst,(typ,th as obj)) = + let typ' = subst_mps subst typ in + let th' = subst_mps subst th in + if typ' == typ && th' == th then obj else + (typ',th') +let export_addfield x = Some x + +(* Declaration of the Add Field library object *) +let (in_addfield,out_addfield)= + Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with + Libobject.open_function = (fun i o -> if i=1 then cache_addfield o); + Libobject.cache_function = cache_addfield; + Libobject.subst_function = subst_addfield; + Libobject.classify_function = (fun (_,a) -> Libobject.Substitute a); + Libobject.export_function = export_addfield } + +(* Adds a theory to the table *) +let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth + ainv_l = + begin + (try + Ring.add_theory true true false a None None None aplus amult aone azero + (Some aopp) aeq rth Quote.ConstrSet.empty + with | UserError("Add Semi Ring",_) -> ()); + let th = mkApp ((constant ["Field_Theory"] "Build_Field_Theory"), + [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in + begin + let _ = type_of (Global.env ()) Evd.empty th in (); + Lib.add_anonymous_leaf (in_addfield (a,th)) + end + end + +(* Vernac command declaration *) +open Extend +open Pcoq +open Genarg + +VERNAC ARGUMENT EXTEND divarg +| [ "div" ":=" constr(adiv) ] -> [ adiv ] +END + +VERNAC ARGUMENT EXTEND minusarg +| [ "minus" ":=" constr(aminus) ] -> [ aminus ] +END + +(* +(* The v7->v8 translator needs printers, then temporary use ARGUMENT EXTEND...*) +VERNAC ARGUMENT EXTEND minus_div_arg +| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] +| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ] +| [ ] -> [ None, None ] +END +*) + +(* For the translator, otherwise the code above is OK *) +open Ppconstrnew +let pp_minus_div_arg _prc _prt (omin,odiv) = + if omin=None && odiv=None then mt() else + spc() ++ str "with" ++ + pr_opt (fun c -> str "minus := " ++ _prc c) omin ++ + pr_opt (fun c -> str "div := " ++ _prc c) odiv +(* +let () = + Pptactic.declare_extra_genarg_pprule true + (rawwit_minus_div_arg,pp_minus_div_arg) + (globwit_minus_div_arg,pp_minus_div_arg) + (wit_minus_div_arg,pp_minus_div_arg) +*) +ARGUMENT EXTEND minus_div_arg + TYPED AS constr_opt * constr_opt + PRINTED BY pp_minus_div_arg +| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] +| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ] +| [ ] -> [ None, None ] +END + +VERNAC COMMAND EXTEND Field + [ "Add" "Field" + constr(a) constr(aplus) constr(amult) constr(aone) + constr(azero) constr(aopp) constr(aeq) + constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ] + -> [ let (aminus_o, adiv_o) = md in + add_field + (constr_of a) (constr_of aplus) (constr_of amult) + (constr_of aone) (constr_of azero) (constr_of aopp) + (constr_of aeq) (constr_of ainv) (constr_of_opt a aminus_o) + (constr_of_opt a adiv_o) (constr_of rth) (constr_of ainv_l) ] +END + +(* Guesses the type and calls field_gen with the right theory *) +let field g = + Library.check_required_library ["Coq";"field";"Field"]; + let ist = { lfun=[]; debug=get_debug () } in + let typ = + match Hipattern.match_with_equation (pf_concl g) with + | Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t + | _ -> error "The statement is not built from Leibniz' equality" in + let th = VConstr (lookup (pf_env g) typ) in + (interp_tac_gen [(id_of_string "FT",th)] (get_debug ()) + <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g + +(* Verifies that all the terms have the same type and gives the right theory *) +let guess_theory env evc = function + | c::tl -> + let t = type_of env evc c in + if List.exists (fun c1 -> + not (Reductionops.is_conv env evc t (type_of env evc c1))) tl then + errorlabstrm "Field:" (str" All the terms must have the same type") + else + lookup env t + | [] -> anomaly "Field: must have a non-empty constr list here" + +(* Guesses the type and calls Field_Term with the right theory *) +let field_term l g = + Library.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)) + and nl = List.map (fun x -> valueIn (VConstr x)) (Quote.sort_subterm g l) in + (List.fold_right + (fun c a -> + let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in + Tacticals.tclTHENFIRSTn tac [|a|]) nl Tacticals.tclIDTAC) g + +(* Declaration of Field *) + +TACTIC EXTEND 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 new file mode 100644 index 00000000..49cb8e25 --- /dev/null +++ b/contrib/first-order/formula.ml @@ -0,0 +1,271 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: formula.ml,v 1.18.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +open Hipattern +open Names +open Term +open Termops +open Reductionops +open Tacmach +open Util +open Declarations +open Libnames +open Inductiveops + +let qflag=ref true + +let red_flags=ref Closure.betaiotazeta + +let (=?) f g i1 i2 j1 j2= + let c=f i1 i2 in + if c=0 then g j1 j2 else c + +let (==?) fg h i1 i2 j1 j2 k1 k2= + let c=fg i1 i2 j1 j2 in + if c=0 then h k1 k2 else c + +type ('a,'b) sum = Left of 'a | Right of 'b + +type counter = bool -> metavariable + +exception Is_atom of constr + +let meta_succ m = m+1 + +let rec nb_prod_after n c= + match kind_of_term c with + | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else + 1+(nb_prod_after 0 b) + | _ -> 0 + +let construct_nhyps ind gls = + let 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 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 lp=Array.length types in + let myhyps i= + let t1=Term.prod_applist types.(i) largs in + let t2=snd (Sign.decompose_prod_n_assum nevar t1) in + fst (Sign.decompose_prod_assum t2) in + Array.init lp myhyps + +let special_nf gl= + let infos=Closure.create_clos_infos !red_flags (pf_env gl) in + (fun t -> Closure.norm_val infos (Closure.inject t)) + +let special_whd gl= + let infos=Closure.create_clos_infos !red_flags (pf_env gl) in + (fun t -> Closure.whd_val infos (Closure.inject t)) + +type kind_of_formula= + Arrow of constr*constr + | False of inductive*constr list + | And of inductive*constr list*bool + | Or of inductive*constr list*bool + | Exists of inductive*constr list + | Forall of constr*constr + | Atom of constr + +let rec kind_of_formula gl term = + let normalize=special_nf gl in + let cciterm=special_whd gl term in + match match_with_imp_term cciterm with + Some (a,b)-> Arrow(a,(pop b)) + |_-> + match match_with_forall_term cciterm with + Some (_,a,b)-> Forall(a,b) + |_-> + match match_with_nodep_ind cciterm with + Some (i,l,n)-> + let ind=destInd i in + let (mib,mip) = Global.lookup_inductive ind in + let nconstr=Array.length mip.mind_consnames in + if nconstr=0 then + False(ind,l) + else + let has_realargs=(n>0) in + let is_trivial= + let is_constant c = + nb_prod c = mip.mind_nparams in + array_exists is_constant mip.mind_nf_lc in + if Inductiveops.mis_is_recursive (ind,mib,mip) || + (has_realargs && not is_trivial) + then + Atom cciterm + else + if nconstr=1 then + And(ind,l,is_trivial) + else + Or(ind,l,is_trivial) + | _ -> + match match_with_sigma_type cciterm with + Some (i,l)-> Exists((destInd i),l) + |_-> Atom (normalize cciterm) + +type atoms = {positive:constr list;negative:constr list} + +type side = Hyp | Concl | Hint + +let no_atoms = (false,{positive=[];negative=[]}) + +let dummy_id=VarRef (id_of_string "") + +let build_atoms gl metagen side cciterm = + let trivial =ref false + and positive=ref [] + and negative=ref [] in + let normalize=special_nf gl in + let rec build_rec env polarity cciterm= + match kind_of_formula gl cciterm with + False(_,_)->if not polarity then trivial:=true + | Arrow (a,b)-> + build_rec env (not polarity) a; + build_rec env polarity b + | And(i,l,b) | Or(i,l,b)-> + if b then + begin + let unsigned=normalize (substnl env 0 cciterm) in + if polarity then + positive:= unsigned :: !positive + else + negative:= unsigned :: !negative + end; + let v = ind_hyps 0 i l gl in + let g i _ (_,_,t) = + build_rec env polarity (lift i t) in + let f l = + list_fold_left_i g (1-(List.length l)) () l in + if polarity && (* we have a constant constructor *) + array_exists (function []->true|_->false) v + then trivial:=true; + Array.iter f v + | Exists(i,l)-> + let var=mkMeta (metagen true) in + let v =(ind_hyps 1 i l gl).(0) in + let g i _ (_,_,t) = + build_rec (var::env) polarity (lift i t) in + list_fold_left_i g (2-(List.length l)) () v + | Forall(_,b)-> + let var=mkMeta (metagen true) in + build_rec (var::env) polarity b + | Atom t-> + let unsigned=substnl env 0 t in + if not (isMeta unsigned) then (* discarding wildcard atoms *) + if polarity then + positive:= unsigned :: !positive + else + negative:= unsigned :: !negative in + begin + match side with + Concl -> build_rec [] true cciterm + | Hyp -> build_rec [] false cciterm + | Hint -> + let rels,head=decompose_prod cciterm in + let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in + build_rec env false head;trivial:=false (* special for hints *) + end; + (!trivial, + {positive= !positive; + negative= !negative}) + +type right_pattern = + Rarrow + | Rand + | Ror + | Rfalse + | Rforall + | Rexists of metavariable*constr*bool + +type left_arrow_pattern= + LLatom + | LLfalse of inductive*constr list + | LLand of inductive*constr list + | LLor of inductive*constr list + | LLforall of constr + | LLexists of inductive*constr list + | LLarrow of constr*constr*constr + +type left_pattern= + Lfalse + | Land of inductive + | Lor of inductive + | Lforall of metavariable*constr*bool + | Lexists of inductive + | LA of constr*left_arrow_pattern + +type t={id:global_reference; + constr:constr; + pat:(left_pattern,right_pattern) sum; + atoms:atoms} + +let build_formula side nam typ gl metagen= + let normalize = special_nf gl in + try + let m=meta_succ(metagen false) in + let trivial,atoms= + if !qflag then + build_atoms gl metagen side typ + else no_atoms in + let pattern= + match side with + Concl -> + let pat= + match kind_of_formula gl typ with + False(_,_) -> Rfalse + | Atom a -> raise (Is_atom a) + | And(_,_,_) -> Rand + | Or(_,_,_) -> Ror + | Exists (i,l) -> + let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in + Rexists(m,d,trivial) + | Forall (_,a) -> Rforall + | Arrow (a,b) -> Rarrow in + Right pat + | _ -> + let pat= + match kind_of_formula gl typ with + False(i,_) -> Lfalse + | Atom a -> raise (Is_atom a) + | And(i,_,b) -> + if b then + let nftyp=normalize typ in raise (Is_atom nftyp) + else Land i + | Or(i,_,b) -> + if b then + let nftyp=normalize typ in raise (Is_atom nftyp) + else Lor i + | Exists (ind,_) -> Lexists ind + | Forall (d,_) -> + Lforall(m,d,trivial) + | Arrow (a,b) -> + let nfa=normalize a in + LA (nfa, + match kind_of_formula gl a with + False(i,l)-> LLfalse(i,l) + | Atom t-> LLatom + | And(i,l,_)-> LLand(i,l) + | Or(i,l,_)-> LLor(i,l) + | Arrow(a,c)-> LLarrow(a,c,b) + | Exists(i,l)->LLexists(i,l) + | Forall(_,_)->LLforall a) in + Left pat + in + Left {id=nam; + constr=normalize typ; + pat=pattern; + atoms=atoms} + with Is_atom a-> Right a (* already in nf *) + diff --git a/contrib/first-order/formula.mli b/contrib/first-order/formula.mli new file mode 100644 index 00000000..db24f20f --- /dev/null +++ b/contrib/first-order/formula.mli @@ -0,0 +1,77 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: formula.mli,v 1.17.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +open Term +open Names +open Libnames + +val qflag : bool ref + +val red_flags: Closure.RedFlags.reds ref + +val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> + 'a -> 'a -> 'b -> 'b -> int + +val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> + 'a -> 'a -> 'b -> 'b -> 'c ->'c -> int + +type ('a,'b) sum = Left of 'a | Right of 'b + +type counter = bool -> metavariable + +val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array + +val ind_hyps : int -> inductive -> constr list -> + Proof_type.goal Tacmach.sigma -> Sign.rel_context array + +type atoms = {positive:constr list;negative:constr list} + +type side = Hyp | Concl | Hint + +val dummy_id: global_reference + +val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> + side -> constr -> bool * atoms + +type right_pattern = + Rarrow + | Rand + | Ror + | Rfalse + | Rforall + | Rexists of metavariable*constr*bool + +type left_arrow_pattern= + LLatom + | LLfalse of inductive*constr list + | LLand of inductive*constr list + | LLor of inductive*constr list + | LLforall of constr + | LLexists of inductive*constr list + | LLarrow of constr*constr*constr + +type left_pattern= + Lfalse + | Land of inductive + | Lor of inductive + | Lforall of metavariable*constr*bool + | Lexists of inductive + | LA of constr*left_arrow_pattern + +type t={id: global_reference; + constr: constr; + pat: (left_pattern,right_pattern) sum; + atoms: atoms} + +(*exception Is_atom of constr*) + +val build_formula : side -> global_reference -> types -> + Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum + diff --git a/contrib/first-order/g_ground.ml4 b/contrib/first-order/g_ground.ml4 new file mode 100644 index 00000000..f85f2171 --- /dev/null +++ b/contrib/first-order/g_ground.ml4 @@ -0,0 +1,103 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* $Id: g_ground.ml4,v 1.10.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +open Formula +open Sequent +open Ground +open Goptions +open Tactics +open Tacticals +open Tacinterp +open Term +open Names +open Util +open Libnames + +(* declaring search depth as a global option *) + +let ground_depth=ref 5 + +let _= + let gdopt= + { optsync=true; + optname="Firstorder Depth"; + optkey=SecondaryTable("Firstorder","Depth"); + optread=(fun ()->Some !ground_depth); + optwrite= + (function + None->ground_depth:=5 + | Some i->ground_depth:=(max i 0))} + in + declare_int_option gdopt + +let default_solver=(Tacinterp.interp <:tactic<auto with *>>) + +let fail_solver=tclFAIL 0 "GTauto failed" + +type external_env= + Ids of global_reference list + | Bases of Auto.hint_db_name list + | Void + +let gen_ground_tac flag taco ext gl= + let backup= !qflag in + try + qflag:=flag; + let solver= + match taco with + Some tac-> tac + | None-> default_solver in + let startseq= + match ext with + Void -> (fun gl -> empty_seq !ground_depth) + | Ids l-> create_with_ref_list l !ground_depth + | Bases l-> create_with_auto_hints l !ground_depth in + let result=ground_tac solver startseq gl in + qflag:=backup;result + with e ->qflag:=backup;raise e + +(* special for compatibility with Intuition + +let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str + +let defined_connectives=lazy + [[],EvalConstRef (destConst (constant "not")); + [],EvalConstRef (destConst (constant "iff"))] + +let normalize_evaluables= + onAllClauses + (function + None->unfold_in_concl (Lazy.force defined_connectives) + | Some id-> + unfold_in_hyp (Lazy.force defined_connectives) + (Tacexpr.InHypType id)) *) + +TACTIC EXTEND Firstorder + [ "Firstorder" tactic_opt(t) "with" ne_reference_list(l) ] -> + [ gen_ground_tac true (option_app eval_tactic t) (Ids l) ] +| [ "Firstorder" tactic_opt(t) "using" ne_preident_list(l) ] -> + [ gen_ground_tac true (option_app eval_tactic t) (Bases l) ] +| [ "Firstorder" tactic_opt(t) ] -> + [ gen_ground_tac true (option_app eval_tactic t) Void ] +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) ] -> + [ 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 new file mode 100644 index 00000000..23e27a3c --- /dev/null +++ b/contrib/first-order/ground.ml @@ -0,0 +1,151 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: ground.ml,v 1.5.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +open Formula +open Sequent +open Rules +open Instances +open Term +open Tacmach +open Tactics +open Tacticals +open Libnames + +(* +let old_search=ref !Auto.searchtable + +(* I use this solution as a means to know whether hints have changed, +but this prevents the GC from collecting the previous table, +resulting in some limited space wasting*) + +let update_flags ()= + if not ( !Auto.searchtable == !old_search ) then + begin + old_search:=!Auto.searchtable; + let predref=ref Names.KNpred.empty in + let f p_a_t = + match p_a_t.Auto.code with + Auto.Unfold_nth (ConstRef kn)-> + predref:=Names.KNpred.add kn !predref + | _ ->() in + let g _ l=List.iter f l in + let h _ hdb=Auto.Hint_db.iter g hdb in + Util.Stringmap.iter h !Auto.searchtable; + red_flags:= + Closure.RedFlags.red_add_transparent + Closure.betaiotazeta (Names.Idpred.full,!predref) + end +*) + +let update_flags ()= + let predref=ref Names.KNpred.empty in + let f coe= + try + let kn=destConst (Classops.get_coercion_value coe) in + predref:=Names.KNpred.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) + +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)); + tclORELSE (axiom_tac seq.gl seq) + begin + try + let (hd,seq1)=take_formula seq + and re_add s=re_add_formula_list skipped s in + let continue=toptac [] + and backtrack gl=toptac (hd::skipped) seq1 gl in + match hd.pat with + Right rpat-> + begin + match rpat with + Rand-> + and_tac backtrack continue (re_add seq1) + | Rforall-> + let backtrack1= + if !qflag then + tclFAIL 0 "reversible in 1st order mode" + else + backtrack in + forall_tac backtrack continue (re_add seq1) + | Rarrow-> + arrow_tac backtrack continue (re_add seq1) + | Ror-> + or_tac backtrack continue (re_add seq1) + | Rfalse->backtrack + | Rexists(i,dom,triv)-> + let (lfp,seq2)=collect_quantified seq in + let backtrack2=toptac (lfp@skipped) seq2 in + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 + continue (re_add seq) + else + backtrack2 (* need special backtracking *) + end + | Left lpat-> + begin + match lpat with + Lfalse-> + left_false_tac hd.id + | Land ind-> + left_and_tac ind backtrack + hd.id continue (re_add seq1) + | Lor ind-> + left_or_tac ind backtrack + hd.id continue (re_add seq1) + | Lforall (_,_,_)-> + let (lfp,seq2)=collect_quantified seq in + let backtrack2=toptac (lfp@skipped) seq2 in + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 + continue (re_add seq) + else + backtrack2 (* need special backtracking *) + | Lexists ind -> + if !qflag then + left_exists_tac ind hd.id continue (re_add seq1) + else backtrack + | LA (typ,lap)-> + let la_tac= + begin + match lap with + LLatom -> backtrack + | LLand (ind,largs) | LLor(ind,largs) + | LLfalse (ind,largs)-> + (ll_ind_tac ind largs backtrack + hd.id continue (re_add seq1)) + | LLforall p -> + if seq.depth>0 && !qflag then + (ll_forall_tac p backtrack + hd.id continue (re_add seq1)) + else backtrack + | LLexists (ind,l) -> + if !qflag then + ll_ind_tac ind l backtrack + hd.id continue (re_add seq1) + else + backtrack + | LLarrow (a,b,c) -> + (ll_arrow_tac a b c backtrack + hd.id continue (re_add seq1)) + end in + ll_atom_tac typ la_tac hd.id continue (re_add seq1) + end + with Heap.EmptyHeap->solver + end gl in + wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl + diff --git a/contrib/first-order/ground.mli b/contrib/first-order/ground.mli new file mode 100644 index 00000000..cfc17e77 --- /dev/null +++ b/contrib/first-order/ground.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: ground.mli,v 1.1.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +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 new file mode 100644 index 00000000..e2e9e2ef --- /dev/null +++ b/contrib/first-order/instances.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 *) +(************************************************************************) + +(*i $Id: instances.ml,v 1.9.2.1 2004/07/16 19:30:10 herbelin Exp $ i*) + +open Formula +open Sequent +open Unify +open Rules +open Util +open Term +open Rawterm +open Tacmach +open Tactics +open Tacticals +open Termops +open Reductionops +open Declarations +open Formula +open Sequent +open Names +open Libnames + +let compare_instance inst1 inst2= + match inst1,inst2 with + Phantom(d1),Phantom(d2)-> + (OrderedConstr.compare d1 d2) + | Real((m1,c1),n1),Real((m2,c2),n2)-> + ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2 + | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1 + | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1 + +let compare_gr id1 id2= + if id1==id2 then 0 else + if id1==dummy_id then 1 + else if id2==dummy_id then -1 + else Pervasives.compare id1 id2 + +module OrderedInstance= +struct + type t=instance * Libnames.global_reference + let compare (inst1,id1) (inst2,id2)= + (compare_instance =? compare_gr) inst2 inst1 id2 id1 + (* we want a __decreasing__ total order *) +end + +module IS=Set.Make(OrderedInstance) + +let make_simple_atoms seq= + let ratoms= + match seq.glatom with + Some t->[t] + | None->[] + in {negative=seq.latoms;positive=ratoms} + +let do_sequent setref triv id seq i dom atoms= + let flag=ref true in + let phref=ref triv in + let do_atoms a1 a2 = + let do_pair t1 t2 = + match unif_atoms i dom t1 t2 with + None->() + | Some (Phantom _) ->phref:=true + | Some c ->flag:=false;setref:=IS.add (c,id) !setref in + List.iter (fun t->List.iter (do_pair t) a2.negative) a1.positive; + List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in + HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes; + do_atoms atoms (make_simple_atoms seq); + !flag && !phref + +let match_one_quantified_hyp setref seq lf= + match lf.pat with + Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> + if do_sequent setref triv lf.id seq i dom lf.atoms then + setref:=IS.add ((Phantom dom),lf.id) !setref + | _ ->anomaly "can't happen" + +let give_instances lf seq= + let setref=ref IS.empty in + List.iter (match_one_quantified_hyp setref seq) lf; + IS.elements !setref + +(* collector for the engine *) + +let rec collect_quantified seq= + try + let hd,seq1=take_formula seq in + (match hd.pat with + Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> + let (q,seq2)=collect_quantified seq1 in + ((hd::q),seq2) + | _->[],seq) + with Heap.EmptyHeap -> [],seq + +(* open instances processor *) + +let dummy_constr=mkMeta (-1) + +let dummy_bvid=id_of_string "x" + +let mk_open_instance id gl m t= + let env=pf_env gl in + let evmap=Refiner.sig_sig gl in + let var_id= + if id==dummy_id then dummy_bvid else + let typ=pf_type_of gl (constr_of_reference id) in + (* since we know we will get a product, + reduction is not too expensive *) + let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in + match nam with + Name id -> id + | Anonymous -> dummy_bvid in + let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in + let rec aux n avoid= + if n=0 then [] else + let nid=(fresh_id avoid var_id gl) in + (Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in + let nt=it_mkLambda_or_LetIn revt (aux m []) in + let rawt=Detyping.detype (false,env) [] [] 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) + | _-> anomaly "can't happen" in + let ntt=Pretyping.understand evmap env (raux m rawt) in + Sign.decompose_lam_n_assum m ntt + +(* tactics *) + +let left_instance_tac (inst,id) continue seq= + match inst with + Phantom dom-> + if lookup (id,None) seq then + tclFAIL 0 "already done" + else + tclTHENS (cut dom) + [tclTHENLIST + [introf; + (fun gls->generalize + [mkApp(constr_of_reference id, + [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls); + introf; + tclSOLVE [wrap 1 false continue + (deepen (record (id,None) seq))]]; + tclTRY assumption] + | Real((m,t) as c,_)-> + if lookup (id,Some c) seq then + tclFAIL 0 "already done" + else + let special_generalize= + if m>0 then + fun gl-> + let (rc,ot)= mk_open_instance id gl m t in + let gt= + it_mkLambda_or_LetIn + (mkApp(constr_of_reference id,[|ot|])) rc in + generalize [gt] gl + else + generalize [mkApp(constr_of_reference id,[|t|])] + in + tclTHENLIST + [special_generalize; + introf; + tclSOLVE + [wrap 1 false continue (deepen (record (id,Some c) seq))]] + +let right_instance_tac inst continue seq= + match inst with + Phantom dom -> + tclTHENS (cut dom) + [tclTHENLIST + [introf; + (fun gls-> + split (Rawterm.ImplicitBindings + [mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls); + tclSOLVE [wrap 0 true continue (deepen seq)]]; + tclTRY assumption] + | Real ((0,t),_) -> + (tclTHEN (split (Rawterm.ImplicitBindings [t])) + (tclSOLVE [wrap 0 true continue (deepen seq)])) + | Real ((m,t),_) -> + tclFAIL 0 "not implemented ... yet" + +let instance_tac inst= + if (snd inst)==dummy_id then + right_instance_tac (fst inst) + else + left_instance_tac inst + +let quantified_tac lf backtrack continue seq gl= + let insts=give_instances lf seq in + tclORELSE + (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) + backtrack gl + + diff --git a/contrib/first-order/instances.mli b/contrib/first-order/instances.mli new file mode 100644 index 00000000..509bfc70 --- /dev/null +++ b/contrib/first-order/instances.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 *) +(************************************************************************) + +(*i $Id: instances.mli,v 1.3.2.1 2004/07/16 19:30:10 herbelin Exp $ i*) + +open Term +open Tacmach +open Names +open Libnames +open Rules + +val collect_quantified : Sequent.t -> Formula.t list * Sequent.t + +val give_instances : Formula.t list -> Sequent.t -> + (Unify.instance * global_reference) list + +val quantified_tac : Formula.t list -> seqtac with_backtracking + + + + diff --git a/contrib/first-order/rules.ml b/contrib/first-order/rules.ml new file mode 100644 index 00000000..7fbefa37 --- /dev/null +++ b/contrib/first-order/rules.ml @@ -0,0 +1,214 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: rules.ml,v 1.24.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +open Util +open Names +open Term +open Tacmach +open Tactics +open Tacticals +open Termops +open Declarations +open Formula +open Sequent +open Libnames + +type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic + +type lseqtac= global_reference -> seqtac + +type 'a with_backtracking = tactic -> 'a + +let wrap n b continue seq gls= + check_for_interrupt (); + let nc=pf_hyps gls in + let env=pf_env gls in + let rec aux i nc ctx= + if i<=0 then seq else + match nc with + []->anomaly "Not the expected number of hyps" + | ((id,_,typ) as nd)::q-> + if occur_var env id (pf_concl gls) || + List.exists (occur_var_in_decl env id) ctx then + (aux (i-1) q (nd::ctx)) + else + add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in + let seq1=aux n nc [] in + let seq2=if b then + add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in + continue seq2 gls + +let id_of_global=function + VarRef id->id + | _->assert false + +let clear_global=function + VarRef id->clear [id] + | _->tclIDTAC + + +(* connection rules *) + +let axiom_tac t seq= + try exact_no_check (constr_of_reference (find_left t seq)) + with Not_found->tclFAIL 0 "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)|])]; + clear_global id; + intro] + with Not_found->tclFAIL 0 "No link") + (wrap 1 false continue seq) backtrack + +(* right connectives rules *) + +let and_tac backtrack continue seq= + tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack + +let or_tac backtrack continue seq= + tclORELSE + (any_constructor (Some (tclCOMPLETE (wrap 0 true continue seq)))) + backtrack + +let arrow_tac backtrack continue seq= + tclIFTHENELSE intro (wrap 1 true continue seq) + (tclORELSE + (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq))) + backtrack) +(* left connectives rules *) + +let left_and_tac ind backtrack id continue seq gls= + let n=(construct_nhyps ind gls).(0) in + tclIFTHENELSE + (tclTHENLIST + [simplest_elim (constr_of_reference id); + clear_global id; + tclDO n intro]) + (wrap n false continue seq) + backtrack gls + +let left_or_tac ind backtrack id continue seq gls= + let v=construct_nhyps ind gls in + let f n= + tclTHENLIST + [clear_global id; + tclDO n intro; + wrap n false continue seq] in + tclIFTHENSVELSE + (simplest_elim (constr_of_reference id)) + (Array.map f v) + backtrack gls + +let left_false_tac id= + simplest_elim (constr_of_reference id) + +(* left arrow connective rules *) + +(* We use this function for false, and, or, exists *) + +let ll_ind_tac ind largs backtrack id continue seq gl= + let rcs=ind_hyps 0 ind largs gl in + let vargs=Array.of_list largs in + (* construire le terme H->B, le generaliser etc *) + let myterm i= + let rc=rcs.(i) in + let p=List.length rc in + let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in + let vars=Array.init p (fun j->mkRel (p-j)) in + let capply=mkApp ((lift p cstr),vars) in + let head=mkApp ((lift p (constr_of_reference id)),[|capply|]) in + Sign.it_mkLambda_or_LetIn head rc in + let lp=Array.length rcs in + let newhyps=list_tabulate myterm lp in + tclIFTHENELSE + (tclTHENLIST + [generalize newhyps; + clear_global id; + tclDO lp intro]) + (wrap lp false continue seq) backtrack gl + +let ll_arrow_tac a b c backtrack id continue seq= + let cc=mkProd(Anonymous,a,(lift 1 b)) in + let d=mkLambda (Anonymous,b, + mkApp ((constr_of_reference id), + [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in + tclORELSE + (tclTHENS (cut c) + [tclTHENLIST + [introf; + clear_global id; + wrap 1 false continue seq]; + tclTHENS (cut cc) + [exact_no_check (constr_of_reference id); + tclTHENLIST + [generalize [d]; + clear_global id; + introf; + introf; + tclCOMPLETE (wrap 2 true continue seq)]]]) + backtrack + +(* quantifier rules (easy side) *) + +let forall_tac backtrack continue seq= + tclORELSE + (tclIFTHENELSE intro (wrap 0 true continue seq) + (tclORELSE + (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) + backtrack)) + (if !qflag then + tclFAIL 0 "reversible in 1st order mode" + else + backtrack) + +let left_exists_tac ind 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 + +let ll_forall_tac prod backtrack id continue seq= + tclORELSE + (tclTHENS (cut prod) + [tclTHENLIST + [intro; + (fun gls-> + let id0=pf_nth_hyp_id gls 1 in + let term=mkApp((constr_of_reference id),[|mkVar(id0)|]) in + tclTHEN (generalize [term]) (clear [id0]) gls); + clear_global id; + intro; + tclCOMPLETE (wrap 1 false continue (deepen seq))]; + tclCOMPLETE (wrap 0 true continue (deepen seq))]) + backtrack + +(* rules for instantiation with unification moved to instances.ml *) + +(* special for compatibility with old Intuition *) + +let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str + +let defined_connectives=lazy + [[],EvalConstRef (destConst (constant "not")); + [],EvalConstRef (destConst (constant "iff"))] + +let normalize_evaluables= + onAllClauses + (function + None->unfold_in_concl (Lazy.force defined_connectives) + | Some (id,_,_)-> + unfold_in_hyp (Lazy.force defined_connectives) + (id,[],(Tacexpr.InHypTypeOnly,ref None))) diff --git a/contrib/first-order/rules.mli b/contrib/first-order/rules.mli new file mode 100644 index 00000000..eb4d81bd --- /dev/null +++ b/contrib/first-order/rules.mli @@ -0,0 +1,54 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: rules.mli,v 1.11.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +open Term +open Tacmach +open Names +open Libnames + +type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic + +type lseqtac= global_reference -> seqtac + +type 'a with_backtracking = tactic -> 'a + +val wrap : int -> bool -> seqtac + +val id_of_global: global_reference -> identifier + +val clear_global: global_reference -> tactic + +val axiom_tac : constr -> Sequent.t -> tactic + +val ll_atom_tac : constr -> lseqtac with_backtracking + +val and_tac : seqtac with_backtracking + +val or_tac : seqtac with_backtracking + +val arrow_tac : seqtac with_backtracking + +val left_and_tac : inductive -> lseqtac with_backtracking + +val left_or_tac : inductive -> lseqtac with_backtracking + +val left_false_tac : global_reference -> tactic + +val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking + +val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking + +val forall_tac : seqtac with_backtracking + +val left_exists_tac : inductive -> lseqtac + +val ll_forall_tac : types -> lseqtac with_backtracking + +val normalize_evaluables : tactic diff --git a/contrib/first-order/sequent.ml b/contrib/first-order/sequent.ml new file mode 100644 index 00000000..13215348 --- /dev/null +++ b/contrib/first-order/sequent.ml @@ -0,0 +1,303 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: sequent.ml,v 1.17.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +open Term +open Util +open Formula +open Unify +open Tacmach +open Names +open Libnames +open Pp + +let newcnt ()= + let cnt=ref (-1) in + fun b->if b then incr cnt;!cnt + +let priority = (* pure heuristics, <=0 for non reversible *) + function + Right rf-> + begin + match rf with + Rarrow -> 100 + | Rand -> 40 + | Ror -> -15 + | Rfalse -> -50 + | Rforall -> 100 + | Rexists (_,_,_) -> -29 + end + | Left lf -> + match lf with + Lfalse -> 999 + | Land _ -> 90 + | Lor _ -> 40 + | Lforall (_,_,_) -> -30 + | Lexists _ -> 60 + | LA(_,lap) -> + match lap with + LLatom -> 0 + | LLfalse (_,_) -> 100 + | LLand (_,_) -> 80 + | LLor (_,_) -> 70 + | LLforall _ -> -20 + | LLexists (_,_) -> 50 + | LLarrow (_,_,_) -> -10 + +let left_reversible lpat=(priority lpat)>0 + +module OrderedFormula= +struct + type t=Formula.t + let compare e1 e2= + (priority e1.pat) - (priority e2.pat) +end + +(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare + the immediate subterms of [c1] of [c2] if needed; Cast's, + application associativity, binders name and Cases annotations are + not taken into account *) + +let rec compare_list f l1 l2= + match l1,l2 with + [],[]-> 0 + | [],_ -> -1 + | _,[] -> 1 + | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2 + +let compare_array f v1 v2= + let l=Array.length v1 in + let c=l - Array.length v2 in + if c=0 then + let rec comp_aux i= + if i<0 then 0 + else + let ci=f v1.(i) v2.(i) in + if ci=0 then + comp_aux (i-1) + else ci + in comp_aux (l-1) + else c + +let compare_constr_int f t1 t2 = + match kind_of_term t1, kind_of_term t2 with + | Rel n1, Rel n2 -> n1 - n2 + | Meta m1, Meta m2 -> m1 - m2 + | Var id1, Var id2 -> Pervasives.compare id1 id2 + | Sort s1, Sort s2 -> Pervasives.compare s1 s2 + | Cast (c1,_), _ -> f c1 t2 + | _, Cast (c2,_) -> f t1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> + (f =? f) t1 t2 c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> + ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 + | App (_,_), App (_,_) -> + let c1,l1=decompose_app t1 + and c2,l2=decompose_app t2 in + (f =? (compare_list f)) c1 c2 l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> + ((-) =? (compare_array f)) e1 e2 l1 l2 + | Const c1, Const c2 -> Pervasives.compare c1 c2 + | Ind c1, Ind c2 -> Pervasives.compare c1 c2 + | Construct c1, Construct c2 -> Pervasives.compare c1 c2 + | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> + ((f =? f) ==? (compare_array f)) p1 p2 c1 c2 bl1 bl2 + | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> + ((Pervasives.compare =? (compare_array f)) ==? (compare_array f)) + ln1 ln2 tl1 tl2 bl1 bl2 + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + ((Pervasives.compare =? (compare_array f)) ==? (compare_array f)) + ln1 ln2 tl1 tl2 bl1 bl2 + | _ -> Pervasives.compare t1 t2 + +let rec compare_constr m n= + compare_constr_int compare_constr m n + +module OrderedConstr= +struct + type t=constr + let compare=compare_constr +end + +type h_item = global_reference * (int*constr) option + +module Hitem= +struct + type t = h_item + let compare (id1,co1) (id2,co2)= + (Pervasives.compare + =? (fun oc1 oc2 -> + match oc1,oc2 with + Some (m1,c1),Some (m2,c2) -> + ((-) =? OrderedConstr.compare) m1 m2 c1 c2 + | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2 +end + +module CM=Map.Make(OrderedConstr) + +module History=Set.Make(Hitem) + +let cm_add typ nam cm= + try + let l=CM.find typ cm in CM.add typ (nam::l) cm + with + Not_found->CM.add typ [nam] cm + +let cm_remove typ nam cm= + try + let l=CM.find typ cm in + let l0=List.filter (fun id->id<>nam) l in + match l0 with + []->CM.remove typ cm + | _ ->CM.add typ l0 cm + with Not_found ->cm + +module HP=Heap.Functional(OrderedFormula) + +type t= + {redexes:HP.t; + context:(global_reference list) CM.t; + latoms:constr list; + gl:types; + glatom:constr option; + cnt:counter; + history:History.t; + depth:int} + +let deepen seq={seq with depth=seq.depth-1} + +let record item seq={seq with history=History.add item seq.history} + +let lookup item seq= + History.mem item seq.history || + match item with + (_,None)->false + | (id,Some ((m,t) as c))-> + let p (id2,o)= + match o with + None -> false + | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in + History.exists p seq.history + +let rec add_formula side nam t seq gl= + match build_formula side nam t gl seq.cnt with + Left f-> + begin + match side with + Concl -> + {seq with + redexes=HP.add f seq.redexes; + gl=f.constr; + glatom=None} + | _ -> + {seq with + redexes=HP.add f seq.redexes; + context=cm_add f.constr nam seq.context} + end + | Right t-> + match side with + Concl -> + {seq with gl=t;glatom=Some t} + | _ -> + {seq with + context=cm_add t nam seq.context; + latoms=t::seq.latoms} + +let re_add_formula_list lf seq= + let do_one f cm= + if f.id == dummy_id then cm + else cm_add f.constr f.id cm in + {seq with + redexes=List.fold_right HP.add lf seq.redexes; + context=List.fold_right do_one lf seq.context} + +let find_left t seq=List.hd (CM.find t seq.context) + +(*let rev_left seq= + try + let lpat=(HP.maximum seq.redexes).pat in + left_reversible lpat + with Heap.EmptyHeap -> false +*) +let no_formula seq= + seq.redexes=HP.empty + +let rec take_formula seq= + let hd=HP.maximum seq.redexes + and hp=HP.remove seq.redexes in + if hd.id == dummy_id then + let nseq={seq with redexes=hp} in + if seq.gl==hd.constr then + hd,nseq + else + take_formula nseq (* discarding deprecated goal *) + else + hd,{seq with + redexes=hp; + context=cm_remove hd.constr hd.id seq.context} + +let empty_seq depth= + {redexes=HP.empty; + context=CM.empty; + latoms=[]; + gl=(mkMeta 1); + glatom=None; + cnt=newcnt (); + history=History.empty; + depth=depth} + +let create_with_ref_list l depth gl= + let f gr seq= + let c=constr_of_reference gr in + let typ=(pf_type_of gl c) in + add_formula Hyp gr typ seq gl in + List.fold_right f l (empty_seq depth) + +open Auto + +let create_with_auto_hints l depth gl= + let seqref=ref (empty_seq depth) in + let f p_a_t = + match p_a_t.code with + Res_pf (c,_) | Give_exact c + | Res_pf_THEN_trivial_fail (c,_) -> + (try + let gr=reference_of_constr c in + let typ=(pf_type_of gl c) in + seqref:=add_formula Hint gr typ !seqref gl + with Not_found->()) + | _-> () in + let g _ l=List.iter f l in + let h dbname= + let hdb= + try + Util.Stringmap.find dbname !searchtable + with Not_found-> + error ("Firstorder: "^dbname^" : No such Hint database") in + Hint_db.iter g hdb in + List.iter h l; + !seqref + +let print_cmap map= + let print_entry c l s= + let xc=Constrextern.extern_constr false (Global.env ()) c in + str "| " ++ + Util.prlist (Ppconstr.pr_global Idset.empty) l ++ + str " : " ++ + Ppconstr.pr_constr xc ++ + cut () ++ + s in + msgnl (v 0 + (str "-----" ++ + cut () ++ + CM.fold print_entry map (mt ()) ++ + str "-----")) + + diff --git a/contrib/first-order/sequent.mli b/contrib/first-order/sequent.mli new file mode 100644 index 00000000..df27d2ff --- /dev/null +++ b/contrib/first-order/sequent.mli @@ -0,0 +1,66 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: sequent.mli,v 1.8.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +open Term +open Util +open Formula +open Tacmach +open Names +open Libnames + +module OrderedConstr: Set.OrderedType with type t=constr + +module CM: Map.S with type key=constr + +type h_item = global_reference * (int*constr) option + +module History: Set.S with type elt = h_item + +val cm_add : constr -> global_reference -> global_reference list CM.t -> + global_reference list CM.t + +val cm_remove : constr -> global_reference -> global_reference list CM.t -> + global_reference list CM.t + +module HP: Heap.S with type elt=Formula.t + +type t = {redexes:HP.t; + context: global_reference list CM.t; + latoms:constr list; + gl:types; + glatom:constr option; + cnt:counter; + history:History.t; + depth:int} + +val deepen: t -> t + +val record: h_item -> t -> t + +val lookup: h_item -> t -> bool + +val add_formula : side -> global_reference -> constr -> t -> + Proof_type.goal sigma -> t + +val re_add_formula_list : Formula.t list -> t -> t + +val find_left : constr -> t -> global_reference + +val take_formula : t -> Formula.t * t + +val empty_seq : int -> t + +val create_with_ref_list : global_reference list -> + int -> Proof_type.goal sigma -> t + +val create_with_auto_hints : Auto.hint_db_name list -> + int -> Proof_type.goal sigma -> t + +val print_cmap: global_reference list CM.t -> unit diff --git a/contrib/first-order/unify.ml b/contrib/first-order/unify.ml new file mode 100644 index 00000000..1186fb90 --- /dev/null +++ b/contrib/first-order/unify.ml @@ -0,0 +1,143 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i $Id: unify.ml,v 1.10.2.1 2004/07/16 19:30:10 herbelin Exp $ i*) + +open Util +open Formula +open Tacmach +open Term +open Names +open Termops +open Reductionops + +exception UFAIL of constr*constr + +(* + RIGID-only Martelli-Montanari style unification for CLOSED terms + I repeat : t1 and t2 must NOT have ANY free deBruijn + sigma is kept normal with respect to itself but is lazily applied + to the equation set. Raises UFAIL with a pair of terms +*) + +let unif t1 t2= + let bige=Queue.create () + and sigma=ref [] in + let bind i t= + sigma:=(i,t):: + (List.map (function (n,tn)->(n,subst_meta [i,t] tn)) !sigma) in + let rec head_reduce t= + (* forbids non-sigma-normal meta in head position*) + match kind_of_term t with + Meta i-> + (try + head_reduce (List.assoc i !sigma) + with Not_found->t) + | _->t in + Queue.add (t1,t2) bige; + try while true do + let t1,t2=Queue.take bige in + let nt1=head_reduce (whd_betaiotazeta t1) + and nt2=head_reduce (whd_betaiotazeta t2) in + match (kind_of_term nt1),(kind_of_term nt2) with + Meta i,Meta j-> + if i<>j then + if i<j then bind j nt1 + else bind i nt2 + | Meta i,_ -> + let t=subst_meta !sigma nt2 in + if Intset.is_empty (free_rels t) && + not (occur_term (mkMeta i) t) then + bind i t else raise (UFAIL(nt1,nt2)) + | _,Meta i -> + let t=subst_meta !sigma nt1 in + if Intset.is_empty (free_rels t) && + not (occur_term (mkMeta i) t) then + bind i t else raise (UFAIL(nt1,nt2)) + | Cast(_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige + | _,Cast(_,_)->Queue.add (nt1,strip_outer_cast nt2) bige + | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> + Queue.add (a,c) bige;Queue.add (pop b,pop d) bige + | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> + Queue.add (pa,pb) bige; + Queue.add (ca,cb) bige; + let l=Array.length va in + if l<>(Array.length vb) then + raise (UFAIL (nt1,nt2)) + else + for i=0 to l-1 do + Queue.add (va.(i),vb.(i)) bige + done + | App(ha,va),App(hb,vb)-> + Queue.add (ha,hb) bige; + let l=Array.length va in + if l<>(Array.length vb) then + raise (UFAIL (nt1,nt2)) + else + for i=0 to l-1 do + Queue.add (va.(i),vb.(i)) bige + done + | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2)) + done; + assert false + (* this place is unreachable but needed for the sake of typing *) + with Queue.Empty-> !sigma + +let value i t= + let add x y= + if x<0 then y else if y<0 then x else x+y in + let tref=mkMeta i in + let rec vaux term= + if term=tref then 0 else + let f v t=add v (vaux t) in + let vr=fold_constr f (-1) term in + if vr<0 then -1 else vr+1 in + vaux t + +type instance= + Real of (int*constr)*int + | Phantom of constr + +let mk_rel_inst t= + let new_rel=ref 1 in + let rel_env=ref [] in + let rec renum_rec d t= + match kind_of_term t with + Meta n-> + (try + mkRel (d+(List.assoc n !rel_env)) + with Not_found-> + let m= !new_rel in + incr new_rel; + rel_env:=(n,m) :: !rel_env; + mkRel (m+d)) + | _ -> map_constr_with_binders succ renum_rec d t + in + let nt=renum_rec 0 t in (!new_rel - 1,nt) + +let unif_atoms i dom t1 t2= + try + let t=List.assoc i (unif t1 t2) in + if isMeta t then Some (Phantom dom) + else Some (Real(mk_rel_inst t,value i t1)) + with + UFAIL(_,_) ->None + | Not_found ->Some (Phantom dom) + +let renum_metas_from k n t= (* requires n = max (free_rels t) *) + let l=list_tabulate (fun i->mkMeta (k+i)) n in + substl l t + +let more_general (m1,t1) (m2,t2)= + let mt1=renum_metas_from 0 m1 t1 + and mt2=renum_metas_from m1 m2 t2 in + try + let sigma=unif mt1 mt2 in + let p (n,t)= n<m1 || isMeta t in + List.for_all p sigma + with UFAIL(_,_)->false diff --git a/contrib/first-order/unify.mli b/contrib/first-order/unify.mli new file mode 100644 index 00000000..dd9dbdec --- /dev/null +++ b/contrib/first-order/unify.mli @@ -0,0 +1,23 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: unify.mli,v 1.7.2.1 2004/07/16 19:30:10 herbelin Exp $ *) + +open Term + +exception UFAIL of constr*constr + +val unif : constr -> constr -> (int*constr) list + +type instance= + Real of (int*constr)*int (* nb trous*terme*valeur heuristique *) + | Phantom of constr (* domaine de quantification *) + +val unif_atoms : metavariable -> constr -> constr -> constr -> instance option + +val more_general : (int*constr) -> (int*constr) -> bool diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v new file mode 100644 index 00000000..f6faf94c --- /dev/null +++ b/contrib/fourier/Fourier.v @@ -0,0 +1,25 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Fourier.v,v 1.4.2.1 2004/07/16 19:30:11 herbelin Exp $ *) + +(* "Fourier's method to solve linear inequations/equations systems.".*) + +Declare ML Module "quote". +Declare ML Module "ring". +Declare ML Module "fourier". +Declare ML Module "fourierR". +Declare ML Module "field". + +Require Export Fourier_util. +Require Export Field. +Require Export DiscrR. + +Ltac fourier := abstract (fourierz; field; discrR). + +Ltac fourier_eq := apply Rge_antisym; fourier. diff --git a/contrib/fourier/Fourier_util.v b/contrib/fourier/Fourier_util.v new file mode 100644 index 00000000..abcd4449 --- /dev/null +++ b/contrib/fourier/Fourier_util.v @@ -0,0 +1,222 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Fourier_util.v,v 1.4.2.1 2004/07/16 19:30:11 herbelin Exp $ *) + +Require Export Rbase. +Comments "Lemmas used by the tactic Fourier". + +Open Scope R_scope. + +Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1. +intros; apply Rmult_lt_compat_l; assumption. +Qed. + +Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. +red in |- *. +intros. +case H; auto with real. +Qed. + +Lemma Rfourier_lt_lt : + forall x1 y1 x2 y2 a:R, + x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. +intros x1 y1 x2 y2 a H H0 H1; try assumption. +apply Rplus_lt_compat. +try exact H. +apply Rfourier_lt. +try exact H0. +try exact H1. +Qed. + +Lemma Rfourier_lt_le : + forall x1 y1 x2 y2 a:R, + x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. +intros x1 y1 x2 y2 a H H0 H1; try assumption. +case H0; intros. +apply Rplus_lt_compat. +try exact H. +apply Rfourier_lt; auto with real. +rewrite H2. +rewrite (Rplus_comm y1 (a * y2)). +rewrite (Rplus_comm x1 (a * y2)). +apply Rplus_lt_compat_l. +try exact H. +Qed. + +Lemma Rfourier_le_lt : + forall x1 y1 x2 y2 a:R, + x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. +intros x1 y1 x2 y2 a H H0 H1; try assumption. +case H; intros. +apply Rfourier_lt_le; auto with real. +rewrite H2. +apply Rplus_lt_compat_l. +apply Rfourier_lt; auto with real. +Qed. + +Lemma Rfourier_le_le : + forall x1 y1 x2 y2 a:R, + x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. +intros x1 y1 x2 y2 a H H0 H1; try assumption. +case H0; intros. +red in |- *. +left; try assumption. +apply Rfourier_le_lt; auto with real. +rewrite H2. +case H; intros. +red in |- *. +left; try assumption. +rewrite (Rplus_comm x1 (a * y2)). +rewrite (Rplus_comm y1 (a * y2)). +apply Rplus_lt_compat_l. +try exact H3. +rewrite H3. +red in |- *. +right; try assumption. +auto with real. +Qed. + +Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. +intros x H; try assumption. +rewrite Rplus_comm. +apply Rle_lt_0_plus_1. +red in |- *; auto with real. +Qed. + +Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. +intros x y H H0; try assumption. +replace 0 with (x * 0). +apply Rmult_lt_compat_l; auto with real. +ring. +Qed. + +Lemma Rlt_zero_1 : 0 < 1. +exact Rlt_0_1. +Qed. + +Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. +intros x H; try assumption. +case H; intros. +red in |- *. +left; try assumption. +apply Rlt_zero_pos_plus1; auto with real. +rewrite <- H0. +replace (1 + 0) with 1. +red in |- *; left. +exact Rlt_zero_1. +ring. +Qed. + +Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. +intros x y H H0; try assumption. +case H; intros. +red in |- *; left. +apply Rlt_mult_inv_pos; auto with real. +rewrite <- H1. +red in |- *; right; ring. +Qed. + +Lemma Rle_zero_1 : 0 <= 1. +red in |- *; left. +exact Rlt_zero_1. +Qed. + +Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. +intros n d H; red in |- *; intros H0; try exact H0. +generalize (Rgt_not_le 0 (n * / d)). +intros H1; elim H1; try assumption. +replace (n * / d) with (- - (n * / d)). +replace 0 with (- -0). +replace (- (n * / d)) with (- n * / d). +replace (-0) with 0. +red in |- *. +apply Ropp_gt_lt_contravar. +red in |- *. +exact H0. +ring. +ring. +ring. +ring. +Qed. + +Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. +intros x; try assumption. +replace (0 * x) with 0. +apply Rlt_irrefl. +ring. +Qed. + +Lemma Rlt_not_le : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. +intros n d H; try assumption. +apply Rgt_not_le. +replace 0 with (-0). +replace (- n * / d) with (- (n * / d)). +apply Ropp_lt_gt_contravar. +try exact H. +ring. +ring. +Qed. + +Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. +unfold not in |- *; intros. +apply H. +apply Rplus_lt_reg_r with x. +replace (x + 0) with x. +replace (x + (y - x)) with y. +try exact H0. +ring. +ring. +Qed. + +Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. +unfold not in |- *; intros. +apply H. +case H0; intros. +left. +apply Rplus_lt_reg_r with x. +replace (x + 0) with x. +replace (x + (y - x)) with y. +try exact H1. +ring. +ring. +right. +rewrite H1; ring. +Qed. + +Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. +unfold Rgt in |- *; intros; assumption. +Qed. + +Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. +intros x y; exact (Rge_le y x). +Qed. + +Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. +exact Req_le. +Qed. + +Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. +exact Req_le_sym. +Qed. + +Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. +exact Rnot_ge_lt. +Qed. + +Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. +exact Rnot_gt_le. +Qed. + +Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. +exact Rnot_le_lt. +Qed. + +Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. +exact Rnot_lt_ge. +Qed. diff --git a/contrib/fourier/fourier.ml b/contrib/fourier/fourier.ml new file mode 100644 index 00000000..f5763c34 --- /dev/null +++ b/contrib/fourier/fourier.ml @@ -0,0 +1,205 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: fourier.ml,v 1.2.16.1 2004/07/16 19:30:11 herbelin Exp $ *) + +(* Méthode d'élimination de Fourier *) +(* Référence: +Auteur(s) : Fourier, Jean-Baptiste-Joseph + +Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,... + +Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890 + +Pages: 326-327 + +http://gallica.bnf.fr/ +*) + +(* Un peu de calcul sur les rationnels... +Les opérations rendent des rationnels normalisés, +i.e. le numérateur et le dénominateur sont premiers entre eux. +*) +type rational = {num:int; + den:int} +;; +let print_rational x = + print_int x.num; + print_string "/"; + print_int x.den +;; + +let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);; + + +let r0 = {num=0;den=1};; +let r1 = {num=1;den=1};; + +let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in + if x.num=0 then r0 + else (let d=pgcd x.num x.den in + let d= (if d<0 then -d else d) in + {num=(x.num)/d;den=(x.den)/d});; + +let rop x = rnorm {num=(-x.num);den=x.den};; + +let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};; + +let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};; + +let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};; + +let rinv x = rnorm {num=x.den;den=x.num};; + +let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};; + +let rinf x y = x.num*y.den < y.num*x.den;; +let rinfeq x y = x.num*y.den <= y.num*x.den;; + +(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation +c1x1+...+cnxn < d si strict=true, <= sinon, +hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ. +*) + +type ineq = {coef:rational list; + hist:rational list; + strict:bool};; + +let pop x l = l:=x::(!l);; + +(* sépare la liste d'inéquations s selon que leur premier coefficient est +négatif, nul ou positif. *) +let partitionne s = + let lpos=ref [] in + let lneg=ref [] in + let lnul=ref [] in + List.iter (fun ie -> match ie.coef with + [] -> raise (Failure "empty ineq") + |(c::r) -> if rinf c r0 + then pop ie lneg + else if rinf r0 c then pop ie lpos + else pop ie lnul) + s; + [!lneg;!lnul;!lpos] +;; +(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!): +(add_hist [(equation 1, s1);...;(équation n, sn)]) += +[{équation 1, [1;0;...;0], s1}; + {équation 2, [0;1;...;0], s2}; + ... + {équation n, [0;0;...;1], sn}] +*) +let add_hist le = + let n = List.length le in + let i=ref 0 in + List.map (fun (ie,s) -> + let h =ref [] in + for k=1 to (n-(!i)-1) do pop r0 h; done; + pop r1 h; + for k=1 to !i do pop r0 h; done; + i:=!i+1; + {coef=ie;hist=(!h);strict=s}) + le +;; +(* additionne deux inéquations *) +let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; + hist=List.map2 rplus ie1.hist ie2.hist; + strict=ie1.strict || ie2.strict} +;; +(* multiplication d'une inéquation par un rationnel (positif) *) +let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef; + hist=List.map (fun x -> rmult a x) ie.hist; + strict= ie.strict} +;; +(* on enlève le premier coefficient *) +let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict} +;; +(* le premier coefficient: "tête" de l'inéquation *) +let hd_coef ie = List.hd ie.coef +;; + +(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient. +*) +let deduce_add lneg lpos = + let res=ref [] in + List.iter (fun i1 -> + List.iter (fun i2 -> + let a = rop (hd_coef i1) in + let b = hd_coef i2 in + pop (ie_tl (ie_add (ie_emult b i1) + (ie_emult a i2))) res) + lpos) + lneg; + !res +;; +(* élimination de la première variable à partir d'une liste d'inéquations: +opération qu'on itère dans l'algorithme de Fourier. +*) +let deduce1 s = + match (partitionne s) with + [lneg;lnul;lpos] -> + let lnew = deduce_add lneg lpos in + (List.map ie_tl lnul)@lnew + |_->assert false +;; +(* algorithme de Fourier: on élimine successivement toutes les variables. +*) +let deduce lie = + let n = List.length (fst (List.hd lie)) in + let lie=ref (add_hist lie) in + for i=1 to n-1 do + lie:= deduce1 !lie; + done; + !lie +;; + +(* donne [] si le système a des solutions, +sinon donne [c,s,lc] +où lc est la combinaison linéaire des inéquations de départ +qui donne 0 < c si s=true + ou 0 <= c sinon +cette inéquation étant absurde. +*) +let unsolvable lie = + let lr = deduce lie in + let res = ref [] in + (try (List.iter (fun e -> + match e with + {coef=[c];hist=lc;strict=s} -> + if (rinf c r0 && (not s)) || (rinfeq c r0 && s) + then (res := [c,s,lc]; + raise (Failure "contradiction found")) + |_->assert false) + lr) + with _ -> ()); + !res +;; + +(* Exemples: + +let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];; +deduce test1;; +unsolvable test1;; + +let test2=[ +[r1;r1;r0;r0;r0],false; +[r0;r1;r1;r0;r0],false; +[r0;r0;r1;r1;r0],false; +[r0;r0;r0;r1;r1],false; +[r1;r0;r0;r0;r1],false; +[rop r1;rop r1;r0;r0;r0],false; +[r0;rop r1;rop r1;r0;r0],false; +[r0;r0;rop r1;rop r1;r0],false; +[r0;r0;r0;rop r1;rop r1],false; +[rop r1;r0;r0;r0;rop r1],false +];; +deduce test2;; +unsolvable test2;; + +*)
\ No newline at end of file diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml new file mode 100644 index 00000000..49fa35da --- /dev/null +++ b/contrib/fourier/fourierR.ml @@ -0,0 +1,630 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: fourierR.ml,v 1.14.2.2 2004/07/19 13:28:28 herbelin Exp $ *) + + + +(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients +des inéquations et équations sont entiers. En attendant la tactique Field. +*) + +open Term +open Tactics +open Clenv +open Names +open Libnames +open Tacticals +open Tacmach +open Fourier +open Contradiction + +(****************************************************************************** +Opérations sur les combinaisons linéaires affines. +La partie homogène d'une combinaison linéaire est en fait une table de hash +qui donne le coefficient d'un terme du calcul des constructions, +qui est zéro si le terme n'y est pas. +*) + +type flin = {fhom:(constr , rational)Hashtbl.t; + fcste:rational};; + +let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};; + +let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;; + +let flin_add f x c = + let cx = flin_coef f x in + Hashtbl.remove f.fhom x; + Hashtbl.add f.fhom x (rplus cx c); + f +;; +let flin_add_cste f c = + {fhom=f.fhom; + fcste=rplus f.fcste c} +;; + +let flin_one () = flin_add_cste (flin_zero()) r1;; + +let flin_plus f1 f2 = + let f3 = flin_zero() in + Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; + Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; + flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; +;; + +let flin_minus f1 f2 = + let f3 = flin_zero() in + Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; + Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; + flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste); +;; +let flin_emult a f = + let f2 = flin_zero() in + Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; + flin_add_cste f2 (rmult a f.fcste); +;; + +(*****************************************************************************) +open Vernacexpr + +type ineq = Rlt | Rle | Rgt | Rge + +let string_of_R_constant kn = + match Names.repr_kn kn with + | MPfile dir, sec_dir, id when + sec_dir = empty_dirpath && + string_of_dirpath dir = "Coq.Reals.Rdefinitions" + -> string_of_label id + | _ -> "constant_not_of_R" + +let rec string_of_R_constr c = + match kind_of_term c with + Cast (c,t) -> 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) + | App (c,args) -> + (match (string_of_R_constr c) with + | "Ropp" -> + rop (rational_of_constr args.(0)) + | "Rinv" -> + rinv (rational_of_constr args.(0)) + | "Rmult" -> + rmult (rational_of_constr args.(0)) + (rational_of_constr args.(1)) + | "Rdiv" -> + rdiv (rational_of_constr args.(0)) + (rational_of_constr args.(1)) + | "Rplus" -> + rplus (rational_of_constr args.(0)) + (rational_of_constr args.(1)) + | "Rminus" -> + rminus (rational_of_constr args.(0)) + (rational_of_constr args.(1)) + | _ -> failwith "not a rational") + | Const kn -> + (match (string_of_R_constant kn) with + "R1" -> r1 + |"R0" -> r0 + | _ -> failwith "not a rational") + | _ -> failwith "not a rational" +;; + +let rec flin_of_constr c = + try( + match kind_of_term c with + | Cast (c,t) -> (flin_of_constr c) + | App (c,args) -> + (match (string_of_R_constr c) with + "Ropp" -> + flin_emult (rop r1) (flin_of_constr args.(0)) + | "Rplus"-> + flin_plus (flin_of_constr args.(0)) + (flin_of_constr args.(1)) + | "Rminus"-> + flin_minus (flin_of_constr args.(0)) + (flin_of_constr args.(1)) + | "Rmult"-> + (try (let a=(rational_of_constr args.(0)) in + try (let b = (rational_of_constr args.(1)) in + (flin_add_cste (flin_zero()) (rmult a b))) + with _-> (flin_add (flin_zero()) + args.(1) + a)) + with _-> (flin_add (flin_zero()) + args.(0) + (rational_of_constr args.(1)))) + | "Rinv"-> + let a=(rational_of_constr args.(0)) in + flin_add_cste (flin_zero()) (rinv a) + | "Rdiv"-> + (let b=(rational_of_constr args.(1)) in + try (let a = (rational_of_constr args.(0)) in + (flin_add_cste (flin_zero()) (rdiv a b))) + with _-> (flin_add (flin_zero()) + args.(0) + (rinv b))) + |_->assert false) + | Const c -> + (match (string_of_R_constant c) with + "R1" -> flin_one () + |"R0" -> flin_zero () + |_-> assert false) + |_-> assert false) + with _ -> flin_add (flin_zero()) + c + r1 +;; + +let flin_to_alist f = + let res=ref [] in + Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f; + !res +;; + +(* Représentation des hypothèses qui sont des inéquations ou des équations. +*) +type hineq={hname:constr; (* le nom de l'hypothèse *) + htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *) + hleft:constr; + hright:constr; + hflin:flin; + hstrict:bool} +;; + +(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0 +*) +let ineq1_of_constr (h,t) = + match (kind_of_term t) with + App (f,args) -> + (match kind_of_term f with + Const c when Array.length args = 2 -> + let t1= args.(0) in + let t2= args.(1) in + (match (string_of_R_constant c) with + "Rlt" -> [{hname=h; + htype="Rlt"; + hleft=t1; + hright=t2; + hflin= flin_minus (flin_of_constr t1) + (flin_of_constr t2); + hstrict=true}] + |"Rgt" -> [{hname=h; + htype="Rgt"; + hleft=t2; + hright=t1; + hflin= flin_minus (flin_of_constr t2) + (flin_of_constr t1); + hstrict=true}] + |"Rle" -> [{hname=h; + htype="Rle"; + hleft=t1; + hright=t2; + hflin= flin_minus (flin_of_constr t1) + (flin_of_constr t2); + hstrict=false}] + |"Rge" -> [{hname=h; + htype="Rge"; + hleft=t2; + hright=t1; + hflin= flin_minus (flin_of_constr t2) + (flin_of_constr t1); + hstrict=false}] + |_->assert false) + | Ind (kn,i) -> + if IndRef(kn,i) = Coqlib.glob_eqT then + let t0= args.(0) in + let t1= args.(1) in + let t2= args.(2) in + (match (kind_of_term t0) with + Const c -> + (match (string_of_R_constant c) with + "R"-> + [{hname=h; + htype="eqTLR"; + hleft=t1; + hright=t2; + hflin= flin_minus (flin_of_constr t1) + (flin_of_constr t2); + hstrict=false}; + {hname=h; + htype="eqTRL"; + hleft=t2; + hright=t1; + hflin= flin_minus (flin_of_constr t2) + (flin_of_constr t1); + hstrict=false}] + |_-> assert false) + |_-> assert false) + else + assert false + |_-> assert false) + |_-> assert false +;; + +(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) +*) + +let fourier_lineq lineq1 = + let nvar=ref (-1) in + let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *) + List.iter (fun f -> + Hashtbl.iter (fun x c -> + try (Hashtbl.find hvar x;()) + with _-> nvar:=(!nvar)+1; + Hashtbl.add hvar x (!nvar)) + f.hflin.fhom) + lineq1; + let sys= List.map (fun h-> + let v=Array.create ((!nvar)+1) r0 in + Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) + h.hflin.fhom; + ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) + lineq1 in + unsolvable sys +;; + +(*********************************************************************) +(* Defined constants *) + +let get = Lazy.force +let constant = Coqlib.gen_constant "Fourier" + +(* Standard library *) +open Coqlib +let coq_sym_eqT = lazy (build_coq_sym_eqT ()) +let coq_False = lazy (build_coq_False ()) +let coq_not = lazy (build_coq_not ()) +let coq_eq = lazy (build_coq_eq ()) + +(* Rdefinitions *) +let constant_real = constant ["Reals";"Rdefinitions"] + +let coq_Rlt = lazy (constant_real "Rlt") +let coq_Rgt = lazy (constant_real "Rgt") +let coq_Rle = lazy (constant_real "Rle") +let coq_Rge = lazy (constant_real "Rge") +let coq_R = lazy (constant_real "R") +let coq_Rminus = lazy (constant_real "Rminus") +let coq_Rmult = lazy (constant_real "Rmult") +let coq_Rplus = lazy (constant_real "Rplus") +let coq_Ropp = lazy (constant_real "Ropp") +let coq_Rinv = lazy (constant_real "Rinv") +let coq_R0 = lazy (constant_real "R0") +let coq_R1 = lazy (constant_real "R1") + +(* RIneq *) +let coq_Rinv_R1 = lazy (constant ["Reals";"RIneq"] "Rinv_R1") + +(* Fourier_util *) +let constant_fourier = constant ["fourier";"Fourier_util"] + +let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1") +let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1") +let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1") +let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos") +let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero") +let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1") +let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos") +let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0") +let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt") +let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt") +let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le") +let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le") +let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le") + +let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt") +let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le") +let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt") +let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge") +let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt") +let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le") +let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt") +let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le") +let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt") +let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le") +let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt") +let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le") +let coq_Rlt_not_le = lazy (constant_fourier "Rlt_not_le") + +(****************************************************************************** +Construction de la preuve en cas de succès de la méthode de Fourier, +i.e. on obtient une contradiction. +*) +let is_int x = (x.den)=1 +;; + +(* fraction = couple (num,den) *) +let rec rational_to_fraction x= (x.num,x.den) +;; + +(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) +*) +let int_to_real n = + let nn=abs n in + if nn=0 + then get coq_R0 + else + (let s=ref (get coq_R1) in + for i=1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done; + if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s) +;; +(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1))) +*) +let rational_to_real x = + let (n,d)=rational_to_fraction x in + mkApp (get coq_Rmult, + [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|]) +;; + +(* preuve que 0<n*1/d +*) +let tac_zero_inf_pos gl (n,d) = + let tacn=ref (apply (get coq_Rlt_zero_1)) in + let tacd=ref (apply (get coq_Rlt_zero_1)) in + for i=1 to n-1 do + tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done; + for i=1 to d-1 do + tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; + (tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd]) +;; + +(* preuve que 0<=n*1/d +*) +let tac_zero_infeq_pos gl (n,d)= + let tacn=ref (if n=0 + then (apply (get coq_Rle_zero_zero)) + else (apply (get coq_Rle_zero_1))) in + let tacd=ref (apply (get coq_Rlt_zero_1)) in + for i=1 to n-1 do + tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done; + for i=1 to d-1 do + tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; + (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd]) +;; + +(* preuve que 0<(-n)*(1/d) => False +*) +let tac_zero_inf_false gl (n,d) = + if n=0 then (apply (get coq_Rnot_lt0)) + else + (tclTHEN (apply (get coq_Rle_not_lt)) + (tac_zero_infeq_pos gl (-n,d))) +;; + +(* preuve que 0<=(-n)*(1/d) => False +*) +let tac_zero_infeq_false gl (n,d) = + (tclTHEN (apply (get coq_Rlt_not_le)) + (tac_zero_inf_pos gl (-n,d))) +;; + +let create_meta () = mkMeta(new_meta());; + +let my_cut c gl= + let concl = pf_concl gl in + apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl +;; + +let exact = exact_check;; + +let tac_use h = match h.htype with + "Rlt" -> exact h.hname + |"Rle" -> exact h.hname + |"Rgt" -> (tclTHEN (apply (get coq_Rfourier_gt_to_lt)) + (exact h.hname)) + |"Rge" -> (tclTHEN (apply (get coq_Rfourier_ge_to_le)) + (exact h.hname)) + |"eqTLR" -> (tclTHEN (apply (get coq_Rfourier_eqLR_to_le)) + (exact h.hname)) + |"eqTRL" -> (tclTHEN (apply (get coq_Rfourier_eqRL_to_le)) + (exact h.hname)) + |_->assert false +;; + +(* +let is_ineq (h,t) = + match (kind_of_term t) with + App (f,args) -> + (match (string_of_R_constr f) with + "Rlt" -> true + | "Rgt" -> true + | "Rle" -> true + | "Rge" -> true +(* Wrong:not in Rdefinitions: *) | "eqT" -> + (match (string_of_R_constr args.(0)) with + "R" -> true + | _ -> false) + | _ ->false) + |_->false +;; +*) + +let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;; + +let mkAppL a = + let l = Array.to_list a in + mkApp(List.hd l, Array.of_list (List.tl l)) +;; + +(* Résolution d'inéquations linéaires dans R *) +let rec fourier gl= + Library.check_required_library ["Coq";"fourier";"Fourier"]; + let goal = strip_outer_cast (pf_concl gl) in + let fhyp=id_of_string "new_hyp_for_fourier" in + (* si le but est une inéquation, on introduit son contraire, + et le but à prouver devient False *) + try (let tac = + match (kind_of_term goal) with + App (f,args) -> + (match (string_of_R_constr f) with + "Rlt" -> + (tclTHEN + (tclTHEN (apply (get coq_Rfourier_not_ge_lt)) + (intro_using fhyp)) + fourier) + |"Rle" -> + (tclTHEN + (tclTHEN (apply (get coq_Rfourier_not_gt_le)) + (intro_using fhyp)) + fourier) + |"Rgt" -> + (tclTHEN + (tclTHEN (apply (get coq_Rfourier_not_le_gt)) + (intro_using fhyp)) + fourier) + |"Rge" -> + (tclTHEN + (tclTHEN (apply (get coq_Rfourier_not_lt_ge)) + (intro_using fhyp)) + fourier) + |_->assert false) + |_->assert false + in tac gl) + with _ -> + (* les hypothèses *) + let hyps = List.map (fun (h,t)-> (mkVar h,(body_of_type t))) + (list_of_sign (pf_hyps gl)) in + let lineq =ref [] in + List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) + with _ -> ()) + hyps; + (* lineq = les inéquations découlant des hypothèses *) + if !lineq=[] then Util.error "No inequalities"; + let res=fourier_lineq (!lineq) in + let tac=ref tclIDTAC in + if res=[] + then (print_string "Tactic Fourier fails.\n"; + flush stdout) + (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) + else (match res with + [(cres,sres,lc)]-> + (* lc=coefficients multiplicateurs des inéquations + qui donnent 0<cres ou 0<=cres selon sres *) + (*print_string "Fourier's method can prove the goal...";flush stdout;*) + let lutil=ref [] in + List.iter + (fun (h,c) -> + if c<>r0 + then (lutil:=(h,c)::(!lutil)(*; + print_rational(c);print_string " "*))) + (List.combine (!lineq) lc); + (* on construit la combinaison linéaire des inéquation *) + (match (!lutil) with + (h1,c1)::lutil -> + let s=ref (h1.hstrict) in + let t1=ref (mkAppL [|get coq_Rmult; + rational_to_real c1; + h1.hleft|]) in + let t2=ref (mkAppL [|get coq_Rmult; + rational_to_real c1; + h1.hright|]) in + List.iter (fun (h,c) -> + s:=(!s)||(h.hstrict); + t1:=(mkAppL [|get coq_Rplus; + !t1; + mkAppL [|get coq_Rmult; + rational_to_real c; + h.hleft|] |]); + t2:=(mkAppL [|get coq_Rplus; + !t2; + mkAppL [|get coq_Rmult; + rational_to_real c; + h.hright|] |])) + lutil; + let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle; + !t1; + !t2 |] in + let tc=rational_to_real cres in + (* puis sa preuve *) + let tac1=ref (if h1.hstrict + then (tclTHENS (apply (get coq_Rfourier_lt)) + [tac_use h1; + tac_zero_inf_pos gl + (rational_to_fraction c1)]) + else (tclTHENS (apply (get coq_Rfourier_le)) + [tac_use h1; + tac_zero_inf_pos gl + (rational_to_fraction c1)])) in + s:=h1.hstrict; + List.iter (fun (h,c)-> + (if (!s) + then (if h.hstrict + then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt)) + [!tac1;tac_use h; + tac_zero_inf_pos gl + (rational_to_fraction c)]) + else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le)) + [!tac1;tac_use h; + tac_zero_inf_pos gl + (rational_to_fraction c)])) + else (if h.hstrict + then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt)) + [!tac1;tac_use h; + tac_zero_inf_pos gl + (rational_to_fraction c)]) + else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le)) + [!tac1;tac_use h; + tac_zero_inf_pos gl + (rational_to_fraction c)]))); + s:=(!s)||(h.hstrict)) + lutil; + let tac2= if sres + then tac_zero_inf_false gl (rational_to_fraction cres) + else tac_zero_infeq_false gl (rational_to_fraction cres) + in + tac:=(tclTHENS (my_cut ineq) + [tclTHEN (change_in_concl None + (mkAppL [| get coq_not; ineq|] + )) + (tclTHEN (apply (if sres then get coq_Rnot_lt_lt + else get coq_Rnot_le_le)) + (tclTHENS (Equality.replace + (mkAppL [|get coq_Rminus;!t2;!t1|] + ) + tc) + [tac2; + (tclTHENS + (Equality.replace + (mkApp (get coq_Rinv, + [|get coq_R1|])) + (get coq_R1)) +(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) + + [tclORELSE + (Ring.polynom []) + tclIDTAC; + (tclTHEN (apply (get coq_sym_eqT)) + (apply (get coq_Rinv_R1)))] + + ) + ])); + !tac1]); + tac:=(tclTHENS (cut (get coq_False)) + [tclTHEN intro (contradiction None); + !tac]) + |_-> assert false) |_-> assert false + ); +(* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) + (!tac gl) +(* ((tclABSTRACT None !tac) gl) *) + +;; + +(* +let fourier_tac x gl = + fourier gl +;; + +let v_fourier = add_tactic "Fourier" fourier_tac +*) + diff --git a/contrib/fourier/g_fourier.ml4 b/contrib/fourier/g_fourier.ml4 new file mode 100644 index 00000000..05c3adbd --- /dev/null +++ b/contrib/fourier/g_fourier.ml4 @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* $Id: g_fourier.ml4,v 1.1.12.1 2004/07/16 19:30:11 herbelin Exp $ *) + +open FourierR + +TACTIC EXTEND Fourier + [ "FourierZ" (* constr_list(l) *) ] -> [ fourier (* l *) ] +END diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4 new file mode 100644 index 00000000..d2ae12d6 --- /dev/null +++ b/contrib/funind/tacinv.ml4 @@ -0,0 +1,853 @@ +(*i camlp4deps: "parsing/grammar.cma" i*) + +(*s FunInv Tactic: inversion following the shape of a function. *) +(* Use: + \begin{itemize} + \item The Tacinv directory must be in the path (-I <path> option) + \item use the bytecode version of coqtop or coqc (-byte option), or make a + coqtop + \item Do [Require Tacinv] to be able to use it. + \item For syntax see Tacinv.v + \end{itemize} +*) + + +(*i*) +open Termops +open Equality +open Names +open Pp +open Tacmach +open Proof_type +open Tacinterp +open Tactics +open Tacticals +open Term +open Util +open Printer +open Reductionops +open Inductiveops +open Coqlib +open Refine +open Typing +open Declare +open Decl_kinds +open Safe_typing +open Vernacinterp +open Evd +open Environ +open Entries +open Setoid_replace +open Tacinvutils +(*i*) + +module Smap = Map.Make(struct type t = constr let compare = compare end) +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 mkthesort = mkProp (* would like to put Type here, but with which index? *) + +(* this is the prefix used to name equality hypothesis generated by + case analysis*) +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 *) +let id_of_name = function + Anonymous -> id_of_string "H" + | Name id -> id;; +let string_of_name nme = string_of_id (id_of_name nme) + (*end debugging *) + +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 + (function (r,(typofg,g,d)) + -> lift 1 r, (lift 1 typofg, lift 1 g , lift 1 d)) leq + +let lift1_relleqs leq= List.map (function (r,x) -> lift 1 r,x) leq + +(* WARNING: In the types, we don't lift the rels in the type. This is + intentional. Use with care. *) +let lift1_lvars lvars= List.map + (function x,(nme,c) -> lift 1 x, (nme, (*lift 1*) c)) lvars + +let pop1_levar levars = List.map (function ev,tev -> ev, popn 1 tev) levars + + +let rec add_n_dummy_prod t n = + if n<=0 then t + else add_n_dummy_prod (mkNamedProd (id_of_string "DUMMY") mkthesort t) (n-1) + +(* [add_lambdas t gl [csr1;csr2...]] returns [[x1:type of csr1] + [x2:type of csr2] t [csr <- x1 ...]], names of abstracted variables + are not specified *) +let rec add_lambdas t gl lcsr = + match lcsr with + | [] -> t + | csr::lcsr' -> + let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in + lambda_id hyp_csr hyptyp (add_lambdas t gl lcsr') + +(* [add_pis t gl [csr1;csr2...]] returns ([x1] :type of [csr1] + [x2]:type of csr2) [t]*) +let rec add_pis t gl lcsr = + match lcsr with + | [] -> t + | csr::lcsr' -> + let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in + prod_id hyp_csr hyptyp (add_pis t gl lcsr') + +let mkProdEg teq eql eqr concl = + mkProd (name_of_string "eg", mkEq teq eql eqr, lift 1 concl) + +let eqs_of_beqs x = + List.map (function (_,(a,b,c)) -> (Anonymous, mkEq a b c)) x + + +let rec eqs_of_beqs_named_aux s i l = + match l with + | [] -> [] + | (r,(a,b,c))::l' -> + (Name(id_of_string (s^ string_of_int i)), mkEq a b c) + ::eqs_of_beqs_named_aux s (i-1) l' + + +let eqs_of_beqs_named s l = eqs_of_beqs_named_aux s (List.length l) l + +let rec patternify ltypes c nme = + match ltypes with + | [] -> c + | (mv,t)::ltypes' -> + let c'= substitterm 0 mv (mkRel 1) c in + let tlift = lift (List.length ltypes') t in + let res = + patternify ltypes' (mkLambda (newname_append nme "rec", tlift, c')) nme in + res + +let rec npatternify ltypes c = + match ltypes with + | [] -> c + | (mv,nme,t)::ltypes' -> + let c'= substitterm 0 mv (mkRel 1) c in +(* let _ = prconstr c' in *) + let tlift = lift (List.length ltypes') t in + let res = + npatternify ltypes' (mkLambda (newname_append nme "", tlift, c')) in +(* let _ = prconstr res in *) + res + +let rec apply_levars c lmetav = + match lmetav with + | [] -> [],c + | (i,typ) :: lmetav' -> + let levars,trm = apply_levars c lmetav' in + let exkey = mknewexist() in + ((exkey,typ)::levars), applistc trm [mkEvar exkey] + (* EXPERIMENT le refine est plus long si on met un cast: + ((exkey,typ)::levars), mkCast ((applistc trm [mkEvar exkey]),typ) *) + + +let prod_change_concl c newconcl = + let lv,_ = decompose_prod c in prod_it newconcl lv + +let lam_change_concl c newconcl = + let lv,_ = decompose_prod c in lam_it newconcl lv + + +let rec mkAppRel c largs n = + match largs with + | [] -> c + | arg::largs' -> + let newc = mkApp (c,[|(mkRel n)|]) in mkAppRel newc largs' (n-1) + +let applFull c typofc = + let lv,t = decompose_prod typofc in + let ltyp = List.map fst lv in + let res = mkAppRel c ltyp (List.length ltyp) in + res + + +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 + | 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.") + | _,_ -> 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 + + +(*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} +*) + +type mimickinfo = + { + concl: constr; + absconcl: constr array; + mimick: constr; + env: env; + sigma: Evd.evar_map; + nmefonc: constr array; + fonc: int * int; + 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 + found before a case or a fix are treated as parameters of + the induction principle *) + } + +(* + \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 = + { + princ:constr; + evarlist: (constr*Term.types) list; + hypnum: (int*int*int) list; + mutfixmetas: constr array ; + conclarray: types array; + params:(constr*name*constr) list + } + +(* + 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. + + \item[[(ev1,tev1);(ev2,tev2)...]] est l'ensemble des méta variables + correspondant à des trous. [evi] est la meta variable, [tevi] est son type. + + \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. + + \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. + + \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 = + 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 + 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,[] + + (* <pcase> Cases b of arrPt end.*) + | 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 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)*) + + | 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 + (* 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,[] + 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) + + | 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 nb_vars = (List.length varnames) in + let nb_eqs = (List.length lst_eqs) in + let eqrels = List.map fst lst_eqs in + (* [terms_recs]: appel rec du fixpoint, On concatène les appels recs + trouvés dans les let in et les Cases. *) + (* TODO: il faudra gérer plusieurs pt fixes imbriqués ? *) + let terms_recs = 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. *) + (* d'abord, on fabrique les types des appels recursifs en replacant le nom + de des fonctions par les predicats dans [terms_recs]: [(f_i t u v)] + devient [(P_i t u v)] *) + (* TODO optimiser ici: *) + 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,[] + + + +let mkevarmap_aux ex = let x,y = ex in (mkevarmap_from_listex x),y + +(* Interpretation of constr's *) +let constr_of_Constr c = Constrintern.interp_constr Evd.empty (Global.env()) c + + +(* TODO: deal with any term, not only a constant. *) +let interp_fonc_tacarg fonctac gl = + (* [fonc] is the constr corresponding to fontact not unfolded, + if [fonctac] is a (qualified) name then this is a [const] ?. *) +(* let fonc = constr_of_Constr fonctac in *) + (* TODO: replace the [with _ -> ] by something more precise in + the following. *) + (* [def_fonc] is the definition of fonc. TODO: We should do this only + if [fonc] is a const, and take [fonc] otherwise.*) + try fonctac, pf_const_value gl (destConst fonctac) + with _ -> failwith ("don't know how to deal with this function " + ^"(DEBUG:is it a constante?)") + + + + +(* [invfun_proof fonc def_fonc gl_abstr pis] builds the principle, + following the shape of [def_fonc], [fonc] is the constant + corresponding to [def_func] (or a reduced form of it ?), gl_abstr and + pis are the goal to be proved, of the form [x,y...]g and (x.y...)g. + + This function calls the big function proofPrinc. *) + +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 + +(* 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 = + if i<=0 then tclIDTAC else + tclTHEN + (tclTHEN + intro + (iterintro (i-1))) + (fun gl -> + (tclREPEAT + (tclNTH_HYP i + (fun hyp -> + let hypname = (string_of_id (destVar hyp)) in + 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") + )) gl) + + +(* + (fun hyp gl -> + let _ = print_string ("nthhyp= "^ string_of_int i) in + if isConst hyp && ((name_of_const hyp)==heq_prefix) then + let _ = print_string "YES\n" in + rewriteLR hyp gl + else + let _ = print_string "NO\n" in + tclIDTAC gl) + *) + +(* [invfun_basic C listargs_ids gl dorew lposeq] builds the tactic + which: + \begin{itemize} + \item Do refine on C (the induction principle), + \item try to Clear listargs_ids + \item if boolean dorew is true, then intro all new hypothesis, and + try rewrite on those hypothesis that are equalities. + \end{itemize} +*) + +let invfun_basic open_princ_proof_applied listargs_ids gl dorew lposeq = + (tclTHEN_i + (tclTHEN + (tclTHEN + (* Refine on the right term (following the sheme of the + given function) *) + (fun gl -> refine open_princ_proof_applied gl) + (* Clear the hypothesis given as arguments of the tactic + (because they are generalized) *) + (tclTHEN simpl_in_concl (tclTRY (clear listargs_ids)))) + (* Now we introduce the created hypothesis, and try rewrite on + equalities due to case analysis *) + (fun gl -> (tclIDTAC gl))) + (fun i gl -> + if not dorew then tclIDTAC gl + else + (* d,m,f correspond respectively to vars, induction hyps and + equalities*) + let d,m,f = List.nth lposeq (i-1) in + tclTHEN (iterintro (d)) (tclDO m (tclTRY intro)) gl) + ) + gl + + + + +(* This function trys to reduce instanciated arguments, provided they + are of the form [(C t u v...)] where [C] is a constructor, and + provided that the argument is not the argument of a fixpoint (i.e. the + argument corresponds to a simple lambda) . *) +let rec applistc_iota cstr lcstr env sigma = + match lcstr with + | [] -> cstr,[] + | arg::lcstr' -> + let arghd = + if isApp arg then let x,_ = destApplication 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]))) + lcstr' env sigma + else + try + let nme,typ,suite = destLambda cstr in + let c, l = applistc_iota suite lcstr' env sigma in + mkLambda (nme,typ,c), arg::l + with _ -> cstr,arg::lcstr' (* the arg does not correspond to a lambda*) + + + +(* TODO: ne plus mettre les sous-but à l'exterieur, mais à l'intérieur (le bug + de refine est normalement resolu). Ca permettra 2 choses: d'une part que + les preuves soient plus simple, et d'autre part de fabriquer un terme de + refine qui pourra s'aapliquer SANS FAIRE LES INTROS AVANT, ce qui est bcp + mieux car fonctionne comme induction et plus comme inversion (pas de perte + de connexion entre les hypothèse et les variables). *) + +(*s Tactic that makes induction and case analysis following the shape + of a function (idf) given with arguments (listargs) *) +let invfun c l dorew gl = +(* \begin{itemize} + \item [fonc] = the constant corresponding to the function + (necessary for equalities of the form [(f x1 x2 ...)=...] where + [f] is the recursive function). + \item [def_fonc] = body of the function, where let ins have + been expanded. *) + let fonc, def_fonc' = interp_fonc_tacarg c gl in + let def_fonc'',listargs' = + applistc_iota def_fonc' l (pf_env gl) (project gl) in + let def_fonc = expand_letins def_fonc'' in + (* quantifies on previously generalized arguments. + [(x1:T1)...g[arg1 <- x1 ...]] *) + 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 + + (* 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 + + (* 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 + + (* 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) + 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'' + else princ_applied_hyps'' in + + 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') + else princ_applied_hyps' (* No Fixpoint *) in + let _ = prNamedConstr "princ_applied_hyps" princ_applied_hyps in + + (* replace params metavar by real args *) + let rec replace_parms lparms largs t = + match lparms, largs with + [], _ -> 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 + + +(* + (* replace params metavar by abstracted variables *) + let princ_proof_params = npatternify (List.rev parms) princ_applied_hyps in + (* we apply now the real parameters *) + let princ_proof_applied = + applistc princ_proof_params (listpref (List.length parms) listargs') in +*) + + + + let princ_applied_evars = apply_levars princ_proof_applied levar in + let open_princ_proof_applied = princ_applied_evars in + let listargs_ids = List.map destVar (List.filter isVar listargs') in + invfun_basic (mkevarmap_aux open_princ_proof_applied) listargs_ids + gl dorew lposeq + +(* function must be a constant, all arguments must be given. *) +let invfun_verif c l dorew gl = + if not (isConst c) then error "given function is not a constant" + else + let x,_ = decompose_prod (pf_type_of gl c) in + if List.length x = List.length l then + try invfun c l dorew gl + with + UserError (x,y) -> raise (UserError (x,y)) + else error "wrong number of arguments for the function" + + +TACTIC EXTEND FunctionalInduction + [ "Functional" "Induction" constr(c) ne_constr_list(l) ] + -> [ invfun_verif c l true ] +END + + + +(* Construction of the functional scheme. *) +let buildFunscheme fonc mutflist = + let def_fonc = expand_letins (def_of_const fonc) in + let ftyp = type_of (Global.env ()) Evd.empty fonc in + let _ = resetmeta() in + let gl = mknewmeta() in + let gl_app = applFull gl ftyp in + 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 + (* 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_hyps = + patternify (List.rev levar) 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? *) + princ_replace_metas ev abs (i+1) + (mkLambda ( + (Name (id_of_string ("Q"^(string_of_int i)))), + prod_change_concl (lift 0 abs.(i)) mkthesort, + (substitterm 0 ev.(i) (mkRel 1) (lift 0 t)))) + in + let rec princ_replace_params params t = + List.fold_left ( + fun acc ev,nam,typ -> + 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? *) + then (* No Fixpoint *) + princ_replace_params parms (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 + + + +(* Declaration of the functional scheme. *) +let declareFunScheme f fname mutflist = + let scheme = + buildFunscheme (constr_of f) + (Array.of_list (List.map constr_of (f::mutflist))) 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 + () + + + +VERNAC COMMAND EXTEND FunctionalScheme + [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" + constr(c) "with" ne_constr_list(l) ] + -> [ declareFunScheme c na l ] +| [ "Functional" "Scheme" ident(na) ":=" "Induction" "for" constr(c) ] + -> [ declareFunScheme c na [] ] +END + + + + + +(* +*** Local Variables: *** +*** compile-command: "make -C ../.. contrib/funind/tacinv.cmo" *** +*** tab-width: 1 *** +*** tuareg-default-indent:1 *** +*** tuareg-begin-indent:1 *** +*** tuareg-let-indent:1 *** +*** tuareg-match-indent:-1 *** +*** tuareg-try-indent:1 *** +*** tuareg-with-indent:1 *** +*** tuareg-if-then-else-inden:1 *** +*** fill-column: 78 *** +*** indent-tabs-mode: nil *** +*** test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v" *** +*** End: *** +*) + + diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml new file mode 100644 index 00000000..758071ba --- /dev/null +++ b/contrib/funind/tacinvutils.ml @@ -0,0 +1,277 @@ +(* tacinvutils.ml *) +(*s utilities *) + +(*i*) +open Names +open Util +open Term +open Termops +open Coqlib +open Pp +open Printer +open Inductiveops +open Environ +open Declarations +open Nameops +open Evd +open Sign +open Reductionops +(*i*) + +(*s printing of constr -- debugging *) + +let msg x = () ;; let prterm c = str "" (* comment this to see debug msgs *) + (* uncomment this to see debugging *) +let prconstr c = msg (str" " ++ prterm c ++ str"\n") +let prlistconstr lc = List.iter prconstr lc +let prstr s = msg(str s) + +let prchr () = msg (str" (ret) \n") +let prNamedConstr s c = + begin + msg(str ""); + msg(str(s^"==>\n ") ++ prterm c ++ str "\n<==\n"); + msg(str ""); + end + +let prNamedLConstr_aux lc = + List.iter (prNamedConstr "#>") lc + +let prNamedLConstr s lc = + begin + prstr s; + prNamedLConstr_aux lc + end + + +(* FIXME: ref 1, pas bon, si? *) +let evarcpt = ref 0 +let metacpt = ref 0 +let mknewexist ()= + begin + evarcpt := !evarcpt+1; + !evarcpt,[||] + end + +let resetexist ()= evarcpt := 0 + +let mknewmeta ()= + begin + metacpt := !metacpt+1; + mkMeta (!metacpt) + end + +let resetmeta () = metacpt := 0 + +let rec mkevarmap_from_listex lex = + match lex with + | [] -> Evd.empty + | ((ex,_),typ)::lex' -> + let info ={ + evar_concl = typ; + evar_hyps = empty_named_context; + evar_body = Evar_empty} in + Evd.add (mkevarmap_from_listex lex') ex info + +let mkEq typ c1 c2 = + mkApp (build_coq_eq(),[| typ; c1; c2|]) + +let mkRefl typ c1 = + mkApp ((build_coq_eq_data()).refl, [| typ; c1|]) + +let rec popn i c = if i<=0 then c else pop (popn (i-1) c) + + +(* Operations on names *) +let id_of_name = function + Anonymous -> id_of_string "H" + | Name id -> id;; +let string_of_name nme = string_of_id (id_of_name nme) +let name_of_string str = Name (id_of_string str) +let newname_append nme str = + Name(id_of_string ((string_of_id (id_of_name nme))^str)) + +(* Substitutions in constr *) + +let compare_constr_nosub t1 t2 = + if compare_constr (fun _ _ -> false) t1 t2 + then true + else false + +let rec compare_constr' t1 t2 = + if compare_constr_nosub t1 t2 + then true + else (compare_constr (compare_constr') t1 t2) + +let rec substitterm prof t by_t in_u = + if (compare_constr' (lift prof t) in_u) + then (lift prof by_t) + else map_constr_with_binders succ + (fun i -> substitterm i t by_t) prof in_u + + +let apply_eqtrpl eq t = + let r,(tb,b,by_t) = eq in + substitterm 0 b by_t t + +let apply_eqtrpl_lt lt eq = List.map (apply_eqtrpl eq) lt + +let apply_leqtrpl_t t leq = + List.fold_left (fun x y -> apply_eqtrpl y x) t leq + + +let apply_refl_term eq t = + let _,arr = destApplication eq in + let reli= (Array.get arr 1) in + let by_t= (Array.get arr 2) in + substitterm 0 reli by_t t + +let apply_eq_leqtrpl leq eq = + List.map + (function (r,(tb,b,t)) -> + r,(tb, + (if isRel b then b else (apply_refl_term eq b)), apply_refl_term eq t)) + leq + + + +(* [(a b c) a] -> true *) +let constr_head_match u t= + if isApp u + then + let uhd,args= destApplication u in + uhd=t + else false + +(* My operations on constr *) +let lift1L l = (List.map (lift 1) l) +let mkArrow_lift t1 t2 = mkArrow t1 (lift 1 t2) +let mkProd_liftc nme c1 c2 = mkProd (nme,c1,(lift 1 c2)) +(* prod_it_lift x [a1 a2 ...] *) +let prod_it_lift ini lcpl = + List.fold_right (function a,b -> (fun c -> mkProd_liftc a b c)) ini lcpl;; + +let prod_it_anonym_lift trm lst = List.fold_right mkArrow_lift lst trm + +let lam_it_anonymous trm lst = + List.fold_right + (fun elt res -> mkLambda(Name(id_of_string "Hrec"),elt,res)) lst trm + +let lambda_id id typeofid cstr = + let cstr' = mkNamedLambda (id_of_string "FUNX") typeofid cstr in + substitterm 0 id (mkRel 0) cstr' + +let prod_id id typeofid cstr = + let cstr' = mkNamedProd (id_of_string "FUNX") typeofid cstr in + substitterm 0 id (mkRel 0) cstr' + + + + + +let nth_dep_constructor indtype n = + let sigma = Evd.empty and env = Global.env() in + let indtypedef = find_rectype env sigma indtype in + let indfam,_ = dest_ind_type indtypedef in + let arr_cstr_summary = get_constructors env indfam in + let cstr_sum = Array.get arr_cstr_summary n in + build_dependent_constructor cstr_sum, cstr_sum.cs_nargs + + +let rec buildrefl_from_eqs eqs = + match eqs with + | [] -> [] + | cstr::eqs' -> + let eq,args = destApplication cstr in + (mkRefl (Array.get args 0) (Array.get args 2)) + :: (buildrefl_from_eqs eqs') + + + + +(* list of occurrences of a term inside another, no imbricated + occurrence are considered (ie we stop looking inside a termthat is + an occurrence). *) +let rec hdMatchSub u t= + if constr_head_match u t then + u::(fold_constr (fun l cstr -> l@(hdMatchSub cstr t)) + [] + u) + else + fold_constr (fun l cstr -> l@(hdMatchSub cstr t)) + [] + u + +(* let hdMatchSub_list u lt = List.flatten (List.map (hdMatchSub u) lt) *) +let hdMatchSub_cpl u (d,f) = + let res = ref [] in + begin + for i = d to f do res := (hdMatchSub u (mkRel i)) @ !res done; + !res + end + + +(* destApplication raises an exception if [t] is not an application *) +let exchange_hd_prod subst_hd t = + let (hd,args)= destApplication t in mkApp (subst_hd,args) + +(* substitute t by by_t in head of products inside in_u, reduces each + product found *) +let rec substit_red prof t by_t in_u = + if constr_head_match in_u (lift prof t) + then + let _ = prNamedConstr "in_u" in_u in + let x = whd_beta (exchange_hd_prod (lift prof by_t) in_u) in + let _ = prNamedConstr "xx " x in + let _ = prstr "\n\n" in + x + else + map_constr_with_binders succ (fun i u -> substit_red i t by_t u) + prof 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 i = destRel hd in + whd_beta (mkApp (tarr.(f-i) ,args)) + +let exchange_reli_arrayi_L tarr (d,f) = + List.map (exchange_reli_arrayi tarr (d,f)) + + +(* expand all letins in a term, before building the principle. *) +let rec expand_letins mimick = + match kind_of_term mimick with + | LetIn(nme,cstr1, typ, cstr) -> + let cstr' = substitterm 0 (mkRel 1) (lift 1 cstr1) cstr in + expand_letins (pop cstr') + | x -> map_constr expand_letins mimick + + +(* Valeur d'une constante, or identity *) +let def_of_const t = + match kind_of_term t with + | Const sp -> + (try + match Global.lookup_constant sp with + {const_body=Some c} -> force c + |_ -> assert false + with _ -> assert false) + | _ -> 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) + |_ -> assert false + ;; + + +(*i +*** Local Variables: +*** compile-command: "make -k tacinvutils.cmo" +*** test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v" +*** End: +i*) + diff --git a/contrib/funind/tacinvutils.mli b/contrib/funind/tacinvutils.mli new file mode 100644 index 00000000..2fc37b2c --- /dev/null +++ b/contrib/funind/tacinvutils.mli @@ -0,0 +1,79 @@ +(* tacinvutils.ml *) +(*s utilities *) + +(*i*) +open Termops +open Equality +open Names +open Pp +open Tacmach +open Proof_type +open Tacinterp +open Tactics +open Tacticals +open Term +open Util +open Printer +open Reductionops +open Inductiveops +open Coqlib +open Refine +open Evd +(*i*) + +(* printing debugging *) +val prconstr: constr -> unit +val prlistconstr: constr list -> unit +val prNamedConstr:string -> constr -> unit +val prNamedLConstr:string -> constr list -> unit +val prstr: string -> unit + + +val mknewmeta: unit -> constr +val mknewexist: unit -> existential +val resetmeta: unit -> unit (* safe *) +val resetexist: unit -> unit (* be careful with this one *) +val mkevarmap_from_listex: (Term.existential * Term.types) list -> evar_map +val mkEq: types -> constr -> constr -> constr +(* let mkEq typ c1 c2 = mkApp (build_coq_eq_data.eq(),[| typ; c1; c2|]) *) +val mkRefl: types -> constr -> constr +val buildrefl_from_eqs: constr list -> constr list +(* typ c1 = mkApp ((constant ["Coq"; "Init"; "Logic"] "refl_equal"), [| typ; c1|]) *) + +val nth_dep_constructor: constr -> int -> (constr*int) + +val prod_it_lift: (name*constr) list -> constr -> constr +val prod_it_anonym_lift: constr -> constr list -> constr +val lam_it_anonymous: constr -> constr list -> constr +val lift1L: (constr list) -> constr list +val popn: int -> constr -> constr +val lambda_id: constr -> constr -> constr -> constr +val prod_id: constr -> constr -> constr -> constr + + +val name_of_string : string -> name +val newname_append: name -> string -> name + +val apply_eqtrpl: constr*(constr*constr*constr) -> constr -> constr +val substitterm: int -> constr -> constr -> constr -> constr +val apply_leqtrpl_t: + constr -> (constr*(constr*constr*constr)) list -> constr +val apply_eq_leqtrpl: + (constr*(constr*constr*constr)) list -> constr -> (constr*(constr*constr*constr)) list +(* val apply_leq_lt: constr list -> constr list -> constr list *) + +val hdMatchSub: constr -> constr -> constr list +val hdMatchSub_cpl: constr -> int*int -> constr list +val exchange_hd_prod: constr -> constr -> constr +val exchange_reli_arrayi_L: constr array -> int*int -> constr list -> constr list +val substit_red: int -> constr -> constr -> constr -> constr +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: +i*) + diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT new file mode 100644 index 00000000..2fb11c6b --- /dev/null +++ b/contrib/interface/COPYRIGHT @@ -0,0 +1,19 @@ +(*****************************************************************************) +(* *) +(* Coq support for the Pcoq Graphical Interface of Coq *) +(* *) +(* Copyright (C) 1999-2004 INRIA Sophia-Antipolis (Lemme team) *) +(* *) +(*****************************************************************************) + +The current directory contrib/interface implements Coq support for the +Pcoq Graphical Interface of Coq. It has been developed by Yves Bertot +with contributions from Loïc Pottier and Laurence Rideau. + +The Pcoq Graphical Interface (see http://www-sop.inria.fr/lemme/pcoq) +is developed by the Lemme team at INRIA Sophia-Antipolis (see +http://www-sop.inria.fr/lemme) + +The files of the current directory are distributed under the terms of +the GNU Lesser General Public License Version 2.1. + diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli new file mode 100644 index 00000000..61d0d5a3 --- /dev/null +++ b/contrib/interface/ascent.mli @@ -0,0 +1,784 @@ +type ct_AST = + CT_coerce_ID_OR_INT_to_AST of ct_ID_OR_INT + | CT_coerce_ID_OR_STRING_to_AST of ct_ID_OR_STRING + | CT_coerce_SINGLE_OPTION_VALUE_to_AST of ct_SINGLE_OPTION_VALUE + | CT_astnode of ct_ID * ct_AST_LIST + | CT_astpath of ct_ID_LIST + | CT_astslam of ct_ID_OPT * ct_AST +and ct_AST_LIST = + CT_ast_list of ct_AST list +and ct_BINARY = + CT_binary of int +and ct_BINDER = + CT_coerce_DEF_to_BINDER of ct_DEF + | CT_binder of ct_ID_OPT_NE_LIST * ct_FORMULA + | CT_binder_coercion of ct_ID_OPT_NE_LIST * ct_FORMULA +and ct_BINDER_LIST = + CT_binder_list of ct_BINDER list +and ct_BINDER_NE_LIST = + CT_binder_ne_list of ct_BINDER * ct_BINDER list +and ct_BINDING = + CT_binding of ct_ID_OR_INT * ct_FORMULA +and ct_BINDING_LIST = + CT_binding_list of ct_BINDING list +and ct_BOOL = + CT_false + | CT_true +and ct_CASE = + CT_case of string +and ct_CLAUSE = + CT_clause of ct_HYP_LOCATION_LIST_OR_STAR * ct_STAR_OPT +and ct_COERCION_OPT = + CT_coerce_NONE_to_COERCION_OPT of ct_NONE + | CT_coercion_atm +and ct_COFIXTAC = + CT_cofixtac of ct_ID * ct_FORMULA +and ct_COFIX_REC = + CT_cofix_rec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_FORMULA +and ct_COFIX_REC_LIST = + CT_cofix_rec_list of ct_COFIX_REC * ct_COFIX_REC list +and ct_COFIX_TAC_LIST = + CT_cofix_tac_list of ct_COFIXTAC list +and ct_COMMAND = + CT_coerce_COMMAND_LIST_to_COMMAND of ct_COMMAND_LIST + | CT_coerce_EVAL_CMD_to_COMMAND of ct_EVAL_CMD + | CT_coerce_SECTION_BEGIN_to_COMMAND of ct_SECTION_BEGIN + | CT_coerce_THEOREM_GOAL_to_COMMAND of ct_THEOREM_GOAL + | CT_abort of ct_ID_OPT_OR_ALL + | CT_abstraction of ct_ID * ct_FORMULA * ct_INT_LIST + | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_BINDING_LIST + | CT_add_natural_feature of ct_NATURAL_FEATURE * ct_ID + | CT_addpath of ct_STRING * ct_ID_OPT + | CT_arguments_scope of ct_ID * ct_ID_OPT_LIST + | CT_bind_scope of ct_ID * ct_ID_NE_LIST + | CT_cd of ct_STRING_OPT + | CT_check of ct_FORMULA + | CT_class of ct_ID + | CT_close_scope of ct_ID + | CT_coercion of ct_LOCAL_OPT * ct_IDENTITY_OPT * ct_ID * ct_ID * ct_ID + | CT_cofix_decl of ct_COFIX_REC_LIST + | CT_compile_module of ct_VERBOSE_OPT * ct_ID * ct_STRING_OPT + | CT_declare_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR + | CT_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT + | CT_definition of ct_DEFN * ct_ID * ct_BINDER_LIST * ct_DEF_BODY * ct_FORMULA_OPT + | CT_delim_scope of ct_ID * ct_ID + | CT_delpath of ct_STRING + | CT_derive_depinversion of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE + | CT_derive_inversion of ct_INV_TYPE * ct_INT_OPT * ct_ID * ct_ID + | CT_derive_inversion_with of ct_INV_TYPE * ct_ID * ct_FORMULA * ct_SORT_TYPE + | CT_explain_proof of ct_INT_LIST + | CT_explain_prooftree of ct_INT_LIST + | CT_export_id of ct_ID_NE_LIST + | CT_extract_to_file of ct_STRING * ct_ID_NE_LIST + | CT_extraction of ct_ID_OPT + | CT_fix_decl of ct_FIX_REC_LIST + | CT_focus of ct_INT_OPT + | CT_go of ct_INT_OR_LOCN + | CT_guarded + | CT_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_hintrewrite of ct_ORIENTATION * ct_FORMULA_NE_LIST * ct_ID * ct_TACTIC_COM + | CT_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST + | CT_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST + | CT_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST + | CT_hyp_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES + | CT_implicits of ct_ID * ct_ID_LIST_OPT + | CT_import_id of ct_ID_NE_LIST + | CT_ind_scheme of ct_SCHEME_SPEC_LIST + | CT_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT + | CT_inline of ct_ID_NE_LIST + | CT_inspect of ct_INT + | CT_kill_node of ct_INT + | CT_load of ct_VERBOSE_OPT * ct_ID_OR_STRING + | CT_local_close_scope of ct_ID + | CT_local_define_notation of ct_STRING * ct_FORMULA * ct_MODIFIER_LIST * ct_ID_OPT + | CT_local_hint_destruct of ct_ID * ct_INT * ct_DESTRUCT_LOCATION * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_local_hint_extern of ct_INT * ct_FORMULA * ct_TACTIC_COM * ct_ID_LIST + | CT_local_hints of ct_ID * ct_ID_NE_LIST * ct_ID_LIST + | CT_local_hints_immediate of ct_FORMULA_NE_LIST * ct_ID_LIST + | CT_local_hints_resolve of ct_FORMULA_NE_LIST * ct_ID_LIST + | CT_local_infix of ct_STRING * ct_ID * ct_MODIFIER_LIST * ct_ID_OPT + | CT_local_open_scope of ct_ID + | CT_local_reserve_notation of ct_STRING * ct_MODIFIER_LIST + | CT_locate of ct_ID + | CT_locate_file of ct_STRING + | CT_locate_lib of ct_ID + | CT_locate_notation of ct_STRING + | CT_mind_decl of ct_CO_IND * ct_IND_SPEC_LIST + | CT_ml_add_path of ct_STRING + | CT_ml_declare_modules of ct_STRING_NE_LIST + | CT_ml_print_modules + | CT_ml_print_path + | CT_module of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_CHECK * ct_MODULE_EXPR + | CT_module_type_decl of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_OPT + | CT_no_inline of ct_ID_NE_LIST + | CT_omega_flag of ct_OMEGA_MODE * ct_OMEGA_FEATURE + | CT_opaque of ct_ID_NE_LIST + | CT_open_scope of ct_ID + | CT_print + | CT_print_about of ct_ID + | CT_print_all + | CT_print_classes + | 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_id of ct_ID + | CT_print_implicit of ct_ID + | CT_print_loadpath + | CT_print_module of ct_ID + | CT_print_module_type of ct_ID + | CT_print_modules + | CT_print_natural of ct_ID + | CT_print_natural_feature of ct_NATURAL_FEATURE + | CT_print_opaqueid of ct_ID + | CT_print_path of ct_ID * ct_ID + | CT_print_proof of ct_ID + | CT_print_scope of ct_ID + | CT_print_scopes + | CT_print_section of ct_ID + | CT_print_states + | CT_print_tables + | CT_print_universes of ct_STRING_OPT + | CT_print_visibility of ct_ID_OPT + | CT_proof of ct_FORMULA + | CT_proof_no_op + | CT_proof_with of ct_TACTIC_COM + | CT_pwd + | CT_quit + | CT_read_module of ct_ID + | CT_rec_ml_add_path of ct_STRING + | CT_recaddpath of ct_STRING * ct_ID_OPT + | CT_record of ct_COERCION_OPT * ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_ID_OPT * ct_RECCONSTR_LIST + | CT_remove_natural_feature of ct_NATURAL_FEATURE * ct_ID + | CT_require of ct_IMPEXP * ct_SPEC_OPT * ct_ID_NE_LIST_OR_STRING + | CT_reserve of ct_ID_NE_LIST * ct_FORMULA + | CT_reserve_notation of ct_STRING * ct_MODIFIER_LIST + | CT_reset of ct_ID + | CT_reset_section of ct_ID + | CT_restart + | CT_restore_state of ct_ID + | CT_resume of ct_ID_OPT + | CT_save of ct_THM_OPT * ct_ID_OPT + | CT_scomments of ct_SCOMMENT_CONTENT_LIST + | CT_search of ct_ID * ct_IN_OR_OUT_MODULES + | CT_search_about of ct_ID_OR_STRING_NE_LIST * ct_IN_OR_OUT_MODULES + | CT_search_pattern of ct_FORMULA * ct_IN_OR_OUT_MODULES + | CT_search_rewrite of ct_FORMULA * ct_IN_OR_OUT_MODULES + | CT_section_end of ct_ID + | CT_section_struct of ct_SECTION_BEGIN * ct_SECTION_BODY * ct_COMMAND + | CT_set_natural of ct_ID + | CT_set_natural_default + | CT_set_option of ct_TABLE + | CT_set_option_value of ct_TABLE * ct_SINGLE_OPTION_VALUE + | CT_set_option_value2 of ct_TABLE * ct_ID_OR_STRING_NE_LIST + | CT_sethyp of ct_INT + | CT_setundo of ct_INT + | CT_show_existentials + | CT_show_goal of ct_INT_OPT + | CT_show_implicit of ct_INT + | CT_show_intro + | CT_show_intros + | CT_show_node + | CT_show_proof + | CT_show_proofs + | CT_show_script + | CT_show_tree + | CT_solve of ct_INT * ct_TACTIC_COM * ct_DOTDOT_OPT + | CT_suspend + | CT_syntax_macro of ct_ID * ct_FORMULA * ct_INT_OPT + | CT_tactic_definition of ct_TAC_DEF_NE_LIST + | CT_test_natural_feature of ct_NATURAL_FEATURE * ct_ID + | CT_theorem_struct of ct_THEOREM_GOAL * ct_PROOF_SCRIPT + | CT_time of ct_COMMAND + | CT_transparent of ct_ID_NE_LIST + | CT_undo of ct_INT_OPT + | CT_unfocus + | CT_unset_option of ct_TABLE + | CT_unsethyp + | CT_unsetundo + | CT_user_vernac of ct_ID * ct_VARG_LIST + | CT_variable of ct_VAR * ct_BINDER_NE_LIST + | CT_write_module of ct_ID * ct_STRING_OPT +and ct_COMMAND_LIST = + CT_command_list of ct_COMMAND * ct_COMMAND list +and ct_COMMENT = + CT_comment of string +and ct_COMMENT_S = + CT_comment_s of ct_COMMENT list +and ct_CONSTR = + CT_constr of ct_ID * ct_FORMULA + | CT_constr_coercion of ct_ID * ct_FORMULA +and ct_CONSTR_LIST = + CT_constr_list of ct_CONSTR list +and ct_CONTEXT_HYP_LIST = + CT_context_hyp_list of ct_PREMISE_PATTERN list +and ct_CONTEXT_PATTERN = + CT_coerce_FORMULA_to_CONTEXT_PATTERN of ct_FORMULA + | CT_context of ct_ID_OPT * ct_FORMULA +and ct_CONTEXT_RULE = + CT_context_rule of ct_CONTEXT_HYP_LIST * ct_CONTEXT_PATTERN * ct_TACTIC_COM + | CT_def_context_rule of ct_TACTIC_COM +and ct_CONVERSION_FLAG = + CT_beta + | CT_delta + | CT_evar + | CT_iota + | CT_zeta +and ct_CONVERSION_FLAG_LIST = + CT_conversion_flag_list of ct_CONVERSION_FLAG list +and ct_CONV_SET = + CT_unf of ct_ID list + | CT_unfbut of ct_ID list +and ct_CO_IND = + CT_co_ind of string +and ct_DECL_NOTATION_OPT = + CT_coerce_NONE_to_DECL_NOTATION_OPT of ct_NONE + | CT_decl_notation of ct_STRING * ct_FORMULA * ct_ID_OPT +and ct_DEF = + CT_def of ct_ID_OPT * ct_FORMULA +and ct_DEFN = + CT_defn of string +and ct_DEFN_OR_THM = + CT_coerce_DEFN_to_DEFN_OR_THM of ct_DEFN + | CT_coerce_THM_to_DEFN_OR_THM of ct_THM +and ct_DEF_BODY = + CT_coerce_CONTEXT_PATTERN_to_DEF_BODY of ct_CONTEXT_PATTERN + | CT_coerce_EVAL_CMD_to_DEF_BODY of ct_EVAL_CMD + | CT_type_of of ct_FORMULA +and ct_DEF_BODY_OPT = + CT_coerce_DEF_BODY_to_DEF_BODY_OPT of ct_DEF_BODY + | CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT of ct_FORMULA_OPT +and ct_DEP = + CT_dep of string +and ct_DESTRUCTING = + CT_coerce_NONE_to_DESTRUCTING of ct_NONE + | CT_destructing +and ct_DESTRUCT_LOCATION = + CT_conclusion_location + | CT_discardable_hypothesis + | CT_hypothesis_location +and ct_DOTDOT_OPT = + CT_coerce_NONE_to_DOTDOT_OPT of ct_NONE + | CT_dotdot +and ct_EQN = + CT_eqn of ct_MATCH_PATTERN_NE_LIST * ct_FORMULA +and ct_EQN_LIST = + CT_eqn_list of ct_EQN list +and ct_EVAL_CMD = + CT_eval of ct_INT_OPT * ct_RED_COM * ct_FORMULA +and ct_FIXTAC = + CT_fixtac of ct_ID * ct_INT * ct_FORMULA +and ct_FIX_BINDER = + CT_coerce_FIX_REC_to_FIX_BINDER of ct_FIX_REC + | CT_fix_binder of ct_ID * ct_INT * ct_FORMULA * ct_FORMULA +and ct_FIX_BINDER_LIST = + CT_fix_binder_list of ct_FIX_BINDER * ct_FIX_BINDER list +and ct_FIX_REC = + CT_fix_rec of ct_ID * ct_BINDER_NE_LIST * ct_ID_OPT * + ct_FORMULA * ct_FORMULA +and ct_FIX_REC_LIST = + CT_fix_rec_list of ct_FIX_REC * ct_FIX_REC list +and ct_FIX_TAC_LIST = + CT_fix_tac_list of ct_FIXTAC list +and ct_FORMULA = + CT_coerce_BINARY_to_FORMULA of ct_BINARY + | CT_coerce_ID_to_FORMULA of ct_ID + | CT_coerce_NUM_to_FORMULA of ct_NUM + | CT_coerce_SORT_TYPE_to_FORMULA of ct_SORT_TYPE + | CT_coerce_TYPED_FORMULA_to_FORMULA of ct_TYPED_FORMULA + | CT_appc of ct_FORMULA * ct_FORMULA_NE_LIST + | CT_arrowc of ct_FORMULA * ct_FORMULA + | CT_bang of ct_FORMULA + | CT_cases of ct_MATCHED_FORMULA_NE_LIST * ct_FORMULA_OPT * ct_EQN_LIST + | CT_cofixc of ct_ID * ct_COFIX_REC_LIST + | CT_elimc of ct_CASE * ct_FORMULA_OPT * ct_FORMULA * ct_FORMULA_LIST + | CT_existvarc + | CT_fixc of ct_ID * ct_FIX_BINDER_LIST + | CT_if of ct_FORMULA * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA + | CT_inductive_let of ct_FORMULA_OPT * ct_ID_OPT_NE_LIST * ct_FORMULA * ct_FORMULA + | CT_labelled_arg of ct_ID * ct_FORMULA + | CT_lambdac of ct_BINDER_NE_LIST * ct_FORMULA + | CT_let_tuple of ct_ID_OPT_NE_LIST * ct_RETURN_INFO * ct_FORMULA * ct_FORMULA + | CT_letin of ct_DEF * ct_FORMULA + | CT_notation of ct_STRING * ct_FORMULA_LIST + | CT_num_encapsulator of ct_NUM_TYPE * ct_FORMULA + | CT_prodc of ct_BINDER_NE_LIST * ct_FORMULA + | CT_proj of ct_FORMULA * ct_FORMULA_NE_LIST +and ct_FORMULA_LIST = + CT_formula_list of ct_FORMULA list +and ct_FORMULA_NE_LIST = + CT_formula_ne_list of ct_FORMULA * ct_FORMULA list +and ct_FORMULA_OPT = + CT_coerce_FORMULA_to_FORMULA_OPT of ct_FORMULA + | CT_coerce_ID_OPT_to_FORMULA_OPT of ct_ID_OPT +and ct_FORMULA_OR_INT = + CT_coerce_FORMULA_to_FORMULA_OR_INT of ct_FORMULA + | CT_coerce_ID_OR_INT_to_FORMULA_OR_INT of ct_ID_OR_INT +and ct_GRAMMAR = + CT_grammar_none +and ct_HYP_LOCATION = + CT_coerce_UNFOLD_to_HYP_LOCATION of ct_UNFOLD + | CT_intype of ct_ID * ct_INT_LIST + | CT_invalue of ct_ID * ct_INT_LIST +and ct_HYP_LOCATION_LIST_OR_STAR = + CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR of ct_STAR + | CT_hyp_location_list of ct_HYP_LOCATION list +and ct_ID = + CT_ident of string + | CT_metac of ct_INT + | CT_metaid of string +and ct_IDENTITY_OPT = + CT_coerce_NONE_to_IDENTITY_OPT of ct_NONE + | CT_identity +and ct_ID_LIST = + CT_id_list of ct_ID list +and ct_ID_LIST_LIST = + CT_id_list_list of ct_ID_LIST list +and ct_ID_LIST_OPT = + CT_coerce_ID_LIST_to_ID_LIST_OPT of ct_ID_LIST + | CT_coerce_NONE_to_ID_LIST_OPT of ct_NONE +and ct_ID_NE_LIST = + CT_id_ne_list of ct_ID * ct_ID list +and ct_ID_NE_LIST_OR_STAR = + CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR of ct_ID_NE_LIST + | CT_coerce_STAR_to_ID_NE_LIST_OR_STAR of ct_STAR +and ct_ID_NE_LIST_OR_STRING = + CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING of ct_ID_NE_LIST + | CT_coerce_STRING_to_ID_NE_LIST_OR_STRING of ct_STRING +and ct_ID_OPT = + CT_coerce_ID_to_ID_OPT of ct_ID + | CT_coerce_NONE_to_ID_OPT of ct_NONE +and ct_ID_OPT_LIST = + CT_id_opt_list of ct_ID_OPT list +and ct_ID_OPT_NE_LIST = + CT_id_opt_ne_list of ct_ID_OPT * ct_ID_OPT list +and ct_ID_OPT_OR_ALL = + CT_coerce_ID_OPT_to_ID_OPT_OR_ALL of ct_ID_OPT + | CT_all +and ct_ID_OR_INT = + CT_coerce_ID_to_ID_OR_INT of ct_ID + | CT_coerce_INT_to_ID_OR_INT of ct_INT +and ct_ID_OR_INT_OPT = + CT_coerce_ID_OPT_to_ID_OR_INT_OPT of ct_ID_OPT + | CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT of ct_ID_OR_INT + | CT_coerce_INT_OPT_to_ID_OR_INT_OPT of ct_INT_OPT +and ct_ID_OR_STAR = + CT_coerce_ID_to_ID_OR_STAR of ct_ID + | CT_coerce_STAR_to_ID_OR_STAR of ct_STAR +and ct_ID_OR_STRING = + CT_coerce_ID_to_ID_OR_STRING of ct_ID + | CT_coerce_STRING_to_ID_OR_STRING of ct_STRING +and ct_ID_OR_STRING_NE_LIST = + CT_id_or_string_ne_list of ct_ID_OR_STRING * ct_ID_OR_STRING list +and ct_IMPEXP = + CT_coerce_NONE_to_IMPEXP of ct_NONE + | CT_export + | CT_import +and ct_IND_SPEC = + CT_ind_spec of ct_ID * ct_BINDER_LIST * ct_FORMULA * ct_CONSTR_LIST * ct_DECL_NOTATION_OPT +and ct_IND_SPEC_LIST = + CT_ind_spec_list of ct_IND_SPEC list +and ct_INT = + CT_int of int +and ct_INTRO_PATT = + CT_coerce_ID_to_INTRO_PATT of ct_ID + | CT_disj_pattern of ct_INTRO_PATT_LIST * ct_INTRO_PATT_LIST list +and ct_INTRO_PATT_LIST = + CT_intro_patt_list of ct_INTRO_PATT list +and ct_INTRO_PATT_OPT = + CT_coerce_ID_OPT_to_INTRO_PATT_OPT of ct_ID_OPT + | CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT of ct_INTRO_PATT +and ct_INT_LIST = + CT_int_list of ct_INT list +and ct_INT_NE_LIST = + CT_int_ne_list of ct_INT * ct_INT list +and ct_INT_OPT = + CT_coerce_INT_to_INT_OPT of ct_INT + | CT_coerce_NONE_to_INT_OPT of ct_NONE +and ct_INT_OR_LOCN = + CT_coerce_INT_to_INT_OR_LOCN of ct_INT + | CT_coerce_LOCN_to_INT_OR_LOCN of ct_LOCN +and ct_INT_OR_NEXT = + CT_coerce_INT_to_INT_OR_NEXT of ct_INT + | CT_next_level +and ct_INV_TYPE = + CT_inv_clear + | CT_inv_regular + | CT_inv_simple +and ct_IN_OR_OUT_MODULES = + CT_coerce_NONE_to_IN_OR_OUT_MODULES of ct_NONE + | CT_in_modules of ct_ID_NE_LIST + | CT_out_modules of ct_ID_NE_LIST +and ct_LET_CLAUSE = + CT_let_clause of ct_ID * ct_TACTIC_OPT * ct_LET_VALUE +and ct_LET_CLAUSES = + CT_let_clauses of ct_LET_CLAUSE * ct_LET_CLAUSE list +and ct_LET_VALUE = + CT_coerce_DEF_BODY_to_LET_VALUE of ct_DEF_BODY + | CT_coerce_TACTIC_COM_to_LET_VALUE of ct_TACTIC_COM +and ct_LOCAL_OPT = + CT_coerce_NONE_to_LOCAL_OPT of ct_NONE + | CT_local +and ct_LOCN = + CT_locn of string +and ct_MATCHED_FORMULA = + CT_coerce_FORMULA_to_MATCHED_FORMULA of ct_FORMULA + | CT_formula_as of ct_FORMULA * ct_ID_OPT + | CT_formula_as_in of ct_FORMULA * ct_ID_OPT * ct_FORMULA + | CT_formula_in of ct_FORMULA * ct_FORMULA +and ct_MATCHED_FORMULA_NE_LIST = + CT_matched_formula_ne_list of ct_MATCHED_FORMULA * ct_MATCHED_FORMULA list +and ct_MATCH_PATTERN = + CT_coerce_ID_OPT_to_MATCH_PATTERN of ct_ID_OPT + | CT_coerce_NUM_to_MATCH_PATTERN of ct_NUM + | CT_pattern_app of ct_MATCH_PATTERN * ct_MATCH_PATTERN_NE_LIST + | CT_pattern_as of ct_MATCH_PATTERN * ct_ID_OPT + | CT_pattern_delimitors of ct_NUM_TYPE * ct_MATCH_PATTERN + | CT_pattern_notation of ct_STRING * ct_MATCH_PATTERN_LIST +and ct_MATCH_PATTERN_LIST = + CT_match_pattern_list of ct_MATCH_PATTERN list +and ct_MATCH_PATTERN_NE_LIST = + CT_match_pattern_ne_list of ct_MATCH_PATTERN * ct_MATCH_PATTERN list +and ct_MATCH_TAC_RULE = + CT_match_tac_rule of ct_CONTEXT_PATTERN * ct_LET_VALUE +and ct_MATCH_TAC_RULES = + CT_match_tac_rules of ct_MATCH_TAC_RULE * ct_MATCH_TAC_RULE list +and ct_MODIFIER = + CT_entry_type of ct_ID * ct_ID + | CT_format of ct_STRING + | CT_lefta + | CT_nona + | CT_only_parsing + | CT_righta + | CT_set_item_level of ct_ID_NE_LIST * ct_INT_OR_NEXT + | CT_set_level of ct_INT +and ct_MODIFIER_LIST = + CT_modifier_list of ct_MODIFIER list +and ct_MODULE_BINDER = + CT_module_binder of ct_ID_NE_LIST * ct_MODULE_TYPE +and ct_MODULE_BINDER_LIST = + CT_module_binder_list of ct_MODULE_BINDER list +and ct_MODULE_EXPR = + CT_coerce_ID_OPT_to_MODULE_EXPR of ct_ID_OPT + | CT_module_app of ct_MODULE_EXPR * ct_MODULE_EXPR +and ct_MODULE_TYPE = + CT_coerce_ID_to_MODULE_TYPE of ct_ID + | CT_module_type_with_def of ct_MODULE_TYPE * ct_ID * ct_FORMULA + | CT_module_type_with_mod of ct_MODULE_TYPE * ct_ID * ct_ID +and ct_MODULE_TYPE_CHECK = + CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK of ct_MODULE_TYPE_OPT + | CT_only_check of ct_MODULE_TYPE +and ct_MODULE_TYPE_OPT = + CT_coerce_ID_OPT_to_MODULE_TYPE_OPT of ct_ID_OPT + | CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT of ct_MODULE_TYPE +and ct_NATURAL_FEATURE = + CT_contractible + | CT_implicit + | CT_nat_transparent +and ct_NONE = + CT_none +and ct_NUM = + CT_int_encapsulator of string +and ct_NUM_TYPE = + CT_num_type of string +and ct_OMEGA_FEATURE = + CT_coerce_STRING_to_OMEGA_FEATURE of ct_STRING + | CT_flag_action + | CT_flag_system + | CT_flag_time +and ct_OMEGA_MODE = + CT_set + | CT_switch + | CT_unset +and ct_ORIENTATION = + CT_lr + | CT_rl +and ct_PATTERN = + CT_pattern_occ of ct_INT_LIST * ct_FORMULA +and ct_PATTERN_NE_LIST = + CT_pattern_ne_list of ct_PATTERN * ct_PATTERN list +and ct_PATTERN_OPT = + CT_coerce_NONE_to_PATTERN_OPT of ct_NONE + | CT_coerce_PATTERN_to_PATTERN_OPT of ct_PATTERN +and ct_PREMISE = + CT_coerce_TYPED_FORMULA_to_PREMISE of ct_TYPED_FORMULA + | CT_eval_result of ct_FORMULA * ct_FORMULA * ct_FORMULA + | CT_premise of ct_ID * ct_FORMULA +and ct_PREMISES_LIST = + CT_premises_list of ct_PREMISE list +and ct_PREMISE_PATTERN = + CT_premise_pattern of ct_ID_OPT * ct_CONTEXT_PATTERN +and ct_PROOF_SCRIPT = + CT_proof_script of ct_COMMAND list +and ct_RECCONSTR = + CT_defrecconstr of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT + | CT_defrecconstr_coercion of ct_ID_OPT * ct_FORMULA * ct_FORMULA_OPT + | CT_recconstr of ct_ID_OPT * ct_FORMULA + | CT_recconstr_coercion of ct_ID_OPT * ct_FORMULA +and ct_RECCONSTR_LIST = + CT_recconstr_list of ct_RECCONSTR list +and ct_REC_TACTIC_FUN = + CT_rec_tactic_fun of ct_ID * ct_ID_OPT_NE_LIST * ct_TACTIC_COM +and ct_REC_TACTIC_FUN_LIST = + CT_rec_tactic_fun_list of ct_REC_TACTIC_FUN * ct_REC_TACTIC_FUN list +and ct_RED_COM = + CT_cbv of ct_CONVERSION_FLAG_LIST * ct_CONV_SET + | CT_fold of ct_FORMULA_LIST + | CT_hnf + | CT_lazy of ct_CONVERSION_FLAG_LIST * ct_CONV_SET + | CT_pattern of ct_PATTERN_NE_LIST + | CT_red + | CT_simpl of ct_PATTERN_OPT + | CT_unfold of ct_UNFOLD_NE_LIST +and ct_RETURN_INFO = + CT_coerce_NONE_to_RETURN_INFO of ct_NONE + | CT_as_and_return of ct_ID_OPT * ct_FORMULA + | CT_return of ct_FORMULA +and ct_RULE = + CT_rule of ct_PREMISES_LIST * ct_FORMULA +and ct_RULE_LIST = + CT_rule_list of ct_RULE list +and ct_SCHEME_SPEC = + CT_scheme_spec of ct_ID * ct_DEP * ct_FORMULA * ct_SORT_TYPE +and ct_SCHEME_SPEC_LIST = + CT_scheme_spec_list of ct_SCHEME_SPEC * ct_SCHEME_SPEC list +and ct_SCOMMENT_CONTENT = + CT_coerce_FORMULA_to_SCOMMENT_CONTENT of ct_FORMULA + | CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT of ct_ID_OR_STRING +and ct_SCOMMENT_CONTENT_LIST = + CT_scomment_content_list of ct_SCOMMENT_CONTENT list +and ct_SECTION_BEGIN = + CT_section of ct_ID +and ct_SECTION_BODY = + CT_section_body of ct_COMMAND list +and ct_SIGNED_INT = + CT_coerce_INT_to_SIGNED_INT of ct_INT + | CT_minus of ct_INT +and ct_SIGNED_INT_LIST = + CT_signed_int_list of ct_SIGNED_INT list +and ct_SINGLE_OPTION_VALUE = + CT_coerce_INT_to_SINGLE_OPTION_VALUE of ct_INT + | CT_coerce_STRING_to_SINGLE_OPTION_VALUE of ct_STRING +and ct_SORT_TYPE = + CT_sortc of string +and ct_SPEC_LIST = + CT_coerce_BINDING_LIST_to_SPEC_LIST of ct_BINDING_LIST + | CT_coerce_FORMULA_LIST_to_SPEC_LIST of ct_FORMULA_LIST +and ct_SPEC_OPT = + CT_coerce_NONE_to_SPEC_OPT of ct_NONE + | CT_spec +and ct_STAR = + CT_star +and ct_STAR_OPT = + CT_coerce_NONE_to_STAR_OPT of ct_NONE + | CT_coerce_STAR_to_STAR_OPT of ct_STAR +and ct_STRING = + CT_string of string +and ct_STRING_NE_LIST = + CT_string_ne_list of ct_STRING * ct_STRING list +and ct_STRING_OPT = + CT_coerce_NONE_to_STRING_OPT of ct_NONE + | CT_coerce_STRING_to_STRING_OPT of ct_STRING +and ct_TABLE = + CT_coerce_ID_to_TABLE of ct_ID + | CT_table of ct_ID * ct_ID +and ct_TACTIC_ARG = + CT_coerce_EVAL_CMD_to_TACTIC_ARG of ct_EVAL_CMD + | CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG of ct_FORMULA_OR_INT + | CT_coerce_TACTIC_COM_to_TACTIC_ARG of ct_TACTIC_COM + | CT_coerce_TERM_CHANGE_to_TACTIC_ARG of ct_TERM_CHANGE + | CT_void +and ct_TACTIC_ARG_LIST = + CT_tactic_arg_list of ct_TACTIC_ARG * ct_TACTIC_ARG list +and ct_TACTIC_COM = + CT_abstract of ct_ID_OPT * ct_TACTIC_COM + | CT_absurd of ct_FORMULA + | CT_any_constructor of ct_TACTIC_OPT + | CT_apply of ct_FORMULA * ct_SPEC_LIST + | CT_assert of ct_ID_OPT * ct_FORMULA + | CT_assumption + | CT_auto of ct_INT_OPT + | CT_auto_with of ct_INT_OPT * ct_ID_NE_LIST_OR_STAR + | CT_autorewrite of ct_ID_NE_LIST * ct_TACTIC_OPT + | CT_autotdb of ct_INT_OPT + | CT_case_type of ct_FORMULA + | CT_casetac of ct_FORMULA * ct_SPEC_LIST + | CT_cdhyp of ct_ID + | CT_change of ct_FORMULA * ct_CLAUSE + | CT_change_local of ct_PATTERN * ct_FORMULA * ct_CLAUSE + | CT_clear of ct_ID_NE_LIST + | CT_clear_body of ct_ID_NE_LIST + | CT_cofixtactic of ct_ID_OPT * ct_COFIX_TAC_LIST + | CT_condrewrite_lr of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT + | CT_condrewrite_rl of ct_TACTIC_COM * ct_FORMULA * ct_SPEC_LIST * ct_ID_OPT + | CT_constructor of ct_INT * ct_SPEC_LIST + | CT_contradiction + | CT_contradiction_thm of ct_FORMULA * ct_SPEC_LIST + | CT_cut of ct_FORMULA + | CT_cutrewrite_lr of ct_FORMULA * ct_ID_OPT + | CT_cutrewrite_rl of ct_FORMULA * ct_ID_OPT + | CT_dauto of ct_INT_OPT * ct_INT_OPT + | CT_dconcl + | CT_decompose_list of ct_ID_NE_LIST * ct_FORMULA + | CT_decompose_record of ct_FORMULA + | CT_decompose_sum of ct_FORMULA + | CT_depinversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_FORMULA_OPT + | CT_deprewrite_lr of ct_ID + | CT_deprewrite_rl of ct_ID + | CT_destruct of ct_ID_OR_INT + | CT_dhyp of ct_ID + | CT_discriminate_eq of ct_ID_OR_INT_OPT + | CT_do of ct_ID_OR_INT * ct_TACTIC_COM + | CT_eapply of ct_FORMULA * ct_SPEC_LIST + | CT_eauto of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT + | CT_eauto_with of ct_ID_OR_INT_OPT * ct_ID_OR_INT_OPT * ct_ID_NE_LIST_OR_STAR + | CT_elim of ct_FORMULA * ct_SPEC_LIST * ct_USING + | CT_elim_type of ct_FORMULA + | CT_exact of ct_FORMULA + | CT_exists of ct_SPEC_LIST + | CT_fail of ct_ID_OR_INT * ct_STRING_OPT + | CT_first of ct_TACTIC_COM * ct_TACTIC_COM list + | CT_firstorder of ct_TACTIC_OPT + | CT_firstorder_using of ct_TACTIC_OPT * ct_ID_NE_LIST + | CT_firstorder_with of ct_TACTIC_OPT * ct_ID_NE_LIST + | CT_fixtactic of ct_ID_OPT * ct_INT * ct_FIX_TAC_LIST + | CT_formula_marker of ct_FORMULA + | CT_fresh of ct_STRING_OPT + | CT_generalize of ct_FORMULA_NE_LIST + | CT_generalize_dependent of ct_FORMULA + | CT_idtac of ct_STRING_OPT + | CT_induction of ct_ID_OR_INT + | CT_info of ct_TACTIC_COM + | CT_injection_eq of ct_ID_OR_INT_OPT + | CT_instantiate of ct_INT * ct_FORMULA * ct_CLAUSE + | CT_intro of ct_ID_OPT + | CT_intro_after of ct_ID_OPT * ct_ID + | CT_intros of ct_INTRO_PATT_LIST + | CT_intros_until of ct_ID_OR_INT + | CT_inversion of ct_INV_TYPE * ct_ID_OR_INT * ct_INTRO_PATT_OPT * ct_ID_LIST + | CT_left of ct_SPEC_LIST + | CT_let_ltac of ct_LET_CLAUSES * ct_LET_VALUE + | CT_lettac of ct_ID_OPT * ct_FORMULA * ct_CLAUSE + | CT_match_context of ct_CONTEXT_RULE * ct_CONTEXT_RULE list + | CT_match_context_reverse of ct_CONTEXT_RULE * ct_CONTEXT_RULE list + | CT_match_tac of ct_TACTIC_COM * ct_MATCH_TAC_RULES + | CT_move_after of ct_ID * ct_ID + | CT_new_destruct of ct_FORMULA_OR_INT * ct_USING * ct_INTRO_PATT_OPT + | CT_new_induction of ct_FORMULA_OR_INT * ct_USING * ct_INTRO_PATT_OPT + | CT_omega + | CT_orelse of ct_TACTIC_COM * ct_TACTIC_COM + | CT_parallel of ct_TACTIC_COM * ct_TACTIC_COM list + | CT_pose of ct_ID_OPT * ct_FORMULA + | CT_progress of ct_TACTIC_COM + | CT_prolog of ct_FORMULA_LIST * ct_INT + | CT_rec_tactic_in of ct_REC_TACTIC_FUN_LIST * ct_TACTIC_COM + | CT_reduce of ct_RED_COM * ct_CLAUSE + | CT_refine of ct_FORMULA + | CT_reflexivity + | CT_rename of ct_ID * ct_ID + | CT_repeat of ct_TACTIC_COM + | CT_replace_with of ct_FORMULA * ct_FORMULA + | CT_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 + | CT_ring of ct_FORMULA_LIST + | CT_simple_user_tac of ct_ID * ct_TACTIC_ARG_LIST + | CT_simplify_eq of ct_ID_OR_INT_OPT + | CT_specialize of ct_INT_OPT * ct_FORMULA * ct_SPEC_LIST + | CT_split of ct_SPEC_LIST + | CT_subst of ct_ID_LIST + | CT_superauto of ct_INT_OPT * ct_ID_LIST * ct_DESTRUCTING * ct_USINGTDB + | CT_symmetry of ct_CLAUSE + | CT_tac_double of ct_ID_OR_INT * ct_ID_OR_INT + | CT_tacsolve of ct_TACTIC_COM * ct_TACTIC_COM list + | CT_tactic_fun of ct_ID_OPT_NE_LIST * ct_TACTIC_COM + | CT_then of ct_TACTIC_COM * ct_TACTIC_COM list + | CT_transitivity of ct_FORMULA + | CT_trivial + | CT_trivial_with of ct_ID_NE_LIST_OR_STAR + | CT_truecut of ct_ID_OPT * ct_FORMULA + | CT_try of ct_TACTIC_COM + | CT_use of ct_FORMULA + | CT_use_inversion of ct_ID_OR_INT * ct_FORMULA * ct_ID_LIST + | CT_user_tac of ct_ID * ct_TARG_LIST +and ct_TACTIC_OPT = + CT_coerce_NONE_to_TACTIC_OPT of ct_NONE + | CT_coerce_TACTIC_COM_to_TACTIC_OPT of ct_TACTIC_COM +and ct_TAC_DEF = + CT_tac_def of ct_ID * ct_TACTIC_COM +and ct_TAC_DEF_NE_LIST = + CT_tac_def_ne_list of ct_TAC_DEF * ct_TAC_DEF list +and ct_TARG = + CT_coerce_BINDING_to_TARG of ct_BINDING + | CT_coerce_COFIXTAC_to_TARG of ct_COFIXTAC + | CT_coerce_FIXTAC_to_TARG of ct_FIXTAC + | CT_coerce_FORMULA_OR_INT_to_TARG of ct_FORMULA_OR_INT + | CT_coerce_PATTERN_to_TARG of ct_PATTERN + | CT_coerce_SCOMMENT_CONTENT_to_TARG of ct_SCOMMENT_CONTENT + | CT_coerce_SIGNED_INT_LIST_to_TARG of ct_SIGNED_INT_LIST + | CT_coerce_SINGLE_OPTION_VALUE_to_TARG of ct_SINGLE_OPTION_VALUE + | CT_coerce_SPEC_LIST_to_TARG of ct_SPEC_LIST + | CT_coerce_TACTIC_COM_to_TARG of ct_TACTIC_COM + | CT_coerce_TARG_LIST_to_TARG of ct_TARG_LIST + | CT_coerce_UNFOLD_to_TARG of ct_UNFOLD + | CT_coerce_UNFOLD_NE_LIST_to_TARG of ct_UNFOLD_NE_LIST +and ct_TARG_LIST = + CT_targ_list of ct_TARG list +and ct_TERM_CHANGE = + CT_check_term of ct_FORMULA + | CT_inst_term of ct_ID * ct_FORMULA +and ct_TEXT = + CT_coerce_ID_to_TEXT of ct_ID + | CT_text_formula of ct_FORMULA + | CT_text_h of ct_TEXT list + | CT_text_hv of ct_TEXT list + | CT_text_op of ct_TEXT list + | CT_text_path of ct_SIGNED_INT_LIST + | CT_text_v of ct_TEXT list +and ct_THEOREM_GOAL = + CT_goal of ct_FORMULA + | CT_theorem_goal of ct_DEFN_OR_THM * ct_ID * ct_BINDER_LIST * ct_FORMULA +and ct_THM = + CT_thm of string +and ct_THM_OPT = + CT_coerce_NONE_to_THM_OPT of ct_NONE + | CT_coerce_THM_to_THM_OPT of ct_THM +and ct_TYPED_FORMULA = + CT_typed_formula of ct_FORMULA * ct_FORMULA +and ct_UNFOLD = + CT_coerce_ID_to_UNFOLD of ct_ID + | CT_unfold_occ of ct_ID * ct_INT_NE_LIST +and ct_UNFOLD_NE_LIST = + CT_unfold_ne_list of ct_UNFOLD * ct_UNFOLD list +and ct_USING = + CT_coerce_NONE_to_USING of ct_NONE + | CT_using of ct_FORMULA * ct_SPEC_LIST +and ct_USINGTDB = + CT_coerce_NONE_to_USINGTDB of ct_NONE + | CT_usingtdb +and ct_VAR = + CT_var of string +and ct_VARG = + CT_coerce_AST_to_VARG of ct_AST + | CT_coerce_AST_LIST_to_VARG of ct_AST_LIST + | CT_coerce_BINDER_to_VARG of ct_BINDER + | CT_coerce_BINDER_LIST_to_VARG of ct_BINDER_LIST + | CT_coerce_BINDER_NE_LIST_to_VARG of ct_BINDER_NE_LIST + | CT_coerce_FORMULA_LIST_to_VARG of ct_FORMULA_LIST + | CT_coerce_FORMULA_OPT_to_VARG of ct_FORMULA_OPT + | CT_coerce_FORMULA_OR_INT_to_VARG of ct_FORMULA_OR_INT + | CT_coerce_ID_OPT_OR_ALL_to_VARG of ct_ID_OPT_OR_ALL + | CT_coerce_ID_OR_INT_OPT_to_VARG of ct_ID_OR_INT_OPT + | CT_coerce_INT_LIST_to_VARG of ct_INT_LIST + | CT_coerce_SCOMMENT_CONTENT_to_VARG of ct_SCOMMENT_CONTENT + | CT_coerce_STRING_OPT_to_VARG of ct_STRING_OPT + | CT_coerce_TACTIC_OPT_to_VARG of ct_TACTIC_OPT + | CT_coerce_VARG_LIST_to_VARG of ct_VARG_LIST +and ct_VARG_LIST = + CT_varg_list of ct_VARG list +and ct_VERBOSE_OPT = + CT_coerce_NONE_to_VERBOSE_OPT of ct_NONE + | CT_verbose +;; diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml new file mode 100755 index 00000000..d5236a7a --- /dev/null +++ b/contrib/interface/blast.ml @@ -0,0 +1,628 @@ +(* 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;; +open Environ;; +open Equality;; +open Evd;; +open Hipattern;; +open Inductive;; +open Names;; +open Pattern;; +open Pbp;; +open Pfedit;; +open Pp;; +open Printer +open Proof_trees;; +open Proof_type;; +open Rawterm;; +open Reduction;; +open Refiner;; +open Sign;; +open String;; +open Tacmach;; +open Tacred;; +open Tacticals;; +open Tactics;; +open Term;; +open Typing;; +open Util;; +open Vernacentries;; +open Vernacinterp;; +open Evar_refiner;; + + +let parse_com = Pcoq.parse_string Pcoq.Constr.constr;; +let parse_tac t = + try (Pcoq.parse_string Pcoq.Tactic.tactic t) + with _ -> (msgnl (hov 0 (str"pas parsé: " ++ str t)); + failwith "tactic") +;; + +let is_free () = + let st =open_in_bin ((Sys.getenv "HOME")^"/.free") in + let c=input_char st in + close_in st; + c = 'A' +;; + +(* marche pas *) +(* +let is_free () = + msgnl (hov 0 [< 'str"Isfree========= "; 'fNL >]); + let s = Stream.of_channel stdin in + msgnl (hov 0 [< 'str"Isfree s "; 'fNL >]); + try (Stream.empty s; + msgnl (hov 0 [< 'str"Isfree empty "; 'fNL >]); + true) + with _ -> (msgnl (hov 0 [< 'str"Isfree not empty "; 'fNL >]); + false) +;; +*) +let free_try tac g = + if is_free() + then (tac g) + else (failwith "not free") +;; +let adrel (x,t) e = + match x with + Name(xid) -> Environ.push_rel (x,None,t) e + | Anonymous -> Environ.push_rel (x,None,t) e +(* les constantes ayant une définition apparaissant dans x *) +let rec def_const_in_term_rec vl x = + match (kind_of_term x) with + Prod(n,t,c)-> + let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c + | Lambda(n,t,c) -> + let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c + | App(f,args) -> def_const_in_term_rec vl f + | Sort(Prop(Null)) -> Prop(Null) + | Sort(c) -> c + | Ind(ind) -> + let (mib, mip) = Global.lookup_inductive ind in + mip.mind_sort + | Construct(c) -> + def_const_in_term_rec vl (mkInd (inductive_of_constructor c)) + | Case(_,x,t,a) + -> def_const_in_term_rec vl x + | Cast(x,t)-> def_const_in_term_rec vl t + | Const(c) -> def_const_in_term_rec vl (lookup_constant c vl).const_type + | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x) +;; +let def_const_in_term_ x = + def_const_in_term_rec (Global.env()) (strip_outer_cast x) +;; +(************************************************************************* + recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli + modif de print_info_script avec pr_bar +*) + +let pr_bar () = str "|" + +let rec print_info_script sigma osign pf = + let {evar_hyps=sign; evar_concl=cl} = pf.goal in + match pf.ref with + | None -> (mt ()) + | Some(r,spfl) -> + pr_rule r ++ + match spfl with + | [] -> + (str " " ++ fnl()) + | [pf1] -> + if pf1.ref = None then + (str " " ++ fnl()) + else + (str";" ++ brk(1,3) ++ + print_info_script sigma sign pf1) + | _ -> ( str";[" ++ fnl() ++ + prlist_with_sep pr_bar + (print_info_script sigma sign) spfl ++ + str"]") + +let format_print_info_script sigma osign pf = + hov 0 (print_info_script sigma osign pf) + +let print_subscript sigma sign pf = + (* if is_tactic_proof pf then + format_print_info_script sigma sign (subproof_of_proof pf) + else *) + format_print_info_script sigma sign pf +(****************) + +let pp_string x = + msgnl_with Format.str_formatter x; + Format.flush_str_formatter () +;; + +(*********************************************************************** + copié de tactics/eauto.ml +*) + +(***************************************************************************) +(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *) +(***************************************************************************) + +let unify_e_resolve (c,clenv) gls = + let (wc,kONT) = startWalk gls in + let clenv' = connect_clenv wc clenv in + let _ = clenv_unique_resolver false clenv' gls in + vernac_e_resolve_constr c gls + +let rec e_trivial_fail_db db_list local_db goal = + let tacl = + registered_e_assumption :: + (tclTHEN Tactics.intro + (function g'-> + let d = pf_last_hyp g' in + let hintl = make_resolve_hyp (pf_env g') (project g') d in + (e_trivial_fail_db db_list + (Hint_db.add_list hintl local_db) g'))) :: + (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) + in + tclFIRST (List.map tclCOMPLETE tacl) goal + +and e_my_find_search db_list local_db hdc concl = + let hdc = head_of_constr_reference hdc in + let hintl = + if occur_existential concl then + list_map_append (Hint_db.map_all hdc) (local_db::db_list) + else + 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) -> + (b, + let tac = + match t with + | Res_pf (term,cl) -> unify_resolve (term,cl) + | ERes_pf (term,cl) -> unify_e_resolve (term,cl) + | Give_exact (c) -> e_give_exact_constr c + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN (unify_e_resolve (term,cl)) + (e_trivial_fail_db db_list local_db) + | Unfold_nth c -> unfold_constr c + | Extern tacast -> Auto.conclPattern concl + (out_some p) tacast + in + (free_try tac,fmt_autotactic t)) + (*i + fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); + try tac gls + with e when Logic.catchable_exception(e) -> + (Format.print_string "Fail\n"; + Format.print_flush (); + raise e) + i*) + in + List.map tac_of_hint hintl + +and e_trivial_resolve db_list local_db gl = + try + Auto.priority + (e_my_find_search db_list local_db + (List.hd (head_constr_bound gl [])) gl) + with Bound | Not_found -> [] + +let e_possible_resolve db_list local_db gl = + try List.map snd (e_my_find_search db_list local_db + (List.hd (head_constr_bound gl [])) gl) + with Bound | Not_found -> [] + +let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id)) + +let find_first_goal gls = + try first_goal gls with UserError _ -> assert false + +(*s The following module [SearchProblem] is used to instantiate the generic + exploration functor [Explore.Make]. *) + +module MySearchProblem = struct + + type state = { + depth : int; (*r depth of search before failing *) + tacres : goal list sigma * validation; + last_tactic : std_ppcmds; + dblist : Auto.Hint_db.t list; + localdb : Auto.Hint_db.t list } + + let success s = (sig_it (fst s.tacres)) = [] + + let rec filter_tactics (glls,v) = function + | [] -> [] + | (tac,pptac) :: tacl -> + try + let (lgls,ptl) = apply_tac_list tac glls in + let v' p = v (ptl p) in + ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl + with e when Logic.catchable_exception e -> + filter_tactics (glls,v) tacl + + let rec list_addn n x l = + if n = 0 then l else x :: (list_addn (pred n) x l) + + (* Ordering of states is lexicographic on depth (greatest first) then + number of remaining goals. *) + let compare s s' = + let d = s'.depth - s.depth in + let nbgoals s = List.length (sig_it (fst s.tacres)) in + if d <> 0 then d else nbgoals s - nbgoals s' + + let branching s = + if s.depth = 0 then + [] + else + let lg = fst s.tacres in + let nbgl = List.length (sig_it lg) in + assert (nbgl > 0); + let g = find_first_goal lg in + let assumption_tacs = + let l = + filter_tactics s.tacres + (List.map + (fun id -> (e_give_exact_constr (mkVar id), + (str "Exact" ++ spc()++ pr_id id))) + (pf_ids_of_hyps g)) + in + List.map (fun (res,pp) -> { depth = s.depth; tacres = res; + last_tactic = pp; dblist = s.dblist; + localdb = List.tl s.localdb }) l + in + let intro_tac = + List.map + (fun ((lgls,_) as res,pp) -> + let g' = first_goal lgls in + let hintl = + make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') + in + let ldb = Hint_db.add_list hintl (List.hd s.localdb) in + { depth = s.depth; tacres = res; + last_tactic = pp; dblist = s.dblist; + localdb = ldb :: List.tl s.localdb }) + (filter_tactics s.tacres [Tactics.intro,(str "Intro" )]) + in + let rec_tacs = + let l = + filter_tactics s.tacres + (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) + in + List.map + (fun ((lgls,_) as res, pp) -> + let nbgl' = List.length (sig_it lgls) in + if nbgl' < nbgl then + { depth = s.depth; tacres = res; last_tactic = pp; + dblist = s.dblist; localdb = List.tl s.localdb } + else + { depth = pred s.depth; tacres = res; + dblist = s.dblist; last_tactic = pp; + localdb = + list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) + l + in + List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) + + let pp s = + msg (hov 0 (str " depth="++ int s.depth ++ spc() ++ + s.last_tactic ++ str "\n")) + +end + +module MySearch = Explore.Make(MySearchProblem) + +let make_initial_state n gl dblist localdb = + { MySearchProblem.depth = n; + MySearchProblem.tacres = tclIDTAC gl; + MySearchProblem.last_tactic = (mt ()); + MySearchProblem.dblist = dblist; + MySearchProblem.localdb = [localdb] } + +let e_depth_search debug p db_list local_db gl = + try + let tac = if debug then MySearch.debug_depth_first else MySearch.depth_first in + let s = tac (make_initial_state p gl db_list local_db) in + s.MySearchProblem.tacres + with Not_found -> error "EAuto: depth first search failed" + +let e_breadth_search debug n db_list local_db gl = + try + let tac = + if debug then MySearch.debug_breadth_first else MySearch.breadth_first + in + let s = tac (make_initial_state n gl db_list local_db) in + s.MySearchProblem.tacres + with Not_found -> error "EAuto: breadth first search failed" + +let e_search_auto debug (n,p) db_list gl = + let local_db = make_local_hint_db gl in + if n = 0 then + e_depth_search debug p db_list local_db gl + else + e_breadth_search debug n db_list local_db gl + +let eauto debug np dbnames = + let db_list = + List.map + (fun x -> + try Stringmap.find x !searchtable + 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 = 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 + tclTRY (e_search_auto debug n db_list) gl + +let my_full_eauto n gl = full_eauto false (n,0) gl + +(********************************************************************** + copié de tactics/auto.ml on a juste modifié search_gen +*) +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 + de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) + +let rec trivial_fail_db db_list local_db gl = + let intro_tac = + tclTHEN intro + (fun g'-> + let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') + in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g') + in + tclFIRST + (assumption::intro_tac:: + (List.map tclCOMPLETE + (trivial_resolve db_list local_db (pf_concl gl)))) gl + +and my_find_search db_list local_db hdc concl = + let tacl = + if occur_existential concl then + list_map_append (fun db -> Hint_db.map_all hdc db) (local_db::db_list) + else + list_map_append (fun db -> Hint_db.map_auto (hdc,concl) db) + (local_db::db_list) + in + List.map + (fun ({pri=b; pat=p; code=t} as patac) -> + (b, + match t with + | Res_pf (term,cl) -> unify_resolve (term,cl) + | ERes_pf (_,c) -> (fun gl -> error "eres_pf") + | Give_exact c -> exact_check c + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN + (unify_resolve (term,cl)) + (trivial_fail_db db_list local_db) + | Unfold_nth c -> unfold_constr c + | Extern tacast -> + conclPattern concl (out_some p) tacast)) + tacl + +and trivial_resolve db_list local_db cl = + try + let hdconstr = List.hd (head_constr_bound cl []) in + priority + (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) + with Bound | Not_found -> + [] + +(**************************************************************************) +(* The classical Auto tactic *) +(**************************************************************************) + +let possible_resolve db_list local_db cl = + try + let hdconstr = List.hd (head_constr_bound cl []) in + List.map snd + (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) + with Bound | Not_found -> + [] + +let decomp_unary_term c gls = + let typc = pf_type_of gls c in + let hd = List.hd (head_constr typc) in + if Hipattern.is_conjunction hd then + simplest_case c gls + else + errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") + +let decomp_empty_term c gls = + let typc = pf_type_of gls c in + let (hd,_) = decompose_app typc in + if Hipattern.is_empty_type hd then + simplest_case c gls + else + errorlabstrm "Auto.decomp_empty_term" (str "not an empty type") + + +(* decomp is an natural number giving an indication on decomposition + of conjunction in hypotheses, 0 corresponds to no decomposition *) +(* n is the max depth of search *) +(* local_db contains the local Hypotheses *) + +let rec search_gen decomp n db_list local_db extra_sign goal = + if n=0 then error "BOUND 2"; + let decomp_tacs = match decomp with + | 0 -> [] + | p -> + (tclTRY_sign decomp_empty_term extra_sign) + :: + (List.map + (fun id -> tclTHEN (decomp_unary_term (mkVar id)) + (tclTHEN + (clear [id]) + (free_try (search_gen decomp p db_list local_db [])))) + (pf_ids_of_hyps goal)) + in + let intro_tac = + tclTHEN intro + (fun g' -> + let (hid,_,htyp as d) = pf_last_hyp g' in + let hintl = + try + [make_apply_entry (pf_env g') (project g') + (true,false) + hid (mkVar hid,body_of_type htyp)] + with Failure _ -> [] + in + (free_try + (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d]) + g')) + in + let rec_tacs = + List.map + (fun ntac -> + tclTHEN ntac + (free_try + (search_gen decomp (n-1) db_list local_db empty_named_context))) + (possible_resolve db_list local_db (pf_concl goal)) + in + tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal + + +let search = search_gen 0 + +let default_search_depth = ref 5 + +let full_auto n gl = + let dbnames = stringmap_dom !searchtable in + let dbnames = list_subtract dbnames ["v62"] in + let db_list = List.map (fun x -> searchtable_map x) dbnames in + let hyps = pf_hyps gl in + tclTRY (search n db_list (make_local_hint_db gl) hyps) gl + +let default_full_auto gl = full_auto !default_search_depth gl +(************************************************************************) + +let blast_tactic = ref (free_try default_full_auto) +;; + +let blast_auto = (free_try default_full_auto) +(* (tclTHEN (free_try default_full_auto) + (free_try (my_full_eauto 2))) +*) +;; +let blast_simpl = (free_try (reduce (Simpl None) onConcl)) +;; +let blast_induction1 = + (free_try (tclTHEN (tclTRY intro) + (tclTRY (tclLAST_HYP simplest_elim)))) +;; +let blast_induction2 = + (free_try (tclTHEN (tclTRY (tclTHEN intro intro)) + (tclTRY (tclLAST_HYP simplest_elim)))) +;; +let blast_induction3 = + (free_try (tclTHEN (tclTRY (tclTHEN intro (tclTHEN intro intro))) + (tclTRY (tclLAST_HYP simplest_elim)))) +;; + +blast_tactic := + (tclORELSE (tclCOMPLETE blast_auto) + (tclORELSE (tclCOMPLETE (tclTHEN blast_simpl blast_auto)) + (tclORELSE (tclCOMPLETE (tclTHEN blast_induction1 + (tclTHEN blast_simpl blast_auto))) + (tclORELSE (tclCOMPLETE (tclTHEN blast_induction2 + (tclTHEN blast_simpl blast_auto))) + (tclCOMPLETE (tclTHEN blast_induction3 + (tclTHEN blast_simpl blast_auto))))))) +;; +(* +blast_tactic := (tclTHEN (free_try default_full_auto) + (free_try (my_full_eauto 4))) +;; +*) + +let vire_extvar s = + let interro = ref false in + let interro_pos = ref 0 in + for i=0 to (length s)-1 do + if get s i = '?' + then (interro := true; + interro_pos := i) + else if (!interro && + (List.mem (get s i) + ['0';'1';'2';'3';'4';'5';'6';'7';'8';'9'])) + then set s i ' ' + else interro:=false + done; + s +;; + +let blast gls = + let leaf g = { + open_subgoals = 1; + goal = g; + ref = None } in + try (let (sgl,v) as res = !blast_tactic gls in + let {it=lg} = sgl in + if lg = [] + then (let pf = v (List.map leaf (sig_it sgl)) in + let sign = (sig_it gls).evar_hyps in + let x = print_subscript + (sig_sig gls) sign pf in + msgnl (hov 0 (str"Blast ==> " ++ x)); + let x = print_subscript + (sig_sig gls) sign pf in + let tac_string = + pp_string (hov 0 x ) in + (* on remplace les ?1 ?2 ... de refine par ? *) + parse_tac ((vire_extvar tac_string) + ^ ".") + ) + else (msgnl (hov 0 (str"Blast failed to prove the goal...")); + failwith "echec de blast")) + with _ -> failwith "echec de blast" +;; + +let blast_tac display_function = function + | (n::_) as l -> + (function g -> + let exp_ast = (blast g) in + (display_function exp_ast; + tclIDTAC g)) + | _ -> failwith "expecting other arguments";; + +let blast_tac_txt = + blast_tac + (function x -> msgnl(Pptactic.pr_glob_tactic (Tacinterp.glob_tactic x)));; + +(* Obsolète ? +overwriting_add_tactic "Blast1" blast_tac_txt;; +*) + +(* +Grammar tactic ne_numarg_list : list := + ne_numarg_single [numarg($n)] ->[$n] +| ne_numarg_cons [numarg($n) ne_numarg_list($ns)] -> [ $n ($LIST $ns) ]. +Grammar tactic simple_tactic : ast := + blast1 [ "Blast1" ne_numarg_list($ns) ] -> + [ (Blast1 ($LIST $ns)) ]. + + + +PATH=/usr/local/bin:/usr/bin:$PATH +COQTOP=d:/Tools/coq-7.0-3mai +CAMLLIB=/usr/local/lib/ocaml +CAMLP4LIB=/usr/local/lib/camlp4 +export CAMLLIB +export COQTOP +export CAMLP4LIB +d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe +Drop. +#use "/cygdrive/D/Tools/coq-7.0-3mai/dev/base_include";; +*) diff --git a/contrib/interface/blast.mli b/contrib/interface/blast.mli new file mode 100644 index 00000000..21c29bc9 --- /dev/null +++ b/contrib/interface/blast.mli @@ -0,0 +1,5 @@ +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;; + diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 new file mode 100644 index 00000000..7bf12f3b --- /dev/null +++ b/contrib/interface/centaur.ml4 @@ -0,0 +1,700 @@ +(*i camlp4deps: "parsing/grammar.cma" i*) + +(*Toplevel loop for the communication between Coq and Centaur *) +open Names;; +open Nameops;; +open Util;; +open Ast;; +open Term;; +open Pp;; +open Libnames;; +open Libobject;; +open Library;; +open Vernacinterp;; +open Evd;; +open Proof_trees;; +open Termast;; +open Tacmach;; +open Pfedit;; +open Proof_type;; +open Parsing;; +open Environ;; +open Declare;; +open Declarations;; +open Rawterm;; +open Reduction;; +open Classops;; +open Vernacinterp;; +open Vernac;; +open Command;; +open Protectedtoplevel;; +open Coqast;; +open Line_oriented_parser;; +open Xlate;; +open Vtp;; +open Ascent;; +open Translate;; +open Name_to_ast;; +open Pbp;; +open Blast;; +(* open Dad;; *) +open Debug_tac;; +open Search;; +open Constrintern;; +open Nametab;; +open Showproof;; +open Showproof_ct;; +open Tacexpr;; +open Vernacexpr;; + +let pcoq_started = ref None;; + +let if_pcoq f a = + if !pcoq_started <> None then f a else error "Pcoq is not started";; + +let text_proof_flag = ref "en";; + +let current_proof_name () = + try + string_of_id (get_current_proof_name ()) + with + UserError("Pfedit.get_proof", _) -> "";; + +let current_goal_index = ref 0;; + +let guarded_force_eval_stream (s : std_ppcmds) = + let l = ref [] in + let f elt = l:= elt :: !l in + (try Stream.iter f s with + | _ -> f (Stream.next (str "error guarded_force_eval_stream"))); + Stream.of_list (List.rev !l);; + + +let rec string_of_path p = + match p with [] -> "\n" + | i::p -> (string_of_int i)^" "^ (string_of_path p) +;; +let print_path p = + output_results_nl (str "Path:" ++ str (string_of_path p)) +;; + +let kill_proof_node index = + let paths = History.historical_undo (current_proof_name()) index in + let _ = List.iter + (fun path -> (traverse_to path; + Pfedit.mutate weak_undo_pftreestate; + traverse_to [])) + paths in + History.border_length (current_proof_name());; + + +(*Message functions, the text of these messages is recognized by the protocols *) +(*of CtCoq *) +let ctf_header message_name request_id = + fnl () ++ str "message" ++ fnl() ++ str message_name ++ fnl() ++ + int request_id ++ fnl();; + +let ctf_acknowledge_command request_id command_count opt_exn = + let goal_count, goal_index = + if refining() then + let g_count = + List.length + (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in + g_count, (min g_count !current_goal_index) + else + (0, 0) in + (ctf_header "acknowledge" request_id ++ + int command_count ++ fnl() ++ + int goal_count ++ fnl () ++ + int goal_index ++ fnl () ++ + str (current_proof_name()) ++ fnl() ++ + (match opt_exn with + Some e -> Cerrors.explain_exn e + | None -> mt ()) ++ fnl() ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());; + +let ctf_undoResults = ctf_header "undo_results";; + +let ctf_TextMessage = ctf_header "text_proof";; + +let ctf_SearchResults = ctf_header "search_results";; + +let ctf_OtherGoal = ctf_header "other_goal";; + +let ctf_Location = ctf_header "location";; + +let ctf_StateMessage = ctf_header "state";; + +let ctf_PathGoalMessage () = + fnl () ++ str "message" ++ fnl () ++ str "single_goal" ++ fnl ();; + +let ctf_GoalReqIdMessage = ctf_header "single_goal_state";; + +let ctf_NewStateMessage = ctf_header "fresh_state";; + +let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++ + str "saved" ++ fnl();; + +let ctf_KilledMessage req_id ngoals = + ctf_header "killed" req_id ++ int ngoals ++ fnl ();; + +let ctf_AbortedAllMessage () = + fnl() ++ str "message" ++ fnl() ++ str "aborted_all" ++ fnl();; + +let ctf_AbortedMessage request_id na = + ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ + str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; + +let ctf_UserErrorMessage request_id stream = + let stream = guarded_force_eval_stream stream in + ctf_header "user_error" request_id ++ stream ++ fnl() ++ + str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; + +let ctf_ResetInitialMessage () = + fnl () ++ str "message" ++ fnl () ++ str "reset_initial" ++ fnl ();; + +let ctf_ResetIdentMessage request_id s = + ctf_header "reset_ident" request_id ++ str s ++ fnl () ++ + str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; + +type vtp_tree = + | P_rl of ct_RULE_LIST + | P_r of ct_RULE + | P_s_int of ct_SIGNED_INT_LIST + | P_pl of ct_PREMISES_LIST + | P_cl of ct_COMMAND_LIST + | P_t of ct_TACTIC_COM + | P_text of ct_TEXT + | P_ids of ct_ID_LIST;; + +let print_tree t = + (match t with + | P_rl x -> fRULE_LIST x + | P_r x -> fRULE x + | P_s_int x -> fSIGNED_INT_LIST x + | P_pl x -> fPREMISES_LIST x + | P_cl x -> fCOMMAND_LIST x + | P_t x -> fTACTIC_COM x + | P_text x -> fTEXT x + | P_ids x -> fID_LIST x); + print_string "e\nblabla\n";; + + + +let break_happened = ref false;; + +let output_results stream vtp_tree = + let _ = Sys.signal Sys.sigint + (Sys.Signal_handle(fun i -> (break_happened := true;()))) in + msg stream; + match vtp_tree with + Some t -> print_tree t + | None -> ();; + +let output_results_nl stream = + let _ = Sys.signal Sys.sigint + (Sys.Signal_handle(fun i -> break_happened := true;())) + in + msgnl stream;; + + +let rearm_break () = + let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun i -> raise Sys.Break)) + in ();; + +let check_break () = + if (!break_happened) then + begin + break_happened := false; + raise Sys.Break + end + else ();; + +let print_past_goal index = + let path = History.get_path_for_rank (current_proof_name()) index in + try traverse_to path; + let pf = proof_of_pftreestate (get_pftreestate ()) in + output_results (ctf_PathGoalMessage ()) + (Some (P_r (translate_goal pf.goal))) + with + | Invalid_argument s -> + ((try traverse_to [] with _ -> ()); + error "No focused proof (No proof-editing in progress)") + | e -> (try traverse_to [] with _ -> ()); raise e +;; + +let show_nth n = + try + let pf = proof_of_pftreestate (get_pftreestate()) in + if (!text_proof_flag<>"off") then + (if n=0 + then output_results (ctf_TextMessage !global_request_id) + (Some (P_text (show_proof !text_proof_flag []))) + else + let path = History.get_nth_open_path (current_proof_name()) n in + output_results (ctf_TextMessage !global_request_id) + (Some (P_text (show_proof !text_proof_flag path)))) + else + output_results (ctf_GoalReqIdMessage !global_request_id) + (let goal = List.nth (fst (frontier pf)) + (n - 1) in + (Some (P_r (translate_goal goal)))) + with + | Invalid_argument s -> + error "No focused proof (No proof-editing in progress)";; + +(* The rest of the file contains commands that are changed from the plain + Coq distribution *) + +let ctv_SEARCH_LIST = ref ([] : ct_PREMISE list);; + +(* +let filter_by_module_from_varg_list l = + let dir_list, b = Vernacentries.interp_search_restriction l in + Search.filter_by_module_from_list (dir_list, b);; +*) + +let add_search (global_reference:global_reference) assumptions cstr = + try + let id_string = + string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty + global_reference) in + let ast = + try + CT_premise (CT_ident id_string, translate_constr false assumptions cstr) + with Not_found -> + CT_premise (CT_ident id_string, + CT_coerce_ID_to_FORMULA( + CT_ident ("Error printing" ^ id_string))) in + ctv_SEARCH_LIST:= ast::!ctv_SEARCH_LIST + with e -> msgnl (str "add_search raised an exception"); raise e;; + +(* +let make_error_stream node_string = + str "The syntax of " ++ str node_string ++ + str " is inconsistent with the vernac interpreter entry";; +*) + +let ctf_EmptyGoalMessage id = + fnl () ++ str "Empty Goal is a no-op. Fun oh fun." ++ fnl ();; + + +let print_check judg = + let {uj_val=value; uj_type=typ} = judg in + 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) ++ + 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 + ((ctf_SearchResults !global_request_id), + (Some (P_pl + (CT_premises_list + [CT_coerce_TYPED_FORMULA_to_PREMISE + (CT_typed_formula(value_ct_ast,type_ct_ast) + )]))));; + +let ct_print_eval ast red_fun env judg = +((if refining() then traverse_to []); +let {uj_val=value; uj_type=typ} = judg in +let nvalue = red_fun value +(* // Attention , ici il faut peut être utiliser des environnemenst locaux *) +and ntyp = nf_betaiota typ in +(ctf_SearchResults !global_request_id, + Some (P_pl + (CT_premises_list + [CT_eval_result + (xlate_formula ast, + translate_constr false env nvalue, + translate_constr false env ntyp)]))));; + + + +(* 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 + (ctf_header "pbp_results" !global_request_id) + (Some (P_t(xlate_tactic x))));; + +let blast_tac_pcoq = + blast_tac (function (x:raw_tactic_expr) -> + output_results + (ctf_header "pbp_results" !global_request_id) + (Some (P_t(xlate_tactic x))));; + +(* <\cpa> +let dad_tac_pcoq = + dad_tac(function x -> + output_results + (ctf_header "pbp_results" !global_request_id) + (Some (P_t(xlate_tactic x))));; +</cpa> *) + +let search_output_results () = + output_results + (ctf_SearchResults !global_request_id) + (Some (P_pl (CT_premises_list + (List.rev !ctv_SEARCH_LIST))));; + + +let debug_tac2_pcoq tac = + (fun g -> + let the_goal = ref (None : goal sigma option) in + let the_ast = ref tac in + let the_path = ref ([] : int list) in + try + let result = report_error tac the_goal the_ast the_path [] g in + (errorlabstrm "DEBUG TACTIC" + (str "no error here " ++ fnl () ++ pr_goal (sig_it g) ++ + fnl () ++ str "the tactic is" ++ fnl () ++ + Pptactic.pr_glob_tactic tac); + result) + with + e -> + match !the_goal with + None -> raise e + | Some g -> + (output_results + (ctf_Location !global_request_id) + (Some (P_s_int + (CT_signed_int_list + (List.map + (fun n -> CT_coerce_INT_to_SIGNED_INT + (CT_int n)) + (clean_path tac + (List.rev !the_path))))))); + (output_results + (ctf_OtherGoal !global_request_id) + (Some (P_r (translate_goal (sig_it g))))); + raise e);; + +let rec selectinspect n env = + match env with + [] -> [] + | a::tl -> + if n = 0 then + [] + else + match a with + (sp, Lib.Leaf lobj) -> a::(selectinspect (n -1 ) tl) + | _ -> (selectinspect n tl);; + +open Term;; + +let inspect n = + let env = Global.env() in + let add_search2 x y = add_search x env y in + let l = selectinspect n (Lib.contents_after None) in + ctv_SEARCH_LIST := []; + List.iter + (fun a -> + try + (match a with + oname, Lib.Leaf lobj -> + (match oname, object_tag lobj with + (sp,_), "VARIABLE" -> + let (_, _, v) = 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 + 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()) + (RRef(dummy_loc, IndRef(kn,0)))) + | _ -> failwith ("unexpected value 1 for "^ + (string_of_id (basename (fst oname))))) + | _ -> failwith "unexpected value") + with e -> ()) + l; + output_results + (ctf_SearchResults !global_request_id) + (Some + (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; + +let ct_int_to_TARG n = + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_INT_to_ID_OR_INT (CT_int n)));; + +let pair_list_to_ct l = + CT_user_tac(CT_ident "pair_int_list", + CT_targ_list + (List.map (fun (a,b) -> + CT_coerce_TACTIC_COM_to_TARG + (CT_user_tac + (CT_ident "pair_int", + CT_targ_list + [ct_int_to_TARG a; ct_int_to_TARG b]))) + l));; + +(* Annule toutes les commandes qui s'appliquent sur les sous-buts du + but auquel a été appliquée la n-ième tactique *) +let logical_kill n = + let path = History.get_path_for_rank (current_proof_name()) n in + begin + traverse_to path; + Pfedit.mutate weak_undo_pftreestate; + (let kept_cmds, undone_cmds, remaining_goals, current_goal = + History.logical_undo (current_proof_name()) n in + output_results (ctf_undoResults !global_request_id) + (Some + (P_t + (CT_user_tac + (CT_ident "log_undo_result", + CT_targ_list + [CT_coerce_TACTIC_COM_to_TARG (pair_list_to_ct kept_cmds); + CT_coerce_TACTIC_COM_to_TARG(pair_list_to_ct undone_cmds); + ct_int_to_TARG remaining_goals; + ct_int_to_TARG current_goal]))))); + traverse_to [] + end;; + +let simulate_solve n tac = + let path = History.get_nth_open_path (current_proof_name()) n in + solve_nth n (Tacinterp.hide_interp tac (get_end_tac())); + traverse_to path; + Pfedit.mutate weak_undo_pftreestate; + traverse_to [] + +let kill_node_verbose n = + let ngoals = kill_proof_node n in + output_results_nl (ctf_KilledMessage !global_request_id ngoals) + +let set_text_mode s = text_proof_flag := s + +let pcoq_reset_initial() = + output_results(ctf_AbortedAllMessage()) None; + Vernacentries.abort_refine Lib.reset_initial (); + output_results(ctf_ResetInitialMessage()) None;; + +let pcoq_reset x = + if refining() then + output_results (ctf_AbortedAllMessage ()) None; + Vernacentries.abort_refine Lib.reset_name (dummy_loc,x); + output_results + (ctf_ResetIdentMessage !global_request_id (string_of_id x)) None;; + + +VERNAC ARGUMENT EXTEND text_mode +| [ "fr" ] -> [ "fr" ] +| [ "en" ] -> [ "en" ] +| [ "Off" ] -> [ "off" ] +END + +VERNAC COMMAND EXTEND TextMode +| [ "Text" "Mode" text_mode(s) ] -> [ set_text_mode s ] +END + +VERNAC COMMAND EXTEND OutputGoal + [ "Goal" ] -> [ output_results_nl(ctf_EmptyGoalMessage "") ] +END + +VERNAC COMMAND EXTEND OutputGoal + [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ simulate_solve n tac ] +END + +VERNAC COMMAND EXTEND KillProofAfter +| [ "Kill" "Proof" "after" natural(n) ] -> [ kill_node_verbose n ] +END + +VERNAC COMMAND EXTEND KillProofAt +| [ "Kill" "Proof" "at" natural(n) ] -> [ kill_node_verbose n ] +END + +VERNAC COMMAND EXTEND KillSubProof + [ "Kill" "SubProof" natural(n) ] -> [ logical_kill n ] +END + +VERNAC COMMAND EXTEND PcoqReset + [ "Pcoq" "Reset" ident(x) ] -> [ pcoq_reset x ] +END + +VERNAC COMMAND EXTEND PcoqResetInitial + [ "Pcoq" "ResetInitial" ] -> [ pcoq_reset_initial() ] +END + +let start_proof_hook () = + History.start_proof (current_proof_name()); + current_goal_index := 1 + +let solve_hook n = + let name = current_proof_name () in + let old_n_count = History.border_length name in + let pf = proof_of_pftreestate (get_pftreestate ()) in + let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in + begin + current_goal_index := n; + History.push_command name n n_goals + end + +let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s) + +let interp_search_about_item = function + | SearchRef qid -> GlobSearchRef (Nametab.global qid) + | SearchString s -> GlobSearchString s + +let pcoq_search s l = + ctv_SEARCH_LIST:=[]; + begin match s with + | SearchAbout sl -> + raw_search_about (filter_by_module_from_list l) add_search + (List.map interp_search_about_item sl) + | SearchPattern c -> + let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + raw_pattern_search (filter_by_module_from_list l) add_search pat + | SearchRewrite c -> + let _,pat = interp_constrpattern Evd.empty (Global.env()) c in + raw_search_rewrite (filter_by_module_from_list l) add_search pat; + | SearchHead locqid -> + filtered_search + (filter_by_module_from_list l) add_search (Nametab.global locqid) + end; + search_output_results() + +(* Check sequentially whether the pattern is one of the premises *) +let rec hyp_pattern_filter pat name a c = + let c1 = strip_outer_cast c in + match kind_of_term c with + | Prod(_, hyp, c2) -> + (try +(* let _ = msgnl ((str "WHOLE ") ++ (Printer.prterm c)) in + let _ = msgnl ((str "PAT ") ++ (Printer.pr_pattern pat)) in *) + if Matching.is_matching pat hyp then + (msgnl (str "ok"); true) + else + false + with UserError _ -> false) or + hyp_pattern_filter pat name a c2 + | _ -> false;; + +let hyp_search_pattern c l = + let _, pat = interp_constrpattern Evd.empty (Global.env()) c in + ctv_SEARCH_LIST := []; + gen_filtered_search + (fun s a c -> (filter_by_module_from_list l s a c && + (if hyp_pattern_filter pat s a c then + (msgnl (str "ok2"); true) else false))) + (fun s a c -> (msgnl (str "ok3"); add_search s a c)); + output_results + (ctf_SearchResults !global_request_id) + (Some + (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; +let pcoq_print_name ref = + let results = xlate_vernac_list (name_to_ast ref) in + output_results + (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl ()) + (Some (P_cl results)) + +let pcoq_print_check j = + let a,b = print_check j in output_results a b + +let pcoq_print_eval redfun env c j = + let strm, vtp = ct_print_eval c redfun env j in + output_results strm vtp;; + +open Vernacentries + +let pcoq_show_goal = function + | Some n -> show_nth n + | None -> + if !pcoq_started = Some true (* = debug *) then + msg (Pfedit.pr_open_subgoals ()) + else errorlabstrm "show_goal" + (str "Show must be followed by an integer in Centaur mode");; + +let pcoq_hook = { + start_proof = start_proof_hook; + solve = solve_hook; + abort = abort_hook; + search = pcoq_search; + print_name = pcoq_print_name; + print_check = pcoq_print_check; + print_eval = pcoq_print_eval; + show_goal = pcoq_show_goal +} + + +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) ] +END + +TACTIC EXTEND CtDebugTac2 +| [ "DebugTac2" tactic(t) ] -> [ if_pcoq debug_tac2_pcoq (fst t) ] +END + + +let start_pcoq_mode debug = + begin + pcoq_started := Some debug; +(* <\cpa> + start_dad(); +</cpa> *) + declare_in_coq(); +(* The following ones are added to enable rich comments in pcoq *) +(* TODO ... + add_tactic "Image" (fun _ -> tclIDTAC); +*) +(* "Comments" moved to Vernacentries, other obsolete ? + List.iter (fun (a,b) -> vinterp_add a b) command_creations; +*) +(* Now hooks in Vernacentries + List.iter (fun (a,b) -> overwriting_vinterp_add a b) command_changes; + if not debug then + List.iter (fun (a,b) -> overwriting_vinterp_add a b) non_debug_changes; +*) + set_pcoq_hook pcoq_hook; + end;; + + +let start_pcoq () = + start_pcoq_mode false; + set_acknowledge_command ctf_acknowledge_command; + set_start_marker "CENTAUR_RESERVED_TOKEN_start_command"; + set_end_marker "CENTAUR_RESERVED_TOKEN_end_command"; + raise Vernacexpr.ProtectedLoop;; + +let start_pcoq_debug () = + start_pcoq_mode true; + set_acknowledge_command ctf_acknowledge_command; + set_start_marker "--->"; + set_end_marker "<---"; + raise Vernacexpr.ProtectedLoop;; + +VERNAC COMMAND EXTEND HypSearchPattern + [ "HypSearchPattern" constr(pat) ] -> [ hyp_search_pattern pat ([], false) ] +END + +VERNAC COMMAND EXTEND StartPcoq + [ "Start" "Pcoq" "Mode" ] -> [ start_pcoq () ] +END + +VERNAC COMMAND EXTEND Pcoq_inspect + [ "Pcoq_inspect" ] -> [ inspect 15 ] +END + +VERNAC COMMAND EXTEND StartPcoqDebug +| [ "Start" "Pcoq" "Debug" "Mode" ] -> [ start_pcoq_debug () ] +END diff --git a/contrib/interface/ctast.ml b/contrib/interface/ctast.ml new file mode 100644 index 00000000..67279bb8 --- /dev/null +++ b/contrib/interface/ctast.ml @@ -0,0 +1,76 @@ +(* 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 new file mode 100644 index 00000000..ec989296 --- /dev/null +++ b/contrib/interface/dad.ml @@ -0,0 +1,382 @@ +(* This file contains an ml version of drag-and-drop. *) + +(* #use "/net/home/bertot/experiments/pcoq/src/dad/dad.ml" *) + +open Names;; +open Term;; +open Rawterm;; +open Util;; +open Environ;; +open Tactics;; +open Tacticals;; +open Pattern;; +open Matching;; +open Reduction;; +open Constrextern;; +open Constrintern;; +open Vernacinterp;; +open Libnames;; +open Nametab + +open Proof_type;; +open Proof_trees;; +open Tacmach;; +open Typing;; +open Pp;; + +open Paths;; + +open Topconstr;; +open Genarg;; +open Tacexpr;; +open Rawterm;; + +(* In a first approximation, drag-and-drop rules are like in CtCoq + 1/ a pattern, + 2,3/ Two paths: start and end positions, + 4/ the degree: the number of steps the algorithm should go up from the + longest common prefix, + 5/ the tail path: the suffix of the longest common prefix of length the + degree, + 6/ the command pattern, where meta variables are represented by objects + of the form Node(_,"META"; [Num(_,i)]) +*) + + +type dad_rule = + constr_expr * int list * int list * int * int list + * raw_atomic_tactic_expr;; + +(* This value will be used systematically when constructing objects *) + +let zz = Util.dummy_loc;; + +(* This function receives a length n, a path p, and a term and returns a + couple whose first component is the subterm designated by the prefix + of p of length n, and the second component is the rest of the path *) + +let rec get_subterm (depth:int) (path: int list) (constr:constr) = + match depth, path, kind_of_term constr with + 0, l, c -> (constr,l) + | n, 2::a::tl, App(func,arr) -> + get_subterm (n - 2) tl arr.(a-1) + | _,l,_ -> failwith (int_list_to_string + "wrong path or wrong form of term" + l);; + +(* This function maps a substitution on an abstract syntax tree. The + first argument, an object of type env, is necessary to + transform constr terms into abstract syntax trees. The second argument is + the substitution, a list of pairs linking an integer and a constr term. *) + +let rec map_subst (env :env) (subst:patvar_map) = function + | CPatVar (_,(_,i)) -> + let constr = List.assoc i subst in + extern_constr false env constr + | x -> map_constr_expr_with_binders (map_subst env) (fun _ x -> x) subst x;; + +let map_subst_tactic env subst = function + | TacExtend (loc,("Rewrite" as x),[b;cbl]) -> + let c,bl = out_gen rawwit_constr_with_bindings cbl in + assert (bl = NoBindings); + let c = (map_subst env subst c,NoBindings) in + TacExtend (loc,x,[b;in_gen rawwit_constr_with_bindings c]) + | _ -> failwith "map_subst_tactic: unsupported tactic" + +(* This function is really the one that is important. *) +let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 = + match l with + [] -> failwith "nothing happens" + | (name, (pat, p_f, p_l, deg, p_r, cmd))::tl -> + let length = List.length p in + try + if deg > length then + failwith "internal" + else + let term_to_match, p_r = + try + get_subterm (length - deg) p constr + with + Failure s -> failwith "internal" in + let _, constr_pat = + interp_constrpattern Evd.empty (Global.env()) + ((*ct_to_ast*) pat) in + let subst = matches constr_pat term_to_match in + if (is_prefix p_f (p_r@p1)) & (is_prefix p_l (p_r@p2)) then + TacAtom (zz, map_subst_tactic env subst cmd) + else + failwith "internal" + with + Failure "internal" -> find_cmd tl env constr p p1 p2 + | PatternMatchingFailure -> find_cmd tl env constr p p1 p2;; + + +let dad_rule_list = ref ([]: (string * dad_rule) list);; + +(* +(* \\ This function is also used in pbp. *) +let rec tactic_args_to_ints = function + [] -> [] + | (Integer n)::l -> n::(tactic_args_to_ints l) + | _ -> failwith "expecting only numbers";; + +(* We assume that the two lists of integers for the tactic are simply + given in one list, separated by a dummy tactic. *) +let rec part_tac_args l = function + [] -> l,[] + | (Tacexp a)::tl -> l, (tactic_args_to_ints tl) + | (Integer n)::tl -> part_tac_args (n::l) tl + | _ -> failwith "expecting only numbers and the word \"to\"";; + + +(* The dad_tac tactic takes a display_function as argument. This makes + it possible to use it in pcoq, but also in other contexts, just by + changing the output routine. *) +let dad_tac display_function = function + l -> let p1, p2 = part_tac_args [] l in + (function g -> + let (p_a, p1prime, p2prime) = decompose_path (List.rev p1,p2) in + (display_function + (find_cmd (!dad_rule_list) (pf_env g) + (pf_concl g) p_a p1prime p2prime)); + tclIDTAC g);; +*) +let dad_tac display_function p1 p2 g = + let (p_a, p1prime, p2prime) = decompose_path (p1,p2) in + (display_function + (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime)); + tclIDTAC g;; + +(* Now we enter dad rule list management. *) + +let add_dad_rule name patt p1 p2 depth pr command = + dad_rule_list := (name, + (patt, p1, p2, depth, pr, command))::!dad_rule_list;; + +let rec remove_if_exists name = function + [] -> false, [] + | ((a,b) as rule1)::tl -> if a = name then + let result1, l = (remove_if_exists name tl) in + true, l + else + let result1, l = remove_if_exists name tl in + result1, (rule1::l);; + +let remove_dad_rule name = + let result1, result2 = remove_if_exists name !dad_rule_list in + if result1 then + failwith("No such name among the drag and drop rules " ^ name) + else + dad_rule_list := result2;; + +let dad_rule_names () = + List.map (function (s,_) -> s) !dad_rule_list;; + +(* this function is inspired from matches_core in pattern.ml *) +let constrain ((n : patvar),(pat : constr_pattern)) sigma = + if List.mem_assoc n sigma then + if pat = (List.assoc n sigma) then sigma + else failwith "internal" + else + (n,pat)::sigma + +(* This function is inspired from matches_core in pattern.ml *) +let more_general_pat pat1 pat2 = + let rec match_rec sigma p1 p2 = + match p1, p2 with + | PMeta (Some n), m -> constrain (n,m) sigma + + | PMeta None, m -> sigma + + | PRef (VarRef sp1), PRef(VarRef sp2) when sp1 = sp2 -> sigma + + | PVar v1, PVar v2 when v1 = v2 -> sigma + + | PRef ref1, PRef ref2 when ref1 = ref2 -> sigma + + | PRel n1, PRel n2 when n1 = n2 -> sigma + + | PSort (RProp c1), PSort (RProp c2) when c1 = c2 -> sigma + + | PSort (RType _), PSort (RType _) -> sigma + + | PApp (c1,arg1), PApp (c2,arg2) -> + (try array_fold_left2 match_rec (match_rec sigma c1 c2) arg1 arg2 + with Invalid_argument _ -> failwith "internal") + | _ -> failwith "unexpected case in more_general_pat" in + try let _ = match_rec [] pat1 pat2 in true + with Failure "internal" -> false;; + +let more_general r1 r2 = + match r1,r2 with + (_,(patt1,p11,p12,_,_,_)), + (_,(patt2,p21,p22,_,_,_)) -> + (more_general_pat patt1 patt2) & + (is_prefix p11 p21) & (is_prefix p12 p22);; + +let not_less_general r1 r2 = + not (match r1,r2 with + (_,(patt1,p11,p12,_,_,_)), + (_,(patt2,p21,p22,_,_,_)) -> + (more_general_pat patt1 patt2) & + (is_prefix p21 p11) & (is_prefix p22 p12));; + +let rec add_in_list_sorting rule1 = function + [] -> [rule1] + | (b::tl) as this_list -> + if more_general rule1 b then + b::(add_in_list_sorting rule1 tl) + else if not_less_general rule1 b then + let tl2 = add_in_list_sorting_aux rule1 tl in + (match tl2 with + [] -> rule1::this_list + | _ -> b::tl2) + else + rule1::this_list +and add_in_list_sorting_aux rule1 = function + [] -> [] + | b::tl -> + if more_general rule1 b then + b::(add_in_list_sorting rule1 tl) + else + let tl2 = add_in_list_sorting_aux rule1 tl in + (match tl2 with + [] -> [] + | _ -> rule1::tl2);; + +let rec sort_list = function + [] -> [] + | a::l -> add_in_list_sorting a (sort_list l);; + +let mk_dad_meta n = CPatVar (zz,(true,Nameops.make_ident "DAD" (Some n)));; +let mk_rewrite lr ast = + let b = in_gen rawwit_bool lr in + let cb = in_gen rawwit_constr_with_bindings ((*Ctast.ct_to_ast*) ast,NoBindings) in + TacExtend (zz,"Rewrite",[b;cb]) + +open Vernacexpr + +let dad_status = ref false;; + +let start_dad () = dad_status := true;; + +let add_dad_rule_fn name pat p1 p2 tac = + let pr = match decompose_path (p1, p2) with pr, _, _ -> pr in + add_dad_rule name pat p1 p2 (List.length pr) pr tac;; + +(* To be parsed by camlp4 + +(*i camlp4deps: "parsing/grammar.cma" i*) + +VERNAC COMMAND EXTEND AddDadRule + [ "Add" "Dad" "Rule" string(name) constr(pat) + "From" natural_list(p1) "To" natural_list(p2) tactic(tac) ] -> + [ add_dad_rule_fn name pat p1 p2 tac ] +END + +*) + +let mk_id s = mkIdentC (id_of_string s);; +let mkMetaC = mk_dad_meta;; + +add_dad_rule "distributivity-inv" +(mkAppC(mk_id("mult"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) +[2; 2] +[2; 1] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "distributivity1-r" +(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) +[2; 2; 2; 2] +[] +0 +[] +(mk_rewrite false (mkAppC(mk_id("mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "distributivity1-l" +(mkAppC(mk_id("plus"),[mkAppC(mk_id("mult"),[mkMetaC(4);mkMetaC(2)]);mkAppC(mk_id("mult"),[mkMetaC(3);mkMetaC(2)])])) +[2; 1; 2; 2] +[] +0 +[] +(mk_rewrite false (mkAppC(mk_id( "mult_plus_distr"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "associativity" +(mkAppC(mk_id("plus"),[mkAppC(mk_id("plus"),[mkMetaC(4);mkMetaC(3)]);mkMetaC(2)])) +[2; 1] +[] +0 +[] +(mk_rewrite true (mkAppC(mk_id( "plus_assoc_r"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "minus-identity-lr" +(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) +[2; 1] +[2; 2] +1 +[2] +(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); + +add_dad_rule "minus-identity-rl" +(mkAppC(mk_id("minus"),[mkMetaC(2);mkMetaC(2)])) +[2; 2] +[2; 1] +1 +[2] +(mk_rewrite false (mkAppC(mk_id( "minus_n_n"),[(mk_dad_meta 2) ]))); + +add_dad_rule "plus-sym-rl" +(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) +[2; 2] +[2; 1] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "plus-sym-lr" +(mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])) +[2; 1] +[2; 2] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "plus_sym"),[(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "absorb-0-r-rl" +(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) +[2; 2] +[1] +0 +[] +(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); + +add_dad_rule "absorb-0-r-lr" +(mkAppC(mk_id("plus"),[mkMetaC(2);mk_id("O")])) +[1] +[2; 2] +0 +[] +(mk_rewrite false (mkAppC(mk_id( "plus_n_O"),[(mk_dad_meta 2) ]))); + +add_dad_rule "plus-permute-lr" +(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) +[2; 1] +[2; 2; 2; 1] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ]))); + +add_dad_rule "plus-permute-rl" +(mkAppC(mk_id("plus"),[mkMetaC(4);mkAppC(mk_id("plus"),[mkMetaC(3);mkMetaC(2)])])) +[2; 2; 2; 1] +[2; 1] +1 +[2] +(mk_rewrite true (mkAppC(mk_id( "plus_permute"),[(mk_dad_meta 4) ;(mk_dad_meta 3) ;(mk_dad_meta 2) ])));; + +vinterp_add "StartDad" + (function + | [] -> + (function () -> start_dad()) + | _ -> errorlabstrm "StartDad" (mt()));; diff --git a/contrib/interface/dad.mli b/contrib/interface/dad.mli new file mode 100644 index 00000000..f556c192 --- /dev/null +++ b/contrib/interface/dad.mli @@ -0,0 +1,10 @@ +open Proof_type;; +open Tacmach;; +open Topconstr;; + +val dad_rule_names : unit -> string list;; +val start_dad : unit -> unit;; +val dad_tac : (Tacexpr.raw_tactic_expr -> 'a) -> int list -> int list -> goal sigma -> + goal list sigma * validation;; +val add_dad_rule : string -> constr_expr -> (int list) -> (int list) -> + int -> (int list) -> Tacexpr.raw_atomic_tactic_expr -> unit;; diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4 new file mode 100644 index 00000000..bf596b28 --- /dev/null +++ b/contrib/interface/debug_tac.ml4 @@ -0,0 +1,570 @@ +(*i camlp4deps: "parsing/grammar.cma" i*) + +open Ast;; +open Coqast;; +open Tacmach;; +open Tacticals;; +open Proof_trees;; +open Pp;; +open Pptactic;; +open Util;; +open Proof_type;; +open Tacexpr;; +open Genarg;; + +(* Compacting and uncompacting proof commands *) + +type report_tree = + Report_node of bool *int * report_tree list + | Mismatch of int * int + | Tree_fail of report_tree + | Failed of int;; + +type report_card = + Ngoals of int + | Goals_mismatch of int + | Recursive_fail of report_tree + | Fail;; + +type card_holder = report_card ref;; +type report_holder = report_tree list ref;; + +(* This tactical receives an integer and a tactic and checks that the + tactic produces that number of goals. It never fails but signals failure + by updating the boolean reference given as third argument to false. + It is especially suited for use in checked_thens below. *) + +let check_subgoals_count : card_holder -> int -> bool ref -> tactic -> tactic = + fun card_holder count flag t g -> + try + let (gls, v) as result = t g in + let len = List.length (sig_it gls) in + card_holder := + (if len = count then + (flag := true; + Ngoals count) + else + (flag := false; + Goals_mismatch len)); + result + with + e -> card_holder := Fail; + flag := false; + tclIDTAC g;; + +let no_failure = function + [Report_node(true,_,_)] -> true + | _ -> false;; + +let check_subgoals_count2 + : card_holder -> int -> bool ref -> (report_holder -> tactic) -> tactic = + fun card_holder count flag t g -> + let new_report_holder = ref ([] : report_tree list) in + let (gls, v) as result = t new_report_holder g in + let succeeded = no_failure !new_report_holder in + let len = List.length (sig_it gls) in + card_holder := + (if (len = count) & succeeded then + (flag := true; + Ngoals count) + else + (flag := false; + Recursive_fail (List.hd !new_report_holder))); + result;; + +(* +let traceable = function + Node(_, "TACTICLIST", a::b::tl) -> true + | _ -> false;; +*) +let traceable = function + | TacThen _ | TacThens _ -> true + | _ -> false;; + +let rec collect_status = function + Report_node(true,_,_)::tl -> collect_status tl + | [] -> true + | _ -> false;; + +(* This tactical receives a tactic and executes it, reporting information + about success in the report holder and a boolean reference. *) + +let count_subgoals : card_holder -> bool ref -> tactic -> tactic = + fun card_holder flag t g -> + try + let (gls, _) as result = t g in + card_holder := (Ngoals(List.length (sig_it gls))); + flag := true; + result + with + e -> card_holder := Fail; + flag := false; + tclIDTAC g;; + +let count_subgoals2 + : card_holder -> bool ref -> (report_holder -> tactic) -> tactic = + fun card_holder flag t g -> + let new_report_holder = ref([] : report_tree list) in + let (gls, v) as result = t new_report_holder g in + let succeeded = no_failure !new_report_holder in + if succeeded then + (flag := true; + card_holder := Ngoals (List.length (sig_it gls))) + else + (flag := false; + card_holder := Recursive_fail(List.hd !new_report_holder)); + result;; + +let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function +(* + 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) -> + (fun report_holder -> checked_then report_holder a b) + | t -> + (fun report_holder g -> + try + let (gls, _) as result = Tacinterp.eval_tactic t g in + report_holder := (Report_node(true, List.length (sig_it gls), [])) + ::!report_holder; + result + with e -> (report_holder := (Failed 1)::!report_holder; + tclIDTAC g)) + + +(* This tactical receives a tactic and a list of tactics as argument. + It applies the first tactic and then maps the list of tactics to + various produced sub-goals. This tactic will never fail, but reports + are added in the report_holder in the following way: + - In case of partial success, a new report_tree is added to the report_holder + - In case of failure of the first tactic, with no more indications + then Failed 0 is added to the report_holder, + - In case of partial failure of the first tactic then (Failed n) is added to + the report holder. + - In case of success of the first tactic, but count mismatch, then + Mismatch n is added to the report holder. *) + +and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = + (fun report_holder t1 l g -> + let flag = ref true in + let traceable_t1 = traceable t1 in + let card_holder = ref Fail in + let new_holder = ref ([]:report_tree list) in + let tac_t1 = + if traceable_t1 then + (check_subgoals_count2 card_holder (List.length l) + flag (local_interp t1)) + else + (check_subgoals_count card_holder (List.length l) + flag (Tacinterp.eval_tactic t1)) in + let (gls, _) as result = + tclTHEN_i tac_t1 + (fun i -> + if !flag then + (fun g -> + let tac_i = (List.nth l i) in + if traceable tac_i then + local_interp tac_i new_holder g + else + try + let (gls,_) as result = Tacinterp.eval_tactic tac_i g in + let len = List.length (sig_it gls) in + new_holder := + (Report_node(true, len, []))::!new_holder; + result + with + e -> (new_holder := (Failed 1)::!new_holder; + tclIDTAC g)) + else + tclIDTAC) g in + let new_goal_list = sig_it gls in + (if !flag then + report_holder := + (Report_node(collect_status !new_holder, + (List.length new_goal_list), + List.rev !new_holder))::!report_holder + else + report_holder := + (match !card_holder with + Goals_mismatch(n) -> Mismatch(n, List.length l) + | Recursive_fail tr -> Tree_fail tr + | Fail -> Failed 1 + | _ -> errorlabstrm "check_thens" + (str "this case should not happen in check_thens")):: + !report_holder); + result) + +(* This tactical receives two tactics as argument, it executes the + first tactic and applies the second one to all the produced goals, + reporting information about the success of all tactics in the report + holder. It never fails. *) + +and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tactic = + (fun report_holder t1 t2 g -> + let flag = ref true in + let card_holder = ref Fail in + let tac_t1 = + if traceable t1 then + (count_subgoals2 card_holder flag (local_interp t1)) + else + (count_subgoals card_holder flag (Tacinterp.eval_tactic t1)) in + let new_tree_holder = ref ([] : report_tree list) in + let (gls, _) as result = + tclTHEN tac_t1 + (fun (g:goal sigma) -> + if !flag then + if traceable t2 then + local_interp t2 new_tree_holder g + else + try + let (gls, _) as result = Tacinterp.eval_tactic t2 g in + new_tree_holder := + (Report_node(true, List.length (sig_it gls),[])):: + !new_tree_holder; + result + with + e -> + (new_tree_holder := ((Failed 1)::!new_tree_holder); + tclIDTAC g) + else + tclIDTAC g) g in + (if !flag then + report_holder := + (Report_node(collect_status !new_tree_holder, + List.length (sig_it gls), + List.rev !new_tree_holder))::!report_holder + else + report_holder := + (match !card_holder with + Recursive_fail tr -> Tree_fail tr + | Fail -> Failed 1 + | _ -> error "this case should not happen in check_then")::!report_holder); + result);; + +(* This tactic applies the given tactic only to those subgoals designated + by the list of integers given as extra arguments. + *) + +let on_then = function [t1;t2;l] -> + let t1 = out_gen wit_tactic t1 in + let t2 = out_gen wit_tactic t2 in + let l = out_gen (wit_list0 wit_int) l in + tclTHEN_i (Tacinterp.eval_tactic t1) + (fun i -> + if List.mem (i + 1) l then + (Tacinterp.eval_tactic t2) + else + tclIDTAC) + | _ -> anomaly "bad arguments for on_then";; + +let mkOnThen t1 t2 selected_indices = + let a = in_gen rawwit_tactic t1 in + let b = in_gen rawwit_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) -> + (function + Report_node(true, n, l) -> tac + | Report_node(false, n, rl) -> + TacThens (a,List.map2 reconstruct_success_tac l rl) + | Failed n -> TacId "" + | Tree_fail r -> reconstruct_success_tac a r + | Mismatch (n,p) -> a) + | TacThen (a,b) -> + (function + Report_node(true, n, l) -> tac + | Report_node(false, n, rl) -> + let selected_indices = select_success 1 rl in + TacAtom (dummy_loc,TacExtend (dummy_loc,"OnThen", + [in_gen globwit_tactic a; + in_gen globwit_tactic b; + in_gen (wit_list0 globwit_int) selected_indices])) + | Failed n -> TacId "" + | Tree_fail r -> reconstruct_success_tac a r + | _ -> error "this error case should not happen in a THEN tactic") + | _ -> + (function + Report_node(true, n, l) -> tac + | Failed n -> TacId "" + | _ -> + errorlabstrm + "this error case should not happen on an unknown tactic" + (str "error in reconstruction with " ++ fnl () ++ + (pr_glob_tactic tac)));; + + +let rec path_to_first_error = function +| Report_node(true, _, l) -> + let rec find_first_error n = function + | (Report_node(true, _, _))::tl -> find_first_error (n + 1) tl + | it::tl -> n, it + | [] -> error "no error detected" in + let p, t = find_first_error 1 l in + p::(path_to_first_error t) +| _ -> [];; + +(* +let 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 -> + let report = ref ([] : report_tree list) in + let result = local_interp ast report g in + let clean_ast = (* expand_tactic *) ast in + let report_tree = + try List.hd !report with + Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in + let success_tac = + reconstruct_success_tac clean_ast report_tree in + let compact_success_tac = (* flatten_then *) success_tac in + msgnl (fnl () ++ + str "========= Successful tactic =============" ++ + fnl () ++ + pr_glob_tactic compact_success_tac ++ fnl () ++ + str "========= End of successful tactic ============"); + result) + | _ -> error "wrong arguments for debug_tac";; + +(* TODO ... used ? +add_tactic "DebugTac" debug_tac;; +*) + +(* +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 -> + fst::(clean_path (if fst = 1 then a else b) tl) + | TacThens (a,l), 1::tl -> + 1::(clean_path a tl) + | TacThens (a,tacs), 2::fst::tl -> + 2::fst::(clean_path (List.nth tacs (fst - 1)) tl) + | _, [] -> [] + | _, _ -> failwith "this case should not happen in clean_path";; + +let rec report_error + : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> + int list -> tactic = + fun tac the_goal the_ast returned_path path -> + match tac with + TacThens (a,l) -> + let the_card_holder = ref Fail in + let the_flag = ref false in + let the_exn = ref (Failure "") in + tclTHENS + (fun g -> + let result = + check_subgoals_count + the_card_holder + (List.length l) + the_flag + (fun g2 -> + try + (report_error a the_goal the_ast returned_path (1::path) g2) + with + e -> (the_exn := e; raise e)) + g in + if !the_flag then + result + else + (match !the_card_holder with + Fail -> + the_ast := TacThens (!the_ast, l); + raise !the_exn + | Goals_mismatch p -> + the_ast := tac; + returned_path := path; + error ("Wrong number of tactics: expected " ^ + (string_of_int (List.length l)) ^ " received " ^ + (string_of_int p)) + | _ -> error "this should not happen")) + (let rec fold_num n = function + [] -> [] + | t::tl -> (report_error t the_goal the_ast returned_path (n::2::path)):: + (fold_num (n + 1) tl) in + fold_num 1 l) + | TacThen (a,b) -> + let the_count = ref 1 in + tclTHEN + (fun g -> + try + report_error a the_goal the_ast returned_path (1::path) g + with + e -> + (the_ast := TacThen (!the_ast, b); + raise e)) + (fun g -> + try + let result = + report_error b the_goal the_ast returned_path (2::path) g in + the_count := !the_count + 1; + result + with + e -> + if !the_count > 1 then + msgnl + (str "in branch no " ++ int !the_count ++ + str " after tactic " ++ pr_glob_tactic a); + raise e) + | tac -> + (fun g -> + try + Tacinterp.eval_tactic tac g + with + e -> + (the_ast := tac; + the_goal := Some g; + returned_path := path; + raise e));; + +let strip_some = function + Some n -> n + | None -> failwith "No optional value";; + +let descr_first_error tac = + (fun g -> + let the_goal = ref (None : goal sigma option) in + let the_ast = ref tac in + let the_path = ref ([] : int list) in + try + let result = report_error tac the_goal the_ast the_path [] g in + msgnl (str "no Error here"); + result + with + e -> + (msgnl (str "Execution of this tactic raised message " ++ fnl () ++ + fnl () ++ Cerrors.explain_exn e ++ fnl () ++ + fnl () ++ str "on goal" ++ fnl () ++ + pr_goal (sig_it (strip_some !the_goal)) ++ fnl () ++ + str "faulty tactic is" ++ fnl () ++ fnl () ++ + pr_glob_tactic ((*flatten_then*) !the_ast) ++ fnl ()); + tclIDTAC g)) + +(* TODO ... used ?? +add_tactic "DebugTac2" descr_first_error;; +*) + +(* +TACTIC EXTEND DebugTac2 + [ ??? ] -> [ descr_first_error tac ] +END +*) diff --git a/contrib/interface/debug_tac.mli b/contrib/interface/debug_tac.mli new file mode 100644 index 00000000..ded714b6 --- /dev/null +++ b/contrib/interface/debug_tac.mli @@ -0,0 +1,6 @@ + +val report_error : Tacexpr.glob_tactic_expr -> + Proof_type.goal Proof_type.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/history.ml b/contrib/interface/history.ml new file mode 100644 index 00000000..f73c2084 --- /dev/null +++ b/contrib/interface/history.ml @@ -0,0 +1,373 @@ +open Paths;; + +type tree = {mutable index : int; + parent : tree option; + path_to_root : int list; + mutable is_open : bool; + mutable sub_proofs : tree list};; + +type prf_info = { + mutable prf_length : int; + mutable ranks_and_goals : (int * int * tree) list; + mutable border : tree list; + prf_struct : tree};; + +let theorem_proofs = ((Hashtbl.create 17): + (string, prf_info) Hashtbl.t);; + + +let rec mk_trees_for_goals path tree rank k n = + if k = (n + 1) then + [] + else + { index = rank; + parent = tree; + path_to_root = k::path; + is_open = true; + sub_proofs = [] } ::(mk_trees_for_goals path tree rank (k+1) n);; + + +let push_command s rank ngoals = + let ({prf_length = this_length; + ranks_and_goals = these_ranks; + border = this_border} as proof_info) = + Hashtbl.find theorem_proofs s in + let rec push_command_aux n = function + [] -> failwith "the given rank was too large" + | a::l -> + if n = 1 then + let {path_to_root = p} = a in + let new_trees = mk_trees_for_goals p (Some a) (this_length + 1) 1 ngoals in + new_trees,(new_trees@l),a + else + let new_trees, res, this_tree = push_command_aux (n-1) l in + new_trees,(a::res),this_tree in + let new_trees, new_border, this_tree = + push_command_aux rank this_border in + let new_length = this_length + 1 in + begin + proof_info.border <- new_border; + proof_info.prf_length <- new_length; + proof_info.ranks_and_goals <- (rank, ngoals, this_tree)::these_ranks; + this_tree.index <- new_length; + this_tree.is_open <- false; + this_tree.sub_proofs <- new_trees + end;; + +let get_tree_for_rank thm_name rank = + let {ranks_and_goals=l;prf_length=n} = + Hashtbl.find theorem_proofs thm_name in + let rec get_tree_aux = function + [] -> + failwith + "inconsistent values for thm_name and rank in get_tree_for_rank" + | (_,_,({index=i} as tree))::tl -> + if i = rank then + tree + else + get_tree_aux tl in + get_tree_aux l;; + +let get_path_for_rank thm_name rank = + let {path_to_root=l}=get_tree_for_rank thm_name rank in + l;; + +let rec list_descendants_aux l tree = + let {index = i; is_open = open_status; sub_proofs = tl} = tree in + let res = (List.fold_left list_descendants_aux l tl) in + if open_status then i::res else res;; + +let list_descendants thm_name rank = + list_descendants_aux [] (get_tree_for_rank thm_name rank);; + +let parent_from_rank thm_name rank = + let {parent=mommy} = get_tree_for_rank thm_name rank in + match mommy with + Some x -> Some x.index + | None -> None;; + +let first_child_command thm_name rank = + let {sub_proofs = l} = get_tree_for_rank thm_name rank in + let rec first_child_rec = function + [] -> None + | {index=i;is_open=b}::l -> + if b then + (first_child_rec l) + else + Some i in + first_child_rec l;; + +type index_or_rank = Is_index of int | Is_rank of int;; + +let first_child_command_or_goal thm_name rank = + let proof_info = Hashtbl.find theorem_proofs thm_name in + let {sub_proofs=l}=get_tree_for_rank thm_name rank in + match l with + [] -> None + | ({index=i;is_open=b} as t)::_ -> + if b then + let rec get_rank n = function + [] -> failwith "A goal is lost in first_child_command_or_goal" + | a::l -> + if a==t then + n + else + get_rank (n + 1) l in + Some(Is_rank(get_rank 1 proof_info.border)) + else + Some(Is_index i);; + +let next_sibling thm_name rank = + let ({parent=mommy} as t)=get_tree_for_rank thm_name rank in + match mommy with + None -> None + | Some real_mommy -> + let {sub_proofs=l}=real_mommy in + let rec next_sibling_aux b = function + (opt_first, []) -> + if b then + opt_first + else + failwith "inconsistency detected in next_sibling" + | (opt_first, {is_open=true}::l) -> + next_sibling_aux b (opt_first, l) + | (Some(first),({index=i; is_open=false} as t')::l) -> + if b then + Some i + else + next_sibling_aux (t == t') (Some first,l) + | None,({index=i;is_open=false} as t')::l -> + next_sibling_aux (t == t') ((Some i), l) + in + Some (next_sibling_aux false (None, l));; + + +let prefix l1 l2 = + let l1rev = List.rev l1 in + let l2rev = List.rev l2 in + is_prefix l1rev l2rev;; + +let rec remove_all_prefixes p = function + [] -> [] + | a::l -> + if is_prefix p a then + (remove_all_prefixes p l) + else + a::(remove_all_prefixes p l);; + +let recompute_border tree = + let rec recompute_border_aux tree acc = + let {is_open=b;sub_proofs=l}=tree in + if b then + tree::acc + else + List.fold_right recompute_border_aux l acc in + recompute_border_aux tree [];; + + +let historical_undo thm_name rank = + let ({ranks_and_goals=l} as proof_info)= + Hashtbl.find theorem_proofs thm_name in + let rec undo_aux acc = function + [] -> failwith "bad rank provided for undoing in historical_undo" + | (r, n, ({index=i} as tree))::tl -> + let this_path_reversed = List.rev tree.path_to_root in + let res = remove_all_prefixes this_path_reversed acc in + if i = rank then + begin + proof_info.prf_length <- i-1; + proof_info.ranks_and_goals <- tl; + tree.is_open <- true; + tree.sub_proofs <- []; + proof_info.border <- recompute_border proof_info.prf_struct; + this_path_reversed::res + end + else + begin + tree.is_open <- true; + tree.sub_proofs <- []; + undo_aux (this_path_reversed::res) tl + end + in + List.map List.rev (undo_aux [] l);; + +(* The following function takes a list of trees and compute the + number of elements whose path is lexically smaller or a suffixe of + the path given as a first argument. This works under the precondition that + the list is lexicographically order. *) + +let rec logical_undo_on_border the_tree rev_path = function + [] -> (0,[the_tree]) + | ({path_to_root=p}as tree)::tl -> + let p_rev = List.rev p in + if is_prefix rev_path p_rev then + let (k,res) = (logical_undo_on_border the_tree rev_path tl) in + (k+1,res) + else if lex_smaller p_rev rev_path then + let (k,res) = (logical_undo_on_border the_tree rev_path tl) in + (k,tree::res) + else + (0, the_tree::tree::tl);; + + +let logical_undo thm_name rank = + let ({ranks_and_goals=l; border=last_border} as proof_info)= + Hashtbl.find theorem_proofs thm_name in + let ({path_to_root=ref_path} as ref_tree)=get_tree_for_rank thm_name rank in + let rev_ref_path = List.rev ref_path in + let rec logical_aux lex_smaller_offset family_width = function + [] -> failwith "this case should never happen in logical_undo" + | (r,n,({index=i;path_to_root=this_path; sub_proofs=these_goals} as tree)):: + tl -> + let this_path_rev = List.rev this_path in + let new_rank, new_offset, new_width, kept = + if is_prefix rev_ref_path this_path_rev then + (r + lex_smaller_offset), lex_smaller_offset, + (family_width + 1 - n), false + else if lex_smaller this_path_rev rev_ref_path then + r, (lex_smaller_offset - 1 + n), family_width, true + else + (r + 1 - family_width+ lex_smaller_offset), + lex_smaller_offset, family_width, true in + if i=rank then + [i,new_rank],[], tl, rank + else + let ranks_undone, ranks_kept, ranks_and_goals, current_rank = + (logical_aux new_offset new_width tl) in + begin + if kept then + begin + tree.index <- current_rank; + ranks_undone, ((i,new_rank)::ranks_kept), + ((new_rank, n, tree)::ranks_and_goals), + (current_rank + 1) + end + else + ((i,new_rank)::ranks_undone), ranks_kept, + ranks_and_goals, current_rank + end in + let number_suffix, new_border = + logical_undo_on_border ref_tree rev_ref_path last_border in + let changed_ranks_undone, changed_ranks_kept, new_ranks_and_goals, + new_length_plus_one = logical_aux 0 number_suffix l in + let the_goal_index = + let rec compute_goal_index n = function + [] -> failwith "this case should never happen in logical undo (2)" + | {path_to_root=path}::tl -> + if List.rev path = (rev_ref_path) then + n + else + compute_goal_index (n+1) tl in + compute_goal_index 1 new_border in + begin + ref_tree.is_open <- true; + ref_tree.sub_proofs <- []; + proof_info.border <- new_border; + proof_info.ranks_and_goals <- new_ranks_and_goals; + proof_info.prf_length <- new_length_plus_one - 1; + changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, + the_goal_index + end;; + +let start_proof thm_name = + let the_tree = + {index=0;parent=None;path_to_root=[];is_open=true;sub_proofs=[]} in + Hashtbl.add theorem_proofs thm_name + {prf_length=0; + ranks_and_goals=[]; + border=[the_tree]; + prf_struct=the_tree};; + +let dump_sequence chan s = + match (Hashtbl.find theorem_proofs s) with + {ranks_and_goals=l}-> + let rec dump_rec = function + [] -> () + | (r,n,_)::tl -> + dump_rec tl; + output_string chan (string_of_int r); + output_string chan ","; + output_string chan (string_of_int n); + output_string chan "\n" in + begin + dump_rec l; + output_string chan "end\n" + end;; + + +let proof_info_as_string s = + let res = ref "" in + match (Hashtbl.find theorem_proofs s) with + {prf_struct=tree} -> + let open_goal_counter = ref 0 in + let rec dump_rec = function + {index=i;sub_proofs=trees;parent=the_parent;is_open=op} -> + begin + (match the_parent with + None -> + if op then + res := !res ^ "\"open goal\"\n" + | Some {index=j} -> + begin + res := !res ^ (string_of_int j); + res := !res ^ " -> "; + if op then + begin + res := !res ^ "\"open goal "; + open_goal_counter := !open_goal_counter + 1; + res := !res ^ (string_of_int !open_goal_counter); + res := !res ^ "\"\n"; + end + else + begin + res := !res ^ (string_of_int i); + res := !res ^ "\n" + end + end); + List.iter dump_rec trees + end in + dump_rec tree; + !res;; + + +let dump_proof_info chan s = + match (Hashtbl.find theorem_proofs s) with + {prf_struct=tree} -> + let open_goal_counter = ref 0 in + let rec dump_rec = function + {index=i;sub_proofs=trees;parent=the_parent;is_open=op} -> + begin + (match the_parent with + None -> + if op then + output_string chan "\"open goal\"\n" + | Some {index=j} -> + begin + output_string chan (string_of_int j); + output_string chan " -> "; + if op then + begin + output_string chan "\"open goal "; + open_goal_counter := !open_goal_counter + 1; + output_string chan (string_of_int !open_goal_counter); + output_string chan "\"\n"; + end + else + begin + output_string chan (string_of_int i); + output_string chan "\n" + end + end); + List.iter dump_rec trees + end in + dump_rec tree;; + +let get_nth_open_path s n = + match Hashtbl.find theorem_proofs s with + {border=l} -> + let {path_to_root=p}=List.nth l (n - 1) in + p;; + +let border_length s = + match Hashtbl.find theorem_proofs s with + {border=l} -> List.length l;; diff --git a/contrib/interface/history.mli b/contrib/interface/history.mli new file mode 100644 index 00000000..053883f0 --- /dev/null +++ b/contrib/interface/history.mli @@ -0,0 +1,12 @@ +type prf_info;; + +val start_proof : string -> unit;; +val historical_undo : string -> int -> int list list +val logical_undo : string -> int -> (int * int) list * (int * int) list * int * int +val dump_sequence : out_channel -> string -> unit +val proof_info_as_string : string -> string +val dump_proof_info : out_channel -> string -> unit +val push_command : string -> int -> int -> unit +val get_path_for_rank : string -> int -> int list +val get_nth_open_path : string -> int -> int list +val border_length : string -> int diff --git a/contrib/interface/line_parser.ml4 b/contrib/interface/line_parser.ml4 new file mode 100755 index 00000000..b5669351 --- /dev/null +++ b/contrib/interface/line_parser.ml4 @@ -0,0 +1,241 @@ +(* line-oriented Syntactic analyser for a Coq parser *) +(* This parser expects a very small number of commands, each given on a complete +line. Some of these commands are then followed by a text fragment terminated +by a precise keyword, which is also expected to appear alone on a line. *) + +(* The main parsing loop procedure is "parser_loop", given at the end of this +file. It read lines one by one and checks whether they can be parsed using +a very simple parser. This very simple parser uses a lexer, which is also given +in this file. + +The lexical analyser: + There are only 5 sorts of tokens *) +type simple_tokens = Tspace | Tid of string | Tint of int | Tstring of string | + Tlbracket | Trbracket;; + +(* When recognizing identifiers or strings, the lexical analyser accumulates + the characters in a buffer, using the command add_in_buff. To recuperate + the characters, one can use get_buff (this code was inspired by the + code in src/meta/lexer.ml of Coq revision 6.1) *) +let add_in_buff,get_buff = + let buff = ref (String.create 80) in + (fun i x -> + let len = String.length !buff in + if i >= len then (buff := !buff ^ (String.create len);()); + String.set !buff i x; + succ i), + (fun len -> String.sub !buff 0 len);; + +(* Identifiers are [a-zA-Z_][.a-zA-Z0-9_]*. When arriving here the first + character has already been recognized. *) +let rec ident len = parser + [<''_' | '.' | 'a'..'z' | 'A'..'Z' | '0'..'9' as c; s >] -> + ident (add_in_buff len c) s +| [< >] -> let str = get_buff len in Tid(str);; + +(* While recognizing integers, one constructs directly the integer value. + The ascii code of '0' is important for this. *) +let code0 = Char.code '0';; + +let get_digit c = Char.code c - code0;; + +(* Integers are [0-9]* + The variable intval is the integer value of the text that has already + been recognized. As for identifiers, the first character has already been + recognized. *) + +let rec parse_int intval = parser + [< ''0'..'9' as c ; i=parse_int (10 * intval + get_digit c)>] -> i +| [< >] -> Tint intval;; + +(* The string lexer is borrowed from the string parser of Coq V6.1 + This may be a problem if convention have changed in Coq, + However this parser is only used to recognize file names which should + not contain too many special characters *) + +let rec spec_char = parser + [< ''n' >] -> '\n' +| [< ''t' >] -> '\t' +| [< ''b' >] -> '\008' +| [< ''r' >] -> '\013' +| [< ''0'..'9' as c; v= (spec1 (get_digit c)) >] -> + Char.chr v +| [< 'x >] -> x + +and spec1 v = parser + [< ''0'..'9' as c; s >] -> spec1 (10*v+(get_digit c)) s +| [< >] -> v +;; + +(* This is the actual string lexical analyser. Strings are + QUOT([^QUOT\\]|\\[0-9]*|\\[^0-9])QUOT (the word QUOT is used + to represents double quotation characters, that cannot be used + freely, even inside comments. *) + +let rec string len = parser + [< ''"' >] -> len +| [<''\\' ; + len = (parser [< ''\n' >] -> len + | [< c=spec_char >] -> add_in_buff len c); + s >] -> string len s +| [< 'x; s >] -> string (add_in_buff len x) s;; + +(* The lexical analyser repeats the recognized given by next_token: + spaces and tabulations are ignored, identifiers, integers, + strings, opening and closing square brackets. Lexical errors are + ignored ! *) +let rec next_token = parser count + [< '' ' | '\t'; tok = next_token >] -> tok +| [< ''_' | 'a'..'z' | 'A'..'Z' as c;i = (ident (add_in_buff 0 c))>] -> i +| [< ''0'..'9' as c ; i = (parse_int (get_digit c))>] -> i +| [< ''"' ; len = (string 0) >] -> Tstring (get_buff len) +| [< ''[' >] -> Tlbracket +| [< '']' >] -> Trbracket +| [< '_ ; x = next_token >] -> x;; + +(* A very simple lexical analyser to recognize a integer value behind + blank characters *) + +let rec next_int = parser count + [< '' ' | '\t'; v = next_int >] -> v +| [< ''0'..'9' as c; i = (parse_int (get_digit c))>] -> + (match i with + Tint n -> n + | _ -> failwith "unexpected branch in next_int");; + +(* This is the actual lexical analyser, implemented as a function on a stream. + It will be used with the Stream.from primitive to construct a function + of type char Stream.t -> simple_token option Stream.t *) +let token_stream cs _ = + try let tok = next_token cs in + Some tok + with Stream.Failure -> None;; + +(* Two of the actions of the parser request that one reads the rest of + the input up to a specific string stop_string. This is done + with a function that transform the input_channel into a pair of + char Stream.t, reading from the input_channel all the lines to + the stop_string first. *) + + +let rec gather_strings stop_string input_channel = + let buff = input_line input_channel in + if buff = stop_string then + [] + else + (buff::(gather_strings stop_string input_channel));; + + +(* the result of this function is supposed to be used in a Stream.from + construction. *) + +let line_list_to_stream string_list = + let count = ref 0 in + let buff = ref "" in + let reserve = ref string_list in + let current_length = ref 0 in + (fun i -> if (i - !count) >= !current_length then + begin + count := !count + !current_length + 1; + match !reserve with + | [] -> None + | s1::rest -> + begin + buff := s1; + current_length := String.length !buff; + reserve := rest; + Some '\n' + end + end + else + Some(String.get !buff (i - !count)));; + + +(* In older revisions of this file you would find a function that + does line oriented breakdown of the input channel without resorting to + a list of lines. However, the need for the list of line appeared when + we wanted to have a channel and a list of strings describing the same + data, one for regular parsing and the other for error recovery. *) + +let channel_to_stream_and_string_list stop_string input_channel = + let string_list = gather_strings stop_string input_channel in + (line_list_to_stream string_list, string_list);; + +let flush_until_end_of_stream char_stream = + Stream.iter (function _ -> ()) char_stream;; + +(* There are only 5 kinds of lines recognized by our little parser. + Unrecognized lines are ignored. *) +type parser_request = + | PRINT_VERSION + | PARSE_STRING of string + (* parse_string <int> [<ident>] then text and && END--OF--DATA *) + | QUIET_PARSE_STRING + (* quiet_parse_string then text and && END--OF--DATA *) + | PARSE_FILE of string + (* parse_file <int> <string> *) + | ADD_PATH of string + (* add_path <int> <string> *) + | ADD_REC_PATH of string * string + (* add_rec_path <int> <string> <ident> *) + | LOAD_SYNTAX of string + (* load_syntax_file <int> <ident> *) + | GARBAGE +;; + +(* The procedure parser_loop should never terminate while the input_channel is + not closed. This procedure receives the functions called for each sentence + as arguments. Thus the code is completely independent from the Coq sources. *) +let parser_loop functions input_channel = + let print_version_action, + parse_string_action, + quiet_parse_string_action, + parse_file_action, + add_path_action, + add_rec_path_action, + load_syntax_action = functions in + let rec parser_loop_rec input_channel = + (let line = input_line input_channel in + let reqid, parser_request = + try + (match Stream.from (token_stream (Stream.of_string line)) with + parser + | [< 'Tid "print_version" >] -> + 0, PRINT_VERSION + | [< 'Tid "parse_string" ; 'Tint reqid ; 'Tlbracket ; + 'Tid phylum ; 'Trbracket >] + -> reqid,PARSE_STRING phylum + | [< 'Tid "quiet_parse_string" >] -> + 0,QUIET_PARSE_STRING + | [< 'Tid "parse_file" ; 'Tint reqid ; 'Tstring fname >] -> + reqid, PARSE_FILE fname + | [< 'Tid "add_rec_path"; 'Tint reqid ; 'Tstring directory ; 'Tid alias >] + -> reqid, ADD_REC_PATH(directory, alias) + | [< 'Tid "add_path"; 'Tint reqid ; 'Tstring directory >] + -> reqid, ADD_PATH directory + | [< 'Tid "load_syntax_file"; 'Tint reqid; 'Tid module_name >] -> + reqid, LOAD_SYNTAX module_name + | [< 'Tid "quit_parser" >] -> raise End_of_file + | [< >] -> 0, GARBAGE) + with + Stream.Failure | Stream.Error _ -> 0,GARBAGE in + match parser_request with + PRINT_VERSION -> print_version_action () + | PARSE_STRING phylum -> + let regular_stream, string_list = + channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in + parse_string_action reqid phylum (Stream.from regular_stream) + string_list;() + | QUIET_PARSE_STRING -> + let regular_stream, string_list = + channel_to_stream_and_string_list "&& END--OF--DATA" input_channel in + quiet_parse_string_action + (Stream.from regular_stream);() + | PARSE_FILE file_name -> + parse_file_action reqid file_name + | ADD_PATH path -> add_path_action reqid path + | ADD_REC_PATH(path, alias) -> add_rec_path_action reqid path alias + | LOAD_SYNTAX syn -> load_syntax_action reqid syn + | GARBAGE -> ()); + parser_loop_rec input_channel in + parser_loop_rec input_channel;; diff --git a/contrib/interface/line_parser.mli b/contrib/interface/line_parser.mli new file mode 100644 index 00000000..b0b043c7 --- /dev/null +++ b/contrib/interface/line_parser.mli @@ -0,0 +1,5 @@ +val parser_loop : + (unit -> unit) * (int -> string -> char Stream.t -> string list -> 'a) * + (char Stream.t -> 'b) * (int -> string -> unit) * (int -> string -> unit) * + (int -> string -> string -> unit) * (int -> string -> unit) -> in_channel -> 'c +val flush_until_end_of_stream : 'a Stream.t -> unit diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml new file mode 100644 index 00000000..eaff0968 --- /dev/null +++ b/contrib/interface/name_to_ast.ml @@ -0,0 +1,252 @@ +open Sign;; +open Classops;; +open Names;; +open Nameops +open Coqast;; +open Ast;; +open Termast;; +open Term;; +open Impargs;; +open Reduction;; +open Libnames;; +open Libobject;; +open Environ;; +open Declarations;; +open Prettyp;; +open Inductive;; +open Util;; +open Pp;; +open Declare;; +open Nametab +open Vernacexpr;; +open Decl_kinds;; +open Constrextern;; +open Topconstr;; + +(* This function converts the parameter binders of an inductive definition, + in particular you have to be careful to handle each element in the + context containing all previously defined variables. This squeleton + of this procedure is taken from the function print_env in pretty.ml *) +let convert_env = + let convert_binder env (na, b, c) = + match b with + | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b) + | None -> LocalRawAssum ([dummy_loc,na], extern_constr true env c) in + let rec cvrec env = function + [] -> [] + | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in + cvrec (Global.env());; + +(* let mib string = + let sp = Nametab.sp_of_id CCI (id_of_string string) in + let lobj = Lib.map_leaf (objsp_of sp) in + let (cmap, _) = outMutualInductive lobj in + Listmap.map cmap CCI;; *) + +(* This function is directly inspired by print_impl_args in pretty.ml *) + +let impl_args_to_string_by_pos = function + [] -> None + | [i] -> Some(" position " ^ (string_of_int i) ^ " is implicit.") + | l -> Some (" positions " ^ + (List.fold_right (fun i s -> (string_of_int i) ^ " " ^ s) + l + " are implicit."));; + +(* This function is directly inspired by implicit_args_id in pretty.ml *) + +let impl_args_to_string l = + impl_args_to_string_by_pos (positions_of_implicits l) + +let implicit_args_id_to_ast_list id l ast_list = + (match impl_args_to_string l with + None -> ast_list + | Some(s) -> CommentString s:: + CommentString ("For " ^ (string_of_id id)):: + ast_list);; + +(* This function construct an ast to enumerate the implicit positions for an + inductive type and its constructors. It is obtained directly from + implicit_args_msg in pretty.ml. *) + +let implicit_args_to_ast_list sp mipv = + let implicit_args_descriptions = + let ast_list = ref [] in + (Array.iteri + (fun i mip -> + let imps = implicits_of_global (IndRef (sp, i)) in + (ast_list := + implicit_args_id_to_ast_list mip.mind_typename imps !ast_list; + Array.iteri + (fun j idc -> + let impls = implicits_of_global + (ConstructRef ((sp,i),j+1)) in + ast_list := + implicit_args_id_to_ast_list idc impls !ast_list) + mip.mind_consnames)) + mipv; + !ast_list) in + match implicit_args_descriptions with + [] -> [] + | _ -> [VernacComments (List.rev implicit_args_descriptions)];; + +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 *) + +let convert_constructors envpar names types = + let array_idC = + array_map2 + (fun n t -> + let coercion_flag = false (* arbitrary *) in + (coercion_flag, ((dummy_loc,n), extern_constr true envpar t))) + names types in + Array.to_list array_idC;; + +(* this function converts one inductive type in a possibly multiple inductive + definition *) + +let convert_one_inductive sp tyi = + let (ref, params, arity, cstrnames, cstrtypes) = build_inductive sp tyi in + let env = Global.env () in + let envpar = push_rel_context params env in + let sp = sp_of_global (IndRef (sp, tyi)) in + ((dummy_loc,basename sp), None, + convert_env(List.rev params), + (extern_constr true envpar arity), + convert_constructors envpar cstrnames cstrtypes);; + +(* This function converts a Mutual inductive definition to a Coqast.t. + It is obtained directly from print_mutual in pretty.ml. However, all + references to kinds have been removed and it treats only CCI stuff. *) + +let mutual_to_ast_list sp mib = + let mipv = (Global.lookup_mind sp).mind_packets in + let _, l = + Array.fold_right + (fun mi (n,l) -> (n+1, (convert_one_inductive sp n)::l)) mipv (0, []) in + VernacInductive (mib.mind_finite, l) + :: (implicit_args_to_ast_list sp mipv);; + +let constr_to_ast v = + extern_constr true (Global.env()) v;; + +let implicits_to_ast_list implicits = + match (impl_args_to_string implicits) with + | None -> [] + | Some s -> [VernacComments [CommentString s]];; + +(* +let make_variable_ast name typ implicits = + (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), + [false,([dummy_loc,name], constr_to_ast (body_of_type typ))])) + ::(implicits_to_ast_list implicits);; + + +let make_definition_ast name c typ implicits = + VernacDefinition ((Global,Definition), (dummy_loc,name), DefineBody ([], None, + (constr_to_ast c), Some (constr_to_ast (body_of_type typ))), + (fun _ _ -> ())) + ::(implicits_to_ast_list implicits);; + +(* This function is inspired by print_constant *) +let constant_to_ast_list kn = + let cb = Global.lookup_constant kn in + let c = cb.const_body in + let typ = cb.const_type in + let l = implicits_of_global (ConstRef kn) in + (match c with + None -> + make_variable_ast (id_of_label (label kn)) typ l + | Some c1 -> + make_definition_ast (id_of_label (label kn)) (Declarations.force c1) typ l) + +let variable_to_ast_list sp = + let (id, c, v) = get_variable sp in + let l = implicits_of_global (VarRef sp) in + (match c with + None -> + make_variable_ast id v l + | Some c1 -> + make_definition_ast id c1 v l);; + +(* this function is taken from print_inductive in file pretty.ml *) + +let inductive_to_ast_list sp = + let mib = Global.lookup_mind sp in + mutual_to_ast_list sp mib + +(* this function is inspired by print_leaf_entry from pretty.ml *) + +let leaf_entry_to_ast_list ((sp,kn),lobj) = + let tag = object_tag lobj in + match tag with + | "VARIABLE" -> variable_to_ast_list (basename sp) + | "CONSTANT" -> constant_to_ast_list kn + | "INDUCTIVE" -> inductive_to_ast_list kn + | s -> + errorlabstrm + "print" (str ("printing of unrecognized object " ^ + s ^ " has been required"));; + + + + +(* this function is inspired by print_name *) +let name_to_ast ref = + let (loc,qid) = qualid_of_reference ref in + let l = + try + let sp = Nametab.locate_obj qid in + let (sp,lobj) = + let (sp,entry) = + List.find (fun en -> (fst (fst en)) = sp) (Lib.contents_after None) + in + match entry with + | Lib.Leaf obj -> (sp,obj) + | _ -> raise Not_found + in + leaf_entry_to_ast_list (sp,lobj) + with Not_found -> + try + match Nametab.locate qid with + | ConstRef sp -> constant_to_ast_list sp + | IndRef (sp,_) -> inductive_to_ast_list sp + | ConstructRef ((sp,_),_) -> inductive_to_ast_list sp + | VarRef sp -> variable_to_ast_list sp + with Not_found -> + try (* Var locale de but, pas var de section... donc pas d'implicits *) + let dir,name = repr_qualid qid in + if (repr_dirpath dir) <> [] then raise Not_found; + let (_,c,typ) = Global.lookup_named name in + (match c with + None -> make_variable_ast name typ [] + | Some c1 -> make_definition_ast name c1 typ []) + with Not_found -> + try + let sp = Nametab.locate_syntactic_definition qid in + errorlabstrm "print" + (str "printing of syntax definitions not implemented") + with Not_found -> + errorlabstrm "print" + (pr_qualid qid ++ + spc () ++ str "not a defined object") + in + VernacList (List.map (fun x -> (dummy_loc,x)) l) + diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli new file mode 100644 index 00000000..0eca0a1e --- /dev/null +++ b/contrib/interface/name_to_ast.mli @@ -0,0 +1,2 @@ +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 new file mode 100644 index 00000000..3f0b2d2e --- /dev/null +++ b/contrib/interface/parse.ml @@ -0,0 +1,488 @@ +open Util;; +open System;; +open Pp;; +open Libnames;; +open Library;; +open Ascent;; +open Vtp;; +open Xlate;; +open Line_parser;; +open Pcoq;; +open Vernacexpr;; +open Mltop;; + +type parsed_tree = + | P_cl of ct_COMMAND_LIST + | P_c of ct_COMMAND + | P_t of ct_TACTIC_COM + | P_f of ct_FORMULA + | P_id of ct_ID + | P_s of ct_STRING + | P_i of ct_INT;; + +let print_parse_results n msg = + print_string "message\nparsed\n"; + print_int n; + print_string "\n"; + (match msg with + | P_cl x -> fCOMMAND_LIST x + | P_c x -> fCOMMAND x + | P_t x -> fTACTIC_COM x + | P_f x -> fFORMULA x + | P_id x -> fID x + | P_s x -> fSTRING x + | P_i x -> fINT x); + print_string "e\nblabla\n"; + flush stdout;; + +let ctf_SyntaxErrorMessage reqid pps = + fnl () ++ str "message" ++ fnl () ++ str "syntax_error" ++ fnl () ++ + int reqid ++ fnl () ++ + pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; +let ctf_SyntaxWarningMessage reqid pps = + fnl () ++ str "message" ++ fnl () ++ str "syntax_warning" ++ fnl () ++ + int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl();; + +let ctf_FileErrorMessage reqid pps = + fnl () ++ str "message" ++ fnl () ++ str "file_error" ++ fnl () ++ + int reqid ++ fnl () ++ pps ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ + fnl ();; + +(* +(*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 + Vernacentries.interp v + with _ -> + let l=prlist_with_sep spc pr_reference l in + msgnl (str "Reinterning of " ++ l ++ str " failed")) + | VernacRequireFrom (_,_,f) -> + (try + Vernacentries.interp v + with _ -> + msgnl (str "Reinterning of " ++ Util.pr_str f ++ str " failed")) + | _ -> ()); v;; + +let parse_to_dot = + let rec dot st = match Stream.next st with + | ("", ".") -> () + | ("EOI", "") -> raise End_of_file + | _ -> dot st in + Gram.Entry.of_parser "Coqtoplevel.dot" dot;; + +let rec discard_to_dot stream = + try Gram.Entry.parse parse_to_dot (Gram.parsable stream) with + | Stdpp.Exc_located(_, Token.Error _) -> discard_to_dot stream;; + +let rec decompose_string_aux s n = + try let index = String.index_from s n '\n' in + (String.sub s n (index - n)):: + (decompose_string_aux s (index + 1)) + with Not_found -> [String.sub s n ((String.length s) - n)];; + +let decompose_string s n = + match decompose_string_aux s n with + ""::tl -> tl + | a -> a;; + +let make_string_list file_chan fst_pos snd_pos = + let len = (snd_pos - fst_pos) in + let s = String.create len in + begin + seek_in file_chan fst_pos; + really_input file_chan s 0 len; + decompose_string s 0; + end;; + +let rec get_sub_aux string_list snd_pos = + match string_list with + [] -> [] + | s::l -> + let len = String.length s in + if len >= snd_pos then + if snd_pos < 0 then + [] + else + [String.sub s 0 snd_pos] + else + s::(get_sub_aux l (snd_pos - len - 1));; + +let rec get_substring_list string_list fst_pos snd_pos = + match string_list with + [] -> [] + | s::l -> + let len = String.length s in + if fst_pos > len then + get_substring_list l (fst_pos - len - 1) (snd_pos - len - 1) + else + (* take into account the fact that carriage returns are not in the *) + (* strings. *) + let fst_pos2 = if fst_pos = 0 then 1 else fst_pos in + if snd_pos > len then + String.sub s (fst_pos2 - 1) (len + 1 - fst_pos2):: + (get_sub_aux l (snd_pos - len - 2)) + else + let gap = (snd_pos - fst_pos2) in + if gap < 0 then + [] + else + [String.sub s (fst_pos2 - 1) gap];; + +(* When parsing a list of commands, we try to recover error messages for + each individual command. *) + +type parse_result = + | ParseOK of Vernacexpr.vernac_expr located option + | ParseError of string * string list + +let embed_string s = + CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT (CT_string s)) + +let make_parse_error_item s l = + CT_user_vernac (CT_ident s, CT_varg_list (List.map embed_string l)) + +let parse_command_list reqid stream string_list = + let rec parse_whole_stream () = + let this_pos = Stream.count stream in + let first_ast = + try ParseOK (Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) + with + | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> + begin + msgnl (ctf_SyntaxWarningMessage reqid (Cerrors.explain_exn e)); + try + discard_to_dot stream; + msgnl (str "debug" ++ fnl () ++ int this_pos ++ fnl () ++ + int (Stream.count stream)); +(* + 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)) + with End_of_file -> ParseOK None + end + | 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 + (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() + | ParseOK None -> [] + | ParseError (s,l) -> + (make_parse_error_item s l)::parse_whole_stream() + in + match parse_whole_stream () with + | first_one::tail -> (P_cl (CT_command_list(first_one, tail))) + | [] -> raise (UserError ("parse_string", (str "empty text.")));; + +(*When parsing a string using a phylum, the string is first transformed + into a Coq Ast using the regular Coq parser, then it is transformed into + the right ascent term using xlate functions, then it is transformed into + a stream, using the right vtp function. There is a special case for commands, + since some of these must be executed!*) +let parse_string_action reqid phylum char_stream string_list = + try let msg = + match phylum with + | "COMMAND_LIST" -> + parse_command_list reqid char_stream string_list + | "COMMAND" -> + P_c + (xlate_vernac + (execute_when_necessary + (Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream)))) + | "TACTIC_COM" -> + P_t + (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi + (Gram.parsable char_stream))) + | "FORMULA" -> + P_f + (xlate_formula + (Gram.Entry.parse + (Pcoq.eoi_entry Pcoq.Constr.lconstr) (Gram.parsable char_stream))) + | "ID" -> P_id (CT_ident + (Libnames.string_of_qualid + (snd + (Gram.Entry.parse (Pcoq.eoi_entry Pcoq.Prim.qualid) + (Gram.parsable char_stream))))) + | "STRING" -> + P_s + (CT_string (Gram.Entry.parse Pcoq.Prim.string + (Gram.parsable char_stream))) + | "INT" -> + P_i (CT_int (Gram.Entry.parse Pcoq.Prim.natural + (Gram.parsable char_stream))) + | _ -> error "parse_string_action : bad phylum" in + print_parse_results reqid msg + with + | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> + flush_until_end_of_stream char_stream; + msgnl (ctf_SyntaxErrorMessage reqid + (Cerrors.explain_exn + (Stdpp.Exc_located(l,Stream.Error "match failure")))) + | e -> + flush_until_end_of_stream char_stream; + msgnl (ctf_SyntaxErrorMessage reqid (Cerrors.explain_exn e));; + + +let quiet_parse_string_action char_stream = + try let _ = + Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream) in + () + with + | _ -> flush_until_end_of_stream char_stream; ();; + + +let parse_file_action reqid file_name = + try let file_chan = open_in file_name in + (* file_chan_err, stream_err are the channel and stream used to + get the text when a syntax error occurs *) + let file_chan_err = open_in file_name in + let stream = Stream.of_channel file_chan in + let stream_err = Stream.of_channel file_chan_err in + let rec discard_to_dot () = + try Gram.Entry.parse parse_to_dot (Gram.parsable stream) + with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in + match let rec parse_whole_file () = + let this_pos = Stream.count stream in + match + try + ParseOK(Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) + with + | Stdpp.Exc_located(l,Stream.Error txt) -> + msgnl (ctf_SyntaxWarningMessage reqid + (str "Error with file" ++ spc () ++ + str file_name ++ fnl () ++ + Cerrors.explain_exn + (Stdpp.Exc_located(l,Stream.Error txt)))); + (try + begin + discard_to_dot (); + ParseError ("PARSING_ERROR", + (make_string_list file_chan_err this_pos + (Stream.count stream))) + end + with End_of_file -> ParseOK None) + | e -> + begin + Gram.Entry.parse parse_to_dot (Gram.parsable stream); + ParseError ("PARSING_ERROR2", + (make_string_list file_chan this_pos + (Stream.count stream))) + end + + with + | ParseOK (Some (_,ast)) -> + let ast0=(execute_when_necessary ast) in + let term = + (try xlate_vernac ast + with e -> + print_string ("translation error between " ^ + (string_of_int this_pos) ^ + " " ^ + (string_of_int (Stream.count stream)) ^ + "\n"); + make_parse_error_item "PARSING_ERROR2" + (make_string_list file_chan_err this_pos + (Stream.count stream))) in + term::parse_whole_file () + | ParseOK None -> [] + | ParseError (s,l) -> + (make_parse_error_item s l)::parse_whole_file () in + parse_whole_file () with + | first_one :: tail -> + print_parse_results reqid + (P_cl (CT_command_list (first_one, tail))) + | [] -> raise (UserError ("parse_file_action", str "empty file.")) + with + | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> + msgnl + (ctf_SyntaxErrorMessage reqid + (str "Error with file" ++ spc () ++ str file_name ++ + fnl () ++ + Cerrors.explain_exn + (Stdpp.Exc_located(l,Stream.Error "match failure")))) + | e -> + msgnl + (ctf_SyntaxErrorMessage reqid + (str "Error with file" ++ spc () ++ str file_name ++ + fnl () ++ Cerrors.explain_exn e));; + +let add_rec_path_action reqid string_arg ident_arg = + let directory_name = glob string_arg in + begin + add_rec_path directory_name (Libnames.dirpath_of_string ident_arg) + end;; + + +let add_path_action reqid string_arg = + let directory_name = glob string_arg in + begin + add_path directory_name Names.empty_dirpath + end;; + +let print_version_action () = + msgnl (mt ()); + msgnl (str "$Id: parse.ml,v 1.22 2004/04/21 08:36:58 barras Exp $");; + +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); + msg (str "opening... "); + Declaremods.import_module false (Nametab.locate_module qid); + msgnl (str "done" ++ fnl ()); + ()) + with + | UserError (label, pp_stream) -> + (*This one may be necessary to make sure that the message won't be indented *) + msgnl (mt ()); + msgnl + (fnl () ++ str "error while loading syntax module " ++ str module_name ++ + str ": " ++ str label ++ fnl () ++ pp_stream) + | e -> + msgnl (mt ()); + msgnl + (fnl () ++ str "message" ++ fnl () ++ str "load_error" ++ fnl () ++ + int reqid ++ fnl ()); + ();; + +let coqparser_loop inchan = + (parser_loop : (unit -> unit) * + (int -> string -> char Stream.t -> string list -> unit) * + (char Stream.t -> unit) * (int -> string -> unit) * + (int -> string -> unit) * (int -> string -> string -> unit) * + (int -> string -> unit) -> in_channel -> unit) + (print_version_action, parse_string_action, quiet_parse_string_action, parse_file_action, + add_path_action, add_rec_path_action, load_syntax_action) inchan;; + +if !Sys.interactive then () + else +Libobject.relax true; +(let coqdir = + try Sys.getenv "COQDIR" + with Not_found -> + let coqdir = Coq_config.coqlib in + if Sys.file_exists coqdir then + coqdir + else + (msgnl (str "could not find the value of COQDIR"); exit 1) in + begin + add_rec_path (Filename.concat coqdir "theories") + (Names.make_dirpath [Nameops.coq_root]); + add_rec_path (Filename.concat coqdir "contrib") + (Names.make_dirpath [Nameops.coq_root]) + end; +(let vernacrc = + try + Sys.getenv "VERNACRC" + with + Not_found -> + List.fold_left + (fun s1 s2 -> (Filename.concat s1 s2)) + coqdir [ "contrib"; "interface"; "vernacrc"] in + try + (Gramext.warning_verbose := false; + Esyntax.warning_verbose := false; + coqparser_loop (open_in vernacrc)) + with + | End_of_file -> () + | e -> + (msgnl (Cerrors.explain_exn e); + msgnl (str "could not load the VERNACRC file")); + try + msgnl (str vernacrc) + with + e -> ()); +(try let user_vernacrc = + try Some(Sys.getenv "USERVERNACRC") + with + | Not_found as e -> + msgnl (str "no .vernacrc file"); None in + (match user_vernacrc with + Some f -> coqparser_loop (open_in f) + | None -> ()) + with + | End_of_file -> () + | e -> + msgnl (Cerrors.explain_exn e); + msgnl (str "error in your .vernacrc file")); +msgnl (str "Starting Centaur Specialized Parser Loop"); +try + coqparser_loop stdin +with + | End_of_file -> () + | e -> msgnl(Cerrors.explain_exn e)) diff --git a/contrib/interface/paths.ml b/contrib/interface/paths.ml new file mode 100644 index 00000000..b1244d15 --- /dev/null +++ b/contrib/interface/paths.ml @@ -0,0 +1,26 @@ +let int_list_to_string s l = + List.fold_left + (fun s -> (fun v -> s ^ " " ^ (string_of_int v))) + s + l;; + +(* Given two paths, this function returns the longest common prefix and the + two suffixes. *) +let rec decompose_path + : (int list * int list) -> (int list * int list * int list) = + function + (a::l,b::m) when a = b -> + let (c,p1,p2) = decompose_path (l,m) in + (a::c,p1,p2) + | p1,p2 -> [], p1, p2;; + +let rec is_prefix p1 p2 = match p1,p2 with + [], _ -> true +| a::tl1, b::tl2 when a = b -> is_prefix tl1 tl2 +| _ -> false;; + +let rec lex_smaller p1 p2 = match p1,p2 with + [], _ -> true +| a::tl1, b::tl2 when a < b -> true +| a::tl1, b::tl2 when a = b -> lex_smaller tl1 tl2 +| _ -> false;;
\ No newline at end of file diff --git a/contrib/interface/paths.mli b/contrib/interface/paths.mli new file mode 100644 index 00000000..26620723 --- /dev/null +++ b/contrib/interface/paths.mli @@ -0,0 +1,4 @@ +val decompose_path : (int list * int list) -> (int list * int list * int list);; +val int_list_to_string : string -> int list -> string;; +val is_prefix : int list -> int list -> bool;; +val lex_smaller : int list -> int list -> bool;; diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml new file mode 100644 index 00000000..e0f88ba6 --- /dev/null +++ b/contrib/interface/pbp.ml @@ -0,0 +1,758 @@ +(* A proof by pointing algorithm. *) +open Util;; +open Names;; +open Term;; +open Tactics;; +open Tacticals;; +open Hipattern;; +open Pattern;; +open Matching;; +open Reduction;; +open Rawterm;; +open Environ;; + +open Proof_trees;; +open Proof_type;; +open Tacmach;; +open Tacexpr;; +open Typing;; +open Pp;; +open Libnames;; +open Genarg;; +open Topconstr;; +open Termops;; + +let zz = Util.dummy_loc;; + +let hyp_radix = id_of_string "H";; + +let next_global_ident = next_global_ident_away true + +(* get_hyp_by_name : goal sigma -> string -> constr, + looks up for an hypothesis (or a global constant), from its name *) +let get_hyp_by_name g name = + let evd = project g in + let env = pf_env g in + try (let judgment = + Pretyping.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))) +;; + +type pbp_atom = + | PbpTryAssumption of identifier option + | PbpTryClear of identifier list + | PbpGeneralize of identifier * identifier list + | PbpLApply of identifier (* = CutAndApply *) + | PbpIntros of intro_pattern_expr list + | PbpSplit + (* Existential *) + | PbpExists of identifier + (* Or *) + | PbpLeft + | PbpRight + (* Head *) + | PbpApply of identifier + | PbpElim of identifier * identifier list;; + +(* Invariant: In PbpThens ([a1;...;an],[t1;...;tp]), all tactics + [a1]..[an-1] are atomic (or try of an atomic) tactic and produce + exactly one goal, and [an] produces exactly p subgoals + + In [PbpThen [a1;..an]], all tactics are (try of) atomic tactics and + produces exactly one subgoal, except the last one which may complete the + goal + + Convention: [PbpThen []] is Idtac and [PbpThen t] is a coercion + from atomic to composed tactic +*) + +type pbp_sequence = + | PbpThens of pbp_atom list * pbp_sequence list + | PbpThen of pbp_atom list + +(* This flattens sequences of tactics producing just one subgoal *) +let chain_tactics tl1 = function + | PbpThens (tl2, tl3) -> PbpThens (tl1@tl2, tl3) + | PbpThen tl2 -> PbpThen (tl1@tl2) + +type pbp_rule = (identifier list * + identifier list * + bool * + identifier option * + (types, constr) kind_of_term * + int list * + (identifier list -> + identifier list -> + bool -> + identifier option -> (types, constr) kind_of_term -> int list -> pbp_sequence)) -> + pbp_sequence option;; + + +let make_named_intro id = PbpIntros [IntroIdentifier id];; + +let make_clears str_list = PbpThen [PbpTryClear str_list] + +let add_clear_names_if_necessary tactic clear_names = + match clear_names with + [] -> tactic + | l -> chain_tactics [PbpTryClear l] tactic;; + +let make_final_cmd f optname clear_names constr path = + add_clear_names_if_necessary (f optname constr path) clear_names;; + +let (rem_cast:pbp_rule) = function + (a,c,cf,o, Cast(f,_), p, func) -> + Some(func a c cf o (kind_of_term f) p) + | _ -> None;; + +let (forall_intro: pbp_rule) = function + (avoid, + clear_names, + clear_flag, + None, + Prod(Name x, _, body), + (2::path), + f) -> + let x' = next_global_ident x avoid in + Some(chain_tactics [make_named_intro x'] + (f (x'::avoid) + clear_names clear_flag None (kind_of_term body) path)) +| _ -> None;; + +let (imply_intro2: pbp_rule) = function + avoid, clear_names, + clear_flag, None, Prod(Anonymous, _, body), 2::path, f -> + let h' = next_global_ident hyp_radix avoid in + Some(chain_tactics [make_named_intro h'] + (f (h'::avoid) clear_names clear_flag None (kind_of_term body) path)) + | _ -> None;; + + +(* +let (imply_intro1: pbp_rule) = function + avoid, clear_names, + clear_flag, None, Prod(Anonymous, prem, body), 1::path, f -> + let h' = next_global_ident hyp_radix avoid in + let str_h' = h' in + Some(chain_tactics [make_named_intro str_h'] + (f (h'::avoid) clear_names clear_flag (Some str_h') + (kind_of_term prem) path)) + | _ -> None;; +*) + +let make_var id = CRef (Ident(zz, id)) + +let make_app f l = CApp (zz,(None,f),List.map (fun x -> (x,None)) l) + +let make_pbp_pattern x = + make_app (make_var (id_of_string "PBP_META")) + [make_var (id_of_string ("Value_for_" ^ (string_of_id x)))] + +let rec make_then = function + | [] -> TacId "" + | [t] -> t + | t1::t2::l -> make_then (TacThen (t1,t2)::l) + +let make_pbp_atomic_tactic = function + | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption)) + | PbpTryAssumption (Some a) -> + TacTry (TacAtom (zz, TacExact (make_var a))) + | PbpExists x -> + TacAtom (zz, TacSplit (true,ImplicitBindings [make_pbp_pattern x])) + | PbpGeneralize (h,args) -> + let l = List.map make_pbp_pattern args in + TacAtom (zz, TacGeneralize [make_app (make_var h) l]) + | PbpLeft -> TacAtom (zz, TacLeft NoBindings) + | PbpRight -> TacAtom (zz, TacRight NoBindings) + | PbpIntros l -> TacAtom (zz, TacIntroPattern l) + | PbpLApply h -> TacAtom (zz, TacLApply (make_var h)) + | PbpApply h -> TacAtom (zz, TacApply (make_var h,NoBindings)) + | PbpElim (hyp_name, names) -> + let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in + TacAtom + (zz, TacElim ((make_var hyp_name,ExplicitBindings bind),None)) + | PbpTryClear l -> + TacTry (TacAtom (zz, TacClear (List.map (fun s -> AI (zz,s)) l))) + | PbpSplit -> TacAtom (zz, TacSplit (false,NoBindings));; + +let rec make_pbp_tactic = function + | PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl) + | PbpThens (l,tl) -> + TacThens + (make_then (List.map make_pbp_atomic_tactic l), + List.map make_pbp_tactic tl) + +let (forall_elim: pbp_rule) = function + avoid, clear_names, clear_flag, + Some h, Prod(Name x, _, body), 2::path, f -> + let h' = next_global_ident hyp_radix avoid in + let clear_names' = if clear_flag then h::clear_names else clear_names in + Some + (chain_tactics [PbpGeneralize (h,[x]); make_named_intro h'] + (f (h'::avoid) clear_names' true (Some h') (kind_of_term body) path)) + | _ -> None;; + + +let (imply_elim1: pbp_rule) = function + avoid, clear_names, clear_flag, + Some h, Prod(Anonymous, prem, body), 1::path, f -> + let clear_names' = if clear_flag then h::clear_names else clear_names in + let h' = next_global_ident hyp_radix avoid in + let str_h' = (string_of_id h') in + Some(PbpThens + ([PbpLApply h], + [chain_tactics [make_named_intro h'] (make_clears (h::clear_names)); + f avoid clear_names' false None (kind_of_term prem) path])) + | _ -> None;; + + +let (imply_elim2: pbp_rule) = function + avoid, clear_names, clear_flag, + Some h, Prod(Anonymous, prem, body), 2::path, f -> + let clear_names' = if clear_flag then h::clear_names else clear_names in + let h' = next_global_ident hyp_radix avoid in + Some(PbpThens + ([PbpLApply h], + [chain_tactics [make_named_intro h'] + (f (h'::avoid) clear_names' false (Some h') + (kind_of_term body) path); + make_clears clear_names])) + | _ -> None;; + +let reference dir s = Coqlib.gen_reference "Pbp" ("Init"::dir) s + +let constant dir s = Coqlib.gen_constant "Pbp" ("Init"::dir) s + +let andconstr: unit -> constr = Coqlib.build_coq_and;; +let prodconstr () = constant ["Datatypes"] "prod";; +let exconstr = Coqlib.build_coq_ex;; +let sigconstr () = constant ["Specif"] "sig";; +let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ;; +let orconstr = Coqlib.build_coq_or;; +let sumboolconstr = Coqlib.build_coq_sumbool;; +let sumconstr() = constant ["Datatypes"] "sum";; +let notconstr = Coqlib.build_coq_not;; +let notTconstr () = constant ["Logic_Type"] "notT";; + +let is_matching_local a b = is_matching (pattern_of_constr a) b;; + +let rec (or_and_tree_to_intro_pattern: identifier list -> + constr -> int list -> + intro_pattern_expr * identifier list * identifier *constr + * int list * int * int) = +fun avoid c path -> match kind_of_term c, path with + | (App(oper, [|c1; c2|]), 2::a::path) + when ((is_matching_local (andconstr()) oper) or + (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> + let id2 = next_global_ident hyp_radix avoid in + let cont_expr = if a = 1 then c1 else c2 in + let cont_patt, avoid_names, id, c, path, rank, total_branches = + or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in + let patt_list = + if a = 1 then + [cont_patt; IntroIdentifier id2] + else + [IntroIdentifier id2; cont_patt] in + (IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, + total_branches) + | (App(oper, [|c1; c2|]), 2::3::path) + when ((is_matching_local (exconstr()) oper) or + (is_matching_local (sigconstr()) oper)) -> + (match (kind_of_term c2) with + Lambda (Name x, _, body) -> + let id1 = next_global_ident x avoid in + let cont_patt, avoid_names, id, c, path, rank, total_branches = + or_and_tree_to_intro_pattern (id1::avoid) body path in + (IntroOrAndPattern[[IntroIdentifier id1; cont_patt]], + avoid_names, id, c, path, rank, total_branches) + | _ -> assert false) + | (App(oper, [|c1; c2|]), 2::a::path) + when ((is_matching_local (orconstr ()) oper) or + (is_matching_local (sumboolconstr ()) oper) or + (is_matching_local (sumconstr ()) oper)) & (a = 1 or a = 2) -> + let id2 = next_global_ident hyp_radix avoid in + let cont_expr = if a = 1 then c1 else c2 in + let cont_patt, avoid_names, id, c, path, rank, total_branches = + or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in + let new_rank = if a = 1 then rank else rank+1 in + let patt_list = + if a = 1 then + [[cont_patt];[IntroIdentifier id2]] + else + [[IntroIdentifier id2];[cont_patt]] in + (IntroOrAndPattern patt_list, + avoid_names, id, c, path, new_rank, total_branches+1) + | (_, path) -> let id = next_global_ident hyp_radix avoid in + (IntroIdentifier id, (id::avoid), id, c, path, 1, 1);; + +let auxiliary_goals clear_names clear_flag this_name n_aux others = + let clear_cmd = + make_clears (if clear_flag then (this_name ::clear_names) else clear_names) in + let rec clear_list = function + 0 -> others + | n -> clear_cmd::(clear_list (n - 1)) in + clear_list n_aux;; + + +let (imply_intro3: pbp_rule) = function + avoid, clear_names, clear_flag, None, Prod(Anonymous, prem, body), + 1::path, f -> + let intro_patt, avoid_names, id, c, p, rank, total_branches = + or_and_tree_to_intro_pattern avoid prem path in + if total_branches = 1 then + Some(chain_tactics [PbpIntros [intro_patt]] + (f avoid_names clear_names clear_flag (Some id) + (kind_of_term c) path)) + else + Some + (PbpThens + ([PbpIntros [intro_patt]], + auxiliary_goals clear_names clear_flag id + (rank - 1) + ((f avoid_names clear_names clear_flag (Some id) + (kind_of_term c) path):: + auxiliary_goals clear_names clear_flag id + (total_branches - rank) []))) + | _ -> None;; + + + +let (and_intro: pbp_rule) = function + avoid, clear_names, clear_flag, + None, App(and_oper, [|c1; c2|]), 2::a::path, f + -> + if ((is_matching_local (andconstr()) and_oper) or + (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then + let cont_term = if a = 1 then c1 else c2 in + let cont_cmd = f avoid clear_names false None + (kind_of_term cont_term) path in + let clear_cmd = make_clears clear_names in + let cmds = + (if a = 1 + then [cont_cmd;clear_cmd] + else [clear_cmd;cont_cmd]) in + Some (PbpThens ([PbpSplit],cmds)) + else None + | _ -> None;; + +let exists_from_lambda avoid clear_names clear_flag c2 path f = + match kind_of_term c2 with + Lambda(Name x, _, body) -> + Some (PbpThens ([PbpExists x], + [f avoid clear_names false None (kind_of_term body) path])) + | _ -> None;; + + +let (ex_intro: pbp_rule) = function + avoid, clear_names, clear_flag, None, + App(oper, [| c1; c2|]), 2::3::path, f + when (is_matching_local (exconstr ()) oper) + or (is_matching_local (sigconstr ()) oper) -> + exists_from_lambda avoid clear_names clear_flag c2 path f + | _ -> None;; + +let (exT_intro : pbp_rule) = function + avoid, clear_names, clear_flag, None, + App(oper, [| c1; c2|]), 2::2::2::path, f + when (is_matching_local (sigTconstr ()) oper) -> + exists_from_lambda avoid clear_names clear_flag c2 path f + | _ -> None;; + +let (or_intro: pbp_rule) = function + avoid, clear_names, clear_flag, None, + App(or_oper, [|c1; c2 |]), 2::a::path, f -> + if ((is_matching_local (orconstr ()) or_oper) or + (is_matching_local (sumboolconstr ()) or_oper) or + (is_matching_local (sumconstr ()) or_oper)) + & (a = 1 or a = 2) then + let cont_term = if a = 1 then c1 else c2 in + let fst_cmd = if a = 1 then PbpLeft else PbpRight in + let cont_cmd = f avoid clear_names false None + (kind_of_term cont_term) path in + Some(chain_tactics [fst_cmd] cont_cmd) + else + None + | _ -> None;; + +let dummy_id = id_of_string "Dummy";; + +let (not_intro: pbp_rule) = function + avoid, clear_names, clear_flag, None, + App(not_oper, [|c1|]), 2::1::path, f -> + if(is_matching_local (notconstr ()) not_oper) or + (is_matching_local (notTconstr ()) not_oper) then + let h' = next_global_ident hyp_radix avoid in + Some(chain_tactics [make_named_intro h'] + (f (h'::avoid) clear_names false (Some h') + (kind_of_term c1) path)) + else + None + | _ -> None;; + + + + +let elim_with_bindings hyp_name names = + PbpElim (hyp_name, names);; + +(* This function is used to follow down a path, while staying on the spine of + successive products (universal quantifications or implications). + Arguments are the current observed constr object and the path that remains + to be followed, and an integer indicating how many products have already been + crossed. + Result is: + - a list of string indicating the names of universally quantified variables. + - a list of integers indicating the positions of the successive + universally quantified variables. + - an integer indicating the number of non-dependent products. + - the last constr object encountered during the walk down, and + - the remaining path. + + For instance the following session should happen: + let tt = raw_constr_of_com (Evd.mt_evd())(gLOB(initial_sign())) + (parse_com "(P:nat->Prop)(x:nat)(P x)->(P x)") in + down_prods (tt, [2;2;2], 0) + ---> ["P","x"],[0;1], 1, <<(P x)>>, [] +*) + + +let rec down_prods: (types, constr) kind_of_term * (int list) * int -> + identifier list * (int list) * int * (types, constr) kind_of_term * + (int list) = + function + Prod(Name x, _, body), 2::path, k -> + let res_sl, res_il, res_i, res_cstr, res_p + = down_prods (kind_of_term body, path, k+1) in + x::res_sl, (k::res_il), res_i, res_cstr, res_p + | Prod(Anonymous, _, body), 2::path, k -> + let res_sl, res_il, res_i, res_cstr, res_p + = down_prods (kind_of_term body, path, k+1) in + res_sl, res_il, res_i+1, res_cstr, res_p + | cstr, path, _ -> [], [], 0, cstr, path;; + +exception Pbp_internal of int list;; + +(* This function should be usable to check that a type can be used by the + Apply command. Basically, c is supposed to be the head of some + type, where l gives the ranks of all universally quantified variables. + It check that these universally quantified variables occur in the head. + + The knowledge I have on constr structures is incomplete. +*) +let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = + function c -> function l -> + let rec delete n = function + | [] -> [] + | p::tl -> if n = p then tl else p::(delete n tl) in + let rec check_rec l = function + | App(f, array) -> + Array.fold_left (fun l c -> check_rec l (kind_of_term c)) + (check_rec l (kind_of_term f)) array + | Const _ -> l + | Ind _ -> l + | Construct _ -> l + | Var _ -> l + | Rel p -> + let result = delete p l in + if result = [] then + raise (Pbp_internal []) + else + result + | _ -> raise (Pbp_internal l) in + try + (check_rec l c) = [] + with Pbp_internal l -> l = [];; + +let (mk_db_indices: int list -> int -> int list) = + function int_list -> function nprems -> + let total = (List.length int_list) + nprems in + let rec mk_db_aux = function + [] -> [] + | a::l -> (total - a)::(mk_db_aux l) in + mk_db_aux int_list;; + + +(* This proof-by-pointing rule is quite complicated, as it attempts to foresee + usages of head tactics. A first operation is to follow the path as far + as possible while staying on the spine of products (function down_prods) + and then to check whether the next step will be an elim step. If the + answer is true, then the built command takes advantage of the power of + head tactics. *) + +let (head_tactic_patt: pbp_rule) = function + avoid, clear_names, clear_flag, Some h, cstr, path, f -> + (match down_prods (cstr, path, 0) with + | (str_list, _, nprems, App(oper,[|c1; c2|]), b::a::path) + when (((is_matching_local (exconstr ()) oper) (* or + (is_matching_local (sigconstr ()) oper) *)) && a = 3) -> + (match (kind_of_term c2) with + Lambda(Name x, _,body) -> + Some(PbpThens + ([elim_with_bindings h str_list], + let x' = next_global_ident x avoid in + let cont_body = + Prod(Name x', c1, + mkProd(Anonymous, body, + mkVar(dummy_id))) in + let cont_tac + = f avoid (h::clear_names) false None + cont_body (2::1::path) in + cont_tac::(auxiliary_goals + clear_names clear_flag + h nprems []))) + | _ -> None) + | (str_list, _, nprems, + App(oper,[|c1|]), 2::1::path) + when + (is_matching_local (notconstr ()) oper) or + (is_matching_local (notTconstr ()) oper) -> + Some(chain_tactics [elim_with_bindings h str_list] + (f avoid clear_names false None (kind_of_term c1) path)) + | (str_list, _, nprems, + App(oper, [|c1; c2|]), 2::a::path) + when ((is_matching_local (andconstr()) oper) or + (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> + let h1 = next_global_ident hyp_radix avoid in + let h2 = next_global_ident hyp_radix (h1::avoid) in + Some(PbpThens + ([elim_with_bindings h str_list], + let cont_body = + if a = 1 then c1 else c2 in + let cont_tac = + f (h2::h1::avoid) (h::clear_names) + false (Some (if 1 = a then h1 else h2)) + (kind_of_term cont_body) path in + (chain_tactics + [make_named_intro h1; make_named_intro h2] + cont_tac):: + (auxiliary_goals clear_names clear_flag h nprems []))) + | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) + when ((is_matching_local (sigTconstr()) oper)) & a = 2 -> + (match (kind_of_term c2),path with + Lambda(Name x, _,body), (2::path) -> + Some(PbpThens + ([elim_with_bindings h str_list], + let x' = next_global_ident x avoid in + let cont_body = + Prod(Name x', c1, + mkProd(Anonymous, body, + mkVar(dummy_id))) in + let cont_tac + = f avoid (h::clear_names) false None + cont_body (2::1::path) in + cont_tac::(auxiliary_goals + clear_names clear_flag + h nprems []))) + | _ -> None) + | (str_list, _, nprems, App(oper,[|c1; c2|]), 2::a::path) + when ((is_matching_local (orconstr ()) oper) or + (is_matching_local (sumboolconstr ()) oper) or + (is_matching_local (sumconstr ()) oper)) & + (a = 1 or a = 2) -> + Some(PbpThens + ([elim_with_bindings h str_list], + let cont_body = + if a = 1 then c1 else c2 in + (* h' is the name for the new intro *) + let h' = next_global_ident hyp_radix avoid in + let cont_tac = + chain_tactics + [make_named_intro h'] + (f + (* h' should not be used again *) + (h'::avoid) + (* the disjunct itself can be discarded *) + (h::clear_names) false (Some h') + (kind_of_term cont_body) path) in + let snd_tac = + chain_tactics + [make_named_intro h'] + (make_clears (h::clear_names)) in + let tacs1 = + if a = 1 then + [cont_tac; snd_tac] + else + [snd_tac; cont_tac] in + tacs1@(auxiliary_goals (h::clear_names) + false dummy_id nprems []))) + | (str_list, int_list, nprems, c, []) + when (check_apply c (mk_db_indices int_list nprems)) & + (match c with Prod(_,_,_) -> false + | _ -> true) & + (List.length int_list) + nprems > 0 -> + Some(add_clear_names_if_necessary (PbpThen [PbpApply h]) clear_names) + | _ -> None) + | _ -> None;; + + +let pbp_rules = ref [rem_cast;head_tactic_patt;forall_intro;imply_intro2; + forall_elim; imply_intro3; imply_elim1; imply_elim2; + and_intro; or_intro; not_intro; ex_intro; exT_intro];; + + +let try_trace = ref true;; + +let traced_try (f1:tactic) g = + try (try_trace := true; tclPROGRESS f1 g) + with e when Logic.catchable_exception e -> + (try_trace := false; tclIDTAC g);; + +let traced_try_entry = function + [Tacexp t] -> + traced_try (Tacinterp.interp t) + | _ -> failwith "traced_try_entry received wrong arguments";; + + +(* When the recursive descent along the path is over, one includes the + command requested by the point-and-shoot strategy. Default is + Try Assumption--Try Exact. *) + + +let default_ast optname constr path = PbpThen [PbpTryAssumption optname] + +(* This is the main proof by pointing function. *) +(* avoid: les noms a ne pas utiliser *) +(* final_cmd: la fonction appelee par defaut *) +(* opt_name: eventuellement le nom de l'hypothese sur laquelle on agit *) + +let rec pbpt final_cmd avoid clear_names clear_flag opt_name constr path = + let rec try_all_rules rl = + match rl with + f::tl -> + (match f (avoid, clear_names, clear_flag, + opt_name, constr, path, pbpt final_cmd) with + Some(ast) -> ast + | None -> try_all_rules tl) + | [] -> make_final_cmd final_cmd opt_name clear_names constr path + in try_all_rules (!pbp_rules);; + +(* these are the optimisation functions. *) +(* This function takes care of flattening successive then commands. *) + + +(* Invariant: in [flatten_sequence t], occurrences of [PbpThenCont(l,t)] enjoy + that t is some [PbpAtom t] *) + +(* This optimization function takes care of compacting successive Intro commands + together. *) + +let rec group_intros names = function + [] -> (match names with + [] -> [] + | l -> [PbpIntros l]) + | (PbpIntros ids)::others -> group_intros (names@ids) others + | t1::others -> + (match names with + [] -> t1::(group_intros [] others) + | l -> (PbpIntros l)::t1::(group_intros [] others)) + +let rec optim2 = function + | PbpThens (tl1,tl2) -> PbpThens (group_intros [] tl1, List.map optim2 tl2) + | PbpThen tl -> PbpThen (group_intros [] tl) + + +let rec cleanup_clears str_list = function + [] -> [] + | x::tail -> + if List.mem x str_list then cleanup_clears str_list tail + else x::(cleanup_clears str_list tail);; + +(* This function takes care of compacting instanciations of universal + quantifications. *) + +let rec optim3_aux str_list = function + (PbpGeneralize (h,l1)):: + (PbpIntros [IntroIdentifier s])::(PbpGeneralize (h',l2))::others + when s=h' -> + optim3_aux (s::str_list) (PbpGeneralize (h,l1@l2)::others) + | (PbpTryClear names)::other -> + (match cleanup_clears str_list names with + [] -> other + | l -> (PbpTryClear l)::other) + | a::l -> a::(optim3_aux str_list l) + | [] -> [];; + +let rec optim3 str_list = function + PbpThens (tl1, tl2) -> + PbpThens (optim3_aux str_list tl1, List.map (optim3 str_list) tl2) + | PbpThen tl -> PbpThen (optim3_aux str_list tl) + +let optim x = make_pbp_tactic (optim3 [] (optim2 x));; + +(* TODO +add_tactic "Traced_Try" traced_try_entry;; +*) + +let rec tactic_args_to_ints = function + [] -> [] + | (Integer n)::l -> n::(tactic_args_to_ints l) + | _ -> failwith "expecting only numbers";; + +(* +let pbp_tac display_function = function + (Identifier a)::l -> + (function g -> + let str = (string_of_id a) in + let (ou,tstr) = (get_hyp_by_name g str) in + let exp_ast = + pbpt default_ast + (match ou with + "hyp" ->(pf_ids_of_hyps g) + |_ -> (a::(pf_ids_of_hyps g))) + [] + false + (Some str) + (kind_of_term tstr) + (tactic_args_to_ints l) in + (display_function (optim exp_ast); + tclIDTAC g)) + | ((Integer n)::_) as l -> + (function g -> + let exp_ast = + (pbpt default_ast (pf_ids_of_hyps g) [] false + None (kind_of_term (pf_concl g)) + (tactic_args_to_ints l)) in + (display_function (optim exp_ast); + tclIDTAC g)) + | [] -> (function g -> + (display_function (default_ast None (pf_concl g) []); + tclIDTAC g)) + | _ -> failwith "expecting other arguments";; + + +*) +let pbp_tac display_function idopt nl = + match idopt with + | Some str -> + (function g -> + let (ou,tstr) = (get_hyp_by_name g str) in + let exp_ast = + pbpt default_ast + (match ou with + "hyp" ->(pf_ids_of_hyps g) + |_ -> (str::(pf_ids_of_hyps g))) + [] + false + (Some str) + (kind_of_term tstr) + nl in + (display_function (optim exp_ast); tclIDTAC g)) + | None -> + if nl <> [] then + (function g -> + let exp_ast = + (pbpt default_ast (pf_ids_of_hyps g) [] false + None (kind_of_term (pf_concl g)) nl) in + (display_function (optim exp_ast); tclIDTAC g)) + else + (function g -> + (display_function + (make_pbp_tactic (default_ast None (pf_concl g) [])); + tclIDTAC g));; + + diff --git a/contrib/interface/pbp.mli b/contrib/interface/pbp.mli new file mode 100644 index 00000000..43ec1274 --- /dev/null +++ b/contrib/interface/pbp.mli @@ -0,0 +1,4 @@ +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;; diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml new file mode 100644 index 00000000..5b265ec8 --- /dev/null +++ b/contrib/interface/showproof.ml @@ -0,0 +1,1899 @@ +(* +#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";; +open Coqast;; +*) +open Environ +open Evd +open Names +open Nameops +open Libnames +open Term +open Termops +open Util +open Proof_type +open Coqast +open Pfedit +open Translate +open Term +open Reductionops +open Clenv +open Typing +open Inductive +open Inductiveops +open Vernacinterp +open Declarations +open Showproof_ct +open Proof_trees +open Sign +open Pp +open Printer +open Rawterm +open Tacexpr +open Genarg +(*****************************************************************************) +(* + Arbre de preuve maison: + +*) + +(* hypotheses *) + +type nhyp = {hyp_name : identifier; + hyp_type : Term.constr; + hyp_full_type: Term.constr} +;; + +type ntactic = tactic_expr +;; + +type nproof = + Notproved + | Proof of ntactic * (ntree list) + +and ngoal= + {newhyp : nhyp list; + t_concl : Term.constr; + t_full_concl: Term.constr; + t_full_env: Sign.named_context} +and ntree= + {t_info:string; + t_goal:ngoal; + t_proof : nproof} +;; + + +let hyps {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = lh +;; + +let concl {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = g +;; + +let proof {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = p +;; +let g_env {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = ge +;; +let sub_ntrees t = + match (proof t) with + Notproved -> [] + | Proof (_,l) -> l +;; + +let tactic t = + match (proof t) with + Notproved -> failwith "no tactic applied" + | Proof (t,_) -> t +;; + + +(* +un arbre est clos s'il ne contient pas de sous-but non prouves, +ou bien s'il a un cousin gauche qui n'est pas clos +ce qui fait qu'on a au plus un sous-but non clos, le premier sous-but. +*) +let update_closed nt = + let found_not_closed=ref false in + let rec update {t_info=b; t_goal=g; t_proof =p} = + if !found_not_closed + then {t_info="to_prove"; t_goal=g; t_proof =p} + else + match p with + Notproved -> found_not_closed:=true; + {t_info="not_proved"; t_goal=g; t_proof =p} + | Proof(tac,lt) -> + let lt1=List.map update lt in + let b=ref "proved" in + (List.iter + (fun x -> + if x.t_info ="not_proved" then b:="not_proved") lt1; + {t_info=(!b); + t_goal=g; + t_proof=Proof(tac,lt1)}) + in update nt + ;; + + +(* + type complet avec les hypotheses. +*) + +let long_type_hyp lh t= + let t=ref t in + List.iter (fun (n,th) -> + let ni = match n with Name ni -> ni | _ -> assert false in + t:= mkProd(n,th,subst_term (mkVar ni) !t)) + (List.rev lh); + !t +;; + +(* let long_type_hyp x y = y;; *) + +(* Expansion des tactikelles *) + +let seq_to_lnhyp sign sign' cl = + let lh= ref (List.map (fun (x,c,t) -> (Name x, t)) sign) in + let nh=List.map (fun (id,c,ty) -> + {hyp_name=id; + hyp_type=ty; + hyp_full_type= + let res= long_type_hyp !lh ty in + lh:=(!lh)@[(Name id,ty)]; + res}) + sign' + in + {newhyp=nh; + t_concl=cl; + t_full_concl=long_type_hyp !lh cl; + t_full_env = sign@sign'} +;; + + +let rule_is_complex r = + match r with + Tactic (TacArg (Tacexp t),_) -> true + | Tactic (TacAtom (_,TacAuto _), _) -> true + | Tactic (TacAtom (_,TacSymmetry _), _) -> true + |_ -> false +;; + +let ast_of_constr = Termast.ast_of_constr true (Global.env()) ;; + +(* +let rule_to_ntactic r = + let rast = + (match r with + Tactic (s,l) -> + Ast.ope (s,(List.map ast_of_cvt_arg l)) + | Prim (Refine h) -> + Ast.ope ("Exact", + [Node ((0,0), "COMMAND", [ast_of_constr h])]) + | _ -> Ast.ope ("Intros",[])) in + if rule_is_complex r + then (match rast with + Node(_,_,[Node(_,_,[Node(_,_,x)])]) ->x + | _ -> assert false) + + else [rast ] +;; +*) +let rule_to_ntactic r = + let rt = + (match r with + Tactic (t,_) -> t + | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h) + | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in + if rule_is_complex r + then (match rt with + TacArg (Tacexp _) as t -> t + | _ -> assert false) + + 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 *) + + +let fill_unproved nt l = + let lnt = ref l in + let rec fill nt = + let {t_goal=g;t_proof=p}=nt in + match p with + Notproved -> let p=List.hd (!lnt) in + lnt:=List.tl (!lnt); + {t_info="to_prove";t_goal=g;t_proof=p} + |Proof(tac,lt) -> + {t_info="to_prove";t_goal=g; + t_proof=Proof(tac,List.map fill lt)} + in fill nt +;; +(* Differences entre signatures *) + +let new_sign osign sign = + let res=ref [] in + List.iter (fun (id,c,ty) -> + try (let (_,_,ty1)= (lookup_named id osign) in + ()) + with Not_found -> res:=(id,c,ty)::(!res)) + sign; + !res +;; + +let old_sign osign sign = + let res=ref [] in + List.iter (fun (id,c,ty) -> + try (let (_,_,ty1) = (lookup_named id osign) in + if ty1 = ty then res:=(id,c,ty)::(!res)) + with Not_found -> ()) + sign; + !res +;; + +(* convertit l'arbre de preuve courant en ntree *) +let to_nproof sigma osign pf = + let rec to_nproof_rec sigma osign pf = + let {evar_hyps=sign;evar_concl=cl} = pf.goal in + let nsign = new_sign osign sign in + let oldsign = old_sign osign sign in + match pf.ref with + + None -> {t_info="to_prove"; + t_goal=(seq_to_lnhyp oldsign nsign cl); + t_proof=Notproved} + | Some(r,spfl) -> + if rule_is_complex r + then ( + let p1= to_nproof_rec sigma sign (subproof_of_proof pf) in + let ntree= fill_unproved p1 + (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof) + spfl) in + (match r with + Tactic (TacAtom (_, TacAuto _),_) -> + if spfl=[] + then + {t_info="to_prove"; + t_goal= {newhyp=[]; + t_concl=concl ntree; + t_full_concl=ntree.t_goal.t_full_concl; + t_full_env=ntree.t_goal.t_full_env}; + t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])} + else ntree + | _ -> ntree)) + else + {t_info="to_prove"; + t_goal=(seq_to_lnhyp oldsign nsign cl); + t_proof=(Proof (rule_to_ntactic r, + List.map (fun x -> to_nproof_rec sigma sign x) spfl))} + in update_closed (to_nproof_rec sigma osign pf) + ;; + +(* + recupere l'arbre de preuve courant. +*) + +let get_nproof () = + to_nproof (Global.env()) [] + (Tacmach.proof_of_pftreestate (get_pftreestate())) +;; + + +(*****************************************************************************) +(* + Pprinter +*) + +let pr_void () = sphs "";; + +let list_rem l = match l with [] -> [] |x::l1->l1;; + +(* liste de chaines *) +let prls l = + let res = ref (sps (List.hd l)) in + List.iter (fun s -> + res:= sphv [ !res; spb; sps s]) (list_rem l); + !res +;; + +let prphrases f l = + spv (List.map (fun s -> sphv [f s; sps ","]) l) +;; + +(* indentation *) +let spi = spnb 3;; + +(* en colonne *) +let prl f l = + if l=[] then spe else spv (List.map f l);; +(*en colonne, avec indentation *) +let prli f l = + if l=[] then spe else sph [spi; spv (List.map f l)];; + +(* + Langues. +*) + +let rand l = + List.nth l (Random.int (List.length l)) +;; + +type natural_languages = French | English;; +let natural_language = ref French;; + +(*****************************************************************************) +(* + Les liens html pour proof-by-pointing +*) + +(* le path du but en cours. *) + +let path=ref[1];; + +let ftag_apply =ref (fun (n:string) t -> spt t);; + +let ftag_case =ref (fun n -> sps n);; + +let ftag_elim =ref (fun n -> sps n);; + +let ftag_hypt =ref (fun h t -> sphypt (translate_path !path) h t);; + +let ftag_hyp =ref (fun h t -> sphyp (translate_path !path) h t);; + +let ftag_uselemma =ref (fun h t -> + let intro = match !natural_language with + French -> "par" + | English -> "by" + in + spuselemma intro h t);; + +let ftag_toprove =ref (fun t -> sptoprove (translate_path !path) t);; + +let tag_apply = !ftag_apply;; + +let tag_case = !ftag_case;; + +let tag_elim = !ftag_elim;; + +let tag_uselemma = !ftag_uselemma;; + +let tag_hyp = !ftag_hyp;; + +let tag_hypt = !ftag_hypt;; + +let tag_toprove = !ftag_toprove;; + +(*****************************************************************************) + +(* pluriel *) +let txtn n s = + if n=1 then s + else match s with + |"un" -> "des" + |"a" -> "" + |"an" -> "" + |"une" -> "des" + |"Soit" -> "Soient" + |"Let" -> "Let" + | s -> s^"s" +;; + +let _et () = match !natural_language with + French -> sps "et" +| English -> sps "and" +;; + +let name_count = ref 0;; +let new_name () = + name_count:=(!name_count)+1; + string_of_int !name_count +;; + +let enumerate f ln = + match ln with + [] -> [] + | [x] -> [f x] + |ln -> + let rec enum_rec f ln = + (match ln with + [x;y] -> [f x; spb; sph [_et ();spb;f y]] + |x::l -> [sph [(f x);sps ","];spb]@(enum_rec f l) + | _ -> assert false) + in enum_rec f ln +;; + + +let constr_of_ast = Constrintern.interp_constr Evd.empty (Global.env());; + +(* +let sp_tac tac = + 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 + French -> + sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls [txtn nh "une";txtn nh "proposition"]]) +| English -> + sphv ([sps "Let";spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls ["be"; txtn nh "a";txtn nh "proposition"]]) +;; + +let on_a ()= match !natural_language with + French -> rand ["on a "] +| English ->rand ["we have "] +;; + +let bon_a ()= match !natural_language with + French -> rand ["On a "] +| English ->rand ["We have "] +;; + +let soit_X_un_element_de_T nh ln t = match !natural_language with + French -> + sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls [txtn nh "un";txtn nh "élément";"de"]] + @[spb; spt t]) +| English -> + sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls ["be";txtn nh "an";txtn nh "element";"of"]] + @[spb; spt t]) +;; + +let soit_F_une_fonction_de_type_T nh ln t = match !natural_language with + French -> + sphv ([sps (txtn nh "Soit");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls [txtn nh "une";txtn nh "fonction";"de";"type"]] + @[spb; spt t]) +| English -> + sphv ([sps (txtn nh "Let");spb]@(enumerate (fun x -> tag_hyp x t) ln) + @[spb; prls ["be";txtn nh "a";txtn nh "function";"of";"type"]] + @[spb; spt t]) +;; + + +let telle_que nh = match !natural_language with + French -> [prls [" ";txtn nh "telle";"que";" "]] +| English -> [prls [" "; "such";"that";" "]] +;; + +let tel_que nh = match !natural_language with + French -> [prls [" ";txtn nh "tel";"que";" "]] +| English -> [prls [" ";"such";"that";" "]] +;; + +let supposons () = match !natural_language with + French -> "Supposons " +| English -> "Suppose " +;; + +let cas () = match !natural_language with + French -> "Cas" +| English -> "Case" +;; + +let donnons_une_proposition () = match !natural_language with + French -> sph[ (prls ["Donnons";"une";"proposition"])] +| English -> sph[ (prls ["Let us give";"a";"proposition"])] +;; + +let montrons g = match !natural_language with + French -> sph[ sps (rand ["Prouvons";"Montrons";"Démontrons"]); + spb; spt g; sps ". "] +| English -> sph[ sps (rand ["Let us";"Now"]);spb; + sps (rand ["prove";"show"]); + spb; spt g; sps ". "] +;; + +let calculons_un_element_de g = match !natural_language with + French -> sph[ (prls ["Calculons";"un";"élément";"de"]); + spb; spt g; sps ". "] +| English -> sph[ (prls ["Let us";"compute";"an";"element";"of"]); + spb; spt g; sps ". "] +;; + +let calculons_une_fonction_de_type g = match !natural_language with + French -> sphv [ (prls ["Calculons";"une";"fonction";"de";"type"]); + spb; spt g; sps ". "] +| English -> sphv [ (prls ["Let";"us";"compute";"a";"function";"of";"type"]); + spb; spt g; sps ". "];; + +let en_simplifiant_on_obtient g = match !natural_language with + French -> + sphv [ (prls [rand ["Après simplification,"; "En simplifiant,"]; + rand ["on doit";"il reste à"]; + rand ["prouver";"montrer";"démontrer"]]); + spb; spt g; sps ". "] +| English -> + sphv [ (prls [rand ["After simplification,"; "Simplifying,"]; + rand ["we must";"it remains to"]; + rand ["prove";"show"]]); + spb; spt g; sps ". "] ;; + +let on_obtient g = match !natural_language with + French -> sph[ (prls [rand ["on doit";"il reste à"]; + rand ["prouver";"montrer";"démontrer"]]); + spb; spt g; sps ". "] +| English ->sph[ (prls [rand ["we must";"it remains to"]; + rand ["prove";"show"]]); + spb; spt g; sps ". "] +;; + +let reste_a_montrer g = match !natural_language with + French -> sph[ (prls ["Reste";"à"; + rand ["prouver";"montrer";"démontrer"]]); + spb; spt g; sps ". "] +| English -> sph[ (prls ["It remains";"to"; + rand ["prove";"show"]]); + spb; spt g; sps ". "] +;; + +let discutons_avec_A type_arg = match !natural_language with + French -> sphv [sps "Discutons"; spb; sps "avec"; spb; + spt type_arg; sps ":"] +| English -> sphv [sps "Let us discuss"; spb; sps "with"; spb; + spt type_arg; sps ":"] +;; + +let utilisons_A arg1 = match !natural_language with + French -> sphv [sps (rand ["Utilisons";"Avec";"A l'aide de"]); + spb; spt arg1; sps ":"] +| English -> sphv [sps (rand ["Let us use";"With";"With the help of"]); + spb; spt arg1; sps ":"] +;; + +let selon_les_valeurs_de_A arg1 = match !natural_language with + French -> sphv [ (prls ["Selon";"les";"valeurs";"de"]); + spb; spt arg1; sps ":"] +| English -> sphv [ (prls ["According";"values";"of"]); + spb; spt arg1; sps ":"] +;; + +let de_A_on_a arg1 = match !natural_language with + French -> sphv [ sps (rand ["De";"Avec";"Grâce à"]); spb; spt arg1; spb; + sps (rand ["on a:";"on déduit:";"on obtient:"])] +| English -> sphv [ sps (rand ["From";"With";"Thanks to"]); spb; + spt arg1; spb; + sps (rand ["we have:";"we deduce:";"we obtain:"])] +;; + + +let procedons_par_recurrence_sur_A arg1 = match !natural_language with + French -> sphv [ (prls ["Procédons";"par";"récurrence";"sur"]); + spb; spt arg1; sps ":"] +| English -> sphv [ (prls ["By";"induction";"on"]); + spb; spt arg1; sps ":"] +;; + + +let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A + nfun tfun narg = match !natural_language with + French -> sphv [ + sphv [ prls ["Calculons";"la";"fonction"]; + spb; sps (string_of_id nfun);spb; + prls ["de";"type"]; + spb; spt tfun;spb; + prls ["par";"récurrence";"sur";"son";"argument"]; + spb; sps (string_of_int narg); sps ":"] + ] +| English -> sphv [ + sphv [ prls ["Let us compute";"the";"function"]; + spb; sps (string_of_id nfun);spb; + prls ["of";"type"]; + spb; spt tfun;spb; + prls ["by";"induction";"on";"its";"argument"]; + spb; sps (string_of_int narg); sps ":"] + ] + +;; +let pour_montrer_G_la_valeur_recherchee_est_A g arg1 = + match !natural_language with + French -> sph [sps "Pour";spb;sps "montrer"; spt g; spb; + sps ","; spb; sps "choisissons";spb; + spt arg1;sps ". " ] +| English -> sph [sps "In order to";spb;sps "show"; spt g; spb; + sps ","; spb; sps "let us choose";spb; + spt arg1;sps ". " ] +;; + +let on_se_sert_de_A arg1 = match !natural_language with + French -> sph [sps "On se sert de";spb ;spt arg1;sps ":" ] +| English -> sph [sps "We use";spb ;spt arg1;sps ":" ] +;; + + +let d_ou_A g = match !natural_language with + French -> sph [spi; sps "d'où";spb ;spt g;sps ". " ] +| English -> sph [spi; sps "then";spb ;spt g;sps ". " ] +;; + + +let coq_le_demontre_seul () = match !natural_language with + French -> rand [prls ["Coq";"le";"démontre"; "seul."]; + sps "Fastoche."; + sps "Trop cool"] +| English -> rand [prls ["Coq";"shows";"it"; "alone."]; + sps "Fingers in the nose."] +;; + +let de_A_on_deduit_donc_B arg g = match !natural_language with + French -> sph + [ sps "De"; spb; spt arg; spb; sps "on";spb; + sps "déduit";spb; sps "donc";spb; spt g ] +| English -> sph + [ sps "From"; spb; spt arg; spb; sps "we";spb; + sps "deduce";spb; sps "then";spb; spt g ] +;; + +let _A_est_immediat_par_B g arg = match !natural_language with + French -> sph [ spt g; spb; (prls ["est";"immédiat";"par"]); + spb; spt arg ] +| English -> sph [ spt g; spb; (prls ["is";"immediate";"from"]); + spb; spt arg ] +;; + +let le_resultat_est arg = match !natural_language with + French -> sph [ (prls ["le";"résultat";"est"]); + spb; spt arg ] +| English -> sph [ (prls ["the";"result";"is"]); + spb; spt arg ];; + +let on_applique_la_tactique tactic tac = match !natural_language with + French -> sphv + [ sps "on applique";spb;sps "la tactique"; spb;tactic;spb;tac] +| English -> sphv + [ sps "we apply";spb;sps "the tactic"; spb;tactic;spb;tac] +;; + +let de_A_il_vient_B arg g = match !natural_language with + French -> sph + [ sps "De"; spb; spt arg; spb; + sps "il";spb; sps "vient";spb; spt g; sps ". " ] +| English -> sph + [ sps "From"; spb; spt arg; spb; + sps "it";spb; sps "comes";spb; spt g; sps ". " ] +;; + +let ce_qui_est_trivial () = match !natural_language with + French -> sps "Trivial." +| English -> sps "Trivial." +;; + +let en_utilisant_l_egalite_A arg = match !natural_language with + French -> sphv [ sps "En"; spb;sps "utilisant"; spb; + sps "l'egalite"; spb; spt arg; sps "," + ] +| English -> sphv [ sps "Using"; spb; + sps "the equality"; spb; spt arg; sps "," + ] +;; + +let simplifions_H_T hyp thyp = match !natural_language with + French -> sphv [sps"En simplifiant";spb;sps hyp;spb;sps "on obtient:"; + spb;spt thyp;sps "."] +| English -> sphv [sps"Simplifying";spb;sps hyp;spb;sps "we get:"; + spb;spt thyp;sps "."] +;; + +let grace_a_A_il_suffit_de_montrer_LA arg lg= + match !natural_language with + French -> sphv ([sps (rand ["Grâce à";"Avec";"A l'aide de"]);spb; + spt arg;sps ",";spb; + sps "il suffit";spb; sps "de"; spb; + sps (rand["prouver";"montrer";"démontrer"]); spb] + @[spv (enumerate (fun x->x) lg)]) +| English -> sphv ([sps (rand ["Thanks to";"With"]);spb; + spt arg;sps ",";spb; + sps "it suffices";spb; sps "to"; spb; + sps (rand["prove";"show"]); spb] + @[spv (enumerate (fun x->x) lg)]) +;; +let reste_a_montrer_LA lg= + match !natural_language with + French -> sphv ([ sps "Il reste";spb; sps "à"; spb; + sps (rand["prouver";"montrer";"démontrer"]); spb] + @[spv (enumerate (fun x->x) lg)]) +| English -> sphv ([ sps "It remains";spb; sps "to"; spb; + sps (rand["prove";"show"]); spb] + @[spv (enumerate (fun x->x) lg)]) +;; +(*****************************************************************************) +(* + Traduction des hypothèses. +*) + +type n_sort= + Nprop + | Nformula + | Ntype + | Nfunction +;; + + +let sort_of_type t ts = + let t=(strip_outer_cast t) in + if is_Prop t + then Nprop + else + match ts with + Prop(Null) -> Nformula + |_ -> (match (kind_of_term t) with + Prod(_,_,_) -> Nfunction + |_ -> Ntype) +;; + +let adrel (x,t) e = + match x with + Name(xid) -> Environ.push_rel (x,None,t) e + | Anonymous -> Environ.push_rel (x,None,t) e + +let rec nsortrec vl x = + match (kind_of_term x) with + Prod(n,t,c)-> + let vl = (adrel (n,t) vl) in nsortrec vl c + | Lambda(n,t,c) -> + let vl = (adrel (n,t) vl) in nsortrec vl c + | App(f,args) -> nsortrec vl f + | Sort(Prop(Null)) -> Prop(Null) + | Sort(c) -> c + | Ind(ind) -> + let (mib,mip) = lookup_mind_specif vl ind in + mip.mind_sort + | Construct(c) -> + nsortrec vl (mkInd (inductive_of_constructor c)) + | Case(_,x,t,a) + -> nsortrec vl x + | Cast(x,t)-> nsortrec vl t + | Const c -> nsortrec vl (lookup_constant c vl).const_type + | _ -> nsortrec vl (type_of vl Evd.empty x) +;; +let nsort x = + nsortrec (Global.env()) (strip_outer_cast x) +;; + +let sort_of_hyp h = + (sort_of_type h.hyp_type (nsort h.hyp_full_type)) +;; + +(* grouper les hypotheses successives de meme type, ou logiques. + donne une liste de liste *) +let rec group_lhyp lh = + match lh with + [] -> [] + |[h] -> [[h]] + |h::lh -> + match group_lhyp lh with + (h1::lh1)::lh2 -> + if h.hyp_type=h1.hyp_type + || ((sort_of_hyp h)=(sort_of_hyp h1) && (sort_of_hyp h1)=Nformula) + then (h::(h1::lh1))::lh2 + else [h]::((h1::lh1)::lh2) + |_-> assert false +;; + +(* ln noms des hypotheses, lt leurs types *) +let natural_ghyp (sort,ln,lt) intro = + let t=List.hd lt in + let nh=List.length ln in + let ns=List.hd ln in + match sort with + Nprop -> soit_A_une_proposition nh ln t + | Ntype -> soit_X_un_element_de_T nh ln t + | Nfunction -> soit_F_une_fonction_de_type_T nh ln t + | Nformula -> + sphv ((sps intro)::(enumerate (fun (n,t) -> tag_hypt n t) + (List.combine ln lt))) +;; + +(* Cas d'une hypothese *) +let natural_hyp h = + let ns= string_of_id h.hyp_name in + let t=h.hyp_type in + let ts= (nsort h.hyp_full_type) in + natural_ghyp ((sort_of_type t ts),[ns],[t]) (supposons ()) +;; + +let rec pr_ghyp lh intro= + match lh with + [] -> [] + | [(sort,ln,t)]-> + (match sort with + Nformula -> [natural_ghyp(sort,ln,t) intro; sps ". "] + | _ -> [natural_ghyp(sort,ln,t) ""; sps ". "]) + | (sort,ln,t)::lh -> + let hp= + ([natural_ghyp(sort,ln,t) intro] + @(match lh with + [] -> [sps ". "] + |(sort1,ln1,t1)::lh1 -> + match sort1 with + Nformula -> + (let nh=List.length ln in + match sort with + Nprop -> telle_que nh + |Nfunction -> telle_que nh + |Ntype -> tel_que nh + |Nformula -> [sps ". "]) + | _ -> [sps ". "])) in + (sphv hp)::(pr_ghyp lh "") +;; + +(* traduction d'une liste d'hypotheses groupees. *) +let prnatural_ghyp llh intro= + if llh=[] + then spe + else + sphv (pr_ghyp (List.map + (fun lh -> + let h=(List.hd lh) in + let sh = sort_of_hyp h in + let lhname = (List.map (fun h -> + string_of_id h.hyp_name) lh) in + let lhtype = (List.map (fun h -> h.hyp_type) lh) in + (sh,lhname,lhtype)) + llh) intro) +;; + + +(*****************************************************************************) +(* + Liste des hypotheses. +*) +type type_info_subgoals_hyp= + All_subgoals_hyp + | Reduce_hyp + | No_subgoals_hyp + | Case_subgoals_hyp of string (* word for introduction *) + * Term.constr (* variable *) + * string (* constructor *) + * int (* arity *) + * int (* number of constructors *) + | Case_prop_subgoals_hyp of string (* word for introduction *) + * Term.constr (* variable *) + * int (* index of constructor *) + * int (* arity *) + * int (* number of constructors *) + | Elim_subgoals_hyp of Term.constr (* variable *) + * string (* constructor *) + * int (* arity *) + * (string list) (* rec hyp *) + * int (* number of constructors *) + | Elim_prop_subgoals_hyp of Term.constr (* variable *) + * int (* index of constructor *) + * int (* arity *) + * (string list) (* rec hyp *) + * int (* number of constructors *) +;; +let rec nrem l n = + if n<=0 then l else nrem (list_rem l) (n-1) +;; + +let rec nhd l n = + if n<=0 then [] else (List.hd l)::(nhd (list_rem l) (n-1)) +;; + +let par_hypothese_de_recurrence () = match !natural_language with + French -> sphv [(prls ["par";"hypothèse";"de";"récurrence";","])] +| English -> sphv [(prls ["by";"induction";"hypothesis";","])] +;; + +let natural_lhyp lh hi = + match hi with + All_subgoals_hyp -> + ( match lh with + [] -> spe + |_-> prnatural_ghyp (group_lhyp lh) (supposons ())) + | Reduce_hyp -> + (match lh with + [h] -> simplifions_H_T (string_of_id h.hyp_name) h.hyp_type + | _-> spe) + | No_subgoals_hyp -> spe + |Case_subgoals_hyp (sintro,var,c,a,ncase) -> (* sintro pas encore utilisee *) + let s=ref c in + for i=1 to a do + let nh=(List.nth lh (i-1)) in + s:=(!s)^" "^(string_of_id nh.hyp_name); + done; + if a>0 then s:="("^(!s)^")"; + sphv [ (if ncase>1 + then sph[ sps ("-"^(cas ()));spb] + else spe); + (* spt var;sps "="; *) sps !s; sps ":"; + (prphrases (natural_hyp) (nrem lh a))] + |Case_prop_subgoals_hyp (sintro,var,c,a,ncase) -> + prnatural_ghyp (group_lhyp lh) sintro + |Elim_subgoals_hyp (var,c,a,lhci,ncase) -> + let nlh = List.length lh in + let nlhci = List.length lhci in + let lh0 = ref [] in + for i=1 to (nlh-nlhci) do + lh0:=(!lh0)@[List.nth lh (i-1)]; + done; + let lh=nrem lh (nlh-nlhci) in + let s=ref c in + let lh1=ref [] in + for i=1 to nlhci do + let targ=(List.nth lhci (i-1))in + let nh=(List.nth lh (i-1)) in + if targ="arg" || targ="argrec" + then + (s:=(!s)^" "^(string_of_id nh.hyp_name); + lh0:=(!lh0)@[nh]) + else lh1:=(!lh1)@[nh]; + done; + let introhyprec= + (if (!lh1)=[] then spe + else par_hypothese_de_recurrence () ) + in + if a>0 then s:="("^(!s)^")"; + spv [sphv [(if ncase>1 + then sph[ sps ("-"^(cas ()));spb] + else spe); + sps !s; sps ":"]; + prnatural_ghyp (group_lhyp !lh0) (supposons ()); + introhyprec; + prl (natural_hyp) !lh1] + |Elim_prop_subgoals_hyp (var,c,a,lhci,ncase) -> + sphv [ (if ncase>1 + then sph[ sps ("-"^(cas ()));spb;sps (string_of_int c); + sps ":";spb] + else spe); + (prphrases (natural_hyp) lh )] + +;; + +(*****************************************************************************) +(* + Analyse des tactiques. +*) + +(* +let name_tactic tac = + match tac with + (Node(_,"Interp", + (Node(_,_, + (Node(_,t,_))::_))::_))::_ -> t + |(Node(_,t,_))::_ -> t + | _ -> assert false +;; +*) +let name_tactic = function + | TacIntroPattern _ -> "Intro" + | TacAssumption -> "Assumption" + | _ -> failwith "TODO" +;; + +(* +let arg1_tactic tac = + match tac with + (Node(_,"Interp", + (Node(_,_, + (Node(_,_,x::_))::_))::_))::_ ->x + | (Node(_,_,x::_))::_ -> x + | x::_ -> x + | _ -> assert false +;; +*) + +let arg1_tactic tac = failwith "TODO" + +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 id_of_command x = + match x with + Node(_,_,Node(_,_,y::_)::_) -> y + |_ -> assert false +;; +type type_info_subgoals = + {ihsg: type_info_subgoals_hyp; + isgintro : string} +;; + +let rec show_goal lh ig g gs = + match ig with + "intros" -> + if lh = [] + then spe + else show_goal lh "standard" g gs + |"standard" -> + (match (sort_of_type g gs) with + Nprop -> donnons_une_proposition () + | Nformula -> montrons g + | Ntype -> calculons_un_element_de g + | Nfunction ->calculons_une_fonction_de_type g) + | "apply" -> show_goal lh "" g gs + | "simpl" ->en_simplifiant_on_obtient g + | "rewrite" -> on_obtient g + | "equality" -> reste_a_montrer g + | "trivial_equality" -> reste_a_montrer g + | "" -> spe + |_ -> sph[ sps "A faire ..."; spb; spt g; sps ". " ] +;; + +let show_goal2 lh {ihsg=hi;isgintro=ig} g gs s = + if ig="" && lh = [] + then spe + else sphv [ show_goal lh ig g gs; sps s] +;; + +let imaginez_une_preuve_de () = match !natural_language with + French -> "Imaginez une preuve de" +| English -> "Imagine a proof of" +;; + +let donnez_un_element_de () = match !natural_language with + French -> "Donnez un element de" +| English -> "Give an element of";; + +let intro_not_proved_goal gs = + match gs with + Prop(Null) -> imaginez_une_preuve_de () + |_ -> donnez_un_element_de () +;; + +let first_name_hyp_of_ntree {t_goal={newhyp=lh}}= + match lh with + {hyp_name=n}::_ -> n + | _ -> assert false +;; + +let rec find_type x t= + match (kind_of_term (strip_outer_cast t)) with + Prod(y,ty,t) -> + (match y with + Name y -> + if x=(string_of_id y) then ty + else find_type x t + | _ -> find_type x t) + |_-> assert false +;; + +(*********************************************************************** +Traitement des égalités +*) +(* +let is_equality e = + match (kind_of_term e) with + AppL args -> + (match (kind_of_term args.(0)) with + Const (c,_) -> + (match (string_of_sp c) with + "Equal" -> true + | "eq" -> true + | "eqT" -> true + | "identityT" -> true + | _ -> false) + | _ -> false) + | _ -> false +;; +*) + +let is_equality e = + let e= (strip_outer_cast e) in + match (kind_of_term e) with + App (f,args) -> (Array.length args) >= 3 + | _ -> false +;; + +let terms_of_equality e = + let e= (strip_outer_cast e) in + match (kind_of_term e) with + App (f,args) -> (args.(1) , args.(2)) + | _ -> assert false +;; + +let eq_term = eq_constr;; + +let is_equality_tac = function + | TacAtom (_, + (TacExtend + (_,("ERewriteLR"|"ERewriteRL"|"ERewriteLRocc"|"ERewriteRLocc" + |"ERewriteParallel"|"ERewriteNormal" + |"RewriteLR"|"RewriteRL"|"Replace"),_) + | TacReduce _ + | TacSymmetry _ | TacReflexivity + | TacExact _ | TacIntroPattern _ | TacIntroMove _ | TacAuto _)) -> true + | _ -> false + +let equalities_ntree ig ntree = + let rec equalities_ntree ig ntree = + if not (is_equality (concl ntree)) + then [] + else + match (proof ntree) with + Notproved -> [(ig,ntree)] + | Proof (tac,ltree) -> + if is_equality_tac tac + then (match ltree with + [] -> [(ig,ntree)] + | t::_ -> let res=(equalities_ntree ig t) in + if eq_term (concl ntree) (concl t) + then res + else (ig,ntree)::res) + else [(ig,ntree)] + in + equalities_ntree ig ntree +;; + +let remove_seq_of_terms l = + let rec remove_seq_of_terms l = match l with + a::b::l -> if (eq_term (fst a) (fst b)) + then remove_seq_of_terms (b::l) + else a::(remove_seq_of_terms (b::l)) + | _ -> l + in remove_seq_of_terms l +;; + +let list_to_eq l o= + let switch = fun h h' -> (if o then h else h') in + match l with + [a] -> spt (fst a) + | (a,h)::(b,h')::l -> + let rec list_to_eq h l = + match l with + [] -> [] + | (b,h')::l -> + (sph [sps "="; spb; spt b; spb;tag_uselemma (switch h h') spe]) + :: (list_to_eq (switch h' h) l) + in sph [spt a; spb; + spv ((sph [sps "="; spb; spt b; spb; + tag_uselemma (switch h h') spe]) + ::(list_to_eq (switch h' h) l))] + | _ -> assert false +;; + +let stde = Global.env;; + +let dbize env = Constrintern.interp_constr Evd.empty env;; + +(**********************************************************************) +let rec natural_ntree ig ntree = + let {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} = ntree in + let leq = List.rev (equalities_ntree ig ntree) in + if List.length leq > 1 + then (* Several equalities to treate ... *) + ( + print_string("Several equalities to treate ...\n"); + let l1 = ref [] in + let l2 = ref [] in + List.iter + (fun (_,ntree) -> + let lemma = match (proof ntree) with + Proof (tac,ltree) -> + (try (sph [spt (dbize (gLOB ge) (arg1_tactic tac));(* TODO *) + (match ltree with + [] ->spe + | [_] -> spe + | _::l -> sphv[sps ": "; + prli (natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="standard"}) + l])]) + with _ -> sps "simplification" ) + | Notproved -> spe + in + let (t1,t2)= terms_of_equality (concl ntree) in + l2:=(t2,lemma)::(!l2); + l1:=(t1,lemma)::(!l1)) + leq; + l1:=remove_seq_of_terms !l1; + l2:=remove_seq_of_terms !l2; + l2:=List.rev !l2; + let ltext=ref [] in + if List.length !l1 > 1 + then (ltext:=(!ltext)@[list_to_eq !l1 true]; + if List.length !l2 > 1 then + (ltext:=(!ltext)@[_et()]; + ltext:=(!ltext)@[list_to_eq !l2 false])) + else if List.length !l2 > 1 then ltext:=(!ltext)@[list_to_eq !l2 false]; + if !ltext<>[] then ltext:=[sps (bon_a ()); spv !ltext]; + let (ig,ntree)=(List.hd leq) in + spv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g (nsort gf) ""); + sph !ltext; + + natural_ntree {ihsg=All_subgoals_hyp; + isgintro= + let (t1,t2)= terms_of_equality (concl ntree) in + if eq_term t1 t2 + then "trivial_equality" + else "equality"} + ntree] + ) + else + let ntext = + let gs=nsort gf in + match p with + Notproved -> spv [ (natural_lhyp lh ig.ihsg); + sph [spi; sps (intro_not_proved_goal gs); spb; + tag_toprove g ] + ] + + | Proof (TacId _,ltree) -> natural_ntree ig (List.hd ltree) + | Proof (TacAtom (_,tac),ltree) -> + (let ntext = + match tac with +(* Pas besoin de l'argument éventuel de la tactique *) + TacIntroPattern _ -> natural_intros ig lh g gs ltree + | TacIntroMove _ -> natural_intros ig lh g gs ltree + | TacFix (_,n) -> natural_fix ig lh g gs n ltree + | TacSplit (_,NoBindings) -> natural_split ig lh g gs ge [] ltree + | TacSplit(_,ImplicitBindings l) -> natural_split ig lh g gs ge l ltree + | TacGeneralize l -> natural_generalize ig lh g gs ge l ltree + | TacRight _ -> natural_right ig lh g gs ltree + | TacLeft _ -> natural_left ig lh g gs ltree + | (* "Simpl" *)TacReduce (r,cl) -> + natural_reduce ig lh g gs ge r cl ltree + | TacExtend (_,"InfoAuto",[]) -> natural_infoauto ig lh g gs ltree + | TacAuto _ -> natural_auto ig lh g gs ltree + | TacExtend (_,"EAuto",_) -> natural_auto ig lh g gs ltree + | TacTrivial _ -> natural_trivial ig lh g gs ltree + | TacAssumption -> natural_trivial ig lh g gs ltree + | TacClear _ -> natural_clear ig lh g gs ltree +(* Besoin de l'argument de la tactique *) + | TacSimpleInduction (NamedHyp id,_) -> + natural_induction ig lh g gs ge id ltree false + | TacExtend (_,"InductionIntro",[a]) -> + let id=(out_gen wit_ident a) in + natural_induction ig lh g gs ge id ltree true + | TacApply (c,_) -> natural_apply ig lh g gs c ltree + | 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 + natural_cutintro ig lh g gs a ltree + | TacCase (c,_) -> natural_case ig lh g gs ge c ltree false + | TacExtend (_,"CaseIntro",[a]) -> + let c = out_gen wit_constr a in + natural_case ig lh g gs ge c ltree true + | TacElim ((c,_),_) -> natural_elim ig lh g gs ge c ltree false + | TacExtend (_,"ElimIntro",[a]) -> + let c = out_gen wit_constr a in + natural_elim ig lh g gs ge c ltree true + | TacExtend (_,"Rewrite",[_;a]) -> + let (c,_) = out_gen wit_constr_with_bindings a in + natural_rewrite ig lh g gs c ltree + | TacExtend (_,"ERewriteRL",[a]) -> + let c = out_gen wit_constr a in (* TODO *) + natural_rewrite ig lh g gs c ltree + | TacExtend (_,"ERewriteLR",[a]) -> + let c = out_gen wit_constr a in (* TODO *) + natural_rewrite ig lh g gs c ltree + |_ -> natural_generic ig lh g gs (sps (name_tactic tac)) (prl sp_tac [tac]) ltree + in + ntext (* spwithtac ntext tactic*) + ) + | Proof _ -> failwith "Don't know what to do with that" + in + if info<>"not_proved" + then spshrink info ntext + else ntext +and natural_generic ig lh g gs tactic tac ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + on_applique_la_tactique tactic tac ; + (prli(natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="standard"}) + ltree) + ] +and natural_clear ig lh g gs ltree = natural_ntree ig (List.hd ltree) +(* + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prl (natural_ntree ig) ltree) + ] +*) +and natural_intros ig lh g gs ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prl (natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="intros"}) + ltree) + ] +and natural_apply ig lh g gs arg ltree = + let lg = List.map concl ltree in + match lg with + [] -> + spv + [ (natural_lhyp lh ig.ihsg); + de_A_il_vient_B arg g + ] + | [sg]-> + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh + {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply" + then "standard" + else ""} + g gs ""); + grace_a_A_il_suffit_de_montrer_LA arg [spt sg]; + sph [spi ; natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="apply"} (List.hd ltree)] + ] + | _ -> + let ln = List.map (fun _ -> new_name()) lg in + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh + {ihsg=ig.ihsg; isgintro= if ig.isgintro<>"apply" + then "standard" + else ""} + g gs ""); + grace_a_A_il_suffit_de_montrer_LA arg + (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) + lg ln); + sph [spi; spv (List.map2 + (fun x n -> sph [sps ("("^n^"):"); spb; + natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="apply"} x]) + ltree ln)] + ] +and natural_rem_goals ltree = + let lg = List.map concl ltree in + match lg with + [] -> spe + | [sg]-> + spv + [ reste_a_montrer_LA [spt sg]; + sph [spi ; natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="apply"} (List.hd ltree)] + ] + | _ -> + let ln = List.map (fun _ -> new_name()) lg in + spv + [ reste_a_montrer_LA + (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) + lg ln); + sph [spi; spv (List.map2 + (fun x n -> sph [sps ("("^n^"):"); spb; + natural_ntree + {ihsg=All_subgoals_hyp; + isgintro="apply"} x]) + ltree ln)] + ] +and natural_exact ig lh g gs arg ltree = +spv + [ + (natural_lhyp lh ig.ihsg); + (let {ihsg=pi;isgintro=ig}= ig in + (show_goal2 lh {ihsg=pi;isgintro=""} + g gs "")); + (match gs with + Prop(Null) -> _A_est_immediat_par_B g arg + |_ -> le_resultat_est arg) + + ] +and natural_cut ig lh g gs arg ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + (List.rev ltree)); + de_A_on_deduit_donc_B arg g + ] +and natural_cutintro ig lh g gs arg ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + sph [spi; + (natural_ntree + {ihsg=All_subgoals_hyp;isgintro=""} + (List.nth ltree 1))]; + sph [spi; + (natural_ntree + {ihsg=No_subgoals_hyp;isgintro=""} + (List.nth ltree 0))] + ] +and whd_betadeltaiota x = whd_betaiotaevar (Global.env()) Evd.empty x +and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c) +and prod_head t = + match (kind_of_term (strip_outer_cast t)) with + Prod(_,_,c) -> prod_head c +(* |App(f,a) -> f *) + | _ -> t +and string_of_sp sp = string_of_id (basename sp) +and constr_of_mind mip i = + (string_of_id mip.mind_consnames.(i-1)) +and arity_of_constr_of_mind env indf i = + (get_constructors env indf).(i-1).cs_nargs +and gLOB ge = Global.env_of_context ge (* (Global.env()) *) + +and natural_case ig lh g gs ge arg1 ltree with_intros = + let env= (gLOB ge) in + let targ1 = prod_head (type_of env Evd.empty arg1) in + let IndType (indf,targ) = find_rectype env Evd.empty targ1 in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let ti =(string_of_id mip.mind_typename) in + let type_arg= targ1 (* List.nth targ (mis_index dmi)*) in + if ncti<>1 +(* Zéro ou Plusieurs constructeurs *) + then ( + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (match (nsort targ1) with + Prop(Null) -> + (match ti with + "or" -> discutons_avec_A type_arg + | _ -> utilisons_A arg1) + |_ -> selon_les_valeurs_de_A arg1); + (let ci=ref 0 in + (prli + (fun treearg -> ci:=!ci+1; + let nci=(constr_of_mind mip !ci) in + let aci=if with_intros + then (arity_of_constr_of_mind env indf !ci) + else 0 in + let ici= (!ci) in + sph[ (natural_ntree + {ihsg= + (match (nsort targ1) with + Prop(Null) -> + Case_prop_subgoals_hyp (supposons (),arg1,ici,aci, + (List.length ltree)) + |_-> Case_subgoals_hyp ("",arg1,nci,aci, + (List.length ltree))); + isgintro= if with_intros then "" else "standard"} + treearg) + ]) + (nrem ltree ((List.length ltree)- ncti)))); + (sph [spi; (natural_rem_goals + (nhd ltree ((List.length ltree)- ncti)))]) + ] ) +(* Cas d'un seul constructeur *) + else ( + + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + de_A_on_a arg1; + (let treearg=List.hd ltree in + let nci=(constr_of_mind mip 1) in + let aci= + if with_intros + then (arity_of_constr_of_mind env indf 1) + else 0 in + let ici= 1 in + sph[ (natural_ntree + {ihsg= + (match (nsort targ1) with + Prop(Null) -> + Case_prop_subgoals_hyp ("",arg1,1,aci, + (List.length ltree)) + |_-> Case_subgoals_hyp ("",arg1,nci,aci, + (List.length ltree))); + isgintro=""} + treearg) + ]); + (sph [spi; (natural_rem_goals + (nhd ltree ((List.length ltree)- 1)))]) + ] + ) +(* with _ ->natural_generic ig lh g gs (sps "Case") (spt arg1) ltree *) + +(*****************************************************************************) +(* + Elim +*) +and prod_list_var t = + match (kind_of_term (strip_outer_cast t)) with + Prod(_,t,c) -> t::(prod_list_var c) + |_ -> [] +and hd_is_mind t ti = + try (let env = Global.env() in + let IndType (indf,targ) = find_rectype env Evd.empty t in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + (string_of_id mip.mind_typename) = ti) + with _ -> false +and mind_ind_info_hyp_constr indf c = + let env = Global.env() in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let p = mip.mind_nparams in + let a = arity_of_constr_of_mind env indf c in + let lp=ref (get_constructors env indf).(c).cs_args in + let lr=ref [] in + let ti = (string_of_id mip.mind_typename) in + for i=1 to a do + match !lp with + ((_,_,t)::lp1)-> + if hd_is_mind t ti + then (lr:=(!lr)@["argrec";"hyprec"]; lp:=List.tl lp1) + else (lr:=(!lr)@["arg"];lp:=lp1) + | _ -> raise (Failure "mind_ind_info_hyp_constr") + done; + !lr +(* + mind_ind_info_hyp_constr "le" 2;; +donne ["arg"; "argrec"] +mind_ind_info_hyp_constr "le" 1;; +donne [] + mind_ind_info_hyp_constr "nat" 2;; +donne ["argrec"] +*) + +and natural_elim ig lh g gs ge arg1 ltree with_intros= + let env= (gLOB ge) in + let targ1 = prod_head (type_of env Evd.empty arg1) in + let IndType (indf,targ) = find_rectype env Evd.empty targ1 in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let ti =(string_of_id mip.mind_typename) in + let type_arg=targ1 (* List.nth targ (mis_index dmi) *) in + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (match (nsort targ1) with + Prop(Null) -> utilisons_A arg1 + |_ ->procedons_par_recurrence_sur_A arg1); + (let ci=ref 0 in + (prli + (fun treearg -> ci:=!ci+1; + let nci=(constr_of_mind mip !ci) in + let aci=(arity_of_constr_of_mind env indf !ci) in + let hci= + if with_intros + then mind_ind_info_hyp_constr indf !ci + else [] in + let ici= (!ci) in + sph[ (natural_ntree + {ihsg= + (match (nsort targ1) with + Prop(Null) -> + Elim_prop_subgoals_hyp (arg1,ici,aci,hci, + (List.length ltree)) + |_-> Elim_subgoals_hyp (arg1,nci,aci,hci, + (List.length ltree))); + isgintro= ""} + treearg) + ]) + (nhd ltree ncti))); + (sph [spi; (natural_rem_goals (nrem ltree ncti))]) + ] +(* ) + with _ ->natural_generic ig lh g gs (sps "Elim") (spt arg1) ltree *) + +(*****************************************************************************) +(* + InductionIntro n +*) +and natural_induction ig lh g gs ge arg2 ltree with_intros= + let env = (gLOB (g_env (List.hd ltree))) in + let arg1= mkVar arg2 in + let targ1 = prod_head (type_of env Evd.empty arg1) in + let IndType (indf,targ) = find_rectype env Evd.empty targ1 in + let ncti= Array.length(get_constructors env indf) in + let (ind,_) = dest_ind_family indf in + let (mib,mip) = lookup_mind_specif env ind in + let ti =(string_of_id mip.mind_typename) in + let type_arg= targ1(*List.nth targ (mis_index dmi)*) in + + let lh1= hyps (List.hd ltree) in (* la liste des hyp jusqu'a n *) + (* on les enleve des hypotheses des sous-buts *) + let ltree = List.map + (fun {t_info=info; + t_goal={newhyp=lh;t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p} -> + {t_info=info; + t_goal={newhyp=(nrem lh (List.length lh1)); + t_concl=g;t_full_concl=gf;t_full_env=ge}; + t_proof=p}) ltree in + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (natural_lhyp lh1 All_subgoals_hyp); + (match (print_string "targ1------------\n";(nsort targ1)) with + Prop(Null) -> utilisons_A arg1 + |_ -> procedons_par_recurrence_sur_A arg1); + (let ci=ref 0 in + (prli + (fun treearg -> ci:=!ci+1; + let nci=(constr_of_mind mip !ci) in + let aci=(arity_of_constr_of_mind env indf !ci) in + let hci= + if with_intros + then mind_ind_info_hyp_constr indf !ci + else [] in + let ici= (!ci) in + sph[ (natural_ntree + {ihsg= + (match (nsort targ1) with + Prop(Null) -> + Elim_prop_subgoals_hyp (arg1,ici,aci,hci, + (List.length ltree)) + |_-> Elim_subgoals_hyp (arg1,nci,aci,hci, + (List.length ltree))); + isgintro= "standard"} + treearg) + ]) + ltree)) + ] +(************************************************************************) +(* Points fixes *) + +and natural_fix ig lh g gs narg ltree = + let {t_info=info; + t_goal={newhyp=lh1;t_concl=g1;t_full_concl=gf1; + t_full_env=ge1};t_proof=p1}=(List.hd ltree) in + match lh1 with + {hyp_name=nfun;hyp_type=tfun}::lh2 -> + let ltree=[{t_info=info; + t_goal={newhyp=lh2;t_concl=g1;t_full_concl=gf1; + t_full_env=ge1}; + t_proof=p1}] in + spv + [ (natural_lhyp lh ig.ihsg); + calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A nfun tfun narg; + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro=""}) + ltree) + ] + | _ -> assert false +and natural_reduce ig lh g gs ge mode la ltree = + match la with + {onhyps=Some[];onconcl=true} -> + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prl (natural_ntree + {ihsg=All_subgoals_hyp;isgintro="simpl"}) + ltree) + ] + | {onhyps=Some[hyp]; onconcl=false} -> + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prl (natural_ntree + {ihsg=Reduce_hyp;isgintro=""}) + ltree) + ] + | _ -> assert false +and natural_split ig lh g gs ge la ltree = + match la with + [arg] -> + let env= (gLOB ge) in + let arg1= (*dbize env*) arg in + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + pour_montrer_G_la_valeur_recherchee_est_A g arg1; + (prl (natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree) + ] + | [] -> + spv + [ (natural_lhyp lh ig.ihsg); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree) + ] + | _ -> assert false +and natural_generalize ig lh g gs ge la ltree = + match la with + [arg] -> + let env= (gLOB ge) in + let arg1= (*dbize env*) arg in + let type_arg=type_of (Global.env()) Evd.empty arg in +(* let type_arg=type_of_ast ge arg in*) + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + on_se_sert_de_A arg1; + (prl (natural_ntree + {ihsg=All_subgoals_hyp;isgintro=""}) + ltree) + ] + | _ -> assert false +and natural_right ig lh g gs ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree); + d_ou_A g + ] +and natural_left ig lh g gs ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree); + d_ou_A g + ] +and natural_auto ig lh g gs ltree = + match ig.isgintro with + "trivial_equality" -> spe + | _ -> + if ltree=[] + then sphv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + coq_le_demontre_seul ()] + else spv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + (prli (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""} + ) + ltree)] +and natural_infoauto ig lh g gs ltree = + match ig.isgintro with + "trivial_equality" -> + spshrink "trivial_equality" + (natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"} + (List.hd ltree)) + | _ -> sphv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + coq_le_demontre_seul (); + spshrink "auto" + (sph [spi; + (natural_ntree + {ihsg=All_subgoals_hyp;isgintro=""} + (List.hd ltree))])] +and natural_trivial ig lh g gs ltree = + if ltree=[] + then sphv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + ce_qui_est_trivial () ] + else spv [(natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ". "); + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="standard"}) + ltree)] +and natural_rewrite ig lh g gs arg ltree = + spv + [ (natural_lhyp lh ig.ihsg); + (show_goal2 lh ig g gs ""); + en_utilisant_l_egalite_A arg; + (prli(natural_ntree + {ihsg=All_subgoals_hyp;isgintro="rewrite"}) + ltree) + ] +;; + +let natural_ntree_path ig g = + Random.init(0); + natural_ntree ig g +;; + +let show_proof lang gpath = + (match lang with + "fr" -> natural_language:=French + |"en" -> natural_language:=English + | _ -> natural_language:=English); + path:=List.rev gpath; + name_count:=0; + let ntree=(get_nproof ()) in + let {t_info=i;t_goal=g;t_proof=p} =ntree in + root_of_text_proof + (sph [(natural_ntree_path {ihsg=All_subgoals_hyp; + isgintro="standard"} + {t_info="not_proved";t_goal=g;t_proof=p}); + spr]) + ;; + +let show_nproof path = + pp (sp_print (sph [spi; show_proof "fr" path]));; + +vinterp_add "ShowNaturalProof" + (fun _ -> + (fun () ->show_nproof[];()));; + +(*********************************************************************** +debug sous cygwin: + +PATH=/usr/local/bin:/usr/bin:$PATH +COQTOP=d:/Tools/coq-7avril +CAMLLIB=/usr/local/lib/ocaml +CAMLP4LIB=/usr/local/lib/camlp4 +export CAMLLIB +export COQTOP +export CAMLP4LIB +cd d:/Tools/pcoq/src/text +d:/Tools/coq-7avril/bin/coqtop.byte.exe -I /cygdrive/D/Tools/pcoq/src/abs_syntax -I /cygdrive/D/Tools/pcoq/src/text -I /cygdrive/D/Tools/pcoq/src/coq -I /cygdrive/D/Tools/pcoq/src/pbp -I /cygdrive/D/Tools/pcoq/src/dad -I /cygdrive/D/Tools/pcoq/src/history + + + +Lemma l1: (A, B : Prop) A \/ B -> B -> A. +Intros. +Elim H. +Auto. +Qed. + + +Drop. + +#use "/cygdrive/D/Tools/coq-7avril/dev/base_include";; +#load "xlate.cmo";; +#load "translate.cmo";; +#load "showproof_ct.cmo";; +#load "showproof.cmo";; +#load "pbp.cmo";; +#load "debug_tac.cmo";; +#load "name_to_ast.cmo";; +#load "paths.cmo";; +#load "dad.cmo";; +#load "vtp.cmo";; +#load "history.cmo";; +#load "centaur.cmo";; +Xlate.set_xlate_mut_stuff Centaur.globcv;; +Xlate.declare_in_coq();; + +#use "showproof.ml";; + +let pproof x = pP (sp_print x);; +Pp_control.set_depth_boxes 100;; +#install_printer pproof;; + +ep();; +let bidon = ref (constr_of_string "O");; + +#trace to_nproof;; +***********************************************************************) +let ep()=show_proof "fr" [];; diff --git a/contrib/interface/showproof.mli b/contrib/interface/showproof.mli new file mode 100755 index 00000000..ee269458 --- /dev/null +++ b/contrib/interface/showproof.mli @@ -0,0 +1,23 @@ +open Environ +open Evd +open Names +open Term +open Util +open Proof_type +open Coqast +open Pfedit +open Translate +open Term +open Reduction +open Clenv +open Typing +open Inductive +open Vernacinterp +open Declarations +open Showproof_ct +open Proof_trees +open Sign +open Pp +open Printer + +val show_proof : string -> int list -> Ascent.ct_TEXT;; diff --git a/contrib/interface/showproof_ct.ml b/contrib/interface/showproof_ct.ml new file mode 100644 index 00000000..ee901c5e --- /dev/null +++ b/contrib/interface/showproof_ct.ml @@ -0,0 +1,185 @@ +(*****************************************************************************) +(* + Vers Ctcoq +*) + +open Esyntax +open Metasyntax +open Printer +open Pp +open Translate +open Ascent +open Vtp +open Xlate + +let ct_text x = CT_coerce_ID_to_TEXT (CT_ident x);; + +let sps s = + ct_text s + ;; + + +let sphs s = + ct_text s + ;; + +let spe = sphs "";; +let spb = sps " ";; +let spr = sps "Retour chariot pour Show proof";; + +let spnb n = + let s = ref "" in + for i=1 to n do s:=(!s)^" "; done; sps !s +;; + + +let rec spclean l = + match l with + [] -> [] + |x::l -> if x=spe then (spclean l) else x::(spclean l) +;; + + +let spnb n = + let s = ref "" in + for i=1 to n do s:=(!s)^" "; done; sps !s +;; + +let ct_FORMULA_constr = Hashtbl.create 50;; + +let stde() = (Global.env()) + +;; + +let spt t = + let f = (translate_constr true (stde()) t) in + Hashtbl.add ct_FORMULA_constr f t; + CT_text_formula f +;; + + + +let root_of_text_proof t= + CT_text_op [ct_text "root_of_text_proof"; + t] + ;; + +let spshrink info t = + CT_text_op [ct_text "shrink"; + CT_text_op [ct_text info; + t]] +;; + +let spuselemma intro x y = + CT_text_op [ct_text "uselemma"; + ct_text intro; + x;y] +;; + +let sptoprove p t = + CT_text_op [ct_text "to_prove"; + CT_text_path p; + ct_text "goal"; + (spt t)] +;; +let sphyp p h t = + CT_text_op [ct_text "hyp"; + CT_text_path p; + ct_text h; + (spt t)] +;; +let sphypt p h t = + CT_text_op [ct_text "hyp_with_type"; + CT_text_path p; + ct_text h; + (spt t)] +;; + +let spwithtac x t = + CT_text_op [ct_text "with_tactic"; + ct_text t; + x] +;; + + +let spv l = + let l= spclean l in + CT_text_v l +;; + +let sph l = + let l= spclean l in + CT_text_h l +;; + + +let sphv l = + let l= spclean l in + CT_text_hv l +;; + +let rec prlist_with_sep f g l = + match l with + [] -> hov 0 (mt ()) + |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1)) +;; + +let rec sp_print x = + match x with + | CT_coerce_ID_to_TEXT (CT_ident s) + -> (match s with + | "\n" -> fnl () + | "Retour chariot pour Show proof" -> fnl () + |_ -> str s) + | CT_text_formula f -> prterm (Hashtbl.find ct_FORMULA_constr f) + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "to_prove"); + CT_text_path (CT_signed_int_list p); + CT_coerce_ID_to_TEXT (CT_ident "goal"); + g] -> + let p=(List.map (fun y -> match y with + (CT_coerce_INT_to_SIGNED_INT + (CT_int x)) -> x + | _ -> raise (Failure "sp_print")) p) in + h 0 (str "<b>" ++ sp_print g ++ str "</b>") + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "uselemma"); + CT_coerce_ID_to_TEXT (CT_ident intro); + l;g] -> + h 0 (str ("<i>("^intro^" ") ++ sp_print l ++ str ")</i>" ++ sp_print g) + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp"); + CT_text_path (CT_signed_int_list p); + CT_coerce_ID_to_TEXT (CT_ident hyp); + g] -> + let p=(List.map (fun y -> match y with + (CT_coerce_INT_to_SIGNED_INT + (CT_int x)) -> x + | _ -> raise (Failure "sp_print")) p) in + h 0 (str hyp) + + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "hyp_with_type"); + CT_text_path (CT_signed_int_list p); + CT_coerce_ID_to_TEXT (CT_ident hyp); + g] -> + let p=(List.map (fun y -> match y with + (CT_coerce_INT_to_SIGNED_INT + (CT_int x)) -> x + | _ -> raise (Failure "sp_print")) p) in + h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>") + + | CT_text_h l -> + h 0 (prlist_with_sep (fun () -> mt ()) + (fun y -> sp_print y) l) + | CT_text_v l -> + v 0 (prlist_with_sep (fun () -> mt ()) + (fun y -> sp_print y) l) + | CT_text_hv l -> + h 0 (prlist_with_sep (fun () -> mt ()) + (fun y -> sp_print y) l) + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "shrink"); + CT_text_op [CT_coerce_ID_to_TEXT (CT_ident info); t]] -> + h 0 (str ("("^info^": ") ++ sp_print t ++ str ")") + | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof"); + t]-> + sp_print t + | _ -> str "..." +;; + diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml new file mode 100644 index 00000000..e63baecf --- /dev/null +++ b/contrib/interface/translate.ml @@ -0,0 +1,165 @@ +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;; +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);; + +(*translates a named_context into a centaur-tree --> PREMISES_LIST *) +(* this code is inspired from printer.ml (function pr_named_context_of) *) +let translate_sign env = + let l = + Environ.fold_named_context + (fun env (id,v,c) l -> + (match v with + None -> + CT_premise(CT_ident(string_of_id id), translate_constr false env c) + | Some v1 -> + CT_eval_result + (CT_coerce_ID_to_FORMULA (CT_ident (string_of_id id)), + translate_constr false env v1, + translate_constr false env c))::l) + env ~init:[] + in + CT_premises_list l;; + +(* the function rev_and_compact performs two operations: + 1- it reverses the list of integers given as argument + 2- it replaces sequences of "1" by a negative number that is + the length of the sequence. *) +let rec rev_and_compact l = function + [] -> l + | 1::tl -> + (match l with + n::tl' -> + if n < 0 then + rev_and_compact ((n - 1)::tl') tl + else + rev_and_compact ((-1)::l) tl + | [] -> rev_and_compact [-1] tl) + | a::tl -> + if a < 0 then + (match l with + n::tl' -> + if n < 0 then + rev_and_compact ((n + a)::tl') tl + else + rev_and_compact (a::l) tl + | [] -> rev_and_compact (a::l) tl) + else + rev_and_compact (a::l) tl;; + +(*translates an int list into a centaur-tree --> SIGNED_INT_LIST *) +let translate_path l = + CT_signed_int_list + (List.map (function n -> CT_coerce_INT_to_SIGNED_INT (CT_int n)) + (rev_and_compact [] l));; + +(*translates a path and a goal into a centaur-tree --> RULE *) +let translate_goal (g:goal) = + CT_rule(translate_sign (evar_env g), translate_constr true (evar_env g) g.evar_concl);; diff --git a/contrib/interface/translate.mli b/contrib/interface/translate.mli new file mode 100644 index 00000000..65d8331b --- /dev/null +++ b/contrib/interface/translate.mli @@ -0,0 +1,11 @@ +open Ascent;; +open Evd;; +open Proof_type;; +open Environ;; +open Term;; + +val translate_goal : goal -> ct_RULE;; +(* The boolean argument indicates whether names from the environment should *) +(* be avoided (same interpretation as for prterm_env and ast_of_constr) *) +val translate_constr : bool -> env -> constr -> ct_FORMULA;; +val translate_path : int list -> ct_SIGNED_INT_LIST;; diff --git a/contrib/interface/vernacrc b/contrib/interface/vernacrc new file mode 100644 index 00000000..42b5e5ab --- /dev/null +++ b/contrib/interface/vernacrc @@ -0,0 +1,12 @@ +# $Id: vernacrc,v 1.3 2004/01/14 14:52:59 bertot Exp $ + +# This file is loaded initially by ./vernacparser. + +load_syntax_file 1 Notations +load_syntax_file 2 Logic +load_syntax_file 34 Omega +load_syntax_file 27 Ring +quiet_parse_string +Goal a. +&& END--OF--DATA +print_version diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml new file mode 100644 index 00000000..ff418523 --- /dev/null +++ b/contrib/interface/vtp.ml @@ -0,0 +1,1915 @@ +open Ascent;; + +let fNODE s n = + print_string "n\n"; + print_string ("vernac$" ^ s); + print_string "\n"; + print_int n; + print_string "\n";; + +let fATOM s1 = + print_string "a\n"; + print_string ("vernac$" ^ s1); + print_string "\n";; + +let f_atom_string = print_string;; +let f_atom_int = print_int;; +let rec fAST = function +| CT_coerce_ID_OR_INT_to_AST x -> fID_OR_INT x +| CT_coerce_ID_OR_STRING_to_AST x -> fID_OR_STRING x +| CT_coerce_SINGLE_OPTION_VALUE_to_AST x -> fSINGLE_OPTION_VALUE x +| CT_astnode(x1, x2) -> + fID x1; + fAST_LIST x2; + fNODE "astnode" 2 +| CT_astpath(x1) -> + fID_LIST x1; + fNODE "astpath" 1 +| CT_astslam(x1, x2) -> + fID_OPT x1; + fAST x2; + fNODE "astslam" 2 +and fAST_LIST = function +| CT_ast_list l -> + (List.iter fAST l); + fNODE "ast_list" (List.length l) +and fBINARY = function +| CT_binary x -> fATOM "binary"; + (f_atom_int x); + print_string "\n"and fBINDER = function +| CT_coerce_DEF_to_BINDER x -> fDEF x +| CT_binder(x1, x2) -> + fID_OPT_NE_LIST x1; + fFORMULA x2; + fNODE "binder" 2 +| CT_binder_coercion(x1, x2) -> + fID_OPT_NE_LIST x1; + fFORMULA x2; + fNODE "binder_coercion" 2 +and fBINDER_LIST = function +| CT_binder_list l -> + (List.iter fBINDER l); + fNODE "binder_list" (List.length l) +and fBINDER_NE_LIST = function +| CT_binder_ne_list(x,l) -> + fBINDER x; + (List.iter fBINDER l); + fNODE "binder_ne_list" (1 + (List.length l)) +and fBINDING = function +| CT_binding(x1, x2) -> + fID_OR_INT x1; + fFORMULA x2; + fNODE "binding" 2 +and fBINDING_LIST = function +| CT_binding_list l -> + (List.iter fBINDING l); + fNODE "binding_list" (List.length l) +and fBOOL = function +| CT_false -> fNODE "false" 0 +| CT_true -> fNODE "true" 0 +and fCASE = function +| CT_case x -> fATOM "case"; + (f_atom_string x); + print_string "\n"and fCLAUSE = function +| CT_clause(x1, x2) -> + fHYP_LOCATION_LIST_OR_STAR x1; + fSTAR_OPT x2; + fNODE "clause" 2 +and fCOERCION_OPT = function +| CT_coerce_NONE_to_COERCION_OPT x -> fNONE x +| CT_coercion_atm -> fNODE "coercion_atm" 0 +and fCOFIXTAC = function +| CT_cofixtac(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "cofixtac" 2 +and fCOFIX_REC = function +| CT_cofix_rec(x1, x2, x3, x4) -> + fID x1; + fBINDER_LIST x2; + fFORMULA x3; + fFORMULA x4; + fNODE "cofix_rec" 4 +and fCOFIX_REC_LIST = function +| CT_cofix_rec_list(x,l) -> + fCOFIX_REC x; + (List.iter fCOFIX_REC l); + fNODE "cofix_rec_list" (1 + (List.length l)) +and fCOFIX_TAC_LIST = function +| CT_cofix_tac_list l -> + (List.iter fCOFIXTAC l); + fNODE "cofix_tac_list" (List.length l) +and fCOMMAND = function +| CT_coerce_COMMAND_LIST_to_COMMAND x -> fCOMMAND_LIST x +| CT_coerce_EVAL_CMD_to_COMMAND x -> fEVAL_CMD x +| CT_coerce_SECTION_BEGIN_to_COMMAND x -> fSECTION_BEGIN x +| CT_coerce_THEOREM_GOAL_to_COMMAND x -> fTHEOREM_GOAL x +| CT_abort(x1) -> + fID_OPT_OR_ALL x1; + fNODE "abort" 1 +| CT_abstraction(x1, x2, x3) -> + fID x1; + fFORMULA x2; + fINT_LIST x3; + fNODE "abstraction" 3 +| CT_add_field(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) -> + fFORMULA x1; + fFORMULA x2; + fFORMULA x3; + fFORMULA x4; + fFORMULA x5; + fFORMULA x6; + fFORMULA x7; + fFORMULA x8; + fFORMULA x9; + fFORMULA x10; + fBINDING_LIST x11; + fNODE "add_field" 11 +| CT_add_natural_feature(x1, x2) -> + fNATURAL_FEATURE x1; + fID x2; + fNODE "add_natural_feature" 2 +| CT_addpath(x1, x2) -> + fSTRING x1; + fID_OPT x2; + fNODE "addpath" 2 +| CT_arguments_scope(x1, x2) -> + fID x1; + fID_OPT_LIST x2; + fNODE "arguments_scope" 2 +| CT_bind_scope(x1, x2) -> + fID x1; + fID_NE_LIST x2; + fNODE "bind_scope" 2 +| CT_cd(x1) -> + fSTRING_OPT x1; + fNODE "cd" 1 +| CT_check(x1) -> + fFORMULA x1; + fNODE "check" 1 +| CT_class(x1) -> + fID x1; + fNODE "class" 1 +| CT_close_scope(x1) -> + fID x1; + fNODE "close_scope" 1 +| CT_coercion(x1, x2, x3, x4, x5) -> + fLOCAL_OPT x1; + fIDENTITY_OPT x2; + fID x3; + fID x4; + fID x5; + fNODE "coercion" 5 +| CT_cofix_decl(x1) -> + fCOFIX_REC_LIST x1; + fNODE "cofix_decl" 1 +| CT_compile_module(x1, x2, x3) -> + fVERBOSE_OPT x1; + fID x2; + fSTRING_OPT x3; + fNODE "compile_module" 3 +| CT_declare_module(x1, x2, x3, x4) -> + fID x1; + fMODULE_BINDER_LIST x2; + fMODULE_TYPE_CHECK x3; + fMODULE_EXPR x4; + fNODE "declare_module" 4 +| CT_define_notation(x1, x2, x3, x4) -> + fSTRING x1; + fFORMULA x2; + fMODIFIER_LIST x3; + fID_OPT x4; + fNODE "define_notation" 4 +| CT_definition(x1, x2, x3, x4, x5) -> + fDEFN x1; + fID x2; + fBINDER_LIST x3; + fDEF_BODY x4; + fFORMULA_OPT x5; + fNODE "definition" 5 +| CT_delim_scope(x1, x2) -> + fID x1; + fID x2; + fNODE "delim_scope" 2 +| CT_delpath(x1) -> + fSTRING x1; + fNODE "delpath" 1 +| CT_derive_depinversion(x1, x2, x3, x4) -> + fINV_TYPE x1; + fID x2; + fFORMULA x3; + fSORT_TYPE x4; + fNODE "derive_depinversion" 4 +| CT_derive_inversion(x1, x2, x3, x4) -> + fINV_TYPE x1; + fINT_OPT x2; + fID x3; + fID x4; + fNODE "derive_inversion" 4 +| CT_derive_inversion_with(x1, x2, x3, x4) -> + fINV_TYPE x1; + fID x2; + fFORMULA x3; + fSORT_TYPE x4; + fNODE "derive_inversion_with" 4 +| CT_explain_proof(x1) -> + fINT_LIST x1; + fNODE "explain_proof" 1 +| CT_explain_prooftree(x1) -> + fINT_LIST x1; + fNODE "explain_prooftree" 1 +| CT_export_id(x1) -> + fID_NE_LIST x1; + fNODE "export_id" 1 +| CT_extract_to_file(x1, x2) -> + fSTRING x1; + fID_NE_LIST x2; + fNODE "extract_to_file" 2 +| CT_extraction(x1) -> + fID_OPT x1; + fNODE "extraction" 1 +| CT_fix_decl(x1) -> + fFIX_REC_LIST x1; + fNODE "fix_decl" 1 +| CT_focus(x1) -> + fINT_OPT x1; + fNODE "focus" 1 +| CT_go(x1) -> + fINT_OR_LOCN x1; + fNODE "go" 1 +| CT_guarded -> fNODE "guarded" 0 +| CT_hint_destruct(x1, x2, x3, x4, x5, x6) -> + fID x1; + fINT x2; + fDESTRUCT_LOCATION x3; + fFORMULA x4; + fTACTIC_COM x5; + fID_LIST x6; + fNODE "hint_destruct" 6 +| CT_hint_extern(x1, x2, x3, x4) -> + fINT x1; + fFORMULA x2; + fTACTIC_COM x3; + fID_LIST x4; + fNODE "hint_extern" 4 +| CT_hintrewrite(x1, x2, x3, x4) -> + fORIENTATION x1; + fFORMULA_NE_LIST x2; + fID x3; + fTACTIC_COM x4; + fNODE "hintrewrite" 4 +| CT_hints(x1, x2, x3) -> + fID x1; + fID_NE_LIST x2; + fID_LIST x3; + fNODE "hints" 3 +| CT_hints_immediate(x1, x2) -> + fFORMULA_NE_LIST x1; + fID_LIST x2; + fNODE "hints_immediate" 2 +| CT_hints_resolve(x1, x2) -> + fFORMULA_NE_LIST x1; + fID_LIST x2; + fNODE "hints_resolve" 2 +| CT_hyp_search_pattern(x1, x2) -> + fFORMULA x1; + fIN_OR_OUT_MODULES x2; + fNODE "hyp_search_pattern" 2 +| CT_implicits(x1, x2) -> + fID x1; + fID_LIST_OPT x2; + fNODE "implicits" 2 +| CT_import_id(x1) -> + fID_NE_LIST x1; + fNODE "import_id" 1 +| CT_ind_scheme(x1) -> + fSCHEME_SPEC_LIST x1; + fNODE "ind_scheme" 1 +| CT_infix(x1, x2, x3, x4) -> + fSTRING x1; + fID x2; + fMODIFIER_LIST x3; + fID_OPT x4; + fNODE "infix" 4 +| CT_inline(x1) -> + fID_NE_LIST x1; + fNODE "inline" 1 +| CT_inspect(x1) -> + fINT x1; + fNODE "inspect" 1 +| CT_kill_node(x1) -> + fINT x1; + fNODE "kill_node" 1 +| CT_load(x1, x2) -> + fVERBOSE_OPT x1; + fID_OR_STRING x2; + fNODE "load" 2 +| CT_local_close_scope(x1) -> + fID x1; + fNODE "local_close_scope" 1 +| CT_local_define_notation(x1, x2, x3, x4) -> + fSTRING x1; + fFORMULA x2; + fMODIFIER_LIST x3; + fID_OPT x4; + fNODE "local_define_notation" 4 +| CT_local_hint_destruct(x1, x2, x3, x4, x5, x6) -> + fID x1; + fINT x2; + fDESTRUCT_LOCATION x3; + fFORMULA x4; + fTACTIC_COM x5; + fID_LIST x6; + fNODE "local_hint_destruct" 6 +| CT_local_hint_extern(x1, x2, x3, x4) -> + fINT x1; + fFORMULA x2; + fTACTIC_COM x3; + fID_LIST x4; + fNODE "local_hint_extern" 4 +| CT_local_hints(x1, x2, x3) -> + fID x1; + fID_NE_LIST x2; + fID_LIST x3; + fNODE "local_hints" 3 +| CT_local_hints_immediate(x1, x2) -> + fFORMULA_NE_LIST x1; + fID_LIST x2; + fNODE "local_hints_immediate" 2 +| CT_local_hints_resolve(x1, x2) -> + fFORMULA_NE_LIST x1; + fID_LIST x2; + fNODE "local_hints_resolve" 2 +| CT_local_infix(x1, x2, x3, x4) -> + fSTRING x1; + fID x2; + fMODIFIER_LIST x3; + fID_OPT x4; + fNODE "local_infix" 4 +| CT_local_open_scope(x1) -> + fID x1; + fNODE "local_open_scope" 1 +| CT_local_reserve_notation(x1, x2) -> + fSTRING x1; + fMODIFIER_LIST x2; + fNODE "local_reserve_notation" 2 +| CT_locate(x1) -> + fID x1; + fNODE "locate" 1 +| CT_locate_file(x1) -> + fSTRING x1; + fNODE "locate_file" 1 +| CT_locate_lib(x1) -> + fID x1; + fNODE "locate_lib" 1 +| CT_locate_notation(x1) -> + fSTRING x1; + fNODE "locate_notation" 1 +| CT_mind_decl(x1, x2) -> + fCO_IND x1; + fIND_SPEC_LIST x2; + fNODE "mind_decl" 2 +| CT_ml_add_path(x1) -> + fSTRING x1; + fNODE "ml_add_path" 1 +| CT_ml_declare_modules(x1) -> + fSTRING_NE_LIST x1; + fNODE "ml_declare_modules" 1 +| CT_ml_print_modules -> fNODE "ml_print_modules" 0 +| CT_ml_print_path -> fNODE "ml_print_path" 0 +| CT_module(x1, x2, x3, x4) -> + fID x1; + fMODULE_BINDER_LIST x2; + fMODULE_TYPE_CHECK x3; + fMODULE_EXPR x4; + fNODE "module" 4 +| CT_module_type_decl(x1, x2, x3) -> + fID x1; + fMODULE_BINDER_LIST x2; + fMODULE_TYPE_OPT x3; + fNODE "module_type_decl" 3 +| CT_no_inline(x1) -> + fID_NE_LIST x1; + fNODE "no_inline" 1 +| CT_omega_flag(x1, x2) -> + fOMEGA_MODE x1; + fOMEGA_FEATURE x2; + fNODE "omega_flag" 2 +| CT_opaque(x1) -> + fID_NE_LIST x1; + fNODE "opaque" 1 +| CT_open_scope(x1) -> + fID x1; + fNODE "open_scope" 1 +| CT_print -> fNODE "print" 0 +| CT_print_about(x1) -> + fID x1; + fNODE "print_about" 1 +| CT_print_all -> fNODE "print_all" 0 +| CT_print_classes -> fNODE "print_classes" 0 +| CT_print_coercions -> fNODE "print_coercions" 0 +| CT_print_grammar(x1) -> + fGRAMMAR x1; + fNODE "print_grammar" 1 +| CT_print_graph -> fNODE "print_graph" 0 +| CT_print_hint(x1) -> + fID_OPT x1; + fNODE "print_hint" 1 +| CT_print_hintdb(x1) -> + fID_OR_STAR x1; + fNODE "print_hintdb" 1 +| CT_print_id(x1) -> + fID x1; + fNODE "print_id" 1 +| CT_print_implicit(x1) -> + fID x1; + fNODE "print_implicit" 1 +| CT_print_loadpath -> fNODE "print_loadpath" 0 +| CT_print_module(x1) -> + fID x1; + fNODE "print_module" 1 +| CT_print_module_type(x1) -> + fID x1; + fNODE "print_module_type" 1 +| CT_print_modules -> fNODE "print_modules" 0 +| CT_print_natural(x1) -> + fID x1; + fNODE "print_natural" 1 +| CT_print_natural_feature(x1) -> + fNATURAL_FEATURE x1; + fNODE "print_natural_feature" 1 +| CT_print_opaqueid(x1) -> + fID x1; + fNODE "print_opaqueid" 1 +| CT_print_path(x1, x2) -> + fID x1; + fID x2; + fNODE "print_path" 2 +| CT_print_proof(x1) -> + fID x1; + fNODE "print_proof" 1 +| CT_print_scope(x1) -> + fID x1; + fNODE "print_scope" 1 +| CT_print_scopes -> fNODE "print_scopes" 0 +| CT_print_section(x1) -> + fID x1; + fNODE "print_section" 1 +| CT_print_states -> fNODE "print_states" 0 +| CT_print_tables -> fNODE "print_tables" 0 +| CT_print_universes(x1) -> + fSTRING_OPT x1; + fNODE "print_universes" 1 +| CT_print_visibility(x1) -> + fID_OPT x1; + fNODE "print_visibility" 1 +| CT_proof(x1) -> + fFORMULA x1; + fNODE "proof" 1 +| CT_proof_no_op -> fNODE "proof_no_op" 0 +| CT_proof_with(x1) -> + fTACTIC_COM x1; + fNODE "proof_with" 1 +| CT_pwd -> fNODE "pwd" 0 +| CT_quit -> fNODE "quit" 0 +| CT_read_module(x1) -> + fID x1; + fNODE "read_module" 1 +| CT_rec_ml_add_path(x1) -> + fSTRING x1; + fNODE "rec_ml_add_path" 1 +| CT_recaddpath(x1, x2) -> + fSTRING x1; + fID_OPT x2; + fNODE "recaddpath" 2 +| CT_record(x1, x2, x3, x4, x5, x6) -> + fCOERCION_OPT x1; + fID x2; + fBINDER_LIST x3; + fFORMULA x4; + fID_OPT x5; + fRECCONSTR_LIST x6; + fNODE "record" 6 +| CT_remove_natural_feature(x1, x2) -> + fNATURAL_FEATURE x1; + fID x2; + fNODE "remove_natural_feature" 2 +| CT_require(x1, x2, x3) -> + fIMPEXP x1; + fSPEC_OPT x2; + fID_NE_LIST_OR_STRING x3; + fNODE "require" 3 +| CT_reserve(x1, x2) -> + fID_NE_LIST x1; + fFORMULA x2; + fNODE "reserve" 2 +| CT_reserve_notation(x1, x2) -> + fSTRING x1; + fMODIFIER_LIST x2; + fNODE "reserve_notation" 2 +| CT_reset(x1) -> + fID x1; + fNODE "reset" 1 +| CT_reset_section(x1) -> + fID x1; + fNODE "reset_section" 1 +| CT_restart -> fNODE "restart" 0 +| CT_restore_state(x1) -> + fID x1; + fNODE "restore_state" 1 +| CT_resume(x1) -> + fID_OPT x1; + fNODE "resume" 1 +| CT_save(x1, x2) -> + fTHM_OPT x1; + fID_OPT x2; + fNODE "save" 2 +| CT_scomments(x1) -> + fSCOMMENT_CONTENT_LIST x1; + fNODE "scomments" 1 +| CT_search(x1, x2) -> + fID x1; + fIN_OR_OUT_MODULES x2; + fNODE "search" 2 +| CT_search_about(x1, x2) -> + fID_OR_STRING_NE_LIST x1; + fIN_OR_OUT_MODULES x2; + fNODE "search_about" 2 +| CT_search_pattern(x1, x2) -> + fFORMULA x1; + fIN_OR_OUT_MODULES x2; + fNODE "search_pattern" 2 +| CT_search_rewrite(x1, x2) -> + fFORMULA x1; + fIN_OR_OUT_MODULES x2; + fNODE "search_rewrite" 2 +| CT_section_end(x1) -> + fID x1; + fNODE "section_end" 1 +| CT_section_struct(x1, x2, x3) -> + fSECTION_BEGIN x1; + fSECTION_BODY x2; + fCOMMAND x3; + fNODE "section_struct" 3 +| CT_set_natural(x1) -> + fID x1; + fNODE "set_natural" 1 +| CT_set_natural_default -> fNODE "set_natural_default" 0 +| CT_set_option(x1) -> + fTABLE x1; + fNODE "set_option" 1 +| CT_set_option_value(x1, x2) -> + fTABLE x1; + fSINGLE_OPTION_VALUE x2; + fNODE "set_option_value" 2 +| CT_set_option_value2(x1, x2) -> + fTABLE x1; + fID_OR_STRING_NE_LIST x2; + fNODE "set_option_value2" 2 +| CT_sethyp(x1) -> + fINT x1; + fNODE "sethyp" 1 +| CT_setundo(x1) -> + fINT x1; + fNODE "setundo" 1 +| CT_show_existentials -> fNODE "show_existentials" 0 +| CT_show_goal(x1) -> + fINT_OPT x1; + fNODE "show_goal" 1 +| CT_show_implicit(x1) -> + fINT x1; + fNODE "show_implicit" 1 +| CT_show_intro -> fNODE "show_intro" 0 +| CT_show_intros -> fNODE "show_intros" 0 +| CT_show_node -> fNODE "show_node" 0 +| CT_show_proof -> fNODE "show_proof" 0 +| CT_show_proofs -> fNODE "show_proofs" 0 +| CT_show_script -> fNODE "show_script" 0 +| CT_show_tree -> fNODE "show_tree" 0 +| CT_solve(x1, x2, x3) -> + fINT x1; + fTACTIC_COM x2; + fDOTDOT_OPT x3; + fNODE "solve" 3 +| CT_suspend -> fNODE "suspend" 0 +| CT_syntax_macro(x1, x2, x3) -> + fID x1; + fFORMULA x2; + fINT_OPT x3; + fNODE "syntax_macro" 3 +| CT_tactic_definition(x1) -> + fTAC_DEF_NE_LIST x1; + fNODE "tactic_definition" 1 +| CT_test_natural_feature(x1, x2) -> + fNATURAL_FEATURE x1; + fID x2; + fNODE "test_natural_feature" 2 +| CT_theorem_struct(x1, x2) -> + fTHEOREM_GOAL x1; + fPROOF_SCRIPT x2; + fNODE "theorem_struct" 2 +| CT_time(x1) -> + fCOMMAND x1; + fNODE "time" 1 +| CT_transparent(x1) -> + fID_NE_LIST x1; + fNODE "transparent" 1 +| CT_undo(x1) -> + fINT_OPT x1; + fNODE "undo" 1 +| CT_unfocus -> fNODE "unfocus" 0 +| CT_unset_option(x1) -> + fTABLE x1; + fNODE "unset_option" 1 +| CT_unsethyp -> fNODE "unsethyp" 0 +| CT_unsetundo -> fNODE "unsetundo" 0 +| CT_user_vernac(x1, x2) -> + fID x1; + fVARG_LIST x2; + fNODE "user_vernac" 2 +| CT_variable(x1, x2) -> + fVAR x1; + fBINDER_NE_LIST x2; + fNODE "variable" 2 +| CT_write_module(x1, x2) -> + fID x1; + fSTRING_OPT x2; + fNODE "write_module" 2 +and fCOMMAND_LIST = function +| CT_command_list(x,l) -> + fCOMMAND x; + (List.iter fCOMMAND l); + fNODE "command_list" (1 + (List.length l)) +and fCOMMENT = function +| CT_comment x -> fATOM "comment"; + (f_atom_string x); + print_string "\n"and fCOMMENT_S = function +| CT_comment_s l -> + (List.iter fCOMMENT l); + fNODE "comment_s" (List.length l) +and fCONSTR = function +| CT_constr(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "constr" 2 +| CT_constr_coercion(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "constr_coercion" 2 +and fCONSTR_LIST = function +| CT_constr_list l -> + (List.iter fCONSTR l); + fNODE "constr_list" (List.length l) +and fCONTEXT_HYP_LIST = function +| CT_context_hyp_list l -> + (List.iter fPREMISE_PATTERN l); + fNODE "context_hyp_list" (List.length l) +and fCONTEXT_PATTERN = function +| CT_coerce_FORMULA_to_CONTEXT_PATTERN x -> fFORMULA x +| CT_context(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "context" 2 +and fCONTEXT_RULE = function +| CT_context_rule(x1, x2, x3) -> + fCONTEXT_HYP_LIST x1; + fCONTEXT_PATTERN x2; + fTACTIC_COM x3; + fNODE "context_rule" 3 +| CT_def_context_rule(x1) -> + fTACTIC_COM x1; + fNODE "def_context_rule" 1 +and fCONVERSION_FLAG = function +| CT_beta -> fNODE "beta" 0 +| CT_delta -> fNODE "delta" 0 +| CT_evar -> fNODE "evar" 0 +| CT_iota -> fNODE "iota" 0 +| CT_zeta -> fNODE "zeta" 0 +and fCONVERSION_FLAG_LIST = function +| CT_conversion_flag_list l -> + (List.iter fCONVERSION_FLAG l); + fNODE "conversion_flag_list" (List.length l) +and fCONV_SET = function +| CT_unf l -> + (List.iter fID l); + fNODE "unf" (List.length l) +| CT_unfbut l -> + (List.iter fID l); + fNODE "unfbut" (List.length l) +and fCO_IND = function +| CT_co_ind x -> fATOM "co_ind"; + (f_atom_string x); + print_string "\n"and fDECL_NOTATION_OPT = function +| CT_coerce_NONE_to_DECL_NOTATION_OPT x -> fNONE x +| CT_decl_notation(x1, x2, x3) -> + fSTRING x1; + fFORMULA x2; + fID_OPT x3; + fNODE "decl_notation" 3 +and fDEF = function +| CT_def(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "def" 2 +and fDEFN = function +| CT_defn x -> fATOM "defn"; + (f_atom_string x); + print_string "\n"and fDEFN_OR_THM = function +| CT_coerce_DEFN_to_DEFN_OR_THM x -> fDEFN x +| CT_coerce_THM_to_DEFN_OR_THM x -> fTHM x +and fDEF_BODY = function +| CT_coerce_CONTEXT_PATTERN_to_DEF_BODY x -> fCONTEXT_PATTERN x +| CT_coerce_EVAL_CMD_to_DEF_BODY x -> fEVAL_CMD x +| CT_type_of(x1) -> + fFORMULA x1; + fNODE "type_of" 1 +and fDEF_BODY_OPT = function +| CT_coerce_DEF_BODY_to_DEF_BODY_OPT x -> fDEF_BODY x +| CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT x -> fFORMULA_OPT x +and fDEP = function +| CT_dep x -> fATOM "dep"; + (f_atom_string x); + print_string "\n"and fDESTRUCTING = function +| CT_coerce_NONE_to_DESTRUCTING x -> fNONE x +| CT_destructing -> fNODE "destructing" 0 +and fDESTRUCT_LOCATION = function +| CT_conclusion_location -> fNODE "conclusion_location" 0 +| CT_discardable_hypothesis -> fNODE "discardable_hypothesis" 0 +| CT_hypothesis_location -> fNODE "hypothesis_location" 0 +and fDOTDOT_OPT = function +| CT_coerce_NONE_to_DOTDOT_OPT x -> fNONE x +| CT_dotdot -> fNODE "dotdot" 0 +and fEQN = function +| CT_eqn(x1, x2) -> + fMATCH_PATTERN_NE_LIST x1; + fFORMULA x2; + fNODE "eqn" 2 +and fEQN_LIST = function +| CT_eqn_list l -> + (List.iter fEQN l); + fNODE "eqn_list" (List.length l) +and fEVAL_CMD = function +| CT_eval(x1, x2, x3) -> + fINT_OPT x1; + fRED_COM x2; + fFORMULA x3; + fNODE "eval" 3 +and fFIXTAC = function +| CT_fixtac(x1, x2, x3) -> + fID x1; + fINT x2; + fFORMULA x3; + fNODE "fixtac" 3 +and fFIX_BINDER = function +| CT_coerce_FIX_REC_to_FIX_BINDER x -> fFIX_REC x +| CT_fix_binder(x1, x2, x3, x4) -> + fID x1; + fINT x2; + fFORMULA x3; + fFORMULA x4; + fNODE "fix_binder" 4 +and fFIX_BINDER_LIST = function +| CT_fix_binder_list(x,l) -> + fFIX_BINDER x; + (List.iter fFIX_BINDER l); + fNODE "fix_binder_list" (1 + (List.length l)) +and fFIX_REC = function +| CT_fix_rec(x1, x2, x3, x4, x5) -> + fID x1; + fBINDER_NE_LIST x2; + fID_OPT x3; + fFORMULA x4; + fFORMULA x5; + fNODE "fix_rec" 5 +and fFIX_REC_LIST = function +| CT_fix_rec_list(x,l) -> + fFIX_REC x; + (List.iter fFIX_REC l); + fNODE "fix_rec_list" (1 + (List.length l)) +and fFIX_TAC_LIST = function +| CT_fix_tac_list l -> + (List.iter fFIXTAC l); + fNODE "fix_tac_list" (List.length l) +and fFORMULA = function +| CT_coerce_BINARY_to_FORMULA x -> fBINARY x +| CT_coerce_ID_to_FORMULA x -> fID x +| CT_coerce_NUM_to_FORMULA x -> fNUM x +| CT_coerce_SORT_TYPE_to_FORMULA x -> fSORT_TYPE x +| CT_coerce_TYPED_FORMULA_to_FORMULA x -> fTYPED_FORMULA x +| CT_appc(x1, x2) -> + fFORMULA x1; + fFORMULA_NE_LIST x2; + fNODE "appc" 2 +| CT_arrowc(x1, x2) -> + fFORMULA x1; + fFORMULA x2; + fNODE "arrowc" 2 +| CT_bang(x1) -> + fFORMULA x1; + fNODE "bang" 1 +| CT_cases(x1, x2, x3) -> + fMATCHED_FORMULA_NE_LIST x1; + fFORMULA_OPT x2; + fEQN_LIST x3; + fNODE "cases" 3 +| CT_cofixc(x1, x2) -> + fID x1; + fCOFIX_REC_LIST x2; + fNODE "cofixc" 2 +| CT_elimc(x1, x2, x3, x4) -> + fCASE x1; + fFORMULA_OPT x2; + fFORMULA x3; + fFORMULA_LIST x4; + fNODE "elimc" 4 +| CT_existvarc -> fNODE "existvarc" 0 +| CT_fixc(x1, x2) -> + fID x1; + fFIX_BINDER_LIST x2; + fNODE "fixc" 2 +| CT_if(x1, x2, x3, x4) -> + fFORMULA x1; + fRETURN_INFO x2; + fFORMULA x3; + fFORMULA x4; + fNODE "if" 4 +| CT_inductive_let(x1, x2, x3, x4) -> + fFORMULA_OPT x1; + fID_OPT_NE_LIST x2; + fFORMULA x3; + fFORMULA x4; + fNODE "inductive_let" 4 +| CT_labelled_arg(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "labelled_arg" 2 +| CT_lambdac(x1, x2) -> + fBINDER_NE_LIST x1; + fFORMULA x2; + fNODE "lambdac" 2 +| CT_let_tuple(x1, x2, x3, x4) -> + fID_OPT_NE_LIST x1; + fRETURN_INFO x2; + fFORMULA x3; + fFORMULA x4; + fNODE "let_tuple" 4 +| CT_letin(x1, x2) -> + fDEF x1; + fFORMULA x2; + fNODE "letin" 2 +| CT_notation(x1, x2) -> + fSTRING x1; + fFORMULA_LIST x2; + fNODE "notation" 2 +| CT_num_encapsulator(x1, x2) -> + fNUM_TYPE x1; + fFORMULA x2; + fNODE "num_encapsulator" 2 +| CT_prodc(x1, x2) -> + fBINDER_NE_LIST x1; + fFORMULA x2; + fNODE "prodc" 2 +| CT_proj(x1, x2) -> + fFORMULA x1; + fFORMULA_NE_LIST x2; + fNODE "proj" 2 +and fFORMULA_LIST = function +| CT_formula_list l -> + (List.iter fFORMULA l); + fNODE "formula_list" (List.length l) +and fFORMULA_NE_LIST = function +| CT_formula_ne_list(x,l) -> + fFORMULA x; + (List.iter fFORMULA l); + fNODE "formula_ne_list" (1 + (List.length l)) +and fFORMULA_OPT = function +| CT_coerce_FORMULA_to_FORMULA_OPT x -> fFORMULA x +| CT_coerce_ID_OPT_to_FORMULA_OPT x -> fID_OPT x +and fFORMULA_OR_INT = function +| CT_coerce_FORMULA_to_FORMULA_OR_INT x -> fFORMULA x +| CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x -> fID_OR_INT x +and fGRAMMAR = function +| CT_grammar_none -> fNODE "grammar_none" 0 +and fHYP_LOCATION = function +| CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x +| CT_intype(x1, x2) -> + fID x1; + fINT_LIST x2; + fNODE "intype" 2 +| CT_invalue(x1, x2) -> + fID x1; + fINT_LIST x2; + fNODE "invalue" 2 +and fHYP_LOCATION_LIST_OR_STAR = function +| CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR x -> fSTAR x +| CT_hyp_location_list l -> + (List.iter fHYP_LOCATION l); + fNODE "hyp_location_list" (List.length l) +and fID = function +| CT_ident x -> fATOM "ident"; + (f_atom_string x); + print_string "\n"| CT_metac(x1) -> + fINT x1; + fNODE "metac" 1 +| CT_metaid x -> fATOM "metaid"; + (f_atom_string x); + print_string "\n"and fIDENTITY_OPT = function +| CT_coerce_NONE_to_IDENTITY_OPT x -> fNONE x +| CT_identity -> fNODE "identity" 0 +and fID_LIST = function +| CT_id_list l -> + (List.iter fID l); + fNODE "id_list" (List.length l) +and fID_LIST_LIST = function +| CT_id_list_list l -> + (List.iter fID_LIST l); + fNODE "id_list_list" (List.length l) +and fID_LIST_OPT = function +| CT_coerce_ID_LIST_to_ID_LIST_OPT x -> fID_LIST x +| CT_coerce_NONE_to_ID_LIST_OPT x -> fNONE x +and fID_NE_LIST = function +| CT_id_ne_list(x,l) -> + fID x; + (List.iter fID l); + fNODE "id_ne_list" (1 + (List.length l)) +and fID_NE_LIST_OR_STAR = function +| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR x -> fID_NE_LIST x +| CT_coerce_STAR_to_ID_NE_LIST_OR_STAR x -> fSTAR x +and fID_NE_LIST_OR_STRING = function +| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING x -> fID_NE_LIST x +| CT_coerce_STRING_to_ID_NE_LIST_OR_STRING x -> fSTRING x +and fID_OPT = function +| CT_coerce_ID_to_ID_OPT x -> fID x +| CT_coerce_NONE_to_ID_OPT x -> fNONE x +and fID_OPT_LIST = function +| CT_id_opt_list l -> + (List.iter fID_OPT l); + fNODE "id_opt_list" (List.length l) +and fID_OPT_NE_LIST = function +| CT_id_opt_ne_list(x,l) -> + fID_OPT x; + (List.iter fID_OPT l); + fNODE "id_opt_ne_list" (1 + (List.length l)) +and fID_OPT_OR_ALL = function +| CT_coerce_ID_OPT_to_ID_OPT_OR_ALL x -> fID_OPT x +| CT_all -> fNODE "all" 0 +and fID_OR_INT = function +| CT_coerce_ID_to_ID_OR_INT x -> fID x +| CT_coerce_INT_to_ID_OR_INT x -> fINT x +and fID_OR_INT_OPT = function +| CT_coerce_ID_OPT_to_ID_OR_INT_OPT x -> fID_OPT x +| CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT x -> fID_OR_INT x +| CT_coerce_INT_OPT_to_ID_OR_INT_OPT x -> fINT_OPT x +and fID_OR_STAR = function +| CT_coerce_ID_to_ID_OR_STAR x -> fID x +| CT_coerce_STAR_to_ID_OR_STAR x -> fSTAR x +and fID_OR_STRING = function +| CT_coerce_ID_to_ID_OR_STRING x -> fID x +| CT_coerce_STRING_to_ID_OR_STRING x -> fSTRING x +and fID_OR_STRING_NE_LIST = function +| CT_id_or_string_ne_list(x,l) -> + fID_OR_STRING x; + (List.iter fID_OR_STRING l); + fNODE "id_or_string_ne_list" (1 + (List.length l)) +and fIMPEXP = function +| CT_coerce_NONE_to_IMPEXP x -> fNONE x +| CT_export -> fNODE "export" 0 +| CT_import -> fNODE "import" 0 +and fIND_SPEC = function +| CT_ind_spec(x1, x2, x3, x4, x5) -> + fID x1; + fBINDER_LIST x2; + fFORMULA x3; + fCONSTR_LIST x4; + fDECL_NOTATION_OPT x5; + fNODE "ind_spec" 5 +and fIND_SPEC_LIST = function +| CT_ind_spec_list l -> + (List.iter fIND_SPEC l); + fNODE "ind_spec_list" (List.length l) +and fINT = function +| CT_int x -> fATOM "int"; + (f_atom_int x); + print_string "\n"and fINTRO_PATT = function +| CT_coerce_ID_to_INTRO_PATT x -> fID x +| CT_disj_pattern(x,l) -> + fINTRO_PATT_LIST x; + (List.iter fINTRO_PATT_LIST l); + fNODE "disj_pattern" (1 + (List.length l)) +and fINTRO_PATT_LIST = function +| CT_intro_patt_list l -> + (List.iter fINTRO_PATT l); + fNODE "intro_patt_list" (List.length l) +and fINTRO_PATT_OPT = function +| CT_coerce_ID_OPT_to_INTRO_PATT_OPT x -> fID_OPT x +| CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT x -> fINTRO_PATT x +and fINT_LIST = function +| CT_int_list l -> + (List.iter fINT l); + fNODE "int_list" (List.length l) +and fINT_NE_LIST = function +| CT_int_ne_list(x,l) -> + fINT x; + (List.iter fINT l); + fNODE "int_ne_list" (1 + (List.length l)) +and fINT_OPT = function +| CT_coerce_INT_to_INT_OPT x -> fINT x +| CT_coerce_NONE_to_INT_OPT x -> fNONE x +and fINT_OR_LOCN = function +| CT_coerce_INT_to_INT_OR_LOCN x -> fINT x +| CT_coerce_LOCN_to_INT_OR_LOCN x -> fLOCN x +and fINT_OR_NEXT = function +| CT_coerce_INT_to_INT_OR_NEXT x -> fINT x +| CT_next_level -> fNODE "next_level" 0 +and fINV_TYPE = function +| CT_inv_clear -> fNODE "inv_clear" 0 +| CT_inv_regular -> fNODE "inv_regular" 0 +| CT_inv_simple -> fNODE "inv_simple" 0 +and fIN_OR_OUT_MODULES = function +| CT_coerce_NONE_to_IN_OR_OUT_MODULES x -> fNONE x +| CT_in_modules(x1) -> + fID_NE_LIST x1; + fNODE "in_modules" 1 +| CT_out_modules(x1) -> + fID_NE_LIST x1; + fNODE "out_modules" 1 +and fLET_CLAUSE = function +| CT_let_clause(x1, x2, x3) -> + fID x1; + fTACTIC_OPT x2; + fLET_VALUE x3; + fNODE "let_clause" 3 +and fLET_CLAUSES = function +| CT_let_clauses(x,l) -> + fLET_CLAUSE x; + (List.iter fLET_CLAUSE l); + fNODE "let_clauses" (1 + (List.length l)) +and fLET_VALUE = function +| CT_coerce_DEF_BODY_to_LET_VALUE x -> fDEF_BODY x +| CT_coerce_TACTIC_COM_to_LET_VALUE x -> fTACTIC_COM x +and fLOCAL_OPT = function +| CT_coerce_NONE_to_LOCAL_OPT x -> fNONE x +| CT_local -> fNODE "local" 0 +and fLOCN = function +| CT_locn x -> fATOM "locn"; + (f_atom_string x); + print_string "\n"and fMATCHED_FORMULA = function +| CT_coerce_FORMULA_to_MATCHED_FORMULA x -> fFORMULA x +| CT_formula_as(x1, x2) -> + fFORMULA x1; + fID_OPT x2; + fNODE "formula_as" 2 +| CT_formula_as_in(x1, x2, x3) -> + fFORMULA x1; + fID_OPT x2; + fFORMULA x3; + fNODE "formula_as_in" 3 +| CT_formula_in(x1, x2) -> + fFORMULA x1; + fFORMULA x2; + fNODE "formula_in" 2 +and fMATCHED_FORMULA_NE_LIST = function +| CT_matched_formula_ne_list(x,l) -> + fMATCHED_FORMULA x; + (List.iter fMATCHED_FORMULA l); + fNODE "matched_formula_ne_list" (1 + (List.length l)) +and fMATCH_PATTERN = function +| CT_coerce_ID_OPT_to_MATCH_PATTERN x -> fID_OPT x +| CT_coerce_NUM_to_MATCH_PATTERN x -> fNUM x +| CT_pattern_app(x1, x2) -> + fMATCH_PATTERN x1; + fMATCH_PATTERN_NE_LIST x2; + fNODE "pattern_app" 2 +| CT_pattern_as(x1, x2) -> + fMATCH_PATTERN x1; + fID_OPT x2; + fNODE "pattern_as" 2 +| CT_pattern_delimitors(x1, x2) -> + fNUM_TYPE x1; + fMATCH_PATTERN x2; + fNODE "pattern_delimitors" 2 +| CT_pattern_notation(x1, x2) -> + fSTRING x1; + fMATCH_PATTERN_LIST x2; + fNODE "pattern_notation" 2 +and fMATCH_PATTERN_LIST = function +| CT_match_pattern_list l -> + (List.iter fMATCH_PATTERN l); + fNODE "match_pattern_list" (List.length l) +and fMATCH_PATTERN_NE_LIST = function +| CT_match_pattern_ne_list(x,l) -> + fMATCH_PATTERN x; + (List.iter fMATCH_PATTERN l); + fNODE "match_pattern_ne_list" (1 + (List.length l)) +and fMATCH_TAC_RULE = function +| CT_match_tac_rule(x1, x2) -> + fCONTEXT_PATTERN x1; + fLET_VALUE x2; + fNODE "match_tac_rule" 2 +and fMATCH_TAC_RULES = function +| CT_match_tac_rules(x,l) -> + fMATCH_TAC_RULE x; + (List.iter fMATCH_TAC_RULE l); + fNODE "match_tac_rules" (1 + (List.length l)) +and fMODIFIER = function +| CT_entry_type(x1, x2) -> + fID x1; + fID x2; + fNODE "entry_type" 2 +| CT_format(x1) -> + fSTRING x1; + fNODE "format" 1 +| CT_lefta -> fNODE "lefta" 0 +| CT_nona -> fNODE "nona" 0 +| CT_only_parsing -> fNODE "only_parsing" 0 +| CT_righta -> fNODE "righta" 0 +| CT_set_item_level(x1, x2) -> + fID_NE_LIST x1; + fINT_OR_NEXT x2; + fNODE "set_item_level" 2 +| CT_set_level(x1) -> + fINT x1; + fNODE "set_level" 1 +and fMODIFIER_LIST = function +| CT_modifier_list l -> + (List.iter fMODIFIER l); + fNODE "modifier_list" (List.length l) +and fMODULE_BINDER = function +| CT_module_binder(x1, x2) -> + fID_NE_LIST x1; + fMODULE_TYPE x2; + fNODE "module_binder" 2 +and fMODULE_BINDER_LIST = function +| CT_module_binder_list l -> + (List.iter fMODULE_BINDER l); + fNODE "module_binder_list" (List.length l) +and fMODULE_EXPR = function +| CT_coerce_ID_OPT_to_MODULE_EXPR x -> fID_OPT x +| CT_module_app(x1, x2) -> + fMODULE_EXPR x1; + fMODULE_EXPR x2; + fNODE "module_app" 2 +and fMODULE_TYPE = function +| CT_coerce_ID_to_MODULE_TYPE x -> fID x +| CT_module_type_with_def(x1, x2, x3) -> + fMODULE_TYPE x1; + fID x2; + fFORMULA x3; + fNODE "module_type_with_def" 3 +| CT_module_type_with_mod(x1, x2, x3) -> + fMODULE_TYPE x1; + fID x2; + fID x3; + fNODE "module_type_with_mod" 3 +and fMODULE_TYPE_CHECK = function +| CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK x -> fMODULE_TYPE_OPT x +| CT_only_check(x1) -> + fMODULE_TYPE x1; + fNODE "only_check" 1 +and fMODULE_TYPE_OPT = function +| CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x +| CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT x -> fMODULE_TYPE x +and fNATURAL_FEATURE = function +| CT_contractible -> fNODE "contractible" 0 +| CT_implicit -> fNODE "implicit" 0 +| CT_nat_transparent -> fNODE "nat_transparent" 0 +and fNONE = function +| CT_none -> fNODE "none" 0 +and fNUM = function +| CT_int_encapsulator x -> fATOM "int_encapsulator"; + (f_atom_string x); + print_string "\n"and fNUM_TYPE = function +| CT_num_type x -> fATOM "num_type"; + (f_atom_string x); + print_string "\n"and fOMEGA_FEATURE = function +| CT_coerce_STRING_to_OMEGA_FEATURE x -> fSTRING x +| CT_flag_action -> fNODE "flag_action" 0 +| CT_flag_system -> fNODE "flag_system" 0 +| CT_flag_time -> fNODE "flag_time" 0 +and fOMEGA_MODE = function +| CT_set -> fNODE "set" 0 +| CT_switch -> fNODE "switch" 0 +| CT_unset -> fNODE "unset" 0 +and fORIENTATION = function +| CT_lr -> fNODE "lr" 0 +| CT_rl -> fNODE "rl" 0 +and fPATTERN = function +| CT_pattern_occ(x1, x2) -> + fINT_LIST x1; + fFORMULA x2; + fNODE "pattern_occ" 2 +and fPATTERN_NE_LIST = function +| CT_pattern_ne_list(x,l) -> + fPATTERN x; + (List.iter fPATTERN l); + fNODE "pattern_ne_list" (1 + (List.length l)) +and fPATTERN_OPT = function +| CT_coerce_NONE_to_PATTERN_OPT x -> fNONE x +| CT_coerce_PATTERN_to_PATTERN_OPT x -> fPATTERN x +and fPREMISE = function +| CT_coerce_TYPED_FORMULA_to_PREMISE x -> fTYPED_FORMULA x +| CT_eval_result(x1, x2, x3) -> + fFORMULA x1; + fFORMULA x2; + fFORMULA x3; + fNODE "eval_result" 3 +| CT_premise(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "premise" 2 +and fPREMISES_LIST = function +| CT_premises_list l -> + (List.iter fPREMISE l); + fNODE "premises_list" (List.length l) +and fPREMISE_PATTERN = function +| CT_premise_pattern(x1, x2) -> + fID_OPT x1; + fCONTEXT_PATTERN x2; + fNODE "premise_pattern" 2 +and fPROOF_SCRIPT = function +| CT_proof_script l -> + (List.iter fCOMMAND l); + fNODE "proof_script" (List.length l) +and fRECCONSTR = function +| CT_defrecconstr(x1, x2, x3) -> + fID_OPT x1; + fFORMULA x2; + fFORMULA_OPT x3; + fNODE "defrecconstr" 3 +| CT_defrecconstr_coercion(x1, x2, x3) -> + fID_OPT x1; + fFORMULA x2; + fFORMULA_OPT x3; + fNODE "defrecconstr_coercion" 3 +| CT_recconstr(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "recconstr" 2 +| CT_recconstr_coercion(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "recconstr_coercion" 2 +and fRECCONSTR_LIST = function +| CT_recconstr_list l -> + (List.iter fRECCONSTR l); + fNODE "recconstr_list" (List.length l) +and fREC_TACTIC_FUN = function +| CT_rec_tactic_fun(x1, x2, x3) -> + fID x1; + fID_OPT_NE_LIST x2; + fTACTIC_COM x3; + fNODE "rec_tactic_fun" 3 +and fREC_TACTIC_FUN_LIST = function +| CT_rec_tactic_fun_list(x,l) -> + fREC_TACTIC_FUN x; + (List.iter fREC_TACTIC_FUN l); + fNODE "rec_tactic_fun_list" (1 + (List.length l)) +and fRED_COM = function +| CT_cbv(x1, x2) -> + fCONVERSION_FLAG_LIST x1; + fCONV_SET x2; + fNODE "cbv" 2 +| CT_fold(x1) -> + fFORMULA_LIST x1; + fNODE "fold" 1 +| CT_hnf -> fNODE "hnf" 0 +| CT_lazy(x1, x2) -> + fCONVERSION_FLAG_LIST x1; + fCONV_SET x2; + fNODE "lazy" 2 +| CT_pattern(x1) -> + fPATTERN_NE_LIST x1; + fNODE "pattern" 1 +| CT_red -> fNODE "red" 0 +| CT_simpl(x1) -> + fPATTERN_OPT x1; + fNODE "simpl" 1 +| CT_unfold(x1) -> + fUNFOLD_NE_LIST x1; + fNODE "unfold" 1 +and fRETURN_INFO = function +| CT_coerce_NONE_to_RETURN_INFO x -> fNONE x +| CT_as_and_return(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "as_and_return" 2 +| CT_return(x1) -> + fFORMULA x1; + fNODE "return" 1 +and fRULE = function +| CT_rule(x1, x2) -> + fPREMISES_LIST x1; + fFORMULA x2; + fNODE "rule" 2 +and fRULE_LIST = function +| CT_rule_list l -> + (List.iter fRULE l); + fNODE "rule_list" (List.length l) +and fSCHEME_SPEC = function +| CT_scheme_spec(x1, x2, x3, x4) -> + fID x1; + fDEP x2; + fFORMULA x3; + fSORT_TYPE x4; + fNODE "scheme_spec" 4 +and fSCHEME_SPEC_LIST = function +| CT_scheme_spec_list(x,l) -> + fSCHEME_SPEC x; + (List.iter fSCHEME_SPEC l); + fNODE "scheme_spec_list" (1 + (List.length l)) +and fSCOMMENT_CONTENT = function +| CT_coerce_FORMULA_to_SCOMMENT_CONTENT x -> fFORMULA x +| CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT x -> fID_OR_STRING x +and fSCOMMENT_CONTENT_LIST = function +| CT_scomment_content_list l -> + (List.iter fSCOMMENT_CONTENT l); + fNODE "scomment_content_list" (List.length l) +and fSECTION_BEGIN = function +| CT_section(x1) -> + fID x1; + fNODE "section" 1 +and fSECTION_BODY = function +| CT_section_body l -> + (List.iter fCOMMAND l); + fNODE "section_body" (List.length l) +and fSIGNED_INT = function +| CT_coerce_INT_to_SIGNED_INT x -> fINT x +| CT_minus(x1) -> + fINT x1; + fNODE "minus" 1 +and fSIGNED_INT_LIST = function +| CT_signed_int_list l -> + (List.iter fSIGNED_INT l); + fNODE "signed_int_list" (List.length l) +and fSINGLE_OPTION_VALUE = function +| CT_coerce_INT_to_SINGLE_OPTION_VALUE x -> fINT x +| CT_coerce_STRING_to_SINGLE_OPTION_VALUE x -> fSTRING x +and fSORT_TYPE = function +| CT_sortc x -> fATOM "sortc"; + (f_atom_string x); + print_string "\n"and fSPEC_LIST = function +| CT_coerce_BINDING_LIST_to_SPEC_LIST x -> fBINDING_LIST x +| CT_coerce_FORMULA_LIST_to_SPEC_LIST x -> fFORMULA_LIST x +and fSPEC_OPT = function +| CT_coerce_NONE_to_SPEC_OPT x -> fNONE x +| CT_spec -> fNODE "spec" 0 +and fSTAR = function +| CT_star -> fNODE "star" 0 +and fSTAR_OPT = function +| CT_coerce_NONE_to_STAR_OPT x -> fNONE x +| CT_coerce_STAR_to_STAR_OPT x -> fSTAR x +and fSTRING = function +| CT_string x -> fATOM "string"; + (f_atom_string x); + print_string "\n"and fSTRING_NE_LIST = function +| CT_string_ne_list(x,l) -> + fSTRING x; + (List.iter fSTRING l); + fNODE "string_ne_list" (1 + (List.length l)) +and fSTRING_OPT = function +| CT_coerce_NONE_to_STRING_OPT x -> fNONE x +| CT_coerce_STRING_to_STRING_OPT x -> fSTRING x +and fTABLE = function +| CT_coerce_ID_to_TABLE x -> fID x +| CT_table(x1, x2) -> + fID x1; + fID x2; + fNODE "table" 2 +and fTACTIC_ARG = function +| CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x +| CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG x -> fFORMULA_OR_INT x +| CT_coerce_TACTIC_COM_to_TACTIC_ARG x -> fTACTIC_COM x +| CT_coerce_TERM_CHANGE_to_TACTIC_ARG x -> fTERM_CHANGE x +| CT_void -> fNODE "void" 0 +and fTACTIC_ARG_LIST = function +| CT_tactic_arg_list(x,l) -> + fTACTIC_ARG x; + (List.iter fTACTIC_ARG l); + fNODE "tactic_arg_list" (1 + (List.length l)) +and fTACTIC_COM = function +| CT_abstract(x1, x2) -> + fID_OPT x1; + fTACTIC_COM x2; + fNODE "abstract" 2 +| CT_absurd(x1) -> + fFORMULA x1; + fNODE "absurd" 1 +| CT_any_constructor(x1) -> + fTACTIC_OPT x1; + fNODE "any_constructor" 1 +| CT_apply(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "apply" 2 +| CT_assert(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "assert" 2 +| CT_assumption -> fNODE "assumption" 0 +| CT_auto(x1) -> + fINT_OPT x1; + fNODE "auto" 1 +| CT_auto_with(x1, x2) -> + fINT_OPT x1; + fID_NE_LIST_OR_STAR x2; + fNODE "auto_with" 2 +| CT_autorewrite(x1, x2) -> + fID_NE_LIST x1; + fTACTIC_OPT x2; + fNODE "autorewrite" 2 +| CT_autotdb(x1) -> + fINT_OPT x1; + fNODE "autotdb" 1 +| CT_case_type(x1) -> + fFORMULA x1; + fNODE "case_type" 1 +| CT_casetac(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "casetac" 2 +| CT_cdhyp(x1) -> + fID x1; + fNODE "cdhyp" 1 +| CT_change(x1, x2) -> + fFORMULA x1; + fCLAUSE x2; + fNODE "change" 2 +| CT_change_local(x1, x2, x3) -> + fPATTERN x1; + fFORMULA x2; + fCLAUSE x3; + fNODE "change_local" 3 +| CT_clear(x1) -> + fID_NE_LIST x1; + fNODE "clear" 1 +| CT_clear_body(x1) -> + fID_NE_LIST x1; + fNODE "clear_body" 1 +| CT_cofixtactic(x1, x2) -> + fID_OPT x1; + fCOFIX_TAC_LIST x2; + fNODE "cofixtactic" 2 +| CT_condrewrite_lr(x1, x2, x3, x4) -> + fTACTIC_COM x1; + fFORMULA x2; + fSPEC_LIST x3; + fID_OPT x4; + fNODE "condrewrite_lr" 4 +| CT_condrewrite_rl(x1, x2, x3, x4) -> + fTACTIC_COM x1; + fFORMULA x2; + fSPEC_LIST x3; + fID_OPT x4; + fNODE "condrewrite_rl" 4 +| CT_constructor(x1, x2) -> + fINT x1; + fSPEC_LIST x2; + fNODE "constructor" 2 +| CT_contradiction -> fNODE "contradiction" 0 +| CT_contradiction_thm(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "contradiction_thm" 2 +| CT_cut(x1) -> + fFORMULA x1; + fNODE "cut" 1 +| CT_cutrewrite_lr(x1, x2) -> + fFORMULA x1; + fID_OPT x2; + fNODE "cutrewrite_lr" 2 +| CT_cutrewrite_rl(x1, x2) -> + fFORMULA x1; + fID_OPT x2; + fNODE "cutrewrite_rl" 2 +| CT_dauto(x1, x2) -> + fINT_OPT x1; + fINT_OPT x2; + fNODE "dauto" 2 +| CT_dconcl -> fNODE "dconcl" 0 +| CT_decompose_list(x1, x2) -> + fID_NE_LIST x1; + fFORMULA x2; + fNODE "decompose_list" 2 +| CT_decompose_record(x1) -> + fFORMULA x1; + fNODE "decompose_record" 1 +| CT_decompose_sum(x1) -> + fFORMULA x1; + fNODE "decompose_sum" 1 +| CT_depinversion(x1, x2, x3, x4) -> + fINV_TYPE x1; + fID_OR_INT x2; + fINTRO_PATT_OPT x3; + fFORMULA_OPT x4; + fNODE "depinversion" 4 +| CT_deprewrite_lr(x1) -> + fID x1; + fNODE "deprewrite_lr" 1 +| CT_deprewrite_rl(x1) -> + fID x1; + fNODE "deprewrite_rl" 1 +| CT_destruct(x1) -> + fID_OR_INT x1; + fNODE "destruct" 1 +| CT_dhyp(x1) -> + fID x1; + fNODE "dhyp" 1 +| CT_discriminate_eq(x1) -> + fID_OR_INT_OPT x1; + fNODE "discriminate_eq" 1 +| CT_do(x1, x2) -> + fID_OR_INT x1; + fTACTIC_COM x2; + fNODE "do" 2 +| CT_eapply(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "eapply" 2 +| CT_eauto(x1, x2) -> + fID_OR_INT_OPT x1; + fID_OR_INT_OPT x2; + fNODE "eauto" 2 +| CT_eauto_with(x1, x2, x3) -> + fID_OR_INT_OPT x1; + fID_OR_INT_OPT x2; + fID_NE_LIST_OR_STAR x3; + fNODE "eauto_with" 3 +| CT_elim(x1, x2, x3) -> + fFORMULA x1; + fSPEC_LIST x2; + fUSING x3; + fNODE "elim" 3 +| CT_elim_type(x1) -> + fFORMULA x1; + fNODE "elim_type" 1 +| CT_exact(x1) -> + fFORMULA x1; + fNODE "exact" 1 +| CT_exists(x1) -> + fSPEC_LIST x1; + fNODE "exists" 1 +| CT_fail(x1, x2) -> + fID_OR_INT x1; + fSTRING_OPT x2; + fNODE "fail" 2 +| CT_first(x,l) -> + fTACTIC_COM x; + (List.iter fTACTIC_COM l); + fNODE "first" (1 + (List.length l)) +| CT_firstorder(x1) -> + fTACTIC_OPT x1; + fNODE "firstorder" 1 +| CT_firstorder_using(x1, x2) -> + fTACTIC_OPT x1; + fID_NE_LIST x2; + fNODE "firstorder_using" 2 +| CT_firstorder_with(x1, x2) -> + fTACTIC_OPT x1; + fID_NE_LIST x2; + fNODE "firstorder_with" 2 +| CT_fixtactic(x1, x2, x3) -> + fID_OPT x1; + fINT x2; + fFIX_TAC_LIST x3; + fNODE "fixtactic" 3 +| CT_formula_marker(x1) -> + fFORMULA x1; + fNODE "formula_marker" 1 +| CT_fresh(x1) -> + fSTRING_OPT x1; + fNODE "fresh" 1 +| CT_generalize(x1) -> + fFORMULA_NE_LIST x1; + fNODE "generalize" 1 +| CT_generalize_dependent(x1) -> + fFORMULA x1; + fNODE "generalize_dependent" 1 +| CT_idtac(x1) -> + fSTRING_OPT x1; + fNODE "idtac" 1 +| CT_induction(x1) -> + fID_OR_INT x1; + fNODE "induction" 1 +| CT_info(x1) -> + fTACTIC_COM x1; + fNODE "info" 1 +| CT_injection_eq(x1) -> + fID_OR_INT_OPT x1; + fNODE "injection_eq" 1 +| CT_instantiate(x1, x2, x3) -> + fINT x1; + fFORMULA x2; + fCLAUSE x3; + fNODE "instantiate" 3 +| CT_intro(x1) -> + fID_OPT x1; + fNODE "intro" 1 +| CT_intro_after(x1, x2) -> + fID_OPT x1; + fID x2; + fNODE "intro_after" 2 +| CT_intros(x1) -> + fINTRO_PATT_LIST x1; + fNODE "intros" 1 +| CT_intros_until(x1) -> + fID_OR_INT x1; + fNODE "intros_until" 1 +| CT_inversion(x1, x2, x3, x4) -> + fINV_TYPE x1; + fID_OR_INT x2; + fINTRO_PATT_OPT x3; + fID_LIST x4; + fNODE "inversion" 4 +| CT_left(x1) -> + fSPEC_LIST x1; + fNODE "left" 1 +| CT_let_ltac(x1, x2) -> + fLET_CLAUSES x1; + fLET_VALUE x2; + fNODE "let_ltac" 2 +| CT_lettac(x1, x2, x3) -> + fID_OPT x1; + fFORMULA x2; + fCLAUSE x3; + fNODE "lettac" 3 +| CT_match_context(x,l) -> + fCONTEXT_RULE x; + (List.iter fCONTEXT_RULE l); + fNODE "match_context" (1 + (List.length l)) +| CT_match_context_reverse(x,l) -> + fCONTEXT_RULE x; + (List.iter fCONTEXT_RULE l); + fNODE "match_context_reverse" (1 + (List.length l)) +| CT_match_tac(x1, x2) -> + fTACTIC_COM x1; + fMATCH_TAC_RULES x2; + fNODE "match_tac" 2 +| CT_move_after(x1, x2) -> + fID x1; + fID x2; + fNODE "move_after" 2 +| CT_new_destruct(x1, x2, x3) -> + fFORMULA_OR_INT x1; + fUSING x2; + fINTRO_PATT_OPT x3; + fNODE "new_destruct" 3 +| CT_new_induction(x1, x2, x3) -> + fFORMULA_OR_INT x1; + fUSING x2; + fINTRO_PATT_OPT x3; + fNODE "new_induction" 3 +| CT_omega -> fNODE "omega" 0 +| CT_orelse(x1, x2) -> + fTACTIC_COM x1; + fTACTIC_COM x2; + fNODE "orelse" 2 +| CT_parallel(x,l) -> + fTACTIC_COM x; + (List.iter fTACTIC_COM l); + fNODE "parallel" (1 + (List.length l)) +| CT_pose(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "pose" 2 +| CT_progress(x1) -> + fTACTIC_COM x1; + fNODE "progress" 1 +| CT_prolog(x1, x2) -> + fFORMULA_LIST x1; + fINT x2; + fNODE "prolog" 2 +| CT_rec_tactic_in(x1, x2) -> + fREC_TACTIC_FUN_LIST x1; + fTACTIC_COM x2; + fNODE "rec_tactic_in" 2 +| CT_reduce(x1, x2) -> + fRED_COM x1; + fCLAUSE x2; + fNODE "reduce" 2 +| CT_refine(x1) -> + fFORMULA x1; + fNODE "refine" 1 +| CT_reflexivity -> fNODE "reflexivity" 0 +| CT_rename(x1, x2) -> + fID x1; + fID x2; + fNODE "rename" 2 +| CT_repeat(x1) -> + fTACTIC_COM x1; + fNODE "repeat" 1 +| CT_replace_with(x1, x2) -> + fFORMULA x1; + fFORMULA x2; + fNODE "replace_with" 2 +| CT_rewrite_lr(x1, x2, x3) -> + fFORMULA x1; + fSPEC_LIST x2; + fID_OPT x3; + fNODE "rewrite_lr" 3 +| CT_rewrite_rl(x1, x2, x3) -> + fFORMULA x1; + fSPEC_LIST x2; + fID_OPT x3; + fNODE "rewrite_rl" 3 +| CT_right(x1) -> + fSPEC_LIST x1; + fNODE "right" 1 +| CT_ring(x1) -> + fFORMULA_LIST x1; + fNODE "ring" 1 +| CT_simple_user_tac(x1, x2) -> + fID x1; + fTACTIC_ARG_LIST x2; + fNODE "simple_user_tac" 2 +| CT_simplify_eq(x1) -> + fID_OR_INT_OPT x1; + fNODE "simplify_eq" 1 +| CT_specialize(x1, x2, x3) -> + fINT_OPT x1; + fFORMULA x2; + fSPEC_LIST x3; + fNODE "specialize" 3 +| CT_split(x1) -> + fSPEC_LIST x1; + fNODE "split" 1 +| CT_subst(x1) -> + fID_LIST x1; + fNODE "subst" 1 +| CT_superauto(x1, x2, x3, x4) -> + fINT_OPT x1; + fID_LIST x2; + fDESTRUCTING x3; + fUSINGTDB x4; + fNODE "superauto" 4 +| CT_symmetry(x1) -> + fCLAUSE x1; + fNODE "symmetry" 1 +| CT_tac_double(x1, x2) -> + fID_OR_INT x1; + fID_OR_INT x2; + fNODE "tac_double" 2 +| CT_tacsolve(x,l) -> + fTACTIC_COM x; + (List.iter fTACTIC_COM l); + fNODE "tacsolve" (1 + (List.length l)) +| CT_tactic_fun(x1, x2) -> + fID_OPT_NE_LIST x1; + fTACTIC_COM x2; + fNODE "tactic_fun" 2 +| CT_then(x,l) -> + fTACTIC_COM x; + (List.iter fTACTIC_COM l); + fNODE "then" (1 + (List.length l)) +| CT_transitivity(x1) -> + fFORMULA x1; + fNODE "transitivity" 1 +| CT_trivial -> fNODE "trivial" 0 +| CT_trivial_with(x1) -> + fID_NE_LIST_OR_STAR x1; + fNODE "trivial_with" 1 +| CT_truecut(x1, x2) -> + fID_OPT x1; + fFORMULA x2; + fNODE "truecut" 2 +| CT_try(x1) -> + fTACTIC_COM x1; + fNODE "try" 1 +| CT_use(x1) -> + fFORMULA x1; + fNODE "use" 1 +| CT_use_inversion(x1, x2, x3) -> + fID_OR_INT x1; + fFORMULA x2; + fID_LIST x3; + fNODE "use_inversion" 3 +| CT_user_tac(x1, x2) -> + fID x1; + fTARG_LIST x2; + fNODE "user_tac" 2 +and fTACTIC_OPT = function +| CT_coerce_NONE_to_TACTIC_OPT x -> fNONE x +| CT_coerce_TACTIC_COM_to_TACTIC_OPT x -> fTACTIC_COM x +and fTAC_DEF = function +| CT_tac_def(x1, x2) -> + fID x1; + fTACTIC_COM x2; + fNODE "tac_def" 2 +and fTAC_DEF_NE_LIST = function +| CT_tac_def_ne_list(x,l) -> + fTAC_DEF x; + (List.iter fTAC_DEF l); + fNODE "tac_def_ne_list" (1 + (List.length l)) +and fTARG = function +| CT_coerce_BINDING_to_TARG x -> fBINDING x +| CT_coerce_COFIXTAC_to_TARG x -> fCOFIXTAC x +| CT_coerce_FIXTAC_to_TARG x -> fFIXTAC x +| CT_coerce_FORMULA_OR_INT_to_TARG x -> fFORMULA_OR_INT x +| CT_coerce_PATTERN_to_TARG x -> fPATTERN x +| CT_coerce_SCOMMENT_CONTENT_to_TARG x -> fSCOMMENT_CONTENT x +| CT_coerce_SIGNED_INT_LIST_to_TARG x -> fSIGNED_INT_LIST x +| CT_coerce_SINGLE_OPTION_VALUE_to_TARG x -> fSINGLE_OPTION_VALUE x +| CT_coerce_SPEC_LIST_to_TARG x -> fSPEC_LIST x +| CT_coerce_TACTIC_COM_to_TARG x -> fTACTIC_COM x +| CT_coerce_TARG_LIST_to_TARG x -> fTARG_LIST x +| CT_coerce_UNFOLD_to_TARG x -> fUNFOLD x +| CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x +and fTARG_LIST = function +| CT_targ_list l -> + (List.iter fTARG l); + fNODE "targ_list" (List.length l) +and fTERM_CHANGE = function +| CT_check_term(x1) -> + fFORMULA x1; + fNODE "check_term" 1 +| CT_inst_term(x1, x2) -> + fID x1; + fFORMULA x2; + fNODE "inst_term" 2 +and fTEXT = function +| CT_coerce_ID_to_TEXT x -> fID x +| CT_text_formula(x1) -> + fFORMULA x1; + fNODE "text_formula" 1 +| CT_text_h l -> + (List.iter fTEXT l); + fNODE "text_h" (List.length l) +| CT_text_hv l -> + (List.iter fTEXT l); + fNODE "text_hv" (List.length l) +| CT_text_op l -> + (List.iter fTEXT l); + fNODE "text_op" (List.length l) +| CT_text_path(x1) -> + fSIGNED_INT_LIST x1; + fNODE "text_path" 1 +| CT_text_v l -> + (List.iter fTEXT l); + fNODE "text_v" (List.length l) +and fTHEOREM_GOAL = function +| CT_goal(x1) -> + fFORMULA x1; + fNODE "goal" 1 +| CT_theorem_goal(x1, x2, x3, x4) -> + fDEFN_OR_THM x1; + fID x2; + fBINDER_LIST x3; + fFORMULA x4; + fNODE "theorem_goal" 4 +and fTHM = function +| CT_thm x -> fATOM "thm"; + (f_atom_string x); + print_string "\n"and fTHM_OPT = function +| CT_coerce_NONE_to_THM_OPT x -> fNONE x +| CT_coerce_THM_to_THM_OPT x -> fTHM x +and fTYPED_FORMULA = function +| CT_typed_formula(x1, x2) -> + fFORMULA x1; + fFORMULA x2; + fNODE "typed_formula" 2 +and fUNFOLD = function +| CT_coerce_ID_to_UNFOLD x -> fID x +| CT_unfold_occ(x1, x2) -> + fID x1; + fINT_NE_LIST x2; + fNODE "unfold_occ" 2 +and fUNFOLD_NE_LIST = function +| CT_unfold_ne_list(x,l) -> + fUNFOLD x; + (List.iter fUNFOLD l); + fNODE "unfold_ne_list" (1 + (List.length l)) +and fUSING = function +| CT_coerce_NONE_to_USING x -> fNONE x +| CT_using(x1, x2) -> + fFORMULA x1; + fSPEC_LIST x2; + fNODE "using" 2 +and fUSINGTDB = function +| CT_coerce_NONE_to_USINGTDB x -> fNONE x +| CT_usingtdb -> fNODE "usingtdb" 0 +and fVAR = function +| CT_var x -> fATOM "var"; + (f_atom_string x); + print_string "\n"and fVARG = function +| CT_coerce_AST_to_VARG x -> fAST x +| CT_coerce_AST_LIST_to_VARG x -> fAST_LIST x +| CT_coerce_BINDER_to_VARG x -> fBINDER x +| CT_coerce_BINDER_LIST_to_VARG x -> fBINDER_LIST x +| CT_coerce_BINDER_NE_LIST_to_VARG x -> fBINDER_NE_LIST x +| CT_coerce_FORMULA_LIST_to_VARG x -> fFORMULA_LIST x +| CT_coerce_FORMULA_OPT_to_VARG x -> fFORMULA_OPT x +| CT_coerce_FORMULA_OR_INT_to_VARG x -> fFORMULA_OR_INT x +| CT_coerce_ID_OPT_OR_ALL_to_VARG x -> fID_OPT_OR_ALL x +| CT_coerce_ID_OR_INT_OPT_to_VARG x -> fID_OR_INT_OPT x +| CT_coerce_INT_LIST_to_VARG x -> fINT_LIST x +| CT_coerce_SCOMMENT_CONTENT_to_VARG x -> fSCOMMENT_CONTENT x +| CT_coerce_STRING_OPT_to_VARG x -> fSTRING_OPT x +| CT_coerce_TACTIC_OPT_to_VARG x -> fTACTIC_OPT x +| CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x +and fVARG_LIST = function +| CT_varg_list l -> + (List.iter fVARG l); + fNODE "varg_list" (List.length l) +and fVERBOSE_OPT = function +| CT_coerce_NONE_to_VERBOSE_OPT x -> fNONE x +| CT_verbose -> fNODE "verbose" 0 +;; diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli new file mode 100644 index 00000000..fe30b317 --- /dev/null +++ b/contrib/interface/vtp.mli @@ -0,0 +1,15 @@ +open Ascent;; + +val fCOMMAND_LIST : ct_COMMAND_LIST -> unit;; +val fCOMMAND : ct_COMMAND -> unit;; +val fTACTIC_COM : ct_TACTIC_COM -> unit;; +val fFORMULA : ct_FORMULA -> unit;; +val fID : ct_ID -> unit;; +val fSTRING : ct_STRING -> unit;; +val fINT : ct_INT -> unit;; +val fRULE_LIST : ct_RULE_LIST -> unit;; +val fRULE : ct_RULE -> unit;; +val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> unit;; +val fPREMISES_LIST : ct_PREMISES_LIST -> unit;; +val fID_LIST : ct_ID_LIST -> unit;; +val fTEXT : ct_TEXT -> unit;;
\ No newline at end of file diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml new file mode 100644 index 00000000..ed51b9cb --- /dev/null +++ b/contrib/interface/xlate.ml @@ -0,0 +1,2118 @@ +(** Translation from coq abstract syntax trees to centaur vernac + *) +open String;; +open Char;; +open Util;; +open Ast;; +open Names;; +open Ascent;; +open Genarg;; +open Rawterm;; +open Tacexpr;; +open Vernacexpr;; +open Decl_kinds;; +open Topconstr;; +open Libnames;; +open Goptions;; + + +let in_coq_ref = ref false;; + +let declare_in_coq () = in_coq_ref:=true;; + +let in_coq () = !in_coq_ref;; + +(* // Verify whether this is dead code, as of coq version 7 *) +(* The following three sentences have been added to cope with a change +of strategy from the Coq team in the way rules construct ast's. The +problem is that now grammar rules will refer to identifiers by giving +their absolute name, using the mutconstruct when needed. Unfortunately, +when you have a mutconstruct structure, you don't have a way to guess +the corresponding identifier without an environment, and the parser +does not have an environment. We add one, only for the constructs +that are always loaded. *) +let type_table = ((Hashtbl.create 17) : + (string, ((string array) array)) Hashtbl.t);; + +Hashtbl.add type_table "Coq.Init.Logic.and" + [|[|"dummy";"conj"|]|];; + +Hashtbl.add type_table "Coq.Init.Datatypes.prod" + [|[|"dummy";"pair"|]|];; + +Hashtbl.add type_table "Coq.Init.Datatypes.nat" + [|[|"";"O"; "S"|]|];; + +Hashtbl.add type_table "Coq.ZArith.fast_integer.Z" +[|[|"";"ZERO";"POS";"NEG"|]|];; + + +Hashtbl.add type_table "Coq.ZArith.fast_integer.positive" +[|[|"";"xI";"xO";"xH"|]|];; + +(*The following two codes are added to cope with the distinction + between ocaml and caml-light syntax while using ctcaml to + manipulate the program *) +let code_plus = code (get "+" 0);; + +let code_minus = code (get "-" 0);; + +let coercion_description_holder = ref (function _ -> None : t -> int option);; + +let coercion_description t = !coercion_description_holder t;; + +let set_coercion_description f = + coercion_description_holder:=f; ();; + +let 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 ctf_STRING_OPT_NONE = CT_coerce_NONE_to_STRING_OPT CT_none;; + +let ctf_STRING_OPT_SOME s = CT_coerce_STRING_to_STRING_OPT s;; + +let ctf_STRING_OPT = function + | None -> ctf_STRING_OPT_NONE + | Some s -> ctf_STRING_OPT_SOME (CT_string s) + +let ctv_ID_OPT_NONE = CT_coerce_NONE_to_ID_OPT CT_none;; + +let ctf_ID_OPT_SOME s = CT_coerce_ID_to_ID_OPT s;; + +let ctv_ID_OPT_OR_ALL_NONE = + CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_NONE_to_ID_OPT CT_none);; + +let ctv_FORMULA_OPT_NONE = + CT_coerce_ID_OPT_to_FORMULA_OPT(CT_coerce_NONE_to_ID_OPT CT_none);; + +let ctv_PATTERN_OPT_NONE = CT_coerce_NONE_to_PATTERN_OPT CT_none;; + +let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT + ctv_FORMULA_OPT_NONE;; + +let ctf_ID_OPT_OR_ALL_SOME s = + CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (ctf_ID_OPT_SOME s);; + +let ctv_ID_OPT_OR_ALL_ALL = CT_all;; + +let ctv_SPEC_OPT_NONE = CT_coerce_NONE_to_SPEC_OPT CT_none;; + +let ct_coerce_FORMULA_to_DEF_BODY x = + CT_coerce_CONTEXT_PATTERN_to_DEF_BODY + (CT_coerce_FORMULA_to_CONTEXT_PATTERN x);; + +let castc x = CT_coerce_TYPED_FORMULA_to_FORMULA x;; + +let varc x = CT_coerce_ID_to_FORMULA x;; + +let xlate_ident id = CT_ident (string_of_id id) + +let ident_tac s = CT_user_tac (xlate_ident s, CT_targ_list []);; + +let ident_vernac s = CT_user_vernac (CT_ident s, CT_varg_list []);; + +let nums_to_int_list_aux l = List.map (fun x -> CT_int x) l;; + +let nums_to_int_list l = CT_int_list(nums_to_int_list_aux l);; + +let nums_to_int_ne_list n l = + CT_int_ne_list(CT_int n, nums_to_int_list_aux l);; + +type iTARG = Targ_command of ct_FORMULA + | Targ_intropatt of ct_INTRO_PATT_LIST + | Targ_id_list of ct_ID_LIST + | Targ_spec_list of ct_SPEC_LIST + | Targ_binding_com of ct_FORMULA + | Targ_ident of ct_ID + | Targ_int of ct_INT + | Targ_binding of ct_BINDING + | Targ_pattern of ct_PATTERN + | Targ_unfold of ct_UNFOLD + | Targ_unfold_ne_list of ct_UNFOLD_NE_LIST + | Targ_string of ct_STRING + | Targ_fixtac of ct_FIXTAC + | Targ_cofixtac of ct_COFIXTAC + | Targ_tacexp of ct_TACTIC_COM + | Targ_redexp of ct_RED_COM;; + +type iVARG = Varg_binder of ct_BINDER + | Varg_binderlist of ct_BINDER_LIST + | Varg_bindernelist of ct_BINDER_NE_LIST + | Varg_call of ct_ID * iVARG list + | Varg_constr of ct_FORMULA + | Varg_sorttype of ct_SORT_TYPE + | Varg_constrlist of ct_FORMULA list + | Varg_ident of ct_ID + | Varg_int of ct_INT + | Varg_intlist of ct_INT_LIST + | Varg_none + | Varg_string of ct_STRING + | Varg_tactic of ct_TACTIC_COM + | Varg_ast of ct_AST + | Varg_astlist of ct_AST_LIST + | Varg_tactic_arg of iTARG + | Varg_varglist of iVARG list;; + + +let coerce_iVARG_to_FORMULA = + function + | Varg_constr x -> x + | Varg_sorttype x -> CT_coerce_SORT_TYPE_to_FORMULA x + | Varg_ident id -> CT_coerce_ID_to_FORMULA id + | _ -> xlate_error "coerce_iVARG_to_FORMULA: unexpected argument";; + +let coerce_iVARG_to_ID = + function Varg_ident id -> id + | _ -> xlate_error "coerce_iVARG_to_ID";; + +let coerce_VARG_to_ID = + function + | CT_coerce_ID_OPT_OR_ALL_to_VARG (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL (CT_coerce_ID_to_ID_OPT x)) -> + x + | _ -> xlate_error "coerce_VARG_to_ID";; + +let xlate_ident_opt = + function + | None -> ctv_ID_OPT_NONE + | Some id -> ctf_ID_OPT_SOME (xlate_ident id) + +let xlate_id_to_id_or_int_opt s = + CT_coerce_ID_OPT_to_ID_OR_INT_OPT + (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id s)));; + +let xlate_int_to_id_or_int_opt n = + CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT + (CT_coerce_INT_to_ID_OR_INT (CT_int n));; + +let none_in_id_or_int_opt = + CT_coerce_ID_OPT_to_ID_OR_INT_OPT + (CT_coerce_NONE_to_ID_OPT(CT_none));; + +let xlate_int_opt = function + | Some n -> CT_coerce_INT_to_INT_OPT (CT_int n) + | None -> CT_coerce_NONE_to_INT_OPT CT_none + +let tac_qualid_to_ct_ID ref = + CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) + +let loc_qualid_to_ct_ID ref = + CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) + +let int_of_meta n = int_of_string (string_of_id n) +let is_int_meta n = try let _ = int_of_meta n in true with _ -> false + +let xlate_qualid_list l = CT_id_list (List.map loc_qualid_to_ct_ID l) + +let reference_to_ct_ID = function + | Ident (_,id) -> CT_ident (Names.string_of_id id) + | Qualid (_,qid) -> CT_ident (Libnames.string_of_qualid qid) + +let xlate_class = function + | FunClass -> CT_ident "FUNCLASS" + | SortClass -> CT_ident "SORTCLASS" + | RefClass qid -> loc_qualid_to_ct_ID qid + +let id_to_pattern_var ctid = + match ctid with + | CT_metaid _ -> xlate_error "metaid not expected in pattern_var" + | CT_ident "_" -> + CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_NONE_to_ID_OPT CT_none) + | CT_ident id_string -> + CT_coerce_ID_OPT_to_MATCH_PATTERN + (CT_coerce_ID_to_ID_OPT (CT_ident id_string)) + | CT_metac _ -> assert false;; + +exception Not_natural;; + +let xlate_sort = + function + | RProp Term.Pos -> CT_sortc "Set" + | RProp Term.Null -> CT_sortc "Prop" + | RType None -> CT_sortc "Type" + | RType (Some u) -> xlate_error "xlate_sort";; + + +let xlate_qualid a = + let d,i = Libnames.repr_qualid a in + let l = Names.repr_dirpath d in + List.fold_left (fun s i1 -> (string_of_id i1) ^ "." ^ s) (string_of_id i) l;; + +(* // The next two functions should be modified to make direct reference + to a notation operator *) +let notation_to_formula s l = CT_notation(CT_string s, CT_formula_list l);; + +let xlate_reference = function + Ident(_,i) -> CT_ident (string_of_id i) + | Qualid(_, q) -> CT_ident (xlate_qualid q);; +let rec xlate_match_pattern = + function + | CPatAtom(_, Some s) -> id_to_pattern_var (xlate_reference s) + | CPatAtom(_, None) -> id_to_pattern_var (CT_ident "_") + | CPatCstr(_, f, []) -> id_to_pattern_var (xlate_reference f) + | CPatCstr (_, f1 , (arg1 :: args)) -> + CT_pattern_app + (id_to_pattern_var (xlate_reference f1), + CT_match_pattern_ne_list + (xlate_match_pattern arg1, + List.map xlate_match_pattern args)) + | CPatAlias (_, pattern, id) -> + CT_pattern_as + (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id)) + | CPatDelimiters(_, key, p) -> + CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p) + | CPatNumeral(_,n) -> + CT_coerce_NUM_to_MATCH_PATTERN + (CT_int_encapsulator(Bignat.bigint_to_string n)) + | CPatNotation(_, s, l) -> + CT_pattern_notation(CT_string s, + CT_match_pattern_list(List.map xlate_match_pattern l)) +;; + + +let xlate_id_opt_aux = function + Name id -> ctf_ID_OPT_SOME(CT_ident (string_of_id id)) + | Anonymous -> ctv_ID_OPT_NONE;; + +let xlate_id_opt (_, v) = xlate_id_opt_aux v;; + +let xlate_id_opt_ne_list = function + [] -> assert false + | a::l -> CT_id_opt_ne_list(xlate_id_opt a, List.map xlate_id_opt l);; + + +let rec last = function + [] -> assert false + | [a] -> a + | a::tl -> last tl;; + +let rec decompose_last = function + [] -> assert false + | [a] -> [], a + | a::tl -> let rl, b = decompose_last tl in (a::rl), b;; + +let make_fix_struct (n,bl) = + let names = names_of_local_assums bl in + let nn = List.length names in + if nn = 1 then ctv_ID_OPT_NONE + else if n < nn then xlate_id_opt(List.nth names n) + else xlate_error "unexpected result of parsing for Fixpoint";; + + +let rec xlate_binder = function + (l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) +and xlate_return_info = function +| (Some Anonymous, None) | (None, None) -> + CT_coerce_NONE_to_RETURN_INFO CT_none +| (None, Some t) -> CT_return(xlate_formula t) +| (Some x, Some t) -> CT_as_and_return(xlate_id_opt_aux x, xlate_formula t) +| (Some _, None) -> assert false +and xlate_formula_opt = + function + | None -> ctv_FORMULA_OPT_NONE + | Some e -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula e) + +and xlate_binder_l = function + LocalRawAssum(l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) + | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n, + xlate_formula v)) +and + xlate_match_pattern_ne_list = function + [] -> assert false + | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, + List.map xlate_match_pattern l) +and translate_one_equation = function + (_,lp, a) -> CT_eqn ( xlate_match_pattern_ne_list lp, + xlate_formula a) +and + xlate_binder_ne_list = function + [] -> assert false + | a::l -> CT_binder_ne_list(xlate_binder a, List.map xlate_binder l) +and + xlate_binder_list = function + l -> CT_binder_list( List.map xlate_binder_l l) +and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function + + CRef r -> varc (xlate_reference r) + | CArrow(_,a,b)-> CT_arrowc (xlate_formula a, xlate_formula b) + | CProdN(_,ll,b) as whole_term -> + let rec gather_binders = function + CProdN(_, ll, b) -> + ll@(gather_binders b) + | _ -> [] in + let rec fetch_ultimate_body = function + CProdN(_, _, b) -> fetch_ultimate_body b + | a -> a in + CT_prodc(xlate_binder_ne_list (gather_binders whole_term), + xlate_formula (fetch_ultimate_body b)) + | CLambdaN(_,ll,b)-> CT_lambdac(xlate_binder_ne_list ll, xlate_formula b) + | CLetIn(_, v, a, b) -> + CT_letin(CT_def(xlate_id_opt v, xlate_formula a), xlate_formula b) + | CAppExpl(_, (Some n, r), l) -> + let l', last = decompose_last l in + CT_proj(xlate_formula last, + CT_formula_ne_list + (CT_bang(varc (xlate_reference r)), + List.map xlate_formula l')) + | CAppExpl(_, (None, r), []) -> CT_bang(varc(xlate_reference r)) + | CAppExpl(_, (None, r), l) -> + CT_appc(CT_bang(varc (xlate_reference r)), + xlate_formula_ne_list l) + | CApp(_, (Some n,f), l) -> + let l', last = decompose_last l in + CT_proj(xlate_formula_expl last, + CT_formula_ne_list + (xlate_formula f, List.map xlate_formula_expl l')) + | CApp(_, (_,f), l) -> + CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) + | CCases (_, _, [], _) -> assert false + | CCases (_, (Some _, _), _, _) -> xlate_error "NOT parsed: Cases with Some" + | CCases (_,(None, 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), + xlate_return_info ret_info, + xlate_formula c, + xlate_formula b) + | CLetTuple (_, [], _, _, _) -> xlate_error "NOT parsed: Let with ()" + | CIf (_,c, ret_info, b1, b2) -> + CT_if + (xlate_formula c, xlate_return_info ret_info, + xlate_formula b1, xlate_formula b2) + + | 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)) + | 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) -> + CT_coerce_TYPED_FORMULA_to_FORMULA + (CT_typed_formula(xlate_formula e, xlate_formula t)) + | CPatVar (_, (_,i)) when is_int_meta i -> + CT_coerce_ID_to_FORMULA(CT_metac (CT_int (int_of_meta i))) + | CPatVar (_, (false, s)) -> + CT_coerce_ID_to_FORMULA(CT_metaid (string_of_id s)) + | CPatVar (_, (true, s)) -> + xlate_error "Second order variable not supported" + | CEvar (_, _) -> xlate_error "CEvar not supported" + | CCoFix (_, (_, id), lm::lmi) -> + let strip_mutcorec (fid, bl,arf, ardef) = + CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, + xlate_formula arf, xlate_formula ardef) in + CT_cofixc(xlate_ident id, + (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))) + | CFix (_, (_, id), lm::lmi) -> + let strip_mutrec (fid, n, 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 + let ardef = xlate_formula ardef in + match xlate_binder_list bl with + | CT_binder_list (b :: bl) -> + CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), + struct_arg, arf, ardef) + | _ -> xlate_error "mutual recursive" in + CT_fixc (xlate_ident id, + CT_fix_binder_list + (CT_coerce_FIX_REC_to_FIX_BINDER + (strip_mutrec lm), List.map + (fun x-> CT_coerce_FIX_REC_to_FIX_BINDER (strip_mutrec x)) + lmi)) + | CCoFix _ -> assert false + | CFix _ -> assert false +and xlate_matched_formula = function + (f, (Some x, Some y)) -> + CT_formula_as_in(xlate_formula f, xlate_id_opt_aux x, xlate_formula y) + | (f, (None, Some y)) -> + CT_formula_in(xlate_formula f, xlate_formula y) + | (f, (Some x, None)) -> + CT_formula_as(xlate_formula f, xlate_id_opt_aux x) + | (f, (None, None)) -> + CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f) +and xlate_formula_expl = function + (a, None) -> xlate_formula a + | (a, Some (_,ExplByPos i)) -> + xlate_error "explicitation of implicit by rank not supported" + | (a, Some (_,ExplByName i)) -> + CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a) +and xlate_formula_expl_ne_list = function + [] -> assert false + | a::l -> CT_formula_ne_list(xlate_formula_expl a, List.map xlate_formula_expl l) +and xlate_formula_ne_list = function + [] -> assert false + | a::l -> CT_formula_ne_list(xlate_formula a, List.map xlate_formula l);; + +let (xlate_ident_or_metaid: + Names.identifier Util.located Tacexpr.or_metaid -> ct_ID) = function + AI (_, x) -> xlate_ident x + | MetaId(_, x) -> CT_metaid x;; + +let xlate_hyp = function + | AI (_,id) -> xlate_ident id + | MetaId _ -> xlate_error "MetaId should occur only in quotations" + +let xlate_hyp_location = + function + | AI (_,id), nums, (InHypTypeOnly,_) -> + CT_intype(xlate_ident id, nums_to_int_list nums) + | AI (_,id), nums, (InHypValueOnly,_) -> + CT_invalue(xlate_ident id, nums_to_int_list nums) + | AI (_,id), [], (InHyp,_) -> + CT_coerce_UNFOLD_to_HYP_LOCATION + (CT_coerce_ID_to_UNFOLD (xlate_ident id)) + | 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))) + | MetaId _, _,_ -> + xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)" + +let xlate_clause cls = + let hyps_info = + match cls.onhyps with + None -> CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR CT_star + | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in + CT_clause + (hyps_info, + if cls.onconcl then + CT_coerce_STAR_to_STAR_OPT CT_star + else + CT_coerce_NONE_to_STAR_OPT CT_none) + +(** Tactics + *) +let strip_targ_spec_list = + function + | Targ_spec_list x -> x + | _ -> xlate_error "strip tactic: non binding-list argument";; + +let strip_targ_binding = + function + | Targ_binding x -> x + | _ -> xlate_error "strip tactic: non-binding argument";; + +let strip_targ_command = + function + | Targ_command x -> x + | Targ_binding_com x -> x + | _ -> xlate_error "strip tactic: non-command argument";; + +let strip_targ_ident = + function + | Targ_ident x -> x + | _ -> xlate_error "strip tactic: non-ident argument";; + +let strip_targ_int = + function + | Targ_int x -> x + | _ -> xlate_error "strip tactic: non-int argument";; + +let strip_targ_pattern = + function + | Targ_pattern x -> x + | _ -> xlate_error "strip tactic: non-pattern argument";; + +let strip_targ_unfold = + function + | Targ_unfold x -> x + | _ -> xlate_error "strip tactic: non-unfold argument";; + +let strip_targ_fixtac = + function + | Targ_fixtac x -> x + | _ -> xlate_error "strip tactic: non-fixtac argument";; + +let strip_targ_cofixtac = + function + | Targ_cofixtac x -> x + | _ -> xlate_error "strip tactic: non-cofixtac argument";; + +(*Need to transform formula to id for "Prolog" tactic problem *) +let make_ID_from_FORMULA = + function + | CT_coerce_ID_to_FORMULA id -> id + | _ -> xlate_error "make_ID_from_FORMULA: non-formula argument";; + +let make_ID_from_iTARG_FORMULA x = make_ID_from_FORMULA (strip_targ_command x);; + +let xlate_quantified_hypothesis = function + | AnonHyp n -> CT_coerce_INT_to_ID_OR_INT (CT_int n) + | NamedHyp id -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) + +let xlate_quantified_hypothesis_opt = function + | None -> + CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE + | Some (AnonHyp n) -> xlate_int_to_id_or_int_opt n + | Some (NamedHyp id) -> xlate_id_to_id_or_int_opt id;; + +let xlate_id_or_int = function + ArgArg n -> CT_coerce_INT_to_ID_OR_INT(CT_int n) + | ArgVar(_, s) -> CT_coerce_ID_to_ID_OR_INT(xlate_ident s);; + +let xlate_explicit_binding (loc,h,c) = + CT_binding (xlate_quantified_hypothesis h, xlate_formula c) + +let xlate_bindings = function + | ImplicitBindings l -> + CT_coerce_FORMULA_LIST_to_SPEC_LIST + (CT_formula_list (List.map xlate_formula l)) + | ExplicitBindings l -> + CT_coerce_BINDING_LIST_to_SPEC_LIST + (CT_binding_list (List.map xlate_explicit_binding l)) + | NoBindings -> + CT_coerce_FORMULA_LIST_to_SPEC_LIST (CT_formula_list []) + +let strip_targ_spec_list = + function + | Targ_spec_list x -> x + | _ -> xlate_error "strip_tar_spec_list";; + +let strip_targ_intropatt = + function + | Targ_intropatt x -> x + | _ -> xlate_error "strip_targ_intropatt";; + +let get_flag r = + let conv_flags, red_ids = + if r.rDelta then + [CT_delta], CT_unfbut (List.map tac_qualid_to_ct_ID r.rConst) + else + (if r.rConst = [] + then (* probably useless: just for compatibility *) [] + else [CT_delta]), + CT_unf (List.map tac_qualid_to_ct_ID r.rConst) in + let conv_flags = if r.rBeta then CT_beta::conv_flags else conv_flags in + let conv_flags = if r.rIota then CT_iota::conv_flags else conv_flags in + let conv_flags = if r.rZeta then CT_zeta::conv_flags else conv_flags in + (* Rem: EVAR flag obsolète *) + conv_flags, red_ids + +let rec xlate_intro_pattern = + function + | IntroOrAndPattern [] -> assert false + | IntroOrAndPattern (fp::ll) -> + CT_disj_pattern + (CT_intro_patt_list(List.map xlate_intro_pattern fp), + List.map + (fun l -> + CT_intro_patt_list(List.map xlate_intro_pattern l)) + ll) + | IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" ) + | IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c) + +let compute_INV_TYPE = function + FullInversionClear -> CT_inv_clear + | SimpleInversion -> CT_inv_simple + | FullInversion -> CT_inv_regular + +let is_tactic_special_case = function + "AutoRewrite" -> true + | _ -> false;; + +let xlate_context_pattern = function + | Term v -> + CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v) + | Subterm (idopt, v) -> + CT_context(xlate_ident_opt idopt, xlate_formula v) + + +let xlate_match_context_hyps = function + | Hyp (na,b) -> CT_premise_pattern(xlate_id_opt na, xlate_context_pattern b);; + +let xlate_arg_to_id_opt = function + Some id -> CT_coerce_ID_to_ID_OPT(CT_ident (string_of_id id)) + | None -> ctv_ID_OPT_NONE;; + +let xlate_largs_to_id_opt largs = + match List.map xlate_arg_to_id_opt largs with + fst::rest -> fst, rest + | _ -> assert false;; + +let xlate_int_or_constr = function + ElimOnConstr a -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a) + | ElimOnIdent(_,i) -> + CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT(xlate_ident i)) + | ElimOnAnonHyp i -> + CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_INT_to_ID_OR_INT(CT_int i));; + +let xlate_using = function + None -> CT_coerce_NONE_to_USING(CT_none) + | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);; + +let xlate_one_unfold_block = function + ([],qid) -> CT_coerce_ID_to_UNFOLD(tac_qualid_to_ct_ID qid) + | (n::nums, qid) -> + CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_to_int_ne_list n nums);; + +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 rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = + function + | TacVoid -> + CT_void + | Tacexp t -> + CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_tactic t) + | Integer n -> + CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_INT_to_ID_OR_INT (CT_int n))) + | Reference r -> + CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT (reference_to_ct_ID r))) + | TacDynamic _ -> + failwith "Dynamics not treated in xlate_ast" + | ConstrMayEval (ConstrTerm c) -> + CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG + (CT_coerce_FORMULA_to_FORMULA_OR_INT (xlate_formula c)) + | ConstrMayEval(ConstrEval(r,c)) -> + CT_coerce_EVAL_CMD_to_TACTIC_ARG + (CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, xlate_red_tactic r, + xlate_formula c)) + | ConstrMayEval(ConstrTypeOf(c)) -> + CT_coerce_TERM_CHANGE_to_TACTIC_ARG(CT_check_term(xlate_formula c)) + | MetaIdArg _ -> + xlate_error "MetaIdArg should only be used in quotations" + | t -> + CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_call_or_tacarg t) + +and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) = + function + (* Moved from xlate_tactic *) + | TacCall (_, r, a::l) -> + CT_simple_user_tac + (reference_to_ct_ID r, + CT_tactic_arg_list(xlate_tacarg a,List.map xlate_tacarg l)) + | Reference (Ident (_,s)) -> ident_tac s + | ConstrMayEval(ConstrTerm a) -> + CT_formula_marker(xlate_formula a) + | TacFreshId s -> CT_fresh(ctf_STRING_OPT s) + | t -> xlate_error "TODO LATER: result other than tactic or constr" + +and xlate_red_tactic = + function + | Red true -> xlate_error "" + | Red false -> CT_red + | Hnf -> CT_hnf + | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE + | Simpl (Some (l,c)) -> + CT_simpl + (CT_coerce_PATTERN_to_PATTERN_OPT + (CT_pattern_occ + (CT_int_list(List.map (fun n -> CT_int n) l), xlate_formula c))) + | Cbv flag_list -> + let conv_flags, red_ids = get_flag flag_list in + CT_cbv (CT_conversion_flag_list conv_flags, red_ids) + | Lazy flag_list -> + let conv_flags, red_ids = get_flag flag_list in + CT_lazy (CT_conversion_flag_list conv_flags, red_ids) + | Unfold unf_list -> + let ct_unf_list = List.map xlate_one_unfold_block unf_list in + (match ct_unf_list with + | first :: others -> CT_unfold (CT_unfold_ne_list (first, others)) + | [] -> error "there should be at least one thing to unfold") + | Fold formula_list -> + CT_fold(CT_formula_list(List.map xlate_formula formula_list)) + | Pattern l -> + let pat_list = List.map (fun (nums,c) -> + CT_pattern_occ + (CT_int_list (List.map (fun x -> CT_int x) nums), + xlate_formula c)) l in + (match pat_list with + | first :: others -> CT_pattern (CT_pattern_ne_list (first, others)) + | [] -> error "Expecting at least one pattern in a Pattern command") + | ExtraRedExpr _ -> xlate_error "TODO LATER: ExtraRedExpr (probably dead code)" + +and xlate_local_rec_tac = function + (* TODO LATER: local recursive tactics and global ones should be handled in + the same manner *) + | ((_,x),(argl,tac)) -> + let fst, rest = xlate_largs_to_id_opt argl in + CT_rec_tactic_fun(xlate_ident x, + CT_id_opt_ne_list(fst, rest), + xlate_tactic tac) + +and xlate_tactic = + function + | TacFun (largs, t) -> + let fst, rest = xlate_largs_to_id_opt largs in + CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t) + | TacThen (t1,t2) -> + (match xlate_tactic t1 with + CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2]) + | t -> CT_then (t,[xlate_tactic t2])) + | TacThens(t1,[]) -> assert false + | TacThens(t1,t::l) -> + let ct = xlate_tactic t in + let cl = List.map xlate_tactic l in + (match xlate_tactic t1 with + CT_then(ct1,cl1) -> CT_then(ct1, cl1@[CT_parallel(ct, cl)]) + | ct1 -> CT_then(ct1,[CT_parallel(ct, cl)])) + | TacFirst([]) -> assert false + | TacFirst(t1::l)-> CT_first(xlate_tactic t1, List.map xlate_tactic l) + | TacSolve([]) -> assert false + | TacSolve(t1::l)-> CT_tacsolve(xlate_tactic t1, List.map xlate_tactic l) + | TacDo(count, t) -> CT_do(xlate_id_or_int count, xlate_tactic t) + | TacTry t -> CT_try (xlate_tactic t) + | TacRepeat t -> CT_repeat(xlate_tactic t) + | TacAbstract(t,id_opt) -> + CT_abstract((match id_opt with + None -> ctv_ID_OPT_NONE + | Some id -> ctf_ID_OPT_SOME (CT_ident (string_of_id id))), + xlate_tactic t) + | TacProgress t -> CT_progress(xlate_tactic t) + | TacOrelse(t1,t2) -> CT_orelse(xlate_tactic t1, xlate_tactic t2) + | TacMatch (exp, rules) -> + CT_match_tac(xlate_tactic exp, + match List.map + (function + | Pat ([],p,tac) -> + CT_match_tac_rule(xlate_context_pattern p, + mk_let_value tac) + | Pat (_,p,tac) -> xlate_error"No hyps in pure Match" + | All tac -> + CT_match_tac_rule + (CT_coerce_FORMULA_to_CONTEXT_PATTERN + CT_existvarc, + mk_let_value tac)) rules with + | [] -> assert false + | fst::others -> + CT_match_tac_rules(fst, others)) + | TacMatchContext (_,[]) -> failwith "" + | TacMatchContext (false,rule1::rules) -> + CT_match_context(xlate_context_rule rule1, + List.map xlate_context_rule rules) + | TacMatchContext (true,rule1::rules) -> + CT_match_context_reverse(xlate_context_rule rule1, + List.map xlate_context_rule rules) + | TacLetIn (l, t) -> + let cvt_clause = + function + ((_,s),None,ConstrMayEval v) -> + CT_let_clause(xlate_ident s, + CT_coerce_NONE_to_TACTIC_OPT CT_none, + CT_coerce_DEF_BODY_to_LET_VALUE + (formula_to_def_body v)) + | ((_,s),None,Tacexp t) -> + CT_let_clause(xlate_ident s, + CT_coerce_NONE_to_TACTIC_OPT CT_none, + CT_coerce_TACTIC_COM_to_LET_VALUE + (xlate_tactic t)) + | ((_,s),None,t) -> + CT_let_clause(xlate_ident s, + CT_coerce_NONE_to_TACTIC_OPT CT_none, + CT_coerce_TACTIC_COM_to_LET_VALUE + (xlate_call_or_tacarg t)) + | ((_,s),Some c,t) -> + CT_let_clause(xlate_ident s, + CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic c), + CT_coerce_TACTIC_COM_to_LET_VALUE + (xlate_call_or_tacarg t)) in + let cl_l = List.map cvt_clause l in + (match cl_l with + | [] -> assert false + | fst::others -> + CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t)) + | TacLetRecIn([], _) -> xlate_error "recursive definition with no definition" + | TacLetRecIn(f1::l, t) -> + let tl = CT_rec_tactic_fun_list + (xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in + CT_rec_tactic_in(tl, xlate_tactic t) + | TacAtom (_, t) -> xlate_tac t + | TacFail (count, "") -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE) + | TacFail (count, 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)) + | 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 + | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none + | Some t2 -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic t2) in + (match l with + [] -> CT_firstorder t1 + | [l1] -> + (match genarg_tag l1 with + List1ArgType PreIdentArgType -> + let l2 = List.map + (fun x -> CT_ident x) + (out_gen (wit_list1 rawwit_pre_ident) l1) in + let fst,l3 = + match l2 with fst::l3 -> fst,l3 | [] -> assert false in + CT_firstorder_using(t1, CT_id_ne_list(fst, l3)) + | List1ArgType RefArgType -> + let l2 = List.map reference_to_ct_ID + (out_gen (wit_list1 rawwit_ref) l1) in + let fst,l3 = + match l2 with fst::l3 -> fst, l3 | [] -> assert false in + CT_firstorder_with(t1, CT_id_ne_list(fst, l3)) + | _ -> assert false) + | _ -> assert false) + | TacExtend (_, "refine", [c]) -> + CT_refine (xlate_formula (out_gen rawwit_casted_open_constr c)) + | TacExtend (_,"absurd",[c]) -> + CT_absurd (xlate_formula (out_gen rawwit_constr c)) + | TacExtend (_,"contradiction",[opt_c]) -> + (match out_gen (wit_opt rawwit_constr_with_bindings) opt_c with + None -> CT_contradiction + | Some(c, b) -> + let c1 = xlate_formula c in + let bindings = xlate_bindings b in + CT_contradiction_thm(c1, bindings)) + | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b) + | TacChange (Some(l,c), f, b) -> + (* TODO LATER: combine with other constructions of pattern_occ *) + CT_change_local( + CT_pattern_occ(CT_int_list(List.map (fun n -> CT_int n) l), + xlate_formula c), + xlate_formula f, + xlate_clause b) + | TacExtend (_,"contradiction",[]) -> CT_contradiction + | TacDoubleInduction (n1, n2) -> + CT_tac_double (xlate_quantified_hypothesis n1, xlate_quantified_hypothesis n2) + | TacExtend (_,"discriminate", [idopt]) -> + CT_discriminate_eq + (xlate_quantified_hypothesis_opt + (out_gen (wit_opt rawwit_quant_hyp) idopt)) + | TacExtend (_,"deq", [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 + (CT_coerce_NONE_to_ID_OPT CT_none) + | Some v -> + CT_coerce_ID_OR_INT_to_ID_OR_INT_OPT + (xlate_quantified_hypothesis v) in + CT_simplify_eq idopt2 + | TacExtend (_,"injection", [idopt]) -> + CT_injection_eq + (xlate_quantified_hypothesis_opt + (out_gen (wit_opt rawwit_quant_hyp) idopt)) + | TacFix (idopt, n) -> + CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list []) + | TacMutualFix (id, n, fixtac_list) -> + let f (id,n,c) = CT_fixtac (xlate_ident id, CT_int n, xlate_formula c) in + CT_fixtactic + (ctf_ID_OPT_SOME (xlate_ident id), CT_int n, + CT_fix_tac_list (List.map f fixtac_list)) + | TacCofix idopt -> + CT_cofixtactic (xlate_ident_opt idopt, CT_cofix_tac_list []) + | TacMutualCofix (id, cofixtac_list) -> + let f (id,c) = CT_cofixtac (xlate_ident id, xlate_formula c) in + CT_cofixtactic + (CT_coerce_ID_to_ID_OPT (xlate_ident id), + CT_cofix_tac_list (List.map f cofixtac_list)) + | TacIntrosUntil (NamedHyp id) -> + CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id)) + | TacIntrosUntil (AnonHyp n) -> + CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n)) + | TacIntroMove (Some id1, Some (_,id2)) -> + CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_ident id2) + | TacIntroMove (None, Some (_,id2)) -> + CT_intro_after(CT_coerce_NONE_to_ID_OPT CT_none, xlate_ident id2) + | TacMove (true, id1, id2) -> + CT_move_after(xlate_hyp id1, xlate_hyp id2) + | TacMove (false, id1, id2) -> xlate_error "Non dep Move is only internal" + | TacIntroPattern patt_list -> + CT_intros + (CT_intro_patt_list (List.map xlate_intro_pattern patt_list)) + | TacIntroMove (Some id, None) -> + CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)]) + | TacIntroMove (None, None) -> CT_intro (CT_coerce_NONE_to_ID_OPT CT_none) + | TacLeft bindl -> CT_left (xlate_bindings bindl) + | TacRight bindl -> CT_right (xlate_bindings bindl) + | TacSplit (false,bindl) -> CT_split (xlate_bindings bindl) + | TacSplit (true,bindl) -> CT_exists (xlate_bindings bindl) + | TacExtend (_,"replace", [c1; c2]) -> + let c1 = xlate_formula (out_gen rawwit_constr c1) in + let c2 = xlate_formula (out_gen rawwit_constr c2) in + CT_replace_with (c1, c2) + | TacExtend (_,"rewrite", [b; cbindl]) -> + let b = out_gen Extraargs.rawwit_orient b in + let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in + let c = xlate_formula c and bindl = xlate_bindings bindl in + if b then CT_rewrite_lr (c, bindl, ctv_ID_OPT_NONE) + else CT_rewrite_rl (c, bindl, ctv_ID_OPT_NONE) + | TacExtend (_,"rewritein", [b; cbindl; id]) -> + let b = out_gen Extraargs.rawwit_orient b in + let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in + let c = xlate_formula c and bindl = xlate_bindings bindl in + let id = ctf_ID_OPT_SOME (xlate_ident (out_gen rawwit_ident id)) in + if b then CT_rewrite_lr (c, bindl, id) + else CT_rewrite_rl (c, bindl, id) + | TacExtend (_,"conditionalrewrite", [t; b; cbindl]) -> + let t = out_gen rawwit_tactic t in + 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 + let b = out_gen Extraargs.rawwit_orient b in + let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in + let c = xlate_formula c and bindl = xlate_bindings bindl in + let id = ctf_ID_OPT_SOME (xlate_ident (out_gen rawwit_ident id)) in + if b then CT_condrewrite_lr (xlate_tactic t, c, bindl, id) + else CT_condrewrite_rl (xlate_tactic t, c, bindl, id) + | TacExtend (_,"dependentrewrite", [b; id_or_constr]) -> + 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 + 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*) + 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 + if b then CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id) + else CT_cutrewrite_lr (c, ctf_ID_OPT_SOME id) + | TacExtend(_, "subst", [l]) -> + CT_subst + (CT_id_list + (List.map (fun x -> CT_ident (string_of_id x)) + (out_gen (wit_list1 rawwit_ident) l))) + | TacReflexivity -> CT_reflexivity + | TacSymmetry cls -> CT_symmetry(xlate_clause cls) + | TacTransitivity c -> CT_transitivity (xlate_formula c) + | TacAssumption -> CT_assumption + | TacExact c -> CT_exact (xlate_formula c) + | TacDestructHyp (true, (_,id)) -> CT_cdhyp (xlate_ident id) + | TacDestructHyp (false, (_,id)) -> CT_dhyp (xlate_ident id) + | TacDestructConcl -> CT_dconcl + | TacSuperAuto (nopt,l,a3,a4) -> + CT_superauto( + xlate_int_opt nopt, + xlate_qualid_list l, + (if a3 then CT_destructing else CT_coerce_NONE_to_DESTRUCTING CT_none), + (if a4 then CT_usingtdb else CT_coerce_NONE_to_USINGTDB CT_none)) + | TacAutoTDB nopt -> CT_autotdb (xlate_int_opt nopt) + | TacAuto (nopt, Some []) -> CT_auto (xlate_int_opt nopt) + | TacAuto (nopt, None) -> + CT_auto_with (xlate_int_opt nopt, + CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) + | TacAuto (nopt, Some (id1::idl)) -> + CT_auto_with(xlate_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))) + |TacExtend(_, ("autorewritev7"|"autorewritev8"), l::t) -> + let (id_list:ct_ID list) = + List.map (fun x -> CT_ident x) (out_gen (wit_list1 rawwit_pre_ident) l) in + let fst, (id_list1: ct_ID list) = + match id_list with [] -> assert false | a::tl -> a,tl in + let t1 = + match t with + [t0] -> + CT_coerce_TACTIC_COM_to_TACTIC_OPT + (xlate_tactic(out_gen rawwit_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]) -> + let first_n = + match out_gen (wit_opt rawwit_int_or_var) nopt with + | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s + | Some ArgArg n -> xlate_int_to_id_or_int_opt n + | None -> none_in_id_or_int_opt in + let second_n = + match out_gen (wit_opt rawwit_int_or_var) popt with + | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s + | Some ArgArg n -> xlate_int_to_id_or_int_opt n + | None -> none_in_id_or_int_opt in + let idl = out_gen Eauto.rawwit_hintbases idl in + (match idl with + None -> CT_eauto_with(first_n, + second_n, + CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) + | Some [] -> CT_eauto(first_n, second_n) + | Some (a::l) -> + CT_eauto_with(first_n, second_n, + CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR + (CT_id_ne_list + (CT_ident a, + List.map (fun x -> CT_ident x) l)))) + | TacExtend (_,"prolog", [cl; n]) -> + let cl = List.map xlate_formula (out_gen (wit_list0 rawwit_constr) cl) in + (match out_gen wit_int_or_var n with + | ArgVar _ -> xlate_error "" + | ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n)) + | TacExtend (_,"eapply", [cbindl]) -> + let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in + let c = xlate_formula c and bindl = xlate_bindings bindl in + CT_eapply (c, bindl) + | TacTrivial (Some []) -> CT_trivial + | TacTrivial None -> + CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) + | TacTrivial (Some (id1::idl)) -> + CT_trivial_with(CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( + (CT_id_ne_list(CT_ident id1,List.map (fun x -> CT_ident x) idl)))) + | TacReduce (red, l) -> + CT_reduce (xlate_red_tactic red, xlate_clause l) + | TacApply (c,bindl) -> + CT_apply (xlate_formula c, xlate_bindings bindl) + | TacConstructor (n_or_meta, bindl) -> + let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error "" + in CT_constructor (CT_int n, xlate_bindings bindl) + | TacSpecialize (nopt, (c,sl)) -> + CT_specialize (xlate_int_opt nopt, xlate_formula c, xlate_bindings sl) + | TacGeneralize [] -> xlate_error "" + | TacGeneralize (first :: cl) -> + CT_generalize + (CT_formula_ne_list (xlate_formula first, List.map xlate_formula cl)) + | TacGeneralizeDep c -> + CT_generalize_dependent (xlate_formula c) + | TacElimType c -> CT_elim_type (xlate_formula c) + | TacCaseType c -> CT_case_type (xlate_formula c) + | TacElim ((c1,sl), u) -> + 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) + | TacSimpleDestruct h -> CT_destruct (xlate_quantified_hypothesis h) + | TacCut c -> CT_cut (xlate_formula c) + | TacLApply c -> CT_use (xlate_formula c) + | TacDecompose ([],c) -> + xlate_error "Decompose : empty list of identifiers?" + | TacDecompose (id::l,c) -> + let id' = tac_qualid_to_ct_ID id in + let l' = List.map tac_qualid_to_ct_ID l in + CT_decompose_list(CT_id_ne_list(id',l'),xlate_formula c) + | TacDecomposeAnd c -> CT_decompose_record (xlate_formula c) + | TacDecomposeOr c -> CT_decompose_sum(xlate_formula c) + | TacClear [] -> + xlate_error "Clear expects a non empty list of identifiers" + | TacClear (id::idl) -> + let idl' = List.map xlate_hyp idl in + CT_clear (CT_id_ne_list (xlate_hyp id, idl')) + | (*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, + 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) + | TacInversion (InversionUsing (c,idlist), id) -> + let id = xlate_quantified_hypothesis id in + CT_use_inversion (id, xlate_formula c, + CT_id_list (List.map xlate_hyp idlist)) + | TacExtend (_,"omega", []) -> CT_omega + | TacRename (id1, id2) -> CT_rename(xlate_hyp id1, xlate_hyp id2) + | TacClearBody([]) -> assert false + | TacClearBody(a::l) -> + CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l)) + | TacDAuto (a, b) -> CT_dauto(xlate_int_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) -> + CT_instantiate(CT_int a, xlate_formula b, + xlate_clause cl) + | 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) + | TacAnyConstructor(Some tac) -> + CT_any_constructor + (CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac)) + | TacAnyConstructor(None) -> + CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none) + | TacExtend(_, "ring", [args]) -> + CT_ring + (CT_formula_list + (List.map xlate_formula + (out_gen (wit_list0 rawwit_constr) args))) + | TacExtend (_,id, l) -> + CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l)) + | TacAlias _ -> xlate_error "Alias not supported" + +and coerce_genarg_to_TARG x = + match Genarg.genarg_tag x with + (* Basic types *) + | BoolArgType -> xlate_error "TODO: generic boolean argument" + | IntArgType -> + let n = out_gen rawwit_int x in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_INT_to_ID_OR_INT (CT_int n))) + | IntOrVarArgType -> + let x = match out_gen rawwit_int_or_var x with + | ArgArg n -> CT_coerce_INT_to_ID_OR_INT (CT_int n) + | ArgVar (_,id) -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT x) + | StringArgType -> + let s = CT_string (out_gen rawwit_string x) in + CT_coerce_SCOMMENT_CONTENT_to_TARG + (CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT + (CT_coerce_STRING_to_ID_OR_STRING s)) + | PreIdentArgType -> + let id = CT_ident (out_gen rawwit_pre_ident x) in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT id)) + | IntroPatternArgType -> + xlate_error "TODO" + | IdentArgType -> + let id = xlate_ident (out_gen rawwit_ident x) in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT id)) + | HypArgType -> + xlate_error "TODO (similar to IdentArgType)" + | RefArgType -> + let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in + CT_coerce_FORMULA_OR_INT_to_TARG + (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT + (CT_coerce_ID_to_ID_OR_INT id)) + (* Specific types *) + | SortArgType -> + CT_coerce_SCOMMENT_CONTENT_to_TARG + (CT_coerce_FORMULA_to_SCOMMENT_CONTENT + (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) + | ConstrArgType -> + CT_coerce_SCOMMENT_CONTENT_to_TARG + (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x))) + | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" + | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" + | TacticArgType -> + let t = xlate_tactic (out_gen rawwit_tactic x) in + CT_coerce_TACTIC_COM_to_TARG t + | CastedOpenConstrArgType -> + CT_coerce_SCOMMENT_CONTENT_to_TARG + (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula + (out_gen + rawwit_casted_open_constr x))) + | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" + | BindingsArgType -> xlate_error "TODO: generic with bindings" + | RedExprArgType -> xlate_error "TODO: generic red expr" + | List0ArgType l -> xlate_error "TODO: lists of generic arguments" + | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments" + | OptArgType x -> xlate_error "TODO: optional generic arguments" + | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments" + | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments" +and xlate_context_rule = + function + | Pat (hyps, concl_pat, tactic) -> + CT_context_rule + (CT_context_hyp_list (List.map xlate_match_context_hyps hyps), + xlate_context_pattern concl_pat, xlate_tactic tactic) + | All tactic -> + CT_def_context_rule (xlate_tactic tactic) +and formula_to_def_body = + function + | ConstrEval (red, f) -> + CT_coerce_EVAL_CMD_to_DEF_BODY( + CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, + xlate_red_tactic red, xlate_formula f)) + | ConstrContext((_, id), f) -> + CT_coerce_CONTEXT_PATTERN_to_DEF_BODY + (CT_context + (CT_coerce_ID_to_ID_OPT (CT_ident (string_of_id id)), + xlate_formula f)) + | ConstrTypeOf f -> CT_type_of (xlate_formula f) + | ConstrTerm c -> ct_coerce_FORMULA_to_DEF_BODY(xlate_formula c) + +and mk_let_value = function + TacArg (ConstrMayEval v) -> + CT_coerce_DEF_BODY_to_LET_VALUE(formula_to_def_body v) + | v -> CT_coerce_TACTIC_COM_to_LET_VALUE(xlate_tactic v);; + +let coerce_genarg_to_VARG x = + match Genarg.genarg_tag x with + (* Basic types *) + | BoolArgType -> xlate_error "TODO: generic boolean argument" + | IntArgType -> + let n = out_gen rawwit_int x in + CT_coerce_ID_OR_INT_OPT_to_VARG + (CT_coerce_INT_OPT_to_ID_OR_INT_OPT + (CT_coerce_INT_to_INT_OPT (CT_int n))) + | IntOrVarArgType -> + (match out_gen rawwit_int_or_var x with + | ArgArg n -> + CT_coerce_ID_OR_INT_OPT_to_VARG + (CT_coerce_INT_OPT_to_ID_OR_INT_OPT + (CT_coerce_INT_to_INT_OPT (CT_int n))) + | ArgVar (_,id) -> + CT_coerce_ID_OPT_OR_ALL_to_VARG + (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL + (CT_coerce_ID_to_ID_OPT (xlate_ident id)))) + | StringArgType -> + let s = CT_string (out_gen rawwit_string x) in + CT_coerce_STRING_OPT_to_VARG (CT_coerce_STRING_to_STRING_OPT s) + | PreIdentArgType -> + let id = CT_ident (out_gen rawwit_pre_ident x) in + CT_coerce_ID_OPT_OR_ALL_to_VARG + (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL + (CT_coerce_ID_to_ID_OPT id)) + | IntroPatternArgType -> + xlate_error "TODO" + | IdentArgType -> + let id = xlate_ident (out_gen rawwit_ident x) in + CT_coerce_ID_OPT_OR_ALL_to_VARG + (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL + (CT_coerce_ID_to_ID_OPT id)) + | HypArgType -> + xlate_error "TODO (similar to IdentArgType)" + | RefArgType -> + let id = tac_qualid_to_ct_ID (out_gen rawwit_ref x) in + CT_coerce_ID_OPT_OR_ALL_to_VARG + (CT_coerce_ID_OPT_to_ID_OPT_OR_ALL + (CT_coerce_ID_to_ID_OPT id)) + (* Specific types *) + | SortArgType -> + CT_coerce_FORMULA_OPT_to_VARG + (CT_coerce_FORMULA_to_FORMULA_OPT + (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) + | ConstrArgType -> + CT_coerce_FORMULA_OPT_to_VARG + (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr x))) + | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" + | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" + | TacticArgType -> + let t = xlate_tactic (out_gen rawwit_tactic x) in + CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t) + | CastedOpenConstrArgType -> xlate_error "TODO: generic open constr" + | ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings" + | BindingsArgType -> xlate_error "TODO: generic with bindings" + | RedExprArgType -> xlate_error "TODO: red expr as generic argument" + | List0ArgType l -> xlate_error "TODO: lists of generic arguments" + | List1ArgType l -> xlate_error "TODO: non empty lists of generic arguments" + | OptArgType x -> xlate_error "TODO: optional generic arguments" + | PairArgType (u,v) -> xlate_error "TODO: pairs of generic arguments" + | ExtraArgType s -> xlate_error "Cannot treat extra generic arguments" + + +let xlate_thm x = CT_thm (match x with + | Theorem -> "Theorem" + | Remark -> "Remark" + | Lemma -> "Lemma" + | Fact -> "Fact") + + +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_var x = CT_var (match x with + | (Global,Definitional) -> "Parameter" + | (Global,Logical) -> "Axiom" + | (Local,Definitional) -> "Variable" + | (Local,Logical) -> "Hypothesis" + | (Global,Conjectural) -> "Conjecture" + | (Local,Conjectural) -> xlate_error "No local conjecture");; + + +let xlate_dep = + function + | true -> CT_dep "Induction for" + | false -> CT_dep "Minimality for";; + +let xlate_locn = + function + | GoTo n -> CT_coerce_INT_to_INT_OR_LOCN (CT_int n) + | GoTop -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "top") + | GoPrev -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "prev") + | GoNext -> CT_coerce_LOCN_to_INT_OR_LOCN (CT_locn "next") + +let xlate_search_restr = + function + | SearchOutside [] -> CT_coerce_NONE_to_IN_OR_OUT_MODULES CT_none + | SearchInside (m1::l1) -> + CT_in_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1, + List.map loc_qualid_to_ct_ID l1)) + | SearchOutside (m1::l1) -> + CT_out_modules (CT_id_ne_list(loc_qualid_to_ct_ID m1, + List.map loc_qualid_to_ct_ID l1)) + | SearchInside [] -> xlate_error "bad extra argument for Search" + +let xlate_check = + function + | "CHECK" -> "Check" + | "PRINTTYPE" -> "Type" + | _ -> xlate_error "xlate_check";; + +let build_constructors l = + let f (coe,((_,id),c)) = + if coe then CT_constr_coercion (xlate_ident id, xlate_formula c) + else CT_constr (xlate_ident id, xlate_formula c) in + CT_constr_list (List.map f l) + +let build_record_field_list l = + let build_record_field (coe,d) = match d with + | AssumExpr (id,c) -> + if coe then CT_recconstr_coercion (xlate_id_opt id, xlate_formula c) + else + CT_recconstr(xlate_id_opt id, xlate_formula c) + | DefExpr (id,c,topt) -> + if coe then + CT_defrecconstr_coercion(xlate_id_opt id, xlate_formula c, + xlate_formula_opt topt) + else + CT_defrecconstr(xlate_id_opt id, xlate_formula c, xlate_formula_opt topt) in + CT_recconstr_list (List.map build_record_field l);; + +let get_require_flags impexp spec = + let ct_impexp = + match impexp with + | None -> CT_coerce_NONE_to_IMPEXP CT_none + | Some false -> CT_import + | Some true -> CT_export in + let ct_spec = + match spec with + | None -> ctv_SPEC_OPT_NONE + | Some true -> CT_spec + | Some false -> ctv_SPEC_OPT_NONE in + ct_impexp, ct_spec;; + +let cvt_optional_eval_for_definition c1 optional_eval = + match optional_eval with + None -> ct_coerce_FORMULA_to_DEF_BODY (xlate_formula c1) + | Some red -> + CT_coerce_EVAL_CMD_to_DEF_BODY( + CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, + xlate_red_tactic red, + xlate_formula c1)) + +let cvt_vernac_binder = function + | b,(id::idl,c) -> + let l,t = + CT_id_opt_ne_list + (xlate_ident_opt (Some (snd id)), + List.map (fun id -> xlate_ident_opt (Some (snd id))) idl), + xlate_formula c in + if b then + CT_binder_coercion(l,t) + else + CT_binder(l,t) + | _, _ -> xlate_error "binder with no left part, rejected";; + +let cvt_vernac_binders = function + a::args -> CT_binder_ne_list(cvt_vernac_binder a, List.map cvt_vernac_binder args) + | [] -> assert false;; + + +let xlate_comment = function + CommentConstr c -> CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula c) + | CommentString s -> CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT + (CT_coerce_STRING_to_ID_OR_STRING(CT_string s)) + | CommentInt n -> + CT_coerce_FORMULA_to_SCOMMENT_CONTENT + (CT_coerce_NUM_to_FORMULA(CT_int_encapsulator (string_of_int n)));; + +let translate_opt_notation_decl = function + None -> CT_coerce_NONE_to_DECL_NOTATION_OPT(CT_none) + | Some(s, f, sc) -> + let tr_sc = + match sc with + None -> ctv_ID_OPT_NONE + | Some id -> CT_coerce_ID_to_ID_OPT (CT_ident id) in + CT_decl_notation(CT_string s, xlate_formula f, tr_sc);; + +let xlate_level = function + Extend.NumLevel n -> CT_coerce_INT_to_INT_OR_NEXT(CT_int n) + | Extend.NextLevel -> CT_next_level;; + +let xlate_syntax_modifier = function + Extend.SetItemLevel((s::sl), level) -> + CT_set_item_level + (CT_id_ne_list(CT_ident s, List.map (fun s -> CT_ident s) sl), + xlate_level level) + | Extend.SetItemLevel([], _) -> assert false + | Extend.SetLevel level -> CT_set_level (CT_int level) + | Extend.SetAssoc Gramext.LeftA -> CT_lefta + | Extend.SetAssoc Gramext.RightA -> CT_righta + | Extend.SetAssoc Gramext.NonA -> CT_nona + | Extend.SetEntryType(x,typ) -> + CT_entry_type(CT_ident x, + match typ with + Extend.ETIdent -> CT_ident "ident" + | Extend.ETReference -> CT_ident "global" + | Extend.ETBigint -> CT_ident "bigint" + | _ -> xlate_error "syntax_type not parsed") + | Extend.SetOnlyParsing -> CT_only_parsing + | Extend.SetFormat(_,s) -> CT_format(CT_string s);; + + +let rec xlate_module_type = function + | CMTEident(_, qid) -> + CT_coerce_ID_to_MODULE_TYPE(CT_ident (xlate_qualid qid)) + | CMTEwith(mty, decl) -> + let mty1 = xlate_module_type mty in + (match decl with + CWith_Definition((_, 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, + CT_ident (xlate_qualid qid)));; + +let xlate_module_binder_list (l:module_binder list) = + CT_module_binder_list + (List.map (fun (idl, mty) -> + let idl1 = + List.map (fun (_, x) -> CT_ident (string_of_id x)) idl in + let fst,idl2 = match idl1 with + [] -> assert false + | fst::idl2 -> fst,idl2 in + CT_module_binder + (CT_id_ne_list(fst, idl2), xlate_module_type mty)) l);; + +let xlate_module_type_check_opt = function + None -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK + (CT_coerce_ID_OPT_to_MODULE_TYPE_OPT ctv_ID_OPT_NONE) + | Some(mty, true) -> CT_only_check(xlate_module_type mty) + | Some(mty, false) -> + CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK + (CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT + (xlate_module_type mty));; + +let rec xlate_module_expr = function + CMEident (_, qid) -> CT_coerce_ID_OPT_to_MODULE_EXPR + (CT_coerce_ID_to_ID_OPT (CT_ident (xlate_qualid qid))) + | CMEapply (me1, me2) -> CT_module_app(xlate_module_expr me1, + xlate_module_expr me2) + +let rec xlate_vernac = + function + | VernacDeclareTacticDefinition (true, tacs) -> + (match List.map + (function + ((_, id), body) -> + CT_tac_def(CT_ident (string_of_id id), xlate_tactic body)) + tacs with + [] -> assert false + | fst::tacs1 -> + CT_tactic_definition + (CT_tac_def_ne_list(fst, tacs1))) + | VernacDeclareTacticDefinition(false, _) -> + xlate_error "obsolete tactic definition not handled" + | VernacLoad (verbose,s) -> + CT_load ( + (match verbose with + | false -> CT_coerce_NONE_to_VERBOSE_OPT CT_none + | true -> CT_verbose), + CT_coerce_STRING_to_ID_OR_STRING (CT_string s)) + | VernacCheckMayEval (Some red, numopt, f) -> + let red = xlate_red_tactic red in + CT_coerce_EVAL_CMD_to_COMMAND + (CT_eval (xlate_int_opt numopt, red, xlate_formula f)) + |VernacChdir opt_s -> CT_cd (ctf_STRING_OPT opt_s) + | VernacAddLoadPath (false,str,None) -> + CT_addpath (CT_string str, ctv_ID_OPT_NONE) + | VernacAddLoadPath (false,str,Some x) -> + CT_addpath (CT_string str, + CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x))) + | VernacAddLoadPath (true,str,None) -> + CT_recaddpath (CT_string str, ctv_ID_OPT_NONE) + | VernacAddLoadPath (_,str, Some x) -> + CT_recaddpath (CT_string str, + CT_coerce_ID_to_ID_OPT (CT_ident (string_of_dirpath x))) + | VernacRemoveLoadPath str -> CT_delpath (CT_string str) + | VernacToplevelControl Quit -> CT_quit + | VernacToplevelControl _ -> xlate_error "Drop/ProtectedToplevel not supported" + (*ML commands *) + | VernacAddMLPath (false,str) -> CT_ml_add_path (CT_string str) + | VernacAddMLPath (true,str) -> CT_rec_ml_add_path (CT_string str) + | VernacDeclareMLModule [] -> failwith "" + | VernacDeclareMLModule (str :: l) -> + CT_ml_declare_modules + (CT_string_ne_list (CT_string str, List.map (fun x -> CT_string x) l)) + | VernacGoal c -> + CT_coerce_THEOREM_GOAL_to_COMMAND (CT_goal (xlate_formula c)) + | VernacAbort (Some (_,id)) -> + CT_abort(ctf_ID_OPT_OR_ALL_SOME(xlate_ident id)) + | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE + | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL + | VernacRestart -> CT_restart + | VernacSolve (n, tac, b) -> + CT_solve (CT_int n, xlate_tactic tac, + if b then CT_dotdot + else CT_coerce_NONE_to_DOTDOT_OPT CT_none) + | VernacFocus nopt -> CT_focus (xlate_int_opt nopt) + | VernacUnfocus -> CT_unfocus + |VernacExtend("Extraction", [f;l]) -> + let file = out_gen rawwit_string f in + let l1 = out_gen (wit_list1 rawwit_ref) l in + let fst,l2 = match l1 with [] -> assert false | fst::l2 -> fst, l2 in + CT_extract_to_file(CT_string file, + CT_id_ne_list(loc_qualid_to_ct_ID fst, + List.map loc_qualid_to_ct_ID l2)) + | VernacExtend("ExtractionInline", [l]) -> + let l1 = out_gen (wit_list1 rawwit_ref) l in + let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in + CT_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, + List.map loc_qualid_to_ct_ID l2)) + | VernacExtend("ExtractionNoInline", [l]) -> + let l1 = out_gen (wit_list1 rawwit_ref) l in + let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in + CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, + List.map loc_qualid_to_ct_ID l2)) + | VernacExtend("Field", + [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl;minusdiv]) -> + (match List.map (fun v -> xlate_formula(out_gen rawwit_constr v)) + [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl] + with + [a1;aplus1;amult1;aone1;azero1;aopp1;aeq1;ainv1;fth1;ainvl1] -> + let bind = + match out_gen Field.rawwit_minus_div_arg minusdiv with + None, None -> + CT_binding_list[] + | Some m, None -> + CT_binding_list[ + CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m)] + | None, Some d -> + CT_binding_list[ + CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] + | Some m, Some d -> + CT_binding_list[ + CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m); + CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] in + CT_add_field(a1, aplus1, amult1, aone1, azero1, aopp1, aeq1, + ainv1, fth1, ainvl1, bind) + |_ -> 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 + let ct_orient = match orient with + | true -> CT_lr + | false -> CT_rl in + let f_ne_list = match List.map xlate_formula formula_list with + (fst::rest) -> CT_formula_ne_list(fst,rest) + | _ -> assert false in + CT_hintrewrite(ct_orient, f_ne_list, CT_ident base, xlate_tactic t) + | VernacHints (local,dbnames,h) -> + let dblist = CT_id_list(List.map (fun x -> CT_ident x) dbnames) in + (match h with + | HintsConstructors (None, l) -> + let n1, names = match List.map tac_qualid_to_ct_ID l with + n1 :: names -> n1, names + | _ -> failwith "" in + if local then + CT_local_hints(CT_ident "Constructors", + CT_id_ne_list(n1, names), dblist) + else + CT_hints(CT_ident "Constructors", + CT_id_ne_list(n1, names), dblist) + | HintsExtern (None, 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 + a :: tl -> a, tl + | _ -> failwith "" in + let l' = CT_formula_ne_list(f1, formulas) in + if local then + (match h with + HintsResolve _ -> + CT_local_hints_resolve(l', dblist) + | HintsImmediate _ -> + CT_local_hints_immediate(l', dblist) + | _ -> assert false) + else + (match h with + HintsResolve _ -> CT_hints_resolve(l', dblist) + | HintsImmediate _ -> CT_hints_immediate(l', dblist) + | _ -> assert false) + | HintsUnfold l -> + let 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 + n1 :: names -> n1, names + | _ -> failwith "" in + if local then + CT_local_hints(CT_ident "Unfold", + CT_id_ne_list(n1, names), dblist) + else + CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) + | HintsDestruct(id, n, loc, f, t) -> + let dl = match loc with + ConclLocation() -> CT_conclusion_location + | HypLocation true -> CT_discardable_hypothesis + | HypLocation false -> CT_hypothesis_location in + if local then + CT_local_hint_destruct + (xlate_ident id, CT_int n, + dl, xlate_formula f, xlate_tactic t, dblist) + else + CT_hint_destruct + (xlate_ident id, CT_int n, dl, xlate_formula f, + xlate_tactic t, dblist) + | 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) + | VernacEndProof (Proved (false,None)) -> + CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Definition"), ctv_ID_OPT_NONE) + | VernacEndProof (Proved (b,Some ((_,s), Some kind))) -> + CT_save (CT_coerce_THM_to_THM_OPT (xlate_thm kind), + ctf_ID_OPT_SOME (xlate_ident s)) + | VernacEndProof (Proved (b,Some ((_,s),None))) -> + CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Theorem"), + ctf_ID_OPT_SOME (xlate_ident s)) + | VernacEndProof Admitted -> + CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Admitted"), ctv_ID_OPT_NONE) + | VernacSetOpacity (false, id :: idl) -> + CT_transparent(CT_id_ne_list(loc_qualid_to_ct_ID id, + List.map loc_qualid_to_ct_ID idl)) + | VernacSetOpacity (true, id :: idl) + -> CT_opaque (CT_id_ne_list(loc_qualid_to_ct_ID id, + List.map loc_qualid_to_ct_ID idl)) + | VernacSetOpacity (_, []) -> xlate_error "Shouldn't occur" + | VernacUndo n -> CT_undo (CT_coerce_INT_to_INT_OPT (CT_int n)) + | VernacShow (ShowGoal nopt) -> CT_show_goal (xlate_int_opt nopt) + | VernacShow ShowNode -> CT_show_node + | VernacShow ShowProof -> CT_show_proof + | VernacShow ShowTree -> CT_show_tree + | VernacShow ShowProofNames -> CT_show_proofs + | VernacShow (ShowIntros true) -> CT_show_intros + | VernacShow (ShowIntros false) -> CT_show_intro + | VernacShow (ShowGoalImplicitly None) -> CT_show_implicit (CT_int 1) + | VernacShow (ShowGoalImplicitly (Some n)) -> CT_show_implicit (CT_int n) + | VernacShow ShowExistentials -> CT_show_existentials + | VernacShow ShowScript -> CT_show_script + | VernacGo arg -> CT_go (xlate_locn arg) + | VernacShow ExplainProof l -> CT_explain_proof (nums_to_int_list l) + | VernacShow ExplainTree l -> + CT_explain_prooftree (nums_to_int_list l) + | VernacCheckGuard -> CT_guarded + | VernacPrint p -> + (match p with + PrintFullContext -> CT_print_all + | PrintName id -> CT_print_id (loc_qualid_to_ct_ID id) + | PrintOpaqueName id -> CT_print_opaqueid (loc_qualid_to_ct_ID id) + | PrintSectionContext id -> CT_print_section (loc_qualid_to_ct_ID id) + | PrintModules -> CT_print_modules + | PrintGrammar (phylum, name) -> CT_print_grammar CT_grammar_none + | PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star) + | PrintHintDbName id -> + CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id)) + | PrintHint id -> + CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_qualid_to_ct_ID id)) + | PrintHintGoal -> CT_print_hint ctv_ID_OPT_NONE + | PrintLoadPath -> CT_print_loadpath + | PrintMLLoadPath -> CT_ml_print_path + | PrintMLModules -> CT_ml_print_modules + | PrintGraph -> CT_print_graph + | PrintClasses -> CT_print_classes + | PrintCoercions -> CT_print_coercions + | PrintCoercionPaths (id1, id2) -> + CT_print_path (xlate_class id1, xlate_class id2) + | PrintInspect n -> CT_inspect (CT_int n) + | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) + | PrintLocalContext -> CT_print + | PrintTables -> CT_print_tables + | PrintModuleType a -> CT_print_module_type (loc_qualid_to_ct_ID a) + | PrintModule a -> CT_print_module (loc_qualid_to_ct_ID a) + | PrintScopes -> CT_print_scopes + | PrintScope id -> CT_print_scope (CT_ident id) + | PrintVisibility id_opt -> + CT_print_visibility + (match id_opt with + Some id -> CT_coerce_ID_to_ID_OPT(CT_ident id) + | None -> ctv_ID_OPT_NONE) + | PrintAbout qid -> CT_print_about(loc_qualid_to_ct_ID qid) + | PrintImplicit qid -> CT_print_implicit(loc_qualid_to_ct_ID qid)) + | VernacBeginSection (_,id) -> + CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id)) + | VernacEndSegment (_,id) -> CT_section_end (xlate_ident id) + | VernacStartTheoremProof (k, (_,s), (bl,c), _, _) -> + CT_coerce_THEOREM_GOAL_to_COMMAND( + CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s, + xlate_binder_list bl, xlate_formula c)) + | VernacSuspend -> CT_suspend + | VernacResume idopt -> CT_resume (xlate_ident_opt (option_app snd idopt)) + | VernacDefinition (k,(_,s),ProveBody (bl,typ),_) -> + CT_coerce_THEOREM_GOAL_to_COMMAND + (CT_theorem_goal + (CT_coerce_DEFN_to_DEFN_OR_THM (xlate_defn k), + xlate_ident s, xlate_binder_list bl, xlate_formula typ)) + | VernacDefinition (kind,(_,s),DefineBody(bl,red_option,c,typ_opt),_) -> + CT_definition + (xlate_defn kind, xlate_ident s, xlate_binder_list bl, + cvt_optional_eval_for_definition c red_option, + xlate_formula_opt typ_opt) + | VernacAssumption (kind, b) -> + CT_variable (xlate_var kind, cvt_vernac_binders b) + | VernacCheckMayEval (None, numopt, c) -> + CT_check (xlate_formula c) + | VernacSearch (s,x) -> + let translated_restriction = xlate_search_restr x in + (match s with + | SearchPattern c -> + CT_search_pattern(xlate_formula c, translated_restriction) + | SearchHead id -> + CT_search(loc_qualid_to_ct_ID id, translated_restriction) + | SearchRewrite c -> + CT_search_rewrite(xlate_formula c, translated_restriction) + | SearchAbout (a::l) -> + let xlate_search_about_item it = + match it with + SearchRef x -> + CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) + | SearchString s -> + CT_coerce_STRING_to_ID_OR_STRING(CT_string s) in + CT_search_about + (CT_id_or_string_ne_list(xlate_search_about_item a, + List.map xlate_search_about_item l), + translated_restriction) + | SearchAbout [] -> assert false) + + | (*Record from tactics/Record.v *) + VernacRecord + (_, (add_coercion, (_,s)), binders, c1, + rec_constructor_or_none, field_list) -> + let record_constructor = + xlate_ident_opt (option_app snd rec_constructor_or_none) in + CT_record + ((if add_coercion then CT_coercion_atm else + CT_coerce_NONE_to_COERCION_OPT(CT_none)), + xlate_ident s, xlate_binder_list binders, + xlate_formula c1, record_constructor, + build_record_field_list field_list) + | VernacInductive (isind, lmi) -> + let co_or_ind = if isind then "Inductive" else "CoInductive" in + let strip_mutind ((_,s), notopt, parameters, c, constructors) = + CT_ind_spec + (xlate_ident s, xlate_binder_list parameters, xlate_formula c, + build_constructors constructors, + translate_opt_notation_decl notopt) in + CT_mind_decl + (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi)) + | VernacFixpoint [] -> xlate_error "mutual recursive" + | VernacFixpoint (lm :: lmi) -> + let strip_mutrec ((fid, n, bl, arf, ardef), ntn) = + 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 + let ardef = xlate_formula ardef in + match xlate_binder_list bl with + | CT_binder_list (b :: bl) -> + CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), + struct_arg, arf, ardef) + | _ -> xlate_error "mutual recursive" in + CT_fix_decl + (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi)) + | VernacCoFixpoint [] -> xlate_error "mutual corecursive" + | VernacCoFixpoint (lm :: lmi) -> + let strip_mutcorec (fid, bl, arf, ardef) = + CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, + xlate_formula arf, xlate_formula ardef) in + CT_cofix_decl + (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi)) + | VernacScheme [] -> xlate_error "induction scheme" + | VernacScheme (lm :: lmi) -> + let strip_ind ((_,id), depstr, inde, sort) = + CT_scheme_spec + (xlate_ident id, xlate_dep depstr, + CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde), + xlate_sort sort) in + CT_ind_scheme + (CT_scheme_spec_list (strip_ind lm, List.map strip_ind lmi)) + | VernacSyntacticDefinition (id, c, false, _) -> + CT_syntax_macro (xlate_ident id, xlate_formula c, xlate_int_opt None) + | VernacSyntacticDefinition (id, c, true, _) -> + xlate_error "TODO: Local abbreviations" + (* Modules and Module Types *) + | VernacDeclareModuleType((_, id), bl, mty_o) -> + CT_module_type_decl(xlate_ident id, + xlate_module_binder_list bl, + match mty_o with + None -> + CT_coerce_ID_OPT_to_MODULE_TYPE_OPT + ctv_ID_OPT_NONE + | Some mty1 -> + CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT + (xlate_module_type mty1)) + | VernacDefineModule((_, id), bl, mty_o, mexpr_o) -> + CT_module(xlate_ident id, + xlate_module_binder_list bl, + xlate_module_type_check_opt mty_o, + match mexpr_o with + None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE + | Some m -> xlate_module_expr m) + | VernacDeclareModule((_, id), bl, mty_o, mexpr_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) + | VernacRequire (impexp, spec, id::idl) -> + let ct_impexp, ct_spec = get_require_flags impexp spec in + CT_require (ct_impexp, ct_spec, + CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING( + CT_id_ne_list(loc_qualid_to_ct_ID id, + List.map loc_qualid_to_ct_ID idl))) + | VernacRequire (_,_,[]) -> + xlate_error "Require should have at least one id argument" + | VernacRequireFrom (impexp, spec, filename) -> + let ct_impexp, ct_spec = get_require_flags impexp spec in + CT_require(ct_impexp, ct_spec, + CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename)) + + | VernacSyntax (phylum, l) -> xlate_error "SYNTAX not implemented" + + | VernacOpenCloseScope(true, true, s) -> CT_local_open_scope(CT_ident s) + | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s) + | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s) + | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s) + | VernacArgumentsScope(qid, l) -> + CT_arguments_scope(loc_qualid_to_ct_ID qid, + CT_id_opt_list + (List.map + (fun x -> + match x with + None -> ctv_ID_OPT_NONE + | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l)) + | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2) + | VernacBindScope(id, a::l) -> + let xlate_class_rawexpr = function + FunClass -> CT_ident "Funclass" | SortClass -> CT_ident "Sortclass" + | RefClass qid -> loc_qualid_to_ct_ID qid in + CT_bind_scope(CT_ident id, + CT_id_ne_list(xlate_class_rawexpr a, + List.map xlate_class_rawexpr l)) + | VernacBindScope(id, []) -> assert false + | VernacNotation(b, c, None, _, _) -> assert false + | VernacNotation(b, c, Some(s,modif_list), _, opt_scope) -> + let translated_s = CT_string s in + let formula = xlate_formula c in + let translated_modif_list = + CT_modifier_list(List.map xlate_syntax_modifier modif_list) in + let translated_scope = match opt_scope with + None -> ctv_ID_OPT_NONE + | Some x -> ctf_ID_OPT_SOME(CT_ident x) in + if b then + CT_local_define_notation + (translated_s, formula, translated_modif_list, translated_scope) + else + CT_define_notation(translated_s, formula, + translated_modif_list, translated_scope) + | VernacSyntaxExtension(b,Some(s,modif_list), None) -> + let translated_s = CT_string s in + let translated_modif_list = + CT_modifier_list(List.map xlate_syntax_modifier modif_list) in + if b then + CT_local_reserve_notation(translated_s, translated_modif_list) + else + CT_reserve_notation(translated_s, translated_modif_list) + | VernacSyntaxExtension(_, _, _) -> assert false + | VernacInfix (b,(str,modl),id,_, opt_scope) -> + let id1 = loc_qualid_to_ct_ID id in + let modl1 = CT_modifier_list(List.map xlate_syntax_modifier modl) in + let s = CT_string str in + let translated_scope = match opt_scope with + None -> ctv_ID_OPT_NONE + | Some x -> ctf_ID_OPT_SOME(CT_ident x) in + if b then + CT_local_infix(s, id1,modl1, translated_scope) + else + CT_infix(s, id1,modl1, translated_scope) + | 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 = + match s with + (* Cannot decide whether it is a global or a Local but at toplevel *) + | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none + | Local -> CT_local in + CT_coercion (local_opt, id_opt, loc_qualid_to_ct_ID id1, + xlate_class id2, xlate_class id3) + + | VernacIdentityCoercion (s, (_,id1), id2, id3) -> + let id_opt = CT_identity in + let local_opt = + match s with + (* Cannot decide whether it is a global or a Local but at toplevel *) + | Global -> CT_coerce_NONE_to_LOCAL_OPT CT_none + | Local -> CT_local in + CT_coercion (local_opt, id_opt, xlate_ident id1, + xlate_class id2, xlate_class id3) + | VernacResetName id -> CT_reset (xlate_ident (snd id)) + | VernacResetInitial -> CT_restore_state (CT_ident "Initial") + | VernacExtend (s, l) -> + CT_user_vernac + (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l)) + | VernacDebug b -> xlate_error "Debug On/Off not supported" + | VernacList((_, a)::l) -> + CT_coerce_COMMAND_LIST_to_COMMAND + (CT_command_list(xlate_vernac a, + List.map (fun (_, x) -> xlate_vernac x) l)) + | VernacList([]) -> assert false + | (VernacV7only _ | VernacV8only _) -> + xlate_error "Not treated here" + | VernacNop -> CT_proof_no_op + | VernacComments l -> + CT_scomments(CT_scomment_content_list (List.map xlate_comment l)) + | VernacDeclareImplicits(id, opt_positions) -> + CT_implicits + (reference_to_ct_ID id, + match opt_positions with + None -> CT_coerce_NONE_to_ID_LIST_OPT CT_none + | Some l -> + CT_coerce_ID_LIST_to_ID_LIST_OPT + (CT_id_list + (List.map + (function ExplByPos x + -> xlate_error + "explication argument by rank is obsolete" + | ExplByName id -> CT_ident (string_of_id id)) l))) + | VernacReserve((_,a)::l, f) -> + CT_reserve(CT_id_ne_list(xlate_ident a, + List.map (fun (_,x) -> xlate_ident x) l), + xlate_formula f) + | VernacReserve([], _) -> assert false + | VernacLocate(LocateTerm id) -> CT_locate(reference_to_ct_ID id) + | VernacLocate(LocateLibrary id) -> CT_locate_lib(reference_to_ct_ID id) + | VernacLocate(LocateFile s) -> CT_locate_file(CT_string s) + | VernacLocate(LocateNotation s) -> CT_locate_notation(CT_string s) + | VernacTime(v) -> CT_time(xlate_vernac v) + | VernacSetOption (Goptions.SecondaryTable ("Implicit", "Arguments"), BoolValue true)->CT_user_vernac (CT_ident "IMPLICIT_ARGS_ON", CT_varg_list[]) + |VernacExactProof f -> CT_proof(xlate_formula f) + | VernacSetOption (table, BoolValue true) -> + let table1 = + match table with + PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + CT_set_option(table1) + | VernacSetOption (table, v) -> + let table1 = + match table with + PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + let value = + match v with + | BoolValue _ -> assert false + | StringValue s -> + CT_coerce_STRING_to_SINGLE_OPTION_VALUE(CT_string s) + | IntValue n -> + CT_coerce_INT_to_SINGLE_OPTION_VALUE(CT_int n) in + CT_set_option_value(table1, value) + | VernacUnsetOption(table) -> + let table1 = + match table with + PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + CT_unset_option(table1) + | VernacAddOption (table, l) -> + let values = + List.map + (function + | QualidRefValue x -> + CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) + | StringRefValue x -> + CT_coerce_STRING_to_ID_OR_STRING(CT_string x)) l in + let fst, values1 = + match values with [] -> assert false | a::b -> (a,b) in + let table1 = + match table with + PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s) + | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in + CT_set_option_value2(table1, CT_id_or_string_ne_list(fst, values1)) + | VernacImport(true, a::l) -> + CT_export_id(CT_id_ne_list(reference_to_ct_ID a, + List.map reference_to_ct_ID l)) + | VernacImport(false, a::l) -> + CT_import_id(CT_id_ne_list(reference_to_ct_ID a, + List.map reference_to_ct_ID l)) + | VernacImport(_, []) -> assert false + | VernacProof t -> CT_proof_with(xlate_tactic t) + | VernacVar _ -> xlate_error "Grammar vernac obsolete" + | (VernacGlobalCheck _|VernacPrintOption _| + VernacMemOption (_, _)|VernacRemoveOption (_, _) + | VernacBack _|VernacRestoreState _| VernacWriteState _| + VernacSolveExistential (_, _)|VernacCanonical _ | VernacDistfix _| + VernacTacticGrammar _) + -> xlate_error "TODO: vernac";; + +let rec xlate_vernac_list = + function + | 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/interface/xlate.mli b/contrib/interface/xlate.mli new file mode 100644 index 00000000..bedb4ac8 --- /dev/null +++ b/contrib/interface/xlate.mli @@ -0,0 +1,9 @@ +open Ascent;; + +val xlate_vernac : Vernacexpr.vernac_expr -> ct_COMMAND;; +val xlate_tactic : Tacexpr.raw_tactic_expr -> ct_TACTIC_COM;; +val xlate_formula : Topconstr.constr_expr -> ct_FORMULA;; +val xlate_ident : Names.identifier -> ct_ID;; +val xlate_vernac_list : Vernacexpr.vernac_expr -> ct_COMMAND_LIST;; + +val declare_in_coq : (unit -> unit);; diff --git a/contrib/jprover/README b/contrib/jprover/README new file mode 100644 index 00000000..ec654a03 --- /dev/null +++ b/contrib/jprover/README @@ -0,0 +1,76 @@ +An intuitionistic first-order theorem prover -- JProver. + +Usage: + +Require JProver. +Jp [num]. + +Whem [num] is provided, proof is done automatically with +the multiplicity limit [num], otherwise no limit is forced +and JProver may not terminate. + +Example: + +Require JProver. +Coq < Goal (P:Prop) P->P. +1 subgoal + +============================ + (P:Prop)P->P + +Unnamed_thm < Jp 1. +Proof is built. +Subtree proved! +----------------------------------------- + +Description: +JProver is a theorem prover for first-order intuitionistic logic. +It is originally implemented by Stephan Schmitt and then integrated into +MetaPRL by Aleksey Nogin (see jall.ml). After this, Huang extracted the +necessary ML-codes from MetaPRL and then integrated it into Coq. +The MetaPRL URL is http://metaprl.org/. For more information on +integrating JProver into interactive proof assistants, please refer to + + "Stephan Schmitt, Lori Lorigo, Christoph Kreitz, and Aleksey Nogin, + Jprover: Integrating connection-based theorem proving into interactive + proof assistants. In International Joint Conference on Automated + Reasoning, volume 2083 of Lecture Notes in Artificial Intelligence, + pages 421-426. Springer-Verlag, 2001" - + http://www.cs.cornell.edu/nogin/papers/jprover.html + + +Structure of this directory: +This directory contains + + README ------ this file + jall.ml ------ the main module of JProver + jtunify.ml ------ string unification procedures for jall.ml + jlogic.ml ------ interface module of jall.ml + jterm.ml + opname.ml ------ implement the infrastructure for jall.ml + jprover.ml4 ------ the interface of jall.ml to Coq + JProver.v ------ declaration for Coq + Makefile ------ the makefile + go ------ batch file to load JProver to Coq dynamically + + +Comments: +1. The original <jall.ml> is located in meta-prl/refiner/reflib of the +MetaPRL directory. Some parts of this file are modified by Huang. + +2. <jtunify.ml> is also located in meta-prl/refiner/reflib with no modification. + +3. <jlogic.ml> is modified from meta-prl/refiner/reflib/jlogic_sig.mlz. + +4. <jterm.ml> and <opname.ml> are modified from the standard term module +of MetaPRL in meta-prl/refiner/term_std. + +5. The Jp tactic currently cannot prove formula such as + ((x:nat) (P x)) -> (EX y:nat| (P y)), which requires extra constants +in the domain when the left-All rule is applied. + + + +by Huang Guan-Shieng (Guan-Shieng.Huang@lri.fr), March 2002. + + diff --git a/contrib/jprover/jall.ml b/contrib/jprover/jall.ml new file mode 100644 index 00000000..876dc6c0 --- /dev/null +++ b/contrib/jprover/jall.ml @@ -0,0 +1,4701 @@ +(* + * JProver first-order automated prover. See the interface file + * for more information and a list of references for JProver. + * + * ---------------------------------------------------------------- + * + * This file is part of MetaPRL, a modular, higher order + * logical framework that provides a logical programming + * environment for OCaml and other languages. + * + * See the file doc/index.html for information on Nuprl, + * OCaml, and more information about this system. + * + * Copyright (C) 2000 Stephan Schmitt + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + * + * Author: Stephan Schmitt <schmitts@spmail.slu.edu> + * Modified by: Aleksey Nogin <nogin@cs.cornell.edu> + *) + +(*: All of Huang's modifications of this file are quoted or denoted + by comments followed by a colon. +:*) + +(*: +open Mp_debug + +open Refiner.Refiner +open Term +open TermType +open TermOp +open TermSubst +open TermMan +open RefineError +open Opname +:*) + +open Jterm +open Opname +open Jlogic +open Jtunify + +let ruletable = Jlogic.ruletable + +(*: +let free_var_op = make_opname ["free_variable";"Jprover"] +let jprover_op = make_opname ["string";"Jprover"] +:*) +let free_var_op = make_opname ["free_variable"; "Jprover"] +let jprover_op = make_opname ["jprover"; "string"] + +module JProver (JLogic : JLogicSig) = +struct + type polarity = I | O + + type connective = And | Or | Neg | Imp | All | Ex | At | Null + + type ptype = Alpha | Beta | Gamma | Delta | Phi | Psi | PNull + + type stype = + Alpha_1 | Alpha_2 | Beta_1 | Beta_2 | Gamma_0 | Delta_0 + | Phi_0 | Psi_0 | PNull_0 + + type pos = {name : string; + address : int list; + op : connective; + pol : polarity; + pt : ptype; + st : stype; + label : term} + + type 'pos ftree = + Empty + | NodeAt of 'pos + | NodeA of 'pos * ('pos ftree) array + + type atom = {aname : string; + aaddress : int list; + aprefix : string list; + apredicate : operator; + apol : polarity; + ast : stype; + alabel : term} + + type atom_relations = atom * atom list * atom list +(* all atoms except atom occur in [alpha_set] and [beta_set] of atom*) + +(* beta proofs *) + + type bproof = BEmpty + | RNode of string list * bproof + | CNode of (string * string) + | BNode of string * (string list * bproof) * (string list * bproof) + | AtNode of string * (string * string) + +(* Assume only constants for instantiations, not adapted to terms yet *) + type inf = rule * term * term + +(* proof tree for pretty print and permutation *) + type 'inf ptree = + PEmpty + | PNodeAx of 'inf + | PNodeA of 'inf * 'inf ptree + | PNodeB of 'inf * 'inf ptree * 'inf ptree + + module OrderedAtom = + struct + type t = atom + let compare a1 a2 = if (a1.aname) = (a2.aname) then 0 else + if (a1.aname) < (a2.aname) then -1 else 1 + end + + module AtomSet = Set.Make(OrderedAtom) + + module OrderedString = + struct + type t = string + let compare a1 a2 = if a1 = a2 then 0 else + if a1 < a2 then -1 else 1 + end + + module StringSet = Set.Make(OrderedString) + +(*i let _ = + show_loading "Loading Jall%t" i*) + + let debug_jprover = + create_debug (**) + { debug_name = "jprover"; + debug_description = "Display Jprover operations"; + debug_value = false + } + + let jprover_bug = Invalid_argument "Jprover bug (Jall module)" + +(*****************************************************************) + +(************* printing function *************************************) + +(************ printing T-string unifiers ****************************) + +(* ******* printing ********** *) + + let rec list_to_string s = + match s with + [] -> "" + | f::r -> + f^"."^(list_to_string r) + + let rec print_eqlist eqlist = + match eqlist with + [] -> + print_endline "" + | (atnames,f)::r -> + let (s,t) = f in + let ls = list_to_string s + and lt = list_to_string t in + begin + print_endline ("Atom names: "^(list_to_string atnames)); + print_endline (ls^" = "^lt); + print_eqlist r + end + + let print_equations eqlist = + begin + Format.open_box 0; + Format.force_newline (); + print_endline "Equations:"; + print_eqlist eqlist; + Format.force_newline (); + end + + let rec print_subst sigma = + match sigma with + [] -> + print_endline "" + | f::r -> + let (v,s) = f in + let ls = list_to_string s in + begin + print_endline (v^" = "^ls); + print_subst r + end + + let print_tunify sigma = + let (n,subst) = sigma in + begin + print_endline " "; + print_endline ("MaxVar = "^(string_of_int (n-1))); + print_endline " "; + print_endline "Substitution:"; + print_subst subst; + print_endline " " + end + +(*****************************************************) + +(********* printing atoms and their relations ***********************) + + let print_stype st = + match st with + Alpha_1 -> Format.print_string "Alpha_1" + | Alpha_2 -> Format.print_string "Alpha_2" + | Beta_1 -> Format.print_string "Beta_1" + | Beta_2 -> Format.print_string "Beta_2" + | Gamma_0 -> Format.print_string "Gamma_0" + | Delta_0 -> Format.print_string "Delta_0" + | Phi_0 -> Format.print_string "Phi_0" + | Psi_0 -> Format.print_string "Psi_0" + | PNull_0 -> Format.print_string "PNull_0" + + let print_pol pol = + if pol = O then + Format.print_string "O" + else + Format.print_string "I" + + let rec print_address int_list = + match int_list with + [] -> + Format.print_string "" + | hd::rest -> + begin + Format.print_int hd; + print_address rest + end + + let rec print_prefix prefix_list = + match prefix_list with + [] -> Format.print_string "" + | f::r -> + begin + Format.print_string f; + print_prefix r + end + + let print_atom at tab = + let ({aname=x; aaddress=y; aprefix=z; apredicate=p; apol=a; ast=b; alabel=label}) = at in + begin + Format.print_string ("{aname="^x^"; address="); + print_address y; + Format.print_string "; "; + Format.force_newline (); + Format.print_break (tab+1) (tab+1); + Format.print_string "prefix="; + print_prefix z; + Format.print_string "; predicate=<abstr>; "; + Format.print_break (tab+1) (tab+1); + Format.print_break (tab+1) (tab+1); + Format.print_string "pol="; + print_pol a; + Format.print_string "; stype="; + print_stype b; + Format.print_string "; arguments=[<abstr>]"; + Format.print_string "\n alabel="; + print_term stdout label; + Format.print_string "}" + end + + let rec print_atom_list set tab = + match set with + [] -> Format.print_string "" + | (f::r) -> + begin + Format.force_newline (); + Format.print_break (tab) (tab); + print_atom f tab; + print_atom_list r (tab) + end + + let rec print_atom_info atom_relation = + match atom_relation with + [] -> Format.print_string "" + | (a,b,c)::r -> + begin + Format.print_string "atom:"; + Format.force_newline (); + Format.print_break 3 3; + print_atom a 3; + Format.force_newline (); + Format.print_break 0 0; + Format.print_string "alpha_set:"; + print_atom_list b 3; + Format.force_newline (); + Format.print_break 0 0; + Format.print_string "beta_set:"; + print_atom_list c 3; + Format.force_newline (); + Format.force_newline (); + Format.print_break 0 0; + print_atom_info r + end + +(*************** print formula tree, tree ordering etc. ***********) + + let print_ptype pt = + match pt with + Alpha -> Format.print_string "Alpha" + | Beta -> Format.print_string "Beta" + | Gamma -> Format.print_string "Gamma" + | Delta -> Format.print_string "Delta" + | Phi -> Format.print_string "Phi" + | Psi -> Format.print_string "Psi" + | PNull -> Format.print_string "PNull" + + let print_op op = + match op with + At -> Format.print_string "Atom" + | Neg -> Format.print_string "Neg" + | And -> Format.print_string "And" + | Or -> Format.print_string "Or" + | Imp -> Format.print_string "Imp" + | Ex -> Format.print_string "Ex" + | All -> Format.print_string "All" + | Null -> Format.print_string "Null" + + let print_position position tab = + let ({name=x; address=y; op=z; pol=a; pt=b; st=c; label=t}) = position in + begin + Format.print_string ("{name="^x^"; address="); + print_address y; + Format.print_string "; "; + Format.force_newline (); + Format.print_break (tab+1) 0; +(* Format.print_break 0 3; *) + Format.print_string "op="; + print_op z; + Format.print_string "; pol="; + print_pol a; + Format.print_string "; ptype="; + print_ptype b; + Format.print_string "; stype="; + print_stype c; + Format.print_string ";"; + Format.force_newline (); + Format.print_break (tab+1) 0; + Format.print_string "label="; + Format.print_break 0 0; + Format.force_newline (); + Format.print_break tab 0; + print_term stdout t; + Format.print_string "}" + end + + let rec pp_ftree_list tree_list tab = + let rec pp_ftree ftree new_tab = + let dummy = String.make (new_tab-2) ' ' in + match ftree with + Empty -> Format.print_string "" + | NodeAt(position) -> + begin + Format.force_newline (); + Format.print_break new_tab 0; + print_string (dummy^"AtomNode: "); +(* Format.force_newline (); + Format.print_break 0 3; +*) + print_position position new_tab; + Format.force_newline (); + Format.print_break new_tab 0 + end + | NodeA(position,subtrees) -> + let tree_list = Array.to_list subtrees in + begin + Format.force_newline (); + Format.print_break new_tab 0; + Format.print_break 0 0; + print_string (dummy^"InnerNode: "); + print_position position new_tab; + Format.force_newline (); + Format.print_break 0 0; + pp_ftree_list tree_list (new_tab-3) + end + in + let new_tab = tab+5 in + match tree_list with + [] -> Format.print_string "" + | first::rest -> + begin + pp_ftree first new_tab; + pp_ftree_list rest tab + end + + let print_ftree ftree = + begin + Format.open_box 0; + Format.print_break 3 0; + pp_ftree_list [ftree] 0; + Format.print_flush () + end + + let rec stringlist_to_string stringlist = + match stringlist with + [] -> "." + | f::r -> + let rest_s = stringlist_to_string r in + (f^"."^rest_s) + + let rec print_stringlist slist = + match slist with + [] -> + Format.print_string "" + | f::r -> + begin + Format.print_string (f^"."); + print_stringlist r + end + + let rec pp_bproof_list tree_list tab = + let rec pp_bproof ftree new_tab = + let dummy = String.make (new_tab-2) ' ' in + match ftree with + BEmpty -> Format.print_string "" + | CNode((c1,c2)) -> + begin + Format.open_box 0; + Format.force_newline (); + Format.print_break (new_tab-10) 0; + Format.open_box 0; + Format.force_newline (); + Format.print_string (dummy^"CloseNode: connection = ("^c1^","^c2^")"); + Format.print_flush(); +(* Format.force_newline (); + Format.print_break 0 3; +*) + Format.open_box 0; + Format.print_break new_tab 0; + Format.print_flush() + end + | AtNode(posname,(c1,c2)) -> + begin + Format.open_box 0; + Format.force_newline (); + Format.print_break (new_tab-10) 0; + Format.open_box 0; + Format.force_newline (); + Format.print_string (dummy^"AtNode: pos = "^posname^" conneciton = ("^c1^","^c2^")"); + Format.print_flush(); +(* Format.force_newline (); + Format.print_break 0 3; +*) + Format.open_box 0; + Format.print_break new_tab 0; + Format.print_flush() + end + | RNode(alpha_layer,bproof) -> + let alpha_string = stringlist_to_string alpha_layer in + begin + Format.open_box 0; + Format.force_newline (); + Format.print_break new_tab 0; + Format.print_break 0 0; + Format.force_newline (); + Format.print_flush(); + Format.open_box 0; + print_string (dummy^"RootNode: "^alpha_string); + Format.print_flush(); + Format.open_box 0; + Format.print_break 0 0; + Format.print_flush(); + pp_bproof_list [bproof] (new_tab-3) + end + | BNode(posname,(alph1,bproof1),(alph2,bproof2)) -> + let alpha_string1 = stringlist_to_string alph1 + and alpha_string2 = stringlist_to_string alph2 in + begin + Format.open_box 0; + Format.force_newline (); + Format.print_break new_tab 0; + Format.print_break 0 0; + Format.force_newline (); + Format.print_flush(); + Format.open_box 0; + print_string (dummy^"BetaNode: pos = "^posname^" layer1 = "^alpha_string1^" layer2 = "^alpha_string2); + Format.print_flush(); + Format.open_box 0; + Format.print_break 0 0; + Format.print_flush(); + pp_bproof_list [bproof1;bproof2] (new_tab-3) + end + in + let new_tab = tab+5 in + match tree_list with + [] -> Format.print_string "" + | first::rest -> + begin + pp_bproof first new_tab; + pp_bproof_list rest tab + end + + let rec print_pairlist pairlist = + match pairlist with + [] -> Format.print_string "" + | (a,b)::rest -> + begin + Format.print_break 1 1; + Format.print_string ("("^a^","^b^")"); + print_pairlist rest + end + + let print_beta_proof bproof = + begin + Format.open_box 0; + Format.force_newline (); + Format.force_newline (); + Format.print_break 3 0; + pp_bproof_list [bproof] 0; + Format.force_newline (); + Format.force_newline (); + Format.force_newline (); + Format.print_flush () + end + + let rec print_treelist treelist = + match treelist with + [] -> + print_endline "END"; + | f::r -> + begin + print_ftree f; + Format.open_box 0; + print_endline ""; + print_endline ""; + print_endline "NEXT TREE"; + print_endline ""; + print_endline ""; + print_treelist r; + Format.print_flush () + end + + let rec print_set_list set_list = + match set_list with + [] -> "" + | f::r -> + (f.aname)^" "^(print_set_list r) + + let print_set set = + let set_list = AtomSet.elements set in + if set_list = [] then "empty" + else + print_set_list set_list + + let print_string_set set = + let set_list = StringSet.elements set in + print_stringlist set_list + + let rec print_list_sets list_of_sets = + match list_of_sets with + [] -> Format.print_string "" + | (pos,fset)::r -> + begin + Format.print_string (pos^": "); (* first element = node which successors depend on *) + print_stringlist (StringSet.elements fset); + Format.force_newline (); + print_list_sets r + end + + let print_ordering list_of_sets = + begin + Format.open_box 0; + print_list_sets list_of_sets; + Format.print_flush () + end + + let rec print_triplelist triplelist = + match triplelist with + [] -> Format.print_string "" + | ((a,b),i)::rest -> + begin + Format.print_break 1 1; + Format.print_string ("(("^a^","^b^"),"^(string_of_int i)^")"); + print_triplelist rest + end + + let print_pos_n pos_n = + Format.print_int pos_n + + let print_formula_info ftree ordering pos_n = + begin + print_ftree ftree; + Format.open_box 0; + Format.force_newline (); + print_ordering ordering; + Format.force_newline (); + Format.force_newline (); + Format.print_string "number of positions: "; + print_pos_n pos_n; + Format.force_newline (); + print_endline ""; + print_endline ""; + Format.print_flush () + end + +(* print sequent proof tree *) + + let pp_rule (pos,r,formula,term) tab = + let rep = ruletable r in + if List.mem rep ["Alll";"Allr";"Exl";"Exr"] then + begin + Format.open_box 0; +(* Format.force_newline (); *) + Format.print_break tab 0; + Format.print_string (pos^": "^rep^" "); + Format.print_flush (); +(* Format.print_break tab 0; + Format.force_newline (); + Format.print_break tab 0; +*) + + Format.open_box 0; + print_term stdout formula; + Format.print_flush (); + Format.open_box 0; + Format.print_string " "; + Format.print_flush (); + Format.open_box 0; + print_term stdout term; + Format.force_newline (); + Format.force_newline (); + Format.print_flush () + end + else + begin + Format.open_box 0; + Format.print_break tab 0; + Format.print_string (pos^": "^rep^" "); + Format.print_flush (); + Format.open_box 0; +(* Format.print_break tab 0; *) + Format.force_newline (); +(* Format.print_break tab 0; *) + print_term stdout formula; + Format.force_newline () + end + + let last addr = + if addr = "" + then "" + else + String.make 1 (String.get addr (String.length addr-1)) + + let rest addr = + if addr = "" + then "" + else + String.sub addr 0 ((String.length addr) - 1) + + let rec get_r_chain addr = + if addr = "" then + 0 + else + let l = last addr in + if l = "l" then + 0 + else (* l = "r" *) + let rs = rest addr in + 1 + (get_r_chain rs) + + let rec tpp seqtree tab addr = + match seqtree with + | PEmpty -> raise jprover_bug + | PNodeAx(rule) -> + let (pos,r,p,pa) = rule in + begin + pp_rule (pos,r,p,pa) tab; +(* Format.force_newline (); *) +(* let mult = get_r_chain addr in *) +(* Format.print_break 100 (tab - (3 * mult)) *) + end + | PNodeA(rule,left) -> + let (pos,r,p,pa) = rule in + begin + pp_rule (pos,r,p,pa) tab; + tpp left tab addr + end + | PNodeB(rule,left,right) -> + let (pos,r,p,pa) = rule in + let newtab = tab + 3 in + begin + pp_rule (pos,r,p,pa) tab; +(* Format.force_newline (); *) +(* Format.print_break 100 newtab; *) + (tpp left newtab (addr^"l")); + (tpp right newtab (addr^"r")) + end + + let tt seqtree = + begin + Format.open_box 0; + tpp seqtree 0 ""; + Format.force_newline (); + Format.close_box (); + Format.print_newline () + end + +(************ END printing functions *********************************) + +(************ Beta proofs and redundancy deletion **********************) + + let rec remove_dups_connections connection_list = + match connection_list with + [] -> [] + | (c1,c2)::r -> + if (List.mem (c1,c2) r) or (List.mem (c2,c1) r) then + (* only one direction variant of a connection stays *) + remove_dups_connections r + else + (c1,c2)::(remove_dups_connections r) + + let rec remove_dups_list list = + match list with + [] -> [] + | f::r -> + if List.mem f r then + remove_dups_list r + else + f::(remove_dups_list r) + + let beta_pure alpha_layer connections beta_expansions = + let (l1,l2) = List.split connections in + let test_list = l1 @ l2 @ beta_expansions in + begin +(* Format.open_box 0; + print_endline ""; + print_stringlist alpha_layer; + Format.print_flush(); + Format.open_box 0; + print_endline ""; + print_stringlist test_list; + print_endline ""; + Format.print_flush(); +*) + not (List.exists (fun x -> (List.mem x test_list)) alpha_layer) + end + + let rec apply_bproof_purity bproof = + match bproof with + BEmpty -> + raise jprover_bug + | CNode((c1,c2)) -> + bproof,[(c1,c2)],[] + | AtNode(_,(c1,c2)) -> + bproof,[(c1,c2)],[] + | RNode(alpha_layer,subproof) -> + let (opt_subproof,min_connections,beta_expansions) = + apply_bproof_purity subproof in + (RNode(alpha_layer,opt_subproof),min_connections,beta_expansions) + | BNode(pos,(alph1,subp1),(alph2,subp2)) -> + let (opt_subp1,min_conn1,beta_exp1) = apply_bproof_purity subp1 in + if beta_pure alph1 min_conn1 beta_exp1 then + begin +(* print_endline ("Left layer of "^pos); *) + (opt_subp1,min_conn1,beta_exp1) + end + else + let (opt_subp2,min_conn2,beta_exp2) = apply_bproof_purity subp2 in + if beta_pure alph2 min_conn2 beta_exp2 then + begin +(* print_endline ("Right layer of "^pos); *) + (opt_subp2,min_conn2,beta_exp2) + end + else + let min_conn = remove_dups_connections (min_conn1 @ min_conn2) + and beta_exp = remove_dups_list ([pos] @ beta_exp1 @ beta_exp2) in + (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2)),min_conn,beta_exp) + + let bproof_purity bproof = + let (opt_bproof,min_connections,_) = apply_bproof_purity bproof in + opt_bproof,min_connections + +(*********** split permutation *****************) + + let rec apply_permutation bproof rep_name direction act_blayer = + match bproof with + BEmpty | RNode(_,_) -> + raise jprover_bug + | AtNode(cx,(c1,c2)) -> + bproof,act_blayer + | CNode((c1,c2)) -> + bproof,act_blayer + | BNode(pos,(alph1,subp1),(alph2,subp2)) -> + if rep_name = pos then + let (new_blayer,replace_branch) = + if direction = "left" then + (alph1,subp1) + else (* direciton = "right" *) + (alph2,subp2) + in + (match replace_branch with + CNode((c1,c2)) -> + (AtNode(c1,(c1,c2))),new_blayer (* perform atom expansion at c1 *) + | _ -> + replace_branch,new_blayer + ) + else + let pproof1,new_blayer1 = apply_permutation subp1 rep_name direction act_blayer in + let pproof2,new_blayer2 = apply_permutation subp2 rep_name direction new_blayer1 in + (BNode(pos,(alph1,pproof1),(alph2,pproof2))),new_blayer2 + + let split_permutation pname opt_bproof = + match opt_bproof with + RNode(alayer,BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) -> + if pos = pname then +(* if topmost beta expansion agrees with pname, then *) +(* only split the beta proof and give back the two subproofs *) + let (osubp1,min_con1) = bproof_purity opt_subp1 + and (osubp2,min_con2) = bproof_purity opt_subp2 in +(* there will be no purity reductions in the beta subproofs. We use this *) +(* predicate to collect the set of used leaf-connections in each subproof*) + ((RNode((alayer @ alph1),osubp1),min_con1), + (RNode((alayer @ alph2),osubp2),min_con2) + ) +(* we combine the branch after topmost beta expansion at pos into one root alpha layer *) +(* -- the beta expansion node pos will not be needed in this root layer *) + else + let perm_bproof1,balph1 = apply_permutation + (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) pname "left" [] + and perm_bproof2,balph2 = apply_permutation + (BNode(pos,(alph1,opt_subp1),(alph2,opt_subp2))) pname "right" [] in + + begin +(* print_endline " "; + print_beta_proof perm_bproof1; + print_endline" " ; + print_beta_proof perm_bproof2; + print_endline" "; +*) + let (osubp1,min_con1) = bproof_purity perm_bproof1 + and (osubp2,min_con2) = bproof_purity perm_bproof2 in + ((RNode((alayer @ balph1),osubp1),min_con1), + (RNode((alayer @ balph2),osubp2),min_con2) + ) + end +(* we combine the branch after the NEW topmost beta expansion at bpos *) +(* into one root alpha layer -- the beta expansion node bpos will not be *) +(* needed in this root layer *) + | _ -> + raise jprover_bug + +(*********** END split permutation *****************) + + let rec list_del list_el el_list = + match el_list with + [] -> + raise jprover_bug + | f::r -> + if list_el = f then + r + else + f::(list_del list_el r) + + let rec list_diff del_list check_list = + match del_list with + [] -> + [] + | f::r -> + if List.mem f check_list then + list_diff r check_list + else + f::(list_diff r check_list) + +(* let rec compute_alpha_layer ftree_list = + match ftree_list with + [] -> + [],[],[] + | f::r -> + (match f with + Empty -> + raise jprover_bug + | NodeAt(pos) -> + let pn = pos.name + and (rnode,ratom,borderings) = compute_alpha_layer r in + ((pn::rnode),(pn::ratom),borderings) + | NodeA(pos,suctrees) -> + let pn = pos.name in + if pos.pt = Beta then + let (rnode,ratom,borderings) = compute_alpha_layer r in + ((pn::rnode),(ratom),(f::borderings)) + else + let suclist = Array.to_list suctrees in + compute_alpha_layer (suclist @ r) + ) + + let rec compute_connection alpha_layer union_atoms connections = + match connections with + [] -> ("none","none") + | (c,d)::r -> + if (List.mem c union_atoms) & (List.mem d union_atoms) then + let (c1,c2) = + if List.mem c alpha_layer then + (c,d) + else + if List.mem d alpha_layer then + (d,c) (* then, d is supposed to occur in [alpha_layer] *) + else + raise (Invalid_argument "Jprover bug: connection match failure") + in + (c1,c2) + else + compute_connection alpha_layer union_atoms r + + let get_beta_suctrees btree = + match btree with + Empty | NodeAt(_) -> raise jprover_bug + | NodeA(pos,suctrees) -> + let b1tree = suctrees.(0) + and b2tree = suctrees.(1) in + (pos.name,b1tree,b2tree) + + let rec build_beta_proof alpha_layer union_atoms beta_orderings connections = + let (c1,c2) = compute_connection alpha_layer union_atoms connections in +(* [c1] is supposed to occur in the lowmost alpha layer of the branch, *) +(* i.e. [aplha_layer] *) + if (c1,c2) = ("none","none") then + (match beta_orderings with + [] -> raise jprover_bug + | btree::r -> + let (beta_pos,suctree1,suctree2) = get_beta_suctrees btree in + let (alpha_layer1, atoms1, bordering1) = compute_alpha_layer [suctree1] + and (alpha_layer2, atoms2, bordering2) = compute_alpha_layer [suctree2] in + let bproof1,beta1,closure1 = + build_beta_proof alpha_layer1 (atoms1 @ union_atoms) + (bordering1 @ r) connections + in + let bproof2,beta2,closure2 = + build_beta_proof alpha_layer2 (atoms2 @ union_atoms) + (bordering2 @ r) connections in + (BNode(beta_pos,(alpha_layer1,bproof1),(alpha_layer2,bproof2))),(1+beta1+beta2),(closure1+closure2) + ) + else + CNode((c1,c2)),0,1 + + let construct_beta_proof ftree connections = + let (root_node,root_atoms,beta_orderings) = compute_alpha_layer [ftree] + in + let beta_proof,beta_exp,closures = + build_beta_proof root_node root_atoms beta_orderings connections in + (RNode(root_node,beta_proof)),beta_exp,closures +*) + + +(* *********** New Version with direct computation from extension proof **** *) +(* follows a DIRECT step from proof histories via pr-connection orderings to opt. beta-proofs *) + + let rec compute_alpha_layer ftree_list = + match ftree_list with + [] -> + [] + | f::r -> + (match f with + Empty -> + raise jprover_bug + | NodeAt(pos) -> + let rnode = compute_alpha_layer r in + (pos.name::rnode) + | NodeA(pos,suctrees) -> + if pos.pt = Beta then + let rnode = compute_alpha_layer r in + (pos.name::rnode) + else + let suclist = Array.to_list suctrees in + compute_alpha_layer (suclist @ r) + ) + + let rec compute_beta_difference c1_context c2_context act_context = + match c1_context,c2_context with + ([],c2_context) -> + (list_diff c2_context act_context) +(* both connection partners in the same submatrix; [c1] already isolated *) + | ((fc1::rc1),[]) -> + [] (* [c2] is a reduction step, i.e. isolated before [c1] *) + | ((fc1::rc1),(fc2::rc2)) -> + if fc1 = fc2 then (* common initial beta-expansions *) + compute_beta_difference rc1 rc2 act_context + else + (list_diff c2_context act_context) + + let rec non_closed beta_proof_list = + match beta_proof_list with + [] -> + false + | bpf::rbpf -> + (match bpf with + RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") + | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") + | BEmpty -> true + | CNode(_) -> non_closed rbpf + | BNode(pos,(_,bp1),(_,bp2)) -> non_closed ([bp1;bp2] @ rbpf) + ) + + let rec cut_context pos context = + match context with + [] -> + raise (Invalid_argument "Jprover bug: invalid context element") + | (f,num)::r -> + if pos = f then + context + else + cut_context pos r + + let compute_tree_difference beta_proof c1_context = + match beta_proof with + RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") + | CNode(_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") + | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") + | BEmpty -> c1_context + | BNode(pos,_,_) -> +(* print_endline ("actual root: "^pos); *) + cut_context pos c1_context + + let print_context conn bcontext = + begin + Format.open_box 0; + Format.print_string conn; + Format.print_string ": "; + List.iter (fun x -> let (pos,num) = x in Format.print_string (pos^" "^(string_of_int num)^"")) bcontext; + print_endline " "; + Format.print_flush () + end + + let rec build_opt_beta_proof beta_proof ext_proof beta_atoms beta_layer_list act_context = + let rec add_c2_tree (c1,c2) c2_diff_context = + match c2_diff_context with + [] -> + (CNode(c1,c2),0) + | (f,num)::c2_diff_r -> + let next_beta_proof,next_exp = + add_c2_tree (c1,c2) c2_diff_r in + let (layer1,layer2) = List.assoc f beta_layer_list in + let new_bproof = + if num = 1 then + BNode(f,(layer1,next_beta_proof),(layer2,BEmpty)) + else (* num = 2*) + BNode(f,(layer1,BEmpty),(layer2,next_beta_proof)) + in + (new_bproof,(next_exp+1)) + in + let rec add_beta_expansions (c1,c2) rest_ext_proof c1_diff_context c2_diff_context new_act_context = + match c1_diff_context with + [] -> + let (n_c1,n_c2) = + if c2_diff_context = [] then (* make sure that leaf-connection is first element *) + (c1,c2) + else + (c2,c1) + in + let c2_bproof,c2_exp = add_c2_tree (n_c1,n_c2) c2_diff_context in + if c2_exp <> 0 then (* at least one open branch was generated to isloate [c2] *) + begin +(* print_endline "start with new beta-proof"; *) + let new_bproof,new_exp,new_closures,new_rest_proof = + build_opt_beta_proof c2_bproof rest_ext_proof beta_atoms beta_layer_list (act_context @ new_act_context) in + (new_bproof,(new_exp+c2_exp),(new_closures+1),new_rest_proof) + end + else + begin +(* print_endline "proceed with old beta-proof"; *) + (c2_bproof,c2_exp,1,rest_ext_proof) + end + | (f,num)::c1_diff_r -> + let (layer1,layer2) = List.assoc f beta_layer_list in + let next_beta_proof,next_exp,next_closures,next_ext_proof = + add_beta_expansions (c1,c2) rest_ext_proof c1_diff_r c2_diff_context new_act_context in + let new_bproof = + if num = 1 then + BNode(f,(layer1,next_beta_proof),(layer2,BEmpty)) + else (* num = 2*) + BNode(f,(layer1,BEmpty),(layer2,next_beta_proof)) + in + (new_bproof,(next_exp+1),next_closures,next_ext_proof) + + in + let rec insert_connection beta_proof (c1,c2) rest_ext_proof c1_diff_context c2_diff_context act_context = + begin +(* print_context c1 c1_diff_context; + print_endline ""; + print_context c2 c2_diff_context; + print_endline ""; +*) + match beta_proof with + RNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") + | CNode(_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") + | AtNode(_,_) -> raise (Invalid_argument "Jprover bug: invalid beta-proof") + | BEmpty -> + add_beta_expansions (c1,c2) rest_ext_proof c1_diff_context c2_diff_context act_context + | BNode(pos,(layer1,sproof1),(layer2,sproof2)) -> +(* print_endline (c1^" "^c2^" "^pos); *) + (match c1_diff_context with + [] -> + raise (Invalid_argument "Jprover bug: invalid beta-proof") + | (f,num)::rest_context -> (* f = pos must hold!! *) + if num = 1 then + let (next_bproof,next_exp,next_closure,next_ext_proof) = + insert_connection sproof1 (c1,c2) rest_ext_proof rest_context c2_diff_context act_context in + (BNode(pos,(layer1,next_bproof),(layer2,sproof2)),next_exp,next_closure,next_ext_proof) + else (* num = 2 *) + let (next_bproof,next_exp,next_closure,next_ext_proof) = + insert_connection sproof2 (c1,c2) rest_ext_proof rest_context c2_diff_context act_context in + (BNode(pos,(layer1,sproof1),(layer2,next_bproof)),next_exp,next_closure,next_ext_proof) + ) + end + + in + match ext_proof with + [] -> + beta_proof,0,0,[] + | (c1,c2)::rproof -> +(* print_endline ("actual connection: "^c1^" "^c2); *) + let c1_context = List.assoc c1 beta_atoms + and c2_context = List.assoc c2 beta_atoms in + let c2_diff_context = compute_beta_difference c1_context c2_context act_context + and c1_diff_context = compute_tree_difference beta_proof c1_context in (* wrt. actual beta-proof *) + let (next_beta_proof,next_exp,next_closures,next_ext_proof) = + insert_connection beta_proof (c1,c2) rproof c1_diff_context c2_diff_context c1_diff_context in + if non_closed [next_beta_proof] then (* at least one branch was generated to isolate [c1] *) + let rest_beta_proof,rest_exp,rest_closures,rest_ext_proof = + build_opt_beta_proof next_beta_proof next_ext_proof beta_atoms beta_layer_list act_context in + rest_beta_proof,(next_exp+rest_exp),(next_closures+rest_closures),rest_ext_proof + else + next_beta_proof,next_exp,next_closures,next_ext_proof + + let rec annotate_atoms beta_context atlist treelist = + let rec annotate_tree beta_context tree atlist = + match tree with + Empty -> + (atlist,[],[]) + | NodeAt(pos) -> + if List.mem pos.name atlist then + let new_atlist = list_del pos.name atlist in + (new_atlist,[(pos.name,beta_context)],[]) + else + (atlist,[],[]) + | NodeA(pos,suctrees) -> + if pos.pt = Beta then + let s1,s2 = suctrees.(0),suctrees.(1) in + let alayer1 = compute_alpha_layer [s1] + and alayer2 = compute_alpha_layer [s2] + and new_beta_context1 = beta_context @ [(pos.name,1)] + and new_beta_context2 = beta_context @ [(pos.name,2)] in + let atlist1,annotates1,blayer_list1 = + annotate_atoms new_beta_context1 atlist [s1] in + let atlist2,annotates2,blayer_list2 = + annotate_atoms new_beta_context2 atlist1 [s2] + in + (atlist2,(annotates1 @ annotates2),((pos.name,(alayer1,alayer2))::(blayer_list1 @ blayer_list2))) + else + annotate_atoms beta_context atlist (Array.to_list suctrees) + in + match treelist with + [] -> (atlist,[],[]) + | f::r -> + let (next_atlist,f_annotates,f_beta_layers) = annotate_tree beta_context f atlist in + let (rest_atlist,rest_annotates,rest_beta_layers) = (annotate_atoms beta_context next_atlist r) + in + (rest_atlist, (f_annotates @ rest_annotates),(f_beta_layers @ rest_beta_layers)) + + let construct_opt_beta_proof ftree ext_proof = + let con1,con2 = List.split ext_proof in + let con_atoms = remove_dups_list (con1 @ con2) in + let (empty_atoms,beta_atoms,beta_layer_list) = annotate_atoms [] con_atoms [ftree] in + let root_node = compute_alpha_layer [ftree] in + let (beta_proof,beta_exp,closures,_) = + build_opt_beta_proof BEmpty ext_proof beta_atoms beta_layer_list [] in + (RNode(root_node,beta_proof)),beta_exp,closures + +(************* permutation ljmc -> lj *********************************) + +(* REAL PERMUTATION STAFF *) + + let subf1 n m subrel = List.mem ((n,m),1) subrel + let subf2 n m subrel = List.mem ((n,m),2) subrel + let tsubf n m tsubrel = List.mem (n,m) tsubrel + +(* Transforms all normal form layers in an LJ proof *) + + let rec modify prooftree (subrel,tsubrel) = + match prooftree with + PEmpty -> + raise jprover_bug + | PNodeAx((pos,inf,form,term)) -> + prooftree,pos + | PNodeA((pos,inf,form,term),left) -> + let t,qpos = modify left (subrel,tsubrel) in + if List.mem inf [Impr;Negr;Allr] then + PNodeA((pos,inf,form,term),t),pos (* layer bound *) + else if qpos = "Orl-True" then + PNodeA((pos,inf,form,term),t),qpos + else if List.mem inf [Andl;Alll;Exl] then + PNodeA((pos,inf,form,term),t),qpos (* simply propagation *) + else if inf = Exr then + if (subf1 pos qpos subrel) then + PNodeA((pos,inf,form,term),t),pos + else t,qpos + else if inf = Negl then + if (subf1 pos qpos subrel) then + PNodeA((pos,inf,form,term),t),"" (* empty string *) + else t,qpos + else (* x = Orr *) + if (subf1 pos qpos subrel) then + PNodeA((pos,Orr1,form,term),t),pos (* make Orr for LJ *) + else if (subf2 pos qpos subrel) then + PNodeA((pos,Orr2,form,term),t),pos (* make Orr for LJ *) + else t,qpos + | PNodeB((pos,inf,form,term),left,right) -> + let t,qpos = modify left (subrel,tsubrel) in + if inf = Andr then + if (or) (qpos = "Orl-True") (subf1 pos qpos subrel) then + let s,rpos = modify right (subrel,tsubrel) in (* Orl-True -> subf *) + if (or) (rpos = "Orl-True") (subf2 pos rpos subrel) then + PNodeB((pos,inf,form,term),t,s),pos + else s,rpos + else t,qpos (* not subf -> not Orl-True *) + else if inf = Impl then + if (subf1 pos qpos subrel) then + let s,rpos = modify right (subrel,tsubrel) in + PNodeB((pos,inf,form,term),t,s),"" (* empty string *) + else t,qpos + else (* x = Orl *) + let s,rpos = modify right (subrel,tsubrel) in + PNodeB((pos,inf,form,term),t,s),"Orl-True" + +(* transforms the subproof into an LJ proof between + the beta-inference rule (excluded) and + layer boundary in the branch ptree *) + + let rec rec_modify ptree (subrel,tsubrel) = + match ptree with + PEmpty -> + raise jprover_bug + | PNodeAx((pos,inf,form,term)) -> + ptree,pos + | PNodeA((pos,inf,form,term),left) -> + if List.mem inf [Impr;Negr;Allr] then + ptree,pos (* layer bound, stop transforming! *) + else + let t,qpos = rec_modify left (subrel,tsubrel) in + if List.mem inf [Andl;Alll;Exl] then + PNodeA((pos,inf,form,term),t),qpos (* simply propagation*) + else if inf = Exr then + if (subf1 pos qpos subrel) then + PNodeA((pos,inf,form,term),t),pos + else t,qpos + else if inf = Negl then + if (subf1 pos qpos subrel) then + PNodeA((pos,inf,form,term),t),"" (* empty string *) + else t,qpos + else (* x = Orr *) + if (subf1 pos qpos subrel) then + PNodeA((pos,Orr1,form,term),t),pos (* make Orr for LJ *) + else if (subf2 pos qpos subrel) then + PNodeA((pos,Orr2,form,term),t),pos (* make Orr for LJ *) + else t,qpos + | PNodeB((pos,inf,form,term),left,right) -> + let t,qpos = rec_modify left (subrel,tsubrel) in + if inf = Andr then + if (subf1 pos qpos subrel) then + let s,rpos = rec_modify right (subrel,tsubrel) in + if (subf2 pos rpos subrel) then + PNodeB((pos,inf,form,term),t,s),pos + else s,rpos + else t,qpos + else (* x = Impl since x= Orl cannot occur in the partial layer ptree *) + + if (subf1 pos qpos subrel) then + let s,rpos = rec_modify right (subrel,tsubrel) in + PNodeB((pos,inf,form,term),t,s),"" (* empty string *) + else t,qpos + + let weak_modify rule ptree (subrel,tsubrel) = (* recall rule = or_l *) + let (pos,inf,formlua,term) = rule in + if inf = Orl then + ptree,true + else + let ptreem,qpos = rec_modify ptree (subrel,tsubrel) in + if (subf1 pos qpos subrel) then (* weak_modify will always be applied on left branches *) + ptreem,true + else + ptreem,false + +(* Now, the permutation stuff .... *) + +(* Permutation schemes *) + +(* corresponds to local permutation lemma -- Lemma 3 in the paper -- *) +(* with eigenvariablen renaming and branch modification *) + +(* eigenvariablen renaming and branch modification over *) +(* the whole proofs, i.e. over layer boundaries, too *) + + +(* global variable vor eigenvariable renaming during permutations *) + + let eigen_counter = ref 1 + +(* append renamed paramater "r" to non-quantifier subformulae + of renamed quantifier formulae *) + +(*: BUG :*) +(*: + let make_new_eigenvariable term = + let op = (dest_term term).term_op in + let opn = (dest_op op).op_name in + let opnam = dest_opname opn in + match opnam with + [] -> + raise jprover_bug + | ofirst::orest -> + let ofname = List.hd orest in + let new_eigen_var = (ofname^"_r"^(string_of_int (!eigen_counter))) in + eigen_counter := !eigen_counter + 1; +(* print_endline ("New Counter :"^(string_of_int (!eigen_counter))); *) + mk_string_term jprover_op new_eigen_var +:*) + + let make_new_eigenvariable term = + let op = (dest_term term).term_op in + let opa = (dest_op op).op_params in + let oppar = dest_param opa in + match oppar with + | String ofname::_ -> + let new_eigen_var = (ofname^"_r"^(string_of_int (!eigen_counter))) in + eigen_counter := !eigen_counter + 1; + mk_string_term jprover_op new_eigen_var + | _ -> raise jprover_bug + + + let replace_subterm term oldt rept = + let v_term = var_subst term oldt "dummy_var" in + subst1 v_term "dummy_var" rept + + let rec eigen_rename old_parameter new_parameter ptree = + match ptree with + PEmpty -> + raise jprover_bug + | PNodeAx((pos,inf,form,term)) -> + let new_form = replace_subterm form old_parameter new_parameter in + PNodeAx((pos,inf,new_form,term)) + | PNodeA((pos,inf,form,term), left) -> + let new_form = replace_subterm form old_parameter new_parameter + and new_term = replace_subterm term old_parameter new_parameter in + let ren_left = eigen_rename old_parameter new_parameter left in + PNodeA((pos,inf,new_form,new_term), ren_left) + | PNodeB((pos,inf,form,term),left, right) -> + let new_form = replace_subterm form old_parameter new_parameter in + let ren_left = eigen_rename old_parameter new_parameter left in + let ren_right = eigen_rename old_parameter new_parameter right in + PNodeB((pos,inf,new_form,term), ren_left, ren_right) + + let rec update_ptree rule subtree direction tsubrel = + match subtree with + PEmpty -> + raise jprover_bug + | PNodeAx(r) -> + subtree + | PNodeA((pos,inf,formula,term), left) -> + if (pos,inf,formula,term) = rule then + left + (* don't delete rule if subformula belongs to renamed instance of quantifiers; *) + (* but this can never occur now since (renamed) formula is part of rule *) + else + let (posn,infn,formn,termn) = rule in + if (&) (List.mem infn [Exl;Allr] ) (term = termn) then + (* this can only occur if eigenvariable rule with same term as termn has been permuted; *) + (* the application of the same eigenvariable introduction on the same subformula with *) + (* different instantiated variables might occur! *) + (* termn cannot occur in terms of permuted quantifier rules due to substitution split *) + (* during reconstruciton of the ljmc proof *) + let new_term = make_new_eigenvariable term in +(* print_endline "Eigenvariable renaming!!!"; *) + eigen_rename termn new_term subtree + else + let left_del = + update_ptree rule left direction tsubrel + in + PNodeA((pos,inf,formula,term), left_del) + | PNodeB((pos,inf,formula,term), left, right) -> + if (pos,inf,formula,term) = rule then + if direction = "l" then + left + else + right (* direction = "r" *) + else + let left_del = update_ptree rule left direction tsubrel in + let right_del = update_ptree rule right direction tsubrel in + PNodeB((pos,inf,formula,term),left_del,right_del) + + let permute r1 r2 ptree la tsubrel = +(* print_endline "permute in"; *) + match ptree,la with + PNodeA(r1, PNodeA(r2,left)),la -> +(* print_endline "1-o-1"; *) + PNodeA(r2, PNodeA(r1,left)) + (* one-over-one *) + | PNodeA(r1, PNodeB(r2,left,right)),la -> +(* print_endline "1-o-2"; *) + PNodeB(r2, PNodeA(r1,left), PNodeA(r1,right)) + (* one-over-two *) + | PNodeB(r1, PNodeA(r2,left), right),"l" -> +(* print_endline "2-o-1 left"; *) + let right_u = update_ptree r2 right "l" tsubrel in + PNodeA(r2, PNodeB(r1, left, right_u)) + (* two-over-one left *) + | PNodeB(r1, left, PNodeA(r2,right)),"r" -> +(* print_endline "2-o-1 right"; *) + let left_u = update_ptree r2 left "l" tsubrel in + PNodeA(r2, PNodeB(r1, left_u, right)) + (* two-over-one right *) + | PNodeB(r1, PNodeB(r2,left2,right2), right),"l" -> +(* print_endline "2-o-2 left"; *) + let right_ul = update_ptree r2 right "l" tsubrel in + let right_ur = update_ptree r2 right "r" tsubrel in + PNodeB(r2,PNodeB(r1,left2,right_ul),PNodeB(r1,right2,right_ur)) + (* two-over-two left *) + | PNodeB(r1, left, PNodeB(r2,left2,right2)),"r" -> +(* print_endline "2-o-2 right"; *) + let left_ul = update_ptree r2 left "l" tsubrel in + let left_ur = update_ptree r2 left "r" tsubrel in + PNodeB(r2,PNodeB(r1,left_ul,left2),PNodeB(r1,left_ur, right2)) + (* two-over-two right *) + | _ -> raise jprover_bug + +(* permute layers, isolate addmissible branches *) + +(* computes if an Andr is d-generatives *) + + let layer_bound rule = + let (pos,inf,formula,term) = rule in + if List.mem inf [Impr;Negr;Allr] then + true + else + false + + let rec orl_free ptree = + match ptree with + PEmpty -> + raise jprover_bug + | PNodeAx(rule) -> + true + | PNodeA(rule,left) -> + if layer_bound rule then + true + else + orl_free left + | PNodeB(rule,left,right) -> + let (pos,inf,formula,term) = rule in + if inf = Orl then + false + else + (&) (orl_free left) (orl_free right) + + let rec dgenerative rule dglist ptree tsubrel = + let (pos,inf,formula,term) = rule in + if List.mem inf [Exr;Orr;Negl] then + true + else if inf = Andr then + if dglist = [] then + false + else + let first,rest = (List.hd dglist),(List.tl dglist) in + let (pos1,inf1,formula1,term1) = first in + if tsubf pos1 pos tsubrel then + true + else + dgenerative rule rest ptree tsubrel + else if inf = Impl then + not (orl_free ptree) + else + false + + +(* to compute a topmost addmissible pair r,o with + the address addr of r in the proof tree +*) + + let rec top_addmissible_pair ptree dglist act_r act_o act_addr tsubrel dummyt = + let rec search_pair ptree dglist act_r act_o act_addr tsubrel = + match ptree with + PEmpty -> raise jprover_bug + | PNodeAx(_) -> raise jprover_bug + | PNodeA(rule, left) -> +(* print_endline "alpha"; *) + if (dgenerative rule dglist left tsubrel) then (* r = Exr,Orr,Negl *) + let newdg = (@) [rule] dglist in + search_pair left newdg act_r rule act_addr tsubrel + else (* Impr, Allr, Notr only for test *) + search_pair left dglist act_r act_o act_addr tsubrel + | PNodeB(rule,left,right) -> +(* print_endline "beta"; *) + let (pos,inf,formula,term) = rule in + if List.mem inf [Andr;Impl] then + let bool = dgenerative rule dglist left tsubrel in + let newdg,newrule = + if bool then + ((@) [rule] dglist),rule + else + dglist,act_o + in + if orl_free left then + search_pair right newdg act_r newrule (act_addr^"r") tsubrel + else (* not orl_free *) + let left_r,left_o,left_addr = + search_pair left newdg act_r newrule (act_addr^"l") tsubrel in + if left_o = ("",Orr,dummyt,dummyt) then + top_addmissible_pair right dglist act_r act_o (act_addr^"r") tsubrel dummyt + else left_r,left_o,left_addr + else (* r = Orl *) + if orl_free left then + top_addmissible_pair right dglist rule act_o (act_addr^"r") tsubrel dummyt + else + let left_r,left_o,left_addr + = search_pair left dglist rule act_o (act_addr^"l") tsubrel in + if left_o = ("",Orr,dummyt,dummyt) then + top_addmissible_pair right dglist rule act_o (act_addr^"r") tsubrel dummyt + else + left_r,left_o,left_addr + in +(* print_endline "top_addmissible_pair in"; *) + if orl_free ptree then (* there must be a orl BELOW an layer bound *) + begin +(* print_endline "orl_free"; *) + act_r,act_o,act_addr + end + else + begin +(* print_endline "orl_full"; *) + search_pair ptree dglist act_r act_o act_addr tsubrel + end + + let next_direction addr act_addr = + String.make 1 (String.get addr (String.length act_addr)) + (* get starts with count 0*) + + let change_last addr d = + let split = (String.length addr) - 1 in + let prec,last = + (String.sub addr 0 split),(String.sub addr split 1) in + prec^d^last + + let last addr = + if addr = "" + then "" + else + String.make 1 (String.get addr (String.length addr-1)) + + let rest addr = + if addr = "" + then "" + else + String.sub addr 0 ((String.length addr) - 1) + + let rec permute_layer ptree dglist (subrel,tsubrel) = + let rec permute_branch r addr act_addr ptree dglist (subrel,tsubrel) = +(* print_endline "pbranch in"; *) + let la = last act_addr in (* no ensure uniqueness at 2-over-x *) + match ptree,la with + PNodeA(o,PNodeA(rule,left)),la -> (* one-over-one *) +(* print_endline " one-over-one "; *) + let permute_result = permute o rule ptree la tsubrel in + begin match permute_result with + PNodeA(r2,left2) -> + let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in + PNodeA(r2,pbleft) + | _ -> raise jprover_bug + end + | PNodeA(o,PNodeB(rule,left,right)),la -> (* one-over-two *) +(* print_endline " one-over-two "; *) + if rule = r then (* left,right are or_l free *) + permute o rule ptree la tsubrel (* first termination case *) + else + let d = next_direction addr act_addr in + if d = "l" then + let permute_result = permute o rule ptree la tsubrel in + (match permute_result with + PNodeB(r2,left2,right2) -> + let pbleft = permute_branch r addr (act_addr^d) left2 dglist (subrel,tsubrel) in + let plright = permute_layer right2 dglist (subrel,tsubrel) in + PNodeB(r2,pbleft,plright) + | _ -> raise jprover_bug + ) + else (* d = "r", that is left of rule is or_l free *) + let left1,bool = weak_modify rule left (subrel,tsubrel) in + if bool then (* rule is relevant *) + let permute_result = permute o rule (PNodeA(o,PNodeB(rule,left1,right))) la tsubrel in + (match permute_result with + PNodeB(r2,left2,right2) -> + let pbright = permute_branch r addr (act_addr^d) right2 dglist (subrel,tsubrel) in + PNodeB(r2,left2,pbright) + | _ -> raise jprover_bug + ) + else (* rule is not relevant *) + PNodeA(o,left1) (* optimized termination case (1) *) + | PNodeB(o,PNodeA(rule,left),right1),"l" -> (* two-over-one, left *) +(* print_endline " two-over-one, left "; *) + let permute_result = permute o rule ptree la tsubrel in + (match permute_result with + PNodeA(r2,left2) -> + let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in + PNodeA(r2,pbleft) + | _ -> raise jprover_bug + ) + | PNodeB(o,left1,PNodeA(rule,left)),"r" -> (* two-over-one, right *) + (* left of o is or_l free *) +(* print_endline " two-over-one, right"; *) + let leftm,bool = weak_modify o left1 (subrel,tsubrel) in + if bool then (* rule is relevant *) + let permute_result = permute o rule (PNodeB(o,leftm,PNodeA(rule,left))) la tsubrel in + (match permute_result with + PNodeA(r2,left2) -> + let pbleft = permute_branch r addr act_addr left2 dglist (subrel,tsubrel) in + PNodeA(r2,pbleft) + | _ -> raise jprover_bug + ) + else (* rule is not relevant *) + leftm (* optimized termination case (2) *) + | PNodeB(o,PNodeB(rule,left,right),right1),"l" -> (* two-over-two, left *) +(* print_endline " two-over-two, left"; *) + if rule = r then (* left,right are or_l free *) + let permute_result = permute o rule ptree la tsubrel in + (match permute_result with + PNodeB(r2,PNodeB(r3,left3,right3),PNodeB(r4,left4,right4)) -> +(* print_endline "permute 2-o-2, left ok"; *) + let leftm3,bool3 = weak_modify r3 left3 (subrel,tsubrel) in + let leftm4,bool4 = weak_modify r4 left4 (subrel,tsubrel) in + let plleft,plright = + if (&) bool3 bool4 then (* r3 and r4 are relevant *) + (permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel)), + (permute_layer (PNodeB(r4,leftm4,right4)) dglist (subrel,tsubrel)) + else if (&) bool3 (not bool4) then (* only r3 is relevant *) + begin +(* print_endline "two-over-two left: bool3 and not bool4"; *) + (permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel)), + leftm4 + end + else if (&) (not bool3) bool4 then (* only r4 is relevant *) + leftm3, + (permute_layer (PNodeB(r4,leftm4,right4)) dglist (subrel,tsubrel)) + else (* neither r3 nor r4 are relevant *) + leftm3,leftm4 + in + PNodeB(r2,plleft,plright) + | _ -> raise jprover_bug + ) + else + let d = next_direction addr act_addr in + let newadd = change_last act_addr d in + if d = "l" then + let permute_result = permute o rule ptree la tsubrel in + (match permute_result with + PNodeB(r2,left2,right2) -> + let pbleft = permute_branch r addr newadd left2 dglist (subrel,tsubrel) in + let plright = permute_layer right2 dglist (subrel,tsubrel) in + PNodeB(r2,pbleft,plright) + | _ -> raise jprover_bug + ) + else (* d = "r", that is left is or_l free *) + let left1,bool = weak_modify rule left (subrel,tsubrel) in + if bool then (* rule is relevant *) + let permute_result = + permute o rule (PNodeB(o,PNodeB(rule,left1,right),right1)) la tsubrel in + (match permute_result with + PNodeB(r2,PNodeB(r3,left3,right3),right2) -> + let pbright = permute_branch r addr newadd right2 dglist (subrel,tsubrel) in + let leftm3,bool3 = weak_modify r3 left3 (subrel,tsubrel) in + let plleft = + if bool3 (* r3 relevant *) then + permute_layer (PNodeB(r3,leftm3,right3)) dglist (subrel,tsubrel) + else (* r3 redundant *) + leftm3 + in + PNodeB(r2,plleft,pbright) (* further opt. NOT possible *) + | _ -> raise jprover_bug + ) + else (* rule is not relevant *) + permute_layer (PNodeB(o,left1,right1)) dglist (subrel,tsubrel) (* further opt. possible *) + (* combine with orl_free *) + | PNodeB(o,left1,PNodeB(rule,left,right)),"r" -> (* two-over-two, right *) +(* print_endline " two-over-two, right"; *) + let leftm1,bool = weak_modify o left1 (subrel,tsubrel) in (* left1 is or_l free *) + if bool then (* o is relevant, even after permutations *) + if rule = r then (* left, right or_l free *) + permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel + else + let d = next_direction addr act_addr in + let newadd = change_last act_addr d in + if d = "l" then + let permute_result = + permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel in + (match permute_result with + PNodeB(r2,left2,right2) -> + let pbleft = permute_branch r addr newadd left2 dglist (subrel,tsubrel) in + let plright = permute_layer right2 dglist (subrel,tsubrel) in + PNodeB(r2,pbleft,plright) + | _ -> raise jprover_bug + ) + else (* d = "r", that is left is or_l free *) + let leftm,bool = weak_modify rule left (subrel,tsubrel) in + if bool then (* rule is relevant *) + let permute_result = + permute o rule (PNodeB(o,leftm1,PNodeB(rule,left,right))) la tsubrel in + (match permute_result with + PNodeB(r2,left2,right2) -> + let pbright = permute_branch r addr newadd right2 dglist (subrel,tsubrel) in + PNodeB(r2,left2,pbright) (* left2 or_l free *) + | _ -> raise jprover_bug + ) + else (* rule is not relevant *) + PNodeB(o,leftm1,leftm) + + else + leftm1 + | _ -> raise jprover_bug + in + let rec trans_add_branch r o addr act_addr ptree dglist (subrel,tsubrel) = + match ptree with + (PEmpty| PNodeAx(_)) -> raise jprover_bug + | PNodeA(rule,left) -> + if (dgenerative rule dglist left tsubrel) then + let newdg = (@) [rule] dglist in + if rule = o then + begin +(* print_endline "one-rule is o"; *) + permute_branch r addr act_addr ptree dglist (subrel,tsubrel) + end + else + begin +(* print_endline "alpha - but not o"; *) + let tptree = trans_add_branch r o addr act_addr left newdg (subrel,tsubrel) in + permute_layer (PNodeA(rule,tptree)) dglist (subrel,tsubrel) + (* r may not longer be valid for rule *) + end + else + let tptree = trans_add_branch r o addr act_addr left dglist (subrel,tsubrel) in + PNodeA(rule,tptree) + | PNodeB(rule,left,right) -> + let d = next_direction addr act_addr in + let bool = (dgenerative rule dglist left tsubrel) in + if rule = o then + begin +(* print_endline "two-rule is o"; *) + permute_branch r addr (act_addr^d) ptree dglist (subrel,tsubrel) + end + else + begin +(* print_endline ("beta - but not o: address "^d); *) + let dbranch = + if d = "l" then + left + else (* d = "r" *) + right + in + let tptree = + if bool then + let newdg = (@) [rule] dglist in + (trans_add_branch r o addr (act_addr^d) dbranch newdg (subrel,tsubrel)) + else + (trans_add_branch r o addr (act_addr^d) dbranch dglist (subrel,tsubrel)) + in + if d = "l" then + permute_layer (PNodeB(rule,tptree,right)) dglist (subrel,tsubrel) + else (* d = "r" *) + begin +(* print_endline "prob. a redundant call"; *) + let back = permute_layer (PNodeB(rule,left,tptree)) dglist (subrel,tsubrel) in +(* print_endline "SURELY a redundant call"; *) + back + end + end + in +(* print_endline "permute_layer in"; *) + let dummyt = mk_var_term "dummy" in + let r,o,addr = + top_addmissible_pair ptree dglist ("",Orl,dummyt,dummyt) ("",Orr,dummyt,dummyt) "" tsubrel dummyt in + if r = ("",Orl,dummyt,dummyt) then + ptree + 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 ("or_l address: "^addr); + print_endline ("top dgen-rule: "^y1); *) + trans_add_branch r o addr "" ptree dglist (subrel,tsubrel) + +(* Isolate layer and outer recursion structure *) +(* uses weaker layer boundaries: ONLY critical inferences *) + + let rec trans_layer ptree (subrel,tsubrel) = + let rec isol_layer ptree (subrel,tsubrel) = + match ptree with + PEmpty -> raise jprover_bug + | PNodeAx(inf) -> + ptree + | PNodeA((pos,rule,formula,term),left) -> + if List.mem rule [Allr;Impr;Negr] then + let tptree = trans_layer left (subrel,tsubrel) in + PNodeA((pos,rule,formula,term),tptree) + else + let tptree = isol_layer left (subrel,tsubrel) in + PNodeA((pos,rule,formula,term),tptree) + | PNodeB(rule,left,right) -> + let tptree_l = isol_layer left (subrel,tsubrel) + and tptree_r = isol_layer right (subrel,tsubrel) in + PNodeB(rule,tptree_l,tptree_r) + in + begin +(* print_endline "trans_layer in"; *) + let top_tree = isol_layer ptree (subrel,tsubrel) in + let back = permute_layer top_tree [] (subrel,tsubrel) in +(* print_endline "translauer out"; *) + back + end + +(* REAL PERMUTATION STAFF --- End *) + +(* build the proof tree from a list of inference rules *) + + let rec unclosed subtree = + match subtree with + PEmpty -> true + | PNodeAx(y) -> false + | PNodeA(y,left) -> (unclosed left) + | PNodeB(y,left,right) -> (or) (unclosed left) (unclosed right) + + let rec extend prooftree element = + match prooftree with + PEmpty -> + let (pos,rule,formula,term) = element in + if rule = Ax then + PNodeAx(element) + else + if List.mem rule [Andr; Orl; Impl] then + PNodeB(element,PEmpty,PEmpty) + else + PNodeA(element,PEmpty) + | PNodeAx(y) -> + PEmpty (* that's only for exhaustive pattern matching *) + | PNodeA(y, left) -> + PNodeA(y, (extend left element)) + | PNodeB(y, left, right) -> + if (unclosed left) then + PNodeB(y, (extend left element), right) + else + PNodeB(y, left, (extend right element)) + + let rec bptree prooftree nodelist nax= + match nodelist with + [] -> prooftree,nax + | ((_,pos),(rule,formula,term))::rest -> (* kick away the first argument *) + let newax = + if rule = Ax then + 1 + else + 0 + in + bptree (extend prooftree (pos,rule,formula,term)) rest (nax+newax) + + + let bproof nodelist = + bptree PEmpty nodelist 0 + + let rec get_successor_pos treelist = + match treelist with + [] -> [] + | f::r -> + ( + match f with + Empty -> get_successor_pos r + | NodeAt(_) -> raise jprover_bug + | NodeA(pos,_) -> + pos::(get_successor_pos r) + ) + + let rec get_formula_tree ftreelist f predflag = + match ftreelist with + [] -> raise jprover_bug + | ftree::rest_trees -> + (match ftree with + Empty -> get_formula_tree rest_trees f predflag + | NodeAt(_) -> get_formula_tree rest_trees f predflag + | NodeA(pos,suctrees) -> + if predflag = "pred" then + if pos.pt = Gamma then + let succs = get_successor_pos (Array.to_list suctrees) in + if List.mem f succs then + NodeA(pos,suctrees),succs + else + get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag + else + get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag + else (* predflag = "" *) + if pos = f then + NodeA(pos,suctrees),[] + else + get_formula_tree ((Array.to_list suctrees) @ rest_trees) f predflag + ) + + let rec get_formula_treelist ftree po = + match po with + [] -> [] + | f::r -> +(* a posistion in po has either stype Gamma_0,Psi_0,Phi_0 (non-atomic), or it has *) +(* ptype Alpha (or on the right), since there was a deadlock for proof reconstruction in LJ*) + if List.mem f.st [Phi_0;Psi_0] then + let (stree,_) = get_formula_tree [ftree] f "" in + stree::(get_formula_treelist ftree r) + else + if f.st = Gamma_0 then + let (predtree,succs) = get_formula_tree [ftree] f "pred" in + let new_po = list_diff r succs in + predtree::(get_formula_treelist ftree new_po) + else + if f.pt = Alpha then (* same as first case, or on the right *) + let (stree,_) = get_formula_tree [ftree] f "" in + stree::(get_formula_treelist ftree r) + else raise (Invalid_argument "Jprover bug: non-admissible open position") + + let rec build_formula_rel dir_treelist slist predname = + + let rec build_renamed_gamma_rel dtreelist predname posname d = + match dtreelist with + [] -> [],[] + | (x,ft)::rdtlist -> + let rest_rel,rest_ren = build_renamed_gamma_rel rdtlist predname posname d in + ( + match ft with + Empty -> (* may have empty successors due to purity in former reconstruction steps *) + rest_rel,rest_ren + | NodeAt(_) -> + raise jprover_bug (* gamma_0 position never is atomic *) + | NodeA(spos,suctrees) -> + if List.mem spos.name slist then +(* the gamma_0 position is really unsolved *) +(* this is only relevant for the gamma_0 positions in po *) + let new_name = (posname^"_"^spos.name) (* make new unique gamma name *) in + let new_srel_el = ((predname,new_name),d) + and new_rename_el = (spos.name,new_name) (* gamma_0 position as key first *) in + let (srel,sren) = build_formula_rel [(x,ft)] slist new_name in + ((new_srel_el::srel) @ rest_rel),((new_rename_el::sren) @ rest_ren) + else + rest_rel,rest_ren + ) + + + in + match dir_treelist with + [] -> [],[] + | (d,f)::dir_r -> + let (rest_rel,rest_renlist) = build_formula_rel dir_r slist predname in + match f with + Empty -> + print_endline "Hello, an empty subtree!!!!!!"; + rest_rel,rest_renlist + | NodeAt(pos) -> + (((predname,pos.name),d)::rest_rel),rest_renlist + | NodeA(pos,suctrees) -> + (match pos.pt with + Alpha | Beta -> + let dtreelist = + if (pos.pt = Alpha) & (pos.op = Neg) then + [(1,suctrees.(0))] + else + let st1 = suctrees.(0) + and st2 = suctrees.(1) in + [(1,st1);(2,st2)] + in + let (srel,sren) = build_formula_rel dtreelist slist pos.name in + ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist) + | Delta -> + let st1 = suctrees.(0) in + let (srel,sren) = build_formula_rel [(1,st1)] slist pos.name in + ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist) + | Psi| Phi -> + let succlist = Array.to_list suctrees in + let dtreelist = (List.map (fun x -> (d,x)) succlist) in + 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 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 + ((((predname,pos.name),d)::srel) @ rest_rel),(sren @ rest_renlist) + else (* we have more than one gamma instance, which means renaming *) +*) + let (srel,sren) = build_renamed_gamma_rel dtreelist predname pos.name d in + (srel @ rest_rel),(sren @ rest_renlist) + | PNull -> + raise jprover_bug + ) + + let rec rename_gamma ljmc_proof rename_list = + match ljmc_proof with + [] -> [] + | ((inst,pos),(rule,formula,term))::r -> + if List.mem rule [Alll;Exr] then + let new_gamma = List.assoc inst rename_list in + ((inst,new_gamma),(rule,formula,term))::(rename_gamma r rename_list) + else + ((inst,pos),(rule,formula,term))::(rename_gamma r rename_list) + + let rec compare_pair (s,sf) list = + if list = [] then + list + else + let (s_1,sf_1),restlist = (List.hd list),(List.tl list) in + if sf = s_1 then + (@) [(s,sf_1)] (compare_pair (s,sf) restlist) + else + compare_pair (s,sf) restlist + + let rec compare_pairlist list1 list2 = + if list1 = [] then + list1 + else + let (s1,sf1),restlist1 = (List.hd list1),(List.tl list1) in + (@) (compare_pair (s1,sf1) list2) (compare_pairlist restlist1 list2) + + let rec trans_rec pairlist translist = + let tlist = compare_pairlist pairlist translist in + if tlist = [] then + translist + else + (@) (trans_rec pairlist tlist) translist + + let transitive_closure subrel = + let pairlist,nlist = List.split subrel in + trans_rec pairlist pairlist + + let pt ptree subrel = + let tsubrel = transitive_closure subrel in + let transptree = trans_layer ptree (subrel,tsubrel) in + print_endline ""; + fst (modify transptree (subrel,tsubrel)) +(* let mtree = fst (modify transptree (subrel,tsubrel)) in *) +(* pretty_print mtree ax *) + + let rec make_node_list ljproof = + match ljproof with + PEmpty -> + raise jprover_bug + | PNodeAx((pos,inf,form,term)) -> + [(("",pos),(inf,form,term))] + | PNodeA((pos,inf,form,term),left) -> + let left_list = make_node_list left in + (("",pos),(inf,form,term))::left_list + | PNodeB((pos,inf,form,term),left,right) -> + let left_list = make_node_list left + and right_list = make_node_list right in + (("",pos),(inf,form,term))::(left_list @ right_list) + + let permute_ljmc ftree po slist ljmc_proof = + (* ftree/po are the formula tree / open positions of the sequent that caused deadlock and permutation *) +(* print_endline "!!!!!!!!!!!!!Permutation TO DO!!!!!!!!!"; *) + (* the open positions in po are either phi_0, psi_0, or gamma_0 positions *) + (* since proof reconstruction was a deadlock in LJ *) + let po_treelist = get_formula_treelist ftree po in + let dir_treelist = List.map (fun x -> (1,x)) po_treelist in + let (formula_rel,rename_list) = build_formula_rel dir_treelist slist "dummy" in + let renamed_ljmc_proof = rename_gamma ljmc_proof rename_list in + let (ptree,ax) = bproof renamed_ljmc_proof in + let ljproof = pt ptree formula_rel in + (* this is a direct formula relation, comprising left/right subformula *) + begin +(* print_treelist po_treelist; *) +(* print_endline ""; + print_endline ""; +*) +(* print_triplelist formula_rel; *) +(* print_endline ""; + print_endline ""; + tt ljproof; +*) +(* print_pairlist rename_list; *) +(* print_endline ""; + print_endline ""; +*) + make_node_list ljproof + end + +(************** PROOF RECONSTRUCTION without redundancy deletion ******************************) + + let rec init_unsolved treelist = + match treelist with + [] -> [] + | f::r -> + begin match f with + Empty -> [] + | NodeAt(pos) -> + (pos.name)::(init_unsolved r) + | NodeA(pos,suctrees) -> + let new_treelist = (Array.to_list suctrees) @ r in + (pos.name)::(init_unsolved new_treelist) + end + +(* only the unsolved positions will be represented --> skip additional root position *) + + let build_unsolved ftree = + match ftree with + Empty | NodeAt _ -> + raise jprover_bug + | NodeA(pos,suctrees) -> + ((pos.name),init_unsolved (Array.to_list suctrees)) + +(* + let rec collect_variables tree_list = + match tree_list with + [] -> [] + | f::r -> + begin match f with + Empty -> [] + | NodeAt(pos) -> + if pos.st = Gamma_0 then + pos.name::collect_variables r + else + collect_variables r + | NodeA(pos,suctrees) -> + let new_tree_list = (Array.to_list suctrees) @ r in + if pos.st = Gamma_0 then + pos.name::collect_variables new_tree_list + else + collect_variables new_tree_list + end + + let rec extend_sigmaQ sigmaQ vlist = + match vlist with + [] -> [] + | f::r -> + let vf = mk_var_term f in + if List.exists (fun x -> (fst x = vf)) sigmaQ then + extend_sigmaQ sigmaQ r + else +(* first and second component are var terms in meta-prl *) + [(vf,vf)] @ (extend_sigmaQ sigmaQ r) + + let build_sigmaQ sigmaQ ftree = + let vlist = collect_variables [ftree] in + sigmaQ @ (extend_sigmaQ sigmaQ vlist) +*) + +(* subformula relation subrel is assumed to be represented in pairs + (a,b) *) + + let rec delete e list = (* e must not necessarily occur in list *) + match list with + [] -> [] (* e must not necessarily occur in list *) + | first::rest -> + if e = first then + rest + else + first::(delete e rest) + + let rec key_delete fname pos_list = (* in key_delete, f is a pos name (key) but sucs is a list of positions *) + match pos_list with + [] -> [] (* the position with name f must not necessarily occur in pos_list *) + | f::r -> + if fname = f.name then + r + else + f::(key_delete fname r) + + let rec get_roots treelist = + match treelist with + [] -> [] + | f::r -> + match f with + Empty -> (get_roots r) (* Empty is posible below alpha-nodes after purity *) + | NodeAt(pos) -> pos::(get_roots r) + | NodeA(pos,trees) -> pos::(get_roots r) + + let rec comp_ps padd ftree = + match ftree with + Empty -> raise (Invalid_argument "Jprover bug: empty formula tree") + | NodeAt(pos) -> + [] + | NodeA(pos,strees) -> + match padd with + [] -> get_roots (Array.to_list strees) + | f::r -> + if r = [] then + pos::(comp_ps r (Array.get strees (f-1))) + else + comp_ps r (Array.get strees (f-1)) + +(* computes a list: first element predecessor, next elements successoes of p *) + + let tpredsucc p ftree = + let padd = p.address in + comp_ps padd ftree + +(* set an element in an array, without side effects *) + + let myset array int element = + let length = Array.length array in + let firstpart = Array.sub array 0 (int) in + let secondpart = Array.sub array (int+1) (length-(int+1)) in + (Array.append firstpart (Array.append [|element|] secondpart)) + + let rec compute_open treelist slist = + match treelist with + [] -> [] + | first::rest -> + let elements = + match first with + Empty -> [] + | NodeAt(pos) -> + if (List.mem (pos.name) slist) then + [pos] + else + [] + | NodeA(pos,suctrees) -> + if (List.mem (pos.name) slist) then + [pos] + else + compute_open (Array.to_list suctrees) slist + in + elements @ (compute_open rest slist) + + let rec select_connection pname connections slist = + match connections with + [] -> ("none","none") + | f::r -> + let partner = + if (fst f) = pname then + (snd f) + else + if (snd f) = pname then + (fst f) + else + "none" + in + if ((partner = "none") or (List.mem partner slist)) then + select_connection pname r slist + else + f + + let rec replace_element element element_set redord = + match redord with + [] -> raise jprover_bug (* element occurs in redord *) + | (f,fset)::r -> + if f = element then + (f,element_set)::r + else + (f,fset)::(replace_element element element_set r) + + let rec collect_succ_sets sucs redord = + match redord with + [] -> StringSet.empty + | (f,fset)::r -> + let new_sucs = key_delete f sucs in + if (List.length sucs) = (List.length new_sucs) then (* position with name f did not occur in sucs -- no deletion *) + (collect_succ_sets sucs r) + else + StringSet.union (StringSet.add f fset) (collect_succ_sets new_sucs r) + + let replace_ordering psucc_name sucs redord = + let new_psucc_set = collect_succ_sets sucs redord in +(* print_string_set new_psucc_set; *) + replace_element psucc_name new_psucc_set redord + + let rec update pname redord = + match redord with + [] -> [] + | (f,fset)::r -> + if pname=f then + r + else + (f,fset)::(update pname r) + +(* rule construction *) + + let rec selectQ_rec spos_var csigmaQ = + match csigmaQ with + [] -> mk_var_term spos_var (* dynamic completion of csigmaQ *) + | (var,term)::r -> + if spos_var=var then + term + else + selectQ_rec spos_var r + + let selectQ spos_name csigmaQ = + let spos_var = spos_name^"_jprover" in + selectQ_rec spos_var csigmaQ + + let apply_sigmaQ term sigmaQ = + let sigma_vars,sigma_terms = List.split sigmaQ in + (subst term sigma_vars sigma_terms) + + let build_rule pos spos csigmaQ orr_flag calculus = + let inst_label = apply_sigmaQ (pos.label) csigmaQ in + match pos.op,pos.pol with + Null,_ -> raise (Invalid_argument "Jprover: no rule") + | At,O -> Ax,(inst_label),xnil_term (* to give back a term *) + | At,I -> Ax,(inst_label),xnil_term + | And,O -> Andr,(inst_label),xnil_term + | And,I -> Andl,(inst_label),xnil_term + | Or,O -> + if calculus = "LJ" then + let or_rule = + if orr_flag = 1 then + Orr1 + else + Orr2 + in + or_rule,(inst_label),xnil_term + else + Orr,(inst_label),xnil_term + | Or,I -> Orl,(inst_label),xnil_term + | Neg,O -> Negr,(inst_label),xnil_term + | Neg,I -> Negl,(inst_label),xnil_term + | Imp,O -> Impr,(inst_label),xnil_term + | Imp,I -> Impl,(inst_label),xnil_term + | All,I -> Alll,(inst_label),(selectQ spos.name csigmaQ) (* elements of csigmaQ is (string * term) *) + | Ex,O -> Exr,(inst_label), (selectQ spos.name csigmaQ) + | All,O -> Allr,(inst_label),(mk_string_term jprover_op spos.name) (* must be a proper term *) + | Ex,I -> Exl,(inst_label),(mk_string_term jprover_op spos.name) (* must be a proper term *) + + +(* %%%%%%%%%%%%%%%%%%%% Split begin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *) + + let rec nonemptys treearray j n = + if j = n then + 0 + else + let count = + if (Array.get treearray j) <> Empty then + 1 + else + 0 + in + count + (nonemptys treearray (j+1) n) + + let rec collect_pure ftreelist (flist,slist) = + + let rec collect_itpure ftree (flist,slist) = + match ftree with + Empty -> (* assumed that not all brother trees are Empty *) + [] + | NodeAt(pos) -> (* that may NOT longer be an inner node *) + if ((List.mem (pos.name) flist) or (List.mem (pos.name) slist)) then + [] + else + [pos] + | NodeA(pos,treearray) -> + collect_pure (Array.to_list treearray) (flist,slist) + in + match ftreelist with + [] -> [] + | f::r -> + (collect_itpure f (flist,slist)) @ (collect_pure r (flist,slist)) + + let rec update_list testlist list = + match testlist with + [] -> list + | f::r -> + let newlist = delete f list in (* f may not occur in list; then newlist=list *) + update_list r newlist + + let rec update_pairlist p pairlist = + match pairlist with + [] -> [] + | f::r -> + if ((fst f) = p) or ((snd f) = p) then + update_pairlist p r + else + f::(update_pairlist p r) + + let rec update_connections slist connections = + match slist with + [] -> connections + | f::r -> + let connew = update_pairlist f connections in + update_connections r connew + + let rec update_redord delset redord = (* delset is the set of positions to be deleted *) + match redord with + [] -> [] + | (f,fset)::r -> + if (StringSet.mem f delset) then + update_redord delset r (* delete all key elements f from redord which are in delset *) + else + let new_fset = StringSet.diff fset delset in (* no successor of f from delset should remain in fset *) + (f,new_fset)::(update_redord delset r) + + let rec get_position_names treelist = + match treelist with + [] -> [] + | deltree::rests -> + match deltree with + Empty -> get_position_names rests + | NodeAt(pos) -> + (pos.name)::get_position_names rests + | NodeA(pos,strees) -> + (pos.name)::(get_position_names ((Array.to_list strees) @ rests)) + + let rec slist_to_set slist = + match slist with + [] -> + StringSet.empty + | f::r -> + StringSet.add f (slist_to_set r) + + let rec print_purelist pr = + match pr with + [] -> + begin + print_string "."; + print_endline " "; + end + | f::r -> + print_string ((f.name)^", "); + print_purelist r + + let update_relations deltree redord connections unsolved_list = + let pure_names = get_position_names [deltree] in + begin +(* print_ftree deltree; + Format.open_box 0; + print_endline " "; + print_stringlist pure_names; + Format.force_newline (); + Format.print_flush (); +*) + let rednew = update_redord (slist_to_set pure_names) redord + and connew = update_connections pure_names connections + and unsolnew = update_list pure_names unsolved_list in + (rednew,connew,unsolnew) + end + + let rec collect_qpos ftreelist uslist = + match ftreelist with + [] -> [],[] + | ftree::rest -> + match ftree with + Empty -> + collect_qpos rest uslist + | NodeAt(pos) -> + let (rest_delta,rest_gamma) = collect_qpos rest uslist in + if (pos.st = Gamma_0) & (List.mem pos.name uslist) then + rest_delta,(pos.name::rest_gamma) + else + if (pos.st = Delta_0) & (List.mem pos.name uslist) then + (pos.name::rest_delta),rest_gamma + else + rest_delta,rest_gamma + | NodeA(pos,suctrees) -> + let (rest_delta,rest_gamma) = collect_qpos ((Array.to_list suctrees) @ rest) uslist in + if (pos.st = Gamma_0) & (List.mem pos.name uslist) then + rest_delta,(pos.name::rest_gamma) + else + if (pos.st = Delta_0) & (List.mem pos.name uslist) then + (pos.name::rest_delta),rest_gamma + else + rest_delta,rest_gamma + + let rec do_split gamma_diff sigmaQ = + match sigmaQ with + [] -> [] + | (v,term)::r -> + if (List.mem (String.sub v 0 (String.index v '_')) gamma_diff) then + do_split gamma_diff r + else + (v,term)::(do_split gamma_diff r) + +(* make a term list out of a bterm list *) + + let rec collect_subterms = function + [] -> [] + | bt::r -> + let dbt = dest_bterm bt in + (dbt.bterm)::(collect_subterms r) + + (*: Bug! :*) +(*: let rec collect_delta_terms = function + [] -> [] + | t::r -> + let dt = dest_term t in + let top = dt.term_op + and tterms = dt.term_terms in + let dop = dest_op top in + let don = dest_opname dop.op_name in + match don with + [] -> + let sub_terms = collect_subterms tterms in + collect_delta_terms (sub_terms @ r) + | op1::opr -> + if op1 = "jprover" then + match opr with + [] -> raise (Invalid_argument "Jprover: delta position missing") + | delta::_ -> + delta::(collect_delta_terms r) + else + let sub_terms = collect_subterms tterms in + collect_delta_terms (sub_terms @ r) +:*) + + let rec collect_delta_terms = function + [] -> [] + | t::r -> + let dt = dest_term t in + let top = dt.term_op + and tterms = dt.term_terms in + let dop = dest_op top in + let don = dest_opname dop.op_name in + let doa = dest_param dop.op_params in + match don with + [] -> + let sub_terms = collect_subterms tterms in + collect_delta_terms (sub_terms @ r) + | op1::opr -> + if op1 = "jprover" then + match doa with + [] -> raise (Invalid_argument "Jprover: delta position missing") + | String delta::_ -> + delta::(collect_delta_terms r) + | _ -> raise (Invalid_argument "Jprover: delta position error") + else + let sub_terms = collect_subterms tterms in + collect_delta_terms (sub_terms @ r) + + + + let rec check_delta_terms (v,term) ass_delta_diff dterms = + match ass_delta_diff with + [] -> term,[] + | (var,dname)::r -> + if List.mem dname dterms then + let new_var = + if var = "" then + v + else + var + in + let replace_term = mk_string_term jprover_op dname in + let next_term = var_subst term replace_term new_var in + let (new_term,next_diffs) = check_delta_terms (v,next_term) r dterms in + (new_term,((new_var,dname)::next_diffs)) + else + let (new_term,next_diffs) = check_delta_terms (v,term) r dterms in + (new_term,((var,dname)::next_diffs)) + + + let rec localize_sigma zw_sigma ass_delta_diff = + match zw_sigma with + [] -> [] + | (v,term)::r -> + let dterms = collect_delta_terms [term] in + let (new_term,new_ass_delta_diff) = check_delta_terms (v,term) ass_delta_diff dterms in + (v,new_term)::(localize_sigma r new_ass_delta_diff) + + let subst_split ft1 ft2 ftree uslist1 uslist2 uslist sigmaQ = + let delta,gamma = collect_qpos [ftree] uslist + and delta1,gamma1 = collect_qpos [ft1] uslist1 + and delta2,gamma2 = collect_qpos [ft2] uslist2 in + let delta_diff1 = list_diff delta delta1 + and delta_diff2 = list_diff delta delta2 + and gamma_diff1 = list_diff gamma gamma1 + and gamma_diff2 = list_diff gamma gamma2 in + let zw_sigma1 = do_split gamma_diff1 sigmaQ + and zw_sigma2 = do_split gamma_diff2 sigmaQ in + let ass_delta_diff1 = List.map (fun x -> ("",x)) delta_diff1 + and ass_delta_diff2 = List.map (fun x -> ("",x)) delta_diff2 in + let sigmaQ1 = localize_sigma zw_sigma1 ass_delta_diff1 + and sigmaQ2 = localize_sigma zw_sigma2 ass_delta_diff2 in + (sigmaQ1,sigmaQ2) + + let rec reduce_tree addr actual_node ftree beta_flag = + match addr with + [] -> (ftree,Empty,actual_node,beta_flag) + | a::radd -> + match ftree with + Empty -> + print_endline "Empty purity tree"; + raise jprover_bug + | NodeAt(_) -> + print_endline "Atom purity tree"; + raise jprover_bug + | NodeA(pos,strees) -> +(* print_endline pos.name; *) + (* the associated node occurs above f (or the empty address) and hence, is neither atom nor empty tree *) + + let nexttree = (Array.get strees (a-1)) in + if (nonemptys strees 0 (Array.length strees)) < 2 then + begin +(* print_endline "strees 1 or non-empties < 2"; *) + let (ft,dt,an,bf) = reduce_tree radd actual_node nexttree beta_flag in + let nstrees = myset strees (a-1) ft in +(* print_endline ("way back "^pos.name); *) + (NodeA(pos,nstrees),dt,an,bf) + end + else (* nonemptys >= 2 *) + begin +(* print_endline "nonempties >= 2 "; *) + let (new_act,new_bf) = + if pos.pt = Beta then + (actual_node,true) + else + ((pos.name),false) + in + let (ft,dt,an,bf) = reduce_tree radd new_act nexttree new_bf in + if an = pos.name then + let nstrees = myset strees (a-1) Empty in +(* print_endline ("way back assocnode "^pos.name); *) + (NodeA(pos,nstrees),nexttree,an,bf) + else (* has been replaced / will be replaced below / above pos *) + let nstrees = myset strees (a-1) ft in +(* print_endline ("way back "^pos.name); *) + (NodeA(pos,nstrees),dt,an,bf) + end + + let rec purity ftree redord connections unsolved_list = + + let rec purity_reduction pr ftree redord connections unsolved_list = + begin +(* Format.open_box 0; + print_endline " "; + print_purelist pr; + Format.force_newline (); + Format.print_flush (); +*) + match pr with + [] -> (ftree,redord,connections,unsolved_list) + | f::r -> +(* print_endline ("pure position "^(f.name)); *) + let (ftnew,deltree,assocn,beta_flag) = reduce_tree f.address "" ftree false + in +(* print_endline ("assoc node "^assocn); *) + if assocn = "" then + (Empty,[],[],[]) (* should not occur in the final version *) + else + let (rednew,connew,unsolnew) = update_relations deltree redord connections unsolved_list in + begin +(* Format.open_box 0; + print_endline " "; + print_pairlist connew; + Format.force_newline (); + Format.print_flush (); +*) + if beta_flag = true then + begin +(* print_endline "beta_flag true"; *) + purity ftnew rednew connew unsolnew + (* new pure positions may occur; old ones may not longer exist *) + end + else + purity_reduction r ftnew rednew connew unsolnew (* let's finish the old pure positions *) + end + end + + in + let flist,slist = List.split connections in + let pr = collect_pure [ftree] (flist,slist) in + purity_reduction pr ftree redord connections unsolved_list + + let rec betasplit addr ftree redord connections unsolved_list = + match ftree with + Empty -> + print_endline "bsplit Empty tree"; + raise jprover_bug + | NodeAt(_) -> + print_endline "bsplit Atom tree"; + raise jprover_bug (* the beta-node should actually occur! *) + | NodeA(pos,strees) -> + match addr with + [] -> (* we are at the beta node under consideration *) + let st1tree = (Array.get strees 0) + and st2tree = (Array.get strees 1) in + let (zw1red,zw1conn,zw1uslist) = update_relations st2tree redord connections unsolved_list + and (zw2red,zw2conn,zw2uslist) = update_relations st1tree redord connections unsolved_list in + ((NodeA(pos,[|st1tree;Empty|])),zw1red,zw1conn,zw1uslist), + ((NodeA(pos,[|Empty;st2tree|])),zw2red,zw2conn,zw2uslist) + | f::rest -> + let nexttree = Array.get strees (f-1) in + let (zw1ft,zw1red,zw1conn,zw1uslist),(zw2ft,zw2red,zw2conn,zw2uslist) = + betasplit rest nexttree redord connections unsolved_list in +(* let scopytrees = Array.copy strees in *) + let zw1trees = myset strees (f-1) zw1ft + and zw2trees = myset strees (f-1) zw2ft in + (NodeA(pos,zw1trees),zw1red,zw1conn,zw1uslist),(NodeA(pos,zw2trees),zw2red,zw2conn,zw2uslist) + + + + + let split addr pname ftree redord connections unsolved_list opt_bproof = + let (opt_bp1,min_con1),(opt_bp2,min_con2) = split_permutation pname opt_bproof in + begin +(* + print_endline "Beta proof 1: "; + print_endline ""; + print_beta_proof opt_bp1; + print_endline ""; + print_endline ("Beta proof 1 connections: "); + Format.open_box 0; + print_pairlist min_con1; + print_endline "."; + Format.print_flush(); + print_endline ""; + print_endline ""; + print_endline "Beta proof 2: "; + print_endline ""; + print_beta_proof opt_bp2; + print_endline ""; + print_endline ("Beta proof 2 connections: "); + Format.open_box 0; + print_pairlist min_con2; + print_endline "."; + Format.print_flush(); + print_endline ""; +*) + let (zw1ft,zw1red,zw1conn,zw1uslist),(zw2ft,zw2red,zw2conn,zw2uslist) = + betasplit addr ftree redord connections unsolved_list in +(* zw1conn and zw2conn are not longer needed when using beta proofs *) +(* print_endline "betasp_out"; *) + let ft1,red1,conn1,uslist1 = purity zw1ft zw1red min_con1 zw1uslist in +(* print_endline "purity_one_out"; *) + let ft2,red2,conn2,uslist2 = purity zw2ft zw2red min_con2 zw2uslist in +(* print_endline "purity_two_out"; *) +(* again, min_con1 = conn1 and min_con2 = conn2 should hold *) + begin +(* print_endline ""; + print_endline ""; + print_endline ("Purity 1 connections: "); + Format.open_box 0; + print_pairlist conn1; + print_endline "."; + print_endline ""; + Format.print_flush(); + print_endline ""; + print_endline ""; + print_endline ("Purity 2 connections: "); + Format.open_box 0; + print_pairlist conn2; + print_endline "."; + print_endline ""; + Format.print_flush(); + print_endline ""; + print_endline ""; +*) + (ft1,red1,conn1,uslist1,opt_bp1),(ft2,red2,conn2,uslist2,opt_bp2) + end + end + + +(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Splitting end %%%%%%%%%%%%%%%% *) + + +(* for wait labels we collect all solved atoms with pol=0 *) + + let rec collect_solved_O_At ftreelist slist = + match ftreelist with + [] -> + [] + | f::r -> + match f with + Empty -> (* may become possible after purity *) + collect_solved_O_At r slist + | NodeAt(pos) -> + if ((List.mem (pos.name) slist) or (pos.pol = I)) then (* recall slist is the unsolved list *) + collect_solved_O_At r slist + else + (* here, we have pos solved and pos.pol = O) *) + pos::(collect_solved_O_At r slist) + | NodeA(pos,treearray) -> + collect_solved_O_At ((Array.to_list treearray) @ r) slist + + let rec red_ord_block pname redord = + match redord with + [] -> false + | (f,fset)::r -> + if ((f = pname) or (not (StringSet.mem pname fset))) then + red_ord_block pname r + else + true (* then, we have (StringSet.mem pname fset) *) + + let rec check_wait_succ_LJ faddress ftree = + match ftree with + Empty -> raise jprover_bug + | NodeAt(pos) -> raise jprover_bug (* we have an gamma_0 position or an or-formula *) + | NodeA(pos,strees) -> + match faddress with + [] -> + if pos.op = Or then + match (strees.(0),strees.(1)) with + (Empty,Empty) -> raise (Invalid_argument "Jprover: redundancies occur") + | (Empty,_) -> (false,2) (* determines the Orr2 rule *) + | (_,Empty) -> (false,1) (* determines the Orr1 ruke *) + | (_,_) -> (true,0) (* wait-label is set *) + else + (false,0) + | f::r -> + if r = [] then + if (pos.pt = Gamma) & ((nonemptys strees 0 (Array.length strees)) > 1) then + (true,0) (* we are at a gamma position (exr) with one than one successor -- wait label in LJ*) + else + check_wait_succ_LJ r (Array.get strees (f-1)) + else + check_wait_succ_LJ r (Array.get strees (f-1)) + + let blocked f po redord ftree connections slist logic calculus opt_bproof = +(* print_endline ("Blocking check "^(f.name)); *) + if (red_ord_block (f.name) redord) then + begin +(* print_endline "wait-1 check positive"; *) + true,0 + end + else + if logic = "C" then + false,0 (* ready, in C only redord counts *) + else + let pa_O = collect_solved_O_At [ftree] slist (* solved atoms in ftree *) + and po_test = (delete f po) in + if calculus = "LJmc" then (* we provide dynamic wait labels for both sequent calculi *) +(* print_endline "wait-2 check"; *) + if (f.st = Psi_0) & (f.pt <> PNull) & + ((pa_O <> []) or (List.exists (fun x -> x.pol = O) po_test)) then + begin +(* print_endline "wait-2 positive"; *) + true,0 (* wait_2 label *) + end + else + begin +(* print_endline "wait-2 negative"; *) + false,0 + end + else (* calculus is supposed to be LJ *) + if calculus = "LJ" then + if ((f.st = Phi_0) & ((f.op=Neg) or (f.op=Imp)) & + ((pa_O <> []) or (List.exists (fun x -> x.pol = O) po_test)) + ) + (* this would cause an impl or negl rule with an non-empty succedent *) + then + if (f.op=Neg) then + true,0 + else (* (f.op=Imp) *) + (* In case of an impl rule on A => B, the wait_label must NOT be set + iff all succedent formulae depend exclusively on B. For this, we + perform a split operation and determine, if in the A-subgoal + all succedent formulae are pure, i.e.~have been deleted from treds. + Otherwise, in case of A-dependent succedent formulae, the + wait_label must be set. + *) + let ((_,min_con1),_) = split_permutation f.name opt_bproof in + let slist_fake = delete f.name slist in + let ((zw1ft,zw1red,_,zw1uslist),_) = + betasplit (f.address) ftree redord connections slist_fake in + let ft1,_,_,uslist1 = purity zw1ft zw1red min_con1 zw1uslist in +(* print_endline "wait label purity_one_out"; *) + let ft1_root = (List.hd (List.tl (tpredsucc f ft1))) in +(* print_endline ("wait-root "^(ft1_root.name)); *) + let po_fake = compute_open [ft1] uslist1 in + let po_fake_test = delete ft1_root po_fake + and pa_O_fake = collect_solved_O_At [ft1] uslist1 in +(* print_purelist (po_fake_test @ pa_O_fake); *) + if ((pa_O_fake <> []) or (List.exists (fun x -> x.pol = O) po_fake_test)) then + true,0 + else + false,0 + else + if ((f.pol=O) & ((f.st=Gamma_0) or (f.op=Or))) then + let (bool,orr_flag) = check_wait_succ_LJ f.address ftree in + (bool,orr_flag) + (* here is determined if orr1 or orr2 will be performed, provided bool=false) *) + (* orr_flag can be 1 or 2 *) + else + false,0 + else + raise (Invalid_argument "Jprover: calculus should be LJmc or LJ") + + let rec get_beta_preference list actual = + match list with + [] -> actual + | (f,int)::r -> + if f.op = Imp then + (f,int) + else +(* if f.op = Or then + get_beta_preference r (f,int) + else +*) + get_beta_preference r actual + + exception Gamma_deadlock + + let rec select_pos search_po po redord ftree connections slist logic calculus candidates + opt_bproof = + match search_po with + [] -> + (match candidates with + [] -> + if calculus = "LJ" then + raise Gamma_deadlock (* permutation may be necessary *) + else + raise (Invalid_argument "Jprover bug: overall deadlock") (* this case should not occur *) + | c::rest -> + get_beta_preference (c::rest) c + ) + | f::r -> (* there exist an open position *) + let (bool,orr_flag) = (blocked f po redord ftree connections slist logic calculus + opt_bproof) + in + if (bool = true) then + select_pos r po redord ftree connections slist logic calculus candidates opt_bproof + else + if f.pt = Beta then + (* search for non-splitting rules first *) +(* let beta_candidate = + if candidates = [] + then + [(f,orr_flag)] + else + !!!! but preserve first found candidate !!!!!!! + candidates + in + !!!!!!! this strategy is not sure the best -- back to old !!!!!!!!! +*) + select_pos r po redord ftree connections slist logic calculus + ((f,orr_flag)::candidates) opt_bproof + else + (f,orr_flag) + +(* let rec get_position_in_tree pname treelist = + match treelist with + [] -> raise jprover_bug + | f::r -> + begin match f with + Empty -> get_position_in_tree pname r + | NodeAt(pos) -> + if pos.name = pname then + pos + else + get_position_in_tree pname r + | NodeA(pos,suctrees) -> + get_position_in_tree pname ((Array.to_list suctrees) @ r) + end +*) + +(* total corresponds to tot in the thesis, + tot simulates the while-loop, solve is the rest *) + + let rec total ftree redord connections csigmaQ slist logic calculus opt_bproof = + let rec tot ftree redord connections po slist = + let rec solve ftree redord connections p po slist (pred,succs) orr_flag = + let newslist = delete (p.name) slist in + let rback = + if p.st = Gamma_0 then + begin +(* print_endline "that's the gamma rule"; *) + [((p.name,pred.name),(build_rule pred p csigmaQ orr_flag calculus))] + end + else + [] + in +(* print_endline "gamma check finish"; *) + let pnew = + if p.pt <> Beta then + succs @ (delete p po) + else + po + in + match p.pt with + Gamma -> + rback @ (tot ftree redord connections pnew newslist) + | Psi -> + if p.op = At then + let succ = List.hd succs in + rback @ (solve ftree redord connections succ pnew newslist (p,[]) orr_flag) (* solve atoms immediately *) + else + rback @ (tot ftree redord connections pnew newslist) + | Phi -> + if p.op = At then + let succ = List.hd succs in + rback @ (solve ftree redord connections succ pnew newslist (p,[]) orr_flag) (* solve atoms immediately *) + else + rback @ (tot ftree redord connections pnew newslist) + | PNull -> + let new_redord = update p.name redord in + let (c1,c2) = select_connection (p.name) connections newslist in + if (c1= "none" & c2 ="none") then + rback @ (tot ftree new_redord connections pnew newslist) + else + let (ass_pos,inst_pos) = +(* need the pol=O position ass_pos of the connection for later permutation *) +(* need the pol=I position inst_pos for NuPRL instantiation *) + if p.name = c1 then + if p.pol = O then + (c1,c2) + else + (c2,c1) + else (* p.name = c2 *) + if p.pol = O then + (c2,c1) + else + (c1,c2) + in + rback @ [(("",ass_pos),(build_rule p p csigmaQ orr_flag calculus))] + (* one possibility of recursion end *) + | Alpha -> + rback @ ((("",p.name),(build_rule p p csigmaQ orr_flag calculus))::(tot ftree redord connections pnew newslist)) + | Delta -> + let sp = List.hd succs in + rback @ ((("",p.name),(build_rule p sp csigmaQ orr_flag calculus))::(tot ftree redord connections pnew newslist)) + | Beta -> +(* print_endline "split_in"; *) + let (ft1,red1,conn1,uslist1,opt_bproof1),(ft2,red2,conn2,uslist2,opt_bproof2) = + split (p.address) (p.name) ftree redord connections newslist opt_bproof in + let (sigmaQ1,sigmaQ2) = subst_split ft1 ft2 ftree uslist1 uslist2 newslist csigmaQ in +(* print_endline "split_out"; *) + let p1 = total ft1 red1 conn1 sigmaQ1 uslist1 logic calculus opt_bproof1 in +(* print_endline "compute p1 out"; *) + let p2 = total ft2 red2 conn2 sigmaQ2 uslist2 logic calculus opt_bproof2 in +(* print_endline "compute p2 out"; *) + rback @ [(("",p.name),(build_rule p p csigmaQ orr_flag calculus))] @ p1 @ p2 (* second possibility of recursion end *) + in + begin try + let (p,orr_flag) = select_pos po po redord ftree connections slist logic + calculus [] opt_bproof + (* last argument for guiding selection strategy *) + in +(* print_endline ((p.name)^" "^(string_of_int orr_flag)); *) + let predsuccs = tpredsucc p ftree in + let pred = List.hd predsuccs + and succs = List.tl predsuccs in + let redpo = update (p.name) redord in (* deletes the entry (p,psuccset) from the redord *) + let rednew = + 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 + replace_ordering (psucc.name) sucs redpo (* union the succsets of psucc *) + else + redpo + in +(* print_endline "update ok"; *) + solve ftree rednew connections p po slist (pred,succs) orr_flag + with Gamma_deadlock -> + let ljmc_subproof = total ftree redord connections csigmaQ slist "J" "LJmc" opt_bproof + in + eigen_counter := 1; + permute_ljmc ftree po slist ljmc_subproof + (* the permuaiton result will be appended to the lj proof constructed so far *) + end + in + let po = compute_open [ftree] slist in + tot ftree redord connections po slist + + let reconstruct ftree redord sigmaQ ext_proof logic calculus = + let min_connections = remove_dups_connections ext_proof in + let (opt_bproof,beta_exp,closures) = construct_opt_beta_proof ftree ext_proof in +(* let connections = remove_dups_connections ext_proof in + let bproof,beta_exp,closures = construct_beta_proof ftree connections in + let (opt_bproof,min_connections) = bproof_purity bproof in +*) + if !debug_jprover then + begin + print_endline ""; + print_endline ("Beta proof with number of closures = "^(string_of_int closures)^" and number of beta expansions = "^(string_of_int beta_exp)); +(* print_endline ""; + print_endline ""; + print_beta_proof bproof; + print_endline ""; + print_endline ""; + print_endline "Optimal beta proof: "; + print_endline ""; + print_endline ""; + print_beta_proof opt_bproof; + print_endline ""; + print_endline ""; + print_endline ("Beta proof connections: "); + Format.open_box 0; + print_pairlist min_connections; + print_endline "."; + Format.print_flush(); *) + print_endline ""; + end; + let (newroot_name,unsolved_list) = build_unsolved ftree in + let redord2 = (update newroot_name redord) in (* otherwise we would have a deadlock *) + let (init_tree,init_redord,init_connections,init_unsolved_list) = + purity ftree redord2 min_connections unsolved_list in + begin +(* print_endline ""; + print_endline ""; + print_endline ("Purity connections: "); + Format.open_box 0; + print_pairlist init_connections; + print_endline "."; + print_endline ""; + Format.print_flush(); + print_endline ""; + print_endline ""; +*) +(* it should hold: min_connections = init_connections *) + total init_tree init_redord init_connections sigmaQ + init_unsolved_list logic calculus opt_bproof + end + +(* ***************** REDUCTION ORDERING -- both types **************************** *) + + exception Reflexive + + let rec transitive_irreflexive_closure addset const ordering = + match ordering with + [] -> + [] + | (pos,fset)::r -> + if (pos = const) or (StringSet.mem const fset) then +(* check reflexsivity during transitive closure wrt. addset ONLY!!! *) + if StringSet.mem pos addset then + raise Reflexive + else + (pos,(StringSet.union fset addset))::(transitive_irreflexive_closure addset const r) + else + (pos,fset)::(transitive_irreflexive_closure addset const r) + + let rec search_set var ordering = +(* print_endline var; *) + match ordering with + [] -> + raise (Invalid_argument "Jprover: element in ordering missing") + | (pos,fset)::r -> + if pos = var then + StringSet.add pos fset + else + search_set var r + + let add_sets var const ordering = + let addset = search_set var ordering in + transitive_irreflexive_closure addset const ordering + +(* ************* J ordering ********************************************** *) + + let rec add_arrowsJ (v,vlist) ordering = + match vlist with + [] -> ordering + | f::r -> + if ((String.get f 0)='c') then + let new_ordering = add_sets v f ordering in + add_arrowsJ (v,r) new_ordering + else + add_arrowsJ (v,r) ordering + + let rec add_substJ replace_vars replace_string ordering atom_rel = + match replace_vars with + [] -> ordering + | v::r -> + if (String.get v 1 = 'n') (* don't integrate new variables *) + or (List.exists (fun (x,_,_) -> (x.aname = v)) atom_rel) then (* no reduction ordering at atoms *) + (add_substJ r replace_string ordering atom_rel) + else + let next_ordering = add_arrowsJ (v,replace_string) ordering in + (add_substJ r replace_string next_ordering atom_rel) + + let build_orderingJ replace_vars replace_string ordering atom_rel = + try + add_substJ replace_vars replace_string ordering atom_rel + with Reflexive -> (* only possible in the FO case *) + raise Not_unifiable (*search for alternative string unifiers *) + + let rec build_orderingJ_list substJ ordering atom_rel = + match substJ with + [] -> ordering + | (v,vlist)::r -> + let next_ordering = build_orderingJ [v] vlist ordering atom_rel in + build_orderingJ_list r next_ordering atom_rel + +(* ************* J ordering END ********************************************** *) + +(* ************* quantifier ordering ********************************************** *) + + let rec add_arrowsQ v clist ordering = + match clist with + [] -> ordering + | f::r -> + let new_ordering = add_sets v f ordering in + add_arrowsQ v r new_ordering + + let rec print_sigmaQ sigmaQ = + match sigmaQ with + [] -> + print_endline "." + | (v,term)::r -> + begin + Format.open_box 0; + print_endline " "; + print_string (v^" = "); + print_term stdout term; + Format.force_newline (); + Format.print_flush (); + print_sigmaQ r + end + + let rec print_term_list tlist = + match tlist with + [] -> print_string "." + | t::r -> + begin + print_term stdout t; + print_string " "; + print_term_list r + end + + let rec add_sigmaQ new_elements ordering = + match new_elements with + [] -> ([],ordering) + | (v,termlist)::r -> + let dterms = collect_delta_terms termlist in + begin +(*: print_stringlist dterms; + mbreak "add_sigmaQ:1\n"; + Format.open_box 0; + print_endline " "; + print_endline "sigmaQ: "; + print_string (v^" = "); + print_term_list termlist; + Format.force_newline (); + print_stringlist dterms; + Format.force_newline (); + Format.print_flush (); + mbreak "add_sigmaQ:2\n"; +:*) + let new_ordering = add_arrowsQ v dterms ordering in +(*: print_ordering new_ordering; + mbreak "add_sigmaQ:3\n"; +:*) + let (rest_pairs,rest_ordering) = add_sigmaQ r new_ordering in + ((v,dterms)::rest_pairs),rest_ordering + end + + let build_orderingQ new_elements ordering = +(* new_elements is of type (string * term list) list, since one variable can receive more than *) +(* a single term due to substitution multiplication *) + try +(* print_endline "build orderingQ in"; *) (* apple *) + add_sigmaQ new_elements ordering; + with Reflexive -> + raise Failed (* new connection, please *) + + +(* ************* quantifier ordering END ********************************************** *) + +(* ****** Quantifier unification ************** *) + +(* For multiplication we assume always idempotent substitutions sigma, tau! *) + + let rec collect_assoc inst_vars tauQ = + match inst_vars with + [] -> [] + | f::r -> + let f_term = List.assoc f tauQ in + f_term::(collect_assoc r tauQ) + + let rec rec_apply sigmaQ tauQ tau_vars tau_terms = + match sigmaQ with + [] -> [],[] + | (v,term)::r -> + let app_term = subst term tau_vars tau_terms in + let old_free = free_vars_list term + and new_free = free_vars_list app_term in + let inst_vars = list_diff old_free new_free in + let inst_terms = collect_assoc inst_vars tauQ in + let (rest_sigma,rest_sigma_ordering) = rec_apply r tauQ tau_vars tau_terms in + if inst_terms = [] then + ((v,app_term)::rest_sigma),rest_sigma_ordering + else + let ordering_v = String.sub v 0 (String.index v '_') in + ((v,app_term)::rest_sigma),((ordering_v,inst_terms)::rest_sigma_ordering) + +(* let multiply sigmaQ tauQ = + let tau_vars,tau_terms = List.split tauQ + and sigma_vars,sigma_terms = List.split sigmaQ in + let apply_terms = rec_apply sigma_terms tau_vars tau_terms in + (List.combine sigma_vars apply_terms) @ tauQ +*) + + let multiply sigmaQ tauQ = + let (tau_vars,tau_terms) = List.split tauQ in + let (new_sigmaQ,sigma_ordering) = rec_apply sigmaQ tauQ tau_vars tau_terms in + let tau_ordering_terms = (List.map (fun x -> [x]) tau_terms) (* for extending ordering_elements *) in + let tau_ordering_vars = (List.map (fun x -> String.sub x 0 (String.index x '_')) tau_vars) in + let tau_ordering = (List.combine tau_ordering_vars tau_ordering_terms) in + ((new_sigmaQ @ tauQ), + (sigma_ordering @ tau_ordering) + ) + + let apply_2_sigmaQ term1 term2 sigmaQ = + let sigma_vars,sigma_terms = List.split sigmaQ in + (subst term1 sigma_vars sigma_terms),(subst term2 sigma_vars sigma_terms) + + let jqunify term1 term2 sigmaQ = + let app_term1,app_term2 = apply_2_sigmaQ term1 term2 sigmaQ in + try +(*: let tauQ = unify_mm app_term1 app_term2 String_set.StringSet.empty in :*) + let tauQ = unify_mm app_term1 app_term2 StringSet.empty in + let (mult,oel) = multiply sigmaQ tauQ in + (mult,oel) + with + RefineError _ -> (* any unification failure *) +(* print_endline "fo-unification fail"; *) + raise Failed (* new connection, please *) + +(* ************ T-STRING UNIFICATION ******************************** *) + + let rec combine subst (ov,oslist) = + match subst with + [] -> [],[] + | f::r -> + let (v,slist) = f in + let rest_vlist,rest_combine = (combine r (ov,oslist)) in + if (List.mem ov slist) then (* subst assumed to be idemponent *) + let com_element = com_subst slist (ov,oslist) in + (v::rest_vlist),((v,com_element)::rest_combine) + else + (rest_vlist,(f::rest_combine)) + + let compose sigma one_subst = + let (n,subst)=sigma + and (ov,oslist) = one_subst in + let (trans_vars,com) = combine subst (ov,oslist) + in +(* begin + print_endline "!!!!!!!!!test print!!!!!!!!!!"; + print_subst [one_subst]; + print_subst subst; + print_endline "!!!!!!!!! END test print!!!!!!!!!!"; +*) + if List.mem one_subst subst then + (trans_vars,(n,com)) + else +(* ov may multiply as variable in subst with DIFFERENT values *) +(* in order to avoid explicit atom instances!!! *) + (trans_vars,(n,(com @ [one_subst]))) +(* end *) + + let rec apply_element fs ft (v,slist) = + match (fs,ft) with + ([],[]) -> + ([],[]) + | ([],(ft_first::ft_rest)) -> + let new_ft_first = + if ft_first = v then + slist + else + [ft_first] + in + let (emptylist,new_ft_rest) = apply_element [] ft_rest (v,slist) in + (emptylist,(new_ft_first @ new_ft_rest)) + | ((fs_first::fs_rest),[]) -> + let new_fs_first = + if fs_first = v then + slist + else + [fs_first] + in + let (new_fs_rest,emptylist) = apply_element fs_rest [] (v,slist) in + ((new_fs_first @ new_fs_rest),emptylist) + | ((fs_first::fs_rest),(ft_first::ft_rest)) -> + let new_fs_first = + if fs_first = v then + slist + else + [fs_first] + and new_ft_first = + if ft_first = v then + slist + else + [ft_first] + in + let (new_fs_rest,new_ft_rest) = apply_element fs_rest ft_rest (v,slist) in + ((new_fs_first @ new_fs_rest),(new_ft_first @ new_ft_rest)) + + let rec shorten us ut = + match (us,ut) with + ([],_) -> (us,ut) + | (_,[]) -> (us,ut) + | ((fs::rs),(ft::rt)) -> + if fs = ft then + shorten rs rt + else + (us,ut) + + let rec apply_subst_list eq_rest (v,slist) = + + match eq_rest with + [] -> + (true,[]) + | (atomnames,(fs,ft))::r -> + let (n_fs,n_ft) = apply_element fs ft (v,slist) in + let (new_fs,new_ft) = shorten n_fs n_ft in (* delete equal first elements *) + match (new_fs,new_ft) with + [],[] -> + let (bool,new_eq_rest) = apply_subst_list r (v,slist) in + (bool,((atomnames,([],[]))::new_eq_rest)) + | [],(fft::rft) -> + if (is_const fft) then + (false,[]) + else + let (bool,new_eq_rest) = apply_subst_list r (v,slist) in + (bool,((atomnames,([],new_ft))::new_eq_rest)) + | (ffs::rfs),[] -> + if (is_const ffs) then + (false,[]) + else + let (bool,new_eq_rest) = apply_subst_list r (v,slist) in + (bool,((atomnames,(new_fs,[]))::new_eq_rest)) + | (ffs::rfs),(fft::rft) -> + if (is_const ffs) & (is_const fft) then + (false,[]) + (* different first constants cause local fail *) + else + (* at least one of firsts is a variable *) + let (bool,new_eq_rest) = apply_subst_list r (v,slist) in + (bool,((atomnames,(new_fs,new_ft))::new_eq_rest)) + + let apply_subst eq_rest (v,slist) atomnames = + if (List.mem v atomnames) then (* don't apply subst to atom variables !! *) + (true,eq_rest) + else + apply_subst_list eq_rest (v,slist) + + let all_variable_check eqlist = false (* needs some discussion with Jens! -- NOT done *) + +(* + let rec all_variable_check eqlist = + match eqlist with + [] -> true + | ((_,(fs,ft))::rest_eq) -> + if (fs <> []) & (ft <> []) then + let fs_first = List.hd fs + and ft_first = List.hd ft + in + if (is_const fs_first) or (is_const ft_first) then + false + else + all_variable_check rest_eq + else + false +*) + + let rec tunify_list eqlist init_sigma orderingQ atom_rel = + + let rec tunify atomnames fs ft rt rest_eq sigma ordering = + + let apply_r1 fs ft rt rest_eq sigma = +(* print_endline "r1"; *) + tunify_list rest_eq sigma ordering atom_rel + + in + let apply_r2 fs ft rt rest_eq sigma = +(* print_endline "r2"; *) + tunify atomnames rt fs ft rest_eq sigma ordering + + in + let apply_r3 fs ft rt rest_eq sigma = +(* print_endline "r3"; *) + let rfs = (List.tl fs) + and rft = (List.tl rt) in + tunify atomnames rfs ft rft rest_eq sigma ordering + + in + let apply_r4 fs ft rt rest_eq sigma = +(* print_endline "r4"; *) + tunify atomnames rt ft fs rest_eq sigma ordering + + in + let apply_r5 fs ft rt rest_eq sigma = +(* print_endline "r5"; *) + let v = (List.hd fs) in + let (compose_vars,new_sigma) = compose sigma (v,ft) in + let (bool,new_rest_eq) = apply_subst rest_eq (v,ft) atomnames in + if (bool=false) then + raise Not_unifiable + else + let new_ordering = build_orderingJ (v::compose_vars) ft ordering atom_rel in + tunify atomnames (List.tl fs) rt rt new_rest_eq new_sigma new_ordering + + in + let apply_r6 fs ft rt rest_eq sigma = +(* print_endline "r6"; *) + let v = (List.hd fs) in + let (_,new_sigma) = (compose sigma (v,[])) in + let (bool,new_rest_eq) = apply_subst rest_eq (v,[]) atomnames in + if (bool=false) then + raise Not_unifiable + else + (* no relation update since [] has been replaced for v *) + tunify atomnames (List.tl fs) ft rt new_rest_eq new_sigma ordering + + in + let apply_r7 fs ft rt rest_eq sigma = +(* print_endline "r7"; *) + let v = (List.hd fs) + and c1 = (List.hd rt) + and c2t =(List.tl rt) in + let (compose_vars,new_sigma) = (compose sigma (v,(ft @ [c1]))) in + let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [c1])) atomnames in + if bool=false then + raise Not_unifiable + else + let new_ordering = build_orderingJ (v::compose_vars) (ft @ [c1]) ordering atom_rel in + tunify atomnames (List.tl fs) [] c2t new_rest_eq new_sigma new_ordering + + + in + let apply_r8 fs ft rt rest_eq sigma = +(* print_endline "r8"; *) + tunify atomnames rt [(List.hd fs)] (List.tl fs) rest_eq sigma ordering + + in + let apply_r9 fs ft rt rest_eq sigma = +(* print_endline "r9"; *) + let v = (List.hd fs) + and (max,subst) = sigma in + let v_new = ("vnew"^(string_of_int max)) in + let (compose_vars,new_sigma) = (compose ((max+1),subst) (v,(ft @ [v_new]))) in + let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [v_new])) atomnames in + if (bool=false) then + raise Not_unifiable + else + let new_ordering = + build_orderingJ (v::compose_vars) (ft @ [v_new]) ordering atom_rel in + tunify atomnames rt [v_new] (List.tl fs) new_rest_eq new_sigma new_ordering + + in + let apply_r10 fs ft rt rest_eq sigma = +(* print_endline "r10"; *) + let x = List.hd rt in + tunify atomnames fs (ft @ [x]) (List.tl rt) rest_eq sigma ordering + + in + if r_1 fs ft rt then + apply_r1 fs ft rt rest_eq sigma + else if r_2 fs ft rt then + apply_r2 fs ft rt rest_eq sigma + else if r_3 fs ft rt then + apply_r3 fs ft rt rest_eq sigma + else if r_4 fs ft rt then + apply_r4 fs ft rt rest_eq sigma + else if r_5 fs ft rt then + apply_r5 fs ft rt rest_eq sigma + else if r_6 fs ft rt then + (try + apply_r6 fs ft rt rest_eq sigma + with Not_unifiable -> + if r_7 fs ft rt then (* r7 applicable if r6 was and tr6 = C2t' *) + (try + apply_r7 fs ft rt rest_eq sigma + with Not_unifiable -> + apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r6 was *) + ) + else +(* r10 could be represented only once if we would try it before r7.*) +(* but looking at the transformation rules, r10 should be tried at last in any case *) + apply_r10 fs ft rt rest_eq sigma (* r10 always applicable r6 was *) + ) + else if r_7 fs ft rt then (* not r6 and r7 possible if z <> [] *) + (try + apply_r7 fs ft rt rest_eq sigma + with Not_unifiable -> + apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r7 was *) + ) + else if r_8 fs ft rt then + (try + apply_r8 fs ft rt rest_eq sigma + with Not_unifiable -> + if r_10 fs ft rt then (* r10 applicable if r8 was and tr8 <> [] *) + apply_r10 fs ft rt rest_eq sigma + else + raise Not_unifiable (* simply back propagation *) + ) + else if r_9 fs ft rt then + (try + apply_r9 fs ft rt rest_eq sigma + with Not_unifiable -> + if r_10 fs ft rt then (* r10 applicable if r9 was and tr9 <> [] *) + apply_r10 fs ft rt rest_eq sigma + else + raise Not_unifiable (* simply back propagation *) + ) + + + else + if r_10 fs ft rt then (* not ri, i<10, and r10 possible if for instance *) + (* (s=[] and x=v1) or (z<>[] and xt=C1V1t') *) + apply_r10 fs ft rt rest_eq sigma + else (* NO rule applicable *) + raise Not_unifiable + in + match eqlist with + [] -> + init_sigma,orderingQ + | f::rest_eq -> + begin +(* Format.open_box 0; + print_equations [f]; + Format.print_flush (); +*) + let (atomnames,(fs,ft)) = f in + tunify atomnames fs [] ft rest_eq init_sigma orderingQ + end + +let rec test_apply_eq atomnames eqs eqt subst = + match subst with + [] -> (eqs,eqt) + | (f,flist)::r -> + let (first_appl_eqs,first_appl_eqt) = + if List.mem f atomnames then + (eqs,eqt) + else + (apply_element eqs eqt (f,flist)) + in + test_apply_eq atomnames first_appl_eqs first_appl_eqt r + +let rec test_apply_eqsubst eqlist subst = + match eqlist with + [] -> [] + | f::r -> + let (atomnames,(eqs,eqt)) = f in + let applied_element = test_apply_eq atomnames eqs eqt subst in + (atomnames,applied_element)::(test_apply_eqsubst r subst) + +let ttest us ut ns nt eqlist orderingQ atom_rel = + let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 *) + (* to eliminate common beginning *) + let new_element = ([ns;nt],(short_us,short_ut)) in + let full_eqlist = + if List.mem new_element eqlist then + eqlist + else + new_element::eqlist + in + let (sigma,_) = tunify_list full_eqlist (1,[]) orderingQ atom_rel in + let (n,subst) = sigma in + let test_apply = test_apply_eqsubst full_eqlist subst in + begin + print_endline ""; + print_endline "Final equations:"; + print_equations full_eqlist; + print_endline ""; + print_endline "Final substitution:"; + print_tunify sigma; + print_endline ""; + print_endline "Applied equations:"; + print_equations test_apply + end + +let do_stringunify us ut ns nt equations fo_eqlist orderingQ atom_rel qmax = + let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 to eliminate common beginning *) + let new_element = ([ns;nt],(short_us,short_ut)) in + let full_eqlist = + if List.mem new_element equations then + equations @ fo_eqlist + else + (new_element::equations) @ fo_eqlist + in + try +(* print_equations full_eqlist; *) +(* max-1 new variables have been used for the domain equations *) + let (new_sigma,new_ordering) = tunify_list full_eqlist (1,[]) orderingQ atom_rel in +(* sigmaQ will not be returned in eqlist *) + (new_sigma,(qmax,full_eqlist),new_ordering) + with Not_unifiable -> + raise Failed (* new connection please *) + +let rec one_equation gprefix dlist delta_0_prefixes n = + match dlist with + [] -> ([],n) + | f::r -> + let fprefix = List.assoc f delta_0_prefixes in + let (sf1,sg) = shorten fprefix gprefix + and v_new = ("vnewq"^(string_of_int n)) in + let fnew = sf1 @ [v_new] in + let (rest_equations,new_n) = one_equation gprefix r delta_0_prefixes (n+1) in + (([],(fnew,sg))::rest_equations),new_n + +let rec make_domain_equations fo_pairs (gamma_0_prefixes,delta_0_prefixes) n = + match fo_pairs with + [] -> ([],n) + | (g,dlist)::r -> + let gprefix = List.assoc g gamma_0_prefixes in + let (gequations,max) = one_equation gprefix dlist delta_0_prefixes n in + let (rest_equations,new_max) = + make_domain_equations r (gamma_0_prefixes,delta_0_prefixes) max in + (gequations @ rest_equations),new_max + +(* type of one unifier: int * ((string * string list) list) *) +(* global failure: (0,[]) *) + +let stringunify ext_atom try_one eqlist fo_pairs logic orderingQ atom_rel qprefixes = + if logic = "C" then + ((0,[]),(0,[]),orderingQ) + else + let (qmax,equations) = eqlist + and us = ext_atom.aprefix + and ut = try_one.aprefix + and ns = ext_atom.aname + and nt = try_one.aname in + if qprefixes = ([],[]) then (* prop case *) + begin +(* print_endline "This is the prop case"; *) + let (new_sigma,new_eqlist) = Jtunify.do_stringunify us ut ns nt equations + (* prop unification only *) + in + (new_sigma,new_eqlist,[]) (* assume the empty reduction ordering during proof search *) + end + else + begin +(* print_endline "This is the FO case"; *) +(* fo_eqlist encodes the domain condition on J quantifier substitutions *) +(* Again, always computed for the whole substitution sigmaQ *) + let (fo_eqlist,new_max) = make_domain_equations fo_pairs qprefixes qmax in + begin +(* Format.open_box 0; + print_string "domain equations in"; + print_equations fo_eqlist; + print_string "domain equations out"; + Format.print_flush (); +*) + do_stringunify us ut ns nt equations fo_eqlist orderingQ atom_rel new_max + end + end + +(**************************************** add multiplicity *********************************) + +let rec subst_replace subst_list t = + match subst_list with + [] -> t + | (old_t,new_t)::r -> + let inter_term = var_subst t old_t "dummy" in +(*: print_string "("; + print_term stdout old_t; + print_string " --> "; + print_term stdout new_t; + print_string ")\n"; + print_term stdout t; + print_newline (); + print_term stdout inter_term; + print_newline (); :*) + let new_term = subst1 inter_term "dummy" new_t in +(*: print_term stdout new_term; + print_newline (); + mbreak "\n+++========----- ---------..........\n"; :*) + subst_replace r new_term + +let rename_pos x m = + let pref = String.get x 0 in + (Char.escaped pref)^(string_of_int m) + +let update_position position m replace_n subst_list mult = + let ({name=x; address=y; op=z; pol=p; pt=a; st=b; label=t}) = position in + let nx = rename_pos x m in + let nsubst_list = + if b=Gamma_0 then + let vx = mk_var_term (x^"_jprover") + and vnx = mk_var_term (nx^"_jprover") in + (vx,vnx)::subst_list + else + if b=Delta_0 then + let sx = mk_string_term jprover_op x + and snx = mk_string_term jprover_op nx in + (sx,snx)::subst_list + else + subst_list + in + let nt = subst_replace nsubst_list t in + let add_array = Array.of_list y in + let _ = (add_array.(replace_n) <- mult) in + let new_add = Array.to_list add_array in + ({name=nx; address=new_add; op=z; pol=p; pt=a; st=b; label=nt},m,nsubst_list) + +let rec append_orderings list_of_lists = + match list_of_lists with + [] -> + [] + | f::r -> + f @ (append_orderings r) + +let rec union_orderings first_orderings = + match first_orderings with + [] -> + StringSet.empty + | (pos,fset)::r -> + StringSet.union (StringSet.add pos fset) (union_orderings r) + +let rec select_orderings add_orderings = + match add_orderings with + [] -> [] + | f::r -> + (List.hd f)::select_orderings r + +let combine_ordering_list add_orderings pos_name = + let first_orderings = select_orderings add_orderings in + let pos_succs = union_orderings first_orderings in + let rest_orderings = append_orderings add_orderings in + (pos_name,pos_succs)::rest_orderings + +let rec copy_and_rename_tree last_tree replace_n pos_n mult subst_list = + + let rec rename_subtrees tree_list nposition s_pos_n nsubst_list = + match tree_list with + [] -> ([||],[],s_pos_n) + | f::r -> + let (f_subtree,f_ordering,f_pos_n) = + copy_and_rename_tree f replace_n s_pos_n mult nsubst_list in + let (r_subtrees,r_ordering_list,r_pos_n) = rename_subtrees r nposition f_pos_n nsubst_list in + ((Array.append [|f_subtree|] r_subtrees),(f_ordering::r_ordering_list),r_pos_n) + + in + match last_tree with + Empty -> raise (Invalid_argument "Jprover: copy tree") + | NodeAt(position) -> (* can never be a Gamma_0 position -> no replacements *) + let (nposition,npos_n,_) = update_position position (pos_n+1) replace_n subst_list mult in + ((NodeAt(nposition)),[(nposition.name,StringSet.empty)],npos_n) + | NodeA(position, suctrees) -> + let (nposition,npos_n,nsubst_list) = update_position position (pos_n+1) replace_n subst_list mult in + let (new_suctrees, new_ordering_list, new_pos_n) = + rename_subtrees (Array.to_list suctrees) nposition npos_n nsubst_list in + let new_ordering = combine_ordering_list new_ordering_list (nposition.name) in + ((NodeA(nposition,new_suctrees)),new_ordering,new_pos_n) + +(* we construct for each pos a list orderings representing and correspondning to the array of succtrees *) + +let rec add_multiplicity ftree pos_n mult logic = + let rec parse_subtrees tree_list s_pos_n = + match tree_list with + [] -> ([||],[],s_pos_n) + | f::r -> + let (f_subtree,f_ordering,f_pos_n) = add_multiplicity f s_pos_n mult logic in + let (r_subtrees,r_ordering_list,r_pos_n) = parse_subtrees r f_pos_n in + ((Array.append [|f_subtree|] r_subtrees),(f_ordering::r_ordering_list),r_pos_n) + + in + match ftree with + Empty -> raise (Invalid_argument "Jprover: add mult") + | NodeAt(pos) -> (ftree,[(pos.name,StringSet.empty)],pos_n) + | NodeA(pos,suctrees) -> + let (new_suctrees, new_ordering_list, new_pos_n) = parse_subtrees (Array.to_list suctrees) pos_n in + if (((pos.pt = Phi) & (((pos.op <> At) & (logic="J")) or ((pos.op = All) & (logic = "C")))) + (* no explicit atom-instances *) + or ((pos.pt = Gamma) & (pos.st <> Phi_0))) then (* universal quantifiers are copied *) + (* at their Phi positions *) + let replace_n = (List.length pos.address) (* points to the following argument in the array_of_address *) + and last = (Array.length new_suctrees) - 1 in (* array first element has index 0 *) + let last_tree = new_suctrees.(last) in + let (add_tree,add_ordering,final_pos_n) = + copy_and_rename_tree last_tree replace_n new_pos_n mult [] in + let final_suctrees = Array.append new_suctrees [|add_tree|] + and add_orderings = List.append new_ordering_list [add_ordering] in + let final_ordering = combine_ordering_list add_orderings (pos.name) in + ((NodeA(pos,final_suctrees)),final_ordering,final_pos_n) + else + let final_ordering = combine_ordering_list new_ordering_list (pos.name) in + ((NodeA(pos,new_suctrees)),final_ordering,new_pos_n) + + +(************** Path checker ****************************************************) + +let rec get_sets atom atom_sets = + match atom_sets with + [] -> raise (Invalid_argument "Jprover bug: atom not found") + | f::r -> + let (a,b,c) = f in + if atom = a then f + else + get_sets atom r + +let rec get_connections a alpha tabulist = + match alpha with + [] -> [] + | f::r -> + if (a.apredicate = f.apredicate) & (a.apol <> f.apol) & (not (List.mem f tabulist)) then + (a,f)::(get_connections a r tabulist) + else + (get_connections a r tabulist) + +let rec connections atom_rel tabulist = + match atom_rel with + [] -> [] + | f::r -> + let (a,alpha,beta) = f in + (get_connections a alpha tabulist) @ (connections r (a::tabulist)) + +let check_alpha_relation atom set atom_sets = + let (a,alpha,beta) = get_sets atom atom_sets in + AtomSet.subset set alpha + +let rec extset atom_sets path closed = + match atom_sets with + [] -> AtomSet.empty + | f::r -> + let (at,alpha,beta) = f in + if (AtomSet.subset path alpha) & (AtomSet.subset closed beta) then + AtomSet.add at (extset r path closed) + else + (extset r path closed) + +let rec check_ext_list ext_list fail_set atom_sets = (* fail_set consists of one atom only *) + match ext_list with + [] -> AtomSet.empty + | f::r -> + if (check_alpha_relation f fail_set atom_sets) then + AtomSet.add f (check_ext_list r fail_set atom_sets) + else + (check_ext_list r fail_set atom_sets) + +let fail_ext_set ext_atom ext_set atom_sets = + let ext_list = AtomSet.elements ext_set + and fail_set = AtomSet.add ext_atom AtomSet.empty in + check_ext_list ext_list fail_set atom_sets + +let rec ext_partners con path ext_atom (reduction_partners,extension_partners) atom_sets = + match con with + [] -> + (reduction_partners,extension_partners) + | f::r -> + let (a,b) = f in + if List.mem ext_atom [a;b] then + let ext_partner = + if ext_atom = a then b else a + in + let (new_red_partners,new_ext_partners) = +(* force reduction steps first *) + if (AtomSet.mem ext_partner path) then + ((AtomSet.add ext_partner reduction_partners),extension_partners) + else + if (check_alpha_relation ext_partner path atom_sets) then + (reduction_partners,(AtomSet.add ext_partner extension_partners)) + else + (reduction_partners,extension_partners) + in + ext_partners r path ext_atom (new_red_partners,new_ext_partners) atom_sets + else + ext_partners r path ext_atom (reduction_partners,extension_partners) atom_sets + +exception Failed_connections + +let path_checker atom_rel atom_sets qprefixes init_ordering logic = + + let con = connections atom_rel [] in +(*: print_endline ""; + print_endline ("number of connections: "^(string_of_int (List.length con))); + mbreak "#connec\n"; +:*) + let rec provable path closed (orderingQ,reduction_ordering) eqlist (sigmaQ,sigmaJ) = + + let rec check_connections (reduction_partners,extension_partners) ext_atom = + let try_one = + if reduction_partners = AtomSet.empty then + if extension_partners = AtomSet.empty then + raise Failed_connections + else + AtomSet.choose extension_partners + else + (* force reduction steps always first!! *) + AtomSet.choose reduction_partners + in +(* print_endline ("connection partner "^(try_one.aname)); *) +(* print_endline ("partner path "^(print_set path)); +*) + (try + let (new_sigmaQ,new_ordering_elements) = jqunify (ext_atom.alabel) (try_one.alabel) sigmaQ in +(* build the orderingQ incrementally from the new added substitution tau of new_sigmaQ *) + let (relate_pairs,new_orderingQ) = build_orderingQ new_ordering_elements orderingQ in +(* we make in incremental reflexivity test during the string unification *) + let (new_sigmaJ,new_eqlist,new_red_ordering) = +(* new_red_ordering = [] in propositional case *) + stringunify ext_atom try_one eqlist relate_pairs logic new_orderingQ atom_rel qprefixes + in +(* print_endline ("make reduction ordering "^((string_of_int (List.length new_ordering)))); *) + let new_closed = AtomSet.add ext_atom closed in + let ((next_orderingQ,next_red_ordering),next_eqlist,(next_sigmaQ,next_sigmaJ),subproof) = + if AtomSet.mem try_one path then + provable path new_closed (new_orderingQ,new_red_ordering) new_eqlist (new_sigmaQ,new_sigmaJ) + (* always use old first-order ordering for recursion *) + else + let new_path = AtomSet.add ext_atom path + and extension = AtomSet.add try_one AtomSet.empty in + let ((norderingQ,nredordering),neqlist,(nsigmaQ,nsigmaJ),p1) = + provable new_path extension (new_orderingQ,new_red_ordering) new_eqlist (new_sigmaQ,new_sigmaJ) in + let ((nnorderingQ,nnredordering),nneqlist,(nnsigmaQ,nnsigmaJ),p2) = + provable path new_closed (norderingQ,nredordering) neqlist (nsigmaQ,nsigmaJ) in + ((nnorderingQ,nnredordering),nneqlist,(nnsigmaQ,nnsigmaJ),(p1 @ p2)) + (* first the extension subgoals = depth first; then other subgoals in same clause *) + in + ((next_orderingQ,next_red_ordering),next_eqlist,(next_sigmaQ,next_sigmaJ),(((ext_atom.aname),(try_one.aname))::subproof)) + with Failed -> +(* print_endline ("new connection for "^(ext_atom.aname)); *) +(* print_endline ("Failed"); *) + check_connections ((AtomSet.remove try_one reduction_partners), + (AtomSet.remove try_one extension_partners) + ) ext_atom + ) + + in + let rec check_extension extset = + if extset = AtomSet.empty then + raise Failed (* go directly to a new entry connection *) + else + let select_one = AtomSet.choose extset in +(* print_endline ("extension literal "^(select_one.aname)); *) +(* print_endline ("extension path "^(print_set path));*) + let (reduction_partners,extension_partners) = + ext_partners con path select_one (AtomSet.empty,AtomSet.empty) atom_sets in + (try + check_connections (reduction_partners,extension_partners) select_one + with Failed_connections -> +(* print_endline ("no connections for subgoal "^(select_one.aname)); *) +(* print_endline ("Failed_connections"); *) + let fail_ext_set = fail_ext_set select_one extset atom_sets in + check_extension fail_ext_set + ) + + in + let extset = extset atom_sets path closed in + if extset = AtomSet.empty then + ((orderingQ,reduction_ordering),eqlist,(sigmaQ,sigmaJ),[]) + else + check_extension extset + in + if qprefixes = ([],[]) then + begin +(* print_endline "!!!!!!!!!!! prop prover !!!!!!!!!!!!!!!!!!"; *) +(* in the propositional case, the reduction ordering will be computed AFTER proof search *) + let (_,eqlist,(_,(n,substJ)),ext_proof) = + provable AtomSet.empty AtomSet.empty ([],[]) (1,[]) ([],(1,[])) in + let orderingJ = build_orderingJ_list substJ init_ordering atom_rel in + ((init_ordering,orderingJ),eqlist,([],(n,substJ)),ext_proof) + end + else + provable AtomSet.empty AtomSet.empty (init_ordering,[]) (1,[]) ([],(1,[])) + +(*************************** prepare and init prover *******************************************************) + +let rec list_to_set list = + match list with + [] -> AtomSet.empty + | f::r -> + let rest_set = list_to_set r in + AtomSet.add f rest_set + +let rec make_atom_sets atom_rel = + match atom_rel with + [] -> [] + | f::r -> + let (a,alpha,beta) = f in + (a,(list_to_set alpha),(list_to_set beta))::(make_atom_sets r) + +let rec predecessor address_1 address_2 ftree = + match ftree with + Empty -> PNull (* should not occur since every pair of atoms have a common predecessor *) + | NodeAt(position) -> PNull (* should not occur as above *) + | NodeA(position,suctrees) -> + match address_1,address_2 with + [],_ -> raise (Invalid_argument "Jprover: predecessors left") + | _,[] -> raise (Invalid_argument "Jprover: predecessors right") + | (f1::r1),(f2::r2) -> + if f1 = f2 then + predecessor r1 r2 (suctrees.(f1-1)) + else + position.pt + +let rec compute_sets element ftree alist = + match alist with + [] -> [],[] + | first::rest -> + if first = element then + compute_sets element ftree rest (* element is neithes alpha- nor beta-related to itself*) + else + let (alpha_rest,beta_rest) = compute_sets element ftree rest in + if predecessor (element.aaddress) (first.aaddress) ftree = Beta then + (alpha_rest,(first::beta_rest)) + else + ((first::alpha_rest),beta_rest) + +let rec compute_atomlist_relations worklist ftree alist = (* last version of alist for total comparison *) + let rec compute_atom_relations element ftree alist = + let alpha_set,beta_set = compute_sets element ftree alist in + (element,alpha_set,beta_set) + in + match worklist with + [] -> [] + | first::rest -> + let first_relations = compute_atom_relations first ftree alist in + first_relations::(compute_atomlist_relations rest ftree alist) + +let atom_record position prefix = + let aname = (position.name) in + let aprefix = (List.append prefix [aname]) in (* atom position is last element in prefix *) + let aop = (dest_term position.label).term_op in + ({aname=aname; aaddress=(position.address); aprefix=aprefix; apredicate=aop; + apol=(position.pol); ast=(position.st); alabel=(position.label)}) + +let rec select_atoms_treelist treelist prefix = + let rec select_atoms ftree prefix = + match ftree with + Empty -> [],[],[] + | NodeAt(position) -> + [(atom_record position prefix)],[],[] + | NodeA(position,suctrees) -> + let treelist = Array.to_list suctrees in + let new_prefix = + let prefix_element = + if List.mem (position.st) [Psi_0;Phi_0] then + [(position.name)] + else + [] + in + (List.append prefix prefix_element) + in + let (gamma_0_element,delta_0_element) = + if position.st = Gamma_0 then + begin +(* Format.open_box 0; + print_endline "gamma_0 prefixes "; + print_string (position.name^" :"); + print_stringlist prefix; + print_endline " "; + Format.force_newline (); + Format.print_flush (); +*) + [(position.name,prefix)],[] + end + else + if position.st = Delta_0 then + begin +(* Format.open_box 0; + print_endline "delta_0 prefixes "; + print_string (position.name^" :"); + print_stringlist prefix; + print_endline " "; + Format.force_newline (); + Format.print_flush (); +*) + [],[(position.name,prefix)] + end + else + [],[] + in + let (rest_alist,rest_gamma_0_prefixes,rest_delta_0_prefixes) = + select_atoms_treelist treelist new_prefix in + (rest_alist,(rest_gamma_0_prefixes @ gamma_0_element), + (rest_delta_0_prefixes @ delta_0_element)) + + in + match treelist with + [] -> [],[],[] + | first::rest -> + let (first_alist,first_gprefixes,first_dprefixes) = select_atoms first prefix + and (rest_alist,rest_gprefixes,rest_dprefixes) = select_atoms_treelist rest prefix in + ((first_alist @ rest_alist),(first_gprefixes @ rest_gprefixes), + (first_dprefixes @ rest_dprefixes)) + +let prepare_prover ftree = + let alist,gamma_0_prefixes,delta_0_prefixes = select_atoms_treelist [ftree] [] in + let atom_rel = compute_atomlist_relations alist ftree alist in + (atom_rel,(gamma_0_prefixes,delta_0_prefixes)) + +(* ************************ Build intial formula tree and relations *********************************** *) +(* Building a formula tree and the tree ordering from the input formula, i.e. OCaml term *) + +let make_position_name stype pos_n = + let prefix = + if List.mem stype [Phi_0;Gamma_0] + then "v" + else + if List.mem stype [Psi_0;Delta_0] + then "c" + else + "a" + in + prefix^(string_of_int pos_n) + +let dual_pol pol = + if pol = O then I else O + +let check_subst_term (variable,old_term) pos_name stype = + if (List.mem stype [Gamma_0;Delta_0]) then + let new_variable = + if stype = Gamma_0 then (mk_var_term (pos_name^"_jprover")) + else + (mk_string_term jprover_op pos_name) + in + (subst1 old_term variable new_variable) (* replace variable (non-empty) in t by pos_name *) + (* pos_name is either a variable term or a constant, f.i. a string term *) + (* !!! check unification module how handling eingenvariables as constants !!! *) + else + old_term + +let rec build_ftree (variable,old_term) pol stype address pos_n = + let pos_name = make_position_name stype pos_n in + let term = check_subst_term (variable,old_term) pos_name stype in + if JLogic.is_and_term term then + let s,t = JLogic.dest_and term in + let ptype,stype_1,stype_2 = + if pol = O + then Beta,Beta_1,Beta_2 + else + Alpha,Alpha_1,Alpha_2 + in + let position = {name=pos_name; address=address; op=And; pol=pol; pt=ptype; st=stype; label=term} in + let subtree_left,ordering_left,posn_left = build_ftree ("",s) pol stype_1 (address@[1]) (pos_n+1) in + let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[2]) + (posn_left+1) in + let (succ_left,whole_left) = List.hd ordering_left + and (succ_right,whole_right) = List.hd ordering_right in + let pos_succs = + (StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right))) + in + (NodeA(position,[|subtree_left;subtree_right|]), + ((position.name,pos_succs)::(ordering_left @ ordering_right)), + posn_right + ) + else + if JLogic.is_or_term term then + let s,t = JLogic.dest_or term in + let ptype,stype_1,stype_2 = + if pol = O + then Alpha,Alpha_1,Alpha_2 + else + Beta,Beta_1,Beta_2 + in + let position = {name=pos_name; address=address; op=Or; pol=pol; pt=ptype; st=stype; label=term} in + let subtree_left,ordering_left,posn_left = build_ftree ("",s) pol stype_1 (address@[1]) (pos_n+1) in + let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[2]) + (posn_left+1) in + let (succ_left,whole_left) = List.hd ordering_left + and (succ_right,whole_right) = List.hd ordering_right in + let pos_succs = + StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right)) in + (NodeA(position,[|subtree_left;subtree_right|]), + ((position.name),pos_succs) :: (ordering_left @ ordering_right), + posn_right + ) + else + if JLogic.is_implies_term term then + let s,t = JLogic.dest_implies term in + let ptype_0,stype_0,ptype,stype_1,stype_2 = + if pol = O + then Psi,Psi_0,Alpha,Alpha_1,Alpha_2 + else + Phi,Phi_0,Beta,Beta_1,Beta_2 + in + let pos2_name = make_position_name stype_0 (pos_n+1) in + let sposition = {name=pos_name; address=address; op=Imp; pol=pol; pt=ptype_0; st=stype; label=term} + and position = {name=pos2_name; address=address@[1]; op=Imp; pol=pol; pt=ptype; st=stype_0; label=term} in + let subtree_left,ordering_left,posn_left = build_ftree ("",s) (dual_pol pol) stype_1 (address@[1;1]) + (pos_n+2) in + let subtree_right,ordering_right,posn_right = build_ftree ("",t) pol stype_2 (address@[1;2]) + (posn_left+1) in + let (succ_left,whole_left) = List.hd ordering_left + and (succ_right,whole_right) = List.hd ordering_right in + let pos_succs = + StringSet.add succ_left (StringSet.add succ_right (StringSet.union whole_left whole_right)) in + let pos_ordering = (position.name,pos_succs) :: (ordering_left @ ordering_right) in + (NodeA(sposition,[|NodeA(position,[|subtree_left;subtree_right|])|]), + ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering), + posn_right + ) + else + if JLogic.is_not_term term then + let s = JLogic.dest_not term in + let ptype_0,stype_0,ptype,stype_1= + if pol = O + then Psi,Psi_0,Alpha,Alpha_1 + else + Phi,Phi_0,Alpha,Alpha_1 + in + let pos2_name = make_position_name stype_0 (pos_n+1) in + let sposition = {name=pos_name; address=address; op=Neg; pol=pol; pt=ptype_0; st=stype; label=term} + and position = {name=pos2_name; address=address@[1]; op=Neg; pol=pol; pt=ptype; st=stype_0; label=term} in + let subtree_left,ordering_left,posn_left = build_ftree ("",s) (dual_pol pol) stype_1 (address@[1;1]) + (pos_n+2) in + let (succ_left,whole_left) = List.hd ordering_left in + let pos_succs = + StringSet.add succ_left whole_left in + let pos_ordering = (position.name,pos_succs) :: ordering_left in + (NodeA(sposition,[|NodeA(position,[| subtree_left|])|]), + ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering), + posn_left + ) + else + if JLogic.is_exists_term term then + let v,s,t = JLogic.dest_exists term in (* s is type of v and will be supressed here *) + let ptype,stype_1 = + if pol = O + then Gamma,Gamma_0 + else + Delta,Delta_0 + in + let position = {name=pos_name; address=address; op=Ex; pol=pol; pt=ptype; st=stype; label=term} in + let subtree_left,ordering_left,posn_left = build_ftree (v,t) pol stype_1 (address@[1]) (pos_n+1) in + let (succ_left,whole_left) = List.hd ordering_left in + let pos_succs = + StringSet.add succ_left whole_left in + (NodeA(position,[|subtree_left|]), + ((position.name,pos_succs) :: ordering_left), + posn_left + ) + else + if JLogic.is_all_term term then + let v,s,t = JLogic.dest_all term in + (* s is type of v and will be supressed here *) + let ptype_0,stype_0,ptype,stype_1= + if pol = O + then Psi,Psi_0,Delta,Delta_0 + else + Phi,Phi_0,Gamma,Gamma_0 + in + let pos2_name = make_position_name stype_0 (pos_n+1) in + let sposition = {name=pos_name; address=address; op=All; pol=pol; pt=ptype_0; st=stype; label=term} + and position = {name=pos2_name; address=address@[1]; op=All; pol=pol; pt=ptype; st=stype_0; label=term} in + let subtree_left,ordering_left,posn_left = build_ftree (v,t) pol stype_1 (address@[1;1]) + (pos_n+2) in + let (succ_left,whole_left) = List.hd ordering_left in + let pos_succs = + StringSet.add succ_left whole_left in + let pos_ordering = (position.name,pos_succs) :: ordering_left in + (NodeA(sposition,[|NodeA(position,[|subtree_left|])|]), + ((sposition.name,(StringSet.add position.name pos_succs))::pos_ordering), + posn_left + ) + else (* finally, term is atomic *) + let ptype_0,stype_0 = + if pol = O + then Psi,Psi_0 + else + Phi,Phi_0 + in + let pos2_name = make_position_name stype_0 (pos_n+1) in + let sposition = {name=pos_name; address=address; op=At; pol=pol; pt=ptype_0; st=stype; label=term} + and position = {name=pos2_name; address=address@[1]; op=At; pol=pol; pt=PNull; st=stype_0; label=term} in + (NodeA(sposition,[|NodeAt(position)|]), + [(sposition.name,(StringSet.add position.name StringSet.empty));(position.name,StringSet.empty)], + pos_n+1 + ) + +let rec construct_ftree termlist treelist orderinglist pos_n goal = + match termlist with + [] -> + let new_root = {name="w"; address=[]; op=Null; pol=O; pt=Psi; st=PNull_0; label=goal} + and treearray = Array.of_list treelist in + NodeA(new_root,treearray),(("w",(union_orderings orderinglist))::orderinglist),pos_n + | ft::rest_terms -> + let next_address = [((List.length treelist)+1)] + and next_pol,next_goal = + if rest_terms = [] then + O,ft (* construct tree for the conclusion *) + else + I,goal + in + let new_tree,new_ordering,new_pos_n = + build_ftree ("",ft) next_pol Alpha_1 next_address (pos_n+1) in + construct_ftree rest_terms (treelist @ [new_tree]) + (orderinglist @ new_ordering) new_pos_n next_goal + +(*************************** Main LOOP ************************************) +let unprovable = RefineError ("Jprover", StringError "formula is not provable") +let mult_limit_exn = RefineError ("Jprover", StringError "multiplicity limit reached") +let coq_exn = RefineError ("Jprover", StringError "interface for coq: error on ") + +let init_prover ftree = + let atom_relation,qprefixes = prepare_prover ftree in +(* print_atom_info atom_relation; *) (* apple *) + let atom_sets = make_atom_sets atom_relation in + (atom_relation,atom_sets,qprefixes) + + +let rec try_multiplicity mult_limit ftree ordering pos_n mult logic = + try + let (atom_relation,atom_sets,qprefixes) = init_prover ftree in + let ((orderingQ,red_ordering),eqlist,unifier,ext_proof) = + path_checker atom_relation atom_sets qprefixes ordering logic in + (ftree,red_ordering,eqlist,unifier,ext_proof) (* orderingQ is not needed as return value *) + with Failed -> + match mult_limit with + Some m when m == mult -> + raise mult_limit_exn + | _ -> + let new_mult = mult+1 in + begin + Pp.msgnl (Pp.(++) (Pp.str "Multiplicity Fail: Trying new multiplicity ") + (Pp.int new_mult)); +(* + Format.open_box 0; + Format.force_newline (); + Format.print_string "Multiplicity Fail: "; + Format.print_string ("Try new multiplicity "^(string_of_int new_mult)); + Format.force_newline (); + Format.print_flush (); +*) + let (new_ftree,new_ordering,new_pos_n) = + add_multiplicity ftree pos_n new_mult logic in + if (new_ftree = ftree) then + raise unprovable + else +(* print_formula_info new_ftree new_ordering new_pos_n; *) (* apple *) + try_multiplicity mult_limit new_ftree new_ordering new_pos_n new_mult logic + end + +let prove mult_limit termlist logic = + let (ftree,ordering,pos_n) = construct_ftree termlist [] [] 0 (mk_var_term "dummy") in +(* pos_n = number of positions without new root "w" *) +(* print_formula_info ftree ordering pos_n; *) (* apple *) + try_multiplicity mult_limit ftree ordering pos_n 1 logic + +(********** first-order type theory interface *******************) + +let rec renam_free_vars termlist = + match termlist + with [] -> [],[] + | f::r -> + let var_names = free_vars_list f in + let string_terms = + List.map (fun x -> (mk_string_term free_var_op x)) var_names + in + let mapping = List.combine var_names string_terms + and new_f = subst f var_names string_terms in + let (rest_mapping,rest_renamed) = renam_free_vars r in + let unique_mapping = remove_dups_list (mapping @ rest_mapping) in + (unique_mapping,(new_f::rest_renamed)) + +let rec apply_var_subst term var_subst_list = + match var_subst_list with + [] -> term + | (v,t)::r -> + let next_term = var_subst term t v in + apply_var_subst next_term r + +let rec make_equal_list n list_object = + if n = 0 then + [] + else + list_object::(make_equal_list (n-1) list_object) + +let rec create_output rule_list input_map = + match rule_list with + [] -> JLogic.empty_inf + | f::r -> + let (pos,(rule,term1,term2)) = f in + let delta1_names = collect_delta_terms [term1] + and delta2_names = collect_delta_terms [term2] in + let unique_deltas = remove_dups_list (delta1_names @ delta2_names) in + let delta_terms = + List.map (fun x -> (mk_string_term jprover_op x)) unique_deltas in + let delta_vars = List.map (fun x -> (x^"_jprover")) unique_deltas in + let delta_map = List.combine delta_vars delta_terms in + let var_mapping = (input_map @ delta_map) in + let frees1 = free_vars_list term1 + and frees2 = free_vars_list term2 in + let unique_object = mk_var_term "v0_jprover" in + let unique_list1 = make_equal_list (List.length frees1) unique_object + and unique_list2 = make_equal_list (List.length frees2) unique_object + in + let next_term1 = subst term1 frees1 unique_list1 + and next_term2 = subst term2 frees2 unique_list2 in + let new_term1 = apply_var_subst next_term1 var_mapping + and new_term2 = apply_var_subst next_term2 var_mapping + and (a,b) = pos + in +(*: print_string (a^"+++"^b^"\n"); :*) + +(* kick away the first argument, the position *) + (JLogic.append_inf (create_output r input_map) (b,new_term1) (a,new_term2) rule) + +let rec make_test_interface rule_list input_map = + match rule_list with + [] -> [] + | f::r -> + let (pos,(rule,term1,term2)) = f in + let delta1_names = collect_delta_terms [term1] + and delta2_names = collect_delta_terms [term2] in + let unique_deltas = remove_dups_list (delta1_names @ delta2_names) in + let delta_terms = + List.map (fun x -> (mk_string_term jprover_op x)) unique_deltas in + let delta_vars = List.map (fun x -> (x^"_jprover")) unique_deltas in + let delta_map = List.combine delta_vars delta_terms in + let var_mapping = (input_map @ delta_map) in + let frees1 = free_vars_list term1 + and frees2 = free_vars_list term2 in + let unique_object = mk_var_term "v0_jprover" in + let unique_list1 = make_equal_list (List.length frees1) unique_object + and unique_list2 = make_equal_list (List.length frees2) unique_object + in + begin +(* + print_endline ""; + print_endline ""; + print_stringlist frees1; + print_endline ""; + print_stringlist frees2; + print_endline ""; + print_endline ""; +*) + let next_term1 = subst term1 frees1 unique_list1 + and next_term2 = subst term2 frees2 unique_list2 in + let new_term1 = apply_var_subst next_term1 var_mapping + and new_term2 = apply_var_subst next_term2 var_mapping + in + (pos,(rule,new_term1,new_term2))::(make_test_interface r input_map) + end + +(**************************************************************) + +(*: modified for Coq :*) + +let decomp_pos pos = + let {name=n; address=a; label=l} = pos in + (n,(a,l)) + +let rec build_formula_id ftree = + let rec build_fid_list = function + [] -> [] + | t::rest -> (build_formula_id t)@(build_fid_list rest) + in + match ftree with + Empty -> [] + | NodeAt(position) -> + [decomp_pos position] + | NodeA(position,subtrees) -> + let tree_list = Array.to_list subtrees in + (decomp_pos position)::(build_fid_list tree_list) + +let rec encode1 = function (* normal *) + [] -> "" + | i::r -> "_"^(string_of_int i)^(encode1 r) + +let rec encode2 = function (* move up *) + [i] -> "" + | i::r -> "_"^(string_of_int i)^(encode2 r) + | _ -> raise coq_exn + +let rec encode3 = function (* move down *) + [] -> "_1" + | i::r -> "_"^(string_of_int i)^(encode3 r) + +let lookup_coq str map = + try + let (il,t) = List.assoc str map in + il + with Not_found -> raise coq_exn + +let create_coq_input inf map = + let rec rec_coq_part inf = + match inf with + [] -> [] + | (rule, (s1, t1), ((s2, t2) as k))::r -> + begin + match rule with + Andl | Andr | Orl | Orr1 | Orr2 -> + (rule, (encode1 (lookup_coq s1 map), t1), k)::(rec_coq_part r) + | Impr | Impl | Negr | Negl | Ax -> + (rule, (encode2 (lookup_coq s1 map), t1), k)::(rec_coq_part r) + | Exr -> + (rule, (encode1 (lookup_coq s1 map), t1), + (encode1 (lookup_coq s2 map), t2))::(rec_coq_part r) + | Exl -> + (rule, (encode1 (lookup_coq s1 map), t1), + (encode3 (lookup_coq s1 map), t2))::(rec_coq_part r) + | Allr | Alll -> + (rule, (encode2 (lookup_coq s1 map), t1), + (* (s2, t2))::(rec_coq_part r) *) + (encode3 (lookup_coq s1 map), t2))::(rec_coq_part r) + | _ -> raise coq_exn + end + in + rec_coq_part inf + +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 *) + (* we can transform the eigenvariables AFTER proof reconstruction since *) + (* new delta_0 constants may have been constructed during rule permutation *) + (* from the LJmc to the LJ proof *) + create_coq_input (create_output sequent_proof input_map) idl + +(*: end of coq modification :*) + +let prover mult_limit hyps concl = gen_prover mult_limit "J" "LJ" hyps [concl] + +(************* test with propositional proof reconstruction ************) + +let rec count_axioms seq_list = + match seq_list with + [] -> 0 + | f::r -> + let (rule,_,_) = f in + if rule = Ax then + 1 + count_axioms r + else + count_axioms r + +let do_prove mult_limit termlist logic calculus = + try begin + let (input_map,renamed_termlist) = renam_free_vars termlist in + let (ftree,red_ordering,eqlist,(sigmaQ,sigmaJ),ext_proof) = prove mult_limit renamed_termlist logic in + Format.open_box 0; + Format.force_newline (); + Format.force_newline (); + Format.print_string "Extension proof ready"; + Format.force_newline (); + Format.force_newline (); + Format.print_string ("Length of Extension proof: "^((string_of_int (List.length ext_proof)))^ + " Axioms"); + Format.force_newline (); + Format.force_newline (); + print_endline "Extension proof:"; + Format.open_box 0; + print_pairlist ext_proof; (* print list of type (string * string) list *) + Format.force_newline (); + Format.force_newline (); + Format.force_newline (); + Format.print_flush (); + Format.print_flush (); + Format.open_box 0; + print_ordering red_ordering; + Format.print_flush (); + Format.open_box 0; + Format.force_newline (); +(* ----------------------------------------------- *) + Format.open_box 0; + print_tunify sigmaJ; + Format.print_flush (); + print_endline ""; + print_endline ""; + print_sigmaQ sigmaQ; + print_endline ""; + print_endline ""; + Format.open_box 0; + let (qmax,equations) = eqlist in + print_endline ("number of quantifier domains : "^(string_of_int (qmax-1))); + print_endline ""; + print_equations equations; + Format.print_flush (); + print_endline ""; + print_endline ""; + print_endline ("Length of equations : "^((string_of_int (List.length equations)))); + print_endline ""; + print_endline ""; +(* --------------------------------------------------------- *) + Format.print_string "Break ... "; + print_endline ""; + print_endline ""; + Format.print_flush (); +(*: let _ = input_char stdin in :*) + let reconstr_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in + let sequent_proof = make_test_interface reconstr_proof input_map in + Format.open_box 0; + Format.force_newline (); + Format.force_newline (); + Format.print_string "Sequent proof ready"; + Format.force_newline (); + Format.force_newline (); + Format.print_flush (); + let (ptree,count_ax) = bproof sequent_proof in + Format.open_box 0; + Format.print_string ("Length of sequent proof: "^((string_of_int count_ax))^" Axioms"); + Format.force_newline (); + Format.force_newline (); + Format.force_newline (); + Format.force_newline (); + Format.print_flush (); + tt ptree; (*: print proof tree :*) + Format.print_flush (); + print_endline ""; + print_endline "" + end with exn -> begin + print_endline "Jprover got an exception:"; + print_endline (Printexc.to_string exn) + end + +let test concl logic calculus = (* calculus should be LJmc or LJ for J, and LK for C *) + do_prove None [concl] logic calculus + +(* for sequents *) + +let seqtest list_term logic calculus = + let bterms = (dest_term list_term).term_terms in + let termlist = collect_subterms bterms in + do_prove None termlist logic calculus + +(*****************************************************************) + +end (* of struct *) diff --git a/contrib/jprover/jall.mli b/contrib/jprover/jall.mli new file mode 100644 index 00000000..1811fe59 --- /dev/null +++ b/contrib/jprover/jall.mli @@ -0,0 +1,339 @@ +(* JProver provides an efficient refiner for first-order classical + and first-order intuitionistic logic. It consists of two main parts: + a proof search procedure and a proof reconstruction procedure. + + + Proof Search + ============ + + The proof search process is based on a matrix-based (connection-based) + proof procedure, i.e.~a non-normalform extension procedure. + Besides the well-known quantifier substitution (Martelli Montanari), + a special string unifiation procedure is used in order to + efficiently compute intuitionistic rule non-permutabilities. + + + Proof Reconstruction + ==================== + + The proof reconstruction process converts machine-generated matrix proofs + into cut-free Gentzen-style sequent proofs. For classcal logic "C", + Gentzen's sequent calculus "LK" is used as target calculus. + For intuitionistic logic "J", either Gentzen's single-conclusioned sequent + calculus "LJ" or Fitting's multiply-conclusioned sequent calculus "LJmc" + can be used. All sequent claculi are implemented in a set-based formulation + in order to avoid structural rules. + + The proof reconstruction procedure combines three main procedures, depending + on the selected logics and sequent calculi. It consists of: + + 1) A uniform traversal algorithm for all logics and target sequent calculi. + This procedure converts classical (intuitionistic) matrix proofs + directly into cut-free "LK" ("LJmc" or "LJ") sequent proofs. + However, the direct construction of "LJ" proofs may fail in some cases + due to proof theoretical reasons. + + 2) A complete redundancy deletion algorithm, which integrates additional + knowledge from the proof search process into the reconstruction process. + This procedure is called by the traversal algorithms in order to avoid + search and deadlocks during proof reconstruciton. + + 3) A permutation-based proof transformation for converting "LJmc" proofs + into "LJ" proofs. + This procedure is called by-need, whenever the direct reconstruction + of "LJ" proofs from matrix proofs fails. + + + + + Literature: + ========== + + JProver system description was presented at CADE 2001: + @InProceedings{inp:Schmitt+01a, + author = "Stephan Schmitt and Lori Lorigo and Christoph Kreitz and + Alexey Nogin", + title = "{{\sf JProver}}: Integrating Connection-based Theorem + Proving into Interactive Proof Assistants", + booktitle = "International Joint Conference on Automated Reasoning", + year = "2001", + editor = "R. Gore and A. Leitsch and T. Nipkow", + volume = 2083, + series = LNAI, + pages = "421--426", + publisher = SPRINGER, + language = English, + where = OWN, + } + + The implementation of JProver is based on the following publications: + + + + Slides of PRL-seminar talks: + --------------------------- + + An Efficient Refiner for First-order Intuitionistic Logic + + http://www.cs.cornell.edu/Nuprl/PRLSeminar/PRLSeminar99_00/schmitt/feb28.html + + + An Efficient Refiner for First-order Intuitionistic Logic (Part II) + + http://www.cs.cornell.edu/Nuprl/PRLSeminar/PRLSeminar99_00/schmitt/may22.html + + + + Proof search: + ------------- + + +[1] + @InProceedings{inp:OttenKreitz96b, + author = "J.~Otten and C.~Kreitz", + title = "A uniform proof procedure for classical and + non-classical logics", + booktitle = "Proceedings of the 20$^{th}$ German Annual Conference on + Artificial Intelligence", + year = "1996", + editor = "G.~G{\"o}rz and S.~H{\"o}lldobler", + number = "1137", + series = LNAI, + pages = "307--319", + publisher = SPRINGER + } + + +[2] + @Article{ar:KreitzOtten99, + author = "C.~Kreitz and J.~Otten", + title = "Connection-based theorem proving in classical and + non-classical logics", + journal = "Journal for Universal Computer Science, + Special Issue on Integration of Deductive Systems", + year = "1999", + volume = "5", + number = "3", + pages = "88--112" + } + + + + + Special string unifiation procedure: + ------------------------------------ + + +[3] + @InProceedings{inp:OttenKreitz96a, + author = "J.~Otten and C.~Kreitz", + titl = "T-string-unification: unifying prefixes in + non-classical proof methods", + booktitle = "Proceedings of the 5$^{th}$ Workshop on Theorem Proving + with Analytic Tableaux and Related Methods", + year = 1996, + editor = "U.~Moscato", + number = "1071", + series = LNAI, + pages = "244--260", + publisher = SPRINGER, + month = "May " + } + + + + Proof reconstruction: Uniform traversal algorithm + ------------------------------------------------- + + +[4] + @InProceedings{inp:SchmittKreitz96a, + author = "S.~Schmitt and C.~Kreitz", + title = "Converting non-classical matrix proofs into + sequent-style systems", + booktitle = "Proceedings of the 13$^t{}^h$ Conference on + Automated Deduction", + editor = M.~A.~McRobbie and J.~K.~Slaney", + number = "1104", + series = LNAI, + pages = "418--432", + year = "1996", + publisher = SPRINGER, + month = "July/August" + } + + +[5] + @Article{ar:KreitzSchmitt00, + author = "C.~Kreitz and S.~Schmitt", + title = "A uniform procedure for converting matrix proofs + into sequent-style systems", + journal = "Journal of Information and Computation", + year = "2000", + note = "(to appear)" + } + + +[6] + @Book{bo:Schmitt00, + author = "S.~Schmitt", + title = "Proof reconstruction in classical and non-classical logics", + year = "2000", + publisher = "Infix", + series = "Dissertationen zur K{\"u}nstlichen Intelleigenz", + number = "(to appear)", + note = "(Ph.{D}.~{T}hesis, Technische Universit{\"a}t Darmstadt, + FG Intellektik, Germany, 1999)" + } + + The traversal algorithm is presented in the Chapters 2 and 3 of my thesis. + The thesis will be made available for the Department through Christoph Kreitz, + Upson 4159, kreitz@cs.cornell.edu + + + + + Proof reconstruction: Complete redundancy deletion + -------------------------------------------------- + + +[7] + @Book{bo:Schmitt00, + author = "S.~Schmitt", + title = "Proof reconstruction in classical and non-classical logics", + year = "2000", + publisher = "Infix", + series = "Dissertationen zur K{\"u}nstlichen Intelleigenz", + note = "(Ph.{D}.~{T}hesis, Technische Universit{\"a}t Darmstadt, + FG Intellektik, Germany, 1999)" + note = "(to appear)", + + } + + The integration of proof knowledge and complete redundancy deletion is presented + in Chapter 4 of my thesis. + + +[8] + @InProceedings{inp:Schmitt00, + author = "S.~Schmitt", + title = "A tableau-like representation framework for efficient + proof reconstruction", + booktitle = "Proceedings of the International Conference on Theorem Proving + with Analytic Tableaux and Related Methods", + year = "2000", + series = LNAI, + publisher = SPRINGER, + month = "June" + note = "(to appear)", + } + + + + + Proof Reconstruction: Permutation-based poof transformations "LJ" -> "LJmc" + --------------------------------------------------------------------------- + + +[9] + @InProceedings{inp:EglySchmitt98, + author = "U.~Egly and S.~Schmitt", + title = "Intuitionistic proof transformations and their + application to constructive program synthesis", + booktitle = "Proceedings of the 4$^{th}$ International Conference + on Artificial Intelligence and Symbolic Computation", + year = "1998", + editor = "J.~Calmet and J.~Plaza", + number = "1476", + series = LNAI, + pages = "132--144", + publisher = SPRINGER, + month = "September" + } + + +[10] + @Article{ar:EglySchmitt99, + author = "U.~Egly and S.~Schmitt", + title = "On intuitionistic proof transformations, their + complexity, and application to constructive program synthesis", + journal = "Fundamenta Informaticae, + Special Issue: Symbolic Computation and Artificial Intelligence", + year = "1999", + volume = "39", + number = "1--2", + pages = "59--83" + } +*) + +(*: open Refiner.Refiner +open Refiner.Refiner.Term +open Refiner.Refiner.TermType +open Refiner.Refiner.TermSubst + +open Jlogic_sig +:*) + +open Jterm +open Opname +open Jlogic + +val ruletable : rule -> string + +module JProver(JLogic: JLogicSig) : +sig + val test : term -> string -> string -> unit + + (* Procedure call: test conclusion logic calculus + + test is applied to a first-order formula. The output is some + formatted sequent proof for test / debugging purposes. + + The arguments for test are as follows: + + logic = "C"|"J" + i.e. first-order classical logic or first-order intuitionistic logic + + calculus = "LK"|"LJ"|"LJmc" + i.e. "LK" for classical logic "C", and either Gentzen's single conclusioned + calculus "LJ" or Fittings multiply-conclusioned calculus "LJmc" for + intuitionistic logic "J". + + term = first-order formula representing the proof goal. + *) + + + + val seqtest : term -> string -> string -> unit + + (* seqtest procedure is for debugging purposes only *) + + + val gen_prover : int option -> string -> string -> term list -> term list -> JLogic.inference + + (* Procedure call: gen_prover mult_limit logic calculus hypothesis conclusion + + The arguments for gen_prover are as follows: + + mult_limit - maximal multiplicity to try, None for unlimited + + logic = same as in test + + calculus = same as in test + + hypothesis = list of first-order terms forming the antecedent of the input sequent + + conclusion = list of first-order terms forming the succedent of the input sequent + This list should contain only one element if logic = "J" and calculus = "LJ". + *) + + + val prover : int option -> term list -> term -> JLogic.inference + + (* Procedure call: gen_prover mult_limit "J" "LJ" hyps [concl] + + prover provides the first-order refiner for NuPRL, using + a single concluisoned succedent [concl] in the sequent. + The result is a sequent proof in the single-conclusioned calculus "LJ". + *) +end diff --git a/contrib/jprover/jlogic.ml b/contrib/jprover/jlogic.ml new file mode 100644 index 00000000..c074e93e --- /dev/null +++ b/contrib/jprover/jlogic.ml @@ -0,0 +1,106 @@ +open Opname +open Jterm + +type rule = + | Ax | Andr | Andl | Orr | Orr1 | Orr2 | Orl | Impr | Impl | Negr | Negl + | Allr | Alll| Exr | Exl | Fail | Falsel | Truer + +let ruletable = function + | Fail -> "Fail" + | Ax -> "Ax" + | Negl -> "Negl" + | Negr -> "Negr" + | Andl -> "Andl" + | Andr -> "Andr" + | Orl -> "Orl" + | Orr -> "Orr" + | Orr1 -> "Orr1" + | Orr2 -> "Orr2" + | Impl -> "Impl" + | Impr -> "Impr" + | Exl -> "Exl" + | Exr -> "Exr" + | Alll -> "Alll" + | Allr -> "Allr" + | Falsel -> "Falsel" + | Truer -> "Truer" + +module type JLogicSig = +sig + (* understanding the input *) + val is_all_term : term -> bool + val dest_all : term -> string * term * term + val is_exists_term : term -> bool + val dest_exists : term -> string * term * term + val is_and_term : term -> bool + val dest_and : term -> term * term + val is_or_term : term -> bool + val dest_or : term -> term * term + val is_implies_term : term -> bool + val dest_implies : term -> term * term + val is_not_term : term -> bool + val dest_not : term -> term + + (* processing the output *) + type inf_step = rule * (string * term) * (string * term) + type inference = inf_step list +(* type inference *) + val empty_inf : inference + val append_inf : inference -> (string * term) -> (string * term) -> rule -> inference + val print_inf : inference -> unit +end;; + +(* Copy from [term_op_std.ml]: *) + + let rec print_address int_list = + match int_list with + | [] -> + Format.print_string "" + | hd::rest -> + begin + Format.print_int hd; + print_address rest + end + +module JLogic: JLogicSig = +struct + let is_all_term = Jterm.is_all_term + let dest_all = Jterm.dest_all + let is_exists_term = Jterm.is_exists_term + let dest_exists = Jterm.dest_exists + let is_and_term = Jterm.is_and_term + let dest_and = Jterm.dest_and + let is_or_term = Jterm.is_or_term + let dest_or = Jterm.dest_or + let is_implies_term = Jterm.is_implies_term + let dest_implies = Jterm.dest_implies + let is_not_term = Jterm.is_not_term + let dest_not = Jterm.dest_not + + type inf_step = rule * (string * term) * (string * term) + type inference = inf_step list + + let empty_inf = [] + let append_inf inf t1 t2 rule = + (rule, t1, t2)::inf + + let rec print_inf inf = + match inf with + | [] -> print_string "."; Format.print_flush () + | (rule, (n1,t1), (n2,t2))::d -> + print_string (ruletable rule); + print_string (":("^n1^":"); + print_term stdout t1; + print_string (","^n2^":"); + print_term stdout t2; + print_string ")\n"; + print_inf d +end;; + +let show_loading s = print_string s +type my_Debug = { mutable debug_name: string; + mutable debug_description: string; + debug_value: bool + } + +let create_debug x = ref false diff --git a/contrib/jprover/jlogic.mli b/contrib/jprover/jlogic.mli new file mode 100644 index 00000000..a9079791 --- /dev/null +++ b/contrib/jprover/jlogic.mli @@ -0,0 +1,40 @@ +(* The interface to manipulate [jterms], which is + extracted and modified from Meta-Prl. *) + +type rule = + Ax | Andr | Andl | Orr | Orr1 | Orr2 | Orl | Impr | Impl | Negr | Negl + | Allr | Alll| Exr | Exl | Fail | Falsel | Truer + +module type JLogicSig = + sig + val is_all_term : Jterm.term -> bool + val dest_all : Jterm.term -> string * Jterm.term * Jterm.term + val is_exists_term : Jterm.term -> bool + val dest_exists : Jterm.term -> string * Jterm.term * Jterm.term + val is_and_term : Jterm.term -> bool + val dest_and : Jterm.term -> Jterm.term * Jterm.term + val is_or_term : Jterm.term -> bool + val dest_or : Jterm.term -> Jterm.term * Jterm.term + val is_implies_term : Jterm.term -> bool + val dest_implies : Jterm.term -> Jterm.term * Jterm.term + val is_not_term : Jterm.term -> bool + val dest_not : Jterm.term -> Jterm.term + type inf_step = rule * (string * Jterm.term) * (string * Jterm.term) + type inference = inf_step list + val empty_inf : inference + val append_inf : + inference -> (string * Jterm.term) -> (string * Jterm.term) -> rule -> inference + val print_inf : inference -> unit + end + +module JLogic : JLogicSig + +val show_loading : string -> unit + +type my_Debug = { + mutable debug_name : string; + mutable debug_description : string; + debug_value : bool; +} +val create_debug : 'a -> bool ref +val ruletable : rule -> string diff --git a/contrib/jprover/jprover.ml4 b/contrib/jprover/jprover.ml4 new file mode 100644 index 00000000..dd76438f --- /dev/null +++ b/contrib/jprover/jprover.ml4 @@ -0,0 +1,565 @@ +(*i camlp4deps: "parsing/grammar.cma" i*) + +open Jlogic + +module JA = Jall +module JT = Jterm +module T = Tactics +module TCL = Tacticals +module TM = Tacmach +module N = Names +module PT = Proof_type +module HT = Hiddentac +module PA = Pattern +module HP = Hipattern +module TR = Term +module PR = Printer +module RO = Reductionops +module UT = Util +module RA = Rawterm + +module J=JA.JProver(JLogic) (* the JProver *) + +(*i +module NO = Nameops +module TO = Termops +module RE = Reduction +module CL = Coqlib +module ID = Inductiveops +module CV = Clenv +module RF = Refiner +i*) + +(* Interface to JProver: *) +(* type JLogic.inf_step = rule * (string * Jterm.term) * (string * Jterm.term) *) +type jp_inf_step = JLogic.inf_step +type jp_inference = JLogic.inference (* simply a list of [inf_step] *) + +(* Definitions for rebuilding proof tree from JProver: *) +(* leaf, one-branch, two-branch, two-branch, true, false *) +type jpbranch = JP0 | JP1 | JP2 | JP2' | JPT | JPF +type jptree = | JPempty (* empty tree *) + | JPAx of jp_inf_step (* Axiom node *) + | JPA of jp_inf_step * jptree + | JPB of jp_inf_step * jptree * jptree + +(* Private debugging tools: *) +(*i*) +let mbreak s = Format.print_flush (); print_string ("-break at: "^s); + Format.print_flush (); let _ = input_char stdin in () +(*i*) +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 rec print_constr_list = function + | [] -> () + | ct::r -> print_constr ct; print_constr_list r + +let print_constr_pair op c1 c2 = + print_string (op^"("); + print_constr c1; + print_string ","; + print_constr c2; + print_string ")\n" + + +(* Parsing modules for Coq: *) +(* [is_coq_???] : testing functions *) +(* [dest_coq_???] : destructors *) + +let is_coq_true ct = (HP.is_unit_type ct) && not (HP.is_equation ct) + +let is_coq_false = HP.is_empty_type + +(* return two subterms *) +let dest_coq_and ct = + match (HP.match_with_conjunction ct) with + | Some (hdapp,args) -> +(*i print_constr hdapp; print_constr_list args; i*) + begin + match args with + | s1::s2::[] -> +(*i print_constr_pair "and" s1 s2; i*) + (s1,s2) + | _ -> jp_error "dest_coq_and" + end + | None -> jp_error "dest_coq_and" + +let is_coq_or = HP.is_disjunction + +(* return two subterms *) +let dest_coq_or ct = + match (HP.match_with_disjunction ct) with + | Some (hdapp,args) -> +(*i print_constr hdapp; print_constr_list args; i*) + begin + match args with + | s1::s2::[] -> +(*i print_constr_pair "or" s1 s2; i*) + (s1,s2) + | _ -> jp_error "dest_coq_or" + end + | None -> jp_error "dest_coq_or" + +let is_coq_not = HP.is_nottype + +let dest_coq_not ct = + match (HP.match_with_nottype ct) with + | Some (hdapp,arg) -> +(*i print_constr hdapp; print_constr args; i*) +(*i print_string "not "; + print_constr arg; i*) + arg + | None -> jp_error "dest_coq_not" + + +let is_coq_impl ct = + match TR.kind_of_term ct with + | TR.Prod (_,_,b) -> (not (Termops.dependent (TR.mkRel 1) b)) + | _ -> false + + +let dest_coq_impl c = + match TR.kind_of_term c with + | TR.Prod (_,b,c) -> +(*i print_constr_pair "impl" b c; i*) + (b, c) + | _ -> jp_error "dest_coq_impl" + +(* provide new variables for renaming of universal variables *) +let new_counter = + let ctr = ref 0 in + fun () -> incr ctr;!ctr + +(* provide new symbol name for unknown Coq constructors *) +let new_ecounter = + let ectr = ref 0 in + fun () -> incr ectr;!ectr + +(* provide new variables for address naming *) +let new_acounter = + let actr = ref 0 in + fun () -> incr actr;!actr + +let is_coq_forall ct = + match TR.kind_of_term (RO.whd_betaiota ct) with + | TR.Prod (_,_,b) -> Termops.dependent (TR.mkRel 1) b + | _ -> false + +(* return the bounded variable (as a string) and the bounded term *) +let dest_coq_forall ct = + match TR.kind_of_term (RO.whd_betaiota ct) with + | TR.Prod (_,_,b) -> + let x ="jp_"^(string_of_int (new_counter())) in + let v = TR.mkVar (N.id_of_string x) in + let c = TR.subst1 v b in (* substitute de Bruijn variable by [v] *) +(*i print_constr_pair "forall" v c; i*) + (x, c) + | _ -> jp_error "dest_coq_forall" + + +(* Apply [ct] to [t]: *) +let sAPP ct t = + match TR.kind_of_term (RO.whd_betaiota ct) with + | TR.Prod (_,_,b) -> + let c = TR.subst1 t b in + c + | _ -> jp_error "sAPP" + + +let is_coq_exists ct = + if not (HP.is_conjunction ct) then false + else let (hdapp,args) = TR.decompose_app ct in + match args with + | _::la::[] -> + begin + try + match TR.destLambda la with + | (N.Name _,_,_) -> true + | _ -> false + with _ -> false + end + | _ -> false + +(* return the bounded variable (as a string) and the bounded term *) +let dest_coq_exists ct = + let (hdapp,args) = TR.decompose_app ct in + match args with + | _::la::[] -> + begin + try + match TR.destLambda la with + | (N.Name x,t1,t2) -> + let v = TR.mkVar x in + let t3 = TR.subst1 v t2 in +(*i print_constr_pair "exists" v t3; i*) + (N.string_of_id x, t3) + | _ -> jp_error "dest_coq_exists" + with _ -> jp_error "dest_coq_exists" + end + | _ -> jp_error "dest_coq_exists" + + +let is_coq_and ct = + if (HP.is_conjunction ct) && not (is_coq_exists ct) + && not (is_coq_true ct) then true + else false + + +(* Parsing modules: *) + +let jtbl = Hashtbl.create 53 (* associate for unknown Coq constr. *) +let rtbl = Hashtbl.create 53 (* reverse table of [jtbl] *) + +let dest_coq_symb ct = + N.string_of_id (TR.destVar ct) + +(* provide new names for unknown Coq constr. *) +(* [ct] is the unknown constr., string [s] is appended to the name encoding *) +let create_coq_name ct s = + try + Hashtbl.find jtbl ct + with Not_found -> + let t = ("jp_"^s^(string_of_int (new_ecounter()))) in + Hashtbl.add jtbl ct t; + Hashtbl.add rtbl t ct; + t + +let dest_coq_app ct s = + let (hd, args) = TR.decompose_app ct in +(*i print_constr hd; + print_constr_list args; i*) + if TR.isVar hd then + (dest_coq_symb hd, args) + else (* unknown constr *) + (create_coq_name hd s, args) + +let rec parsing2 c = (* for function symbols, variables, constants *) + if (TR.isApp c) then (* function symbol? *) + let (f,args) = dest_coq_app c "fun_" in + JT.fun_ f (List.map parsing2 args) + else if TR.isVar c then (* identifiable variable or constant *) + JT.var_ (dest_coq_symb c) + else (* unknown constr *) + JT.var_ (create_coq_name c "var_") + +(* the main parsing function *) +let rec parsing c = + let ct = Reduction.whd_betadeltaiota (Global.env ()) c in +(* let ct = Reduction.whd_betaiotazeta (Global.env ()) c in *) + if is_coq_true ct then + JT.true_ + else if is_coq_false ct then + JT.false_ + else if is_coq_not ct then + JT.not_ (parsing (dest_coq_not ct)) + else if is_coq_impl ct then + let (t1,t2) = dest_coq_impl ct in + JT.imp_ (parsing t1) (parsing t2) + else if is_coq_or ct then + let (t1,t2) = dest_coq_or ct in + JT.or_ (parsing t1) (parsing t2) + else if is_coq_and ct then + let (t1,t2) = dest_coq_and ct in + JT.and_ (parsing t1) (parsing t2) + else if is_coq_forall ct then + let (v,t) = dest_coq_forall ct in + JT.forall v (parsing t) + else if is_coq_exists ct then + let (v,t) = dest_coq_exists ct in + JT.exists v (parsing t) + else if TR.isApp ct then (* predicate symbol with arguments *) + let (p,args) = dest_coq_app ct "P_" in + JT.pred_ p (List.map parsing2 args) + else if TR.isVar ct then (* predicate symbol without arguments *) + let p = dest_coq_symb ct in + JT.pred_ p [] + else (* unknown predicate *) + JT.pred_ (create_coq_name ct "Q_") [] + +(*i + print_string "??";print_constr ct; + JT.const_ ("err_"^(string_of_int (new_ecounter()))) +i*) + + +(* Translate JProver terms into Coq constructors: *) +(* The idea is to retrieve it from [rtbl] if it exists indeed, otherwise + create one. *) +let rec constr_of_jterm t = + if (JT.is_var_term t) then (* a variable *) + let v = JT.dest_var t in + try + Hashtbl.find rtbl v + with Not_found -> TR.mkVar (N.id_of_string v) + else if (JT.is_fun_term t) then (* a function symbol *) + let (f,ts) = JT.dest_fun t in + let f' = try Hashtbl.find rtbl f with Not_found -> TR.mkVar (N.id_of_string f) in + TR.mkApp (f', Array.of_list (List.map constr_of_jterm ts)) + else jp_error "constr_of_jterm" + + +(* Coq tactics for Sequent Calculus LJ: *) +(* Note that for left-rule a name indicating the being applied rule + in Coq's Hints is required; for right-rule a name is also needed + if it will pass some subterm to the left-hand side. + However, all of these can be computed by the path [id] of the being + applied rule. +*) + +let assoc_addr = Hashtbl.create 97 + +let short_addr s = + let ad = + try + Hashtbl.find assoc_addr s + with Not_found -> + let t = ("jp_H"^(string_of_int (new_acounter()))) in + Hashtbl.add assoc_addr s t; + t + in + N.id_of_string ad + +(* and-right *) +let dyn_andr = + T.split RA.NoBindings + +(* For example, the following implements the [and-left] rule: *) +let dyn_andl id = (* [id1]: left child; [id2]: right child *) + let id1 = (short_addr (id^"_1")) and id2 = (short_addr (id^"_2")) in + (TCL.tclTHEN (T.simplest_elim (TR.mkVar (short_addr id))) (T.intros_using [id1;id2])) + +let dyn_orr1 = + T.left RA.NoBindings + +let dyn_orr2 = + T.right RA.NoBindings + +let dyn_orl id = + let id1 = (short_addr (id^"_1")) and id2 = (short_addr (id^"_2")) in + (TCL.tclTHENS (T.simplest_elim (TR.mkVar (short_addr id))) + [T.intro_using id1; T.intro_using id2]) + +let dyn_negr id = + let id1 = id^"_1_1" in + HT.h_intro (short_addr id1) + +let dyn_negl id = + T.simplest_elim (TR.mkVar (short_addr id)) + +let dyn_impr id = + let id1 = id^"_1_1" in + HT.h_intro (short_addr id1) + +let dyn_impl id gl = + let t = TM.pf_get_hyp_typ gl (short_addr id) in + let ct = Reduction.whd_betadeltaiota (Global.env ()) t in (* unfolding *) + let (_,b) = dest_coq_impl ct in + let id2 = (short_addr (id^"_1_2")) in + (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 + +let dyn_allr c = (* [c] must be an eigenvariable which replaces [v] *) + HT.h_intro (N.id_of_string c) + +(* [id2] is the path of the instantiated term for [id]*) +let dyn_alll id id2 t gl = + let id' = short_addr id in + let id2' = short_addr id2 in + let ct = TM.pf_get_hyp_typ gl id' in + let ct' = Reduction.whd_betadeltaiota (Global.env ()) ct in (* unfolding *) + let ta = sAPP ct' t in + TCL.tclTHENS (T.cut ta) [T.intro_using id2'; T.apply (TR.mkVar id')] gl + +let dyn_exl id id2 c = (* [c] must be an eigenvariable *) + (TCL.tclTHEN (T.simplest_elim (TR.mkVar (short_addr id))) + (T.intros_using [(N.id_of_string c);(short_addr id2)])) + +let dyn_exr t = + T.one_constructor 1 (RA.ImplicitBindings [t]) + +let dyn_falsel = dyn_negl + +let dyn_truer = + T.one_constructor 1 RA.NoBindings + +(* Do the proof by the guidance of JProver. *) + +let do_one_step inf = + let (rule, (s1, t1), ((s2, t2) as k)) = inf in + begin +(*i if not (Jterm.is_xnil_term t2) then + begin + print_string "1: "; JT.print_term stdout t2; print_string "\n"; + print_string "2: "; print_constr (constr_of_jterm t2); print_string "\n"; + end; +i*) + match rule with + | Andl -> dyn_andl s1 + | Andr -> dyn_andr + | Orl -> dyn_orl s1 + | Orr1 -> dyn_orr1 + | Orr2 -> dyn_orr2 + | Impr -> dyn_impr s1 + | Impl -> dyn_impl s1 + | Negr -> dyn_negr s1 + | Negl -> dyn_negl s1 + | Allr -> dyn_allr (JT.dest_var t2) + | Alll -> dyn_alll s1 s2 (constr_of_jterm t2) + | Exr -> dyn_exr (constr_of_jterm t2) + | Exl -> dyn_exl s1 s2 (JT.dest_var t2) + | Ax -> T.assumption (*i TCL.tclIDTAC i*) + | Truer -> dyn_truer + | Falsel -> dyn_falsel s1 + | _ -> jp_error "do_one_step" + (* this is impossible *) + end +;; + +(* Parameter [tr] is the reconstucted proof tree from output of JProver. *) +let do_coq_proof tr = + let rec rec_do trs = + match trs with + | JPempty -> TCL.tclIDTAC + | JPAx h -> do_one_step h + | JPA (h, t) -> TCL.tclTHEN (do_one_step h) (rec_do t) + | JPB (h, left, right) -> TCL.tclTHENS (do_one_step h) [rec_do left; rec_do right] + in + rec_do tr + + +(* Rebuild the proof tree from the output of JProver: *) + +(* Since some universal variables are not necessarily first-order, + lazy substitution may happen. They are recorded in [rtbl]. *) +let reg_unif_subst t1 t2 = + let (v,_,_) = JT.dest_all t1 in + Hashtbl.add rtbl v (TR.mkVar (N.id_of_string (JT.dest_var t2))) + +let count_jpbranch one_inf = + let (rule, (_, t1), (_, t2)) = one_inf in + begin + match rule with + | Ax -> JP0 + | Orr1 | Orr2 | Negl | Impr | Alll | Exr | Exl -> JP1 + | Andr | Orl -> JP2 + | Negr -> if (JT.is_true_term t1) then JPT else JP1 + | Andl -> if (JT.is_false_term t1) then JPF else JP1 + | Impl -> JP2' (* reverse the sons of [Impl] since [dyn_impl] reverses them *) + | Allr -> reg_unif_subst t1 t2; JP1 + | _ -> jp_error "count_jpbranch" + end + +let replace_by r = function + (rule, a, b) -> (r, a, b) + +let rec build_jptree inf = + match inf with + | [] -> ([], JPempty) + | h::r -> + begin + match count_jpbranch h with + | JP0 -> (r,JPAx h) + | JP1 -> let (r1,left) = build_jptree r in + (r1, JPA(h, left)) + | JP2 -> let (r1,left) = build_jptree r in + let (r2,right) = build_jptree r1 in + (r2, JPB(h, left, right)) + | JP2' -> let (r1,left) = build_jptree r in (* for [Impl] *) + let (r2,right) = build_jptree r1 in + (r2, JPB(h, right, left)) + | JPT -> let (r1,left) = build_jptree r in (* right True *) + (r1, JPAx (replace_by Truer h)) + | JPF -> let (r1,left) = build_jptree r in (* left False *) + (r1, JPAx (replace_by Falsel h)) + end + + +(* The main function: *) +(* [limits] is the multiplicity limit. *) +let jp limits gls = + let concl = TM.pf_concl gls in + let ct = concl in +(*i print_constr ct; i*) + Hashtbl.clear jtbl; (* empty the hash tables *) + Hashtbl.clear rtbl; + Hashtbl.clear assoc_addr; + let t = parsing ct in +(*i JT.print_term stdout t; i*) + try + let p = (J.prover limits [] t) in +(*i print_string "\n"; + JLogic.print_inf p; i*) + let (il,tr) = build_jptree p in + if (il = []) then + begin + Pp.msgnl (Pp.str "Proof is built."); + do_coq_proof tr gls + end + else UT.error "Cannot reconstruct proof tree from JProver." + with e -> Pp.msgnl (Pp.str "JProver fails to prove this:"); + JT.print_error_msg e; + UT.error "JProver terminated." + +(* an unfailed generalization procedure *) +let non_dep_gen b gls = + let concl = TM.pf_concl gls in + if (not (Termops.dependent b concl)) then + T.generalize [b] gls + else + TCL.tclIDTAC gls + +let rec unfail_gen = function + | [] -> TCL.tclIDTAC + | h::r -> + TCL.tclTHEN + (TCL.tclORELSE (non_dep_gen h) (TCL.tclIDTAC)) + (unfail_gen r) + +(* +(* no argument, which stands for no multiplicity limit *) +let jp gls = + let ls = List.map (fst) (TM.pf_hyps_types gls) in +(*i T.generalize (List.map TR.mkVar ls) gls i*) + (* generalize the context *) + TCL.tclTHEN (TCL.tclTRY T.red_in_concl) + (TCL.tclTHEN (unfail_gen (List.map TR.mkVar ls)) + (jp None)) gls +*) +(* +let dyn_jp l gls = + assert (l = []); + jp +*) + +(* one optional integer argument for the multiplicity *) +let jpn n gls = + let ls = List.map (fst) (TM.pf_hyps_types gls) in + 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 ] +END + +(* +TACTIC EXTEND Andl + [ "Andl" ident(id)] -> [ ... (Andl id) ... ]. +END +*) diff --git a/contrib/jprover/jterm.ml b/contrib/jprover/jterm.ml new file mode 100644 index 00000000..7fc923a5 --- /dev/null +++ b/contrib/jprover/jterm.ml @@ -0,0 +1,872 @@ +open Printf +open Opname +open List + +(* Definitions of [jterm]: *) +type param = param' + and operator = operator' + and term = term' + and bound_term = bound_term' + and param' = + | Number of int + | String of string + | Token of string + | Var of string + | ParamList of param list + and operator' = { op_name : opname; op_params : param list } + and term' = { term_op : operator; term_terms : bound_term list } + and bound_term' = { bvars : string list; bterm : term } +;; + +(* Debugging tools: *) +(*i*) +let mbreak s = Format.print_flush (); print_string ("-break at: "^s); + Format.print_flush (); let _ = input_char stdin in () +(*i*) + +type error_msg = + | TermMatchError of term * string + | StringError of string + +exception RefineError of string * error_msg + +let ref_raise = function + | RefineError(s,e) -> raise (RefineError(s,e)) + | _ -> raise (RefineError ("Jterm", StringError "unexpected error")) + +(* Printing utilities: *) + +let fprint_str ostream s = + let _ = fprintf ostream "%s." s in ostream + +let fprint_str_list ostream sl = + ignore (List.fold_left fprint_str ostream sl); + Format.print_flush () + +let fprint_opname ostream = function + { opname_token= tk; opname_name = sl } -> + fprint_str_list ostream sl + +let rec fprint_param ostream = function + | Number n -> fprintf ostream " %d " n + | String s -> fprint_str_list ostream [s] + | Token t -> fprint_str_list ostream [t] + | Var v -> fprint_str_list ostream [v] + | ParamList ps -> fprint_param_list ostream ps +and fprint_param_list ostream = function + | [] -> () + | param::r -> fprint_param ostream param; + fprint_param_list ostream r +;; + +let print_strs = fprint_str_list stdout + + +(* Interface to [Jall.ml]: *) +(* It is extracted from Meta-Prl's standard implementation. *) +(*c begin of the extraction *) + +type term_subst = (string * term) list +let mk_term op bterms = { term_op = op; term_terms = bterms } +let make_term x = x (* external [make_term : term' -> term] = "%identity" *) +let dest_term x = x (* external [dest_term : term -> term'] = "%identity" *) +let mk_op name params = + { op_name = name; op_params = params } + +let make_op x = x (* external [make_op : operator' -> operator] = "%identity" *) +let dest_op x = x (* external [dest_op : operator -> operator'] = "%identity" *) +let mk_bterm bvars term = { bvars = bvars; bterm = term } +let make_bterm x = x (* external [make_bterm : bound_term' -> bound_term] = "%identity" *) +let dest_bterm x = x (* external [dest_bterm : bound_term -> bound_term'] = "%identity" *) +let make_param x = x (* external [make_param : param' -> param] = "%identity" *) +let dest_param x = x (* external [dest_param : param -> param'] = "%identity" *) + +(* + * Operator names. + *) +let opname_of_term = function + { term_op = { op_name = name } } -> + name + +(* + * Get the subterms. + * None of the subterms should be bound. + *) +let subterms_of_term t = + List.map (fun { bterm = t } -> t) t.term_terms + +let subterm_count { term_terms = terms } = + List.length terms + +let subterm_arities { term_terms = terms } = + List.map (fun { bvars = vars } -> List.length vars) terms + +(* + * Manifest terms are injected into the "perv" module. + *) +let xperv = make_opname ["Perv"] +let sequent_opname = mk_opname "sequent" xperv + +(* + * Variables. + *) + +let var_opname = make_opname ["var"] + +(* + * See if a term is a variable. + *) +let is_var_term = function + | { term_op = { op_name = opname; op_params = [Var v] }; + term_terms = [] + } when Opname.eq opname var_opname -> true + | _ -> + false + +(* + * Destructor for a variable. + *) +let dest_var = function + | { term_op = { op_name = opname; op_params = [Var v] }; + term_terms = [] + } when Opname.eq opname var_opname -> v + | t -> + ref_raise(RefineError ("dest_var", TermMatchError (t, "not a variable"))) +(* + * Make a variable. + *) +let mk_var_term v = + { term_op = { op_name = var_opname; op_params = [Var v] }; + term_terms = [] + } + +(* + * Simple terms + *) +(* + * "Simple" terms have no parameters and no binding variables. + *) +let is_simple_term_opname name = function + | { term_op = { op_name = name'; op_params = [] }; + term_terms = bterms + } when Opname.eq name' name -> + let rec aux = function + | { bvars = []; bterm = _ }::t -> aux t + | _::t -> false + | [] -> true + in + aux bterms + | _ -> false + +let mk_any_term op terms = + let aux t = + { bvars = []; bterm = t } + in + { term_op = op; term_terms = List.map aux terms } + +let mk_simple_term name terms = + mk_any_term { op_name = name; op_params = [] } terms + +let dest_simple_term = function + | ({ term_op = { op_name = name; op_params = [] }; + term_terms = bterms + } : term) as t -> + let aux = function + | { bvars = []; bterm = t } -> + t + | _ -> + ref_raise(RefineError ("dest_simple_term", TermMatchError (t, "binding vars exist"))) + in + name, List.map aux bterms + | t -> + ref_raise(RefineError ("dest_simple_term", TermMatchError (t, "params exist"))) + +let dest_simple_term_opname name = function + | ({ term_op = { op_name = name'; op_params = [] }; + term_terms = bterms + } : term) as t -> + if Opname.eq name name' then + let aux = function + | { bvars = []; bterm = t } -> t + | _ -> ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "binding vars exist"))) + in + List.map aux bterms + else + ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "opname mismatch"))) + | t -> + ref_raise(RefineError ("dest_simple_term_opname", TermMatchError (t, "params exist"))) + +(* + * Bound terms. + *) +let mk_simple_bterm bterm = + { bvars = []; bterm = bterm } + +let dest_simple_bterm = function + | { bvars = []; bterm = bterm } -> + bterm + | _ -> + ref_raise(RefineError ("dest_simple_bterm", StringError ("bterm is not simple"))) + +(* Copy from [term_op_std.ml]: *) +(*i modified for Jprover, as a patch... i*) +let mk_string_term opname s = + { term_op = { op_name = opname; op_params = [String s] }; term_terms = [] } + +(*i let mk_string_term opname s = + let new_opname={opname_token=opname.opname_token; opname_name=(List.tl opname.opname_name)@[s]} in + { term_op = { op_name = new_opname; op_params = [String (List.hd opname.opname_name)] }; term_terms = [] } +i*) + +(* Copy from [term_subst_std.ml]: *) + +let rec free_vars_term gvars bvars = function + | { term_op = { op_name = opname; op_params = [Var v] }; term_terms = bterms } when Opname.eq opname var_opname -> + (* This is a variable *) + let gvars' = + if List.mem v bvars or List.mem v gvars then + gvars + else + v::gvars + in + free_vars_bterms gvars' bvars bterms + | { term_terms = bterms } -> + free_vars_bterms gvars bvars bterms + and free_vars_bterms gvars bvars = function + | { bvars = vars; bterm = term}::l -> + let bvars' = vars @ bvars in + let gvars' = free_vars_term gvars bvars' term in + free_vars_bterms gvars' bvars l + | [] -> + gvars + +let free_vars_list = free_vars_term [] [] + + +(* Termop: *) + +let is_no_subterms_term opname = function + | { term_op = { op_name = opname'; op_params = [] }; + term_terms = [] + } -> + Opname.eq opname' opname + | _ -> + false + +(* + * Terms with one subterm. + *) +let is_dep0_term opname = function + | { term_op = { op_name = opname'; op_params = [] }; + term_terms = [{ bvars = [] }] + } -> Opname.eq opname' opname + | _ -> false + +let mk_dep0_term opname t = + { term_op = { op_name = opname; op_params = [] }; + term_terms = [{ bvars = []; bterm = t }] + } + +let dest_dep0_term opname = function + | { term_op = { op_name = opname'; op_params = [] }; + term_terms = [{ bvars = []; bterm = t }] + } when Opname.eq opname' opname -> t + | t -> ref_raise(RefineError ("dest_dep0_term", TermMatchError (t, "not a dep0 term"))) + +(* + * Terms with two subterms. + *) +let is_dep0_dep0_term opname = function + | { term_op = { op_name = opname'; op_params = [] }; + term_terms = [{ bvars = [] }; { bvars = [] }] + } -> Opname.eq opname' opname + | _ -> false + +let mk_dep0_dep0_term opname = fun + t1 t2 -> + { term_op = { op_name = opname; op_params = [] }; + term_terms = [{ bvars = []; bterm = t1 }; + { bvars = []; bterm = t2 }] + } + +let dest_dep0_dep0_term opname = function + | { term_op = { op_name = opname'; op_params = [] }; + term_terms = [{ bvars = []; bterm = t1 }; + { bvars = []; bterm = t2 }] + } when Opname.eq opname' opname -> t1, t2 + | t -> ref_raise(RefineError ("dest_dep0_dep0_term", TermMatchError (t, "bad arity"))) + +(* + * Bound term. + *) + +let is_dep0_dep1_term opname = function + | { term_op = { op_name = opname'; op_params = [] }; + term_terms = [{ bvars = [] }; { bvars = [_] }] + } when Opname.eq opname' opname -> true + | _ -> false + +let is_dep0_dep1_any_term = function + | { term_op = { op_params = [] }; + term_terms = [{ bvars = [] }; { bvars = [_] }] + } -> true + | _ -> false + +let mk_dep0_dep1_term opname = fun + v t1 t2 -> { term_op = { op_name = opname; op_params = [] }; + term_terms = [{ bvars = []; bterm = t1 }; + { bvars = [v]; bterm = t2 }] + } + +let dest_dep0_dep1_term opname = function + | { term_op = { op_name = opname'; op_params = [] }; + term_terms = [{ bvars = []; bterm = t1 }; + { bvars = [v]; bterm = t2 }] + } when Opname.eq opname' opname -> v, t1, t2 + | t -> ref_raise(RefineError ("dest_dep0_dep1_term", TermMatchError (t, "bad arity"))) + +let rec smap f = function + | [] -> [] + | (hd::tl) as l -> + let hd' = f hd in + let tl' = smap f tl in + if (hd==hd')&&(tl==tl') then l else hd'::tl' + +let rec try_check_assoc v v' = function + | [] -> raise Not_found + | (v1,v2)::tl -> + begin match v=v1, v'=v2 with + | true, true -> true + | false, false -> try_check_assoc v v' tl + | _ -> false + end + +let rec zip_list l l1 l2 = match (l1,l2) with + | (h1::t1), (h2::t2) -> + zip_list ((h1,h2)::l) t1 t2 + | [], [] -> + l + | _ -> raise (Failure "Term.zip_list") + +let rec assoc_in_range eq y = function + | (_, y')::tl -> + (eq y y') || (assoc_in_range eq y tl) + | [] -> + false + +let rec check_assoc v v' = function + | [] -> v=v' + | (v1,v2)::tl -> + begin match v=v1, v'=v2 with + | true, true -> true + | false, false -> check_assoc v v' tl + | _ -> false + end + +let rec zip a b = match (a,b) with + | (h1::t1), (h2::t2) -> + (h1, h2) :: zip t1 t2 + | [], [] -> + [] + | + _ -> raise (Failure "Term.zip") + +let rec for_all2 f l1 l2 = + match (l1,l2) with + | h1::t1, h2::t2 -> for_all2 f t1 t2 & f h1 h2 + | [], [] -> true + | _ -> false + +let newname v i = + v ^ "_" ^ (string_of_int i) + +let rec new_var v avoid i = + let v' = newname v i in + if avoid v' + then new_var v avoid (succ i) + else v' + +let vnewname v avoid = new_var v avoid 1 + +let rev_mem a b = List.mem b a + +let rec find_index_aux v i = function + | h::t -> + if h = v then + i + else + find_index_aux v (i + 1) t + | [] -> + raise Not_found + +let find_index v l = find_index_aux v 0 l + +let rec remove_elements l1 l2 = + match l1, l2 with + | flag::ft, h::t -> + if flag then + remove_elements ft t + else + h :: remove_elements ft t + | _, l -> + l + +let rec subtract l1 l2 = + match l1 with + | h::t -> + if List.mem h l2 then + subtract t l2 + else + h :: subtract t l2 + | [] -> + [] + +let rec fv_mem fv v = + match fv with + | [] -> false + | h::t -> + List.mem v h || fv_mem t v + +let rec new_vars fv = function + | [] -> [] + | v::t -> + (* Rename the first one, then add it to free vars *) + let v' = vnewname v (fv_mem fv) in + v'::(new_vars ([v']::fv) t) + +let rec fsubtract l = function + | [] -> l + | h::t -> + fsubtract (subtract l h) t + +let add_renames_fv r l = + let rec aux = function + | [] -> l + | v::t -> [v]::(aux t) + in + aux r + +let add_renames_terms r l = + let rec aux = function + | [] -> l + | v::t -> (mk_var_term v)::(aux t) + in + aux r + +(* + * First order simultaneous substitution. + *) +let rec subst_term terms fv vars = function + | { term_op = { op_name = opname; op_params = [Var(v)] }; term_terms = [] } as t + when Opname.eq opname var_opname-> + (* Var case *) + begin + try List.nth terms (find_index v vars) with + Not_found -> + t + end + | { term_op = op; term_terms = bterms } -> + (* Other term *) + { term_op = op; term_terms = subst_bterms terms fv vars bterms } + +and subst_bterms terms fv vars bterms = + (* When subst through bterms, catch binding occurrences *) + let rec subst_bterm = function + | { bvars = []; bterm = term } -> + (* Optimize the common case *) + { bvars = []; bterm = subst_term terms fv vars term } + + | { bvars = bvars; bterm = term } -> + (* First subtract bound instances *) + let flags = List.map (function v -> List.mem v bvars) vars in + let vars' = remove_elements flags vars in + let fv' = remove_elements flags fv in + let terms' = remove_elements flags terms in + + (* If any of the binding variables are free, rename them *) + let renames = subtract bvars (fsubtract bvars fv') in + if renames <> [] then + let fv'' = (free_vars_list term)::fv' in + let renames' = new_vars fv'' renames in + { bvars = subst_bvars renames' renames bvars; + bterm = subst_term + (add_renames_terms renames' terms') + (add_renames_fv renames' fv') + (renames @ vars') + term + } + else + { bvars = bvars; + bterm = subst_term terms' fv' vars' term + } + in + List.map subst_bterm bterms + +and subst_bvars renames' renames bvars = + let subst_bvar v = + try List.nth renames' (find_index v renames) with + Not_found -> v + in + List.map subst_bvar bvars + +let subst term vars terms = + subst_term terms (List.map free_vars_list terms) vars term + +(*i bug!!! in the [term_std] module + let subst1 t var term = + let fv = free_vars_list term in + if List.mem var fv then + subst_term [term] [fv] [var] t + else + t +The following is the correct implementation +i*) + +let subst1 t var term = +if List.mem var (free_vars_list t) then + subst_term [term] [free_vars_list term] [var] t +else + t + +let apply_subst t s = + let vs,ts = List.split s in + subst t vs ts + +let rec equal_params p1 p2 = + match p1, p2 with + | Number n1, Number n2 -> + n1 = n2 + | ParamList pl1, ParamList pl2 -> + List.for_all2 equal_params pl1 pl2 + | _ -> + p1 = p2 + +let rec equal_term vars t t' = + match t, t' with + | { term_op = { op_name = opname1; op_params = [Var v] }; + term_terms = [] + }, + { term_op = { op_name = opname2; op_params = [Var v'] }; + term_terms = [] + } when Opname.eq opname1 var_opname & Opname.eq opname2 var_opname -> + check_assoc v v' vars + | { term_op = { op_name = name1; op_params = params1 }; term_terms = bterms1 }, + { term_op = { op_name = name2; op_params = params2 }; term_terms = bterms2 } -> + (Opname.eq name1 name2) + & (for_all2 equal_params params1 params2) + & (equal_bterms vars bterms1 bterms2) +and equal_bterms vars bterms1 bterms2 = + let equal_bterm = fun + { bvars = bvars1; bterm = term1 } + { bvars = bvars2; bterm = term2 } -> + equal_term (zip_list vars bvars1 bvars2) term1 term2 + in + for_all2 equal_bterm bterms1 bterms2 + + +let alpha_equal t1 t2 = + try equal_term [] t1 t2 with Failure _ -> false + +let var_subst t t' v = + let { term_op = { op_name = opname } } = t' in + let vt = mk_var_term v in + let rec subst_term = function + { term_op = { op_name = opname'; op_params = params }; + term_terms = bterms + } as t -> + (* Check if this is the same *) + if Opname.eq opname' opname & alpha_equal t t' then + vt + else + { term_op = { op_name = opname'; op_params = params }; + term_terms = List.map subst_bterm bterms + } + + and subst_bterm { bvars = vars; bterm = term } = + if List.mem v vars then + let av = vars @ (free_vars_list term) in + let v' = vnewname v (fun v -> List.mem v av) in + let rename var = if var = v then v' else var in + let term = subst1 term v (mk_var_term v') in + { bvars = smap rename vars; bterm = subst_term term } + else + { bvars = vars; bterm = subst_term term } + in + subst_term t + +let xnil_opname = mk_opname "nil" xperv +let xnil_term = mk_simple_term xnil_opname [] +let is_xnil_term = is_no_subterms_term xnil_opname + +(*c End of the extraction from Meta-Prl *) + +(* Huang's modification: *) +let all_opname = make_opname ["quantifier";"all"] +let is_all_term = is_dep0_dep1_term all_opname +let dest_all = dest_dep0_dep1_term all_opname +let mk_all_term = mk_dep0_dep1_term all_opname + +let exists_opname = make_opname ["quantifier";"exst"] +let is_exists_term = is_dep0_dep1_term exists_opname +let dest_exists = dest_dep0_dep1_term exists_opname +let mk_exists_term = mk_dep0_dep1_term exists_opname + +let or_opname = make_opname ["connective";"or"] +let is_or_term = is_dep0_dep0_term or_opname +let dest_or = dest_dep0_dep0_term or_opname +let mk_or_term = mk_dep0_dep0_term or_opname + +let and_opname = make_opname ["connective";"and"] +let is_and_term = is_dep0_dep0_term and_opname +let dest_and = dest_dep0_dep0_term and_opname +let mk_and_term = mk_dep0_dep0_term and_opname + +let cor_opname = make_opname ["connective";"cor"] +let is_cor_term = is_dep0_dep0_term cor_opname +let dest_cor = dest_dep0_dep0_term cor_opname +let mk_cor_term = mk_dep0_dep0_term cor_opname + +let cand_opname = make_opname ["connective";"cand"] +let is_cand_term = is_dep0_dep0_term cand_opname +let dest_cand = dest_dep0_dep0_term cand_opname +let mk_cand_term = mk_dep0_dep0_term cand_opname + +let implies_opname = make_opname ["connective";"=>"] +let is_implies_term = is_dep0_dep0_term implies_opname +let dest_implies = dest_dep0_dep0_term implies_opname +let mk_implies_term = mk_dep0_dep0_term implies_opname + +let iff_opname = make_opname ["connective";"iff"] +let is_iff_term = is_dep0_dep0_term iff_opname +let dest_iff = dest_dep0_dep0_term iff_opname +let mk_iff_term = mk_dep0_dep0_term iff_opname + +let not_opname = make_opname ["connective";"not"] +let is_not_term = is_dep0_term not_opname +let dest_not = dest_dep0_term not_opname +let mk_not_term = mk_dep0_term not_opname + +let var_ = mk_var_term +let fun_opname = make_opname ["function"] +let fun_ f ts = mk_any_term {op_name = fun_opname; op_params = [String f] } ts + +let is_fun_term = function + | { term_op = { op_name = opname; op_params = [String f] }} + when Opname.eq opname fun_opname -> true + | _ -> + false + +let dest_fun = function + | { term_op = { op_name = opname; op_params = [String f] }; term_terms = ts} + when Opname.eq opname fun_opname -> (f, List.map (fun { bterm = t } -> t) ts) + | t -> + ref_raise(RefineError ("dest_fun", TermMatchError (t, "not a function symbol"))) + +let const_ c = fun_ c [] +let is_const_term = function + | { term_op = { op_name = opname; op_params = [String f] }; term_terms = [] } + when Opname.eq opname fun_opname -> true + | _ -> + false + +let dest_const t = + let (n, ts) = dest_fun t in n + +let pred_opname = make_opname ["predicate"] +let pred_ p ts = mk_any_term {op_name = pred_opname; op_params = [String p] } ts + +let not_ = mk_not_term +let and_ = mk_and_term +let or_ = mk_or_term +let imp_ = mk_implies_term +let cand_ = mk_cand_term +let cor_ = mk_cor_term +let iff_ = mk_iff_term +let nil_term = {term_op={op_name=nil_opname; op_params=[]}; term_terms=[] } +let forall v t = mk_all_term v nil_term t +let exists v t= mk_exists_term v nil_term t +let rec wbin op = function + | [] -> raise (Failure "Term.wbin") + | [t] -> t + | t::r -> op t (wbin op r) + +let wand_ = wbin and_ +let wor_ = wbin or_ +let wimp_ = wbin imp_ + +(*i let true_opname = make_opname ["bool";"true"] +let is_true_term = is_no_subterms_term true_opname +let true_ = mk_simple_term true_opname [] +let false_ = not_ true_ + +let is_false_term t = + if is_not_term t then + let t1 = dest_not t in + is_true_term t1 + else + false +i*) + +let dummy_false_ = mk_simple_term (make_opname ["bool";"false"]) [] +let dummy_true_ = mk_simple_term (make_opname ["bool";"true"]) [] +let false_ = and_ (dummy_false_) (not_ dummy_false_) +let true_ = not_ (and_ (dummy_true_) (not_ dummy_true_)) + +let is_false_term t = + if (alpha_equal t false_) then true + else false + +let is_true_term t = + if (alpha_equal t true_) then true + else false + +(* Print a term [t] via the [ostream]: *) +let rec fprint_term ostream t prec = + let l_print op_prec = + if (prec > op_prec) then fprintf ostream "(" in + let r_print op_prec = + if (prec > op_prec) then fprintf ostream ")" in + if is_false_term t then (* false *) + fprint_str_list ostream ["False"] + else if is_true_term t then (* true *) + fprint_str_list ostream ["True"] + else if is_all_term t then (* for all *) + let v, t1, t2 = dest_all t in + fprint_str_list ostream ["A."^v]; + fprint_term ostream t2 4 + else if is_exists_term t then (* exists *) + let v, t1, t2 = dest_exists t in + fprint_str_list ostream ["E."^v]; + fprint_term ostream t2 4 (* implication *) + else if is_implies_term t then + let t1, t2 = dest_implies t in + l_print 0; + fprint_term ostream t1 1; + fprint_str_list ostream ["=>"]; + fprint_term ostream t2 0; + r_print 0 + else if is_and_term t then (* logical and *) + let t1, t2 = dest_and t in + l_print 3; + fprint_term ostream t1 3; + fprint_str_list ostream ["&"]; + fprint_term ostream t2 3; + r_print 3 + else if is_or_term t then (* logical or *) + let t1, t2 = dest_or t in + l_print 2; + fprint_term ostream t1 2; + fprint_str_list ostream ["|"]; + fprint_term ostream t2 2; + r_print 2 + else if is_not_term t then (* logical not *) + let t2 = dest_not t in + fprint_str_list ostream ["~"]; + fprint_term ostream t2 4 (* nil term *) + else if is_xnil_term t then + fprint_str_list ostream ["NIL"] + else match t with (* other cases *) + { term_op = { op_name = opname; op_params = opparm }; term_terms = bterms} -> + if (Opname.eq opname pred_opname) || (Opname.eq opname fun_opname) then + begin + fprint_param_list ostream opparm; + if bterms != [] then + begin + fprintf ostream "("; + fprint_bterm_list ostream prec bterms; + fprintf ostream ")"; + end + end else + begin + fprintf ostream "["; +(* fprint_opname ostream opname; + fprintf ostream ": "; *) + fprint_param_list ostream opparm; + if bterms != [] then + begin + fprintf ostream "("; + fprint_bterm_list ostream prec bterms; + fprintf ostream ")"; + end; + fprintf ostream "]" + end +and fprint_bterm_list ostream prec = function + | [] -> () + | {bvars=bv; bterm=bt}::r -> + fprint_str_list ostream bv; + fprint_term ostream bt prec; + if (r<>[]) then fprint_str_list ostream [","]; + fprint_bterm_list ostream prec r +;; + + +let print_term ostream t = + Format.print_flush (); + fprint_term ostream t 0; + Format.print_flush () + +let print_error_msg = function + | RefineError(s,e) -> print_string ("(module "^s^") "); + begin + match e with + | TermMatchError(t,s) -> print_term stdout t; print_string (s^"\n") + | StringError s -> print_string (s^"\n") + end + | ue -> print_string "Unexpected error for Jp.\n"; + raise ue + + +(* Naive implementation for [jterm] substitution, unification, etc.: *) +let substitute subst term = + apply_subst term subst + +(* A naive unification algorithm: *) +let compsubst subst1 subst2 = + (List.map (fun (v, t) -> (v, substitute subst1 t)) subst2) @ subst1 +;; + +let rec extract_terms = function + | [] -> [] + | h::r -> let {bvars=_; bterm=bt}=h in bt::extract_terms r + +(* Occurs check: *) +let occurs v t = + let rec occur_rec t = + if is_var_term t then v=dest_var t + else let { term_op = _ ; term_terms = bterms} = t in + let sons = extract_terms bterms in + List.exists occur_rec sons + in + occur_rec t + +(* The naive unification algorithm: *) +let rec unify2 (term1,term2) = + if is_var_term term1 then + if equal_term [] term1 term2 then [] + else let v1 = dest_var term1 in + if occurs v1 term2 then raise (RefineError ("unify1", StringError ("1"))) + else [v1,term2] + else if is_var_term term2 then + let v2 = dest_var term2 in + if occurs v2 term1 then raise (RefineError ("unify2", StringError ("2"))) + else [v2,term1] + else + let { term_op = { op_name = opname1; op_params = params1 }; + term_terms = bterms1 + } = term1 + in + let { term_op = { op_name = opname2; op_params = params2 }; + term_terms = bterms2 + } = term2 + in + if Opname.eq opname1 opname2 & params1 = params2 then + let sons1 = extract_terms bterms1 + and sons2 = extract_terms bterms2 in + List.fold_left2 + (fun s t1 t2 -> compsubst + (unify2 (substitute s t1, substitute s t2)) s) + [] sons1 sons2 + else raise (RefineError ("unify3", StringError ("3"))) + +let unify term1 term2 = unify2 (term1, term2) +let unify_mm term1 term2 _ = unify2 (term1, term2) diff --git a/contrib/jprover/jterm.mli b/contrib/jprover/jterm.mli new file mode 100644 index 00000000..0bc42010 --- /dev/null +++ b/contrib/jprover/jterm.mli @@ -0,0 +1,110 @@ +(* This module is modified and extracted from Meta-Prl. *) + +(* Definitions of [jterm]: *) +type param = param' +and operator = operator' +and term = term' +and bound_term = bound_term' +and param' = + | Number of int + | String of string + | Token of string + | Var of string + | ParamList of param list +and operator' = { op_name : Opname.opname; op_params : param list; } +and term' = { term_op : operator; term_terms : bound_term list; } +and bound_term' = { bvars : string list; bterm : term; } +type term_subst = (string * term) list + +type error_msg = TermMatchError of term * string | StringError of string + +exception RefineError of string * error_msg + +(* Collect free variables: *) +val free_vars_list : term -> string list + +(* Substitutions: *) +val subst_term : term list -> string list list -> string list -> term -> term +val subst : term -> string list -> term list -> term +val subst1 : term -> string -> term -> term +val var_subst : term -> term -> string -> term +val apply_subst : term -> (string * term) list -> term + +(* Unification: *) +val unify_mm : term -> term -> 'a -> (string * term) list + +val xnil_term : term' + +(* Testing functions: *) +val is_xnil_term : term' -> bool +val is_var_term : term' -> bool +val is_true_term : term' -> bool +val is_false_term : term' -> bool +val is_all_term : term' -> bool +val is_exists_term : term' -> bool +val is_or_term : term' -> bool +val is_and_term : term' -> bool +val is_cor_term : term' -> bool +val is_cand_term : term' -> bool +val is_implies_term : term' -> bool +val is_iff_term : term' -> bool +val is_not_term : term' -> bool +val is_fun_term : term -> bool +val is_const_term : term -> bool + + +(* Constructors for [jterms]: *) +val var_ : string -> term' +val fun_ : string -> term list -> term' +val const_ : string -> term' +val pred_ : string -> term list -> term' +val not_ : term -> term' +val and_ : term -> term -> term' +val or_ : term -> term -> term' +val imp_ : term -> term -> term' +val cand_ : term -> term -> term' +val cor_ : term -> term -> term' +val iff_ : term -> term -> term' +val false_ : term' +val true_ : term' +val nil_term : term' +val forall : string -> term -> term' +val exists : string -> term -> term' + + +(* Destructors for [jterm]: *) +val dest_var : term -> string +val dest_fun : term -> string * term list +val dest_const : term -> string +val dest_not : term -> term +val dest_iff : term -> term * term +val dest_implies : term -> term * term +val dest_cand : term -> term * term +val dest_cor : term -> term * term +val dest_and : term -> term * term +val dest_or : term -> term * term +val dest_exists : term -> string * term * term +val dest_all : term -> string * term * term + +(* Wide-logical connectives: *) +val wand_ : term list -> term +val wor_ : term list -> term +val wimp_ : term list -> term + +(* Printing and debugging tools: *) +val fprint_str_list : out_channel -> string list -> unit +val mbreak : string -> unit +val print_strs : string list -> unit +val print_term : out_channel -> term -> unit +val print_error_msg : exn -> unit + +(* Other exported functions for [jall.ml]: *) +val make_term : 'a -> 'a +val dest_term : 'a -> 'a +val make_op : 'a -> 'a +val dest_op : 'a -> 'a +val make_bterm : 'a -> 'a +val dest_bterm : 'a -> 'a +val dest_param : 'a -> 'a +val mk_var_term : string -> term' +val mk_string_term : Opname.opname -> string -> term' diff --git a/contrib/jprover/jtunify.ml b/contrib/jprover/jtunify.ml new file mode 100644 index 00000000..2295e62c --- /dev/null +++ b/contrib/jprover/jtunify.ml @@ -0,0 +1,507 @@ +(* + * Unification procedures for JProver. See jall.mli for more + * information on JProver. + * + * ---------------------------------------------------------------- + * + * This file is part of MetaPRL, a modular, higher order + * logical framework that provides a logical programming + * environment for OCaml and other languages. + * + * See the file doc/index.html for information on Nuprl, + * OCaml, and more information about this system. + * + * Copyright (C) 2000 Stephan Schmitt + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + * + * Author: Stephan Schmitt <schmitts@spmail.slu.edu> + * Modified by: Aleksey Nogin <nogin@cs.cornell.edu> + *) + +exception Not_unifiable +exception Failed + +let jprover_bug = Invalid_argument "Jprover bug (Jtunify module)" + +(* ************ T-STRING UNIFICATION *********************************) + + +(* ******* printing ********** *) + +let rec list_to_string s = + match s with + [] -> "" + | f::r -> + f^"."^(list_to_string r) + +let rec print_eqlist eqlist = + match eqlist with + [] -> + print_endline "" + | (atnames,f)::r -> + let (s,t) = f in + let ls = list_to_string s + and lt = list_to_string t in + begin + print_endline ("Atom names: "^(list_to_string atnames)); + print_endline (ls^" = "^lt); + print_eqlist r + end + +let print_equations eqlist = + begin + Format.open_box 0; + Format.force_newline (); + print_endline "Equations:"; + print_eqlist eqlist; + Format.force_newline (); + end + +let rec print_subst sigma = + match sigma with + [] -> + print_endline "" + | f::r -> + let (v,s) = f in + let ls = list_to_string s in + begin + print_endline (v^" = "^ls); + print_subst r + end + +let print_tunify sigma = + let (n,subst) = sigma in + begin + print_endline " "; + print_endline ("MaxVar = "^(string_of_int (n-1))); + print_endline " "; + print_endline "Substitution:"; + print_subst subst; + print_endline " " + end + + (*****************************************************) + +let is_const name = + (String.get name 0) = 'c' + +let is_var name = + (String.get name 0) = 'v' + +let r_1 s ft rt = + (s = []) && (ft = []) && (rt = []) + +let r_2 s ft rt = + (s = []) && (ft = []) && (List.length rt >= 1) + +let r_3 s ft rt = + ft=[] && (List.length s >= 1) && (List.length rt >= 1) && (List.hd s = List.hd rt) + +let r_4 s ft rt = + ft=[] + && (List.length s >= 1) + && (List.length rt >= 1) + && is_const (List.hd s) + && is_var (List.hd rt) + +let r_5 s ft rt = + rt=[] + && (List.length s >= 1) + && is_var (List.hd s) + +let r_6 s ft rt = + ft=[] + && (List.length s >= 1) + && (List.length rt >= 1) + && is_var (List.hd s) + && is_const (List.hd rt) + +let r_7 s ft rt = + List.length s >= 1 + && (List.length rt >= 2) + && is_var (List.hd s) + && is_const (List.hd rt) + && is_const (List.hd (List.tl rt)) + +let r_8 s ft rt = + ft=[] + && List.length s >= 2 + && List.length rt >= 1 + && let v = List.hd s + and v1 = List.hd rt in + (is_var v) & (is_var v1) & (v <> v1) + +let r_9 s ft rt = + (List.length s >= 2) && (List.length ft >= 1) && (List.length rt >= 1) + && let v = (List.hd s) + and v1 = (List.hd rt) in + (is_var v) & (is_var v1) & (v <> v1) + +let r_10 s ft rt = + (List.length s >= 1) && (List.length rt >= 1) + && let v = List.hd s + and x = List.hd rt in + (is_var v) && (v <> x) + && (((List.tl s) =[]) or (is_const x) or ((List.tl rt) <> [])) + +let rec com_subst slist ((ov,ovlist) as one_subst) = + match slist with + [] -> raise jprover_bug + | f::r -> + if f = ov then + (ovlist @ r) + else + f::(com_subst r one_subst) + +let rec combine subst ((ov,oslist) as one_subst) = + match subst with + [] -> [] + | ((v, slist) as f) :: r -> + let rest_combine = (combine r one_subst) in + if (List.mem ov slist) then (* subst assumed to be idemponent *) + let com_element = com_subst slist one_subst in + ((v,com_element)::rest_combine) + else + (f::rest_combine) + +let compose ((n,subst) as sigma) ((ov,oslist) as one_subst) = + let com = combine subst one_subst in +(* begin + print_endline "!!!!!!!!!test print!!!!!!!!!!"; + print_subst [one_subst]; + print_subst subst; + print_endline "!!!!!!!!! END test print!!!!!!!!!!"; +*) + if List.mem one_subst subst then + (n,com) + else +(* ov may multiply as variable in subst with DIFFERENT values *) +(* in order to avoid explicit atom instances!!! *) + (n,(com @ [one_subst])) +(* end *) + +let rec apply_element fs ft (v,slist) = + match (fs,ft) with + ([],[]) -> + ([],[]) + | ([],(ft_first::ft_rest)) -> + let new_ft_first = + if ft_first = v then + slist + else + [ft_first] + in + let (emptylist,new_ft_rest) = apply_element [] ft_rest (v,slist) in + (emptylist,(new_ft_first @ new_ft_rest)) + | ((fs_first::fs_rest),[]) -> + let new_fs_first = + if fs_first = v then + slist + else + [fs_first] + in + let (new_fs_rest,emptylist) = apply_element fs_rest [] (v,slist) in + ((new_fs_first @ new_fs_rest),emptylist) + | ((fs_first::fs_rest),(ft_first::ft_rest)) -> + let new_fs_first = + if fs_first = v then + slist + else + [fs_first] + and new_ft_first = + if ft_first = v then + slist + else + [ft_first] + in + let (new_fs_rest,new_ft_rest) = apply_element fs_rest ft_rest (v,slist) in + ((new_fs_first @ new_fs_rest),(new_ft_first @ new_ft_rest)) + +let rec shorten us ut = + match (us,ut) with + ([],_) | (_,[]) -> (us,ut) (*raise jprover_bug*) + | ((fs::rs),(ft::rt)) -> + if fs = ft then + shorten rs rt + else + (us,ut) + +let rec apply_subst_list eq_rest (v,slist) = + match eq_rest with + [] -> + (true,[]) + | (atomnames,(fs,ft))::r -> + let (n_fs,n_ft) = apply_element fs ft (v,slist) in + let (new_fs,new_ft) = shorten n_fs n_ft in (* delete equal first elements *) + match (new_fs,new_ft) with + [],[] -> + let (bool,new_eq_rest) = apply_subst_list r (v,slist) in + (bool,((atomnames,([],[]))::new_eq_rest)) + | [],(fft::rft) -> + if (is_const fft) then + (false,[]) + else + let (bool,new_eq_rest) = apply_subst_list r (v,slist) in + (bool,((atomnames,([],new_ft))::new_eq_rest)) + | (ffs::rfs),[] -> + if (is_const ffs) then + (false,[]) + else + let (bool,new_eq_rest) = apply_subst_list r (v,slist) in + (bool,((atomnames,(new_fs,[]))::new_eq_rest)) + | (ffs::rfs),(fft::rft) -> + if (is_const ffs) & (is_const fft) then + (false,[]) + (* different first constants cause local fail *) + else + (* at least one of firsts is a variable *) + let (bool,new_eq_rest) = apply_subst_list r (v,slist) in + (bool,((atomnames,(new_fs,new_ft))::new_eq_rest)) + +let apply_subst eq_rest (v,slist) atomnames = + if (List.mem v atomnames) then (* don't apply subst to atom variables !! *) + (true,eq_rest) + else + apply_subst_list eq_rest (v,slist) + + +(* let all_variable_check eqlist = false needs some discussion with Jens! -- NOT done *) + +(* + let rec all_variable_check eqlist = + match eqlist with + [] -> true + | ((_,(fs,ft))::rest_eq) -> + if (fs <> []) & (ft <> []) then + let fs_first = List.hd fs + and ft_first = List.hd ft + in + if (is_const fs_first) or (is_const ft_first) then + false + else + all_variable_check rest_eq + else + false +*) + +let rec tunify_list eqlist init_sigma = + let rec tunify atomnames fs ft rt rest_eq sigma = + let apply_r1 fs ft rt rest_eq sigma = + (* print_endline "r1"; *) + tunify_list rest_eq sigma + + in + let apply_r2 fs ft rt rest_eq sigma = + (* print_endline "r2"; *) + tunify atomnames rt fs ft rest_eq sigma + + in + let apply_r3 fs ft rt rest_eq sigma = + (* print_endline "r3"; *) + let rfs = (List.tl fs) + and rft = (List.tl rt) in + tunify atomnames rfs ft rft rest_eq sigma + + in + let apply_r4 fs ft rt rest_eq sigma = + (* print_endline "r4"; *) + tunify atomnames rt ft fs rest_eq sigma + + in + let apply_r5 fs ft rt rest_eq sigma = + (* print_endline "r5"; *) + let v = (List.hd fs) in + let new_sigma = compose sigma (v,ft) in + let (bool,new_rest_eq) = apply_subst rest_eq (v,ft) atomnames in + if (bool=false) then + raise Not_unifiable + else + tunify atomnames (List.tl fs) rt rt new_rest_eq new_sigma + + in + let apply_r6 fs ft rt rest_eq sigma = + (* print_endline "r6"; *) + let v = (List.hd fs) in + let new_sigma = (compose sigma (v,[])) in + let (bool,new_rest_eq) = apply_subst rest_eq (v,[]) atomnames in + if (bool=false) then + raise Not_unifiable + else + tunify atomnames (List.tl fs) ft rt new_rest_eq new_sigma + + in + let apply_r7 fs ft rt rest_eq sigma = + (* print_endline "r7"; *) + let v = (List.hd fs) + and c1 = (List.hd rt) + and c2t =(List.tl rt) in + let new_sigma = (compose sigma (v,(ft @ [c1]))) in + let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [c1])) atomnames in + if bool=false then + raise Not_unifiable + else + tunify atomnames (List.tl fs) [] c2t new_rest_eq new_sigma + in + let apply_r8 fs ft rt rest_eq sigma = + (* print_endline "r8"; *) + tunify atomnames rt [(List.hd fs)] (List.tl fs) rest_eq sigma + + in + let apply_r9 fs ft rt rest_eq sigma = + (* print_endline "r9"; *) + let v = (List.hd fs) + and (max,subst) = sigma in + let v_new = ("vnew"^(string_of_int max)) in + let new_sigma = (compose ((max+1),subst) (v,(ft @ [v_new]))) in + let (bool,new_rest_eq) = apply_subst rest_eq (v,(ft @ [v_new])) atomnames in + if (bool=false) then + raise Not_unifiable + else + tunify atomnames rt [v_new] (List.tl fs) new_rest_eq new_sigma + + in + let apply_r10 fs ft rt rest_eq sigma = + (* print_endline "r10"; *) + let x = List.hd rt in + tunify atomnames fs (ft @ [x]) (List.tl rt) rest_eq sigma + + in + if r_1 fs ft rt then + apply_r1 fs ft rt rest_eq sigma + else if r_2 fs ft rt then + apply_r2 fs ft rt rest_eq sigma + else if r_3 fs ft rt then + apply_r3 fs ft rt rest_eq sigma + else if r_4 fs ft rt then + apply_r4 fs ft rt rest_eq sigma + else if r_5 fs ft rt then + apply_r5 fs ft rt rest_eq sigma + else if r_6 fs ft rt then + (try + apply_r6 fs ft rt rest_eq sigma + with Not_unifiable -> + if r_7 fs ft rt then (* r7 applicable if r6 was and tr6 = C2t' *) + (try + apply_r7 fs ft rt rest_eq sigma + with Not_unifiable -> + apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r6 was *) + ) + else + (* r10 could be represented only once if we would try it before r7.*) + (* but looking at the transformation rules, r10 should be tried at last in any case *) + apply_r10 fs ft rt rest_eq sigma (* r10 always applicable r6 was *) + ) + else if r_7 fs ft rt then (* not r6 and r7 possible if z <> [] *) + (try + apply_r7 fs ft rt rest_eq sigma + with Not_unifiable -> + apply_r10 fs ft rt rest_eq sigma (* r10 always applicable if r7 was *) + ) + else if r_8 fs ft rt then + (try + apply_r8 fs ft rt rest_eq sigma + with Not_unifiable -> + if r_10 fs ft rt then (* r10 applicable if r8 was and tr8 <> [] *) + apply_r10 fs ft rt rest_eq sigma + else + raise Not_unifiable (* simply back propagation *) + ) + else if r_9 fs ft rt then + (try + apply_r9 fs ft rt rest_eq sigma + with Not_unifiable -> + if r_10 fs ft rt then (* r10 applicable if r9 was and tr9 <> [] *) + apply_r10 fs ft rt rest_eq sigma + else + raise Not_unifiable (* simply back propagation *) + ) + else if r_10 fs ft rt then (* not ri, i<10, and r10 possible if for instance *) + (* (s=[] and x=v1) or (z<>[] and xt=C1V1t') *) + apply_r10 fs ft rt rest_eq sigma + else (* NO rule applicable *) + raise Not_unifiable + in + match eqlist with + [] -> + init_sigma + | f::rest_eq -> + let (atomnames,(fs,ft)) = f in + tunify atomnames fs [] ft rest_eq init_sigma + +let rec test_apply_eq atomnames eqs eqt subst = + match subst with + [] -> (eqs,eqt) + | (f,flist)::r -> + let (first_appl_eqs,first_appl_eqt) = + if List.mem f atomnames then + (eqs,eqt) + else + (apply_element eqs eqt (f,flist)) + in + test_apply_eq atomnames first_appl_eqs first_appl_eqt r + +let rec test_apply_eqsubst eqlist subst = + match eqlist with + [] -> [] + | f::r -> + let (atomnames,(eqs,eqt)) = f in + let applied_element = test_apply_eq atomnames eqs eqt subst in + (atomnames,applied_element)::(test_apply_eqsubst r subst) + +let ttest us ut ns nt eqlist orderingQ atom_rel = + let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 *) + (* to eliminate common beginning *) + let new_element = ([ns;nt],(short_us,short_ut)) in + let full_eqlist = + if List.mem new_element eqlist then + eqlist + else + new_element::eqlist + in + let sigma = tunify_list full_eqlist (1,[]) in + let (n,subst) = sigma in + let test_apply = test_apply_eqsubst full_eqlist subst in + begin + print_endline ""; + print_endline "Final equations:"; + print_equations full_eqlist; + print_endline ""; + print_endline "Final substitution:"; + print_tunify sigma; + print_endline ""; + print_endline "Applied equations:"; + print_equations test_apply + end + +let do_stringunify us ut ns nt equations = + let (short_us,short_ut) = shorten us ut in (* apply intial rule R3 to eliminate common beginning *) + let new_element = ([ns;nt],(short_us,short_ut)) in + let full_eqlist = + if List.mem new_element equations then + equations + else + new_element::equations + in +(* print_equations full_eqlist; *) + (try + let new_sigma = tunify_list full_eqlist (1,[]) in + (new_sigma,(1,full_eqlist)) + with Not_unifiable -> + raise Failed (* new connection please *) + ) + + +(* type of one unifier: int * (string * string) list *) diff --git a/contrib/jprover/jtunify.mli b/contrib/jprover/jtunify.mli new file mode 100644 index 00000000..0aabc79e --- /dev/null +++ b/contrib/jprover/jtunify.mli @@ -0,0 +1,35 @@ +exception Not_unifiable +exception Failed + +(* Utilities *) + +val is_const : string -> bool +val is_var : string -> bool +val r_1 : 'a list -> 'b list -> 'c list -> bool +val r_2 : 'a list -> 'b list -> 'c list -> bool +val r_3 : 'a list -> 'b list -> 'a list -> bool +val r_4 : string list -> 'a list -> string list -> bool +val r_5 : string list -> 'a -> 'b list -> bool +val r_6 : string list -> 'a list -> string list -> bool +val r_7 : string list -> 'a -> string list -> bool +val r_8 : string list -> 'a list -> string list -> bool +val r_9 : string list -> 'a list -> string list -> bool +val r_10 : string list -> 'a -> string list -> bool +val com_subst : 'a list -> 'a * 'a list -> 'a list + +(* Debugging *) + +val print_equations : (string list * (string list * string list)) list -> unit + +val print_tunify : int * (string * string list) list -> unit + +(* Main function *) + +val do_stringunify : string list -> + string list -> + string -> + string -> + (string list * (string list * string list)) list -> + (int * (string * string list) list) * (* unifier *) + (int * ((string list * (string list * string list)) list)) (* applied new eqlist *) + diff --git a/contrib/jprover/opname.ml b/contrib/jprover/opname.ml new file mode 100644 index 00000000..d0aa9046 --- /dev/null +++ b/contrib/jprover/opname.ml @@ -0,0 +1,90 @@ +open Printf + +type token = string +type atom = string list + +let opname_token = String.make 4 (Char.chr 0) + +type opname = + { mutable opname_token : token; + mutable opname_name : string list + } + +let (optable : (string list, opname) Hashtbl.t) = Hashtbl.create 97 + +(* * Constructors.*) +let nil_opname = { opname_token = opname_token; opname_name = [] } + +let _ = Hashtbl.add optable [] nil_opname + +let rec mk_opname s ({ opname_token = token; opname_name = name } as opname) = + if token == opname_token then + let name = s :: name in + try Hashtbl.find optable name with + Not_found -> + let op = { opname_token = opname_token; opname_name = name } in + Hashtbl.add optable name op; + op + else + mk_opname s (normalize_opname opname) + +and make_opname = function + | [] -> + nil_opname + | h :: t -> + mk_opname h (make_opname t) + +and normalize_opname opname = + if opname.opname_token == opname_token then + (* This opname is already normalized *) + opname + else + let res = make_opname opname.opname_name + in + opname.opname_name <- res.opname_name; + opname.opname_token <- opname_token; + res + +(* * Atoms are the inner string list. *) +let intern opname = + if opname.opname_token == opname_token then + opname.opname_name + else + let name = (normalize_opname opname).opname_name in + opname.opname_token <- opname_token; + opname.opname_name <- name; + name + +let eq_inner op1 op2 = + op1.opname_name <- (normalize_opname op1).opname_name; + op1.opname_token <- opname_token; + op2.opname_name <- (normalize_opname op2).opname_name; + op2.opname_token <- opname_token; + op1.opname_name == op2.opname_name + +let eq op1 op2 = + (op1.opname_name == op2.opname_name) + or ((op1.opname_token != opname_token or op2.opname_token != opname_token) & eq_inner op1 op2) + +(* * Destructor. *) +let dst_opname = function + | { opname_name = n :: name } -> n, { opname_token = opname_token; opname_name = name } + | _ -> raise (Invalid_argument "dst_opname") + +let dest_opname { opname_name = name } = + name + +let string_of_opname op = + let rec flatten = function + | [] -> + "" + | h::t -> + let rec collect s = function + | h::t -> + collect (h ^ "!" ^ s) t + | [] -> + s + in + collect h t + in + flatten op.opname_name diff --git a/contrib/jprover/opname.mli b/contrib/jprover/opname.mli new file mode 100644 index 00000000..56bf84e2 --- /dev/null +++ b/contrib/jprover/opname.mli @@ -0,0 +1,15 @@ +(* This module is extracted from Meta-Prl. *) + +type token = string +and atom = string list +val opname_token : token +type opname = { + mutable opname_token : token; + mutable opname_name : string list; +} +val nil_opname : opname +val mk_opname : string -> opname -> opname +val make_opname : string list -> opname +val eq : opname -> opname -> bool +val dest_opname : opname -> string list +val string_of_opname : opname -> string diff --git a/contrib/omega/Omega.v b/contrib/omega/Omega.v new file mode 100755 index 00000000..e72dcec2 --- /dev/null +++ b/contrib/omega/Omega.v @@ -0,0 +1,57 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(**************************************************************************) +(* *) +(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) +(* *) +(* Pierre Crégut (CNET, Lannion, France) *) +(* *) +(**************************************************************************) + +(* $Id: Omega.v,v 1.10.2.1 2004/07/16 19:30:12 herbelin Exp $ *) + +(* We do not require [ZArith] anymore, but only what's necessary for Omega *) +Require Export ZArith_base. +Require Export OmegaLemmas. + +Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l + Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l + Zmult_plus_distr_r: zarith. + +Require Export Zhints. + +(* +(* The constant minus is required in coq_omega.ml *) +Require Minus. +*) + +Hint Extern 10 (_ = _ :>nat) => abstract omega: zarith. +Hint Extern 10 (_ <= _) => abstract omega: zarith. +Hint Extern 10 (_ < _) => abstract omega: zarith. +Hint Extern 10 (_ >= _) => abstract omega: zarith. +Hint Extern 10 (_ > _) => abstract omega: zarith. + +Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith. +Hint Extern 10 (~ _ <= _) => abstract omega: zarith. +Hint Extern 10 (~ _ < _) => abstract omega: zarith. +Hint Extern 10 (~ _ >= _) => abstract omega: zarith. +Hint Extern 10 (~ _ > _) => abstract omega: zarith. + +Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith. +Hint Extern 10 (_ <= _)%Z => abstract omega: zarith. +Hint Extern 10 (_ < _)%Z => abstract omega: zarith. +Hint Extern 10 (_ >= _)%Z => abstract omega: zarith. +Hint Extern 10 (_ > _)%Z => abstract omega: zarith. + +Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith. +Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith. +Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith. +Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith. +Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith. + +Hint Extern 10 False => abstract omega: zarith.
\ No newline at end of file diff --git a/contrib/omega/OmegaLemmas.v b/contrib/omega/OmegaLemmas.v new file mode 100644 index 00000000..6f0ea2c6 --- /dev/null +++ b/contrib/omega/OmegaLemmas.v @@ -0,0 +1,269 @@ +(************************************************************************) +(* 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: OmegaLemmas.v,v 1.4.2.1 2004/07/16 19:30:12 herbelin Exp $ i*) + +Require Import ZArith_base. + +(** These are specific variants of theorems dedicated for the Omega tactic *) + +Lemma new_var : forall x:Z, exists y : Z, x = y. +intros x; exists x; trivial with arith. +Qed. + +Lemma OMEGA1 : forall x y:Z, x = y -> (0 <= x)%Z -> (0 <= y)%Z. +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. +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. + +intros x y k H1 H2 H3; apply (Zmult_integral_l k); + [ unfold not in |- *; intros H4; absurd (k > 0)%Z; + [ 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. + +unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0)%Z; + [ intros H4; cut (0 <= z * y + x)%Z; + [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6; + absurd (z * y + x > 0)%Z; + [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate + | apply Zle_gt_trans with x; + [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x); + apply Zplus_le_compat_r; rewrite Zmult_comm; + generalize H4; unfold Zgt in |- *; case y; + [ simpl in |- *; intros H7; discriminate H7 + | intros p H7; rewrite <- (Zmult_0_r (Zpos p)); + unfold Zle in |- *; rewrite Zcompare_mult_compat; + exact H6 + | simpl in |- *; intros p H7; discriminate H7 ] + | assumption ] ] + | rewrite H3; unfold Zle in |- *; simpl in |- *; discriminate ] + | apply Zgt_trans with x; [ assumption | assumption ] ]. +Qed. + +Lemma OMEGA5 : forall x y z:Z, x = 0%Z -> y = 0%Z -> (x + y * z)%Z = 0%Z. + +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. + +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. + +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. + +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; + 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. + +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. + +intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + rewrite (Zplus_permute (l1 * k1) (v * c2 * k2)); trivial with arith. +Qed. + +Lemma OMEGA11 : + forall v1 c1 l1 l2 k1:Z, + ((v1 * c1 + l1) * k1 + l2)%Z = (v1 * (c1 * k1) + (l1 * k1 + l2))%Z. + +intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + trivial with arith. +Qed. + +Lemma OMEGA12 : + forall v2 c2 l1 l2 k2:Z, + (l1 + (v2 * c2 + l2) * k2)%Z = (v2 * (c2 * k2) + (l1 + l2 * k2))%Z. + +intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + rewrite Zplus_permute; trivial with arith. +Qed. + +Lemma OMEGA13 : + forall (v l1 l2:Z) (x:positive), + (v * Zpos x + l1 + (v * Zneg x + l2))%Z = (l1 + l2)%Z. + +intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1); + rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r; + rewrite <- Zopp_neg; rewrite (Zplus_comm (- Zneg x) (Zneg x)); + rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r; + trivial with arith. +Qed. + +Lemma OMEGA14 : + forall (v l1 l2:Z) (x:positive), + (v * Zneg x + l1 + (v * Zpos x + l2))%Z = (l1 + l2)%Z. + +intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1); + rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r; + rewrite <- Zopp_neg; rewrite Zplus_opp_r; rewrite Zmult_0_r; + rewrite Zplus_0_r; trivial with arith. +Qed. +Lemma OMEGA15 : + forall v c1 c2 l1 l2 k2:Z, + (v * c1 + l1 + (v * c2 + l2) * k2)%Z = + (v * (c1 + c2 * k2) + (l1 + l2 * k2))%Z. + +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. + +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. + +unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; + apply Zplus_reg_l with (y * z)%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. + +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. + +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; + rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption + | intros H2; absurd (x = 0%Z); 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. + +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_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_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_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_OMEGA10 (v c1 c2 l1 l2 k1 k2:Z) (P:Z -> Prop) + (H:P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))%Z) := + 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) := + 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) := + 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) := + 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_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_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_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_Zmult_sym (x y:Z) (P:Z -> Prop) (H:P (y * x)%Z) := + 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_Zopp (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_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_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_Zred_factor1 (x:Z) (P:Z -> Prop) (H:P (x * 2)%Z) := + 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_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_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)%Z) := + eq_ind_r P H (Zred_factor6 x). diff --git a/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml new file mode 100644 index 00000000..7a20aeb6 --- /dev/null +++ b/contrib/omega/coq_omega.ml @@ -0,0 +1,1783 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(**************************************************************************) +(* *) +(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) +(* *) +(* Pierre Crégut (CNET, Lannion, France) *) +(* *) +(**************************************************************************) + +(* $Id: coq_omega.ml,v 1.59.2.3 2004/07/16 19:30:12 herbelin Exp $ *) + +open Util +open Pp +open Reduction +open Proof_type +open Ast +open Names +open Nameops +open Term +open Termops +open Declarations +open Environ +open Sign +open Inductive +open Tacticals +open Tacmach +open Evar_refiner +open Tactics +open Clenv +open Logic +open Libnames +open Nametab +open Omega +open Contradiction + +(* Added by JCF, 09/03/98 *) + +let elim_id id gl = simplest_elim (pf_global gl id) gl +let resolve_id id gl = apply (pf_global gl id) gl + +let timing timer_name f arg = f arg + +let display_time_flag = ref false +let display_system_flag = ref false +let display_action_flag = ref false +let old_style_flag = ref false + +let read f () = !f +let write f x = f:=x + +open Goptions + +(* 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; + optname = "Omega system time displaying flag"; + optkey = SecondaryTable ("Omega","System"); + optread = read display_system_flag; + optwrite = write display_system_flag } + +let _ = + declare_bool_option + { optsync = false; + optname = "Omega action display flag"; + optkey = SecondaryTable ("Omega","Action"); + optread = read display_action_flag; + optwrite = write display_action_flag } + +let _ = + declare_bool_option + { optsync = false; + optname = "Omega old style flag"; + optkey = SecondaryTable ("Omega","OldStyle"); + optread = read old_style_flag; + optwrite = write old_style_flag } + + +let all_time = timing "Omega " +let solver_time = timing "Solver " +let exact_time = timing "Rewrites " +let elim_time = timing "Elim " +let simpl_time = timing "Simpl " +let generalize_time = timing "Generalize" + +let new_identifier = + let cpt = ref 0 in + (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s) + +let new_identifier_state = + let cpt = ref 0 in + (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s) + +let new_identifier_var = + let cpt = ref 0 in + (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s) + +let mk_then = tclTHENLIST + +let exists_tac c = constructor_tac (Some 1) 1 (Rawterm.ImplicitBindings [c]) + +let generalize_tac t = generalize_time (generalize t) +let elim t = elim_time (simplest_elim t) +let exact t = exact_time (Tactics.refine t) +let unfold s = Tactics.unfold_in_concl [[], Lazy.force s] + +let rev_assoc k = + let rec loop = function + | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l + in + loop + +let tag_hypothesis,tag_of_hyp, hyp_of_tag = + let l = ref ([]:(identifier * int) list) in + (fun h id -> l := (h,id):: !l), + (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"), + (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis") + +let hide_constr,find_constr,clear_tables,dump_tables = + let l = ref ([]:(constr * (identifier * identifier * bool)) list) in + (fun h id eg b -> l := (h,(id,eg,b)):: !l), + (fun h -> try List.assoc h !l with Not_found -> failwith "find_contr"), + (fun () -> l := []), + (fun () -> !l) + +(* Lazy evaluation is used for Coq constants, because this code + is evaluated before the compiled modules are loaded. + To use the constant Zplus, one must type "Lazy.force coq_Zplus" + This is the right way to access to Coq constants in tactics ML code *) + +open Coqlib + +let logic_dir = ["Coq";"Logic";"Decidable"] +let coq_modules = + init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules + @ [["Coq"; "omega"; "OmegaLemmas"]] + +let constant = gen_constant_in_modules "Omega" coq_modules + +(* Zarith *) +let coq_xH = lazy (constant "xH") +let coq_xO = lazy (constant "xO") +let coq_xI = lazy (constant "xI") +let coq_ZERO = lazy (constant (if !Options.v7 then "ZERO" else "Z0")) +let coq_POS = lazy (constant (if !Options.v7 then "POS" else "Zpos")) +let coq_NEG = lazy (constant (if !Options.v7 then "NEG" else "Zneg")) +let coq_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_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_Zgt = lazy (constant "Zgt") +let coq_Zle = lazy (constant "Zle") +let coq_inject_nat = lazy (constant "inject_nat") +let coq_inj_plus = lazy (constant "inj_plus") +let coq_inj_mult = lazy (constant "inj_mult") +let coq_inj_minus1 = lazy (constant "inj_minus1") +let coq_inj_minus2 = lazy (constant "inj_minus2") +let coq_inj_S = lazy (constant "inj_S") +let coq_inj_le = lazy (constant "inj_le") +let coq_inj_lt = lazy (constant "inj_lt") +let coq_inj_ge = lazy (constant "inj_ge") +let coq_inj_gt = lazy (constant "inj_gt") +let coq_inj_neq = lazy (constant "inj_neq") +let coq_inj_eq = lazy (constant "inj_eq") +let coq_fast_Zplus_assoc_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_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_Zmult_le_approx = lazy (constant "Zmult_le_approx") +let coq_OMEGA1 = lazy (constant "OMEGA1") +let coq_OMEGA2 = lazy (constant "OMEGA2") +let coq_OMEGA3 = lazy (constant "OMEGA3") +let coq_OMEGA4 = lazy (constant "OMEGA4") +let coq_OMEGA5 = lazy (constant "OMEGA5") +let coq_OMEGA6 = lazy (constant "OMEGA6") +let coq_OMEGA7 = lazy (constant "OMEGA7") +let coq_OMEGA8 = lazy (constant "OMEGA8") +let coq_OMEGA9 = lazy (constant "OMEGA9") +let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10") +let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11") +let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12") +let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13") +let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14") +let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15") +let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16") +let coq_OMEGA17 = lazy (constant "OMEGA17") +let coq_OMEGA18 = lazy (constant "OMEGA18") +let coq_OMEGA19 = lazy (constant "OMEGA19") +let coq_OMEGA20 = lazy (constant "OMEGA20") +let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0") +let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1") +let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2") +let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3") +let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4") +let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5") +let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6") +let coq_fast_Zmult_plus_distr = 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_Zegal_left = lazy (constant "Zegal_left") +let coq_Zne_left = lazy (constant "Zne_left") +let coq_Zlt_left = lazy (constant "Zlt_left") +let coq_Zge_left = lazy (constant "Zge_left") +let coq_Zgt_left = lazy (constant "Zgt_left") +let coq_Zle_left = lazy (constant "Zle_left") +let coq_new_var = lazy (constant "new_var") +let coq_intro_Z = lazy (constant "intro_Z") + +let coq_dec_eq = lazy (constant "dec_eq") +let coq_dec_Zne = lazy (constant "dec_Zne") +let coq_dec_Zle = lazy (constant "dec_Zle") +let coq_dec_Zlt = lazy (constant "dec_Zlt") +let coq_dec_Zgt = lazy (constant "dec_Zgt") +let coq_dec_Zge = lazy (constant "dec_Zge") + +let coq_not_Zeq = lazy (constant "not_Zeq") +let coq_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_neq = lazy (constant "neq") +let coq_Zne = lazy (constant "Zne") +let coq_Zle = lazy (constant "Zle") +let coq_Zgt = lazy (constant "Zgt") +let coq_Zge = lazy (constant "Zge") +let coq_Zlt = lazy (constant "Zlt") + +(* Peano/Datatypes *) +let coq_le = lazy (constant "le") +let coq_lt = lazy (constant "lt") +let coq_ge = lazy (constant "ge") +let coq_gt = lazy (constant "gt") +let coq_minus = lazy (constant "minus") +let coq_plus = lazy (constant "plus") +let coq_mult = lazy (constant "mult") +let coq_pred = lazy (constant "pred") +let coq_nat = lazy (constant "nat") +let coq_S = lazy (constant "S") +let coq_O = lazy (constant "O") + +(* Compare_dec/Peano_dec/Minus *) +let coq_pred_of_minus = lazy (constant "pred_of_minus") +let coq_le_gt_dec = lazy (constant "le_gt_dec") +let coq_dec_eq_nat = lazy (constant "dec_eq_nat") +let coq_dec_le = lazy (constant "dec_le") +let coq_dec_lt = lazy (constant "dec_lt") +let coq_dec_ge = lazy (constant "dec_ge") +let coq_dec_gt = lazy (constant "dec_gt") +let coq_not_eq = lazy (constant "not_eq") +let coq_not_le = lazy (constant "not_le") +let coq_not_lt = lazy (constant "not_lt") +let coq_not_ge = lazy (constant "not_ge") +let coq_not_gt = lazy (constant "not_gt") + +(* Logic/Decidable *) +let coq_eq_ind_r = lazy (constant "eq_ind_r") + +let coq_dec_or = lazy (constant "dec_or") +let coq_dec_and = lazy (constant "dec_and") +let coq_dec_imp = lazy (constant "dec_imp") +let coq_dec_not = lazy (constant "dec_not") +let coq_dec_False = lazy (constant "dec_False") +let coq_dec_not_not = lazy (constant "dec_not_not") +let coq_dec_True = lazy (constant "dec_True") + +let coq_not_or = lazy (constant "not_or") +let coq_not_and = lazy (constant "not_and") +let coq_not_imp = lazy (constant "not_imp") +let coq_not_not = lazy (constant "not_not") +let coq_imp_simp = lazy (constant "imp_simp") + +(* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) + +(* For unfold *) +open Closure +let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with + | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> + EvalConstRef kn + | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant") + +let sp_Zs = lazy (evaluable_ref_of_constr "Zs" coq_Zs) +let sp_Zminus = lazy (evaluable_ref_of_constr "Zminus" coq_Zminus) +let sp_Zle = lazy (evaluable_ref_of_constr "Zle" coq_Zle) +let sp_Zgt = lazy (evaluable_ref_of_constr "Zgt" coq_Zgt) +let sp_Zge = lazy (evaluable_ref_of_constr "Zge" coq_Zge) +let sp_Zlt = lazy (evaluable_ref_of_constr "Zlt" coq_Zlt) +let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ()))) + +let mk_var v = mkVar (id_of_string v) +let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) +let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) +let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) +let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |]) +let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) +let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) +let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) +let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) +let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) +let mk_not t = mkApp (build_coq_not (), [| t |]) +let mk_eq_rel t1 t2 = mkApp (build_coq_eq (), + [| Lazy.force coq_relation; t1; t2 |]) +let mk_inj t = mkApp (Lazy.force coq_inject_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) |]) + in + if n = 0 then Lazy.force coq_ZERO + else mkApp ((if n > 0 then Lazy.force coq_POS else Lazy.force coq_NEG), + [| loop (abs n) |]) + +type omega_constant = + | Zplus | Zmult | Zminus | Zs | Zopp + | Plus | Mult | Minus | Pred | S | O + | POS | NEG | ZERO | Inject_nat + | Eq | Neq + | Zne | Zle | Zlt | Zge | Zgt + | Z | Nat + | And | Or | False | True | Not + | Le | Lt | Ge | Gt + | Other of string + +type omega_proposition = + | Keq of constr * constr * constr + | Kn + +type result = + | Kvar of identifier + | Kapp of omega_constant * constr list + | Kimp of constr * constr + | Kufo + +let destructurate_prop t = + let c, args = decompose_app t in + match kind_of_term c, args with + | _, [_;_;_] when c = build_coq_eq () -> Kapp (Eq,args) + | _, [_;_] when c = Lazy.force coq_neq -> Kapp (Neq,args) + | _, [_;_] when c = Lazy.force coq_Zne -> Kapp (Zne,args) + | _, [_;_] when c = Lazy.force coq_Zle -> Kapp (Zle,args) + | _, [_;_] when c = Lazy.force coq_Zlt -> Kapp (Zlt,args) + | _, [_;_] when c = Lazy.force coq_Zge -> Kapp (Zge,args) + | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args) + | _, [_;_] when c = build_coq_and () -> Kapp (And,args) + | _, [_;_] when c = build_coq_or () -> Kapp (Or,args) + | _, [_] when c = build_coq_not () -> Kapp (Not,args) + | _, [] when c = build_coq_False () -> Kapp (False,args) + | _, [] when c = build_coq_True () -> Kapp (True,args) + | _, [_;_] when c = Lazy.force coq_le -> Kapp (Le,args) + | _, [_;_] when c = Lazy.force coq_lt -> Kapp (Lt,args) + | _, [_;_] when c = Lazy.force coq_ge -> Kapp (Ge,args) + | _, [_;_] when c = Lazy.force coq_gt -> Kapp (Gt,args) + | Const sp, args -> + Kapp (Other (string_of_id (id_of_global (ConstRef sp))),args) + | Construct csp , args -> + Kapp (Other (string_of_id (id_of_global (ConstructRef csp))), args) + | Ind isp, args -> + Kapp (Other (string_of_id (id_of_global (IndRef isp))),args) + | Var id,[] -> Kvar id + | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) + | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" + | _ -> Kufo + +let destructurate_type t = + let c, args = decompose_app t in + match kind_of_term c, args with + | _, [] when c = Lazy.force coq_Z -> Kapp (Z,args) + | _, [] when c = Lazy.force coq_nat -> Kapp (Nat,args) + | _ -> Kufo + +let destructurate_term t = + let c, args = decompose_app t in + match kind_of_term c, args with + | _, [_;_] when c = Lazy.force coq_Zplus -> Kapp (Zplus,args) + | _, [_;_] when c = Lazy.force coq_Zmult -> Kapp (Zmult,args) + | _, [_;_] when c = Lazy.force coq_Zminus -> Kapp (Zminus,args) + | _, [_] when c = Lazy.force coq_Zs -> Kapp (Zs,args) + | _, [_] when c = Lazy.force coq_Zopp -> Kapp (Zopp,args) + | _, [_;_] when c = Lazy.force coq_plus -> Kapp (Plus,args) + | _, [_;_] when c = Lazy.force coq_mult -> Kapp (Mult,args) + | _, [_;_] when c = Lazy.force coq_minus -> Kapp (Minus,args) + | _, [_] when c = Lazy.force coq_pred -> Kapp (Pred,args) + | _, [_] when c = Lazy.force coq_S -> Kapp (S,args) + | _, [] when c = Lazy.force coq_O -> Kapp (O,args) + | _, [_] when c = Lazy.force coq_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) + | 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 + | _ -> 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 + | _ -> failwith "not a number" + +type constr_path = + | P_APP of int + (* Abstraction and product *) + | P_BODY + | P_TYPE + (* Case *) + | P_BRANCH of int + | P_ARITY + | P_ARG + +let context operation path (t : constr) = + let rec loop i p0 t = + match (p0,kind_of_term t) with + | (p, Cast (c,t)) -> mkCast (loop i p c,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') + | ((P_BRANCH n :: p), Case (ci,q,c,v)) -> + (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *) + let v' = Array.copy v in + v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v')) + | ((P_ARITY :: p), App (f,l)) -> + appvect (loop i p f,l) + | ((P_ARG :: p), App (f,v)) -> + let v' = Array.copy v in + v'.(0) <- loop i p v'.(0); mkApp (f,v') + | (p, Fix ((_,n as ln),(tys,lna,v))) -> + let l = Array.length v in + let v' = Array.copy v in + v'.(n) <- loop (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)) + | ((P_BODY :: p), Lambda (n,t,c)) -> + (mkLambda (n,t,loop (i+1) p c)) + | ((P_BODY :: p), LetIn (n,b,t,c)) -> + (mkLetIn (n,b,t,loop (i+1) p c)) + | ((P_TYPE :: p), Prod (n,t,c)) -> + (mkProd (n,loop i p t,c)) + | ((P_TYPE :: p), Lambda (n,t,c)) -> + (mkLambda (n,loop i p t,c)) + | ((P_TYPE :: p), LetIn (n,b,t,c)) -> + (mkLetIn (n,b,loop i p t,c)) + | (p, _) -> + ppnl (Printer.prterm 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 + | ([], _) -> t + | ((P_APP n :: p), App (f,v)) -> loop p v.(n-1) + | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n) + | ((P_ARITY :: p), App (f,_)) -> loop p f + | ((P_ARG :: p), App (f,v)) -> loop p v.(0) + | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n) + | ((P_BODY :: p), Prod (n,t,c)) -> loop p c + | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c + | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c + | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term + | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term + | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term + | (p, _) -> + ppnl (Printer.prterm t); + failwith ("occurence " ^ string_of_int(List.length p)) + in + loop path t + +let abstract_path typ path t = + let term_occur = ref (mkRel 0) in + let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in + mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur + +let focused_simpl path gl = + let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in + convert_concl_no_check newc gl + +let focused_simpl path = simpl_time (focused_simpl path) + +type oformula = + | Oplus of oformula * oformula + | Oinv of oformula + | Otimes of oformula * oformula + | Oatom of identifier + | Oz of int + | Oufo of constr + +let rec oprint = function + | Oplus(t1,t2) -> + print_string "("; oprint t1; print_string "+"; + oprint t2; print_string ")" + | Oinv t -> print_string "~"; oprint t + | Otimes (t1,t2) -> + print_string "("; oprint t1; print_string "*"; + oprint t2; print_string ")" + | Oatom s -> print_string (string_of_id s) + | Oz i -> print_int i + | Oufo f -> print_string "?" + +let rec weight = function + | Oatom c -> intern_id c + | Oz _ -> -1 + | Oinv c -> weight c + | Otimes(c,_) -> weight c + | Oplus _ -> failwith "weight" + | Oufo _ -> -1 + +let rec val_of = function + | Oatom c -> mkVar c + | Oz c -> mk_integer c + | Oinv c -> mkApp (Lazy.force coq_Zopp, [| val_of c |]) + | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |]) + | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) + | Oufo c -> c + +let compile name kind = + let rec loop accu = function + | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r + | Oz n -> + let id = new_id () in + tag_hypothesis name id; + {kind = kind; body = List.rev accu; constant = n; id = id} + | _ -> anomaly "compile_equation" + in + loop [] + +let rec decompile af = + let rec loop = function + | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) + | [] -> Oz af.constant + in + loop af.body + +let mkNewMeta () = mkMeta (Clenv.new_meta()) + +let clever_rewrite_base_poly typ p result theorem gl = + let full = pf_concl gl in + let (abstracted,occ) = abstract_path typ (List.rev p) full in + let t = + applist + (mkLambda + (Name (id_of_string "P"), + mkArrow typ mkProp, + mkLambda + (Name (id_of_string "H"), + applist (mkRel 1,[result]), + mkApp (Lazy.force coq_eq_ind_r, + [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), + [abstracted]) + in + exact (applist(t,[mkNewMeta()])) gl + +let clever_rewrite_base p result theorem gl = + clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl + +let clever_rewrite_base_nat p result theorem gl = + clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl + +let clever_rewrite_gen p result (t,args) = + let theorem = applist(t, args) in + clever_rewrite_base p result theorem + +let clever_rewrite_gen_nat p result (t,args) = + let theorem = applist(t, args) in + clever_rewrite_base_nat p result theorem + +let clever_rewrite p vpath t gl = + let full = pf_concl gl in + let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in + let vargs = List.map (fun p -> occurence p occ) vpath in + let t' = applist(t, (vargs @ [abstracted])) in + exact (applist(t',[mkNewMeta()])) gl + +let rec shuffle p (t1,t2) = + match t1,t2 with + | Oplus(l1,r1), Oplus(l2,r2) -> + if weight l1 > weight l2 then + let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in + (clever_rewrite p [[P_APP 1;P_APP 1]; + [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_r) + :: tac, + Oplus(l1,t')) + else + let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in + (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zplus_permute) + :: tac, + Oplus(l2,t')) + | Oplus(l1,r1), t2 -> + if weight l1 > weight t2 then + let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in + clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_r) + :: tac, + Oplus(l1, t') + else + [clever_rewrite p [[P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zplus_sym)], + Oplus(t2,t1) + | t1,Oplus(l2,r2) -> + if weight l2 > weight t1 then + let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in + clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zplus_permute) + :: tac, + Oplus(l2,t') + else [],Oplus(t1,t2) + | Oz t1,Oz t2 -> + [focused_simpl p], Oz(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)], + Oplus(t2,t1) + else [],Oplus(t1,t2) + +let rec shuffle_mult p_init k1 e1 k2 e2 = + let rec loop p = function + | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> + if v1 = v2 then + let tac = + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA10) + in + if k1*c1 + k2 * c2 = 0 then + let tac' = + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zred_factor5) in + tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: + loop p (l1,l2) + else tac :: loop (P_APP 2 :: p) (l1,l2) + else if v1 > v2 then + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2]; + [P_APP 1; P_APP 2]] + (Lazy.force coq_fast_OMEGA11) :: + loop (P_APP 2 :: p) (l1,l2') + else + clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA12) :: + loop (P_APP 2 :: p) (l1',l2) + | ({c=c1;v=v1}::l1), [] -> + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2]; + [P_APP 1; P_APP 2]] + (Lazy.force coq_fast_OMEGA11) :: + loop (P_APP 2 :: p) (l1,[]) + | [],({c=c2;v=v2}::l2) -> + clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA12) :: + loop (P_APP 2 :: p) ([],l2) + | [],[] -> [focused_simpl p_init] + in + loop p_init (e1,e2) + +let rec shuffle_mult_right p_init e1 k2 e2 = + let rec loop p = function + | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> + if v1 = v2 then + let tac = + clever_rewrite p + [[P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 2]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA15) + in + if c1 + k2 * c2 = 0 then + let tac' = + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zred_factor5) + in + tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: + loop p (l1,l2) + else tac :: loop (P_APP 2 :: p) (l1,l2) + else if v1 > v2 then + clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_r) :: + loop (P_APP 2 :: p) (l1,l2') + else + clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA12) :: + loop (P_APP 2 :: p) (l1',l2) + | ({c=c1;v=v1}::l1), [] -> + clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_r) :: + loop (P_APP 2 :: p) (l1,[]) + | [],({c=c2;v=v2}::l2) -> + clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1]; + [P_APP 2; P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]] + (Lazy.force coq_fast_OMEGA12) :: + loop (P_APP 2 :: p) ([],l2) + | [],[] -> [focused_simpl p_init] + in + loop p_init (e1,e2) + +let rec shuffle_cancel p = function + | [] -> [focused_simpl p] + | ({c=c1}::l1) -> + let tac = + clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; + [P_APP 2; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] + (if c1 > 0 then + (Lazy.force coq_fast_OMEGA13) + else + (Lazy.force coq_fast_OMEGA14)) + in + tac :: shuffle_cancel p l1 + +let rec scalar p n = function + | Oplus(t1,t2) -> + let tac1,t1' = scalar (P_APP 1 :: p) n t1 and + tac2,t2' = scalar (P_APP 2 :: p) n t2 in + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zmult_plus_distr) :: + (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)) + | 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); + focused_simpl (P_APP 2 :: p)], + Otimes(t1,Oz (n*x)) + | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" + | (Oatom _ as t) -> [], Otimes(t,Oz n) + | Oz i -> [focused_simpl p],Oz(n*i) + | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) + +let rec scalar_norm p_init = + let rec loop p = function + | [] -> [focused_simpl p_init] + | (_::l) -> + clever_rewrite p + [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l + in + loop p_init + +let rec norm_add p_init = + let rec loop p = function + | [] -> [focused_simpl p_init] + | _:: l -> + clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_r) :: + loop (P_APP 2 :: p) l + in + loop p_init + +let rec scalar_norm_add p_init = + let rec loop p = function + | [] -> [focused_simpl p_init] + | _ :: l -> + clever_rewrite p + [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; + [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; + [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] + (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l + in + loop p_init + +let rec negate p = function + | Oplus(t1,t2) -> + let tac1,t1' = negate (P_APP 1 :: p) t1 and + tac2,t2' = negate (P_APP 2 :: p) t2 in + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] + (Lazy.force coq_fast_Zopp_Zplus) :: + (tac1 @ tac2), + Oplus(t1',t2') + | Oinv t -> + [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_Zopp)], 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)) + | 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) + | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) + +let rec transform p t = + let default () = + 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 false; + [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v + in + try match destructurate_term t with + | Kapp(Zplus,[t1;t2]) -> + let tac1,t1' = transform (P_APP 1 :: p) t1 + and tac2,t2' = transform (P_APP 2 :: p) t2 in + let tac,t' = shuffle p (t1',t2') in + tac1 @ tac2 @ tac, t' + | Kapp(Zminus,[t1;t2]) -> + let tac,t = + transform p + (mkApp (Lazy.force coq_Zplus, + [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in + unfold sp_Zminus :: tac,t + | Kapp(Zs,[t1]) -> + let tac,t = transform p (mkApp (Lazy.force coq_Zplus, + [| t1; mk_integer 1 |])) in + unfold sp_Zs :: tac,t + | Kapp(Zmult,[t1;t2]) -> + let tac1,t1' = transform (P_APP 1 :: p) t1 + and tac2,t2' = transform (P_APP 2 :: p) t2 in + begin match t1',t2' with + | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' + | (Oz n,_) -> + let sym = + clever_rewrite p [[P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zmult_sym) in + let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' + | _ -> default () + end + | Kapp((POS|NEG|ZERO),_) -> + (try ([],Oz(recognize_number t)) with _ -> default ()) + | 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 () + +let shrink_pair p f1 f2 = + match f1,f2 with + | Oatom v,Oatom _ -> + let r = Otimes(Oatom v,Oz 2) 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 + 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 + clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] + (Lazy.force coq_fast_Zred_factor3), r + | Otimes (Oatom v,c1),Otimes (v2,c2) -> + let r = Otimes(Oatom v,Oplus(c1,c2)) in + clever_rewrite p + [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zred_factor4),r + | t1,t2 -> + begin + oprint t1; print_newline (); oprint t2; print_newline (); + flush Pervasives.stdout; error "shrink.1" + end + +let reduce_factor p = function + | Oatom v -> + let r = Otimes(Oatom v,Oz 1) 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 + | _ -> error "condense.1" + in + [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) + | t -> oprint t; error "reduce_factor.1" + +let rec condense p = function + | Oplus(f1,(Oplus(f2,r) as t)) -> + if weight f1 = weight f2 then begin + let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in + let assoc_tac = + clever_rewrite p + [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] + (Lazy.force coq_fast_Zplus_assoc_l) in + let tac_list,t' = condense p (Oplus(t,r)) in + (assoc_tac :: shrink_tac :: tac_list), t' + end else begin + let tac,f = reduce_factor (P_APP 1 :: p) f1 in + let tac',t' = condense (P_APP 2 :: p) t in + (tac @ tac'), Oplus(f,t') + end + | Oplus(f1,Oz n) as t -> + let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) + | Oplus(f1,f2) -> + if weight f1 = weight f2 then begin + let tac_shrink,t = shrink_pair p f1 f2 in + let tac,t' = condense p t in + tac_shrink :: tac,t' + end else begin + let tac,f = reduce_factor (P_APP 1 :: p) f1 in + let tac',t' = condense (P_APP 2 :: p) f2 in + (tac @ tac'),Oplus(f,t') + end + | Oz _ as t -> [],t + | t -> + let tac,t' = reduce_factor p t in + let final = Oplus(t',Oz 0) 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) -> + let tac = + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + (Lazy.force coq_fast_Zred_factor5) in + let tac',t = clear_zero p r in + tac :: tac',t + | Oplus(f,r) -> + let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) + | t -> [],t + +let replay_history tactic_normalisation = + let aux = id_of_string "auxiliary" in + let aux1 = id_of_string "auxiliary_1" in + let aux2 = id_of_string "auxiliary_2" in + let zero = mk_integer 0 in + let rec loop t = + match t with + | HYP e :: l -> + begin + try + tclTHEN + (List.assoc (hyp_of_tag e.id) tactic_normalisation) + (loop l) + with Not_found -> loop l end + | NEGATE_CONTRADICT (e2,e1,b) :: l -> + let eq1 = decompile e1 + and eq2 = decompile e2 in + let id1 = hyp_of_tag e1.id + and id2 = hyp_of_tag e2.id in + let k = if b then (-1) else 1 in + let p_initial = [P_APP 1;P_TYPE] in + let tac= shuffle_mult_right p_initial e1.body k e2.body in + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA17, [| + val_of eq1; + val_of eq2; + mk_integer k; + mkVar id1; mkVar id2 |])]); + (mk_then tac); + (intros_using [aux]); + (resolve_id aux); + reflexivity + ] + | CONTRADICTION (e1,e2) :: l -> + let eq1 = decompile e1 + and eq2 = decompile e2 in + let p_initial = [P_APP 2;P_TYPE] in + let tac = shuffle_cancel p_initial e1.body in + let solve_le = + let 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 |]) + in + tclTHENS + (tclTHENLIST [ + (unfold sp_Zle); + (simpl_in_concl); + intro; + (absurd not_sup_sup) ]) + [ assumption ; reflexivity ] + in + let theorem = + mkApp (Lazy.force coq_OMEGA2, [| + val_of eq1; val_of eq2; + mkVar (hyp_of_tag e1.id); + mkVar (hyp_of_tag e2.id) |]) + in + tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le) + | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> + let id = hyp_of_tag e1.id in + let eq1 = val_of(decompile e1) + and eq2 = val_of(decompile e2) in + let kk = mk_integer k + and dd = mk_integer d in + let rhs = mk_plus (mk_times eq2 kk) dd in + let state_eg = mk_eq eq1 rhs in + let tac = scalar_norm_add [P_APP 3] e2.body in + tclTHENS + (cut state_eg) + [ tclTHENS + (tclTHENLIST [ + (intros_using [aux]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA1, + [| eq1; rhs; mkVar aux; mkVar id |])]); + (clear [aux;id]); + (intros_using [id]); + (cut (mk_gt kk dd)) ]) + [ tclTHENS + (cut (mk_gt kk zero)) + [ tclTHENLIST [ + (intros_using [aux1; aux2]); + (generalize_tac + [mkApp (Lazy.force coq_Zmult_le_approx, + [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); + (clear [aux1;aux2;id]); + (intros_using [id]); + (loop l) ]; + tclTHENLIST [ + (unfold sp_Zgt); + (simpl_in_concl); + reflexivity ] ]; + tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] + ]; + tclTHEN (mk_then tac) reflexivity ] + + | NOT_EXACT_DIVIDE (e1,k) :: l -> + let id = hyp_of_tag e1.id in + let c = floor_div e1.constant k in + let d = e1.constant - 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 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)) + [ tclTHENS (cut (mk_gt kk dd)) + [tclTHENLIST [ + (intros_using [aux2;aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA4, + [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); + (clear [aux1;aux2]); + (unfold sp_not); + (intros_using [aux]); + (resolve_id aux); + (mk_then tac); + assumption ] ; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ]; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ] + | EXACT_DIVIDE (e1,k) :: l -> + let id = hyp_of_tag e1.id in + let e2 = map_eq_afine (fun c -> c / k) e1 in + let eq1 = val_of(decompile e1) + and eq2 = val_of(decompile e2) in + let kk = mk_integer k in + let state_eq = mk_eq eq1 (mk_times eq2 kk) in + if e1.kind = DISE then + let tac = scalar_norm [P_APP 3] e2.body in + tclTHENS + (cut state_eq) + [tclTHENLIST [ + (intros_using [aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA18, + [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); + (clear [aux1;id]); + (intros_using [id]); + (loop l) ]; + tclTHEN (mk_then tac) reflexivity ] + else + let tac = scalar_norm [P_APP 3] e2.body in + tclTHENS (cut state_eq) + [ + tclTHENS + (cut (mk_gt kk zero)) + [tclTHENLIST [ + (intros_using [aux2;aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA3, + [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); + (clear [aux1;aux2;id]); + (intros_using [id]); + (loop l) ]; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ]; + tclTHEN (mk_then tac) reflexivity ] + | (MERGE_EQ(e3,e1,e2)) :: l -> + let id = new_identifier () in + tag_hypothesis id e3; + let id1 = hyp_of_tag e1.id + and id2 = hyp_of_tag e2 in + let eq1 = val_of(decompile e1) + and eq2 = val_of (decompile (negate_eq e1)) in + let tac = + clever_rewrite [P_APP 3] [[P_APP 1]] + (Lazy.force coq_fast_Zopp_one) :: + scalar_norm [P_APP 3] e1.body + in + tclTHENS + (cut (mk_eq eq1 (mk_inv eq2))) + [tclTHENLIST [ + (intros_using [aux]); + (generalize_tac [mkApp (Lazy.force coq_OMEGA8, + [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); + (clear [id1;id2;aux]); + (intros_using [id]); + (loop l) ]; + tclTHEN (mk_then tac) reflexivity] + + | STATE(new_eq,def,orig,m,sigma) :: l -> + let id = new_identifier () + and id2 = hyp_of_tag orig.id in + tag_hypothesis id new_eq.id; + let eq1 = val_of(decompile def) + and eq2 = val_of(decompile orig) in + let vid = unintern_id sigma in + let theorem = + mkApp (build_coq_ex (), [| + Lazy.force coq_Z; + mkLambda + (Name vid, + Lazy.force coq_Z, + mk_eq (mkRel 1) eq1) |]) + in + let mm = mk_integer m in + let p_initial = [P_APP 2;P_TYPE] in + let 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) :: + shuffle_mult_right p_initial + orig.body m ({c= -1;v=sigma}::def.body) in + tclTHENS + (cut theorem) + [tclTHENLIST [ + (intros_using [aux]); + (elim_id aux); + (clear [aux]); + (intros_using [vid; aux]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA9, + [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); + (mk_then tac); + (clear [aux]); + (intros_using [id]); + (loop l) ]; + tclTHEN (exists_tac eq1) reflexivity ] + | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> + let id1 = new_identifier () + and id2 = new_identifier () in + tag_hypothesis id1 e1; tag_hypothesis id2 e2; + let id = hyp_of_tag e.id in + let tac1 = norm_add [P_APP 2;P_TYPE] e.body in + let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in + let eq = val_of(decompile e) in + tclTHENS + (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) + [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ]; + tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]] + | SUM(e3,(k1,e1),(k2,e2)) :: l -> + let id = new_identifier () in + tag_hypothesis id e3; + let id1 = hyp_of_tag e1.id + and id2 = hyp_of_tag e2.id in + let eq1 = val_of(decompile e1) + and eq2 = val_of(decompile e2) in + if k1 = 1 & e2.kind = EQUA then + let tac_thm = + match e1.kind with + | EQUA -> Lazy.force coq_OMEGA5 + | INEQ -> Lazy.force coq_OMEGA6 + | DISE -> Lazy.force coq_OMEGA20 + in + let kk = mk_integer k2 in + let p_initial = + if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in + let tac = shuffle_mult_right p_initial e1.body k2 e2.body in + tclTHENLIST [ + (generalize_tac + [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); + (mk_then tac); + (intros_using [id]); + (loop l) + ] + else + let kk1 = mk_integer k1 + and kk2 = mk_integer k2 in + let p_initial = [P_APP 2;P_TYPE] in + let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in + tclTHENS (cut (mk_gt kk1 zero)) + [tclTHENS + (cut (mk_gt kk2 zero)) + [tclTHENLIST [ + (intros_using [aux2;aux1]); + (generalize_tac + [mkApp (Lazy.force coq_OMEGA7, [| + eq1;eq2;kk1;kk2; + mkVar aux1;mkVar aux2; + mkVar id1;mkVar id2 |])]); + (clear [aux1;aux2]); + (mk_then tac); + (intros_using [id]); + (loop l) ]; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ]; + tclTHENLIST [ + (unfold sp_Zgt); + simpl_in_concl; + reflexivity ] ] + | CONSTANT_NOT_NUL(e,k) :: l -> + tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl + | CONSTANT_NUL(e) :: l -> + tclTHEN (resolve_id (hyp_of_tag e)) reflexivity + | CONSTANT_NEG(e,k) :: l -> + tclTHENLIST [ + (generalize_tac [mkVar (hyp_of_tag e)]); + (unfold sp_Zle); + simpl_in_concl; + (unfold sp_not); + (intros_using [aux]); + (resolve_id aux); + reflexivity + ] + | _ -> tclIDTAC + in + loop + +let normalize p_initial t = + let (tac,t') = transform p_initial t in + let (tac',t'') = condense p_initial t' in + let (tac'',t''') = clear_zero p_initial t'' in + tac @ tac' @ tac'' , t''' + +let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = + let p_initial = [P_APP pos ;P_TYPE] in + let (tac,t') = normalize p_initial t in + let shift_left = + tclTHEN + (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) + (tclTRY (clear [id])) + in + if tac <> [] then + let id' = new_identifier () in + ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ])) + :: tactic, + compile id' flag t' :: defs) + else + (tactic,defs) + +let destructure_omega gl tac_def (id,c) = + if atompart_of_id id = "State" then + tac_def + else + try match destructurate_prop c with + | Kapp(Eq,[typ;t1;t2]) + when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) -> + let t = mk_plus t1 (mk_inv t2) in + normalize_equation + id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def + | Kapp(Zne,[t1;t2]) -> + let t = mk_plus t1 (mk_inv t2) in + normalize_equation + id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def + | Kapp(Zle,[t1;t2]) -> + let t = mk_plus t2 (mk_inv t1) in + normalize_equation + id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def + | Kapp(Zlt,[t1;t2]) -> + let t = mk_plus (mk_plus t2 (mk_integer (-1))) (mk_inv t1) in + normalize_equation + id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def + | Kapp(Zge,[t1;t2]) -> + let t = mk_plus t1 (mk_inv t2) in + normalize_equation + id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def + | Kapp(Zgt,[t1;t2]) -> + let t = mk_plus (mk_plus t1 (mk_integer (-1))) (mk_inv t2) in + normalize_equation + id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def + | _ -> tac_def + with e when catchable_exception e -> tac_def + +let reintroduce id = + (* [id] cannot be cleared if dependent: protect it by a try *) + tclTHEN (tclTRY (clear [id])) (intro_using id) + +let coq_omega gl = + clear_tables (); + let tactic_normalisation, system = + List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in + let prelude,sys = + List.fold_left + (fun (tac,sys) (t,(v,th,b)) -> + if b then + let id = new_identifier () in + let i = new_id () in + tag_hypothesis id i; + (tclTHENLIST [ + (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); + (intros_using [v; id]); + (elim_id id); + (clear [id]); + (intros_using [th;id]); + tac ]), + {kind = INEQ; + body = [{v=intern_id v; c=1}]; + constant = 0; id = i} :: sys + else + (tclTHENLIST [ + (simplest_elim (applist (Lazy.force coq_new_var, [t]))); + (intros_using [v;th]); + tac ]), + sys) + (tclIDTAC,[]) (dump_tables ()) + in + let system = system @ sys in + if !display_system_flag then display_system system; + if !old_style_flag then begin + try let _ = simplify false system in tclIDTAC gl + with UNSOLVABLE -> + let _,path = depend [] [] (history ()) in + if !display_action_flag then display_action 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; + (tclTHEN prelude (replay_history tactic_normalisation path)) gl + with NO_CONTRADICTION -> error "Omega can't solve this system" + end + +let coq_omega = solver_time coq_omega + +let nat_inject gl = + let 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]) -> + tclTHENLIST [ + (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) + ((Lazy.force coq_inj_plus),[t1;t2])); + (explore (P_APP 1 :: p) t1); + (explore (P_APP 2 :: p) t2) + ] + | Kapp(Mult,[t1;t2]) -> + tclTHENLIST [ + (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) + ((Lazy.force coq_inj_mult),[t1;t2])); + (explore (P_APP 1 :: p) t1); + (explore (P_APP 2 :: p) t2) + ] + | Kapp(Minus,[t1;t2]) -> + let id = new_identifier () in + tclTHENS + (tclTHEN + (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) + (intros_using [id])) + [ + tclTHENLIST [ + (clever_rewrite_gen p + (mk_minus (mk_inj t1) (mk_inj t2)) + ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); + (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); + (explore (P_APP 1 :: p) t1); + (explore (P_APP 2 :: p) t2) ]; + (tclTHEN + (clever_rewrite_gen p (mk_integer 0) + ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) + (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) + ] + | Kapp(S,[t']) -> + let rec is_number t = + try match destructurate_term t with + Kapp(S,[t]) -> is_number t + | Kapp(O,[]) -> true + | _ -> false + with e when catchable_exception e -> false + in + let rec loop p t = + try match destructurate_term t with + Kapp(S,[t]) -> + (tclTHEN + (clever_rewrite_gen p + (mkApp (Lazy.force coq_Zs, [| mk_inj t |])) + ((Lazy.force coq_inj_S),[t])) + (loop (P_APP 1 :: p) t)) + | _ -> explore p t + with e when catchable_exception e -> explore p t + in + if is_number t' then focused_simpl p else loop p t + | Kapp(Pred,[t]) -> + let t_minus_one = + mkApp (Lazy.force coq_minus, [| t; + mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in + tclTHEN + (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one + ((Lazy.force coq_pred_of_minus),[t])) + (explore p t_minus_one) + | Kapp(O,[]) -> focused_simpl p + | _ -> tclIDTAC + with e when catchable_exception e -> tclIDTAC + + and loop = function + | [] -> tclIDTAC + | (i,t)::lit -> + begin try match destructurate_prop t with + Kapp(Le,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Lt,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Ge,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Gt,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Neq,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 1; P_TYPE] t1); + (explore [P_APP 2; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + | Kapp(Eq,[typ;t1;t2]) -> + if pf_conv_x gl typ (Lazy.force coq_nat) then + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); + (explore [P_APP 2; P_TYPE] t1); + (explore [P_APP 3; P_TYPE] t2); + (reintroduce i); + (loop lit) + ] + else loop lit + | _ -> loop lit + with e when catchable_exception e -> loop lit end + in + loop (List.rev (pf_hyps_types gl)) gl + +let rec decidability gl t = + match destructurate_prop t with + | Kapp(Or,[t1;t2]) -> + mkApp (Lazy.force coq_dec_or, [| t1; t2; + decidability gl t1; decidability gl t2 |]) + | Kapp(And,[t1;t2]) -> + mkApp (Lazy.force coq_dec_and, [| t1; t2; + decidability gl t1; decidability gl t2 |]) + | Kimp(t1,t2) -> + mkApp (Lazy.force coq_dec_imp, [| t1; t2; + decidability gl t1; decidability gl t2 |]) + | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; + decidability gl t1 |]) + | Kapp(Eq,[typ;t1;t2]) -> + begin match destructurate_type (pf_nf gl typ) with + | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) + | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) + | _ -> errorlabstrm "decidability" + (str "Omega: Can't solve a goal with equality on " ++ + Printer.prterm typ) + end + | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |]) + | Kapp(Zle,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zle, [| t1;t2 |]) + | Kapp(Zlt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zlt, [| t1;t2 |]) + | Kapp(Zge,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zge, [| t1;t2 |]) + | Kapp(Zgt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zgt, [| t1;t2 |]) + | Kapp(Le, [t1;t2]) -> mkApp (Lazy.force coq_dec_le, [| t1;t2 |]) + | Kapp(Lt, [t1;t2]) -> mkApp (Lazy.force coq_dec_lt, [| t1;t2 |]) + | Kapp(Ge, [t1;t2]) -> mkApp (Lazy.force coq_dec_ge, [| t1;t2 |]) + | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |]) + | Kapp(False,[]) -> Lazy.force coq_dec_False + | Kapp(True,[]) -> Lazy.force coq_dec_True + | Kapp(Other t,_::_) -> error + ("Omega: Unrecognized predicate or connective: "^t) + | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t) + | Kvar _ -> error "Omega: Can't solve a goal with proposition variables" + | _ -> error "Omega: Unrecognized proposition" + +let onClearedName id tac = + (* We cannot ensure that hyps can be cleared (because of dependencies), *) + (* so renaming may be necessary *) + tclTHEN + (tclTRY (clear [id])) + (fun gl -> + let id = fresh_id [] id gl in + tclTHEN (introduction id) (tac id) gl) + +let destructure_hyps gl = + let rec loop = function + | [] -> (tclTHEN nat_inject coq_omega) + | (i,body,t)::lit -> + begin try match destructurate_prop t with + | Kapp(False,[]) -> elim_id i + | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit + | Kapp(Or,[t1;t2]) -> + (tclTHENS + (elim_id i) + [ onClearedName i (fun i -> (loop ((i,None,t1)::lit))); + onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ]) + | Kapp(And,[t1;t2]) -> + tclTHENLIST [ + (elim_id i); + (tclTRY (clear [i])); + (fun gl -> + let i1 = fresh_id [] (add_suffix i "_left") gl in + let i2 = fresh_id [] (add_suffix i "_right") gl in + tclTHENLIST [ + (introduction i1); + (introduction i2); + (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl) + ] + | Kimp(t1,t2) -> + if + is_Prop (pf_type_of gl t1) & + is_Prop (pf_type_of gl t2) & + closed0 t2 + then + tclTHENLIST [ + (generalize_tac [mkApp (Lazy.force coq_imp_simp, + [| t1; t2; decidability gl t1; mkVar i|])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_or (mk_not t1) t2)::lit)))) + ] + else + loop lit + | Kapp(Not,[t]) -> + begin match destructurate_prop t with + Kapp(Or,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit)))) + ] + | Kapp(And,[t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_and, [| t1; t2; + decidability gl t1;mkVar i|])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) + ] + | Kimp(t1,t2) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_imp, [| t1; t2; + decidability gl t1;mkVar i |])]); + (onClearedName i (fun i -> + (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) + ] + | Kapp(Not,[t]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_not, [| t; + decidability gl t; mkVar i |])]); + (onClearedName i (fun i -> (loop ((i,None,t)::lit)))) + ] + | Kapp(Zle, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_Zle, [| 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|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Zlt, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_Zlt, [| 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|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Le, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_le, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Ge, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_ge, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Lt, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_lt, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Gt, [t1;t2]) -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_not_gt, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Eq,[typ;t1;t2]) -> + if !old_style_flag then begin + match destructurate_type (pf_nf gl typ) with + | Kapp(Nat,_) -> + tclTHENLIST [ + (simplest_elim + (mkApp + (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); + (onClearedName i (fun _ -> loop lit)) + ] + | Kapp(Z,_) -> + tclTHENLIST [ + (simplest_elim + (mkApp + (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); + (onClearedName i (fun _ -> loop lit)) + ] + | _ -> loop lit + end else begin + match destructurate_type (pf_nf gl typ) with + | Kapp(Nat,_) -> + (tclTHEN + (convert_hyp_no_check + (i,body, + (mkApp (Lazy.force coq_neq, [| t1;t2|])))) + (loop lit)) + | Kapp(Z,_) -> + (tclTHEN + (convert_hyp_no_check + (i,body, + (mkApp (Lazy.force coq_Zne, [| t1;t2|])))) + (loop lit)) + | _ -> loop lit + end + | _ -> loop lit + end + | _ -> loop lit + with e when catchable_exception e -> loop lit + end + in + loop (pf_hyps gl) gl + +let destructure_goal gl = + let concl = pf_concl gl in + let rec loop t = + match destructurate_prop t with + | Kapp(Not,[t]) -> + (tclTHEN + (tclTHEN (unfold sp_not) intro) + destructure_hyps) + | Kimp(a,b) -> (tclTHEN intro (loop b)) + | Kapp(False,[]) -> destructure_hyps + | _ -> + (tclTHEN + (tclTHEN + (Tactics.refine + (mkApp (Lazy.force coq_dec_not_not, [| t; + decidability gl t; mkNewMeta () |]))) + intro) + (destructure_hyps)) + in + (loop concl) gl + +let destructure_goal = all_time (destructure_goal) + +let omega_solver gl = + Library.check_required_library ["Coq";"omega";"Omega"]; + let result = destructure_goal gl in + (* if !display_time_flag then begin text_time (); + flush Pervasives.stdout end; *) + result diff --git a/contrib/omega/g_omega.ml4 b/contrib/omega/g_omega.ml4 new file mode 100644 index 00000000..726cf8bc --- /dev/null +++ b/contrib/omega/g_omega.ml4 @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(**************************************************************************) +(* *) +(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) +(* *) +(* Pierre Crégut (CNET, Lannion, France) *) +(* *) +(**************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* $Id: g_omega.ml4,v 1.1.12.1 2004/07/16 19:30:13 herbelin Exp $ *) + +open Coq_omega + +TACTIC EXTEND Omega + [ "Omega" ] -> [ omega_solver ] +END diff --git a/contrib/omega/omega.ml b/contrib/omega/omega.ml new file mode 100755 index 00000000..f2eeb5fe --- /dev/null +++ b/contrib/omega/omega.ml @@ -0,0 +1,663 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(**************************************************************************) +(* *) +(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *) +(* *) +(* Pierre Crégut (CNET, Lannion, France) *) +(* *) +(**************************************************************************) + +(* $Id: omega.ml,v 1.7.2.1 2004/07/16 19:30:13 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 + +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 + +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 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 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 afine * afine * afine * int * int + | 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 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 _ = + 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 " (string_of_id (unintern_id f.v)) + else + Printf.printf "%d %s " c (string_of_id (unintern_id 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 operator_of_eq = function + | EQUA -> "=" | DISE -> "!=" | INEQ -> ">=" + +let kind_of = function + | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" + +let display_system 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") + l; + print_string "------------------------\n\n" + +let display_inequations l = + List.iter (fun e -> display_eq e;print_string ">= 0\n") l; + print_string "------------------------\n\n" + +let rec display_action = 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 (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" + | HYP e -> + Printf.printf "We define %d :" e.id; + display_eq (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 l1; + print_newline (); + display_action l2; + print_newline () + end; display_action l + | [] -> + flush stdout + +(*""*) + +let add_event, history, clear_history = + let accu = ref [] in + (fun (v : action) -> if !debug then display_action [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 eq1 eq2 = + { kind = eq1.kind; id = new_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 {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 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 original l1 l2 = + let e = original.body in + let sigma = new_var_num () 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 [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_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_id (); kind = EQUA } in + add_event (STATE (new_eq,definition,original,m,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 + 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 + 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); + 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) = + 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 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) + end else begin + add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE + end + else banerjee (eliminate_one_equation (eq,other,sys_ineq)) +type kind = INVERTED | NORMAL +let redundancy_elimination system = + let normal = function + ({body=f::_} as e) when f.c < 0 -> negate_eq e, INVERTED + | e -> e,NORMAL in + let table = 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) = 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; + remove table ne; + add table ne final + with Not_found -> + 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 + (fun p0 p1 -> match (p0,p1) with + | (e, (Some x, Some y)) when x.constant = y.constant -> + let id=new_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 = 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 + 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 + 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 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) + (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 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 simplify 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 = (eqs @ simp_eq,simp_ineq) in + let rec loop1a system = + let sys_ineq = banerjee system in + loop1b sys_ineq + and loop1b sys_ineq = + let simp_eq,simp_ineq = redundancy_elimination 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 + loop2 (loop1b expanded) + with SOLVED_SYSTEM -> if !debug then display_system 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 (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 solve system = + try let _ = simplify false system in failwith "no contradiction" + with UNSOLVABLE -> display_action (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 = create 7 in + List.iter (fun e -> + let {body=ne;constant=c} ,kind = normal e in + 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') = 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 = + 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 + 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 + 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 + loop2 (loop1b expanded) + with SOLVED_SYSTEM -> if !debug then display_system system; system + in + let rec explode_diseq = function + | (de::diseq,ineqs,expl_map) -> + let id1 = new_id () + and id2 = new_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 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 = create 7 in + let augment x = + try incr (find tbl x) with Not_found -> 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; + !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) -> (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 + 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 + 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/ring/ArithRing.v b/contrib/ring/ArithRing.v new file mode 100644 index 00000000..1a6e0ba6 --- /dev/null +++ b/contrib/ring/ArithRing.v @@ -0,0 +1,89 @@ +(************************************************************************) +(* 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: ArithRing.v,v 1.9.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +(* Instantiation of the Ring tactic for the naturals of Arith $*) + +Require Export Ring. +Require Export Arith. +Require Import Eqdep_dec. + +Open Local Scope nat_scope. + +Fixpoint nateq (n m:nat) {struct m} : bool := + match n, m with + | O, O => true + | S n', S m' => nateq n' m' + | _, _ => false + end. + +Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m. +Proof. + simple induction n; simple induction m; intros; try contradiction. + trivial. + unfold Is_true in H1. + rewrite (H n1 H1). + trivial. +Qed. + +Hint Resolve nateq_prop eq2eqT: 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. +Defined. + + +Add Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ]. + +Goal forall n:nat, S n = 1 + n. +intro; reflexivity. +Save S_to_plus_one. + +(* Replace all occurrences of (S exp) by (plus (S O) exp), except when + exp is already O and only for those occurrences than can be reached by going + down plus and mult operations *) +Ltac rewrite_S_to_plus_term t := + match constr:t with + | 1 => constr:1 + | (S ?X1) => + let t1 := rewrite_S_to_plus_term X1 in + constr:(1 + t1) + | (?X1 + ?X2) => + let t1 := rewrite_S_to_plus_term X1 + with t2 := rewrite_S_to_plus_term X2 in + constr:(t1 + t2) + | (?X1 * ?X2) => + let t1 := rewrite_S_to_plus_term X1 + with t2 := rewrite_S_to_plus_term X2 in + constr:(t1 * t2) + | _ => constr:t + end. + +(* Apply S_to_plus on both sides of an equality *) +Ltac rewrite_S_to_plus := + match goal with + | |- (?X1 = ?X2) => + try + let t1 := + (**) (**) + rewrite_S_to_plus_term X1 + with t2 := rewrite_S_to_plus_term X2 in + change (t1 = t2) in |- * + | |- (?X1 = ?X2) => + try + let t1 := + (**) (**) + rewrite_S_to_plus_term X1 + with t2 := rewrite_S_to_plus_term X2 in + change (t1 = t2) in |- * + end. + +Ltac ring_nat := rewrite_S_to_plus; ring.
\ No newline at end of file diff --git a/contrib/ring/NArithRing.v b/contrib/ring/NArithRing.v new file mode 100644 index 00000000..cfec29ce --- /dev/null +++ b/contrib/ring/NArithRing.v @@ -0,0 +1,44 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: NArithRing.v,v 1.5.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +(* Instantiation of the Ring tactic for the binary natural numbers *) + +Require Export Ring. +Require Export ZArith_base. +Require Import NArith. +Require Import Eqdep_dec. + +Definition Neq (n m:N) := + match (n ?= m)%N with + | Datatypes.Eq => true + | _ => false + end. + +Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m. + intros n m H; unfold Neq in H. + apply Ncompare_Eq_eq. + destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ]. +Qed. + +Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq. + split. + apply Nplus_comm. + apply Nplus_assoc. + apply Nmult_comm. + apply Nmult_assoc. + apply Nplus_0_l. + apply Nmult_1_l. + apply Nmult_0_l. + apply Nmult_plus_distr_r. + apply Nplus_reg_l. + apply Neq_prop. +Qed. + +Add Semi Ring N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
\ No newline at end of file diff --git a/contrib/ring/Quote.v b/contrib/ring/Quote.v new file mode 100644 index 00000000..b4ac5745 --- /dev/null +++ b/contrib/ring/Quote.v @@ -0,0 +1,84 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Quote.v,v 1.7.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +(*********************************************************************** + The "abstract" type index is defined to represent variables. + + index : Set + index_eq : index -> bool + index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m + index_lt : index -> bool + varmap : Type -> Type. + varmap_find : (A:Type)A -> index -> (varmap A) -> A. + + The first arg. of varmap_find is the default value to take + if the object is not found in the varmap. + + index_lt defines a total well-founded order, but we don't prove that. + +***********************************************************************) + +Set Implicit Arguments. + +Section variables_map. + +Variable A : Type. + +Inductive varmap : Type := + | Empty_vm : varmap + | Node_vm : A -> varmap -> varmap -> varmap. + +Inductive index : Set := + | Left_idx : index -> index + | Right_idx : index -> index + | End_idx : index. + +Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A := + match i, v with + | End_idx, Node_vm x _ _ => x + | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2 + | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1 + | _, _ => default_value + end. + +Fixpoint index_eq (n m:index) {struct m} : bool := + match n, m with + | End_idx, End_idx => true + | Left_idx n', Left_idx m' => index_eq n' m' + | Right_idx n', Right_idx m' => index_eq n' m' + | _, _ => false + end. + +Fixpoint index_lt (n m:index) {struct m} : bool := + match n, m with + | End_idx, Left_idx _ => true + | End_idx, Right_idx _ => true + | Left_idx n', Right_idx m' => true + | Right_idx n', Right_idx m' => index_lt n' m' + | Left_idx n', Left_idx m' => index_lt n' m' + | _, _ => false + end. + +Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m. + simple induction n; simple induction m; simpl in |- *; intros. + rewrite (H i0 H1); reflexivity. + discriminate. + discriminate. + discriminate. + rewrite (H i0 H1); reflexivity. + discriminate. + discriminate. + discriminate. + reflexivity. +Qed. + +End variables_map. + +Unset Implicit Arguments.
\ No newline at end of file diff --git a/contrib/ring/Ring.v b/contrib/ring/Ring.v new file mode 100644 index 00000000..81497533 --- /dev/null +++ b/contrib/ring/Ring.v @@ -0,0 +1,36 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Ring.v,v 1.9.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +Require Export Bool. +Require Export Ring_theory. +Require Export Quote. +Require Export Ring_normalize. +Require Export Ring_abstract. + +(* As an example, we provide an instantation for bool. *) +(* Other instatiations are given in ArithRing and ZArithRing in the + same directory *) + +Definition BoolTheory : + Ring_Theory xorb andb true false (fun b:bool => b) eqb. +split; simpl in |- *. +destruct n; destruct m; reflexivity. +destruct n; destruct m; destruct p; reflexivity. +destruct n; destruct m; reflexivity. +destruct n; destruct m; destruct p; reflexivity. +destruct n; reflexivity. +destruct n; reflexivity. +destruct n; reflexivity. +destruct n; destruct m; destruct p; reflexivity. +destruct x; destruct y; reflexivity || simpl in |- *; tauto. +Defined. + +Add Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory + [ true false ].
\ No newline at end of file diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v new file mode 100644 index 00000000..de42e8c3 --- /dev/null +++ b/contrib/ring/Ring_abstract.v @@ -0,0 +1,704 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Ring_abstract.v,v 1.13.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +Require Import Ring_theory. +Require Import Quote. +Require Import Ring_normalize. + +Section abstract_semi_rings. + +Inductive aspolynomial : Type := + | ASPvar : index -> aspolynomial + | ASP0 : aspolynomial + | ASP1 : aspolynomial + | ASPplus : aspolynomial -> aspolynomial -> aspolynomial + | ASPmult : aspolynomial -> aspolynomial -> aspolynomial. + +Inductive abstract_sum : Type := + | Nil_acs : abstract_sum + | Cons_acs : varlist -> abstract_sum -> abstract_sum. + +Fixpoint abstract_sum_merge (s1:abstract_sum) : + abstract_sum -> abstract_sum := + match s1 with + | Cons_acs l1 t1 => + (fix asm_aux (s2:abstract_sum) : abstract_sum := + match s2 with + | Cons_acs l2 t2 => + if varlist_lt l1 l2 + then Cons_acs l1 (abstract_sum_merge t1 s2) + else Cons_acs l2 (asm_aux t2) + | Nil_acs => s1 + end) + | Nil_acs => fun s2 => s2 + end. + +Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} : + abstract_sum := + match s2 with + | Cons_acs l2 t2 => + if varlist_lt l1 l2 + then Cons_acs l1 s2 + else Cons_acs l2 (abstract_varlist_insert l1 t2) + | Nil_acs => Cons_acs l1 Nil_acs + end. + +Fixpoint abstract_sum_scalar (l1:varlist) (s2:abstract_sum) {struct s2} : + abstract_sum := + match s2 with + | Cons_acs l2 t2 => + abstract_varlist_insert (varlist_merge l1 l2) + (abstract_sum_scalar l1 t2) + | Nil_acs => Nil_acs + end. + +Fixpoint abstract_sum_prod (s1 s2:abstract_sum) {struct s1} : abstract_sum := + match s1 with + | Cons_acs l1 t1 => + abstract_sum_merge (abstract_sum_scalar l1 s2) + (abstract_sum_prod t1 s2) + | Nil_acs => Nil_acs + end. + +Fixpoint aspolynomial_normalize (p:aspolynomial) : abstract_sum := + match p with + | ASPvar i => Cons_acs (Cons_var i Nil_var) Nil_acs + | ASP1 => Cons_acs Nil_var Nil_acs + | ASP0 => Nil_acs + | ASPplus l r => + abstract_sum_merge (aspolynomial_normalize l) + (aspolynomial_normalize r) + | ASPmult l r => + abstract_sum_prod (aspolynomial_normalize l) (aspolynomial_normalize r) + end. + + + +Variable A : Type. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aeq : A -> A -> bool. +Variable vm : varmap A. +Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq. + +Fixpoint interp_asp (p:aspolynomial) : A := + match p with + | ASPvar i => interp_var Azero vm i + | ASP0 => Azero + | ASP1 => Aone + | ASPplus l r => Aplus (interp_asp l) (interp_asp r) + | ASPmult l r => Amult (interp_asp l) (interp_asp r) + end. + +(* Local *) Definition iacs_aux := + (fix iacs_aux (a:A) (s:abstract_sum) {struct s} : A := + match s with + | Nil_acs => a + | Cons_acs l t => + Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t) + end). + +Definition interp_acs (s:abstract_sum) : A := + match s with + | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t + | Nil_acs => Azero + end. + +Hint Resolve (SR_plus_comm T). +Hint Resolve (SR_plus_assoc T). +Hint Resolve (SR_plus_assoc2 T). +Hint Resolve (SR_mult_comm T). +Hint Resolve (SR_mult_assoc T). +Hint Resolve (SR_mult_assoc2 T). +Hint Resolve (SR_plus_zero_left T). +Hint Resolve (SR_plus_zero_left2 T). +Hint Resolve (SR_mult_one_left T). +Hint Resolve (SR_mult_one_left2 T). +Hint Resolve (SR_mult_zero_left T). +Hint Resolve (SR_mult_zero_left2 T). +Hint Resolve (SR_distr_left T). +Hint Resolve (SR_distr_left2 T). +Hint Resolve (SR_plus_reg_left T). +Hint Resolve (SR_plus_permute T). +Hint Resolve (SR_mult_permute T). +Hint Resolve (SR_distr_right T). +Hint Resolve (SR_distr_right2 T). +Hint Resolve (SR_mult_zero_right T). +Hint Resolve (SR_mult_zero_right2 T). +Hint Resolve (SR_plus_zero_right T). +Hint Resolve (SR_plus_zero_right2 T). +Hint Resolve (SR_mult_one_right T). +Hint Resolve (SR_mult_one_right2 T). +Hint Resolve (SR_plus_reg_right T). +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + +Remark iacs_aux_ok : + forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s). +Proof. + simple induction s; simpl in |- *; intros. + trivial. + reflexivity. +Qed. + +Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core. + +Lemma abstract_varlist_insert_ok : + forall (l:varlist) (s:abstract_sum), + interp_acs (abstract_varlist_insert l s) = + Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s). + + simple induction s. + trivial. + + simpl in |- *; intros. + elim (varlist_lt l v); simpl in |- *. + eauto. + rewrite iacs_aux_ok. + rewrite H; auto. + +Qed. + +Lemma abstract_sum_merge_ok : + forall x y:abstract_sum, + interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y). + +Proof. + simple induction x. + trivial. + simple induction y; intros. + + auto. + + simpl in |- *; elim (varlist_lt v v0); simpl in |- *. + repeat rewrite iacs_aux_ok. + rewrite H; simpl in |- *; auto. + + simpl in H0. + repeat rewrite iacs_aux_ok. + rewrite H0. simpl in |- *; auto. +Qed. + +Lemma abstract_sum_scalar_ok : + forall (l:varlist) (s:abstract_sum), + interp_acs (abstract_sum_scalar l s) = + Amult (interp_vl Amult Aone Azero vm l) (interp_acs s). +Proof. + simple induction s. + simpl in |- *; eauto. + + simpl in |- *; intros. + rewrite iacs_aux_ok. + rewrite abstract_varlist_insert_ok. + rewrite H. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + auto. +Qed. + +Lemma abstract_sum_prod_ok : + forall x y:abstract_sum, + interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y). + +Proof. + simple induction x. + intros; simpl in |- *; eauto. + + destruct y as [| v0 a0]; intros. + + simpl in |- *; rewrite H; eauto. + + unfold abstract_sum_prod in |- *; fold abstract_sum_prod in |- *. + rewrite abstract_sum_merge_ok. + rewrite abstract_sum_scalar_ok. + rewrite H; simpl in |- *; auto. +Qed. + +Theorem aspolynomial_normalize_ok : + forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x). +Proof. + simple induction x; simpl in |- *; intros; trivial. + rewrite abstract_sum_merge_ok. + rewrite H; rewrite H0; eauto. + rewrite abstract_sum_prod_ok. + rewrite H; rewrite H0; eauto. +Qed. + +End abstract_semi_rings. + +Section abstract_rings. + +(* In abstract polynomials there is no constants other + than 0 and 1. An abstract ring is a ring whose operations plus, + and mult are not functions but constructors. In other words, + when c1 and c2 are closed, (plus c1 c2) doesn't reduce to a closed + term. "closed" mean here "without plus and mult". *) + +(* this section is not parametrized by a (semi-)ring. + Nevertheless, they are two different types for semi-rings and rings + and there will be 2 correction theorems *) + +Inductive apolynomial : Type := + | APvar : index -> apolynomial + | AP0 : apolynomial + | AP1 : apolynomial + | APplus : apolynomial -> apolynomial -> apolynomial + | APmult : apolynomial -> apolynomial -> apolynomial + | APopp : apolynomial -> apolynomial. + +(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-". + Invariant : the list is sorted and there is no varlist is present + with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *) + +Inductive signed_sum : Type := + | Nil_varlist : signed_sum + | Plus_varlist : varlist -> signed_sum -> signed_sum + | Minus_varlist : varlist -> signed_sum -> signed_sum. + +Fixpoint signed_sum_merge (s1:signed_sum) : signed_sum -> signed_sum := + match s1 with + | Plus_varlist l1 t1 => + (fix ssm_aux (s2:signed_sum) : signed_sum := + match s2 with + | Plus_varlist l2 t2 => + if varlist_lt l1 l2 + then Plus_varlist l1 (signed_sum_merge t1 s2) + else Plus_varlist l2 (ssm_aux t2) + | Minus_varlist l2 t2 => + if varlist_eq l1 l2 + then signed_sum_merge t1 t2 + else + if varlist_lt l1 l2 + then Plus_varlist l1 (signed_sum_merge t1 s2) + else Minus_varlist l2 (ssm_aux t2) + | Nil_varlist => s1 + end) + | Minus_varlist l1 t1 => + (fix ssm_aux2 (s2:signed_sum) : signed_sum := + match s2 with + | Plus_varlist l2 t2 => + if varlist_eq l1 l2 + then signed_sum_merge t1 t2 + else + if varlist_lt l1 l2 + then Minus_varlist l1 (signed_sum_merge t1 s2) + else Plus_varlist l2 (ssm_aux2 t2) + | Minus_varlist l2 t2 => + if varlist_lt l1 l2 + then Minus_varlist l1 (signed_sum_merge t1 s2) + else Minus_varlist l2 (ssm_aux2 t2) + | Nil_varlist => s1 + end) + | Nil_varlist => fun s2 => s2 + end. + +Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} : + signed_sum := + match s2 with + | Plus_varlist l2 t2 => + if varlist_lt l1 l2 + then Plus_varlist l1 s2 + else Plus_varlist l2 (plus_varlist_insert l1 t2) + | Minus_varlist l2 t2 => + if varlist_eq l1 l2 + then t2 + else + if varlist_lt l1 l2 + then Plus_varlist l1 s2 + else Minus_varlist l2 (plus_varlist_insert l1 t2) + | Nil_varlist => Plus_varlist l1 Nil_varlist + end. + +Fixpoint minus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} : + signed_sum := + match s2 with + | Plus_varlist l2 t2 => + if varlist_eq l1 l2 + then t2 + else + if varlist_lt l1 l2 + then Minus_varlist l1 s2 + else Plus_varlist l2 (minus_varlist_insert l1 t2) + | Minus_varlist l2 t2 => + if varlist_lt l1 l2 + then Minus_varlist l1 s2 + else Minus_varlist l2 (minus_varlist_insert l1 t2) + | Nil_varlist => Minus_varlist l1 Nil_varlist + end. + +Fixpoint signed_sum_opp (s:signed_sum) : signed_sum := + match s with + | Plus_varlist l2 t2 => Minus_varlist l2 (signed_sum_opp t2) + | Minus_varlist l2 t2 => Plus_varlist l2 (signed_sum_opp t2) + | Nil_varlist => Nil_varlist + end. + + +Fixpoint plus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} : + signed_sum := + match s2 with + | Plus_varlist l2 t2 => + plus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2) + | Minus_varlist l2 t2 => + minus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2) + | Nil_varlist => Nil_varlist + end. + +Fixpoint minus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} : + signed_sum := + match s2 with + | Plus_varlist l2 t2 => + minus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2) + | Minus_varlist l2 t2 => + plus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2) + | Nil_varlist => Nil_varlist + end. + +Fixpoint signed_sum_prod (s1 s2:signed_sum) {struct s1} : signed_sum := + match s1 with + | Plus_varlist l1 t1 => + signed_sum_merge (plus_sum_scalar l1 s2) (signed_sum_prod t1 s2) + | Minus_varlist l1 t1 => + signed_sum_merge (minus_sum_scalar l1 s2) (signed_sum_prod t1 s2) + | Nil_varlist => Nil_varlist + end. + +Fixpoint apolynomial_normalize (p:apolynomial) : signed_sum := + match p with + | APvar i => Plus_varlist (Cons_var i Nil_var) Nil_varlist + | AP1 => Plus_varlist Nil_var Nil_varlist + | AP0 => Nil_varlist + | APplus l r => + signed_sum_merge (apolynomial_normalize l) (apolynomial_normalize r) + | APmult l r => + signed_sum_prod (apolynomial_normalize l) (apolynomial_normalize r) + | APopp q => signed_sum_opp (apolynomial_normalize q) + end. + + +Variable A : Type. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. +Variable vm : varmap A. +Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. + +(* Local *) Definition isacs_aux := + (fix isacs_aux (a:A) (s:signed_sum) {struct s} : A := + match s with + | Nil_varlist => a + | Plus_varlist l t => + Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t) + | Minus_varlist l t => + Aplus a + (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t) + end). + +Definition interp_sacs (s:signed_sum) : A := + match s with + | Plus_varlist l t => isacs_aux (interp_vl Amult Aone Azero vm l) t + | Minus_varlist l t => isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t + | Nil_varlist => Azero + end. + +Fixpoint interp_ap (p:apolynomial) : A := + match p with + | APvar i => interp_var Azero vm i + | AP0 => Azero + | AP1 => Aone + | APplus l r => Aplus (interp_ap l) (interp_ap r) + | APmult l r => Amult (interp_ap l) (interp_ap r) + | APopp q => Aopp (interp_ap q) + end. + +Hint Resolve (Th_plus_comm T). +Hint Resolve (Th_plus_assoc T). +Hint Resolve (Th_plus_assoc2 T). +Hint Resolve (Th_mult_sym T). +Hint Resolve (Th_mult_assoc T). +Hint Resolve (Th_mult_assoc2 T). +Hint Resolve (Th_plus_zero_left T). +Hint Resolve (Th_plus_zero_left2 T). +Hint Resolve (Th_mult_one_left T). +Hint Resolve (Th_mult_one_left2 T). +Hint Resolve (Th_mult_zero_left T). +Hint Resolve (Th_mult_zero_left2 T). +Hint Resolve (Th_distr_left T). +Hint Resolve (Th_distr_left2 T). +Hint Resolve (Th_plus_reg_left T). +Hint Resolve (Th_plus_permute T). +Hint Resolve (Th_mult_permute T). +Hint Resolve (Th_distr_right T). +Hint Resolve (Th_distr_right2 T). +Hint Resolve (Th_mult_zero_right2 T). +Hint Resolve (Th_plus_zero_right T). +Hint Resolve (Th_plus_zero_right2 T). +Hint Resolve (Th_mult_one_right T). +Hint Resolve (Th_mult_one_right2 T). +Hint Resolve (Th_plus_reg_right T). +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + +Lemma isacs_aux_ok : + forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s). +Proof. + simple induction s; simpl in |- *; intros. + trivial. + reflexivity. + reflexivity. +Qed. + +Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core. + +Ltac solve1 v v0 H H0 := + simpl in |- *; elim (varlist_lt v v0); simpl in |- *; rewrite isacs_aux_ok; + [ rewrite H; simpl in |- *; auto | simpl in H0; rewrite H0; auto ]. + +Lemma signed_sum_merge_ok : + forall x y:signed_sum, + interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y). + + simple induction x. + intro; simpl in |- *; auto. + + simple induction y; intros. + + auto. + + solve1 v v0 H H0. + + simpl in |- *; generalize (varlist_eq_prop v v0). + elim (varlist_eq v v0); simpl in |- *. + + intro Heq; rewrite (Heq I). + rewrite H. + repeat rewrite isacs_aux_ok. + rewrite (Th_plus_permute T). + repeat rewrite (Th_plus_assoc T). + rewrite + (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0)) + (interp_vl Amult Aone Azero vm v0)). + rewrite (Th_opp_def T). + rewrite (Th_plus_zero_left T). + reflexivity. + + solve1 v v0 H H0. + + simple induction y; intros. + + auto. + + simpl in |- *; generalize (varlist_eq_prop v v0). + elim (varlist_eq v v0); simpl in |- *. + + intro Heq; rewrite (Heq I). + rewrite H. + repeat rewrite isacs_aux_ok. + rewrite (Th_plus_permute T). + repeat rewrite (Th_plus_assoc T). + rewrite (Th_opp_def T). + rewrite (Th_plus_zero_left T). + reflexivity. + + solve1 v v0 H H0. + + solve1 v v0 H H0. + +Qed. + +Ltac solve2 l v H := + elim (varlist_lt l v); simpl in |- *; rewrite isacs_aux_ok; + [ auto | rewrite H; auto ]. + +Lemma plus_varlist_insert_ok : + forall (l:varlist) (s:signed_sum), + interp_sacs (plus_varlist_insert l s) = + Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s). +Proof. + + simple induction s. + trivial. + + simpl in |- *; intros. + solve2 l v H. + + simpl in |- *; intros. + generalize (varlist_eq_prop l v). + elim (varlist_eq l v); simpl in |- *. + + intro Heq; rewrite (Heq I). + repeat rewrite isacs_aux_ok. + repeat rewrite (Th_plus_assoc T). + rewrite (Th_opp_def T). + rewrite (Th_plus_zero_left T). + reflexivity. + + solve2 l v H. + +Qed. + +Lemma minus_varlist_insert_ok : + forall (l:varlist) (s:signed_sum), + interp_sacs (minus_varlist_insert l s) = + Aplus (Aopp (interp_vl Amult Aone Azero vm l)) (interp_sacs s). +Proof. + + simple induction s. + trivial. + + simpl in |- *; intros. + generalize (varlist_eq_prop l v). + elim (varlist_eq l v); simpl in |- *. + + intro Heq; rewrite (Heq I). + repeat rewrite isacs_aux_ok. + repeat rewrite (Th_plus_assoc T). + rewrite + (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v)) + (interp_vl Amult Aone Azero vm v)). + rewrite (Th_opp_def T). + auto. + + simpl in |- *; intros. + solve2 l v H. + + simpl in |- *; intros; solve2 l v H. + +Qed. + +Lemma signed_sum_opp_ok : + forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s). +Proof. + + simple induction s; simpl in |- *; intros. + + symmetry in |- *; apply (Th_opp_zero T). + + repeat rewrite isacs_aux_ok. + rewrite H. + rewrite (Th_plus_opp_opp T). + reflexivity. + + repeat rewrite isacs_aux_ok. + rewrite H. + rewrite <- (Th_plus_opp_opp T). + rewrite (Th_opp_opp T). + reflexivity. + +Qed. + +Lemma plus_sum_scalar_ok : + forall (l:varlist) (s:signed_sum), + interp_sacs (plus_sum_scalar l s) = + Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s). +Proof. + + simple induction s. + trivial. + + simpl in |- *; intros. + rewrite plus_varlist_insert_ok. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + repeat rewrite isacs_aux_ok. + rewrite H. + auto. + + simpl in |- *; intros. + rewrite minus_varlist_insert_ok. + repeat rewrite isacs_aux_ok. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + rewrite H. + rewrite (Th_distr_right T). + rewrite <- (Th_opp_mult_right T). + reflexivity. + +Qed. + +Lemma minus_sum_scalar_ok : + forall (l:varlist) (s:signed_sum), + interp_sacs (minus_sum_scalar l s) = + Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)). +Proof. + + simple induction s; simpl in |- *; intros. + + rewrite (Th_mult_zero_right T); symmetry in |- *; apply (Th_opp_zero T). + + simpl in |- *; intros. + rewrite minus_varlist_insert_ok. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + repeat rewrite isacs_aux_ok. + rewrite H. + rewrite (Th_distr_right T). + rewrite (Th_plus_opp_opp T). + reflexivity. + + simpl in |- *; intros. + rewrite plus_varlist_insert_ok. + repeat rewrite isacs_aux_ok. + rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). + rewrite H. + rewrite (Th_distr_right T). + rewrite <- (Th_opp_mult_right T). + rewrite <- (Th_plus_opp_opp T). + rewrite (Th_opp_opp T). + reflexivity. + +Qed. + +Lemma signed_sum_prod_ok : + forall x y:signed_sum, + interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y). +Proof. + + simple induction x. + + simpl in |- *; eauto 1. + + intros; simpl in |- *. + rewrite signed_sum_merge_ok. + rewrite plus_sum_scalar_ok. + repeat rewrite isacs_aux_ok. + rewrite H. + auto. + + intros; simpl in |- *. + repeat rewrite isacs_aux_ok. + rewrite signed_sum_merge_ok. + rewrite minus_sum_scalar_ok. + rewrite H. + rewrite (Th_distr_left T). + rewrite (Th_opp_mult_left T). + reflexivity. + +Qed. + +Theorem apolynomial_normalize_ok : + forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p. +Proof. + simple induction p; simpl in |- *; auto 1. + intros. + rewrite signed_sum_merge_ok. + rewrite H; rewrite H0; reflexivity. + intros. + rewrite signed_sum_prod_ok. + rewrite H; rewrite H0; reflexivity. + intros. + rewrite signed_sum_opp_ok. + rewrite H; reflexivity. +Qed. + +End abstract_rings.
\ No newline at end of file diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v new file mode 100644 index 00000000..8c0fd5fb --- /dev/null +++ b/contrib/ring/Ring_normalize.v @@ -0,0 +1,901 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Ring_normalize.v,v 1.16.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +Require Import Ring_theory. +Require Import Quote. + +Set Implicit Arguments. + +Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m. +Proof. + intros. + apply index_eq_prop. + generalize H. + case (index_eq n m); simpl in |- *; trivial; intros. + contradiction. +Qed. + +Section semi_rings. + +Variable A : Type. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aeq : A -> A -> bool. + +(* Section definitions. *) + + +(******************************************) +(* Normal abtract Polynomials *) +(******************************************) +(* DEFINITIONS : +- A varlist is a sorted product of one or more variables : x, x*y*z +- A monom is a constant, a varlist or the product of a constant by a varlist + variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. +- A canonical sum is either a monom or an ordered sum of monoms + (the order on monoms is defined later) +- A normal polynomial it either a constant or a canonical sum or a constant + plus a canonical sum +*) + +(* varlist is isomorphic to (list var), but we built a special inductive + for efficiency *) +Inductive varlist : Type := + | Nil_var : varlist + | Cons_var : index -> varlist -> varlist. + +Inductive canonical_sum : Type := + | Nil_monom : canonical_sum + | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum + | Cons_varlist : varlist -> canonical_sum -> canonical_sum. + +(* Order on monoms *) + +(* That's the lexicographic order on varlist, extended by : + - A constant is less than every monom + - The relation between two varlist is preserved by multiplication by a + constant. + + Examples : + 3 < x < y + x*y < x*y*y*z + 2*x*y < x*y*y*z + x*y < 54*x*y*y*z + 4*x*y < 59*x*y*y*z +*) + +Fixpoint varlist_eq (x y:varlist) {struct y} : bool := + match x, y with + | Nil_var, Nil_var => true + | Cons_var i xrest, Cons_var j yrest => + andb (index_eq i j) (varlist_eq xrest yrest) + | _, _ => false + end. + +Fixpoint varlist_lt (x y:varlist) {struct y} : bool := + match x, y with + | Nil_var, Cons_var _ _ => true + | Cons_var i xrest, Cons_var j yrest => + if index_lt i j + then true + else andb (index_eq i j) (varlist_lt xrest yrest) + | _, _ => false + end. + +(* merges two variables lists *) +Fixpoint varlist_merge (l1:varlist) : varlist -> varlist := + match l1 with + | Cons_var v1 t1 => + (fix vm_aux (l2:varlist) : varlist := + match l2 with + | Cons_var v2 t2 => + if index_lt v1 v2 + then Cons_var v1 (varlist_merge t1 l2) + else Cons_var v2 (vm_aux t2) + | Nil_var => l1 + end) + | Nil_var => fun l2 => l2 + end. + +(* returns the sum of two canonical sums *) +Fixpoint canonical_sum_merge (s1:canonical_sum) : + canonical_sum -> canonical_sum := + match s1 with + | Cons_monom c1 l1 t1 => + (fix csm_aux (s2:canonical_sum) : canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 (canonical_sum_merge t1 s2) + else Cons_monom c2 l2 (csm_aux t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 (canonical_sum_merge t1 s2) + else Cons_varlist l2 (csm_aux t2) + | Nil_monom => s1 + end) + | Cons_varlist l1 t1 => + (fix csm_aux2 (s2:canonical_sum) : canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_varlist l1 (canonical_sum_merge t1 s2) + else Cons_monom c2 l2 (csm_aux2 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_varlist l1 (canonical_sum_merge t1 s2) + else Cons_varlist l2 (csm_aux2 t2) + | Nil_monom => s1 + end) + | Nil_monom => fun s2 => s2 + end. + +(* Insertion of a monom in a canonical sum *) +Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} : + canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 c2) l1 t2 + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 s2 + else Cons_monom c2 l2 (monom_insert c1 l1 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 Aone) l1 t2 + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 s2 + else Cons_varlist l2 (monom_insert c1 l1 t2) + | Nil_monom => Cons_monom c1 l1 Nil_monom + end. + +Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} : + canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone c2) l1 t2 + else + if varlist_lt l1 l2 + then Cons_varlist l1 s2 + else Cons_monom c2 l2 (varlist_insert l1 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone Aone) l1 t2 + else + if varlist_lt l1 l2 + then Cons_varlist l1 s2 + else Cons_varlist l2 (varlist_insert l1 t2) + | Nil_monom => Cons_varlist l1 Nil_monom + end. + +(* Computes c0*s *) +Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} : + canonical_sum := + match s with + | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t) + | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t) + | Nil_monom => Nil_monom + end. + +(* Computes l0*s *) +Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : + canonical_sum := + match s with + | Cons_monom c l t => + monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) + | Cons_varlist l t => + varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) + | Nil_monom => Nil_monom + end. + +(* Computes c0*l0*s *) +Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) + (s:canonical_sum) {struct s} : canonical_sum := + match s with + | Cons_monom c l t => + monom_insert (Amult c0 c) (varlist_merge l0 l) + (canonical_sum_scalar3 c0 l0 t) + | Cons_varlist l t => + monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) + | Nil_monom => Nil_monom + end. + +(* returns the product of two canonical sums *) +Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : + canonical_sum := + match s1 with + | Cons_monom c1 l1 t1 => + canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) + (canonical_sum_prod t1 s2) + | Cons_varlist l1 t1 => + canonical_sum_merge (canonical_sum_scalar2 l1 s2) + (canonical_sum_prod t1 s2) + | Nil_monom => Nil_monom + end. + +(* The type to represent concrete semi-ring polynomials *) +Inductive spolynomial : Type := + | SPvar : index -> spolynomial + | SPconst : A -> spolynomial + | SPplus : spolynomial -> spolynomial -> spolynomial + | SPmult : spolynomial -> spolynomial -> spolynomial. + +Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum := + match p with + | SPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom + | SPconst c => Cons_monom c Nil_var Nil_monom + | SPplus l r => + canonical_sum_merge (spolynomial_normalize l) (spolynomial_normalize r) + | SPmult l r => + canonical_sum_prod (spolynomial_normalize l) (spolynomial_normalize r) + end. + +(* Deletion of useless 0 and 1 in canonical sums *) +Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum := + match s with + | Cons_monom c l t => + if Aeq c Azero + then canonical_sum_simplify t + else + if Aeq c Aone + then Cons_varlist l (canonical_sum_simplify t) + else Cons_monom c l (canonical_sum_simplify t) + | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t) + | Nil_monom => Nil_monom + end. + +Definition spolynomial_simplify (x:spolynomial) := + canonical_sum_simplify (spolynomial_normalize x). + +(* End definitions. *) + +(* Section interpretation. *) + +(*** Here a variable map is defined and the interpetation of a spolynom + acording to a certain variables map. Once again the choosen definition + is generic and could be changed ****) + +Variable vm : varmap A. + +(* Interpretation of list of variables + * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn) + * The unbound variables are mapped to 0. Normally this case sould + * never occur. Since we want only to prove correctness theorems, which form + * is : for any varmap and any spolynom ... this is a safe and pain-saving + * choice *) +Definition interp_var (i:index) := varmap_find Azero i vm. + +(* Local *) Definition ivl_aux := + (fix ivl_aux (x:index) (t:varlist) {struct t} : A := + match t with + | Nil_var => interp_var x + | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t') + end). + +Definition interp_vl (l:varlist) := + match l with + | Nil_var => Aone + | Cons_var x t => ivl_aux x t + end. + +(* Local *) Definition interp_m (c:A) (l:varlist) := + match l with + | Nil_var => c + | Cons_var x t => Amult c (ivl_aux x t) + end. + +(* Local *) Definition ics_aux := + (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A := + match s with + | Nil_monom => a + | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t) + | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t) + end). + +(* Interpretation of a canonical sum *) +Definition interp_cs (s:canonical_sum) : A := + match s with + | Nil_monom => Azero + | Cons_varlist l t => ics_aux (interp_vl l) t + | Cons_monom c l t => ics_aux (interp_m c l) t + end. + +Fixpoint interp_sp (p:spolynomial) : A := + match p with + | SPconst c => c + | SPvar i => interp_var i + | SPplus p1 p2 => Aplus (interp_sp p1) (interp_sp p2) + | SPmult p1 p2 => Amult (interp_sp p1) (interp_sp p2) + end. + + +(* End interpretation. *) + +Unset Implicit Arguments. + +(* Section properties. *) + +Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq. + +Hint Resolve (SR_plus_comm T). +Hint Resolve (SR_plus_assoc T). +Hint Resolve (SR_plus_assoc2 T). +Hint Resolve (SR_mult_comm T). +Hint Resolve (SR_mult_assoc T). +Hint Resolve (SR_mult_assoc2 T). +Hint Resolve (SR_plus_zero_left T). +Hint Resolve (SR_plus_zero_left2 T). +Hint Resolve (SR_mult_one_left T). +Hint Resolve (SR_mult_one_left2 T). +Hint Resolve (SR_mult_zero_left T). +Hint Resolve (SR_mult_zero_left2 T). +Hint Resolve (SR_distr_left T). +Hint Resolve (SR_distr_left2 T). +Hint Resolve (SR_plus_reg_left T). +Hint Resolve (SR_plus_permute T). +Hint Resolve (SR_mult_permute T). +Hint Resolve (SR_distr_right T). +Hint Resolve (SR_distr_right2 T). +Hint Resolve (SR_mult_zero_right T). +Hint Resolve (SR_mult_zero_right2 T). +Hint Resolve (SR_plus_zero_right T). +Hint Resolve (SR_plus_zero_right2 T). +Hint Resolve (SR_mult_one_right T). +Hint Resolve (SR_mult_one_right2 T). +Hint Resolve (SR_plus_reg_right T). +Hint Resolve refl_equal sym_equal trans_equal. +(* Hints Resolve refl_eqT sym_eqT trans_eqT. *) +Hint Immediate T. + +Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. +Proof. + simple induction x; simple induction y; contradiction || (try reflexivity). + simpl in |- *; intros. + generalize (andb_prop2 _ _ H1); intros; elim H2; intros. + rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. +Qed. + +Remark ivl_aux_ok : + forall (v:varlist) (i:index), + ivl_aux i v = Amult (interp_var i) (interp_vl v). +Proof. + simple induction v; simpl in |- *; intros. + trivial. + rewrite H; trivial. +Qed. + +Lemma varlist_merge_ok : + forall x y:varlist, + interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y). +Proof. + simple induction x. + simpl in |- *; trivial. + simple induction y. + simpl in |- *; trivial. + simpl in |- *; intros. + elim (index_lt i i0); simpl in |- *; intros. + + repeat rewrite ivl_aux_ok. + rewrite H. simpl in |- *. + rewrite ivl_aux_ok. + eauto. + + repeat rewrite ivl_aux_ok. + rewrite H0. + rewrite ivl_aux_ok. + eauto. +Qed. + +Remark ics_aux_ok : + forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s). +Proof. + simple induction s; simpl in |- *; intros. + trivial. + reflexivity. + reflexivity. +Qed. + +Remark interp_m_ok : + forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l). +Proof. + destruct l as [| i v]. + simpl in |- *; trivial. + reflexivity. +Qed. + +Lemma canonical_sum_merge_ok : + forall x y:canonical_sum, + interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y). + +simple induction x; simpl in |- *. +trivial. + +simple induction y; simpl in |- *; intros. +(* monom and nil *) +eauto. + +(* monom and monom *) +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +repeat rewrite interp_m_ok. +rewrite (SR_distr_left T). +repeat rewrite <- (SR_plus_assoc T). +apply f_equal with (f := Aplus (Amult a (interp_vl v0))). +trivial. + +elim (varlist_lt v v0); simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. + +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; + eauto. + +(* monom and varlist *) +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +repeat rewrite interp_m_ok. +rewrite (SR_distr_left T). +repeat rewrite <- (SR_plus_assoc T). +apply f_equal with (f := Aplus (Amult a (interp_vl v0))). +rewrite (SR_mult_one_left T). +trivial. + +elim (varlist_lt v v0); simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; + eauto. + +simple induction y; simpl in |- *; intros. +(* varlist and nil *) +trivial. + +(* varlist and monom *) +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +repeat rewrite interp_m_ok. +rewrite (SR_distr_left T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_one_left T). +apply f_equal with (f := Aplus (interp_vl v0)). +trivial. + +elim (varlist_lt v v0); simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; + eauto. + +(* varlist and varlist *) +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +repeat rewrite interp_m_ok. +rewrite (SR_distr_left T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_one_left T). +apply f_equal with (f := Aplus (interp_vl v0)). +trivial. + +elim (varlist_lt v v0); simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; + eauto. +Qed. + +Lemma monom_insert_ok : + forall (a:A) (l:varlist) (s:canonical_sum), + interp_cs (monom_insert a l s) = + Aplus (Amult a (interp_vl l)) (interp_cs s). +intros; generalize s; simple induction s0. + +simpl in |- *; rewrite interp_m_ok; trivial. + +simpl in |- *; intros. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; + repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); + eauto. +elim (varlist_lt l v); simpl in |- *; + [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto + | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; + rewrite ics_aux_ok; eauto ]. + +simpl in |- *; intros. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; + repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); + rewrite (SR_mult_one_left T); eauto. +elim (varlist_lt l v); simpl in |- *; + [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto + | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; + rewrite ics_aux_ok; eauto ]. +Qed. + +Lemma varlist_insert_ok : + forall (l:varlist) (s:canonical_sum), + interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s). +intros; generalize s; simple induction s0. + +simpl in |- *; trivial. + +simpl in |- *; intros. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; + repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); + rewrite (SR_mult_one_left T); eauto. +elim (varlist_lt l v); simpl in |- *; + [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto + | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; + rewrite ics_aux_ok; eauto ]. + +simpl in |- *; intros. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; + repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); + rewrite (SR_mult_one_left T); eauto. +elim (varlist_lt l v); simpl in |- *; + [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto + | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; + rewrite ics_aux_ok; eauto ]. +Qed. + +Lemma canonical_sum_scalar_ok : + forall (a:A) (s:canonical_sum), + interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s). +simple induction s. +simpl in |- *; eauto. + +simpl in |- *; intros. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +reflexivity. + +simpl in |- *; intros. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +reflexivity. +Qed. + +Lemma canonical_sum_scalar2_ok : + forall (l:varlist) (s:canonical_sum), + interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s). +simple induction s. +simpl in |- *; trivial. + +simpl in |- *; intros. +rewrite monom_insert_ok. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite varlist_merge_ok. +repeat rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). +reflexivity. + +simpl in |- *; intros. +rewrite varlist_insert_ok. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite varlist_merge_ok. +repeat rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +repeat rewrite <- (SR_plus_assoc T). +reflexivity. +Qed. + +Lemma canonical_sum_scalar3_ok : + forall (c:A) (l:varlist) (s:canonical_sum), + interp_cs (canonical_sum_scalar3 c l s) = + Amult c (Amult (interp_vl l) (interp_cs s)). +simple induction s. +simpl in |- *; repeat rewrite (SR_mult_zero_right T); reflexivity. + +simpl in |- *; intros. +rewrite monom_insert_ok. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite varlist_merge_ok. +repeat rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). +reflexivity. + +simpl in |- *; intros. +rewrite monom_insert_ok. +repeat rewrite ics_aux_ok. +repeat rewrite interp_m_ok. +rewrite H. +rewrite varlist_merge_ok. +repeat rewrite (SR_distr_right T). +repeat rewrite <- (SR_mult_assoc T). +repeat rewrite <- (SR_plus_assoc T). +rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)). +reflexivity. +Qed. + +Lemma canonical_sum_prod_ok : + forall x y:canonical_sum, + interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y). +simple induction x; simpl in |- *; intros. +trivial. + +rewrite canonical_sum_merge_ok. +rewrite canonical_sum_scalar3_ok. +rewrite ics_aux_ok. +rewrite interp_m_ok. +rewrite H. +rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)). +symmetry in |- *. +eauto. + +rewrite canonical_sum_merge_ok. +rewrite canonical_sum_scalar2_ok. +rewrite ics_aux_ok. +rewrite H. +trivial. +Qed. + +Theorem spolynomial_normalize_ok : + forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p. +simple induction p; simpl in |- *; intros. + +reflexivity. +reflexivity. + +rewrite canonical_sum_merge_ok. +rewrite H; rewrite H0. +reflexivity. + +rewrite canonical_sum_prod_ok. +rewrite H; rewrite H0. +reflexivity. +Qed. + +Lemma canonical_sum_simplify_ok : + forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s. +simple induction s. + +reflexivity. + +(* cons_monom *) +simpl in |- *; intros. +generalize (SR_eq_prop T a Azero). +elim (Aeq a Azero). +intro Heq; rewrite (Heq I). +rewrite H. +rewrite ics_aux_ok. +rewrite interp_m_ok. +rewrite (SR_mult_zero_left T). +trivial. + +intros; simpl in |- *. +generalize (SR_eq_prop T a Aone). +elim (Aeq a Aone). +intro Heq; rewrite (Heq I). +simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite interp_m_ok. +rewrite H. +rewrite (SR_mult_one_left T). +reflexivity. + +simpl in |- *. +repeat rewrite ics_aux_ok. +rewrite interp_m_ok. +rewrite H. +reflexivity. + +(* cons_varlist *) +simpl in |- *; intros. +repeat rewrite ics_aux_ok. +rewrite H. +reflexivity. + +Qed. + +Theorem spolynomial_simplify_ok : + forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p. +intro. +unfold spolynomial_simplify in |- *. +rewrite canonical_sum_simplify_ok. +apply spolynomial_normalize_ok. +Qed. + +(* End properties. *) +End semi_rings. + +Implicit Arguments Cons_varlist. +Implicit Arguments Cons_monom. +Implicit Arguments SPconst. +Implicit Arguments SPplus. +Implicit Arguments SPmult. + +Section rings. + +(* Here the coercion between Ring and Semi-Ring will be useful *) + +Set Implicit Arguments. + +Variable A : Type. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. +Variable vm : varmap A. +Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. + +Hint Resolve (Th_plus_comm T). +Hint Resolve (Th_plus_assoc T). +Hint Resolve (Th_plus_assoc2 T). +Hint Resolve (Th_mult_sym T). +Hint Resolve (Th_mult_assoc T). +Hint Resolve (Th_mult_assoc2 T). +Hint Resolve (Th_plus_zero_left T). +Hint Resolve (Th_plus_zero_left2 T). +Hint Resolve (Th_mult_one_left T). +Hint Resolve (Th_mult_one_left2 T). +Hint Resolve (Th_mult_zero_left T). +Hint Resolve (Th_mult_zero_left2 T). +Hint Resolve (Th_distr_left T). +Hint Resolve (Th_distr_left2 T). +Hint Resolve (Th_plus_reg_left T). +Hint Resolve (Th_plus_permute T). +Hint Resolve (Th_mult_permute T). +Hint Resolve (Th_distr_right T). +Hint Resolve (Th_distr_right2 T). +Hint Resolve (Th_mult_zero_right T). +Hint Resolve (Th_mult_zero_right2 T). +Hint Resolve (Th_plus_zero_right T). +Hint Resolve (Th_plus_zero_right2 T). +Hint Resolve (Th_mult_one_right T). +Hint Resolve (Th_mult_one_right2 T). +Hint Resolve (Th_plus_reg_right T). +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + +(*** Definitions *) + +Inductive polynomial : Type := + | Pvar : index -> polynomial + | Pconst : A -> polynomial + | Pplus : polynomial -> polynomial -> polynomial + | Pmult : polynomial -> polynomial -> polynomial + | Popp : polynomial -> polynomial. + +Fixpoint polynomial_normalize (x:polynomial) : canonical_sum A := + match x with + | Pplus l r => + canonical_sum_merge Aplus Aone (polynomial_normalize l) + (polynomial_normalize r) + | Pmult l r => + canonical_sum_prod Aplus Amult Aone (polynomial_normalize l) + (polynomial_normalize r) + | Pconst c => Cons_monom c Nil_var (Nil_monom A) + | Pvar i => Cons_varlist (Cons_var i Nil_var) (Nil_monom A) + | Popp p => + canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var + (polynomial_normalize p) + end. + +Definition polynomial_simplify (x:polynomial) := + canonical_sum_simplify Aone Azero Aeq (polynomial_normalize x). + +Fixpoint spolynomial_of (x:polynomial) : spolynomial A := + match x with + | Pplus l r => SPplus (spolynomial_of l) (spolynomial_of r) + | Pmult l r => SPmult (spolynomial_of l) (spolynomial_of r) + | Pconst c => SPconst c + | Pvar i => SPvar A i + | Popp p => SPmult (SPconst (Aopp Aone)) (spolynomial_of p) + end. + +(*** Interpretation *) + +Fixpoint interp_p (p:polynomial) : A := + match p with + | Pconst c => c + | Pvar i => varmap_find Azero i vm + | Pplus p1 p2 => Aplus (interp_p p1) (interp_p p2) + | Pmult p1 p2 => Amult (interp_p p1) (interp_p p2) + | Popp p1 => Aopp (interp_p p1) + end. + +(*** Properties *) + +Unset Implicit Arguments. + +Lemma spolynomial_of_ok : + forall p:polynomial, + interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p). +simple induction p; reflexivity || (simpl in |- *; intros). +rewrite H; rewrite H0; reflexivity. +rewrite H; rewrite H0; reflexivity. +rewrite H. +rewrite (Th_opp_mult_left2 T). +rewrite (Th_mult_one_left T). +reflexivity. +Qed. + +Theorem polynomial_normalize_ok : + forall p:polynomial, + polynomial_normalize p = + spolynomial_normalize Aplus Amult Aone (spolynomial_of p). +simple induction p; reflexivity || (simpl in |- *; intros). +rewrite H; rewrite H0; reflexivity. +rewrite H; rewrite H0; reflexivity. +rewrite H; simpl in |- *. +elim + (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var + (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0))); + [ reflexivity + | simpl in |- *; intros; rewrite H0; reflexivity + | simpl in |- *; intros; rewrite H0; reflexivity ]. +Qed. + +Theorem polynomial_simplify_ok : + forall p:polynomial, + interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p. +intro. +unfold polynomial_simplify in |- *. +rewrite spolynomial_of_ok. +rewrite polynomial_normalize_ok. +rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T). +rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T). +reflexivity. +Qed. + +End rings. + +Infix "+" := Pplus : ring_scope. +Infix "*" := Pmult : ring_scope. +Notation "- x" := (Popp x) : ring_scope. +Notation "[ x ]" := (Pvar x) (at level 1) : ring_scope. + +Delimit Scope ring_scope with ring.
\ No newline at end of file diff --git a/contrib/ring/Ring_theory.v b/contrib/ring/Ring_theory.v new file mode 100644 index 00000000..dfdfdf66 --- /dev/null +++ b/contrib/ring/Ring_theory.v @@ -0,0 +1,376 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Ring_theory.v,v 1.21.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +Require Export Bool. + +Set Implicit Arguments. + +Section Theory_of_semi_rings. + +Variable A : Type. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +(* There is also a "weakly decidable" equality on A. That means + that if (A_eq x y)=true then x=y but x=y can arise when + (A_eq x y)=false. On an abstract ring the function [x,y:A]false + is a good choice. The proof of A_eq_prop is in this case easy. *) +Variable Aeq : A -> A -> bool. + +Infix "+" := Aplus (at level 50, left associativity). +Infix "*" := Amult (at level 40, left associativity). +Notation "0" := Azero. +Notation "1" := Aone. + +Record Semi_Ring_Theory : Prop := + {SR_plus_comm : forall n m:A, n + m = m + n; + SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; + SR_mult_comm : forall n m:A, n * m = m * n; + SR_mult_assoc : forall n m p:A, n * (m * p) = n * m * p; + SR_plus_zero_left : forall n:A, 0 + n = n; + SR_mult_one_left : forall n:A, 1 * n = n; + SR_mult_zero_left : forall n:A, 0 * n = 0; + SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p; + SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p; + SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}. + +Variable T : Semi_Ring_Theory. + +Let plus_comm := SR_plus_comm T. +Let plus_assoc := SR_plus_assoc T. +Let mult_comm := SR_mult_comm T. +Let mult_assoc := SR_mult_assoc T. +Let plus_zero_left := SR_plus_zero_left T. +Let mult_one_left := SR_mult_one_left T. +Let mult_zero_left := SR_mult_zero_left T. +Let distr_left := SR_distr_left T. +Let plus_reg_left := SR_plus_reg_left T. + +Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left + mult_one_left mult_zero_left distr_left plus_reg_left. + +(* Lemmas whose form is x=y are also provided in form y=x because Auto does + not symmetry *) +Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). +symmetry in |- *; eauto. Qed. + +Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). +symmetry in |- *; eauto. Qed. + +Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n. +symmetry in |- *; eauto. Qed. + +Lemma SR_mult_one_left2 : forall n:A, n = 1 * n. +symmetry in |- *; eauto. Qed. + +Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n. +symmetry in |- *; eauto. Qed. + +Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. +symmetry in |- *; eauto. Qed. + +Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). +intros. +rewrite plus_assoc. +elim (plus_comm m n). +rewrite <- plus_assoc. +reflexivity. +Qed. + +Lemma SR_mult_permute : forall n m p:A, n * (m * p) = m * (n * p). +intros. +rewrite mult_assoc. +elim (mult_comm m n). +rewrite <- mult_assoc. +reflexivity. +Qed. + +Hint Resolve SR_plus_permute SR_mult_permute. + +Lemma SR_distr_right : forall n m p:A, n * (m + p) = n * m + n * p. +intros. +repeat rewrite (mult_comm n). +eauto. +Qed. + +Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). +symmetry in |- *; apply SR_distr_right. Qed. + +Lemma SR_mult_zero_right : forall n:A, n * 0 = 0. +intro; rewrite mult_comm; eauto. +Qed. + +Lemma SR_mult_zero_right2 : forall n:A, 0 = n * 0. +intro; rewrite mult_comm; eauto. +Qed. + +Lemma SR_plus_zero_right : forall n:A, n + 0 = n. +intro; rewrite plus_comm; eauto. +Qed. +Lemma SR_plus_zero_right2 : forall n:A, n = n + 0. +intro; rewrite plus_comm; eauto. +Qed. + +Lemma SR_mult_one_right : forall n:A, n * 1 = n. +intro; elim mult_comm; auto. +Qed. + +Lemma SR_mult_one_right2 : forall n:A, n = n * 1. +intro; elim mult_comm; auto. +Qed. + +Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. +intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto. +Qed. + +End Theory_of_semi_rings. + +Section Theory_of_rings. + +Variable A : Type. + +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. + +Infix "+" := Aplus (at level 50, left associativity). +Infix "*" := Amult (at level 40, left associativity). +Notation "0" := Azero. +Notation "1" := Aone. +Notation "- x" := (Aopp x). + +Record Ring_Theory : Prop := + {Th_plus_comm : forall n m:A, n + m = m + n; + Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; + Th_mult_sym : forall n m:A, n * m = m * n; + Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p; + Th_plus_zero_left : forall n:A, 0 + n = n; + Th_mult_one_left : forall n:A, 1 * n = n; + Th_opp_def : forall n:A, n + - n = 0; + Th_distr_left : forall n m p:A, (n + m) * p = n * p + m * p; + Th_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}. + +Variable T : Ring_Theory. + +Let plus_comm := Th_plus_comm T. +Let plus_assoc := Th_plus_assoc T. +Let mult_comm := Th_mult_sym T. +Let mult_assoc := Th_mult_assoc T. +Let plus_zero_left := Th_plus_zero_left T. +Let mult_one_left := Th_mult_one_left T. +Let opp_def := Th_opp_def T. +Let distr_left := Th_distr_left T. + +Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left + mult_one_left opp_def distr_left. + +(* Lemmas whose form is x=y are also provided in form y=x because Auto does + not symmetry *) +Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). +symmetry in |- *; eauto. Qed. + +Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). +symmetry in |- *; eauto. Qed. + +Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n. +symmetry in |- *; eauto. Qed. + +Lemma Th_mult_one_left2 : forall n:A, n = 1 * n. +symmetry in |- *; eauto. Qed. + +Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. +symmetry in |- *; eauto. Qed. + +Lemma Th_opp_def2 : forall n:A, 0 = n + - n. +symmetry in |- *; eauto. Qed. + +Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). +intros. +rewrite plus_assoc. +elim (plus_comm m n). +rewrite <- plus_assoc. +reflexivity. +Qed. + +Lemma Th_mult_permute : forall n m p:A, n * (m * p) = m * (n * p). +intros. +rewrite mult_assoc. +elim (mult_comm m n). +rewrite <- mult_assoc. +reflexivity. +Qed. + +Hint Resolve Th_plus_permute Th_mult_permute. + +Lemma aux1 : forall a:A, a + a = a -> a = 0. +intros. +generalize (opp_def a). +pattern a at 1 in |- *. +rewrite <- H. +rewrite <- plus_assoc. +rewrite opp_def. +elim plus_comm. +rewrite plus_zero_left. +trivial. +Qed. + +Lemma Th_mult_zero_left : forall n:A, 0 * n = 0. +intros. +apply aux1. +rewrite <- distr_left. +rewrite plus_zero_left. +reflexivity. +Qed. +Hint Resolve Th_mult_zero_left. + +Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n. +symmetry in |- *; eauto. Qed. + +Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z. +intros. +rewrite <- (plus_zero_left y). +elim H0. +elim plus_assoc. +elim (plus_comm y z). +rewrite plus_assoc. +rewrite H. +rewrite plus_zero_left. +reflexivity. +Qed. + +Lemma Th_opp_mult_left : forall x y:A, - (x * y) = - x * y. +intros. +apply (aux2 (x:=(x * y))); + [ apply opp_def | rewrite <- distr_left; rewrite opp_def; auto ]. +Qed. +Hint Resolve Th_opp_mult_left. + +Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y). +symmetry in |- *; eauto. Qed. + +Lemma Th_mult_zero_right : forall n:A, n * 0 = 0. +intro; elim mult_comm; eauto. +Qed. + +Lemma Th_mult_zero_right2 : forall n:A, 0 = n * 0. +intro; elim mult_comm; eauto. +Qed. + +Lemma Th_plus_zero_right : forall n:A, n + 0 = n. +intro; rewrite plus_comm; eauto. +Qed. + +Lemma Th_plus_zero_right2 : forall n:A, n = n + 0. +intro; rewrite plus_comm; eauto. +Qed. + +Lemma Th_mult_one_right : forall n:A, n * 1 = n. +intro; elim mult_comm; eauto. +Qed. + +Lemma Th_mult_one_right2 : forall n:A, n = n * 1. +intro; elim mult_comm; eauto. +Qed. + +Lemma Th_opp_mult_right : forall x y:A, - (x * y) = x * - y. +intros; do 2 rewrite (mult_comm x); auto. +Qed. + +Lemma Th_opp_mult_right2 : forall x y:A, x * - y = - (x * y). +intros; do 2 rewrite (mult_comm x); auto. +Qed. + +Lemma Th_plus_opp_opp : forall x y:A, - x + - y = - (x + y). +intros. +apply (aux2 (x:=(x + y))); + [ elim plus_assoc; rewrite (Th_plus_permute y (- x)); rewrite plus_assoc; + rewrite opp_def; rewrite plus_zero_left; auto + | auto ]. +Qed. + +Lemma Th_plus_permute_opp : forall n m p:A, - m + (n + p) = n + (- m + p). +eauto. Qed. + +Lemma Th_opp_opp : forall n:A, - - n = n. +intro; apply (aux2 (x:=(- n))); [ auto | elim plus_comm; auto ]. +Qed. +Hint Resolve Th_opp_opp. + +Lemma Th_opp_opp2 : forall n:A, n = - - n. +symmetry in |- *; eauto. Qed. + +Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y. +intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto. +Qed. + +Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y. +symmetry in |- *; apply Th_mult_opp_opp. Qed. + +Lemma Th_opp_zero : - 0 = 0. +rewrite <- (plus_zero_left (- 0)). +auto. Qed. + +Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p. +intros; generalize (f_equal (fun z => - n + z) H). +repeat rewrite plus_assoc. +rewrite (plus_comm (- n) n). +rewrite opp_def. +repeat rewrite Th_plus_zero_left; eauto. +Qed. + +Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. +intros. +eapply Th_plus_reg_left with n. +rewrite (plus_comm n m). +rewrite (plus_comm n p). +auto. +Qed. + +Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p. +intros. +repeat rewrite (mult_comm n). +eauto. +Qed. + +Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). +symmetry in |- *; apply Th_distr_right. +Qed. + +End Theory_of_rings. + +Hint Resolve Th_mult_zero_left Th_plus_reg_left: core. + +Unset Implicit Arguments. + +Definition Semi_Ring_Theory_of : + forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) + (Aopp:A -> A) (Aeq:A -> A -> bool), + Ring_Theory Aplus Amult Aone Azero Aopp Aeq -> + Semi_Ring_Theory Aplus Amult Aone Azero Aeq. +intros until 1; case H. +split; intros; simpl in |- *; eauto. +Defined. + +(* Every ring can be viewed as a semi-ring : this property will be used + in Abstract_polynom. *) +Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory. + + +Section product_ring. + +End product_ring. + +Section power_ring. + +End power_ring.
\ No newline at end of file diff --git a/contrib/ring/Setoid_ring.v b/contrib/ring/Setoid_ring.v new file mode 100644 index 00000000..c4537fe3 --- /dev/null +++ b/contrib/ring/Setoid_ring.v @@ -0,0 +1,13 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Setoid_ring.v,v 1.4.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +Require Export Setoid_ring_theory. +Require Export Quote. +Require Export Setoid_ring_normalize.
\ No newline at end of file diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v new file mode 100644 index 00000000..0c9c1e6a --- /dev/null +++ b/contrib/ring/Setoid_ring_normalize.v @@ -0,0 +1,1137 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Setoid_ring_normalize.v,v 1.11.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +Require Import Setoid_ring_theory. +Require Import Quote. + +Set Implicit Arguments. + +Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m. +Proof. + simple induction n; simple induction m; simpl in |- *; + try reflexivity || contradiction. + intros; rewrite (H i0); trivial. + intros; rewrite (H i0); trivial. +Qed. + +Section setoid. + +Variable A : Type. +Variable Aequiv : A -> A -> Prop. +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. + +Variable S : Setoid_Theory A Aequiv. + +Add Setoid A Aequiv S. + +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 opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0). + +Add Morphism Aplus : Aplus_ext. +exact plus_morph. +Qed. + +Add Morphism Amult : Amult_ext. +exact mult_morph. +Qed. + +Add Morphism Aopp : Aopp_ext. +exact opp_morph. +Qed. + +Let equiv_refl := Seq_refl A Aequiv S. +Let equiv_sym := Seq_sym A Aequiv S. +Let equiv_trans := Seq_trans A Aequiv S. + +Hint Resolve equiv_refl equiv_trans. +Hint Immediate equiv_sym. + +Section semi_setoid_rings. + +(* Section definitions. *) + + +(******************************************) +(* Normal abtract Polynomials *) +(******************************************) +(* DEFINITIONS : +- A varlist is a sorted product of one or more variables : x, x*y*z +- A monom is a constant, a varlist or the product of a constant by a varlist + variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. +- A canonical sum is either a monom or an ordered sum of monoms + (the order on monoms is defined later) +- A normal polynomial it either a constant or a canonical sum or a constant + plus a canonical sum +*) + +(* varlist is isomorphic to (list var), but we built a special inductive + for efficiency *) +Inductive varlist : Type := + | Nil_var : varlist + | Cons_var : index -> varlist -> varlist. + +Inductive canonical_sum : Type := + | Nil_monom : canonical_sum + | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum + | Cons_varlist : varlist -> canonical_sum -> canonical_sum. + +(* Order on monoms *) + +(* That's the lexicographic order on varlist, extended by : + - A constant is less than every monom + - The relation between two varlist is preserved by multiplication by a + constant. + + Examples : + 3 < x < y + x*y < x*y*y*z + 2*x*y < x*y*y*z + x*y < 54*x*y*y*z + 4*x*y < 59*x*y*y*z +*) + +Fixpoint varlist_eq (x y:varlist) {struct y} : bool := + match x, y with + | Nil_var, Nil_var => true + | Cons_var i xrest, Cons_var j yrest => + andb (index_eq i j) (varlist_eq xrest yrest) + | _, _ => false + end. + +Fixpoint varlist_lt (x y:varlist) {struct y} : bool := + match x, y with + | Nil_var, Cons_var _ _ => true + | Cons_var i xrest, Cons_var j yrest => + if index_lt i j + then true + else andb (index_eq i j) (varlist_lt xrest yrest) + | _, _ => false + end. + +(* merges two variables lists *) +Fixpoint varlist_merge (l1:varlist) : varlist -> varlist := + match l1 with + | Cons_var v1 t1 => + (fix vm_aux (l2:varlist) : varlist := + match l2 with + | Cons_var v2 t2 => + if index_lt v1 v2 + then Cons_var v1 (varlist_merge t1 l2) + else Cons_var v2 (vm_aux t2) + | Nil_var => l1 + end) + | Nil_var => fun l2 => l2 + end. + +(* returns the sum of two canonical sums *) +Fixpoint canonical_sum_merge (s1:canonical_sum) : + canonical_sum -> canonical_sum := + match s1 with + | Cons_monom c1 l1 t1 => + (fix csm_aux (s2:canonical_sum) : canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 (canonical_sum_merge t1 s2) + else Cons_monom c2 l2 (csm_aux t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 (canonical_sum_merge t1 s2) + else Cons_varlist l2 (csm_aux t2) + | Nil_monom => s1 + end) + | Cons_varlist l1 t1 => + (fix csm_aux2 (s2:canonical_sum) : canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_varlist l1 (canonical_sum_merge t1 s2) + else Cons_monom c2 l2 (csm_aux2 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2) + else + if varlist_lt l1 l2 + then Cons_varlist l1 (canonical_sum_merge t1 s2) + else Cons_varlist l2 (csm_aux2 t2) + | Nil_monom => s1 + end) + | Nil_monom => fun s2 => s2 + end. + +(* Insertion of a monom in a canonical sum *) +Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} : + canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 c2) l1 t2 + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 s2 + else Cons_monom c2 l2 (monom_insert c1 l1 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus c1 Aone) l1 t2 + else + if varlist_lt l1 l2 + then Cons_monom c1 l1 s2 + else Cons_varlist l2 (monom_insert c1 l1 t2) + | Nil_monom => Cons_monom c1 l1 Nil_monom + end. + +Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} : + canonical_sum := + match s2 with + | Cons_monom c2 l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone c2) l1 t2 + else + if varlist_lt l1 l2 + then Cons_varlist l1 s2 + else Cons_monom c2 l2 (varlist_insert l1 t2) + | Cons_varlist l2 t2 => + if varlist_eq l1 l2 + then Cons_monom (Aplus Aone Aone) l1 t2 + else + if varlist_lt l1 l2 + then Cons_varlist l1 s2 + else Cons_varlist l2 (varlist_insert l1 t2) + | Nil_monom => Cons_varlist l1 Nil_monom + end. + +(* Computes c0*s *) +Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} : + canonical_sum := + match s with + | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t) + | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t) + | Nil_monom => Nil_monom + end. + +(* Computes l0*s *) +Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : + canonical_sum := + match s with + | Cons_monom c l t => + monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) + | Cons_varlist l t => + varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t) + | Nil_monom => Nil_monom + end. + +(* Computes c0*l0*s *) +Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) + (s:canonical_sum) {struct s} : canonical_sum := + match s with + | Cons_monom c l t => + monom_insert (Amult c0 c) (varlist_merge l0 l) + (canonical_sum_scalar3 c0 l0 t) + | Cons_varlist l t => + monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t) + | Nil_monom => Nil_monom + end. + +(* returns the product of two canonical sums *) +Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : + canonical_sum := + match s1 with + | Cons_monom c1 l1 t1 => + canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2) + (canonical_sum_prod t1 s2) + | Cons_varlist l1 t1 => + canonical_sum_merge (canonical_sum_scalar2 l1 s2) + (canonical_sum_prod t1 s2) + | Nil_monom => Nil_monom + end. + +(* The type to represent concrete semi-setoid-ring polynomials *) + +Inductive setspolynomial : Type := + | SetSPvar : index -> setspolynomial + | SetSPconst : A -> setspolynomial + | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial + | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial. + +Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum := + match p with + | SetSPplus l r => + canonical_sum_merge (setspolynomial_normalize l) + (setspolynomial_normalize r) + | SetSPmult l r => + canonical_sum_prod (setspolynomial_normalize l) + (setspolynomial_normalize r) + | SetSPconst c => Cons_monom c Nil_var Nil_monom + | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom + end. + +Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum := + match s with + | Cons_monom c l t => + if Aeq c Azero + then canonical_sum_simplify t + else + if Aeq c Aone + then Cons_varlist l (canonical_sum_simplify t) + else Cons_monom c l (canonical_sum_simplify t) + | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t) + | Nil_monom => Nil_monom + end. + +Definition setspolynomial_simplify (x:setspolynomial) := + canonical_sum_simplify (setspolynomial_normalize x). + +Variable vm : varmap A. + +Definition interp_var (i:index) := varmap_find Azero i vm. + +Definition ivl_aux := + (fix ivl_aux (x:index) (t:varlist) {struct t} : A := + match t with + | Nil_var => interp_var x + | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t') + end). + +Definition interp_vl (l:varlist) := + match l with + | Nil_var => Aone + | Cons_var x t => ivl_aux x t + end. + +Definition interp_m (c:A) (l:varlist) := + match l with + | Nil_var => c + | Cons_var x t => Amult c (ivl_aux x t) + end. + +Definition ics_aux := + (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A := + match s with + | Nil_monom => a + | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t) + | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t) + end). + +Definition interp_setcs (s:canonical_sum) : A := + match s with + | Nil_monom => Azero + | Cons_varlist l t => ics_aux (interp_vl l) t + | Cons_monom c l t => ics_aux (interp_m c l) t + end. + +Fixpoint interp_setsp (p:setspolynomial) : A := + match p with + | SetSPconst c => c + | SetSPvar i => interp_var i + | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2) + | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2) + end. + +(* End interpretation. *) + +Unset Implicit Arguments. + +(* Section properties. *) + +Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq. + +Hint Resolve (SSR_plus_comm T). +Hint Resolve (SSR_plus_assoc T). +Hint Resolve (SSR_plus_assoc2 S T). +Hint Resolve (SSR_mult_comm T). +Hint Resolve (SSR_mult_assoc T). +Hint Resolve (SSR_mult_assoc2 S T). +Hint Resolve (SSR_plus_zero_left T). +Hint Resolve (SSR_plus_zero_left2 S T). +Hint Resolve (SSR_mult_one_left T). +Hint Resolve (SSR_mult_one_left2 S T). +Hint Resolve (SSR_mult_zero_left T). +Hint Resolve (SSR_mult_zero_left2 S T). +Hint Resolve (SSR_distr_left T). +Hint Resolve (SSR_distr_left2 S T). +Hint Resolve (SSR_plus_reg_left T). +Hint Resolve (SSR_plus_permute S plus_morph T). +Hint Resolve (SSR_mult_permute S mult_morph T). +Hint Resolve (SSR_distr_right S plus_morph T). +Hint Resolve (SSR_distr_right2 S plus_morph T). +Hint Resolve (SSR_mult_zero_right S T). +Hint Resolve (SSR_mult_zero_right2 S T). +Hint Resolve (SSR_plus_zero_right S T). +Hint Resolve (SSR_plus_zero_right2 S T). +Hint Resolve (SSR_mult_one_right S T). +Hint Resolve (SSR_mult_one_right2 S T). +Hint Resolve (SSR_plus_reg_right S T). +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + +Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. +Proof. + simple induction x; simple induction y; contradiction || (try reflexivity). + simpl in |- *; intros. + generalize (andb_prop2 _ _ H1); intros; elim H2; intros. + rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. +Qed. + +Remark ivl_aux_ok : + forall (v:varlist) (i:index), + Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)). +Proof. + simple induction v; simpl in |- *; intros. + trivial. + rewrite (H i); trivial. +Qed. + +Lemma varlist_merge_ok : + forall x y:varlist, + Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)). +Proof. + simple induction x. + simpl in |- *; trivial. + simple induction y. + simpl in |- *; trivial. + simpl in |- *; intros. + elim (index_lt i i0); simpl in |- *; intros. + + rewrite (ivl_aux_ok v i). + rewrite (ivl_aux_ok v0 i0). + rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i). + rewrite (H (Cons_var i0 v0)). + simpl in |- *. + rewrite (ivl_aux_ok v0 i0). + eauto. + + rewrite (ivl_aux_ok v i). + rewrite (ivl_aux_ok v0 i0). + rewrite + (ivl_aux_ok + ((fix vm_aux (l2:varlist) : varlist := + match l2 with + | Nil_var => Cons_var i v + | Cons_var v2 t2 => + if index_lt i v2 + then Cons_var i (varlist_merge v l2) + else Cons_var v2 (vm_aux t2) + end) v0) i0). + rewrite H0. + rewrite (ivl_aux_ok v i). + eauto. +Qed. + +Remark ics_aux_ok : + forall (x:A) (s:canonical_sum), + Aequiv (ics_aux x s) (Aplus x (interp_setcs s)). +Proof. + simple induction s; simpl in |- *; intros; trivial. +Qed. + +Remark interp_m_ok : + forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)). +Proof. + destruct l as [| i v]; trivial. +Qed. + +Hint Resolve ivl_aux_ok. +Hint Resolve ics_aux_ok. +Hint Resolve interp_m_ok. + +(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *) + +Lemma canonical_sum_merge_ok : + forall x y:canonical_sum, + Aequiv (interp_setcs (canonical_sum_merge x y)) + (Aplus (interp_setcs x) (interp_setcs y)). +Proof. +simple induction x; simpl in |- *. +trivial. + +simple induction y; simpl in |- *; intros. +eauto. + +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *. +rewrite (ics_aux_ok (interp_m a v0) c). +rewrite (ics_aux_ok (interp_m a0 v0) c0). +rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)). +rewrite (H c0). +rewrite (interp_m_ok (Aplus a a0) v0). +rewrite (interp_m_ok a v0). +rewrite (interp_m_ok a0 v0). +setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with + (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0))). +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)))). +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)))). +auto. + +elim (varlist_lt v v0); simpl in |- *. +intro. +rewrite + (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0))) + . +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (ics_aux_ok (interp_m a0 v0) c0). +rewrite (H (Cons_monom a0 v0 c0)); simpl in |- *. +rewrite (ics_aux_ok (interp_m a0 v0) c0); auto. + +intro. +rewrite + (ics_aux_ok (interp_m a0 v0) + ((fix csm_aux (s2:canonical_sum) : canonical_sum := + match s2 with + | Nil_monom => Cons_monom a v c + | Cons_monom c2 l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_monom a v (canonical_sum_merge c s2) + else Cons_monom c2 l2 (csm_aux t2) + | Cons_varlist l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_monom a v (canonical_sum_merge c s2) + else Cons_varlist l2 (csm_aux t2) + end) c0)). +rewrite H0. +rewrite (ics_aux_ok (interp_m a v) c); + rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; + auto. + +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0)); + rewrite (ics_aux_ok (interp_m a v0) c); + rewrite (ics_aux_ok (interp_vl v0) c0). +rewrite (H c0). +rewrite (interp_m_ok (Aplus a Aone) v0). +rewrite (interp_m_ok a v0). +setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with + (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0))). +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)))). +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). +auto. + +elim (varlist_lt v v0); simpl in |- *. +intro. +rewrite + (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0))) + ; rewrite (ics_aux_ok (interp_m a v) c); + rewrite (ics_aux_ok (interp_vl v0) c0). +rewrite (H (Cons_varlist v0 c0)); simpl in |- *. +rewrite (ics_aux_ok (interp_vl v0) c0). +auto. + +intro. +rewrite + (ics_aux_ok (interp_vl v0) + ((fix csm_aux (s2:canonical_sum) : canonical_sum := + match s2 with + | Nil_monom => Cons_monom a v c + | Cons_monom c2 l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_monom a v (canonical_sum_merge c s2) + else Cons_monom c2 l2 (csm_aux t2) + | Cons_varlist l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_monom a v (canonical_sum_merge c s2) + else Cons_varlist l2 (csm_aux t2) + end) c0)); rewrite H0. +rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0); + simpl in |- *. +auto. + +simple induction y; simpl in |- *; intros. +trivial. + +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0). +intros; rewrite (H1 I). +simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0)); + rewrite (ics_aux_ok (interp_vl v0) c); + rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0). +rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0). +setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with + (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0))); + 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)))). +auto. + +elim (varlist_lt v v0); simpl in |- *; intros. +rewrite + (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0))) + ; rewrite (ics_aux_ok (interp_vl v) c); + rewrite (ics_aux_ok (interp_m a v0) c0). +rewrite (H (Cons_monom a v0 c0)); simpl in |- *. +rewrite (ics_aux_ok (interp_m a v0) c0); auto. + +rewrite + (ics_aux_ok (interp_m a v0) + ((fix csm_aux2 (s2:canonical_sum) : canonical_sum := + match s2 with + | Nil_monom => Cons_varlist v c + | Cons_monom c2 l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_varlist v (canonical_sum_merge c s2) + else Cons_monom c2 l2 (csm_aux2 t2) + | Cons_varlist l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_varlist v (canonical_sum_merge c s2) + else Cons_varlist l2 (csm_aux2 t2) + end) c0)); rewrite H0. +rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0); + simpl in |- *; auto. + +generalize (varlist_eq_prop v v0). +elim (varlist_eq v v0); intros. +rewrite (H1 I); simpl in |- *. +rewrite + (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0)) + ; rewrite (ics_aux_ok (interp_vl v0) c); + rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0). +rewrite (interp_m_ok (Aplus Aone Aone) v0). +setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with + (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0))); + 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)))). +setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto. + +elim (varlist_lt v v0); simpl in |- *. +rewrite + (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0))) + ; rewrite (ics_aux_ok (interp_vl v) c); + rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0)); + simpl in |- *. +rewrite (ics_aux_ok (interp_vl v0) c0); auto. + +rewrite + (ics_aux_ok (interp_vl v0) + ((fix csm_aux2 (s2:canonical_sum) : canonical_sum := + match s2 with + | Nil_monom => Cons_varlist v c + | Cons_monom c2 l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_varlist v (canonical_sum_merge c s2) + else Cons_monom c2 l2 (csm_aux2 t2) + | Cons_varlist l2 t2 => + if varlist_eq v l2 + then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2) + else + if varlist_lt v l2 + then Cons_varlist v (canonical_sum_merge c s2) + else Cons_varlist l2 (csm_aux2 t2) + end) c0)); rewrite H0. +rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0); + simpl in |- *; auto. +Qed. + +Lemma monom_insert_ok : + forall (a:A) (l:varlist) (s:canonical_sum), + Aequiv (interp_setcs (monom_insert a l s)) + (Aplus (Amult a (interp_vl l)) (interp_setcs s)). +Proof. +simple induction s; intros. +simpl in |- *; rewrite (interp_m_ok a l); trivial. + +simpl in |- *; generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c); + rewrite (ics_aux_ok (interp_m a0 v) c). +rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v). +setoid_replace (Amult (Aplus a a0) (interp_vl v)) with + (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v))). +auto. + +elim (varlist_lt l v); simpl in |- *; intros. +rewrite (ics_aux_ok (interp_m a0 v) c). +rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l). +auto. + +rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c)); + rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H. +auto. + +simpl in |- *. +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c); + rewrite (ics_aux_ok (interp_vl v) c). +rewrite (interp_m_ok (Aplus a Aone) v). +setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with + (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v))). +setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v). +auto. + +elim (varlist_lt l v); simpl in |- *; intros; auto. +rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H. +rewrite (ics_aux_ok (interp_vl v) c); auto. +Qed. + +Lemma varlist_insert_ok : + forall (l:varlist) (s:canonical_sum), + Aequiv (interp_setcs (varlist_insert l s)) + (Aplus (interp_vl l) (interp_setcs s)). +Proof. +simple induction s; simpl in |- *; intros. +trivial. + +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c); + rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v). +setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with + (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v))). +setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. + +elim (varlist_lt l v); simpl in |- *; intros; auto. +rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c)); + rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite H; auto. + +generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl in |- *. +rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c); + rewrite (ics_aux_ok (interp_vl v) c). +rewrite (interp_m_ok (Aplus Aone Aone) v). +setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with + (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v))). +setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. + +elim (varlist_lt l v); simpl in |- *; intros; auto. +rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)). +rewrite H. +rewrite (ics_aux_ok (interp_vl v) c); auto. +Qed. + +Lemma canonical_sum_scalar_ok : + forall (a:A) (s:canonical_sum), + Aequiv (interp_setcs (canonical_sum_scalar a s)) + (Amult a (interp_setcs s)). +Proof. +simple induction s; simpl in |- *; intros. +trivial. + +rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c)); + rewrite (ics_aux_ok (interp_m a0 v) c). +rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v). +rewrite H. +setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c))) + with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c))). +auto. + +rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c)); + rewrite (ics_aux_ok (interp_vl v) c); rewrite H. +rewrite (interp_m_ok a v). +auto. +Qed. + +Lemma canonical_sum_scalar2_ok : + forall (l:varlist) (s:canonical_sum), + Aequiv (interp_setcs (canonical_sum_scalar2 l s)) + (Amult (interp_vl l) (interp_setcs s)). +Proof. +simple induction s; simpl in |- *; intros; auto. +rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)). +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite H. +rewrite (varlist_merge_ok l v). +setoid_replace + (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with + (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) + (Amult (interp_vl l) (interp_setcs c))). +auto. + +rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)). +rewrite (ics_aux_ok (interp_vl v) c). +rewrite H. +rewrite (varlist_merge_ok l v). +auto. +Qed. + +Lemma canonical_sum_scalar3_ok : + forall (c:A) (l:varlist) (s:canonical_sum), + Aequiv (interp_setcs (canonical_sum_scalar3 c l s)) + (Amult c (Amult (interp_vl l) (interp_setcs s))). +Proof. +simple induction s; simpl in |- *; intros. +rewrite (SSR_mult_zero_right S T (interp_vl l)). +auto. + +rewrite + (monom_insert_ok (Amult c a) (varlist_merge l v) + (canonical_sum_scalar3 c l c0)). +rewrite (ics_aux_ok (interp_m a v) c0). +rewrite (interp_m_ok a v). +rewrite H. +rewrite (varlist_merge_ok l v). +setoid_replace + (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with + (Aplus (Amult (interp_vl l) (Amult a (interp_vl v))) + (Amult (interp_vl l) (interp_setcs c0))). +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)))). +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)))). +auto. + +rewrite + (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0)) + . +rewrite (ics_aux_ok (interp_vl v) c0). +rewrite H. +rewrite (varlist_merge_ok l v). +setoid_replace + (Aplus (Amult c (Amult (interp_vl l) (interp_vl v))) + (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with + (Amult c + (Aplus (Amult (interp_vl l) (interp_vl v)) + (Amult (interp_vl l) (interp_setcs c0)))). +auto. +Qed. + +Lemma canonical_sum_prod_ok : + forall x y:canonical_sum, + Aequiv (interp_setcs (canonical_sum_prod x y)) + (Amult (interp_setcs x) (interp_setcs y)). +Proof. +simple induction x; simpl in |- *; intros. +trivial. + +rewrite + (canonical_sum_merge_ok (canonical_sum_scalar3 a v y) + (canonical_sum_prod c y)). +rewrite (canonical_sum_scalar3_ok a v y). +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite (H y). +setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with + (Amult (Amult a (interp_vl v)) (interp_setcs y)). +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))). +trivial. + +rewrite + (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y)) + . +rewrite (canonical_sum_scalar2_ok v y). +rewrite (ics_aux_ok (interp_vl v) c). +rewrite (H y). +trivial. +Qed. + +Theorem setspolynomial_normalize_ok : + forall p:setspolynomial, + Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p). +Proof. +simple induction p; simpl in |- *; intros; trivial. +rewrite + (canonical_sum_merge_ok (setspolynomial_normalize s) + (setspolynomial_normalize s0)). +rewrite H; rewrite H0; trivial. + +rewrite + (canonical_sum_prod_ok (setspolynomial_normalize s) + (setspolynomial_normalize s0)). +rewrite H; rewrite H0; trivial. +Qed. + +Lemma canonical_sum_simplify_ok : + forall s:canonical_sum, + Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s). +Proof. +simple induction s; simpl in |- *; intros. +trivial. + +generalize (SSR_eq_prop T a Azero). +elim (Aeq a Azero). +simpl in |- *. +intros. +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite (H0 I). +setoid_replace (Amult Azero (interp_vl v)) with Azero. +rewrite H. +trivial. + +intros; simpl in |- *. +generalize (SSR_eq_prop T a Aone). +elim (Aeq a Aone). +intros. +rewrite (ics_aux_ok (interp_m a v) c). +rewrite (interp_m_ok a v). +rewrite (H1 I). +simpl in |- *. +rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). +rewrite H. +auto. + +simpl in |- *. +intros. +rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)). +rewrite (ics_aux_ok (interp_m a v) c). +rewrite H; trivial. + +rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). +rewrite H. +auto. +Qed. + +Theorem setspolynomial_simplify_ok : + forall p:setspolynomial, + Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p). +Proof. +intro. +unfold setspolynomial_simplify in |- *. +rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)). +exact (setspolynomial_normalize_ok p). +Qed. + +End semi_setoid_rings. + +Implicit Arguments Cons_varlist. +Implicit Arguments Cons_monom. +Implicit Arguments SetSPconst. +Implicit Arguments SetSPplus. +Implicit Arguments SetSPmult. + + + +Section setoid_rings. + +Set Implicit Arguments. + +Variable vm : varmap A. +Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq. + +Hint Resolve (STh_plus_comm T). +Hint Resolve (STh_plus_assoc T). +Hint Resolve (STh_plus_assoc2 S T). +Hint Resolve (STh_mult_sym T). +Hint Resolve (STh_mult_assoc T). +Hint Resolve (STh_mult_assoc2 S T). +Hint Resolve (STh_plus_zero_left T). +Hint Resolve (STh_plus_zero_left2 S T). +Hint Resolve (STh_mult_one_left T). +Hint Resolve (STh_mult_one_left2 S T). +Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T). +Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T). +Hint Resolve (STh_distr_left T). +Hint Resolve (STh_distr_left2 S T). +Hint Resolve (STh_plus_reg_left S plus_morph T). +Hint Resolve (STh_plus_permute S plus_morph T). +Hint Resolve (STh_mult_permute S mult_morph T). +Hint Resolve (STh_distr_right S plus_morph T). +Hint Resolve (STh_distr_right2 S plus_morph T). +Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T). +Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T). +Hint Resolve (STh_plus_zero_right S T). +Hint Resolve (STh_plus_zero_right2 S T). +Hint Resolve (STh_mult_one_right S T). +Hint Resolve (STh_mult_one_right2 S T). +Hint Resolve (STh_plus_reg_right S plus_morph T). +Hint Resolve refl_equal sym_equal trans_equal. +(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Immediate T. + + +(*** Definitions *) + +Inductive setpolynomial : Type := + | SetPvar : index -> setpolynomial + | SetPconst : A -> setpolynomial + | SetPplus : setpolynomial -> setpolynomial -> setpolynomial + | SetPmult : setpolynomial -> setpolynomial -> setpolynomial + | SetPopp : setpolynomial -> setpolynomial. + +Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum := + match x with + | SetPplus l r => + canonical_sum_merge (setpolynomial_normalize l) + (setpolynomial_normalize r) + | SetPmult l r => + canonical_sum_prod (setpolynomial_normalize l) + (setpolynomial_normalize r) + | SetPconst c => Cons_monom c Nil_var Nil_monom + | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom + | SetPopp p => + canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p) + end. + +Definition setpolynomial_simplify (x:setpolynomial) := + canonical_sum_simplify (setpolynomial_normalize x). + +Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial := + match x with + | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r) + | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r) + | SetPconst c => SetSPconst c + | SetPvar i => SetSPvar i + | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p) + end. + +(*** Interpretation *) + +Fixpoint interp_setp (p:setpolynomial) : A := + match p with + | SetPconst c => c + | SetPvar i => varmap_find Azero i vm + | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2) + | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2) + | SetPopp p1 => Aopp (interp_setp p1) + end. + +(*** Properties *) + +Unset Implicit Arguments. + +Lemma setspolynomial_of_ok : + forall p:setpolynomial, + Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)). +simple induction p; trivial; simpl in |- *; intros. +rewrite H; rewrite H0; trivial. +rewrite H; rewrite H0; trivial. +rewrite H. +rewrite + (STh_opp_mult_left2 S plus_morph mult_morph T Aone + (interp_setsp vm (setspolynomial_of s))). +rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))). +trivial. +Qed. + +Theorem setpolynomial_normalize_ok : + forall p:setpolynomial, + setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p). +simple induction p; trivial; simpl in |- *; intros. +rewrite H; rewrite H0; reflexivity. +rewrite H; rewrite H0; reflexivity. +rewrite H; simpl in |- *. +elim + (canonical_sum_scalar3 (Aopp Aone) Nil_var + (setspolynomial_normalize (setspolynomial_of s))); + [ reflexivity + | simpl in |- *; intros; rewrite H0; reflexivity + | simpl in |- *; intros; rewrite H0; reflexivity ]. +Qed. + +Theorem setpolynomial_simplify_ok : + forall p:setpolynomial, + Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p). +intro. +unfold setpolynomial_simplify in |- *. +rewrite (setspolynomial_of_ok p). +rewrite setpolynomial_normalize_ok. +rewrite + (canonical_sum_simplify_ok vm + (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq + plus_morph mult_morph T) + (setspolynomial_normalize (setspolynomial_of p))) + . +rewrite + (setspolynomial_normalize_ok vm + (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq + plus_morph mult_morph T) (setspolynomial_of p)) + . +trivial. +Qed. + +End setoid_rings. + +End setoid.
\ No newline at end of file diff --git a/contrib/ring/Setoid_ring_theory.v b/contrib/ring/Setoid_ring_theory.v new file mode 100644 index 00000000..69712216 --- /dev/null +++ b/contrib/ring/Setoid_ring_theory.v @@ -0,0 +1,427 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: Setoid_ring_theory.v,v 1.16.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +Require Export Bool. +Require Export Setoid. + +Set Implicit Arguments. + +Section Setoid_rings. + +Variable A : Type. +Variable Aequiv : A -> A -> Prop. + +Infix Local "==" := Aequiv (at level 70, no associativity). + +Variable S : Setoid_Theory A Aequiv. + +Add Setoid A Aequiv S. + +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. + +Infix "+" := Aplus (at level 50, left associativity). +Infix "*" := Amult (at level 40, left associativity). +Notation "0" := Azero. +Notation "1" := Aone. +Notation "- x" := (Aopp x). + +Variable + plus_morph : forall a a0 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 opp_morph : forall a a0:A, a == a0 -> - a == - a0. + +Add Morphism Aplus : Aplus_ext. +exact plus_morph. +Qed. + +Add Morphism Amult : Amult_ext. +exact mult_morph. +Qed. + +Add Morphism Aopp : Aopp_ext. +exact opp_morph. +Qed. + +Section Theory_of_semi_setoid_rings. + +Record Semi_Setoid_Ring_Theory : Prop := + {SSR_plus_comm : forall n m:A, n + m == m + n; + SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; + SSR_mult_comm : forall n m:A, n * m == m * n; + SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p; + SSR_plus_zero_left : forall n:A, 0 + n == n; + SSR_mult_one_left : forall n:A, 1 * n == n; + SSR_mult_zero_left : forall n:A, 0 * n == 0; + SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p; + SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p; + SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}. + +Variable T : Semi_Setoid_Ring_Theory. + +Let plus_comm := SSR_plus_comm T. +Let plus_assoc := SSR_plus_assoc T. +Let mult_comm := SSR_mult_comm T. +Let mult_assoc := SSR_mult_assoc T. +Let plus_zero_left := SSR_plus_zero_left T. +Let mult_one_left := SSR_mult_one_left T. +Let mult_zero_left := SSR_mult_zero_left T. +Let distr_left := SSR_distr_left T. +Let plus_reg_left := SSR_plus_reg_left T. +Let equiv_refl := Seq_refl A Aequiv S. +Let equiv_sym := Seq_sym A Aequiv S. +Let equiv_trans := Seq_trans A Aequiv S. + +Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left + mult_one_left mult_zero_left distr_left plus_reg_left + equiv_refl (*equiv_sym*). +Hint Immediate equiv_sym. + +(* Lemmas whose form is x=y are also provided in form y=x because + Auto does not symmetry *) +Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). +auto. Qed. + +Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p). +auto. Qed. + +Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n. +auto. Qed. + +Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n. +auto. Qed. + +Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n. +auto. Qed. + +Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p. +auto. Qed. + +Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p). +intros. +rewrite (plus_assoc n m p). +rewrite (plus_comm n m). +rewrite <- (plus_assoc m n p). +trivial. +Qed. + +Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p). +intros. +rewrite (mult_assoc n m p). +rewrite (mult_comm n m). +rewrite <- (mult_assoc m n p). +trivial. +Qed. + +Hint Resolve SSR_plus_permute SSR_mult_permute. + +Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p. +intros. +rewrite (mult_comm n (m + p)). +rewrite (mult_comm n m). +rewrite (mult_comm n p). +auto. +Qed. + +Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p). +intros. +apply equiv_sym. +apply SSR_distr_right. +Qed. + +Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0. +intro; rewrite (mult_comm n 0); auto. +Qed. + +Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0. +intro; rewrite (mult_comm n 0); auto. +Qed. + +Lemma SSR_plus_zero_right : forall n:A, n + 0 == n. +intro; rewrite (plus_comm n 0); auto. +Qed. + +Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0. +intro; rewrite (plus_comm n 0); auto. +Qed. + +Lemma SSR_mult_one_right : forall n:A, n * 1 == n. +intro; rewrite (mult_comm n 1); auto. +Qed. + +Lemma SSR_mult_one_right2 : forall n:A, n == n * 1. +intro; rewrite (mult_comm n 1); auto. +Qed. + +Lemma SSR_plus_reg_right : forall n m p:A, m + n == p + n -> m == p. +intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n). +intro; apply plus_reg_left with n; trivial. +Qed. + +End Theory_of_semi_setoid_rings. + +Section Theory_of_setoid_rings. + +Record Setoid_Ring_Theory : Prop := + {STh_plus_comm : forall n m:A, n + m == m + n; + STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; + STh_mult_sym : forall n m:A, n * m == m * n; + STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p; + STh_plus_zero_left : forall n:A, 0 + n == n; + STh_mult_one_left : forall n:A, 1 * n == n; + STh_opp_def : forall n:A, n + - n == 0; + STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p; + STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}. + +Variable T : Setoid_Ring_Theory. + +Let plus_comm := STh_plus_comm T. +Let plus_assoc := STh_plus_assoc T. +Let mult_comm := STh_mult_sym T. +Let mult_assoc := STh_mult_assoc T. +Let plus_zero_left := STh_plus_zero_left T. +Let mult_one_left := STh_mult_one_left T. +Let opp_def := STh_opp_def T. +Let distr_left := STh_distr_left T. +Let equiv_refl := Seq_refl A Aequiv S. +Let equiv_sym := Seq_sym A Aequiv S. +Let equiv_trans := Seq_trans A Aequiv S. + +Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left + mult_one_left opp_def distr_left equiv_refl equiv_sym. + +(* Lemmas whose form is x=y are also provided in form y=x because Auto does + not symmetry *) + +Lemma STh_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). +auto. Qed. + +Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p). +auto. Qed. + +Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n. +auto. Qed. + +Lemma STh_mult_one_left2 : forall n:A, n == 1 * n. +auto. Qed. + +Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p. +auto. Qed. + +Lemma STh_opp_def2 : forall n:A, 0 == n + - n. +auto. Qed. + +Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p). +intros. +rewrite (plus_assoc n m p). +rewrite (plus_comm n m). +rewrite <- (plus_assoc m n p). +trivial. +Qed. + +Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p). +intros. +rewrite (mult_assoc n m p). +rewrite (mult_comm n m). +rewrite <- (mult_assoc m n p). +trivial. +Qed. + +Hint Resolve STh_plus_permute STh_mult_permute. + +Lemma Saux1 : forall a:A, a + a == a -> a == 0. +intros. +rewrite <- (plus_zero_left a). +rewrite (plus_comm 0 a). +setoid_replace (a + 0) with (a + (a + - a)); auto. +rewrite (plus_assoc a a (- a)). +rewrite H. +apply opp_def. +Qed. + +Lemma STh_mult_zero_left : forall n:A, 0 * n == 0. +intros. +apply Saux1. +rewrite <- (distr_left 0 0 n). +rewrite (plus_zero_left 0). +trivial. +Qed. +Hint Resolve STh_mult_zero_left. + +Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n. +auto. +Qed. + +Lemma Saux2 : forall x y z:A, x + y == 0 -> x + z == 0 -> y == z. +intros. +rewrite <- (plus_zero_left y). +rewrite <- H0. +rewrite <- (plus_assoc x z y). +rewrite (plus_comm z y). +rewrite (plus_assoc x y z). +rewrite H. +auto. +Qed. + +Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y. +intros. +apply Saux2 with (x * y); auto. +rewrite <- (distr_left x (- x) y). +rewrite (opp_def x). +auto. +Qed. +Hint Resolve STh_opp_mult_left. + +Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y). +auto. +Qed. + +Lemma STh_mult_zero_right : forall n:A, n * 0 == 0. +intro; rewrite (mult_comm n 0); auto. +Qed. + +Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0. +intro; rewrite (mult_comm n 0); auto. +Qed. + +Lemma STh_plus_zero_right : forall n:A, n + 0 == n. +intro; rewrite (plus_comm n 0); auto. +Qed. + +Lemma STh_plus_zero_right2 : forall n:A, n == n + 0. +intro; rewrite (plus_comm n 0); auto. +Qed. + +Lemma STh_mult_one_right : forall n:A, n * 1 == n. +intro; rewrite (mult_comm n 1); auto. +Qed. + +Lemma STh_mult_one_right2 : forall n:A, n == n * 1. +intro; rewrite (mult_comm n 1); auto. +Qed. + +Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y. +intros. +rewrite (mult_comm x y). +rewrite (mult_comm x (- y)). +auto. +Qed. + +Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y). +intros. +rewrite (mult_comm x y). +rewrite (mult_comm x (- y)). +auto. +Qed. + +Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y). +intros. +apply Saux2 with (x + y); auto. +rewrite (STh_plus_permute (x + y) (- x) (- y)). +rewrite <- (plus_assoc x y (- y)). +rewrite (opp_def y); rewrite (STh_plus_zero_right x). +rewrite (STh_opp_def2 x); trivial. +Qed. + +Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p). +auto. +Qed. + +Lemma STh_opp_opp : forall n:A, - - n == n. +intro. +apply Saux2 with (- n); auto. +rewrite (plus_comm (- n) n); auto. +Qed. +Hint Resolve STh_opp_opp. + +Lemma STh_opp_opp2 : forall n:A, n == - - n. +auto. +Qed. + +Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y. +intros. +rewrite (STh_opp_mult_left2 x (- y)). +rewrite (STh_opp_mult_right2 x y). +trivial. +Qed. + +Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y. +intros. +apply equiv_sym. +apply STh_mult_opp_opp. +Qed. + +Lemma STh_opp_zero : - 0 == 0. +rewrite <- (plus_zero_left (- 0)). +trivial. +Qed. + +Lemma STh_plus_reg_left : forall n m p:A, n + m == n + p -> m == p. +intros. +rewrite <- (plus_zero_left m). +rewrite <- (plus_zero_left p). +rewrite <- (opp_def n). +rewrite (plus_comm n (- n)). +rewrite <- (plus_assoc (- n) n m). +rewrite <- (plus_assoc (- n) n p). +auto. +Qed. + +Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p. +intros. +apply STh_plus_reg_left with n. +rewrite (plus_comm n m); rewrite (plus_comm n p); assumption. +Qed. + +Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p. +intros. +rewrite (mult_comm n (m + p)). +rewrite (mult_comm n m). +rewrite (mult_comm n p). +trivial. +Qed. + +Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p). +intros. +apply equiv_sym. +apply STh_distr_right. +Qed. + +End Theory_of_setoid_rings. + +Hint Resolve STh_mult_zero_left STh_plus_reg_left: core. + +Unset Implicit Arguments. + +Definition Semi_Setoid_Ring_Theory_of : + Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory. +intros until 1; case H. +split; intros; simpl in |- *; eauto. +Defined. + +Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >-> + Semi_Setoid_Ring_Theory. + + + +Section product_ring. + +End product_ring. + +Section power_ring. + +End power_ring. + +End Setoid_rings.
\ No newline at end of file diff --git a/contrib/ring/ZArithRing.v b/contrib/ring/ZArithRing.v new file mode 100644 index 00000000..c511c076 --- /dev/null +++ b/contrib/ring/ZArithRing.v @@ -0,0 +1,36 @@ +(************************************************************************) +(* 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: ZArithRing.v,v 1.5.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +(* Instantiation of the Ring tactic for the binary integers of ZArith *) + +Require Export ArithRing. +Require Export ZArith_base. +Require Import Eqdep_dec. + +Definition Zeq (x y:Z) := + match (x ?= y)%Z with + | Datatypes.Eq => true + | _ => false + end. + +Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y. + intros x y H; unfold Zeq in H. + apply Zcompare_Eq_eq. + destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ]. +Qed. + +Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq. + split; intros; apply eq2eqT; eauto with zarith. + apply eqT2eq; 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 diff --git a/contrib/ring/g_quote.ml4 b/contrib/ring/g_quote.ml4 new file mode 100644 index 00000000..af23a8f7 --- /dev/null +++ b/contrib/ring/g_quote.ml4 @@ -0,0 +1,18 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* $Id: g_quote.ml4,v 1.1.12.1 2004/07/16 19:30:13 herbelin Exp $ *) + +open Quote + +TACTIC EXTEND Quote + [ "Quote" ident(f) ] -> [ quote f [] ] +| [ "Quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ] +END diff --git a/contrib/ring/g_ring.ml4 b/contrib/ring/g_ring.ml4 new file mode 100644 index 00000000..f7c74c0b --- /dev/null +++ b/contrib/ring/g_ring.ml4 @@ -0,0 +1,135 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* $Id: g_ring.ml4,v 1.4.2.1 2004/07/16 19:30:13 herbelin Exp $ *) + +open Quote +open Ring + +TACTIC EXTEND Ring + [ "Ring" constr_list(l) ] -> [ polynom l ] +END + +(* The vernac commands "Add Ring" and co *) + +let cset_of_constrarg_list l = + List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty + +VERNAC COMMAND EXTEND AddRing + [ "Add" "Ring" + constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) + constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] + -> [ add_theory true false false + (constr_of a) + None + None + None + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + (Some (constr_of aopp)) + (constr_of aeq) + (constr_of t) + (cset_of_constrarg_list l) ] + +| [ "Add" "Semi" "Ring" + constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) + constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] + -> [ add_theory false false false + (constr_of a) + None + None + None + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + None + (constr_of aeq) + (constr_of t) + (cset_of_constrarg_list l) ] + +| [ "Add" "Abstract" "Ring" + constr(a) constr(aplus) constr(amult) constr(aone) + constr(azero) constr(aopp) constr(aeq) constr(t) ] + -> [ add_theory true true false + (constr_of a) + None + None + None + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + (Some (constr_of aopp)) + (constr_of aeq) + (constr_of t) + ConstrSet.empty ] + +| [ "Add" "Abstract" "Semi" "Ring" + constr(a) constr(aplus) constr(amult) constr(aone) + constr(azero) constr(aeq) constr(t) ] + -> [ add_theory false true false + (constr_of a) + None + None + None + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + None + (constr_of aeq) + (constr_of t) + ConstrSet.empty ] + +| [ "Add" "Setoid" "Ring" + constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) + constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm) + constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] + -> [ add_theory true false true + (constr_of a) + (Some (constr_of aequiv)) + (Some (constr_of asetth)) + (Some { + plusm = (constr_of pm); + multm = (constr_of mm); + oppm = Some (constr_of om) }) + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + (Some (constr_of aopp)) + (constr_of aeq) + (constr_of t) + (cset_of_constrarg_list l) ] + +| [ "Add" "Semi" "Setoid" "Ring" + constr(a) constr(aequiv) constr(asetth) constr(aplus) + constr(amult) constr(aone) constr(azero) constr(aeq) + constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] + -> [ add_theory false false true + (constr_of a) + (Some (constr_of aequiv)) + (Some (constr_of asetth)) + (Some { + plusm = (constr_of pm); + multm = (constr_of mm); + oppm = None }) + (constr_of aplus) + (constr_of amult) + (constr_of aone) + (constr_of azero) + None + (constr_of aeq) + (constr_of t) + (cset_of_constrarg_list l) ] +END diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml new file mode 100644 index 00000000..bda04db3 --- /dev/null +++ b/contrib/ring/quote.ml @@ -0,0 +1,489 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: quote.ml,v 1.30.2.1 2004/07/16 19:30:14 herbelin Exp $ *) + +(* The `Quote' tactic *) + +(* The basic idea is to automatize the inversion of interpetation functions + in 2-level approach + + Examples are given in \texttt{theories/DEMOS/DemoQuote.v} + + Suppose you have a langage \texttt{L} of 'abstract terms' + and a type \texttt{A} of 'concrete terms' + and a function \texttt{f : L -> (varmap A L) -> A}. + + Then, the tactic \texttt{Quote f} will replace an + expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)} + such that \texttt{e} and \texttt{(f vm t)} are convertible. + + The problem is then inverting the function f. + + The tactic works when: + + \begin{itemize} + \item L is a simple inductive datatype. The constructors of L may + have one of the three following forms: + + \begin{enumerate} + \item ordinary recursive constructors like: \verb|Cplus : L -> L -> L| + \item variable leaf like: \verb|Cvar : index -> L| + \item constant leaf like \verb|Cconst : A -> L| + \end{enumerate} + + The definition of \texttt{L} must contain at most one variable + leaf and at most one constant leaf. + + When there are both a variable leaf and a constant leaf, there is + an ambiguity on inversion. The term t can be either the + interpretation of \texttt{(Cconst t)} or the interpretation of + (\texttt{Cvar}~$i$) in a variables map containing the binding $i + \rightarrow$~\texttt{t}. How to discriminate between these + choices ? + + To solve the dilemma, one gives to \texttt{Quote} a list of + \emph{constant constructors}: a term will be considered as a + constant if it is either a constant constructor of the + application of a constant constructor to constants. For example + the list \verb+[S, O]+ defines the closed natural + numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is + not. + + The definition of constants vary for each application of the + tactic, so it can even be different for two applications of + \texttt{Quote} with the same function. + + \item \texttt{f} is a quite simple fixpoint on + \texttt{L}. In particular, \texttt{f} must verify: + +\begin{verbatim} + (f (Cvar i)) = (varmap_find vm default_value i) +\end{verbatim} +\begin{verbatim} + (f (Cconst c)) = c +\end{verbatim} + + where \texttt{index} and \texttt{varmap\_find} are those defined + the \texttt{Quote} module. \emph{The tactic won't work with + user's own variables map !!} It is mandatory to use the + variables map defined in module \texttt{Quote}. + + \end{itemize} + + The method to proceed is then clear: + + \begin{itemize} + \item Start with an empty hashtable of "registed leafs" + that map constr to integers and a "variable counter" equal to 0. + \item Try to match the term with every right hand side of the + definition of f. + + If there is one match, returns the correponding left hand + side and call yourself recursively to get the arguments of this + left hand side. + + If there is no match, we are at a leaf. That is the + interpretation of either a variable or a constant. + + If it is a constant, return \texttt{Cconst} applied to that + constant. + + If not, it is a variable. Look in the hashtable + if this leaf has been already encountered. If not, increment + the variables counter and add an entry to the hashtable; then + return \texttt{(Cvar !variables\_counter)} + \end{itemize} +*) + + +(*i*) +open Pp +open Util +open Names +open Term +open Instantiate +open Pattern +open Matching +open Tacmach +open Tactics +open Proof_trees +open Tacexpr +(*i*) + +(*s First, we need to access some Coq constants + We do that lazily, because this code can be linked before + the constants are loaded in the environment *) + +let constant dir s = Coqlib.gen_constant "Quote" ("ring"::dir) s + +let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") +let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") +let coq_varmap_find = lazy (constant ["Quote"] "varmap_find") +let coq_Right_idx = lazy (constant ["Quote"] "Right_idx") +let coq_Left_idx = lazy (constant ["Quote"] "Left_idx") +let coq_End_idx = lazy (constant ["Quote"] "End_idx") + +(*s Then comes the stuff to decompose the body of interpetation function + and pre-compute the inversion data. + +For a function like: + +\begin{verbatim} + Fixpoint interp[vm:(varmap Prop); f:form] := + Cases f of + | (f_and f1 f1 f2) => (interp f1)/\(interp f2) + | (f_or f1 f1 f2) => (interp f1)\/(interp f2) + | (f_var i) => (varmap_find Prop default_v i vm) + | (f_const c) => c +\end{verbatim} + +With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the +corresponding scheme will be: + +\begin{verbatim} + {normal_lhs_rhs = + [ "(f_and ?1 ?2)", "?1 /\ ?2"; + "(f_or ?1 ?2)", " ?1 \/ ?2";]; + return_type = "Prop"; + constants = Some [C1,...Cn]; + variable_lhs = Some "(f_var ?1)"; + constant_lhs = Some "(f_const ?1)" + } +\end{verbatim} + +If there is no constructor for variables in the type \texttt{form}, +then [variable_lhs] is [None]. Idem for constants and +[constant_lhs]. Both cannot be equal to [None]. + +The metas in the RHS must correspond to those in the LHS (one cannot +exchange ?1 and ?2 in the example above) + +*) + +module ConstrSet = Set.Make( + struct + type t = constr + let compare = (Pervasives.compare : t->t->int) + end) + +type inversion_scheme = { + normal_lhs_rhs : (constr * constr_pattern) list; + variable_lhs : constr option; + return_type : constr; + constants : ConstrSet.t; + constant_lhs : constr option } + +(*s [compute_ivs gl f cs] computes the inversion scheme associated to + [f:constr] with constants list [cs:constr list] in the context of + goal [gl]. This function uses the auxiliary functions + [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *) + +let i_can't_do_that () = error "Quote: not a simple fixpoint" + +let decomp_term c = kind_of_term (strip_outer_cast c) + +(*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... + ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive + type [typ] *) + +let coerce_meta_out id = int_of_string (string_of_id id) +let coerce_meta_in n = id_of_string (string_of_int n) + +let compute_lhs typ i nargsi = + match kind_of_term typ with + | Ind(sp,0) -> + let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in + mkApp (mkConstruct ((sp,0),i+1), argsi) + | _ -> i_can't_do_that () + +(*s This function builds the pattern from the RHS. Recursive calls are + replaced by meta-variables ?i corresponding to those in the LHS *) + +let compute_rhs bodyi index_of_f = + let rec aux c = + match kind_of_term c with + | App (j, args) when j = mkRel (index_of_f) (* recursive call *) -> + let i = destRel (array_last args) in + PMeta (Some (coerce_meta_in i)) + | App (f,args) -> + PApp (pattern_of_constr f, Array.map aux args) + | Cast (c,t) -> aux c + | _ -> pattern_of_constr c + in + aux bodyi + +(*s Now the function [compute_ivs] itself *) + +let compute_ivs gl f cs = + let cst = try destConst f with _ -> i_can't_do_that () in + let body = Environ.constant_value (Global.env()) cst in + match decomp_term body with + | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> + let (args3, body3) = decompose_lam body2 in + let nargs3 = List.length args3 in + begin match decomp_term body3 with + | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *) + let n_lhs_rhs = ref [] + and v_lhs = ref (None : constr option) + and c_lhs = ref (None : constr option) in + Array.iteri + (fun i ci -> + let argsi, bodyi = decompose_lam ci in + let nargsi = List.length argsi in + (* REL (narg3 + nargsi + 1) is f *) + (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) + (* REL 1 to REL nargsi are argsi (reverse order) *) + (* First we test if the RHS is the RHS for constants *) + if bodyi = mkRel 1 then + c_lhs := Some (compute_lhs (snd (List.hd args3)) + i nargsi) + (* Then we test if the RHS is the RHS for variables *) + else begin match decompose_app bodyi with + | vmf, [_; _; a3; a4 ] + when isRel a3 & isRel a4 & + pf_conv_x gl vmf + (Lazy.force coq_varmap_find)-> + v_lhs := Some (compute_lhs + (snd (List.hd args3)) + i nargsi) + (* Third case: this is a normal LHS-RHS *) + | _ -> + n_lhs_rhs := + (compute_lhs (snd (List.hd args3)) i nargsi, + compute_rhs bodyi (nargs3 + nargsi + 1)) + :: !n_lhs_rhs + end) + lci; + + if !c_lhs = None & !v_lhs = None then i_can't_do_that (); + + (* The Cases predicate is a lambda; we assume no dependency *) + let p = match kind_of_term p with + | Lambda (_,_,p) -> Termops.pop p + | _ -> p + in + + { normal_lhs_rhs = List.rev !n_lhs_rhs; + variable_lhs = !v_lhs; + return_type = p; + constants = List.fold_right ConstrSet.add cs ConstrSet.empty; + constant_lhs = !c_lhs } + + | _ -> i_can't_do_that () + end + |_ -> i_can't_do_that () + +(* TODO for that function: +\begin{itemize} +\item handle the case where the return type is an argument of the + function +\item handle the case of simple mutual inductive (for example terms + and lists of terms) formulas with the corresponding mutual + recursvive interpretation functions. +\end{itemize} +*) + +(*s Stuff to build variables map, currently implemented as complete +binary search trees (see file \texttt{Quote.v}) *) + +(* First the function to distinghish between constants (closed terms) + and variables (open terms) *) + +let rec closed_under cset t = + (ConstrSet.mem t cset) or + (match (kind_of_term t) with + | Cast(c,_) -> closed_under cset c + | App(f,l) -> closed_under cset f & array_for_all (closed_under cset) l + | _ -> false) + +(*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete + binary search tree containing the [ci], that is: + +\begin{verbatim} + c1 + / \ + c2 c3 + / \ + c4 c5 +\end{verbatim} + +The second argument is a constr (the common type of the [ci]) +*) + +let btree_of_array a ty = + let size_of_a = Array.length a in + let semi_size_of_a = size_of_a lsr 1 in + let node = Lazy.force coq_Node_vm + and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in + let rec aux n = + if n > size_of_a + then empty + else if n > semi_size_of_a + then mkApp (node, [| ty; a.(n-1); empty; empty |]) + else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |]) + in + aux 1 + +(*s [btree_of_array] and [path_of_int] verify the following invariant:\\ + {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)] + = [a.(n)]\\ + [n] must be [> 0] *) + +let path_of_int n = + (* returns the list of digits of n in reverse order with + initial 1 removed *) + let rec digits_of_int n = + if n=1 then [] + else (n mod 2 = 1)::(digits_of_int (n lsr 1)) + in + List.fold_right + (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx + else Lazy.force coq_Left_idx), + [| c |])) + (List.rev (digits_of_int n)) + (Lazy.force coq_End_idx) + +(*s The tactic works with a list of subterms sharing the same + variables map. We need to sort terms in order to avoid than + strange things happen during replacement of terms by their + 'abstract' counterparties. *) + +(* [subterm t t'] tests if constr [t'] occurs in [t] *) +(* This function does not descend under binders (lambda and Cases) *) + +let rec subterm gl (t : constr) (t' : constr) = + (pf_conv_x gl t t') or + (match (kind_of_term t) with + | App (f,args) -> array_exists (fun t -> subterm gl t t') args + | Cast(t,_) -> (subterm gl t t') + | _ -> false) + +(*s We want to sort the list according to reverse subterm order. *) +(* Since it's a partial order the algoritm of Sort.list won't work !! *) + +let rec sort_subterm gl l = + let rec insert c = function + | [] -> [c] + | (h::t as l) when c = h -> l (* Avoid doing the same work twice *) + | h::t -> if subterm gl c h then c::h::t else h::(insert c t) + in + match l with + | [] -> [] + | h::t -> insert h (sort_subterm gl t) + +(*s Now we are able to do the inversion itself. + We destructurate the term and use an imperative hashtable + to store leafs that are already encountered. + The type of arguments is:\\ + [ivs : inversion_scheme]\\ + [lc: constr list]\\ + [gl: goal sigma]\\ *) + +let quote_terms ivs lc gl = + Library.check_required_library ["Coq";"ring";"Quote"]; + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + let rec auxl l = + match l with + | (lhs, rhs)::tail -> + begin try + let s1 = matches rhs c in + let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 + in + Termops.subst_meta s2 lhs + with PatternMatchingFailure -> auxl tail + end + | [] -> + begin match ivs.variable_lhs with + | None -> + begin match ivs.constant_lhs with + | Some c_lhs -> Termops.subst_meta [1, c] c_lhs + | None -> anomaly "invalid inversion scheme for quote" + end + | Some var_lhs -> + begin match ivs.constant_lhs with + | Some c_lhs when closed_under ivs.constants c -> + Termops.subst_meta [1, c] c_lhs + | _ -> + begin + try Hashtbl.find varhash c + with Not_found -> + let newvar = + Termops.subst_meta [1, (path_of_int !counter)] + var_lhs in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + end + end + end + in + auxl ivs.normal_lhs_rhs + in + let lp = List.map aux lc in + (lp, (btree_of_array (Array.of_list (List.rev !varlist)) + ivs.return_type )) + +(*s actually we could "quote" a list of terms instead of the + conclusion of current goal. Ring for example needs that, but Ring doesn't + uses Quote yet. *) + +let quote f lid gl = + let f = pf_global gl f in + let cl = List.map (pf_global gl) lid in + let ivs = compute_ivs gl f cl in + let (p, vm) = match quote_terms ivs [(pf_concl gl)] gl with + | [p], vm -> (p,vm) + | _ -> assert false + in + match ivs.variable_lhs with + | None -> Tactics.convert_concl (mkApp (f, [| p |])) gl + | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) gl + +(*i + +Just testing ... + +#use "include.ml";; +open Quote;; + +let r = raw_constr_of_string;; + +let ivs = { + normal_lhs_rhs = + [ r "(f_and ?1 ?2)", r "?1/\?2"; + r "(f_not ?1)", r "~?1"]; + variable_lhs = Some (r "(f_atom ?1)"); + return_type = r "Prop"; + constants = ConstrSet.empty; + constant_lhs = (r "nat") +};; + +let t1 = r "True/\(True /\ ~False)";; +let t2 = r "True/\~~False";; + +quote_term ivs () t1;; +quote_term ivs () t2;; + +let ivs2 = + normal_lhs_rhs = + [ r "(f_and ?1 ?2)", r "?1/\?2"; + r "(f_not ?1)", r "~?1" + r "True", r "f_true"]; + variable_lhs = Some (r "(f_atom ?1)"); + return_type = r "Prop"; + constants = ConstrSet.empty; + constant_lhs = (r "nat") + +i*) diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml new file mode 100644 index 00000000..378f19a4 --- /dev/null +++ b/contrib/ring/ring.ml @@ -0,0 +1,904 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: ring.ml,v 1.49.2.1 2004/07/16 19:30:14 herbelin Exp $ *) + +(* ML part of the Ring tactic *) + +open Pp +open Util +open Options +open Term +open Names +open Libnames +open Nameops +open Reductionops +open Tacticals +open Tacexpr +open Tacmach +open Proof_trees +open Printer +open Equality +open Vernacinterp +open Vernacexpr +open Libobject +open Closure +open Tacred +open Tactics +open Pattern +open Hiddentac +open Nametab +open Quote + +let mt_evd = Evd.empty +let constr_of c = Constrintern.interp_constr mt_evd (Global.env()) c + +let ring_dir = ["Coq";"ring"] +let setoids_dir = ["Coq";"Setoids"] + +let ring_constant = Coqlib.gen_constant_in_modules "Ring" + [ring_dir@["Ring_theory"]; + ring_dir@["Setoid_ring_theory"]; + ring_dir@["Ring_normalize"]; + ring_dir@["Ring_abstract"]; + setoids_dir@["Setoid"]; + ring_dir@["Setoid_ring_normalize"]] + +(* Ring theory *) +let coq_Ring_Theory = lazy (ring_constant "Ring_Theory") +let coq_Semi_Ring_Theory = lazy (ring_constant "Semi_Ring_Theory") + +(* Setoid ring theory *) +let coq_Setoid_Ring_Theory = lazy (ring_constant "Setoid_Ring_Theory") +let coq_Semi_Setoid_Ring_Theory = lazy(ring_constant "Semi_Setoid_Ring_Theory") + +(* Ring normalize *) +let coq_SPplus = lazy (ring_constant "SPplus") +let coq_SPmult = lazy (ring_constant "SPmult") +let coq_SPvar = lazy (ring_constant "SPvar") +let coq_SPconst = lazy (ring_constant "SPconst") +let coq_Pplus = lazy (ring_constant "Pplus") +let coq_Pmult = lazy (ring_constant "Pmult") +let coq_Pvar = lazy (ring_constant "Pvar") +let coq_Pconst = lazy (ring_constant "Pconst") +let coq_Popp = lazy (ring_constant "Popp") +let coq_interp_sp = lazy (ring_constant "interp_sp") +let coq_interp_p = lazy (ring_constant "interp_p") +let coq_interp_cs = lazy (ring_constant "interp_cs") +let coq_spolynomial_simplify = lazy (ring_constant "spolynomial_simplify") +let coq_polynomial_simplify = lazy (ring_constant "polynomial_simplify") +let coq_spolynomial_simplify_ok = lazy(ring_constant "spolynomial_simplify_ok") +let coq_polynomial_simplify_ok = lazy (ring_constant "polynomial_simplify_ok") + +(* Setoid theory *) +let coq_Setoid_Theory = lazy(ring_constant "Setoid_Theory") + +let coq_seq_refl = lazy(ring_constant "Seq_refl") +let coq_seq_sym = lazy(ring_constant "Seq_sym") +let coq_seq_trans = lazy(ring_constant "Seq_trans") + +(* Setoid Ring normalize *) +let coq_SetSPplus = lazy (ring_constant "SetSPplus") +let coq_SetSPmult = lazy (ring_constant "SetSPmult") +let coq_SetSPvar = lazy (ring_constant "SetSPvar") +let coq_SetSPconst = lazy (ring_constant "SetSPconst") +let coq_SetPplus = lazy (ring_constant "SetPplus") +let coq_SetPmult = lazy (ring_constant "SetPmult") +let coq_SetPvar = lazy (ring_constant "SetPvar") +let coq_SetPconst = lazy (ring_constant "SetPconst") +let coq_SetPopp = lazy (ring_constant "SetPopp") +let coq_interp_setsp = lazy (ring_constant "interp_setsp") +let coq_interp_setp = lazy (ring_constant "interp_setp") +let coq_interp_setcs = lazy (ring_constant "interp_setcs") +let coq_setspolynomial_simplify = + lazy (ring_constant "setspolynomial_simplify") +let coq_setpolynomial_simplify = + lazy (ring_constant "setpolynomial_simplify") +let coq_setspolynomial_simplify_ok = + lazy (ring_constant "setspolynomial_simplify_ok") +let coq_setpolynomial_simplify_ok = + lazy (ring_constant "setpolynomial_simplify_ok") + +(* Ring abstract *) +let coq_ASPplus = lazy (ring_constant "ASPplus") +let coq_ASPmult = lazy (ring_constant "ASPmult") +let coq_ASPvar = lazy (ring_constant "ASPvar") +let coq_ASP0 = lazy (ring_constant "ASP0") +let coq_ASP1 = lazy (ring_constant "ASP1") +let coq_APplus = lazy (ring_constant "APplus") +let coq_APmult = lazy (ring_constant "APmult") +let coq_APvar = lazy (ring_constant "APvar") +let coq_AP0 = lazy (ring_constant "AP0") +let coq_AP1 = lazy (ring_constant "AP1") +let coq_APopp = lazy (ring_constant "APopp") +let coq_interp_asp = lazy (ring_constant "interp_asp") +let coq_interp_ap = lazy (ring_constant "interp_ap") +let coq_interp_acs = lazy (ring_constant "interp_acs") +let coq_interp_sacs = lazy (ring_constant "interp_sacs") +let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize") +let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize") +let coq_aspolynomial_normalize_ok = + lazy (ring_constant "aspolynomial_normalize_ok") +let coq_apolynomial_normalize_ok = + lazy (ring_constant "apolynomial_normalize_ok") + +(* Logic --> to be found in Coqlib *) +open Coqlib + +let mkLApp(fc,v) = mkApp(Lazy.force fc, v) + +(*********** Useful types and functions ************) + +module OperSet = + Set.Make (struct + type t = global_reference + let compare = (Pervasives.compare : t->t->int) + end) + +type morph = + { plusm : constr; + multm : constr; + oppm : constr option; + } + +type theory = + { th_ring : bool; (* false for a semi-ring *) + th_abstract : bool; + th_setoid : bool; (* true for a setoid ring *) + th_equiv : constr option; + th_setoid_th : constr option; + th_morph : morph option; + th_a : constr; (* e.g. nat *) + th_plus : constr; + th_mult : constr; + th_one : constr; + th_zero : constr; + th_opp : constr option; (* None if semi-ring *) + th_eq : constr; + th_t : constr; (* e.g. NatTheory *) + th_closed : ConstrSet.t; (* e.g. [S; O] *) + (* Must be empty for an abstract ring *) + } + +(* Theories are stored in a table which is synchronised with the Reset + mechanism. *) + +module Cmap = Map.Make(struct type t = constr let compare = compare end) + +let theories_map = ref Cmap.empty + +let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map +let theories_map_find c = Cmap.find c !theories_map +let theories_map_mem c = Cmap.mem c !theories_map + +let _ = + Summary.declare_summary "tactic-ring-table" + { Summary.freeze_function = (fun () -> !theories_map); + Summary.unfreeze_function = (fun t -> theories_map := t); + Summary.init_function = (fun () -> theories_map := Cmap.empty); + Summary.survive_module = false; + Summary.survive_section = false } + +(* declare a new type of object in the environment, "tactic-ring-theory" + The functions theory_to_obj and obj_to_theory do the conversions + between theories and environement objects. *) + + +let subst_morph subst morph = + let plusm' = subst_mps subst morph.plusm in + let multm' = subst_mps subst morph.multm in + let oppm' = option_smartmap (subst_mps subst) morph.oppm in + if plusm' == morph.plusm + && multm' == morph.multm + && oppm' == morph.oppm then + morph + else + { plusm = plusm' ; + multm = multm' ; + oppm = oppm' ; + } + +let subst_set subst cset = + let same = ref true in + let copy_subst c newset = + let c' = subst_mps subst c in + if not (c' == c) then same := false; + ConstrSet.add c' newset + in + let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in + if !same then cset else cset' + +let subst_theory subst th = + let th_equiv' = option_smartmap (subst_mps subst) th.th_equiv in + let th_setoid_th' = option_smartmap (subst_mps subst) th.th_setoid_th in + let th_morph' = option_smartmap (subst_morph subst) th.th_morph in + let th_a' = subst_mps subst th.th_a in + let th_plus' = subst_mps subst th.th_plus in + let th_mult' = subst_mps subst th.th_mult in + let th_one' = subst_mps subst th.th_one in + let th_zero' = subst_mps subst th.th_zero in + let th_opp' = option_smartmap (subst_mps subst) th.th_opp in + let th_eq' = subst_mps subst th.th_eq in + let th_t' = subst_mps subst th.th_t in + let th_closed' = subst_set subst th.th_closed in + if th_equiv' == th.th_equiv + && th_setoid_th' == th.th_setoid_th + && th_morph' == th.th_morph + && th_a' == th.th_a + && th_plus' == th.th_plus + && th_mult' == th.th_mult + && th_one' == th.th_one + && th_zero' == th.th_zero + && th_opp' == th.th_opp + && th_eq' == th.th_eq + && th_t' == th.th_t + && th_closed' == th.th_closed + then + th + else + { th_ring = th.th_ring ; + th_abstract = th.th_abstract ; + th_setoid = th.th_setoid ; + th_equiv = th_equiv' ; + th_setoid_th = th_setoid_th' ; + th_morph = th_morph' ; + th_a = th_a' ; + th_plus = th_plus' ; + th_mult = th_mult' ; + th_one = th_one' ; + th_zero = th_zero' ; + th_opp = th_opp' ; + th_eq = th_eq' ; + th_t = th_t' ; + th_closed = th_closed' ; + } + + +let subst_th (_,subst,(c,th as obj)) = + let c' = subst_mps subst c in + let th' = subst_theory subst th in + if c' == c && th' == th then obj else + (c',th') + + +let (theory_to_obj, obj_to_theory) = + let cache_th (_,(c, th)) = theories_map_add (c,th) + and export_th x = Some x in + declare_object {(default_object "tactic-ring-theory") with + open_function = (fun i o -> if i=1 then cache_th o); + cache_function = cache_th; + subst_function = subst_th; + classify_function = (fun (_,x) -> Substitute x); + export_function = export_th } + +(* from the set A, guess the associated theory *) +(* With this simple solution, the theory to use is automatically guessed *) +(* But only one theory can be declared for a given Set *) + +let guess_theory a = + try + theories_map_find a + with Not_found -> + errorlabstrm "Ring" + (str "No Declared Ring Theory for " ++ + prterm a ++ fnl () ++ + str "Use Add [Semi] Ring to declare it") + +(* Looks up an option *) + +let unbox = function + | Some w -> w + | None -> anomaly "Ring : Not in case of a setoid ring." + +(* Protects the convertibility test against undue exceptions when using it + with untyped terms *) + +let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false + + +(* Add a Ring or a Semi-Ring to the database after a type verification *) + +let implement_theory env t th args = + is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args)) + +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); + let env = Global.env () in + if (want_ring & want_setoid & + not (implement_theory env t coq_Setoid_Ring_Theory + [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|]) + & + not (implement_theory env (unbox asetth) coq_Setoid_Theory + [| a; (unbox aequiv) |])) then + errorlabstrm "addring" (str "Not a valid Setoid-Ring theory"); + if (not want_ring & want_setoid & + not (implement_theory env t coq_Semi_Setoid_Ring_Theory + [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) & + not (implement_theory env (unbox asetth) coq_Setoid_Theory + [| a; (unbox aequiv) |])) then + errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory"); + if (want_ring & not want_setoid & + not (implement_theory env t coq_Ring_Theory + [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])) then + errorlabstrm "addring" (str "Not a valid Ring theory"); + if (not want_ring & not want_setoid & + not (implement_theory env t coq_Semi_Ring_Theory + [| a; aplus; amult; aone; azero; aeq |])) then + errorlabstrm "addring" (str "Not a valid Semi-Ring theory"); + Lib.add_anonymous_leaf + (theory_to_obj + (a, { th_ring = want_ring; + th_abstract = want_abstract; + th_setoid = want_setoid; + th_equiv = aequiv; + th_setoid_th = asetth; + th_morph = amorph; + th_a = a; + th_plus = aplus; + th_mult = amult; + th_one = aone; + th_zero = azero; + th_opp = aopp; + th_eq = aeq; + th_t = t; + th_closed = cset })) + +(******** The tactic itself *********) + +(* + gl : goal sigma + th : semi-ring theory (concrete) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_spolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + (* aux creates the spolynom p by a recursive destructuration of c + and builds the varmap with side-effects *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |]) + | _ when closed_under th.th_closed c -> + mkLApp(coq_SPconst, [|th.th_a; c |]) + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in + List.map + (fun p -> + (mkLApp (coq_interp_sp, + [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), + mkLApp (coq_interp_cs, + [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp (coq_spolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; + th.th_eq; p|])) |]), + mkLApp (coq_spolynomial_simplify_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + th.th_eq; v; th.th_t; p |]))) + lp + +(* + gl : goal sigma + th : ring theory (concrete) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_polynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |]) + (* The special case of Zminus *) + | App (binop, [|c1; c2|]) + when safe_pf_conv_x gl c + (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) -> + mkLApp(coq_Pplus, + [|th.th_a; aux c1; + mkLApp(coq_Popp, [|th.th_a; aux c2|]) |]) + | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> + mkLApp(coq_Popp, [|th.th_a; aux c1|]) + | _ when closed_under th.th_closed c -> + mkLApp(coq_Pconst, [|th.th_a; c |]) + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in + List.map + (fun p -> + (mkLApp(coq_interp_p, + [| th.th_a; th.th_plus; th.th_mult; th.th_zero; + (unbox th.th_opp); v; p |])), + mkLApp(coq_interp_cs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_polynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; p |])) |]), + mkLApp(coq_polynomial_simplify_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; v; th.th_t; p |])) + lp + +(* + gl : goal sigma + th : semi-ring theory (abstract) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_aspolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + (* aux creates the aspolynom p by a recursive destructuration of c + and builds the varmap with side-effects *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_ASPplus, [| aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_ASPmult, [| aux c1; aux c2 |]) + | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0 + | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1 + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in + List.map + (fun p -> + (mkLApp(coq_interp_asp, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; v; p |]), + mkLApp(coq_interp_acs, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_aspolynomial_normalize,[|p|])) |]), + mkLApp(coq_spolynomial_simplify_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + th.th_eq; v; th.th_t; p |]))) + lp + +(* + gl : goal sigma + th : ring theory (abstract) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_apolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_APplus, [| aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_APmult, [| aux c1; aux c2 |]) + (* The special case of Zminus *) + | App (binop, [|c1; c2|]) + when safe_pf_conv_x gl c + (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) -> + mkLApp(coq_APplus, + [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |]) + | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> + mkLApp(coq_APopp, [| aux c1 |]) + | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0 + | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1 + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_APvar, [| path_of_int !counter |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in + List.map + (fun p -> + (mkLApp(coq_interp_ap, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; + th.th_zero; (unbox th.th_opp); v; p |]), + mkLApp(coq_interp_sacs, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; (unbox th.th_opp); v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_apolynomial_normalize, [|p|])) |]), + mkLApp(coq_apolynomial_normalize_ok, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))) + lp + +(* + gl : goal sigma + th : setoid ring theory (concrete) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_setpolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |]) + (* The special case of Zminus *) + | App (binop, [|c1; c2|]) + when safe_pf_conv_x gl c + (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) -> + mkLApp(coq_SetPplus, + [| th.th_a; aux c1; + mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |]) + | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) -> + mkLApp(coq_SetPopp, [| th.th_a; aux c1 |]) + | _ when closed_under th.th_closed c -> + mkLApp(coq_SetPconst, [| th.th_a; c |]) + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in + List.map + (fun p -> + (mkLApp(coq_interp_setp, + [| th.th_a; th.th_plus; th.th_mult; th.th_zero; + (unbox th.th_opp); v; p |]), + mkLApp(coq_interp_setcs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_setpolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; + (unbox th.th_opp); th.th_eq; p |])) |]), + mkLApp(coq_setpolynomial_simplify_ok, + [| th.th_a; (unbox th.th_equiv); th.th_plus; + th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp); + th.th_eq; (unbox th.th_setoid_th); + (unbox th.th_morph).plusm; (unbox th.th_morph).multm; + (unbox (unbox th.th_morph).oppm); v; th.th_t; p |]))) + lp + +(* + gl : goal sigma + th : semi setoid ring theory (concrete) + cl : constr list [c1; c2; ...] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + where c'i is convertible with ci and + c'i_eq_c''i is a proof of equality of c'i and c''i + +*) + +let build_setspolynom gl th lc = + let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varlist = ref ([] : constr list) in (* list of variables *) + let counter = ref 1 in (* number of variables created + 1 *) + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> + mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> + mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |]) + | _ when closed_under th.th_closed c -> + mkLApp(coq_SetSPconst, [| th.th_a; c |]) + | _ -> + try Hashtbl.find varhash c + with Not_found -> + let newvar = + mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in + begin + incr counter; + varlist := c :: !varlist; + Hashtbl.add varhash c newvar; + newvar + end + in + let lp = List.map aux lc in + let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in + List.map + (fun p -> + (mkLApp(coq_interp_setsp, + [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), + mkLApp(coq_interp_setcs, + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; + pf_reduce cbv_betadeltaiota gl + (mkLApp(coq_setspolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; + th.th_eq; p |])) |]), + mkLApp(coq_setspolynomial_simplify_ok, + [| th.th_a; (unbox th.th_equiv); th.th_plus; + th.th_mult; th.th_one; th.th_zero; th.th_eq; v; + th.th_t; (unbox th.th_setoid_th); + (unbox th.th_morph).plusm; + (unbox th.th_morph).multm; p |]))) + lp + +module SectionPathSet = + Set.Make(struct + type t = section_path + let compare = Pervasives.compare + end) + +(* Avec l'uniformisation des red_kind, on perd ici sur la structure + SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *) +let constants_to_unfold = +(* List.fold_right SectionPathSet.add *) + let transform s = + let sp = path_of_string s in + let dir, id = repr_path sp in + Libnames.encode_kn dir id + in + List.map transform + [ "Coq.ring.Ring_normalize.interp_cs"; + "Coq.ring.Ring_normalize.interp_var"; + "Coq.ring.Ring_normalize.interp_vl"; + "Coq.ring.Ring_abstract.interp_acs"; + "Coq.ring.Ring_abstract.interp_sacs"; + "Coq.ring.Quote.varmap_find"; + (* anciennement des Local devenus Definition *) + "Coq.ring.Ring_normalize.ics_aux"; + "Coq.ring.Ring_normalize.ivl_aux"; + "Coq.ring.Ring_normalize.interp_m"; + "Coq.ring.Ring_abstract.iacs_aux"; + "Coq.ring.Ring_abstract.isacs_aux"; + "Coq.ring.Setoid_ring_normalize.interp_cs"; + "Coq.ring.Setoid_ring_normalize.interp_var"; + "Coq.ring.Setoid_ring_normalize.interp_vl"; + "Coq.ring.Setoid_ring_normalize.ics_aux"; + "Coq.ring.Setoid_ring_normalize.ivl_aux"; + "Coq.ring.Setoid_ring_normalize.interp_m"; + ] +(* SectionPathSet.empty *) + +(* Unfolds the functions interp and find_btree in the term c of goal gl *) +open RedFlags +let polynom_unfold_tac = + let flags = + (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in + reduct_in_concl (cbv_norm_flags flags) + +let polynom_unfold_tac_in_term gl = + let flags = + (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold))) + in + cbv_norm_flags flags (pf_env gl) (project gl) + +(* lc : constr list *) +(* th : theory associated to t *) +(* op : clause (None for conclusion or Some id for hypothesis id) *) +(* gl : goal *) +(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) + where the ring R, the Ring theory RC, the varmap v and the polynomials p_i + are guessed and such that c_i = (interp R RC v p_i) *) +let raw_polynom th op lc gl = + (* first we sort the terms : if t' is a subterm of t it must appear + after t in the list. This is to avoid that the normalization of t' + modifies t in a non-desired way *) + let lc = sort_subterm gl lc in + let ltriplets = + if th.th_setoid then + if th.th_ring + then build_setpolynom gl th lc + else build_setspolynom gl th lc + else + if th.th_ring then + if th.th_abstract + then build_apolynom gl th lc + else build_polynom gl th lc + else + if th.th_abstract + then build_aspolynom gl th lc + else build_spolynom gl th lc in + let polynom_tac = + List.fold_right2 + (fun ci (c'i, c''i, c'i_eq_c''i) tac -> + let c'''i = + if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i + in + if !term_quality && safe_pf_conv_x gl c'''i ci then + tac (* convertible terms *) + else if th.th_setoid + then + (tclORELSE + (tclORELSE + (h_exact c'i_eq_c''i) + (h_exact (mkLApp(coq_seq_sym, + [| th.th_a; (unbox th.th_equiv); + (unbox th.th_setoid_th); + c'''i; ci; c'i_eq_c''i |])))) + (tclTHEN + (Setoid_replace.setoid_replace ci c'''i None) + (tclTHEN + (tclTRY (h_exact c'i_eq_c''i)) + tac))) + else + (tclORELSE + (tclORELSE + (h_exact c'i_eq_c''i) + (h_exact (mkApp(build_coq_sym_eqT (), + [|th.th_a; c'''i; ci; c'i_eq_c''i |])))) + (tclTHENS + (elim_type + (mkApp(build_coq_eqT (), [|th.th_a; c'''i; ci |]))) + [ tac; + h_exact c'i_eq_c''i ])) +) + lc ltriplets polynom_unfold_tac + in + polynom_tac gl + +let guess_eq_tac th = + (tclORELSE reflexivity + (tclTHEN + polynom_unfold_tac + (tclTHEN + (* Normalized sums associate on the right *) + (tclREPEAT + (tclTHENFIRST + (apply (mkApp(build_coq_f_equal2 (), + [| th.th_a; th.th_a; th.th_a; + th.th_plus |]))) + reflexivity)) + (tclTRY + (tclTHENLAST + (apply (mkApp(build_coq_f_equal2 (), + [| th.th_a; th.th_a; th.th_a; + th.th_plus |]))) + reflexivity))))) + +let guess_equiv_tac th = + (tclORELSE (apply (mkLApp(coq_seq_refl, + [| th.th_a; (unbox th.th_equiv); + (unbox th.th_setoid_th)|]))) + (tclTHEN + polynom_unfold_tac + (tclREPEAT + (tclORELSE + (apply (unbox th.th_morph).plusm) + (apply (unbox th.th_morph).multm))))) + +let match_with_equiv c = match (kind_of_term c) with + | App (e,a) -> + if (List.mem e (Setoid_replace.equiv_list ())) + then Some (decompose_app c) + else None + | _ -> None + +let polynom lc gl = + Library.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, + do "Ring c1 c2 ... cn" and then try to apply the simplification + theorems declared for the relation *) + | [] -> + (match Hipattern.match_with_equation (pf_concl gl) with + | Some (eq,t::args) -> + let th = guess_theory t in + if List.exists + (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) args + then + errorlabstrm "Ring :" + (str" All terms must have the same type"); + (tclTHEN (raw_polynom th None args) (guess_eq_tac th)) gl + | _ -> (match match_with_equiv (pf_concl gl) with + | Some (equiv, c1::args) -> + let t = (pf_type_of gl c1) in + let th = (guess_theory t) in + if List.exists + (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args + then + errorlabstrm "Ring :" + (str" All terms must have the same type"); + (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl + | _ -> errorlabstrm "polynom :" + (str" This goal is not an equality nor a setoid equivalence"))) + (* Elsewhere, guess the theory, check that all terms have the same type + and apply raw_polynom *) + | c :: lc' -> + let t = pf_type_of gl c in + let th = guess_theory t in + if List.exists + (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc' + then + errorlabstrm "Ring :" + (str" All terms must have the same type"); + (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl diff --git a/contrib/romega/README b/contrib/romega/README new file mode 100644 index 00000000..86c9e58a --- /dev/null +++ b/contrib/romega/README @@ -0,0 +1,6 @@ +This work was done for the RNRT Project Calife. +As such it is distributed under the LGPL licence. + +Report bugs to : + pierre.cregut@francetelecom.com + diff --git a/contrib/romega/ROmega.v b/contrib/romega/ROmega.v new file mode 100644 index 00000000..b3895b2a --- /dev/null +++ b/contrib/romega/ROmega.v @@ -0,0 +1,11 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + +Require Import Omega. +Require Import ReflOmegaCore. + diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v new file mode 100644 index 00000000..3dfb5593 --- /dev/null +++ b/contrib/romega/ReflOmegaCore.v @@ -0,0 +1,2787 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence du projet : LGPL version 2.1 + + *************************************************************************) + +Require Import Arith. +Require Import List. +Require Import Bool. +Require Import ZArith. +Require Import OmegaLemmas. + +(* \subsection{Definition of basic types} *) + +(* \subsubsection{Environment of propositions (lists) *) +Inductive PropList : Type := + | Pnil : PropList + | Pcons : Prop -> PropList -> PropList. + +(* Access function for the environment with a default *) +Fixpoint nthProp (n : nat) (l : PropList) (default : Prop) {struct l} : + Prop := + match n, l with + | O, Pcons x l' => x + | O, other => default + | S m, Pnil => default + | S m, Pcons x t => nthProp m t default + end. + +(* \subsubsection{Définition of reified integer expressions} + Terms are either: + \begin{itemize} + \item integers [Tint] + \item variables [Tvar] + \item operation over integers (addition, product, opposite, subtraction) + The last two are translated in additions and products. *) + +Inductive term : Set := + | Tint : Z -> term + | Tplus : term -> term -> term + | Tmult : term -> term -> term + | Tminus : term -> term -> term + | Topp : term -> term + | Tvar : nat -> term. + +(* \subsubsection{Definition of reified goals} *) +(* Very restricted definition of handled predicates that should be extended + to cover a wider set of operations. + Taking care of negations and disequations require solving more than a + goal in parallel. This is a major improvement over previous versions. *) + +Inductive proposition : Set := + | EqTerm : term -> term -> proposition (* egalité entre termes *) + | LeqTerm : term -> term -> proposition (* plus petit ou egal *) + | TrueTerm : proposition (* vrai *) + | FalseTerm : proposition (* faux *) + | Tnot : proposition -> proposition (* négation *) + | GeqTerm : term -> term -> proposition + | GtTerm : term -> term -> proposition + | LtTerm : term -> term -> proposition + | NeqTerm : term -> term -> proposition + | Tor : proposition -> proposition -> proposition + | Tand : proposition -> proposition -> proposition + | Timp : proposition -> proposition -> proposition + | Tprop : nat -> proposition. + +(* Definition of goals as a list of hypothesis *) +Notation hyps := (list proposition) (only parsing). + +(* Definition of lists of subgoals (set of open goals) *) +Notation lhyps := (list (list proposition)) (only parsing). + +(* a syngle goal packed in a subgoal list *) +Notation singleton := (fun a : list proposition => a :: nil) (only parsing). + +(* an absurd goal *) +Definition absurd := FalseTerm :: nil. + +(* \subsubsection{Traces for merging equations} + This inductive type describes how the monomial of two equations should be + merged when the equations are added. + + For [F_equal], both equations have the same head variable and coefficient + must be added, furthermore if coefficients are opposite, [F_cancel] should + be used to collapse the term. [F_left] and [F_right] indicate which monomial + should be put first in the result *) + +Inductive t_fusion : Set := + | F_equal : t_fusion + | F_cancel : t_fusion + | F_left : t_fusion + | F_right : t_fusion. + +(* \subsubsection{Rewriting steps to normalize terms} *) +Inductive step : Set := + (* apply the rewriting steps to both subterms of an operation *) + | C_DO_BOTH : + step -> step -> step + (* apply the rewriting step to the first branch *) + | C_LEFT : step -> step + (* apply the rewriting step to the second branch *) + | C_RIGHT : step -> step + (* apply two steps consecutively to a term *) + | C_SEQ : step -> step -> step + (* empty step *) + | C_NOP : step + (* the following operations correspond to actual rewriting *) + | C_OPP_PLUS : step + | C_OPP_OPP : step + | C_OPP_MULT_R : step + | C_OPP_ONE : + step + (* This is a special step that reduces the term (computation) *) + | C_REDUCE : step + | C_MULT_PLUS_DISTR : step + | C_MULT_OPP_LEFT : step + | C_MULT_ASSOC_R : step + | C_PLUS_ASSOC_R : step + | C_PLUS_ASSOC_L : step + | C_PLUS_PERMUTE : step + | C_PLUS_SYM : step + | C_RED0 : step + | C_RED1 : step + | C_RED2 : step + | C_RED3 : step + | C_RED4 : step + | C_RED5 : step + | C_RED6 : step + | C_MULT_ASSOC_REDUCED : step + | C_MINUS : step + | C_MULT_SYM : step. + +(* \subsubsection{Omega steps} *) +(* The following inductive type describes steps as they can be found in + the trace coming from the decision procedure Omega. *) + +Inductive t_omega : Set := + (* n = 0 n!= 0 *) + | O_CONSTANT_NOT_NUL : nat -> t_omega + | O_CONSTANT_NEG : + nat -> t_omega + (* division et approximation of an equation *) + | O_DIV_APPROX : + Z -> + Z -> + term -> + nat -> + t_omega -> nat -> t_omega + (* no solution because no exact division *) + | O_NOT_EXACT_DIVIDE : + Z -> Z -> term -> nat -> nat -> t_omega + (* exact division *) + | O_EXACT_DIVIDE : Z -> term -> nat -> t_omega -> nat -> t_omega + | O_SUM : Z -> nat -> Z -> nat -> list t_fusion -> t_omega -> t_omega + | O_CONTRADICTION : nat -> nat -> nat -> t_omega + | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega + | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega + | O_CONSTANT_NUL : nat -> t_omega + | O_NEGATE_CONTRADICT : nat -> nat -> t_omega + | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega + | O_STATE : Z -> step -> nat -> nat -> t_omega -> t_omega. + +(* \subsubsection{Règles pour normaliser les hypothèses} *) +(* Ces règles indiquent comment normaliser les propositions utiles + de chaque hypothèse utile avant la décomposition des hypothèses et + incluent l'étape d'inversion pour la suppression des négations *) +Inductive p_step : Set := + | P_LEFT : p_step -> p_step + | P_RIGHT : p_step -> p_step + | P_INVERT : step -> p_step + | P_STEP : step -> p_step + | P_NOP : p_step. +(* Liste des normalisations a effectuer : avec un constructeur dans le + 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] + par une simple liste *) + +Inductive h_step : Set := + pair_step : nat -> p_step -> h_step. + +(* \subsubsection{Règles pour décomposer les hypothèses} *) +(* Ce type permet de se diriger dans les constructeurs logiques formant les + prédicats des hypothèses pour aller les décomposer. Ils permettent + en particulier d'extraire une hypothèse d'une conjonction avec + éventuellement le bon niveau de négations. *) + +Inductive direction : Set := + | D_left : direction + | D_right : direction + | D_mono : direction. + +(* Ce type permet d'extraire les composants utiles des hypothèses : que ce + soit des hypothèses générées par éclatement d'une disjonction, ou + des équations. Le constructeur terminal indique comment résoudre le système + obtenu en recourrant au type de trace d'Omega [t_omega] *) + +Inductive e_step : Set := + | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step + | E_EXTRACT : nat -> list direction -> e_step -> e_step + | E_SOLVE : t_omega -> e_step. + +(* \subsection{Egalité décidable efficace} *) +(* Pour chaque type de donnée réifié, on calcule un test d'égalité efficace. + Ce n'est pas le cas de celui rendu par [Decide Equality]. + + Puis on prouve deux théorèmes permettant d'éliminer de telles égalités : + \begin{verbatim} + (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. + (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. + \end{verbatim} *) + +(* Ces deux tactiques permettent de résoudre pas mal de cas. L'une pour + les théorèmes positifs, l'autre pour les théorèmes négatifs *) + +Ltac absurd_case := simpl in |- *; intros; discriminate. +Ltac trivial_case := unfold not in |- *; intros; discriminate. + +(* \subsubsection{Entiers naturels} *) + +Fixpoint eq_nat (t1 t2 : nat) {struct t2} : bool := + match t1 with + | O => match t2 with + | O => true + | _ => false + end + | S n1 => match t2 with + | O => false + | S n2 => eq_nat n1 n2 + end + end. + +Theorem eq_nat_true : forall t1 t2 : nat, eq_nat t1 t2 = true -> t1 = t2. + +simple induction t1; + [ intro t2; case t2; [ trivial | absurd_case ] + | intros n H t2; case t2; + [ absurd_case + | simpl in |- *; intros; rewrite (H n0); [ trivial | assumption ] ] ]. + +Qed. + +Theorem eq_nat_false : forall t1 t2 : nat, eq_nat t1 t2 = false -> t1 <> t2. + +simple induction t1; + [ intro t2; case t2; [ simpl in |- *; intros; discriminate | trivial_case ] + | intros n H t2; case t2; simpl in |- *; unfold not in |- *; intros; + [ discriminate | elim (H n0 H0); simplify_eq H1; trivial ] ]. + +Qed. + + +(* \subsubsection{Entiers positifs} *) + +Fixpoint eq_pos (p1 p2 : positive) {struct p2} : bool := + match p1 with + | xI n1 => match p2 with + | xI n2 => eq_pos n1 n2 + | _ => false + end + | xO n1 => match p2 with + | xO n2 => eq_pos n1 n2 + | _ => false + end + | xH => match p2 with + | xH => true + | _ => false + end + end. + +Theorem eq_pos_true : forall t1 t2 : positive, eq_pos t1 t2 = true -> t1 = t2. + +simple induction t1; + [ intros p H t2; case t2; + [ simpl in |- *; intros; rewrite (H p0 H0); trivial + | absurd_case + | absurd_case ] + | intros p H t2; case t2; + [ absurd_case + | simpl in |- *; intros; rewrite (H p0 H0); trivial + | absurd_case ] + | intro t2; case t2; [ absurd_case | absurd_case | auto ] ]. + +Qed. + +Theorem eq_pos_false : + forall t1 t2 : positive, eq_pos t1 t2 = false -> t1 <> t2. + +simple induction t1; + [ intros p H t2; case t2; + [ simpl in |- *; unfold not in |- *; intros; elim (H p0 H0); + simplify_eq H1; auto + | trivial_case + | trivial_case ] + | intros p H t2; case t2; + [ trivial_case + | simpl in |- *; unfold not in |- *; intros; elim (H p0 H0); + simplify_eq H1; auto + | trivial_case ] + | intros t2; case t2; [ trivial_case | trivial_case | absurd_case ] ]. +Qed. + +(* \subsubsection{Entiers relatifs} *) + +Definition eq_Z (z1 z2 : Z) : bool := + match z1 with + | Z0 => match z2 with + | Z0 => true + | _ => false + end + | Zpos p1 => match z2 with + | Zpos p2 => eq_pos p1 p2 + | _ => false + end + | Zneg p1 => match z2 with + | Zneg p2 => eq_pos p1 p2 + | _ => false + end + end. + +Theorem eq_Z_true : forall t1 t2 : Z, eq_Z t1 t2 = true -> t1 = t2. + +simple induction t1; + [ intros t2; case t2; [ auto | absurd_case | absurd_case ] + | intros p t2; case t2; + [ absurd_case + | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial + | absurd_case ] + | intros p t2; case t2; + [ absurd_case + | absurd_case + | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial ] ]. + +Qed. + +Theorem eq_Z_false : forall t1 t2 : Z, eq_Z t1 t2 = false -> t1 <> t2. + +simple induction t1; + [ intros t2; case t2; [ absurd_case | trivial_case | trivial_case ] + | intros p t2; case t2; + [ absurd_case + | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H); + simplify_eq H0; auto + | trivial_case ] + | intros p t2; case t2; + [ absurd_case + | trivial_case + | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H); + simplify_eq H0; auto ] ]. +Qed. + +(* \subsubsection{Termes réifiés} *) + +Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := + match t1 with + | Tint st1 => match t2 with + | Tint st2 => eq_Z st1 st2 + | _ => false + end + | Tplus st11 st12 => + match t2 with + | Tplus st21 st22 => eq_term st11 st21 && eq_term st12 st22 + | _ => false + end + | Tmult st11 st12 => + match t2 with + | Tmult st21 st22 => eq_term st11 st21 && eq_term st12 st22 + | _ => false + end + | Tminus st11 st12 => + match t2 with + | Tminus st21 st22 => eq_term st11 st21 && eq_term st12 st22 + | _ => 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. + + +simple induction t1; intros until t2; case t2; try absurd_case; simpl in |- *; + [ intros; elim eq_Z_true with (1 := H); trivial + | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; + elim H with (1 := H4); elim H0 with (1 := H5); + trivial + | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; + elim H with (1 := H4); elim H0 with (1 := H5); + trivial + | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; + elim H with (1 := H4); elim H0 with (1 := H5); + trivial + | intros t21 H3; elim H with (1 := H3); trivial + | intros; elim eq_nat_true with (1 := H); trivial ]. + +Qed. + +Theorem eq_term_false : + forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. + +simple induction t1; + [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; + intros; elim eq_Z_false with (1 := H); simplify_eq H0; + auto + | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; + intros t21 t22 H3; unfold not in |- *; intro H4; + elim andb_false_elim with (1 := H3); intros H5; + [ elim H1 with (1 := H5); simplify_eq H4; auto + | elim H2 with (1 := H5); simplify_eq H4; auto ] + | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; + intros t21 t22 H3; unfold not in |- *; intro H4; + elim andb_false_elim with (1 := H3); intros H5; + [ elim H1 with (1 := H5); simplify_eq H4; auto + | elim H2 with (1 := H5); simplify_eq H4; auto ] + | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; + intros t21 t22 H3; unfold not in |- *; intro H4; + elim andb_false_elim with (1 := H3); intros H5; + [ elim H1 with (1 := H5); simplify_eq H4; auto + | elim H2 with (1 := H5); simplify_eq H4; auto ] + | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3; + unfold not in |- *; intro H4; elim H1 with (1 := H3); + simplify_eq H4; auto + | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; + intros; elim eq_nat_false with (1 := H); simplify_eq H0; + auto ]. + +Qed. + +(* \subsubsection{Tactiques pour éliminer ces tests} + + Si on se contente de faire un [Case (eq_typ t1 t2)] on perd + totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2]. + + Initialement, les développements avaient été réalisés avec les + tests rendus par [Decide Equality], c'est à dire un test rendant + des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un + tel test préserve bien l'information voulue mais calculatoirement de + telles fonctions sont trop lentes. *) + +(* Le théorème suivant permet de garder dans les hypothèses la valeur + du booléen lors de l'élimination. *) + +Theorem bool_ind2 : + forall (P : bool -> Prop) (b : bool), + (b = true -> P true) -> (b = false -> P false) -> P b. + +simple induction b; auto. +Qed. + +(* Les tactiques définies si après se comportent exactement comme si on + avait utilisé le test précédent et fait une elimination dessus. *) + +Ltac elim_eq_term t1 t2 := + pattern (eq_term t1 t2) in |- *; apply bool_ind2; intro Aux; + [ generalize (eq_term_true t1 t2 Aux); clear Aux + | generalize (eq_term_false t1 t2 Aux); clear Aux ]. + +Ltac elim_eq_Z t1 t2 := + pattern (eq_Z t1 t2) in |- *; apply bool_ind2; intro Aux; + [ generalize (eq_Z_true t1 t2 Aux); clear Aux + | generalize (eq_Z_false t1 t2 Aux); clear Aux ]. + +Ltac elim_eq_pos t1 t2 := + pattern (eq_pos t1 t2) in |- *; apply bool_ind2; intro Aux; + [ generalize (eq_pos_true t1 t2 Aux); clear Aux + | generalize (eq_pos_false t1 t2 Aux); clear Aux ]. + +(* \subsubsection{Comparaison sur Z} *) + +(* Sujet très lié au précédent : on introduit la tactique d'élimination + 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. + +simple induction b; auto. +Qed. + +Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2)%Z in |- *; apply relation_ind2. + +(* \subsection{Interprétations} + \subsubsection{Interprétation des termes dans Z} *) + +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 + end. + +(* \subsubsection{Interprétation des prédicats} *) +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 + | 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 + | 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 + | Tand p1 p2 => + interp_proposition envp env p1 /\ interp_proposition envp env p2 + | Timp p1 p2 => + interp_proposition envp env p1 -> interp_proposition envp env p2 + | Tprop n => nthProp n envp True + end. + +(* \subsubsection{Inteprétation des listes d'hypothèses} + \paragraph{Sous forme de conjonction} + Interprétation sous forme d'une conjonction d'hypothèses plus faciles + à manipuler individuellement *) + +Fixpoint interp_hyps (envp : PropList) (env : list Z) + (l : list proposition) {struct l} : Prop := + match l with + | nil => True + | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l' + end. + +(* \paragraph{sous forme de but} + C'est cette interpétation que l'on utilise sur le but (car on utilise + [Generalize] et qu'une conjonction est forcément lourde (répétition des + types dans les conjonctions intermédiaires) *) + +Fixpoint interp_goal_concl (envp : PropList) (env : list Z) + (c : proposition) (l : list proposition) {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' + end. + +Notation interp_goal := + (fun (envp : PropList) (env : list Z) (l : list proposition) => + interp_goal_concl envp env FalseTerm l) (only parsing). + +(* 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. + +simple induction l; + [ simpl in |- *; auto + | simpl in |- *; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. +Qed. + +Theorem hyps_to_goal : + forall (envp : 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. + +simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ]. +Qed. + +(* \subsection{Manipulations sur les hypothèses} *) + +(* \subsubsection{Définitions de base de stabilité pour la réflexion} *) +(* Une opération laisse un terme stable si l'égalité est préservée *) +Definition term_stable (f : term -> term) := + forall (e : list Z) (t : term), interp_term e t = interp_term e (f t). + +(* Une opération est valide sur une hypothèse, si l'hypothèse implique le + résultat de l'opération. \emph{Attention : cela ne concerne que des + opérations sur les hypothèses et non sur les buts (contravariance)}. + On définit la validité pour une opération prenant une ou deux propositions + en argument (cela suffit pour omega). *) + +Definition valid1 (f : proposition -> proposition) := + forall (ep : PropList) (e : list Z) (p1 : proposition), + interp_proposition ep e p1 -> interp_proposition ep e (f p1). + +Definition valid2 (f : proposition -> proposition -> proposition) := + forall (ep : PropList) (e : list Z) (p1 p2 : proposition), + interp_proposition ep e p1 -> + interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). + +(* Dans cette notion de validité, la fonction prend directement une + liste de propositions et rend une nouvelle liste de proposition. + On reste contravariant *) + +Definition valid_hyps (f : list proposition -> list proposition) := + forall (ep : PropList) (e : list Z) (lp : list proposition), + 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. + +intros; simpl in |- *; apply goal_to_hyps; intro H1; + apply (hyps_to_goal ep env (a l) H0); apply H; assumption. +Qed. + +(* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) + + +Fixpoint interp_list_hyps (envp : PropList) (env : list Z) + (l : list (list proposition)) {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 := + 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' + end. + +Theorem list_goal_to_hyps : + forall (envp : PropList) (env : list Z) (l : list (list proposition)), + (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. + +simple induction l; simpl in |- *; + [ auto + | intros h1 l1 H H1; split; + [ apply goal_to_hyps; intro H2; apply H1; auto + | apply H; intro H2; apply H1; auto ] ]. +Qed. + +Theorem list_hyps_to_goal : + forall (envp : PropList) (env : list Z) (l : list (list proposition)), + interp_list_goal envp env l -> interp_list_hyps envp env l -> False. + +simple induction l; simpl in |- *; + [ auto + | intros h1 l1 H (H1, H2) H3; elim H3; intro H4; + [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. +Qed. + +Definition valid_list_hyps + (f : list proposition -> list (list proposition)) := + forall (ep : PropList) (e : list Z) (lp : list proposition), + 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. + +Theorem goal_valid : + forall f : list proposition -> list (list proposition), + 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); + apply (H ep e lp); assumption. +Qed. + +Theorem append_valid : + forall (ep : PropList) (e : list Z) (l1 l2 : list (list proposition)), + interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> + interp_list_hyps ep e (l1 ++ l2). + +intros ep e; simple induction l1; + [ simpl in |- *; intros l2 [H| H]; [ contradiction | trivial ] + | simpl in |- *; intros h1 t1 HR l2 [[H| H]| H]; + [ auto + | right; apply (HR l2); left; trivial + | right; apply (HR l2); right; trivial ] ]. + +Qed. + +(* \subsubsection{Opérateurs valides sur les hypothèses} *) + +(* Extraire une hypothèse de la liste *) +Definition nth_hyps (n : nat) (l : list proposition) := nth n l TrueTerm. + +Theorem nth_valid : + forall (ep : PropList) (e : list Z) (i : nat) (l : list proposition), + interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). + +unfold nth_hyps in |- *; simple induction i; + [ simple induction l; simpl in |- *; [ auto | intros; elim H0; auto ] + | intros n H; simple induction l; + [ simpl in |- *; trivial + | intros; simpl in |- *; apply H; elim H1; auto ] ]. +Qed. + +(* Appliquer une opération (valide) sur deux hypothèses extraites de + la liste et ajouter le résultat à la liste. *) +Definition apply_oper_2 (i j : nat) + (f : proposition -> proposition -> proposition) (l : list proposition) := + f (nth_hyps i l) (nth_hyps j l) :: l. + +Theorem apply_oper_2_valid : + forall (i j : nat) (f : proposition -> proposition -> proposition), + valid2 f -> valid_hyps (apply_oper_2 i j f). + +intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *; + intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ]. +Qed. + +(* Modifier une hypothèse par application d'une opération valide *) + +Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) + (l : list proposition) {struct i} : list proposition := + match l with + | nil => nil (A:=proposition) + | p :: l' => + match i with + | O => f p :: l' + | S j => p :: apply_oper_1 j f l' + end + end. + +Theorem apply_oper_1_valid : + forall (i : nat) (f : proposition -> proposition), + valid1 f -> valid_hyps (apply_oper_1 i f). + +unfold valid_hyps in |- *; intros i f Hf ep e; elim i; + [ intro lp; case lp; + [ simpl in |- *; trivial + | simpl in |- *; intros p l' (H1, H2); split; + [ apply Hf with (1 := H1) | assumption ] ] + | intros n Hrec lp; case lp; + [ simpl in |- *; auto + | simpl in |- *; intros p l' (H1, H2); split; + [ assumption | apply Hrec; assumption ] ] ]. + +Qed. + +(* \subsubsection{Manipulations de termes} *) +(* Les fonctions suivantes permettent d'appliquer une fonction de + réécriture sur un sous terme du terme principal. Avec la composition, + cela permet de construire des réécritures complexes proches des + tactiques de conversion *) + +Definition apply_left (f : term -> term) (t : term) := + match t with + | Tplus x y => Tplus (f x) y + | Tmult x y => Tmult (f x) y + | Topp x => Topp (f x) + | 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 => 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 => x + end. + +(* Les théorèmes suivants montrent la stabilité (conditionnée) des + fonctions. *) + +Theorem apply_left_stable : + forall f : term -> term, term_stable f -> term_stable (apply_left f). + +unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; + intros; elim H; trivial. +Qed. + +Theorem apply_right_stable : + forall f : term -> term, term_stable f -> term_stable (apply_right f). + +unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; + intros t0 t1; elim H; trivial. +Qed. + +Theorem apply_both_stable : + forall f g : term -> term, + term_stable f -> term_stable g -> term_stable (apply_both f g). + +unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *; + intros t0 t1; elim H1; elim H2; trivial. +Qed. + +Theorem compose_term_stable : + forall f g : term -> term, + term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)). + +unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg. +Qed. + +(* \subsection{Les règles de réécriture} *) +(* Chacune des règles de réécriture est accompagnée par sa preuve de + stabilité. Toutes ces preuves ont la même forme : il faut analyser + suivant la forme du terme (élimination de chaque Case). On a besoin d'une + élimination uniquement dans les cas d'utilisation d'égalité décidable. + + Cette tactique itère la décomposition des Case. Elle est + constituée de deux fonctions s'appelant mutuellement : + \begin{itemize} + \item une fonction d'enrobage qui lance la recherche sur le but, + \item une fonction récursive qui décompose ce but. Quand elle a trouvé un + Case, elle l'élimine. + \end{itemize} + Les motifs sur les cas sont très imparfaits et dans certains cas, il + semble que cela ne marche pas. On aimerait plutot un motif de la + forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on + utilise le bon type. + + Chaque élimination introduit correctement exactement le nombre d'hypothèses + nécessaires et conserve dans le cas d'une égalité la connaissance du + résultat du test en faisant la réécriture. Pour un test de comparaison, + on conserve simplement le résultat. + + Cette fonction déborde très largement la résolution des réécritures + simples et fait une bonne partie des preuves des pas de Omega. +*) + +(* \subsubsection{La tactique pour prouver la stabilité} *) + +Ltac loop t := + match constr:t with + | (?X1 = ?X2) => + (* Global *) + loop X1 || loop X2 + | (_ -> ?X1) => loop X1 + | (interp_hyps _ _ ?X1) => + + (* Interpretations *) + 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 + | (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 + | match ?X1 with + | EqTerm x x0 => _ + | LeqTerm x x0 => _ + | TrueTerm => _ + | FalseTerm => _ + | Tnot x => _ + | GeqTerm x x0 => _ + | GtTerm x x0 => _ + | LtTerm x x0 => _ + | NeqTerm x x0 => _ + | Tor x x0 => _ + | Tand x x0 => _ + | Timp x x0 => _ + | Tprop x => _ + end => + + (* Eliminations *) + case X1; + [ intro; intro + | intro; intro + | idtac + | idtac + | intro + | intro; intro + | intro; intro + | intro; intro + | intro; intro + | intro; intro + | intro; intro + | intro; intro + | intro ]; auto; Simplify + | match ?X1 with + | Tint x => _ + | Tplus x x0 => _ + | Tmult x x0 => _ + | Tminus x x0 => _ + | Topp x => _ + | Tvar x => _ + 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 => _ + end => + elim_Zcompare X1 X2; intro; auto; Simplify + | match ?X1 with + | Z0 => _ + | Zpos x => _ + | Zneg x => _ + end => + case X1; [ idtac | intro | intro ]; auto; Simplify + | (if eq_Z ?X1 ?X2 then _ else _) => + elim_eq_Z X1 X2; intro H; [ rewrite H; clear H | clear H ]; + simpl in |- *; auto; Simplify + | (if eq_term ?X1 ?X2 then _ else _) => + elim_eq_term X1 X2; intro H; [ rewrite H; clear H | clear H ]; + simpl in |- *; auto; Simplify + | (if eq_pos ?X1 ?X2 then _ else _) => + elim_eq_pos X1 X2; intro H; [ rewrite H; clear H | clear H ]; + simpl in |- *; auto; Simplify + | _ => fail + end + with Simplify := match goal with + | |- ?X1 => try loop X1 + | _ => idtac + end. + + +Ltac prove_stable x th := + match constr:x with + | ?X1 => + unfold term_stable, X1 in |- *; intros; Simplify; simpl in |- *; + apply th + end. + +(* \subsubsection{Les règles elle mêmes} *) +Definition Tplus_assoc_l (t : term) := + match t with + | Tplus n (Tplus m p) => Tplus (Tplus n m) p + | _ => t + end. + +Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l. + +prove_stable Tplus_assoc_l Zplus_assoc. +Qed. + +Definition Tplus_assoc_r (t : term) := + match t with + | Tplus (Tplus n m) p => Tplus n (Tplus m p) + | _ => t + end. + +Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r. + +prove_stable Tplus_assoc_r Zplus_assoc_reverse. +Qed. + +Definition Tmult_assoc_r (t : term) := + match t with + | Tmult (Tmult n m) p => Tmult n (Tmult m p) + | _ => t + end. + +Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r. + +prove_stable Tmult_assoc_r Zmult_assoc_reverse. +Qed. + +Definition Tplus_permute (t : term) := + match t with + | Tplus n (Tplus m p) => Tplus m (Tplus n p) + | _ => t + end. + +Theorem Tplus_permute_stable : term_stable Tplus_permute. + +prove_stable Tplus_permute Zplus_permute. +Qed. + +Definition Tplus_sym (t : term) := + match t with + | Tplus x y => Tplus y x + | _ => t + end. + +Theorem Tplus_sym_stable : term_stable Tplus_sym. + +prove_stable Tplus_sym Zplus_comm. +Qed. + +Definition Tmult_sym (t : term) := + match t with + | Tmult x y => Tmult y x + | _ => t + end. + +Theorem Tmult_sym_stable : term_stable Tmult_sym. + +prove_stable Tmult_sym Zmult_comm. +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)) => + match eq_term v v' with + | true => + Tplus (Tmult v (Tint (c1 * k1 + c2 * k2))) + (Tplus (Tmult l1 (Tint k1)) (Tmult l2 (Tint k2))) + | false => t + end + | _ => t + end. + +Theorem T_OMEGA10_stable : term_stable T_OMEGA10. + +prove_stable T_OMEGA10 OMEGA10. +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) + | _ => t + end. + +Theorem T_OMEGA11_stable : term_stable T_OMEGA11. + +prove_stable T_OMEGA11 OMEGA11. +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))) + | _ => t + end. + +Theorem T_OMEGA12_stable : term_stable T_OMEGA12. + +prove_stable T_OMEGA12 OMEGA12. +Qed. + +Definition T_OMEGA13 (t : term) := + match t with + | Tplus (Tplus (Tmult v (Tint (Zpos x))) l1) (Tplus (Tmult v' (Tint (Zneg + x'))) l2) => + match eq_term v v' with + | true => match eq_pos x x' with + | true => Tplus l1 l2 + | false => t + end + | false => t + end + | Tplus (Tplus (Tmult v (Tint (Zneg x))) l1) (Tplus (Tmult v' (Tint (Zpos + x'))) l2) => + match eq_term v v' with + | true => match eq_pos x x' with + | true => Tplus l1 l2 + | false => t + end + | false => t + end + | _ => t + end. + +Theorem T_OMEGA13_stable : term_stable T_OMEGA13. + +unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *; + [ apply OMEGA13 | apply OMEGA14 ]. +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)) => + match eq_term v v' with + | true => + Tplus (Tmult v (Tint (c1 + c2 * k2))) + (Tplus l1 (Tmult l2 (Tint k2))) + | false => t + end + | _ => t + end. + +Theorem T_OMEGA15_stable : term_stable T_OMEGA15. + +prove_stable T_OMEGA15 OMEGA15. +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)) + | _ => t + end. + + +Theorem T_OMEGA16_stable : term_stable T_OMEGA16. + +prove_stable T_OMEGA16 OMEGA16. +Qed. + +Definition Tred_factor5 (t : term) := + match t with + | Tplus (Tmult x (Tint Z0)) y => y + | _ => t + end. + +Theorem Tred_factor5_stable : term_stable Tred_factor5. + + +prove_stable Tred_factor5 Zred_factor5. +Qed. + +Definition Topp_plus (t : term) := + match t with + | Topp (Tplus x y) => Tplus (Topp x) (Topp y) + | _ => t + end. + +Theorem Topp_plus_stable : term_stable Topp_plus. + +prove_stable Topp_plus Zopp_plus_distr. +Qed. + + +Definition Topp_opp (t : term) := + match t with + | Topp (Topp x) => x + | _ => t + end. + +Theorem Topp_opp_stable : term_stable Topp_opp. + +prove_stable Topp_opp Zopp_involutive. +Qed. + +Definition Topp_mult_r (t : term) := + match t with + | Topp (Tmult x (Tint k)) => Tmult x (Tint (- k)) + | _ => t + end. + +Theorem Topp_mult_r_stable : term_stable Topp_mult_r. + +prove_stable Topp_mult_r Zopp_mult_distr_r. +Qed. + +Definition Topp_one (t : term) := + match t with + | Topp x => Tmult x (Tint (-1)) + | _ => t + end. + +Theorem Topp_one_stable : term_stable Topp_one. + +prove_stable Topp_one Zopp_eq_mult_neg_1. +Qed. + +Definition Tmult_plus_distr (t : term) := + match t with + | Tmult (Tplus n m) p => Tplus (Tmult n p) (Tmult m p) + | _ => t + end. + +Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr. + +prove_stable Tmult_plus_distr Zmult_plus_distr_l. +Qed. + +Definition Tmult_opp_left (t : term) := + match t with + | Tmult (Topp x) (Tint y) => Tmult x (Tint (- y)) + | _ => t + end. + +Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left. + +prove_stable Tmult_opp_left Zmult_opp_comm. +Qed. + +Definition Tmult_assoc_reduced (t : term) := + match t with + | Tmult (Tmult n (Tint m)) (Tint p) => Tmult n (Tint (m * p)) + | _ => t + end. + +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). + +Theorem Tred_factor0_stable : term_stable Tred_factor0. + +prove_stable Tred_factor0 Zred_factor0. +Qed. + +Definition Tred_factor1 (t : term) := + match t with + | Tplus x y => + match eq_term x y with + | true => Tmult x (Tint 2) + | false => t + end + | _ => t + end. + +Theorem Tred_factor1_stable : term_stable Tred_factor1. + +prove_stable Tred_factor1 Zred_factor1. +Qed. + +Definition Tred_factor2 (t : term) := + match t with + | Tplus x (Tmult y (Tint k)) => + match eq_term x y with + | true => Tmult x (Tint (1 + k)) + | false => t + end + | _ => t + end. + +(* Attention : il faut rendre opaque [Zplus] pour éviter que la tactique + de simplification n'aille trop loin et défasse [Zplus 1 k] *) + +Opaque Zplus. + +Theorem Tred_factor2_stable : term_stable Tred_factor2. +prove_stable Tred_factor2 Zred_factor2. +Qed. + +Definition Tred_factor3 (t : term) := + match t with + | Tplus (Tmult x (Tint k)) y => + match eq_term x y with + | true => Tmult x (Tint (1 + k)) + | false => t + end + | _ => t + end. + +Theorem Tred_factor3_stable : term_stable Tred_factor3. + +prove_stable Tred_factor3 Zred_factor3. +Qed. + + +Definition Tred_factor4 (t : term) := + match t with + | Tplus (Tmult x (Tint k1)) (Tmult y (Tint k2)) => + match eq_term x y with + | true => Tmult x (Tint (k1 + k2)) + | false => t + end + | _ => t + end. + +Theorem Tred_factor4_stable : term_stable Tred_factor4. + +prove_stable Tred_factor4 Zred_factor4. +Qed. + +Definition Tred_factor6 (t : term) := Tplus t (Tint 0). + +Theorem Tred_factor6_stable : term_stable Tred_factor6. + +prove_stable Tred_factor6 Zred_factor6. +Qed. + +Transparent Zplus. + +Definition Tminus_def (t : term) := + match t with + | Tminus x y => Tplus x (Topp y) + | _ => t + end. + +Theorem Tminus_def_stable : term_stable Tminus_def. + +(* Le théorème ne sert à rien. Le but est prouvé avant. *) +prove_stable Tminus_def False. +Qed. + +(* \subsection{Fonctions de réécriture complexes} *) + +(* \subsubsection{Fonction de réduction} *) +(* Cette fonction réduit un terme dont la forme normale est un entier. Il + suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs + réifiés. La réduction est ``gratuite''. *) + +Fixpoint reduce (t : term) : term := + match t with + | Tplus x y => + match reduce x with + | Tint x' => + match reduce y with + | Tint y' => Tint (x' + y') + | y' => Tplus (Tint x') y' + end + | x' => Tplus x' (reduce y) + end + | Tmult x y => + match reduce x with + | Tint x' => + match reduce y with + | Tint y' => Tint (x' * y') + | y' => Tmult (Tint x') y' + end + | x' => Tmult x' (reduce y) + end + | Tminus x y => + match reduce x with + | Tint x' => + match reduce y with + | Tint y' => Tint (x' - y') + | y' => Tminus (Tint x') y' + end + | x' => Tminus x' (reduce y) + end + | Topp x => + match reduce x with + | Tint x' => Tint (- x') + | x' => Topp x' + end + | _ => t + end. + +Theorem reduce_stable : term_stable reduce. + +unfold term_stable in |- *; intros e t; elim t; auto; + try + (intros t0 H0 t1 H1; simpl in |- *; rewrite H0; rewrite H1; + (case (reduce t0); + [ intro z0; case (reduce t1); intros; auto + | intros; auto + | intros; auto + | intros; auto + | intros; auto + | intros; auto ])); intros t0 H0; simpl in |- *; + rewrite H0; case (reduce t0); intros; auto. +Qed. + +(* \subsubsection{Fusions} + \paragraph{Fusion de deux équations} *) +(* On donne une somme de deux équations qui sont supposées normalisées. + Cette fonction prend une trace de fusion en argument et transforme + le terme en une équation normalisée. C'est une version très simplifiée + du moteur de réécriture [rewrite]. *) + +Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := + match trace with + | nil => reduce t + | step :: trace' => + match step with + | F_equal => apply_right (fusion trace') (T_OMEGA10 t) + | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA10 t)) + | F_left => apply_right (fusion trace') (T_OMEGA11 t) + | F_right => apply_right (fusion trace') (T_OMEGA12 t) + end + end. + +Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t). + +simple induction t; simpl in |- *; + [ exact reduce_stable + | intros stp l H; case stp; + [ apply compose_term_stable; + [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ] + | unfold term_stable in |- *; intros e t1; rewrite T_OMEGA10_stable; + rewrite Tred_factor5_stable; apply H + | apply compose_term_stable; + [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ] + | apply compose_term_stable; + [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ]. + +Qed. + +(* \paragraph{Fusion de deux équations dont une sans coefficient} *) + +Definition fusion_right (trace : list t_fusion) (t : term) : term := + match trace with + | nil => reduce t (* Il faut mettre un compute *) + | step :: trace' => + match step with + | F_equal => apply_right (fusion trace') (T_OMEGA15 t) + | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA15 t)) + | F_left => apply_right (fusion trace') (Tplus_assoc_r t) + | F_right => apply_right (fusion trace') (T_OMEGA12 t) + end + end. + +(* \paragraph{Fusion avec anihilation} *) +(* Normalement le résultat est une constante *) + +Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := + match trace with + | O => reduce t + | S trace' => fusion_cancel trace' (T_OMEGA13 t) + end. + +Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). + +unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace; + [ exact (reduce_stable e) + | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. +Qed. + +(* \subsubsection{Opérations afines sur une équation} *) +(* \paragraph{Multiplication scalaire et somme d'une constante} *) + +Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := + match trace with + | O => reduce t + | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t) + end. + +Theorem scalar_norm_add_stable : + forall t : nat, term_stable (scalar_norm_add t). + +unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace; + [ exact reduce_stable + | intros n H e t; elim apply_right_stable; + [ exact (T_OMEGA11_stable e t) | exact H ] ]. +Qed. + +(* \paragraph{Multiplication scalaire} *) +Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := + match trace with + | O => reduce t + | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t) + end. + +Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). + +unfold term_stable, scalar_norm in |- *; intros trace; elim trace; + [ exact reduce_stable + | intros n H e t; elim apply_right_stable; + [ exact (T_OMEGA16_stable e t) | exact H ] ]. +Qed. + +(* \paragraph{Somme d'une constante} *) +Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := + match trace with + | O => reduce t + | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t) + end. + +Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). + +unfold term_stable, add_norm in |- *; intros trace; elim trace; + [ exact reduce_stable + | intros n H e t; elim apply_right_stable; + [ exact (Tplus_assoc_r_stable e t) | exact H ] ]. +Qed. + +(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *) + + +Fixpoint rewrite (s : step) : term -> term := + match s with + | C_DO_BOTH s1 s2 => apply_both (rewrite s1) (rewrite s2) + | C_LEFT s => apply_left (rewrite s) + | C_RIGHT s => apply_right (rewrite s) + | C_SEQ s1 s2 => fun t : term => rewrite s2 (rewrite s1 t) + | C_NOP => fun t : term => t + | C_OPP_PLUS => Topp_plus + | C_OPP_OPP => Topp_opp + | C_OPP_MULT_R => Topp_mult_r + | C_OPP_ONE => Topp_one + | C_REDUCE => reduce + | C_MULT_PLUS_DISTR => Tmult_plus_distr + | C_MULT_OPP_LEFT => Tmult_opp_left + | C_MULT_ASSOC_R => Tmult_assoc_r + | C_PLUS_ASSOC_R => Tplus_assoc_r + | C_PLUS_ASSOC_L => Tplus_assoc_l + | C_PLUS_PERMUTE => Tplus_permute + | C_PLUS_SYM => Tplus_sym + | C_RED0 => Tred_factor0 + | C_RED1 => Tred_factor1 + | C_RED2 => Tred_factor2 + | C_RED3 => Tred_factor3 + | C_RED4 => Tred_factor4 + | C_RED5 => Tred_factor5 + | C_RED6 => Tred_factor6 + | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced + | C_MINUS => Tminus_def + | C_MULT_SYM => Tmult_sym + end. + +Theorem rewrite_stable : forall s : step, term_stable (rewrite s). + +simple induction s; simpl in |- *; + [ intros; apply apply_both_stable; auto + | intros; apply apply_left_stable; auto + | intros; apply apply_right_stable; auto + | unfold term_stable in |- *; intros; elim H0; apply H + | unfold term_stable in |- *; auto + | exact Topp_plus_stable + | exact Topp_opp_stable + | exact Topp_mult_r_stable + | exact Topp_one_stable + | exact reduce_stable + | exact Tmult_plus_distr_stable + | exact Tmult_opp_left_stable + | exact Tmult_assoc_r_stable + | exact Tplus_assoc_r_stable + | exact Tplus_assoc_l_stable + | exact Tplus_permute_stable + | exact Tplus_sym_stable + | exact Tred_factor0_stable + | exact Tred_factor1_stable + | exact Tred_factor2_stable + | exact Tred_factor3_stable + | exact Tred_factor4_stable + | exact Tred_factor5_stable + | exact Tred_factor6_stable + | exact Tmult_assoc_reduced_stable + | exact Tminus_def_stable + | exact Tmult_sym_stable ]. +Qed. + +(* \subsection{tactiques de résolution d'un but omega normalisé} + Trace de la procédure +\subsubsection{Tactiques générant une contradiction} +\paragraph{[O_CONSTANT_NOT_NUL]} *) + +Definition constant_not_nul (i : nat) (h : list proposition) := + match nth_hyps i h with + | EqTerm (Tint Z0) (Tint n) => + match eq_Z n 0 with + | true => h + | false => absurd + end + | _ => h + end. + +Theorem constant_not_nul_valid : + forall i : nat, valid_hyps (constant_not_nul i). + +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 H1; symmetry in |- *; auto. +Qed. + +(* \paragraph{[O_CONSTANT_NEG]} *) + +Definition constant_neg (i : nat) (h : list proposition) := + match nth_hyps i h with + | LeqTerm (Tint Z0) (Tint (Zneg n)) => absurd + | _ => h + end. + +Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). + +unfold valid_hyps, constant_neg in |- *; intros; + generalize (nth_valid ep e i lp); Simplify; simpl in |- *; + unfold Zle in |- *; simpl in |- *; intros H1; elim H1; + [ assumption | trivial ]. +Qed. + +(* \paragraph{[NOT_EXACT_DIVIDE]} *) +Definition not_exact_divide (k1 k2 : Z) (body : term) + (t i : nat) (l : list proposition) := + 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 + with + | true => + match (k2 ?= 0)%Z with + | Datatypes.Gt => + match (k1 ?= k2)%Z with + | Datatypes.Gt => absurd + | _ => l + end + | _ => l + end + | false => l + end + | _ => l + end. + +Theorem not_exact_divide_valid : + forall (k1 k2 : Z) (body : term) (t i : nat), + valid_hyps (not_exact_divide k1 k2 body t i). + +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; + 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); + [ apply OMEGA4; assumption | symmetry in |- *; auto ]. + +Qed. + +(* \paragraph{[O_CONTRADICTION]} *) + +Definition contradiction (t i j : nat) (l : list proposition) := + 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 + | _ => l + end + | _ => l + end + | _ => l + end. + +Theorem contradiction_valid : + forall t i j : nat, valid_hyps (contradiction t i j). + +unfold valid_hyps, contradiction in |- *; intros t i j ep e l H; + generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; 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 |- *; + 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; + elim H3; auto. + +Qed. + +(* \paragraph{[O_NEGATE_CONTRADICT]} *) + +Definition negate_contradict (i1 i2 : nat) (h : list proposition) := + match nth_hyps i1 h with + | EqTerm (Tint Z0) b1 => + match nth_hyps i2 h with + | NeqTerm (Tint Z0) b2 => + match eq_term b1 b2 with + | true => absurd + | false => h + end + | _ => h + end + | NeqTerm (Tint Z0) b1 => + match nth_hyps i2 h with + | EqTerm (Tint Z0) b2 => + match eq_term b1 b2 with + | true => absurd + | false => h + end + | _ => h + end + | _ => h + end. + +Definition negate_contradict_inv (t i1 i2 : nat) (h : list proposition) := + 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 + | true => absurd + | false => h + end + | _ => h + end + | 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 + | true => absurd + | false => h + end + | _ => h + end + | _ => h + end. + +Theorem negate_contradict_valid : + forall i j : nat, valid_hyps (negate_contradict i j). + +unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H; + generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; intros z; 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; + [ elim_eq_term t2 t4; intro H3; + [ elim H1; elim H3; assumption | assumption ] + | elim_eq_term t2 t4; intro H3; + [ elim H2; rewrite H3; assumption | assumption ] ]. + +Qed. + +Theorem negate_contradict_inv_valid : + forall t i j : nat, valid_hyps (negate_contradict_inv t i j). + + +unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H; + generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; intros z; 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 |- *; + apply bool_ind2; intro Aux; + [ generalize (eq_term_true t2 (scalar_norm t (Tmult t4 (Tint (-1)))) Aux); + clear Aux + | generalize (eq_term_false t2 (scalar_norm t (Tmult t4 (Tint (-1)))) Aux); + clear Aux ]); + [ intro H3; elim H1; generalize H2; rewrite H3; + rewrite <- (scalar_norm_stable t e); simpl in |- *; + elim (interp_term e t4); simpl in |- *; auto; intros p H4; + discriminate H4 + | auto + | intro H3; elim H2; rewrite H3; elim (scalar_norm_stable t e); + simpl in |- *; elim H1; simpl in |- *; trivial + | auto ]. + +Qed. + +(* \subsubsection{Tactiques générant une nouvelle équation} *) +(* \paragraph{[O_SUM]} + C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant + les opérateurs de comparaison des deux arguments) d'où une + preuve un peu compliquée. On utilise quelques lemmes qui sont des + généralisations des théorèmes utilisés par OMEGA. *) + +Definition sum (k1 k2 : Z) (trace : list t_fusion) + (prop1 prop2 : proposition) := + match prop1 with + | 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)))) + | LeqTerm (Tint Z0) b2 => + match (k2 ?= 0)%Z with + | Datatypes.Gt => + LeqTerm (Tint 0) + (fusion trace + (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))) + | _ => TrueTerm + end + | _ => TrueTerm + end + | LeqTerm (Tint Z0) b1 => + match (k1 ?= 0)%Z with + | Datatypes.Gt => + match prop2 with + | EqTerm (Tint Z0) b2 => + LeqTerm (Tint 0) + (fusion trace + (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))) + | LeqTerm (Tint Z0) b2 => + match (k2 ?= 0)%Z with + | Datatypes.Gt => + LeqTerm (Tint 0) + (fusion trace + (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))) + | _ => TrueTerm + end + | _ => TrueTerm + end + | _ => TrueTerm + end + | NeqTerm (Tint Z0) b1 => + match prop2 with + | EqTerm (Tint Z0) b2 => + match eq_Z k1 0 with + | true => TrueTerm + | false => + NeqTerm (Tint 0) + (fusion trace + (Tplus (Tmult b1 (Tint k1)) (Tmult b2 (Tint k2)))) + 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. + +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. + +intros; elim H0; simpl in |- *; generalize H H1; case b; case d; + unfold Zle in |- *; simpl in |- *; auto. +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. + +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. + +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. + +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 |- *; + intros; try discriminate; assumption. +Qed. + + +Theorem sum_valid : + forall (k1 k2 : Z) (t : list t_fusion), valid2 (sum k1 k2 t). + +unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *; + Simplify; simpl in |- *; auto; try elim (fusion_stable t); + simpl in |- *; intros; + [ apply sum1; assumption + | apply sum2; try assumption; apply sum4; assumption + | rewrite 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 ]. +Qed. + +(* \paragraph{[O_EXACT_DIVIDE]} + c'est une oper1 valide mais on préfère une substitution a ce point la *) + +Definition exact_divide (k : 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 + | true => + match eq_Z k 0 with + | true => TrueTerm + | false => EqTerm (Tint 0) body + end + | false => TrueTerm + end + | _ => TrueTerm + end. + +Theorem exact_divide_valid : + forall (k : Z) (t : term) (n : nat), valid1 (exact_divide k t n). + + +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 |- *; + 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 p2 p3 H3 H4; discriminate H4 + | intros p2 p3 H3 H4; discriminate H4 ]). + +Qed. + + + +(* \paragraph{[O_DIV_APPROX]} + La preuve reprend le schéma de la précédente mais on + est sur une opération de type valid1 et non sur une opération terminale. *) + +Definition divide_and_approx (k1 k2 : Z) (body : term) + (t : nat) (prop : proposition) := + match prop with + | LeqTerm (Tint Z0) b => + match + eq_term (scalar_norm_add t (Tplus (Tmult body (Tint k1)) (Tint k2))) + b + with + | true => + match (k1 ?= 0)%Z with + | Datatypes.Gt => + match (k1 ?= k2)%Z with + | Datatypes.Gt => LeqTerm (Tint 0) body + | _ => prop + end + | _ => prop + end + | false => prop + end + | _ => prop + end. + +Theorem divide_and_approx_valid : + forall (k1 k2 : Z) (body : term) (t : nat), + valid1 (divide_and_approx k1 k2 body t). + +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; + 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. +Qed. + +(* \paragraph{[MERGE_EQ]} *) + +Definition merge_eq (t : nat) (prop1 prop2 : proposition) := + match prop1 with + | LeqTerm (Tint Z0) b1 => + match prop2 with + | LeqTerm (Tint Z0) b2 => + match eq_term b1 (scalar_norm t (Tmult b2 (Tint (-1)))) with + | true => EqTerm (Tint 0) b1 + | false => TrueTerm + end + | _ => TrueTerm + end + | _ => TrueTerm + end. + +Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). + +unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *; + auto; elim (scalar_norm_stable n e); simpl in |- *; + intros; symmetry in |- *; apply OMEGA8 with (2 := H0); + [ assumption | elim Zopp_eq_mult_neg_1; trivial ]. +Qed. + + + +(* \paragraph{[O_CONSTANT_NUL]} *) + +Definition constant_nul (i : nat) (h : list proposition) := + match nth_hyps i h with + | NeqTerm (Tint Z0) (Tint Z0) => absurd + | _ => h + end. + +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. +Qed. + +(* \paragraph{[O_STATE]} *) + +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)))) + | _ => TrueTerm + end + | _ => TrueTerm + end. + +Theorem state_valid : forall (m : Z) (s : step), valid2 (state m s). + +unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify; + simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; + intros H1 H2; elim H1; + rewrite (Zplus_comm (- interp_term e t5) (interp_term e t3)); + elim H2; simpl in |- *; reflexivity. + +Qed. + +(* \subsubsection{Tactiques générant plusieurs but} + \paragraph{[O_SPLIT_INEQ]} + La seule pour le moment (tant que la normalisation n'est pas réfléchie). *) + +Definition split_ineq (i t : nat) + (f1 f2 : list proposition -> list (list proposition)) + (l : list proposition) := + match nth_hyps i l with + | NeqTerm (Tint Z0) b1 => + f1 (LeqTerm (Tint 0) (add_norm t (Tplus b1 (Tint (-1)))) :: l) ++ + f2 + (LeqTerm (Tint 0) + (scalar_norm_add t (Tplus (Tmult b1 (Tint (-1))) (Tint (-1)))) + :: l) + | _ => l :: nil + end. + +Theorem split_ineq_valid : + forall (i t : nat) (f1 f2 : list proposition -> list (list proposition)), + valid_list_hyps f1 -> + valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). + +unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H; + generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); + simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; + auto; intros z; case z; simpl in |- *; auto; intro H3; + apply append_valid; elim (OMEGA19 (interp_term e t2)); + [ intro H4; left; apply H1; simpl in |- *; elim (add_norm_stable t); + simpl in |- *; auto + | intro H4; right; apply H2; simpl in |- *; elim (scalar_norm_add_stable t); + simpl in |- *; auto + | generalize H3; unfold Zne, not in |- *; intros E1 E2; apply E1; + symmetry in |- *; trivial ]. +Qed. + + +(* \subsection{La fonction de rejeu de la trace} *) + +Fixpoint execute_omega (t : t_omega) (l : list proposition) {struct t} : + list (list proposition) := + 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_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) + | 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_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_NEGATE_CONTRADICT_INV t i j => + (fun a : list proposition => a :: nil) (negate_contradict_inv t i j l) + | O_STATE m s i1 i2 cont => + execute_omega cont (apply_oper_2 i1 i2 (state m s) l) + end. + +Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t). + +simple induction t; simpl in |- *; + [ unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + apply (constant_not_nul_valid n ep e lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + apply (constant_neg_valid n ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros k1 k2 body n t' Ht' m ep e lp H; apply Ht'; + apply + (apply_oper_1_valid m (divide_and_approx k1 k2 body n) + (divide_and_approx_valid k1 k2 body n) ep e lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + apply (not_exact_divide_valid z z0 t0 n n0 ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros k body n t' Ht' m ep e lp H; apply Ht'; + apply + (apply_oper_1_valid m (exact_divide k body n) + (exact_divide_valid k body n) ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; + apply + (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e + lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + apply (contradiction_valid n n0 n1 ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros trace i1 i2 t' Ht' ep e lp H; apply Ht'; + apply + (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e + lp H) + | intros t' i k1 H1 k2 H2; unfold valid_list_hyps in |- *; simpl in |- *; + intros ep e lp H; + apply + (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e + lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros i ep e lp H; left; + apply (constant_nul_valid i ep e lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros i j ep e lp H; left; + apply (negate_contradict_valid i j ep e lp H) + | unfold valid_list_hyps in |- *; simpl in |- *; intros n i j ep e lp H; + left; apply (negate_contradict_inv_valid n i j ep e lp H) + | unfold valid_list_hyps, valid_hyps in |- *; + intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; + apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ]. +Qed. + + +(* \subsection{Les opérations globales sur le but} + \subsubsection{Normalisation} *) + +Definition move_right (s : step) (p : proposition) := + match p with + | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (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))) + | p => p + end. + +Theorem Zne_left_2 : forall x y : Z, Zne x y -> Zne 0 (x + - y). +unfold Zne, not in |- *; intros x y H1 H2; apply H1; + apply (Zplus_reg_l (- y)); rewrite Zplus_comm; elim H2; + rewrite Zplus_opp_l; trivial. +Qed. + +Theorem move_right_valid : forall s : step, valid1 (move_right s). + +unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *; + elim (rewrite_stable s e); simpl in |- *; + [ symmetry in |- *; apply Zegal_left; assumption + | intro; apply Zle_left; assumption + | intro; apply Zge_left; assumption + | intro; apply Zgt_left; assumption + | intro; apply Zlt_left; assumption + | intro; apply Zne_left_2; assumption ]. +Qed. + +Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). + +Theorem do_normalize_valid : + forall (i : nat) (s : step), valid_hyps (do_normalize i s). + +intros; unfold do_normalize in |- *; apply apply_oper_1_valid; + apply move_right_valid. +Qed. + +Fixpoint do_normalize_list (l : list step) (i : nat) + (h : list proposition) {struct l} : list proposition := + match l with + | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) + | nil => h + end. + +Theorem do_normalize_list_valid : + forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). + +simple induction l; simpl in |- *; unfold valid_hyps in |- *; + [ auto + | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; + apply (do_normalize_valid i a ep e lp); assumption ]. +Qed. + +Theorem normalize_goal : + forall (s : list step) (ep : 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. + +intros; apply valid_goal with (2 := H); apply do_normalize_list_valid. +Qed. + +(* \subsubsection{Exécution de la trace} *) + +Theorem execute_goal : + forall (t : t_omega) (ep : 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. + +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)), + interp_list_goal ep e l1 /\ interp_list_goal ep e l2 -> + interp_list_goal ep e (l1 ++ l2). + +intros ep e; simple induction l1; + [ simpl in |- *; intros l2 (H1, H2); assumption + | simpl in |- *; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. + +Qed. + +Require Import Decidable. + +(* A simple decidability checker : if the proposition belongs to the + simple grammar describe below then it is decidable. Proof is by + induction and uses well known theorem about arithmetic and propositional + calculus *) + +Fixpoint decidability (p : proposition) : bool := + match p with + | EqTerm _ _ => true + | LeqTerm _ _ => true + | GeqTerm _ _ => true + | GtTerm _ _ => true + | LtTerm _ _ => true + | NeqTerm _ _ => true + | FalseTerm => true + | TrueTerm => true + | Tnot t => decidability t + | Tand t1 t2 => decidability t1 && decidability t2 + | Timp t1 t2 => decidability t1 && decidability t2 + | Tor t1 t2 => decidability t1 && decidability t2 + | Tprop _ => false + end. + +Theorem decidable_correct : + forall (ep : PropList) (e : list Z) (p : proposition), + decidability p = true -> decidable (interp_proposition ep e p). + +simple induction p; simpl in |- *; intros; + [ apply dec_eq + | apply dec_Zle + | left; auto + | right; unfold not in |- *; auto + | apply dec_not; auto + | apply dec_Zge + | apply dec_Zgt + | apply dec_Zlt + | apply dec_Zne + | apply dec_or; elim andb_prop with (1 := H1); auto + | apply dec_and; elim andb_prop with (1 := H1); auto + | apply dec_imp; elim andb_prop with (1 := H1); auto + | discriminate H ]. + +Qed. + +(* An interpretation function for a complete goal with an explicit + conclusion. We use an intermediate fixpoint. *) + +Fixpoint interp_full_goal (envp : PropList) (env : list Z) + (c : proposition) (l : list proposition) {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 := + match lc with + | (l, c) => interp_full_goal ep e c l + end. + +(* Relates the interpretation of a complete goal with the interpretation + of its hypothesis and conclusion *) + +Theorem interp_full_false : + forall (ep : PropList) (e : list Z) (l : list proposition) (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 |- *; + [ auto | intros a l1 H1 c H2 H3; apply H1; auto ]. + +Qed. + +(* Push the conclusion in the list of hypothesis using a double negation + If the decidability cannot be "proven", then just forget about the + conclusion (equivalent of replacing it with false) *) + +Definition to_contradict (lc : list proposition * proposition) := + match lc with + | (l, c) => if decidability c then Tnot c :: l else l + end. + +(* The previous operation is valid in the sense that the new list of + hypothesis implies the original goal *) + +Theorem to_contradict_valid : + forall (ep : 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. + +intros ep e lc; case lc; intros l c; simpl in |- *; + pattern (decidability c) in |- *; apply bool_ind2; + [ simpl in |- *; intros H H1; apply interp_full_false; intros H2; + apply not_not; + [ apply decidable_correct; assumption + | unfold not at 1 in |- *; intro H3; apply hyps_to_goal with (2 := H2); + auto ] + | intros H1 H2; apply interp_full_false; intro H3; + elim hyps_to_goal with (1 := H2); assumption ]. +Qed. + +(* [map_cons x l] adds [x] at the head of each list in [l] (which is a list + of lists *) + +Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : + list (list A) := + match l with + | nil => nil + | l :: ll => (x :: l) :: map_cons A x ll + end. + +(* This function breaks up a list of hypothesis in a list of simpler + list of hypothesis that together implie the original one. The goal + of all this is to transform the goal in a list of solvable problems. + Note that : + - we need a way to drive the analysis as some hypotheis may not + require a split. + - this procedure must be perfectly mimicked by the ML part otherwise + hypothesis will get desynchronised and this will be a mess. + *) + +Fixpoint destructure_hyps (nn : nat) (ll : list proposition) {struct nn} : + list (list proposition) := + match nn with + | O => ll :: nil + | S n => + match ll with + | nil => nil :: nil + | Tor p1 p2 :: l => + destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l) + | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l) + | Timp p1 p2 :: l => + if decidability p1 + then + destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l) + else map_cons _ (Timp p1 p2) (destructure_hyps n l) + | Tnot p :: l => + match p with + | Tnot p1 => + if decidability p1 + then destructure_hyps n (p1 :: l) + else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l) + | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l) + | Tand p1 p2 => + if decidability p1 + then + destructure_hyps n (Tnot p1 :: l) ++ + destructure_hyps n (Tnot p2 :: l) + else map_cons _ (Tnot p) (destructure_hyps n l) + | _ => map_cons _ (Tnot p) (destructure_hyps n l) + end + | x :: l => map_cons _ x (destructure_hyps n l) + end + end. + +Theorem map_cons_val : + forall (ep : PropList) (e : list Z) (p : proposition) + (l : list (list proposition)), + interp_proposition ep e p -> + interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). + +simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ]. +Qed. + +Hint Resolve map_cons_val append_valid decidable_correct. + +Theorem destructure_hyps_valid : + forall n : nat, valid_list_hyps (destructure_hyps n). + +simple induction n; + [ unfold valid_list_hyps in |- *; simpl in |- *; auto + | unfold valid_list_hyps at 2 in |- *; intros n1 H ep e lp; case lp; + [ simpl in |- *; auto + | intros p l; case p; + try + (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; + auto); + [ intro p'; case p'; + try + (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; + auto); + [ simpl in |- *; intros p1 (H1, H2); + pattern (decidability p1) in |- *; apply bool_ind2; + intro H3; + [ apply H; simpl in |- *; split; + [ apply not_not; auto | assumption ] + | auto ] + | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *; + elim not_or with (1 := H1); auto + | simpl in |- *; intros p1 p2 (H1, H2); + pattern (decidability p1) in |- *; apply bool_ind2; + intro H3; + [ apply append_valid; elim not_and with (2 := H1); + [ intro; left; apply H; simpl in |- *; auto + | intro; right; apply H; simpl in |- *; auto + | auto ] + | auto ] ] + | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid; + (elim H1; intro H3; simpl in |- *; [ left | right ]); + apply H; simpl in |- *; auto + | simpl in |- *; intros; apply H; simpl in |- *; tauto + | simpl in |- *; intros p1 p2 (H1, H2); + pattern (decidability p1) in |- *; apply bool_ind2; + intro H3; + [ apply append_valid; elim imp_simp with (2 := H1); + [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto + | intro H4; right; simpl in |- *; apply H; simpl in |- *; auto + | auto ] + | auto ] ] ] ]. + +Qed. + +Definition prop_stable (f : proposition -> proposition) := + forall (ep : PropList) (e : list Z) (p : proposition), + interp_proposition ep e p <-> interp_proposition ep e (f p). + +Definition p_apply_left (f : proposition -> proposition) + (p : proposition) := + match p with + | Timp x y => Timp (f x) y + | Tor x y => Tor (f x) y + | Tand x y => Tand (f x) y + | Tnot x => Tnot (f x) + | x => x + end. + +Theorem p_apply_left_stable : + forall f : proposition -> proposition, + prop_stable f -> prop_stable (p_apply_left f). + +unfold prop_stable in |- *; intros f H ep e p; split; + (case p; simpl in |- *; auto; intros p1; elim (H ep e p1); tauto). +Qed. + +Definition p_apply_right (f : proposition -> proposition) + (p : proposition) := + match p with + | Timp x y => Timp x (f y) + | Tor x y => Tor x (f y) + | Tand x y => Tand x (f y) + | Tnot x => Tnot (f x) + | x => x + end. + +Theorem p_apply_right_stable : + forall f : proposition -> proposition, + prop_stable f -> prop_stable (p_apply_right f). + +unfold prop_stable in |- *; intros f H ep e p; split; + (case p; simpl in |- *; auto; + [ intros p1; elim (H ep e p1); tauto + | intros p1 p2; elim (H ep e p2); tauto + | intros p1 p2; elim (H ep e p2); tauto + | intros p1 p2; elim (H ep e p2); tauto ]). +Qed. + +Definition p_invert (f : proposition -> proposition) + (p : proposition) := + match p with + | EqTerm x y => Tnot (f (NeqTerm x y)) + | LeqTerm x y => Tnot (f (GtTerm x y)) + | GeqTerm x y => Tnot (f (LtTerm x y)) + | GtTerm x y => Tnot (f (LeqTerm x y)) + | LtTerm x y => Tnot (f (GeqTerm x y)) + | NeqTerm x y => Tnot (f (EqTerm x y)) + | x => x + end. + +Theorem p_invert_stable : + forall f : proposition -> proposition, + prop_stable f -> prop_stable (p_invert f). + +unfold prop_stable in |- *; intros f H ep e p; split; + (case p; simpl in |- *; auto; + [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *; + unfold Zne in |- *; + generalize (dec_eq (interp_term e t1) (interp_term e t2)); + unfold decidable in |- *; tauto + | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl in |- *; + unfold Zgt in |- *; + generalize (dec_Zgt (interp_term e t1) (interp_term e t2)); + unfold decidable, Zgt, Zle in |- *; tauto + | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *; + unfold Zlt in |- *; + generalize (dec_Zlt (interp_term e t1) (interp_term e t2)); + unfold decidable, Zge in |- *; tauto + | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl in |- *; + generalize (dec_Zgt (interp_term e t1) (interp_term e t2)); + unfold Zle, Zgt in |- *; unfold decidable in |- *; + tauto + | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl in |- *; + generalize (dec_Zlt (interp_term e t1) (interp_term e t2)); + unfold Zge, Zlt in |- *; unfold decidable in |- *; + tauto + | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl in |- *; + generalize (dec_eq (interp_term e t1) (interp_term e t2)); + unfold decidable, Zne in |- *; tauto ]). +Qed. + +Theorem Zlt_left_inv : forall x y : Z, (0 <= y + -1 + - x)%Z -> (x < y)%Z. + +intros; apply Zsucc_lt_reg; apply Zle_lt_succ; + apply (fun a b : Z => Zplus_le_reg_r a b (-1 + - x)); + rewrite Zplus_assoc; unfold Zsucc in |- *; rewrite (Zplus_assoc_reverse x); + rewrite (Zplus_assoc y); simpl in |- *; rewrite Zplus_0_r; + rewrite Zplus_opp_r; assumption. +Qed. + +Theorem move_right_stable : forall s : step, prop_stable (move_right s). + +unfold move_right, prop_stable in |- *; intros s ep e p; split; + [ Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *; + [ symmetry in |- *; apply Zegal_left; assumption + | intro; apply Zle_left; assumption + | intro; apply Zge_left; assumption + | intro; apply Zgt_left; assumption + | intro; apply Zlt_left; assumption + | intro; apply Zne_left_2; assumption ] + | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s); + simpl in |- *; intro H1; + [ rewrite (Zplus_0_r_reverse (interp_term e t0)); rewrite H1; + rewrite Zplus_permute; rewrite Zplus_opp_r; + rewrite Zplus_0_r; trivial + | apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t)); + rewrite Zplus_opp_r; assumption + | apply Zle_ge; + apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t0)); + rewrite Zplus_opp_r; assumption + | apply Zlt_gt; apply Zlt_left_inv; assumption + | apply Zlt_left_inv; assumption + | unfold Zne, not in |- *; unfold Zne in H1; intro H2; apply H1; + rewrite H2; rewrite Zplus_opp_r; trivial ] ]. +Qed. + + +Fixpoint p_rewrite (s : p_step) : proposition -> proposition := + match s with + | P_LEFT s => p_apply_left (p_rewrite s) + | P_RIGHT s => p_apply_right (p_rewrite s) + | P_STEP s => move_right s + | P_INVERT s => p_invert (move_right s) + | P_NOP => fun p : proposition => p + end. + +Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). + + +simple induction s; simpl in |- *; + [ intros; apply p_apply_left_stable; trivial + | intros; apply p_apply_right_stable; trivial + | intros; apply p_invert_stable; apply move_right_stable + | apply move_right_stable + | unfold prop_stable in |- *; simpl in |- *; intros; split; auto ]. +Qed. + +Fixpoint normalize_hyps (l : list h_step) (lh : list proposition) {struct l} + : list proposition := + match l with + | nil => lh + | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh) + end. + +Theorem normalize_hyps_valid : + forall l : list h_step, valid_hyps (normalize_hyps l). + +simple induction l; unfold valid_hyps in |- *; simpl in |- *; + [ auto + | intros n_s r; case n_s; intros n s H ep e lp H1; apply H; + apply apply_oper_1_valid; + [ unfold valid1 in |- *; intros ep1 e1 p1 H2; + elim (p_rewrite_stable s ep1 e1 p1); auto + | assumption ] ]. +Qed. + +Theorem normalize_hyps_goal : + forall (s : list h_step) (ep : 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. + +intros; apply valid_goal with (2 := H); apply normalize_hyps_valid. +Qed. + +Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : + proposition := + match s with + | D_left :: l => + match p with + | Tand x y => extract_hyp_pos l x + | _ => p + end + | D_right :: l => + match p with + | Tand x y => extract_hyp_pos l y + | _ => p + end + | D_mono :: l => match p with + | Tnot x => extract_hyp_neg l x + | _ => p + end + | _ => p + end + + with extract_hyp_neg (s : list direction) (p : proposition) {struct s} : + proposition := + match s with + | D_left :: l => + match p with + | Tor x y => extract_hyp_neg l x + | Timp x y => if decidability x then extract_hyp_pos l x else Tnot p + | _ => Tnot p + end + | D_right :: l => + match p with + | Tor x y => extract_hyp_neg l y + | Timp x y => extract_hyp_neg l y + | _ => Tnot p + end + | D_mono :: l => + match p with + | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p + | _ => Tnot p + end + | _ => + match p with + | Tnot x => if decidability x then x else Tnot p + | _ => Tnot p + end + end. + +Definition co_valid1 (f : proposition -> proposition) := + forall (ep : PropList) (e : list Z) (p1 : proposition), + interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1). + +Theorem extract_valid : + forall s : list direction, + valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). + +unfold valid1, co_valid1 in |- *; simple induction s; + [ split; + [ simpl in |- *; auto + | intros ep e p1; case p1; simpl in |- *; auto; intro p; + pattern (decidability p) in |- *; apply bool_ind2; + [ intro H; generalize (decidable_correct ep e p H); + unfold decidable in |- *; tauto + | simpl in |- *; auto ] ] + | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; + case p; auto; simpl in |- *; intros; + (apply H1; tauto) || + (apply H2; tauto) || + (pattern (decidability p0) in |- *; apply bool_ind2; + [ intro H3; generalize (decidable_correct ep e p0 H3); + unfold decidable in |- *; intro H4; apply H1; + tauto + | intro; tauto ]) ]. + +Qed. + +Fixpoint decompose_solve (s : e_step) (h : list proposition) {struct s} : + list (list proposition) := + match s with + | E_SPLIT i dl s1 s2 => + match extract_hyp_pos dl (nth_hyps i h) with + | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h) + | Tnot (Tand x y) => + if decidability x + then + decompose_solve s1 (Tnot x :: h) ++ + decompose_solve s2 (Tnot y :: h) + else h :: nil + | _ => h :: nil + end + | E_EXTRACT i dl s1 => + decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h) + | E_SOLVE t => execute_omega t h + end. + +Theorem decompose_solve_valid : + forall s : e_step, valid_list_goal (decompose_solve s). + +intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s; + simpl in |- *; intros; + [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); + [ case (extract_hyp_pos l (nth_hyps n lp)); simpl in |- *; auto; + [ intro p; case p; simpl in |- *; auto; intros p1 p2 H2; + pattern (decidability p1) in |- *; apply bool_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 ] + | 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 ] ] + | 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)), + interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp). + +Fixpoint reduce_lhyps (lp : list (list proposition)) : + list (list proposition) := + match lp with + | (FalseTerm :: nil) :: lp' => reduce_lhyps lp' + | x :: lp' => x :: reduce_lhyps lp' + | nil => nil (A:=list proposition) + end. + +Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. + +unfold valid_lhyps in |- *; intros ep e lp; elim lp; + [ simpl in |- *; auto + | intros a l HR; elim a; + [ simpl in |- *; tauto + | intros a1 l1; case l1; case a1; simpl in |- *; try tauto ] ]. +Qed. + +Theorem do_reduce_lhyps : + forall (envp : PropList) (env : list Z) (l : list (list proposition)), + 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; + apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; + assumption. +Qed. + +Definition concl_to_hyp (p : proposition) := + if decidability p then Tnot p else TrueTerm. + +Definition do_concl_to_hyp : + forall (envp : 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. + +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); + unfold decidable in |- *; simpl in |- *; tauto + | simpl in |- *; intros H1 H2; elim H2; trivial ] + | simpl in |- *; tauto ]. +Qed. + +Definition omega_tactic (t1 : e_step) (t2 : list h_step) + (c : proposition) (l : list proposition) := + 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), + interp_list_goal envp env (omega_tactic t1 t2 c l) -> + interp_goal_concl envp env c 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 diff --git a/contrib/romega/const_omega.ml b/contrib/romega/const_omega.ml new file mode 100644 index 00000000..3b2a7d31 --- /dev/null +++ b/contrib/romega/const_omega.ml @@ -0,0 +1,488 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + +let module_refl_name = "ReflOmegaCore" +let module_refl_path = ["Coq"; "romega"; module_refl_name] + +type result = + Kvar of string + | Kapp of string * Term.constr list + | Kimp of Term.constr * Term.constr + | Kufo;; + +let destructurate t = + let c, args = Term.decompose_app t in + let env = Global.env() in + match Term.kind_of_term c, args with + | Term.Const sp, args -> + Kapp (Names.string_of_id + (Nametab.id_of_global (Libnames.ConstRef sp)), + args) + | Term.Construct csp , args -> + Kapp (Names.string_of_id + (Nametab.id_of_global (Libnames.ConstructRef csp)), + args) + | Term.Ind isp, args -> + Kapp (Names.string_of_id + (Nametab.id_of_global (Libnames.IndRef isp)), + args) + | Term.Var id,[] -> Kvar(Names.string_of_id id) + | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) + | Term.Prod (Names.Name _,_,_),[] -> + Util.error "Omega: Not a quantifier-free goal" + | _ -> Kufo + +exception Destruct + +let dest_const_apply t = + let f,args = Term.decompose_app t in + let ref = + match Term.kind_of_term f with + | Term.Const sp -> Libnames.ConstRef sp + | Term.Construct csp -> Libnames.ConstructRef csp + | Term.Ind isp -> Libnames.IndRef isp + | _ -> raise Destruct + in Nametab.id_of_global ref, args + +let 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 + | _ -> 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";; + + +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")]] + @ [module_refl_path] + + +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_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_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_Zgt = lazy (constant "Zgt") +let coq_Zle = lazy (constant "Zle") +let coq_inject_nat = lazy (constant "inject_nat") + +(* Peano *) +let coq_le = lazy(constant "le") +let coq_gt = lazy(constant "gt") + +(* Integers *) +let coq_nat = lazy(constant "nat") +let coq_S = lazy(constant "S") +let coq_O = lazy(constant "O") +let coq_minus = lazy(constant "minus") + +(* Logic *) +let coq_eq = lazy(constant "eq") +let coq_refl_equal = lazy(constant "refl_equal") +let coq_and = lazy(constant "and") +let coq_not = lazy(constant "not") +let coq_or = lazy(constant "or") +let coq_true = lazy(constant "true") +let coq_false = lazy(constant "false") +let coq_ex = lazy(constant "ex") +let coq_I = lazy(constant "I") + +(* Lists *) +let coq_cons = lazy (constant "cons") +let coq_nil = lazy (constant "nil") + +let coq_pcons = lazy (constant "Pcons") +let coq_pnil = lazy (constant "Pnil") + +let coq_h_step = lazy (constant "h_step") +let coq_pair_step = lazy (constant "pair_step") +let coq_p_left = lazy (constant "P_LEFT") +let coq_p_right = lazy (constant "P_RIGHT") +let coq_p_invert = lazy (constant "P_INVERT") +let coq_p_step = lazy (constant "P_STEP") +let coq_p_nop = lazy (constant "P_NOP") + + +let coq_t_int = lazy (constant "Tint") +let coq_t_plus = lazy (constant "Tplus") +let coq_t_mult = lazy (constant "Tmult") +let coq_t_opp = lazy (constant "Topp") +let coq_t_minus = lazy (constant "Tminus") +let coq_t_var = lazy (constant "Tvar") + +let coq_p_eq = lazy (constant "EqTerm") +let coq_p_leq = lazy (constant "LeqTerm") +let coq_p_geq = lazy (constant "GeqTerm") +let coq_p_lt = lazy (constant "LtTerm") +let coq_p_gt = lazy (constant "GtTerm") +let coq_p_neq = lazy (constant "NeqTerm") +let coq_p_true = lazy (constant "TrueTerm") +let coq_p_false = lazy (constant "FalseTerm") +let coq_p_not = lazy (constant "Tnot") +let coq_p_or = lazy (constant "Tor") +let coq_p_and = lazy (constant "Tand") +let coq_p_imp = lazy (constant "Timp") +let coq_p_prop = lazy (constant "Tprop") + +let coq_proposition = lazy (constant "proposition") +let coq_interp_sequent = lazy (constant "interp_goal_concl") +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") + +(* Constructors for shuffle tactic *) +let coq_t_fusion = lazy (constant "t_fusion") +let coq_f_equal = lazy (constant "F_equal") +let coq_f_cancel = lazy (constant "F_cancel") +let coq_f_left = lazy (constant "F_left") +let coq_f_right = lazy (constant "F_right") + +(* Constructors for reordering tactics *) +let coq_step = lazy (constant "step") +let coq_c_do_both = lazy (constant "C_DO_BOTH") +let coq_c_do_left = lazy (constant "C_LEFT") +let coq_c_do_right = lazy (constant "C_RIGHT") +let coq_c_do_seq = lazy (constant "C_SEQ") +let coq_c_nop = lazy (constant "C_NOP") +let coq_c_opp_plus = lazy (constant "C_OPP_PLUS") +let coq_c_opp_opp = lazy (constant "C_OPP_OPP") +let coq_c_opp_mult_r = lazy (constant "C_OPP_MULT_R") +let coq_c_opp_one = lazy (constant "C_OPP_ONE") +let coq_c_reduce = lazy (constant "C_REDUCE") +let coq_c_mult_plus_distr = lazy (constant "C_MULT_PLUS_DISTR") +let coq_c_opp_left = lazy (constant "C_MULT_OPP_LEFT") +let coq_c_mult_assoc_r = lazy (constant "C_MULT_ASSOC_R") +let coq_c_plus_assoc_r = lazy (constant "C_PLUS_ASSOC_R") +let coq_c_plus_assoc_l = lazy (constant "C_PLUS_ASSOC_L") +let coq_c_plus_permute = lazy (constant "C_PLUS_PERMUTE") +let coq_c_plus_sym = lazy (constant "C_PLUS_SYM") +let coq_c_red0 = lazy (constant "C_RED0") +let coq_c_red1 = lazy (constant "C_RED1") +let coq_c_red2 = lazy (constant "C_RED2") +let coq_c_red3 = lazy (constant "C_RED3") +let coq_c_red4 = lazy (constant "C_RED4") +let coq_c_red5 = lazy (constant "C_RED5") +let coq_c_red6 = lazy (constant "C_RED6") +let coq_c_mult_opp_left = lazy (constant "C_MULT_OPP_LEFT") +let coq_c_mult_assoc_reduced = + lazy (constant "C_MULT_ASSOC_REDUCED") +let coq_c_minus = lazy (constant "C_MINUS") +let coq_c_mult_sym = lazy (constant "C_MULT_SYM") + +let coq_s_constant_not_nul = lazy (constant "O_CONSTANT_NOT_NUL") +let coq_s_constant_neg = lazy (constant "O_CONSTANT_NEG") +let coq_s_div_approx = lazy (constant "O_DIV_APPROX") +let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE") +let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE") +let coq_s_sum = lazy (constant "O_SUM") +let coq_s_state = lazy (constant "O_STATE") +let coq_s_contradiction = lazy (constant "O_CONTRADICTION") +let coq_s_merge_eq = lazy (constant "O_MERGE_EQ") +let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ") +let coq_s_constant_nul =lazy (constant "O_CONSTANT_NUL") +let coq_s_negate_contradict =lazy (constant "O_NEGATE_CONTRADICT") +let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV") + +(* construction for the [extract_hyp] tactic *) +let coq_direction = lazy (constant "direction") +let coq_d_left = lazy (constant "D_left") +let coq_d_right = lazy (constant "D_right") +let coq_d_mono = lazy (constant "D_mono") + +let coq_e_split = lazy (constant "E_SPLIT") +let coq_e_extract = lazy (constant "E_EXTRACT") +let coq_e_solve = lazy (constant "E_SOLVE") + +let coq_decompose_solve_valid = + lazy (constant "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} *) + + +let mk_var v = Term.mkVar (Names.id_of_string v) +let mk_plus t1 t2 = Term.mkApp (Lazy.force coq_Zplus,[| t1; t2 |]) +let mk_times t1 t2 = Term.mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) +let mk_minus t1 t2 = Term.mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) +let mk_eq t1 t2 = Term.mkApp (Lazy.force coq_eq, [| Lazy.force coq_Z; t1; t2 |]) +let mk_le t1 t2 = Term.mkApp (Lazy.force coq_Zle, [|t1; t2 |]) +let mk_gt t1 t2 = Term.mkApp (Lazy.force coq_Zgt, [|t1; t2 |]) +let mk_inv t = Term.mkApp (Lazy.force coq_Zopp, [|t |]) +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 |]) + + +let do_left t = + if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop + else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) + +let do_right t = + if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop + else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) + +let do_both t1 t2 = + if t1 = Lazy.force coq_c_nop then do_right t2 + else if t2 = Lazy.force coq_c_nop then do_left t1 + else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) + +let do_seq t1 t2 = + if t1 = Lazy.force coq_c_nop then t2 + else if t2 = Lazy.force coq_c_nop then t1 + else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) + +let rec do_list = function + | [] -> Lazy.force coq_c_nop + | [x] -> x + | (x::l) -> do_seq x (do_list l) + + +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 = 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) |]) + +let mk_Z = mk_integer + +let rec mk_nat = function + | 0 -> Lazy.force coq_O + | n -> Term.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |]) + +let mk_list typ l = + let rec loop = function + | [] -> + Term.mkApp (Lazy.force coq_nil, [|typ|]) + | (step :: l) -> + Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in + loop l + +let mk_plist l = + let rec loop = function + | [] -> + (Lazy.force coq_pnil) + | (step :: l) -> + Term.mkApp (Lazy.force coq_pcons, [| step; loop l |]) in + loop l + + +let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l + diff --git a/contrib/romega/g_romega.ml4 b/contrib/romega/g_romega.ml4 new file mode 100644 index 00000000..386f7f28 --- /dev/null +++ b/contrib/romega/g_romega.ml4 @@ -0,0 +1,15 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +open Refl_omega + +TACTIC EXTEND ROmega + [ "ROmega" ] -> [ total_reflexive_omega_tactic ] +END diff --git a/contrib/romega/omega2.ml b/contrib/romega/omega2.ml new file mode 100644 index 00000000..91aefc60 --- /dev/null +++ b/contrib/romega/omega2.ml @@ -0,0 +1,675 @@ +(************************************************************************) +(* 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 new file mode 100644 index 00000000..ef68c587 --- /dev/null +++ b/contrib/romega/refl_omega.ml @@ -0,0 +1,1307 @@ +(************************************************************************* + + PROJET RNRT Calife - 2001 + Author: Pierre Crégut - France Télécom R&D + Licence : LGPL version 2.1 + + *************************************************************************) + +open Const_omega + + +(* \section{Useful functions and flags} *) +(* Especially useful debugging functions *) +let debug = ref false + +let show_goal gl = + if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl + +let pp i = print_int i; print_newline (); flush stdout + +(* More readable than the prefix notation *) +let (>>) = Tacticals.tclTHEN + +(* [list_index t l = i] \eqv $nth l i = t \wedge \forall j < i nth l j != t$ *) + +let list_index t = + let rec loop i = function + | (u::l) -> if u = t then i else loop (i+1) l + | [] -> raise Not_found in + loop 0 + +(* [list_uniq l = filter_i (x i -> nth l (i-1) != x) l] *) +let list_uniq l = + let rec uniq = function + x :: ((y :: _) as l) when x = y -> uniq l + | x :: l -> x :: uniq l + | [] -> [] in + uniq (List.sort compare l) + +(* $\forall x. mem x (list\_union l1 l2) \eqv x \in \{l1\} \cup \{l2\}$ *) +let list_union l1 l2 = + let rec loop buf = function + x :: r -> if List.mem x l2 then loop buf r else loop (x :: buf) r + | [] -> buf in + loop l2 l1 + +(* $\forall x. + mem \;\; x \;\; (list\_intersect\;\; l1\;\;l2) \eqv x \in \{l1\} + \cap \{l2\}$ *) +let list_intersect l1 l2 = + let rec loop buf = function + x :: r -> if List.mem x l2 then loop (x::buf) r else loop buf r + | [] -> buf in + loop [] l1 + +(* cartesian product. Elements are lists and are concatenated. + $cartesian [x_1 ... x_n] [y_1 ... y_p] = [x_1 @ y_1, x_2 @ y_1 ... x_n @ y_1 , x_1 @ y_2 ... x_n @ y_p]$ *) + +let rec cartesien l1 l2 = + let rec loop = function + (x2 :: r2) -> List.map (fun x1 -> x1 @ x2) l1 @ loop r2 + | [] -> [] in + loop l2 + +(* remove element e from list l *) +let list_remove e l = + let rec loop = function + x :: l -> if x = e then loop l else x :: loop l + | [] -> [] in + loop l + +(* equivalent of the map function but no element is added when the function + raises an exception (and the computation silently continues) *) +let map_exc f = + let rec loop = function + (x::l) -> + begin match try Some (f x) with exc -> None with + Some v -> v :: loop l | None -> loop l + end + | [] -> [] in + loop + +let mkApp = Term.mkApp + +(* \section{Types} + \subsection{How to walk in a term} + To represent how to get to a proposition. Only choice points are + kept (branch to choose in a disjunction and identifier of the disjunctive + connector) *) +type direction = Left of int | Right of int + +(* Step to find a proposition (operators are at most binary). A list is + a path *) +type occ_step = O_left | O_right | O_mono +type occ_path = occ_step list + +(* chemin identifiant une proposition sous forme du nom de l'hypothèse et + d'une liste de pas à partir de la racine de l'hypothèse *) +type occurence = {o_hyp : Names.identifier; o_path : occ_path} + +(* \subsection{refiable formulas} *) +type oformula = + (* integer *) + | Oint of int + (* recognized binary and unary operations *) + | Oplus of oformula * oformula + | Omult of oformula * oformula + | Ominus of oformula * oformula + | Oopp of oformula + (* an atome in the environment *) + | Oatom of int + (* weird expression that cannot be translated *) + | Oufo of oformula + +(* Operators for comparison recognized by Omega *) +type comparaison = Eq | Leq | Geq | Gt | Lt | Neq + +(* Type des prédicats réifiés (fragment de calcul propositionnel. Les + * quantifications sont externes au langage) *) +type oproposition = + Pequa of Term.constr * oequation + | Ptrue + | Pfalse + | Pnot of oproposition + | Por of int * oproposition * oproposition + | Pand of int * oproposition * oproposition + | Pimp of int * oproposition * oproposition + | Pprop of Term.constr + +(* Les équations ou proposiitions atomiques utiles du calcul *) +and oequation = { + e_comp: comparaison; (* comparaison *) + e_left: oformula; (* formule brute gauche *) + e_right: oformula; (* formule brute droite *) + e_trace: Term.constr; (* tactique de normalisation *) + e_origin: occurence; (* l'hypothèse dont vient le terme *) + e_negated: bool; (* vrai si apparait en position nié + après normalisation *) + e_depends: direction list; (* liste des points de disjonction dont + dépend l'accès à l'équation avec la + direction (branche) pour y accéder *) + e_omega: Omega2.afine (* la fonction normalisée *) + } + +(* \subsection{Proof context} + This environment codes + \begin{itemize} + \item the terms and propositions that are given as + parameters of the reified proof (and are represented as variables in the + reified goals) + \item translation functions linking the decision procedure and the Coq proof + \end{itemize} *) + +type environment = { + (* La liste des termes non reifies constituant l'environnement global *) + mutable terms : Term.constr list; + (* La meme chose pour les propositions *) + mutable props : Term.constr list; + (* Les variables introduites par omega *) + mutable om_vars : (oformula * int) list; + (* Traduction des indices utilisés ici en les indices finaux utilisés par + * la tactique Omega après dénombrement des variables utiles *) + real_indices : (int,int) Hashtbl.t; + mutable cnt_connectors : int; + equations : (int,oequation) Hashtbl.t; + constructors : (int, occurence) Hashtbl.t +} + +(* \subsection{Solution tree} + Définition d'une solution trouvée par Omega sous la forme d'un identifiant, + d'un ensemble d'équation dont dépend la solution et d'une trace *) +type solution = { + s_index : int; + s_equa_deps : int list; + s_trace : Omega2.action list } + +(* Arbre de solution résolvant complètement un ensemble de systèmes *) +type solution_tree = + Leaf of solution + (* un noeud interne représente un point de branchement correspondant à + l'élimination d'un connecteur générant plusieurs buts + (typ. disjonction). Le premier argument + est l'identifiant du connecteur *) + | Tree of int * solution_tree * solution_tree + +(* Représentation de l'environnement extrait du but initial sous forme de + chemins pour extraire des equations ou d'hypothèses *) + +type context_content = + CCHyp of occurence + | CCEqua of int + +(* \section{Specific utility functions to handle base types} *) +(* Nom arbitraire de l'hypothèse codant la négation du but final *) +let id_concl = Names.id_of_string "__goal__" + +(* Initialisation de l'environnement de réification de la tactique *) +let new_environment () = { + terms = []; props = []; om_vars = []; cnt_connectors = 0; + real_indices = Hashtbl.create 7; + equations = Hashtbl.create 7; + constructors = Hashtbl.create 7; +} + +(* Génération d'un nom d'équation *) +let new_eq_id env = + env.cnt_connectors <- env.cnt_connectors + 1; env.cnt_connectors + +(* Calcul de la branche complémentaire *) +let barre = function Left x -> Right x | Right x -> Left x + +(* Identifiant associé à une branche *) +let indice = function Left x | Right x -> x + +(* Affichage de l'environnement de réification (termes et propositions) *) +let print_env_reification env = + let rec loop c i = function + [] -> Printf.printf "===============================\n\n" + | t :: l -> + Printf.printf "(%c%02d) : " c i; + Pp.ppnl (Printer.prterm 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 + + +(* \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 +(* Affichage des variables d'un système *) +let display_omega_id i = Printf.sprintf "O%d" i +(* Recherche la variable codant un terme pour Omega et crée la variable dans + l'environnement si il n'existe pas. Cas ou la variable dans Omega représente + le terme d'un monome (le plus souvent un atome) *) + +let intern_omega env t = + begin try List.assoc t env.om_vars + with Not_found -> + let v = new_omega_id () 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 + réifié introduit de force *) +let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars + +(* Récupère le terme associé à une variable *) +let unintern_omega env id = + let rec loop = function + [] -> failwith "unintern" + | ((t,j)::l) -> if id = j then t else loop l in + loop env.om_vars + +(* \subsection{Gestion des environnements de variable pour la réflexion} + Gestion des environnements de traduction entre termes des constructions + non réifiés et variables des termes reifies. Attention il s'agit de + l'environnement initial contenant tout. Il faudra le réduire après + calcul des variables utiles. *) + +let add_reified_atom t env = + try list_index t env.terms + with Not_found -> + let i = List.length env.terms in + env.terms <- env.terms @ [t]; i + +let get_reified_atom env = + try List.nth env.terms with _ -> failwith "get_reified_atom" + +(* \subsection{Gestion de l'environnement de proposition pour Omega} *) +(* ajout d'une proposition *) +let add_prop env t = + try list_index t env.props + with Not_found -> + let i = List.length env.props in env.props <- env.props @ [t]; i + +(* accès a une proposition *) +let get_prop v env = try List.nth v env with _ -> failwith "get_prop" + +(* \subsection{Gestion du nommage des équations} *) +(* Ajout d'une equation dans l'environnement de reification *) +let add_equation env e = + let id = e.e_omega.Omega2.id in + try let _ = Hashtbl.find env.equations id in () + with Not_found -> Hashtbl.add env.equations id e + +(* accès a une equation *) +let get_equation env id = + try Hashtbl.find env.equations id + with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e + +(* Affichage des termes réifiés *) +let rec oprint ch = function + | Oint n -> Printf.fprintf ch "%d" n + | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 + | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 + | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 + | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 + | Oatom n -> Printf.fprintf ch "V%02d" n + | Oufo x -> Printf.fprintf ch "?" + +let rec pprint ch = function + Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> + let connector = + match comp with + Eq -> "=" | Leq -> "=<" | Geq -> ">=" + | Gt -> ">" | Lt -> "<" | Neq -> "!=" in + Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 + | Ptrue -> Printf.fprintf ch "TT" + | Pfalse -> Printf.fprintf ch "FF" + | Pnot t -> Printf.fprintf ch "not(%a)" pprint t + | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 + | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 + | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 + | Pprop c -> Printf.fprintf ch "Prop" + +let rec weight env = function + | Oint _ -> -1 + | Oopp c -> weight env c + | Omult(c,_) -> weight env c + | Oplus _ -> failwith "weight" + | Ominus _ -> failwith "weight minus" + | Oufo _ -> -1 + | Oatom _ as c -> (intern_omega env c) + +(* \section{Passage entre oformules et représentation interne de Omega} *) + +(* \subsection{Oformula vers Omega} *) + +let omega_of_oformula env kind = + let rec loop accu = function + | Oplus(Omult(v,Oint n),r) -> + loop ({Omega2.v=intern_omega env v; Omega2.c=n} :: accu) r + | Oint n -> + let id = new_omega_id () in + (*i tag_equation name id; i*) + {Omega2.kind = kind; Omega2.body = List.rev accu; + Omega2.constant = n; Omega2.id = id} + | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in + loop [] + +(* \subsection{Omega vers Oformula} *) + +let reified_of_atom env i = + try Hashtbl.find env.real_indices i + with Not_found -> + Printf.printf "Atome %d non trouvé\n" i; + Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; + raise Not_found + +let rec oformula_of_omega env af = + let rec loop = function + | ({Omega2.v=v; Omega2.c=n}::r) -> + Oplus(Omult(unintern_omega env v,Oint n),loop r) + | [] -> Oint af.Omega2.constant in + loop af.Omega2.body + +let app f v = mkApp(Lazy.force f,v) + +(* \subsection{Oformula vers COQ reel} *) + +let rec coq_of_formula env t = + let rec loop = function + | Oplus (t1,t2) -> app coq_Zplus [| loop t1; loop t2 |] + | Oopp t -> app coq_Zopp [| loop t |] + | Omult(t1,t2) -> app coq_Zmult [| loop t1; loop t2 |] + | Oint v -> mk_Z v + | Oufo t -> loop t + | Oatom var -> + (* attention ne traite pas les nouvelles variables si on ne les + * met pas dans env.term *) + get_reified_atom env var + | Ominus(t1,t2) -> app coq_Zminus [| loop t1; loop t2 |] in + loop t + +(* \subsection{Oformula vers COQ reifié} *) + +let rec reified_of_formula env = function + | Oplus (t1,t2) -> + app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |] + | Oopp t -> + app coq_t_opp [| reified_of_formula env t |] + | Omult(t1,t2) -> + app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |] + | Oint v -> app coq_t_int [| mk_Z v |] + | Oufo t -> reified_of_formula env t + | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |] + | Ominus(t1,t2) -> + app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] + +let reified_of_formula env f = + begin try reified_of_formula env f with e -> oprint stderr f; raise e end + +let rec reified_of_proposition env = function + Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> + app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> + app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> + app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> + app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> + app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |] + | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> + app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |] + | Ptrue -> Lazy.force coq_p_true + | Pfalse -> Lazy.force coq_p_false + | Pnot t -> + app coq_p_not [| reified_of_proposition env t |] + | Por (_,t1,t2) -> + app coq_p_or + [| reified_of_proposition env t1; reified_of_proposition env t2 |] + | Pand(_,t1,t2) -> + app coq_p_and + [| reified_of_proposition env t1; reified_of_proposition env t2 |] + | Pimp(_,t1,t2) -> + app coq_p_imp + [| reified_of_proposition env t1; reified_of_proposition env t2 |] + | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] + +let reified_of_proposition env f = + begin try reified_of_proposition env f + with e -> pprint stderr f; raise e end + +(* \subsection{Omega vers COQ réifié} *) + +let reified_of_omega env body constant = + let coeff_constant = + app coq_t_int [| mk_Z constant |] in + let mk_coeff {Omega2.c=c; Omega2.v=v} t = + let coef = + app coq_t_mult + [| reified_of_formula env (unintern_omega env v); + app coq_t_int [| mk_Z c |] |] in + app coq_t_plus [|coef; t |] in + List.fold_right mk_coeff body coeff_constant + +let reified_of_omega env body c = + begin try + reified_of_omega env body c + with e -> + Omega2.display_eq display_omega_id (body,c); raise e + end + +(* \section{Opérations sur les équations} +Ces fonctions préparent les traces utilisées par la tactique réfléchie +pour faire des opérations de normalisation sur les équations. *) + +(* \subsection{Extractions des variables d'une équation} *) +(* Extraction des variables d'une équation *) + +let rec vars_of_formula = function + | Oint _ -> [] + | Oplus (e1,e2) -> (vars_of_formula e1) @ (vars_of_formula e2) + | Omult (e1,e2) -> (vars_of_formula e1) @ (vars_of_formula e2) + | Ominus (e1,e2) -> (vars_of_formula e1) @ (vars_of_formula e2) + | Oopp e -> (vars_of_formula e) + | Oatom i -> [i] + | Oufo _ -> [] + +let vars_of_equations l = + let rec loop = function + e :: l -> vars_of_formula e.e_left @ vars_of_formula e.e_right @ loop l + | [] -> [] in + list_uniq (List.sort compare (loop l)) + +(* \subsection{Multiplication par un scalaire} *) + +let rec scalar n = function + Oplus(t1,t2) -> + let tac1,t1' = scalar n t1 and + tac2,t2' = scalar n t2 in + do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], + Oplus(t1',t2') + | Oopp t -> + do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(-n)) + | Omult(t1,Oint x) -> + do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) + | Omult(t1,t2) -> + Util.error "Omega: Can't solve a goal with non-linear products" + | (Oatom _ as t) -> do_list [], Omult(t,Oint n) + | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) + | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n)) + | Ominus _ -> failwith "scalar minus" + +(* \subsection{Propagation de l'inversion} *) + +let rec negate = function + Oplus(t1,t2) -> + let tac1,t1' = negate t1 and + tac2,t2' = negate t2 in + do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)], + Oplus(t1',t2') + | Oopp t -> + do_list [Lazy.force coq_c_opp_opp], t + | Omult(t1,Oint x) -> + do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (-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) + | Oufo c -> do_list [], Oufo (Oopp c) + | Ominus _ -> failwith "negate minus" + +let rec norm l = (List.length l) + +(* \subsection{Mélange (fusion) de deux équations} *) +(* \subsubsection{Version avec coefficients} *) +let rec shuffle_path k1 e1 k2 e2 = + let rec loop = function + (({Omega2.c=c1;Omega2.v=v1}::l1) as l1'), + (({Omega2.c=c2;Omega2.v=v2}::l2) as l2') -> + if v1 = v2 then + if k1*c1 + k2 * c2 = 0 then ( + Lazy.force coq_f_cancel :: loop (l1,l2)) + else ( + Lazy.force coq_f_equal :: loop (l1,l2) ) + else if v1 > v2 then ( + Lazy.force coq_f_left :: loop(l1,l2')) + else ( + Lazy.force coq_f_right :: loop(l1',l2)) + | ({Omega2.c=c1;Omega2.v=v1}::l1), [] -> + Lazy.force coq_f_left :: loop(l1,[]) + | [],({Omega2.c=c2;Omega2.v=v2}::l2) -> + Lazy.force coq_f_right :: loop([],l2) + | [],[] -> flush stdout; [] in + mk_shuffle_list (loop (e1,e2)) + +(* \subsubsection{Version sans coefficients} *) +let rec shuffle env (t1,t2) = + match t1,t2 with + Oplus(l1,r1), Oplus(l2,r2) -> + if weight env l1 > weight env l2 then + let l_action,t' = shuffle env (r1,t2) in + do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t') + else + let l_action,t' = shuffle env (t1,r2) in + do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') + | Oplus(l1,r1), t2 -> + if weight env l1 > weight env t2 then + let (l_action,t') = shuffle env (r1,t2) in + do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t') + else do_list [Lazy.force coq_c_plus_sym], Oplus(t2,t1) + | t1,Oplus(l2,r2) -> + if weight env l2 > weight env t1 then + let (l_action,t') = shuffle env (t1,r2) in + do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') + else do_list [],Oplus(t1,t2) + | Oint t1,Oint t2 -> + do_list [Lazy.force coq_c_reduce], Oint(t1+t2) + | t1,t2 -> + if weight env t1 < weight env t2 then + do_list [Lazy.force coq_c_plus_sym], Oplus(t2,t1) + else do_list [],Oplus(t1,t2) + +(* \subsection{Fusion avec réduction} *) + +let shrink_pair f1 f2 = + begin match f1,f2 with + Oatom v,Oatom _ -> + Lazy.force coq_c_red1, Omult(Oatom v,Oint 2) + | Oatom v, Omult(_,c2) -> + Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint 1)) + | Omult (v1,c1),Oatom v -> + Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint 1)) + | Omult (Oatom v,c1),Omult (v2,c2) -> + Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) + | t1,t2 -> + oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); + flush Pervasives.stdout; Util.error "shrink.1" + end + +(* \subsection{Calcul d'une sous formule constante} *) + +let reduce_factor = function + Oatom v -> + let r = Omult(Oatom v,Oint 1) in + [Lazy.force coq_c_red0],r + | Omult(Oatom v,Oint n) as f -> [],f + | Omult(Oatom v,c) -> + let rec compute = function + Oint n -> n + | Oplus(t1,t2) -> compute t1 + compute t2 + | _ -> Util.error "condense.1" in + [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) + | t -> Util.error "reduce_factor.1" + +(* \subsection{Réordonancement} *) + +let rec condense env = function + Oplus(f1,(Oplus(f2,r) as t)) -> + if weight env f1 = weight env f2 then begin + let shrink_tac,t = shrink_pair f1 f2 in + let assoc_tac = Lazy.force coq_c_plus_assoc_l in + let tac_list,t' = condense env (Oplus(t,r)) in + assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t' + end else begin + let tac,f = reduce_factor f1 in + let tac',t' = condense env t in + [do_both (do_list tac) (do_list tac')], Oplus(f,t') + end + | (Oplus(f1,Oint n) as t) -> + let tac,f1' = reduce_factor f1 in + [do_left (do_list tac)],Oplus(f1',Oint n) + | Oplus(f1,f2) -> + if weight env f1 = weight env f2 then begin + let tac_shrink,t = shrink_pair f1 f2 in + let tac,t' = condense env t in + tac_shrink :: tac,t' + end else begin + let tac,f = reduce_factor f1 in + let tac',t' = condense env f2 in + [do_both (do_list tac) (do_list tac')],Oplus(f,t') + end + | (Oint _ as t)-> [],t + | t -> + let tac,t' = reduce_factor t in + let final = Oplus(t',Oint 0) 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) -> + let tac',t = clear_zero r in + Lazy.force coq_c_red5 :: tac',t + | Oplus(f,r) -> + let tac,t = clear_zero r in + (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t) + | t -> [],t;; + +(* \subsection{Transformation des hypothèses} *) + +let rec reduce env = function + Oplus(t1,t2) -> + let t1', trace1 = reduce env t1 in + let t2', trace2 = reduce env t2 in + let trace3,t' = shuffle env (t1',t2') in + t', do_list [do_both trace1 trace2; trace3] + | Ominus(t1,t2) -> + let t,trace = reduce env (Oplus(t1, Oopp t2)) in + t, do_list [Lazy.force coq_c_minus; trace] + | Omult(t1,t2) as t -> + let t1', trace1 = reduce env t1 in + let t2', trace2 = reduce env t2 in + begin match t1',t2' with + | (_, Oint n) -> + let tac,t' = scalar n t1' in + t', do_list [do_both trace1 trace2; tac] + | (Oint n,_) -> + let tac,t' = scalar n t2' in + t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_sym; tac] + | _ -> Oufo t, Lazy.force coq_c_nop + end + | Oopp t -> + let t',trace = reduce env t in + let trace',t'' = negate t' in + t'', do_list [do_left trace; trace'] + | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop + +let normalize_linear_term env t = + let t1,trace1 = reduce env t in + let trace2,t2 = condense env t1 in + let trace3,t3 = clear_zero t2 in + do_list [trace1; do_list trace2; do_list trace3], t3 + +(* Cette fonction reproduit très exactement le comportement de [p_invert] *) +let negate_oper = function + Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq + +let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = + let mk_step t1 t2 f kind = + let t = f t1 t2 in + let trace, oterm = normalize_linear_term env t in + let equa = omega_of_oformula env kind oterm in + { e_comp = oper; e_left = t1; e_right = t2; + e_negated = negated; e_depends = depends; + e_origin = { o_hyp = origin; o_path = List.rev path }; + e_trace = trace; e_omega = equa } in + try match (if negated then (negate_oper oper) else oper) with + | Eq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) 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 + | Lt -> + mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint (-1)),Oopp o1)) + Omega2.INEQ + | Gt -> + mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint (-1)),Oopp o2)) + Omega2.INEQ + with e when Logic.catchable_exception e -> raise e + +(* \section{Compilation des hypothèses} *) + +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(("Zpos"|"Zneg"|"Z0"),_) -> + begin try Oint(recognize_number t) + with _ -> Oatom (add_reified_atom t env) end + | _ -> + Oatom (add_reified_atom t env) + with e when Logic.catchable_exception e -> + Oatom (add_reified_atom t env) + +and binop env c t1 t2 = + let t1' = oformula_of_constr env t1 in + let t2' = oformula_of_constr env t2 in + c t1' t2' + +and binprop env (neg2,depends,origin,path) + add_to_depends neg1 gl c t1 t2 = + let i = new_eq_id env in + let depends1 = if add_to_depends then Left i::depends else depends in + let depends2 = if add_to_depends then Right i::depends else depends in + if add_to_depends then + Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; + let t1' = + oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in + let t2' = + oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in + (* On numérote le connecteur dans l'environnement. *) + c i t1' t2' + +and mk_equation env ctxt c connector t1 t2 = + let t1' = oformula_of_constr env t1 in + let t2' = oformula_of_constr env t2 in + (* On ajoute l'equation dans l'environnement. *) + let omega = normalize_equation env ctxt (connector,t1',t2') in + add_equation env omega; + Pequa (c,omega) + +and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = + try match destructurate c with + | Kapp("eq",[typ;t1;t2]) + when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> + mk_equation env ctxt c Eq t1 t2 + | Kapp("Zne",[t1;t2]) -> + mk_equation env ctxt c Neq t1 t2 + | Kapp("Zle",[t1;t2]) -> + mk_equation env ctxt c Leq t1 t2 + | Kapp("Zlt",[t1;t2]) -> + mk_equation env ctxt c Lt t1 t2 + | Kapp("Zge",[t1;t2]) -> + mk_equation env ctxt c Geq t1 t2 + | Kapp("Zgt",[t1;t2]) -> + mk_equation env ctxt c Gt t1 t2 + | Kapp("True",[]) -> Ptrue + | Kapp("False",[]) -> Pfalse + | Kapp("not",[t]) -> + let t' = + oproposition_of_constr + env (not negated, depends, origin,(O_mono::path)) gl t in + Pnot t' + | Kapp("or",[t1;t2]) -> + binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 + | Kapp("and",[t1;t2]) -> + binprop env ctxt negated negated gl + (fun i x y -> Pand(i,x,y)) t1 t2 + | Kimp(t1,t2) -> + binprop env ctxt (not negated) (not negated) gl + (fun i x y -> Pimp(i,x,y)) t1 t2 + | _ -> Pprop c + with e when Logic.catchable_exception e -> Pprop c + +(* Destructuration des hypothèses et de la conclusion *) + +let reify_gl env gl = + let concl = Tacmach.pf_concl gl in + let t_concl = + Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in + if !debug then begin + Printf.printf "CONCL: "; pprint stdout t_concl; Printf.printf "\n" + end; + let rec loop = function + (i,t) :: lhyps -> + let t' = oproposition_of_constr env (false,[],i,[]) gl t in + if !debug then begin + Printf.printf "%s: " (Names.string_of_id i); + pprint stdout t'; + Printf.printf "\n" + end; + (i,t') :: loop lhyps + | [] -> + if !debug then print_env_reification env; + [] in + let t_lhyps = loop (Tacmach.pf_hyps_types gl) in + (id_concl,t_concl) :: t_lhyps + +let rec destructurate_pos_hyp orig list_equations list_depends = function + | Pequa (_,e) -> [e :: list_equations] + | Ptrue | Pfalse | Pprop _ -> [list_equations] + | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t + | Por (i,t1,t2) -> + let s1 = + destructurate_pos_hyp orig list_equations (i::list_depends) t1 in + let s2 = + destructurate_pos_hyp orig list_equations (i::list_depends) t2 in + s1 @ s2 + | Pand(i,t1,t2) -> + let list_s1 = + destructurate_pos_hyp orig list_equations (list_depends) t1 in + let rec loop = function + le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll + | [] -> [] in + loop list_s1 + | Pimp(i,t1,t2) -> + let s1 = + destructurate_neg_hyp orig list_equations (i::list_depends) t1 in + let s2 = + destructurate_pos_hyp orig list_equations (i::list_depends) t2 in + s1 @ s2 + +and destructurate_neg_hyp orig list_equations list_depends = function + | Pequa (_,e) -> [e :: list_equations] + | Ptrue | Pfalse | Pprop _ -> [list_equations] + | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t + | Pand (i,t1,t2) -> + let s1 = + destructurate_neg_hyp orig list_equations (i::list_depends) t1 in + let s2 = + destructurate_neg_hyp orig list_equations (i::list_depends) t2 in + s1 @ s2 + | Por(_,t1,t2) -> + let list_s1 = + destructurate_neg_hyp orig list_equations list_depends t1 in + let rec loop = function + le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll + | [] -> [] in + loop list_s1 + | Pimp(_,t1,t2) -> + let list_s1 = + destructurate_pos_hyp orig list_equations list_depends t1 in + let rec loop = function + le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll + | [] -> [] in + loop list_s1 + +let destructurate_hyps syst = + let rec loop = function + (i,t) :: l -> + let l_syst1 = destructurate_pos_hyp i [] [] t in + let l_syst2 = loop l in + cartesien l_syst1 l_syst2 + | [] -> [[]] in + loop syst + +(* \subsection{Affichage d'un système d'équation} *) + +(* Affichage des dépendances de système *) +let display_depend = function + Left i -> Printf.printf " L%d" i + | Right i -> Printf.printf " R%d" i + +let display_systems syst_list = + let display_omega om_e = + Printf.printf "%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 + + let display_equation oformula_eq = + pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline (); + display_omega oformula_eq.e_omega; + Printf.printf " Depends on:"; + List.iter display_depend oformula_eq.e_depends; + Printf.printf "\n Path: %s" + (String.concat "" + (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") + oformula_eq.e_origin.o_path)); + Printf.printf "\n Origin: %s -- Negated : %s\n" + (Names.string_of_id oformula_eq.e_origin.o_hyp) + (if oformula_eq.e_negated then "yes" else "false") in + + let display_system syst = + Printf.printf "=SYSTEME==================================\n"; + List.iter display_equation syst in + List.iter display_system syst_list + +(* Extraction des prédicats utilisées dans une trace. Permet ensuite le + calcul des hypothèses *) + +let rec hyps_used_in_trace = function + | act :: l -> + begin match act with + | Omega2.HYP e -> e.Omega2.id :: hyps_used_in_trace l + | Omega2.SPLIT_INEQ (_,(_,act1),(_,act2)) -> + hyps_used_in_trace act1 @ hyps_used_in_trace act2 + | _ -> hyps_used_in_trace l + end + | [] -> [] + +(* Extraction des variables déclarées dans une équation. Permet ensuite + de les déclarer dans l'environnement de la procédure réflexive et + éviter les créations de variable au vol *) + +let rec variable_stated_in_trace = function + | act :: l -> + begin match act with + | Omega2.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)) -> + variable_stated_in_trace act1 @ variable_stated_in_trace act2 + | _ -> variable_stated_in_trace l + end + | [] -> [] +;; + +let add_stated_equations env tree = + let rec loop = function + Tree(_,t1,t2) -> + list_union (loop t1) (loop t2) + | Leaf s -> variable_stated_in_trace s.s_trace in + (* 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 + 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 + (* Notez que si l'ordre de création des variables n'est pas respecté, + * ca va planter *) + let coq_v = coq_of_formula env v_def in + let v = add_reified_atom coq_v env in + (* Le terme qu'il va falloir introduire *) + let term_to_generalize = app coq_refl_equal [|Lazy.force coq_Z; coq_v|] in + (* sa représentation sous forme d'équation mais non réifié car on n'a pas + * l'environnement pour le faire correctement *) + let term_to_reify = (v_def,Oatom v) in + (* enregistre le lien entre la variable omega et la variable Coq *) + intern_omega_force env (Oatom v) st.Omega2.st_var; + (v, term_to_generalize,term_to_reify,st.Omega2.st_def.Omega2.id) in + List.map add_env stated_equations + +(* Calcule la liste des éclatements à réaliser sur les hypothèses + nécessaires pour extraire une liste d'équations donnée *) + +let rec get_eclatement env = function + i :: r -> + let l = try (get_equation env i).e_depends with Not_found -> [] in + list_union l (get_eclatement env r) + | [] -> [] + +let select_smaller l = + let comp (_,x) (_,y) = List.length x - List.length y in + try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" + +let filter_compatible_systems required systems = + let rec select = function + (x::l) -> + if List.mem x required then select l + else if List.mem (barre x) required then raise Exit + else x :: select l + | [] -> [] in + map_exc (function (sol,splits) -> (sol,select splits)) systems + +let rec equas_of_solution_tree = function + Tree(_,t1,t2) -> + list_union (equas_of_solution_tree t1) (equas_of_solution_tree t2) + | Leaf s -> s.s_equa_deps + + +let really_useful_prop l_equa c = + let rec real_of = function + Pequa(t,_) -> t + | Ptrue -> app coq_true [||] + | Pfalse -> app coq_false [||] + | Pnot t1 -> app coq_not [|real_of t1|] + | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|] + | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|] + (* Attention : implications sur le lifting des variables à comprendre ! *) + | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2) + | Pprop t -> t in + let rec loop c = + match c with + Pequa(_,e) -> + if List.mem e.e_omega.Omega2.id l_equa then Some c else None + | Ptrue -> None + | Pfalse -> None + | Pnot t1 -> + begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end + | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 + | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 + | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 + | Pprop t -> None + and binop f t1 t2 = + begin match loop t1, loop t2 with + None, None -> None + | Some t1',Some t2' -> Some (f(t1',t2')) + | Some t1',None -> Some (f(t1',Pprop (real_of t2))) + | None,Some t2' -> Some (f(Pprop (real_of t1),t2')) + end in + match loop c with + None -> Pprop (real_of c) + | Some t -> t + +let rec display_solution_tree ch = function + Leaf t -> + output_string ch + (Printf.sprintf "%d[%s]" + t.s_index + (String.concat " " (List.map string_of_int t.s_equa_deps))) + | Tree(i,t1,t2) -> + Printf.fprintf ch "S%d(%a,%a)" i + display_solution_tree t1 display_solution_tree t2 + +let rec solve_with_constraints all_solutions path = + let rec build_tree sol buf = function + [] -> Leaf sol + | (Left i :: remainder) -> + Tree(i, + build_tree sol (Left i :: buf) remainder, + solve_with_constraints all_solutions (List.rev(Right i :: buf))) + | (Right i :: remainder) -> + Tree(i, + solve_with_constraints all_solutions (List.rev (Left i :: buf)), + build_tree sol (Right i :: buf) remainder) in + let weighted = filter_compatible_systems path all_solutions in + let (winner_sol,winner_deps) = + try select_smaller weighted + with e -> + Printf.printf "%d - %d\n" + (List.length weighted) (List.length all_solutions); + List.iter display_depend path; raise e in + build_tree winner_sol (List.rev path) winner_deps + +let find_path {o_hyp=id;o_path=p} env = + let rec loop_path = function + ([],l) -> Some l + | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2) + | _ -> None in + let rec loop_id i = function + CCHyp{o_hyp=id';o_path=p'} :: l when id = id' -> + begin match loop_path (p',p) with + Some r -> i,r + | None -> loop_id (i+1) l + end + | _ :: l -> loop_id (i+1) l + | [] -> failwith "find_path" in + loop_id 0 env + +let mk_direction_list l = + let trans = function + O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in + mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l) + + +(* \section{Rejouer l'historique} *) + +let get_hyp env_hyp i = + try list_index (CCEqua i) env_hyp + with Not_found -> failwith (Printf.sprintf "get_hyp %d" i) + +let replay_history env env_hyp = + let rec loop env_hyp t = + match t with + | Omega2.CONTRADICTION (e1,e2) :: l -> + let trace = mk_nat (List.length e1.Omega2.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 -> + 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 + 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 -> + 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 + 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 + mkApp (Lazy.force coq_s_merge_eq, + [| mk_nat (List.length e1.Omega2.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 + 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 -> + mkApp (Lazy.force coq_s_constant_not_nul, + [| mk_nat (get_hyp env_hyp e) |]) + | Omega2.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 + let v = unintern_omega env sigma in + let o_def = oformula_of_omega env def in + let o_orig = oformula_of_omega env orig in + let body = + Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in + let trace,_ = normalize_linear_term env body in + mkApp (Lazy.force coq_s_state, + [| 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 -> + mkApp (Lazy.force coq_s_constant_nul, + [| mk_nat (get_hyp env_hyp e) |]) + | Omega2.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 + 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 -> + loop env_hyp l + | (Omega2.WEAKEN _ ) :: l -> failwith "not_treated" + | [] -> failwith "no contradiction" + in loop env_hyp + +let rec decompose_tree env ctxt = function + Tree(i,left,right) -> + let org = + try Hashtbl.find env.constructors i + with Not_found -> + failwith (Printf.sprintf "Cannot find constructor %d" i) in + let (index,path) = find_path org ctxt in + let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in + let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in + app coq_e_split + [| mk_nat index; + mk_direction_list path; + decompose_tree env (left_hyp::ctxt) left; + decompose_tree env (right_hyp::ctxt) right |] + | Leaf s -> + decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps +and decompose_tree_hyps trace env ctxt = function + [] -> app coq_e_solve [| replay_history env ctxt trace |] + | (i::l) -> + let equation = + try Hashtbl.find env.equations i + with Not_found -> + failwith (Printf.sprintf "Cannot find equation %d" i) in + let (index,path) = find_path equation.e_origin ctxt in + let full_path = if equation.e_negated then path @ [O_mono] else path in + let cont = + decompose_tree_hyps trace env + (CCEqua equation.e_omega.Omega2.id :: ctxt) l in + app coq_e_extract [|mk_nat index; + mk_direction_list full_path; + cont |] + +(* \section{La fonction principale} *) + (* Cette fonction construit la +trace pour la procédure de décision réflexive. A partir des résultats +de l'extraction des systèmes, elle lance la résolution par Omega, puis +l'extraction d'un ensemble minimal de solutions permettant la +résolution globale du système et enfin construit la trace qui permet +de faire rejouer cette solution par la tactique réflexive. *) + +let resolution env full_reified_goal systems_list = + let num = ref 0 in + let solve_system list_eq = + let index = !num in + let system = List.map (fun eq -> eq.e_omega) list_eq in + let trace = + Omega2.simplify_strong + ((fun () -> new_eq_id env),new_omega_id,display_omega_id) + 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; + print_string "\n Depend :"; + List.iter (fun i -> Printf.printf " %d" i) vars; + print_string "\n Split points :"; + List.iter display_depend splits; + Printf.printf "\n------------------------------------\n" + end; + incr num; + {s_index = index; s_trace = trace; s_equa_deps = vars}, splits in + if !debug then Printf.printf "\n====================================\n"; + let all_solutions = List.map solve_system systems_list in + let solution_tree = solve_with_constraints all_solutions [] in + if !debug then begin + display_solution_tree stdout solution_tree; + print_newline() + end; + (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *) + let useful_equa_id = list_uniq (equas_of_solution_tree solution_tree) in + (* recupere explicitement ces equations *) + let equations = List.map (get_equation env) useful_equa_id in + let l_hyps' = list_uniq (List.map (fun e -> e.e_origin.o_hyp) equations) in + let l_hyps = id_concl :: list_remove id_concl l_hyps' in + let useful_hyps = + List.map (fun id -> List.assoc id full_reified_goal) l_hyps in + let useful_vars = vars_of_equations equations in + (* variables a introduire *) + let to_introduce = add_stated_equations env solution_tree in + let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in + let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in + let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in + (* L'environnement de base se construit en deux morceaux : + - les variables des équations utiles + - les nouvelles variables declarées durant les preuves *) + let all_vars_env = useful_vars @ stated_vars in + let basic_env = + let rec loop i = function + var :: l -> + let t = get_reified_atom env var in + Hashtbl.add env.real_indices var i; t :: loop (i+1) l + | [] -> [] in + loop 0 all_vars_env in + let env_terms_reified = mk_list (Lazy.force coq_Z) basic_env in + (* On peut maintenant généraliser le but : env est a jour *) + let l_reified_stated = + List.map (fun (_,_,(l,r),_) -> + app coq_p_eq [| reified_of_formula env l; + reified_of_formula env r |]) + to_introduce in + let reified_concl = + match useful_hyps with + (Pnot p) :: _ -> + reified_of_proposition env (really_useful_prop useful_equa_id p) + | _ -> reified_of_proposition env Pfalse in + let l_reified_terms = + (List.map + (fun p -> + reified_of_proposition env (really_useful_prop useful_equa_id p)) + (List.tl useful_hyps)) in + let env_props_reified = mk_plist env.props in + let reified_goal = + mk_list (Lazy.force coq_proposition) + (l_reified_stated @ l_reified_terms) in + let reified = + app coq_interp_sequent + [| env_props_reified;env_terms_reified;reified_concl;reified_goal |] in + let normalize_equation e = + let rec loop = function + [] -> app (if e.e_negated then coq_p_invert else coq_p_step) + [| e.e_trace |] + | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] + | (O_right :: l) -> app coq_p_right [| loop l |] in + app coq_pair_step + [| mk_nat (list_index e.e_origin.o_hyp l_hyps) ; + loop e.e_origin.o_path |] in + let normalization_trace = + mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in + + let initial_context = + List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in + let context = + CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in + let decompose_tactic = decompose_tree env context solution_tree in + + Tactics.generalize + (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >> + Tactics.change_in_concl None reified >> + Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >> + show_goal >> + Tactics.normalise_in_concl >> + 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"; + 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; + resolution env full_reified_goal systems_list gl + with Omega2.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/xml/COPYRIGHT b/contrib/xml/COPYRIGHT new file mode 100644 index 00000000..c8d231fd --- /dev/null +++ b/contrib/xml/COPYRIGHT @@ -0,0 +1,25 @@ +(******************************************************************************) +(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *) +(* Project Helm (http://helm.cs.unibo.it) *) +(* Project MoWGLI (http://mowgli.cs.unibo.it) *) +(* *) +(* Coq Exportation to XML *) +(* *) +(******************************************************************************) + +This Coq module has been developed by Claudio Sacerdoti Coen +<sacerdot@cs.unibo.it> as a developer of projects HELM and MoWGLI. + +Project HELM (for Hypertextual Electronic Library of Mathematics) is a +project developed at the Department of Computer Science, University of Bologna; +http://helm.cs.unibo.it + +Project MoWGLI (Mathematics on the Web: Get It by Logics and Interfaces) +is a UE IST project that generalizes and extends the HELM project; +http://mowgli.cs.unibo.it + +The author is interested in any possible usage of the module. +So, if you plan to use the module, please send him an e-mail. + +The licensing policy applied to the module is the same as for the whole Coq +distribution. diff --git a/contrib/xml/README b/contrib/xml/README new file mode 100644 index 00000000..a45dd31a --- /dev/null +++ b/contrib/xml/README @@ -0,0 +1,254 @@ +(******************************************************************************) +(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *) +(* Project Helm (http://helm.cs.unibo.it) *) +(* Project MoWGLI (http://mowgli.cs.unibo.it) *) +(* *) +(* Coq Exportation to XML *) +(* *) +(******************************************************************************) + +This module provides commands to export a piece of Coq library in XML format. +Only the information relevant to proof-checking and proof-rendering is exported, +i.e. only the CIC proof objects (lambda-terms). + +This document is tructured in the following way: + 1. User documentation + 1.1. New vernacular commands available + 1.2. New coqc/coqtop flags and suggested usage + 1.3. How to exploit the XML files + 2. Technical informations + 2.1. Inner-types + 2.2. CIC with Explicit Named Substitutions + 2.3. The CIC with Explicit Named Substitutions XML DTD + +================================================================================ + USER DOCUMENTATION +================================================================================ + +======================================= +1.1. New vernacular commands available: +======================================= + +The new commands are: + + Print XML qualid. It prints in XML (to standard output) the + object whose qualified name is qualid and + its inner-types (see Sect. 2.1). + The inner-types are always printed + in their own XML file. If the object is a + constant, its type and body are also printed + as two distinct XML files. + The object printed is always the most + discharged form of the object (see + the Section command of the Coq manual). + + Print XML File "filename" qualid. Similar to "Print XML qualid". The generated + files are stored on the hard-disk using the + base file name "filename". + + Show XML Proof. It prints in XML the current proof in + progress. Its inner-types are also printed. + + Show XML File "filename" Proof. Similar to "Show XML Proof". The generated + files are stored on the hard-disk using + the base file name "filename". + + The verbosity of the previous commands is raised if the configuration + parameter verbose of xmlcommand.ml is set to true at compile time. + +============================================== +1.2. New coqc/coqtop flags and suggested usage +============================================== + + The following flag has been added to coqc and coqtop: + + -xml export XML files either to the hierarchy rooted in + the directory $COQ_XML_LIBRARY_ROOT (if the environment + variable is set) or to stdout (if unset) + + If the flag is set, every definition or declaration is immediately + exported to XML. The XML files describe the user-provided non-discharged + form of the definition or declaration. + + + The coq_makefile utility has also been modified to easily allow XML + exportation: + + make COQ_XML=-xml (or, equivalently, setting the environment + variable COQ_XML) + + + The suggested usage of the module is the following: + + 1. add to your own contribution a valid Make file and use coq_makefile + to generate the Makefile from the Make file. + *WARNING:* Since logical names are used to structure the XML hierarchy, + always add to the Make file at least one "-R" option to map physical + file names to logical module paths. See the Coq manual for further + informations on the -R flag. + 2. set $COQ_XML_LIBRARY_ROOT to the directory where the XML file hierarchy + must be physically rooted. + 3. compile your contribution with "make COQ_XML=-xml" + + +================================= +1.3. How to exploit the XML files +================================= + + Once the information is exported to XML, it becomes possible to implement + services that are completely Coq-independent. Projects HELM and MoWGLI + already provide rendering, searching and data mining functionalities. + + In particular, the standard library and contributions of Coq can be + browsed and searched on the HELM web site: + + http://helm.cs.unibo.it/library.html + + + If you want to publish your own contribution so that it is included in the + HELM library, use the MoWGLI prototype upload form: + + http://mowgli.cs.unibo.it + + +================================================================================ + TECHNICAL INFORMATIONS +================================================================================ + +========================== +2.1. Inner-types +========================== + +In order to do proof-rendering (for example in natural language), +some redundant typing information is required, i.e. the type of +at least some of the subterms of the bodies and types. So, each +new command described in section 1.1 print not only +the object, but also another XML file in which you can find +the type of all the subterms of the terms of the printed object +which respect the following conditions: + + 1. It's sort is Prop or CProp (the "sort"-like definition used in + CoRN to type computationally relevant predicative propositions). + 2. It is not a cast or an atomic term, i.e. it's root is not a CAST, REL, + VAR, MUTCONSTR or CONST. + 3. If it's root is a LAMBDA, then the root's parent node is not a LAMBDA, + i.e. only the type of the outer LAMBDA of a block of nested LAMBDAs is + printed. + +The rationale for the 3rd condition is that the type of the inner LAMBDAs +could be easily computed starting from the type of the outer LAMBDA; moreover, +the types of the inner LAMBDAs requires a lot of disk/memory space: removing +the 3rd condition leads to XML file that are two times as big as the ones +exported appling the 3rd condition. + +========================================== +2.2. CIC with Explicit Named Substitutions +========================================== + +The exported files are and XML encoding of the lambda-terms used by the +Coq system. The implementative details of the Coq system are hidden as much +as possible, so that the XML DTD is a straightforward encoding of the +Calculus of (Co)Inductive Constructions. + +Nevertheless, there is a feature of the Coq system that can not be +hidden in a completely satisfactory way: discharging. In Coq it is possible +to open a section, declare variables and use them in the rest of the section +as if they were axiom declarations. Once the section is closed, every definition +and theorem in the section is discharged by abstracting it over the section +variables. Variable declarations as well as section declarations are entirely +dropped. Since we are interested in an XML encoding of definitions and +theorems as close as possible to those directly provided the user, we +do not want to export discharged forms. Exporting non-discharged theorem +and definitions together with theorems that rely on the discharged forms +obliges the tools that work on the XML encoding to implement discharging to +achieve logical consistency. Moreover, the rendering of the files can be +misleading, since hyperlinks can be shown between occurrences of the discharge +form of a definition and the non-discharged definition, that are different +objects. + +To overcome the previous limitations, Claudio Sacerdoti Coen developed in his +PhD. thesis an extension of CIC, called Calculus of (Co)Inductive Constructions +with Explicit Named Substitutions, that is a slight extension of CIC where +discharging is not necessary. The DTD of the exported XML files describes +constants, inductive types and variables of the Calculus of (Co)Inductive +Constructions with Explicit Named Substitions. The conversion to the new +calculus is performed during the exportation phase. + +The following example shows a very small Coq development together with its +version in CIC with Explicit Named Substitutions. + +# CIC version: # +Section S. + Variable A : Prop. + + Definition impl := A -> A. + + Theorem t : impl. (* uses the undischarged form of impl *) + Proof. + exact (fun (a:A) => a). + Qed. + +End S. + +Theorem t' : (impl False). (* uses the discharged form of impl *) + Proof. + exact (t False). (* uses the discharged form of t *) + Qed. + +# Corresponding CIC with Explicit Named Substitutions version: # +Section S. + Variable A : Prop. + + Definition impl(A) := A -> A. (* theorems and definitions are + explicitly abstracted over the + variables. The name is sufficient + to completely describe the abstraction *) + + Theorem t(A) : impl. (* impl where A is not instantiated *) + Proof. + exact (fun (a:A) => a). + Qed. + +End S. + +Theorem t'() : impl{False/A}. (* impl where A is instantiated with False + Notice that t' does not depend on A *) + Proof. + exact t{False/A}. (* t where A is instantiated with False *) + Qed. + +Further details on the typing and reduction rules of the calculus can be +found in Claudio Sacerdoti Coen PhD. dissertation, where the consistency +of the calculus is also proved. + +====================================================== +2.3. The CIC with Explicit Named Substitutions XML DTD +====================================================== + +A copy of the DTD can be found in the file "cic.dtd". + +<ConstantType> is the root element of the files that correspond to + constant types. +<ConstantBody> is the root element of the files that correspond to + constant bodies. It is used only for closed definitions and + theorems (i.e. when no metavariable occurs in the body + or type of the constant) +<CurrentProof> is the root element of the file that correspond to + the body of a constant that depends on metavariables + (e.g. unfinished proofs) +<Variable> is the root element of the files that correspond to variables +<InductiveTypes> is the root element of the files that correspond to blocks + of mutually defined inductive definitions + +The elements + <LAMBDA>,<CAST>,<PROD>,<REL>,<SORT>,<APPLY>,<VAR>,<META>, <IMPLICIT>,<CONST>, + <LETIN>,<MUTIND>,<MUTCONSTRUCT>,<MUTCASE>,<FIX> and <COFIX> +are used to encode the constructors of CIC. The sort or type attribute of the +element, if present, is respectively the sort or the type of the term, that +is a sort because of the typing rules of CIC. + +The element <instantiate> correspond to the application of an explicit named +substitution to its first argument, that is a reference to a definition +or declaration in the environment. + +All the other elements are just syntactic sugar. diff --git a/contrib/xml/acic.ml b/contrib/xml/acic.ml new file mode 100644 index 00000000..032ddbeb --- /dev/null +++ b/contrib/xml/acic.ml @@ -0,0 +1,108 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +open Names +open Term + +(* Maps fron \em{unshared} [constr] to ['a]. *) +module CicHash = + Hashtbl.Make + (struct + type t = Term.constr + let equal = (==) + let hash = Hashtbl.hash + end) +;; + +type id = string (* the type of the (annotated) node identifiers *) +type uri = string + +type 'constr context_entry = + Decl of 'constr (* Declaration *) + | Def of 'constr * 'constr (* Definition; the second argument (the type) *) + (* is not present in the DTD, but is needed *) + (* to use Coq functions during exportation. *) + +type 'constr hypothesis = identifier * 'constr context_entry +type context = constr hypothesis list + +type conjecture = existential_key * context * constr +type metasenv = conjecture list + +(* list of couples section path -- variables defined in that section *) +type params = (string * uri list) list + +type obj = + Constant of string * (* id, *) + constr option * constr * (* value, type, *) + params (* parameters *) + | Variable of + string * constr option * constr * (* name, body, type *) + params (* parameters *) + | CurrentProof of + string * metasenv * (* name, conjectures, *) + constr * constr (* value, type *) + | InductiveDefinition of + inductiveType list * (* inductive types , *) + params * int (* parameters,n ind. pars*) +and inductiveType = + identifier * bool * constr * (* typename, inductive, arity *) + constructor list (* constructors *) +and constructor = + identifier * constr (* id, type *) + +type aconstr = + | ARel of id * int * id * identifier + | AVar of id * uri + | AEvar of id * existential_key * aconstr list + | ASort of id * sorts + | ACast of id * aconstr * aconstr + | AProds of (id * name * aconstr) list * aconstr + | ALambdas of (id * name * aconstr) list * aconstr + | ALetIns of (id * name * aconstr) list * aconstr + | AApp of id * aconstr list + | AConst of id * explicit_named_substitution * uri + | AInd of id * explicit_named_substitution * uri * int + | AConstruct of id * explicit_named_substitution * uri * int * int + | ACase of id * uri * int * aconstr * aconstr * aconstr list + | AFix of id * int * ainductivefun list + | ACoFix of id * int * acoinductivefun list +and ainductivefun = + id * identifier * int * aconstr * aconstr +and acoinductivefun = + id * identifier * aconstr * aconstr +and explicit_named_substitution = id option * (uri * aconstr) list + +type acontext = (id * aconstr hypothesis) list +type aconjecture = id * existential_key * acontext * aconstr +type ametasenv = aconjecture list + +type aobj = + AConstant of id * string * (* id, *) + aconstr option * aconstr * (* value, type, *) + params (* parameters *) + | AVariable of id * + string * aconstr option * aconstr * (* name, body, type *) + params (* parameters *) + | ACurrentProof of id * + string * ametasenv * (* name, conjectures, *) + aconstr * aconstr (* value, type *) + | AInductiveDefinition of id * + anninductiveType list * (* inductive types , *) + params * int (* parameters,n ind. pars*) +and anninductiveType = + id * identifier * bool * aconstr * (* typename, inductive, arity *) + annconstructor list (* constructors *) +and annconstructor = + identifier * aconstr (* id, type *) diff --git a/contrib/xml/acic2Xml.ml4 b/contrib/xml/acic2Xml.ml4 new file mode 100644 index 00000000..64dc8a05 --- /dev/null +++ b/contrib/xml/acic2Xml.ml4 @@ -0,0 +1,363 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +(*CSC codice cut & paste da cicPp e xmlcommand *) + +exception ImpossiblePossible;; +exception NotImplemented;; +let dtdname = "http://mowgli.cs.unibo.it/dtd/cic.dtd";; +let typesdtdname = "http://mowgli.cs.unibo.it/dtd/cictypes.dtd";; + +let rec find_last_id = + function + [] -> Util.anomaly "find_last_id: empty list" + | [id,_,_] -> id + | _::tl -> find_last_id tl +;; + +let export_existential = string_of_int + +let print_term ids_to_inner_sorts = + let rec aux = + let module A = Acic in + let module N = Names in + let module X = Xml in + function + A.ARel (id,n,idref,b) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_empty "REL" + ["value",(string_of_int n) ; "binder",(N.string_of_id b) ; + "id",id ; "idref",idref; "sort",sort] + | A.AVar (id,uri) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort] + | A.AEvar (id,n,l) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "META" + ["no",(export_existential n) ; "id",id ; "sort",sort] + (List.fold_left + (fun i t -> + [< i ; X.xml_nempty "substitution" [] (aux t) >] + ) [< >] (List.rev l)) + | A.ASort (id,s) -> + let string_of_sort = + match Term.family_of_sort s with + Term.InProp -> "Prop" + | Term.InSet -> "Set" + | Term.InType -> "Type" + in + X.xml_empty "SORT" ["value",string_of_sort ; "id",id] + | A.AProds (prods,t) -> + let last_id = find_last_id prods in + let sort = Hashtbl.find ids_to_inner_sorts last_id in + X.xml_nempty "PROD" ["type",sort] + [< List.fold_left + (fun i (id,binder,s) -> + let sort = + Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) + in + let attrs = + ("id",id)::("type",sort):: + match binder with + Names.Anonymous -> [] + | Names.Name b -> ["binder",Names.string_of_id b] + in + [< X.xml_nempty "decl" attrs (aux s) ; i >] + ) [< >] prods ; + X.xml_nempty "target" [] (aux t) + >] + | A.ACast (id,v,t) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "CAST" ["id",id ; "sort",sort] + [< X.xml_nempty "term" [] (aux v) ; + X.xml_nempty "type" [] (aux t) + >] + | A.ALambdas (lambdas,t) -> + let last_id = find_last_id lambdas in + let sort = Hashtbl.find ids_to_inner_sorts last_id in + X.xml_nempty "LAMBDA" ["sort",sort] + [< List.fold_left + (fun i (id,binder,s) -> + let sort = + Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) + in + let attrs = + ("id",id)::("type",sort):: + match binder with + Names.Anonymous -> [] + | Names.Name b -> ["binder",Names.string_of_id b] + in + [< X.xml_nempty "decl" attrs (aux s) ; i >] + ) [< >] lambdas ; + X.xml_nempty "target" [] (aux t) + >] + | A.ALetIns (letins,t) -> + let last_id = find_last_id letins in + let sort = Hashtbl.find ids_to_inner_sorts last_id in + X.xml_nempty "LETIN" ["sort",sort] + [< List.fold_left + (fun i (id,binder,s) -> + let sort = + Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id) + in + let attrs = + ("id",id)::("sort",sort):: + match binder with + Names.Anonymous -> assert false + | Names.Name b -> ["binder",Names.string_of_id b] + in + [< X.xml_nempty "def" attrs (aux s) ; i >] + ) [< >] letins ; + X.xml_nempty "target" [] (aux t) + >] + | A.AApp (id,li) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "APPLY" ["id",id ; "sort",sort] + [< (List.fold_left (fun i x -> [< i ; (aux x) >]) [<>] li) + >] + | A.AConst (id,subst,uri) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + let attrs = ["uri", uri ; "id",id ; "sort",sort] in + aux_subst (X.xml_empty "CONST" attrs) subst + | A.AInd (id,subst,uri,i) -> + let attrs = ["uri", uri ; "noType",(string_of_int i) ; "id",id] in + aux_subst (X.xml_empty "MUTIND" attrs) subst + | A.AConstruct (id,subst,uri,i,j) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + let attrs = + ["uri", uri ; + "noType",(string_of_int i) ; "noConstr",(string_of_int j) ; + "id",id ; "sort",sort] + in + aux_subst (X.xml_empty "MUTCONSTRUCT" attrs) subst + | A.ACase (id,uri,typeno,ty,te,patterns) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "MUTCASE" + ["uriType", uri ; + "noType", (string_of_int typeno) ; + "id", id ; "sort",sort] + [< X.xml_nempty "patternsType" [] [< (aux ty) >] ; + X.xml_nempty "inductiveTerm" [] [< (aux te) >] ; + List.fold_left + (fun i x -> [< i ; X.xml_nempty "pattern" [] [< aux x >] >]) + [<>] patterns + >] + | A.AFix (id, no, funs) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "FIX" + ["noFun", (string_of_int no) ; "id",id ; "sort",sort] + [< List.fold_left + (fun i (id,fi,ai,ti,bi) -> + [< i ; + X.xml_nempty "FixFunction" + ["id",id ; "name", (Names.string_of_id fi) ; + "recIndex", (string_of_int ai)] + [< X.xml_nempty "type" [] [< aux ti >] ; + X.xml_nempty "body" [] [< aux bi >] + >] + >] + ) [<>] funs + >] + | A.ACoFix (id,no,funs) -> + let sort = Hashtbl.find ids_to_inner_sorts id in + X.xml_nempty "COFIX" + ["noFun", (string_of_int no) ; "id",id ; "sort",sort] + [< List.fold_left + (fun i (id,fi,ti,bi) -> + [< i ; + X.xml_nempty "CofixFunction" + ["id",id ; "name", Names.string_of_id fi] + [< X.xml_nempty "type" [] [< aux ti >] ; + X.xml_nempty "body" [] [< aux bi >] + >] + >] + ) [<>] funs + >] + and aux_subst target (id,subst) = + if subst = [] then + target + else + Xml.xml_nempty "instantiate" + (match id with None -> [] | Some id -> ["id",id]) + [< target ; + List.fold_left + (fun i (uri,arg) -> + [< i ; Xml.xml_nempty "arg" ["relUri", uri] (aux arg) >] + ) [<>] subst + >] + in + aux +;; + +let param_attribute_of_params params = + List.fold_right + (fun (path,l) i -> + List.fold_right + (fun x i ->path ^ "/" ^ x ^ ".var" ^ match i with "" -> "" | i' -> " " ^ i' + ) l "" ^ match i with "" -> "" | i' -> " " ^ i' + ) params "" +;; + +let print_object uri ids_to_inner_sorts = + let rec aux = + let module A = Acic in + let module X = Xml in + function + A.ACurrentProof (id,n,conjectures,bo,ty) -> + let xml_for_current_proof_body = +(*CSC: Should the CurrentProof also have the list of variables it depends on? *) +(*CSC: I think so. Not implemented yet. *) + X.xml_nempty "CurrentProof" ["of",uri ; "id", id] + [< List.fold_left + (fun i (cid,n,canonical_context,t) -> + [< i ; + X.xml_nempty "Conjecture" + ["id", cid ; "no",export_existential n] + [< List.fold_left + (fun i (hid,t) -> + [< (match t with + n,A.Decl t -> + X.xml_nempty "Decl" + ["id",hid;"name",Names.string_of_id n] + (print_term ids_to_inner_sorts t) + | n,A.Def (t,_) -> + X.xml_nempty "Def" + ["id",hid;"name",Names.string_of_id n] + (print_term ids_to_inner_sorts t) + ) ; + i + >] + ) [< >] canonical_context ; + X.xml_nempty "Goal" [] + (print_term ids_to_inner_sorts t) + >] + >]) + [<>] (List.rev conjectures) ; + X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >] + in + let xml_for_current_proof_type = + X.xml_nempty "ConstantType" ["name",n ; "id", id] + (print_term ids_to_inner_sorts ty) + in + let xmlbo = + [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; + X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^dtdname ^"\">\n"); + xml_for_current_proof_body + >] in + let xmlty = + [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; + X.xml_cdata + ("<!DOCTYPE ConstantType SYSTEM \"" ^ dtdname ^ "\">\n"); + xml_for_current_proof_type + >] + in + xmlty, Some xmlbo + | A.AConstant (id,n,bo,ty,params) -> + let params' = param_attribute_of_params params in + let xmlbo = + match bo with + None -> None + | Some bo -> + Some + [< X.xml_cdata + "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; + X.xml_cdata + ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ; + X.xml_nempty "ConstantBody" + ["for",uri ; "params",params' ; "id", id] + [< print_term ids_to_inner_sorts bo >] + >] + in + let xmlty = + [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; + X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^dtdname ^"\">\n"); + X.xml_nempty "ConstantType" + ["name",n ; "params",params' ; "id", id] + [< print_term ids_to_inner_sorts ty >] + >] + in + xmlty, xmlbo + | A.AVariable (id,n,bo,ty,params) -> + let params' = param_attribute_of_params params in + [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; + X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n") ; + X.xml_nempty "Variable" ["name",n ; "params",params' ; "id", id] + [< (match bo with + None -> [<>] + | Some bo -> + X.xml_nempty "body" [] + (print_term ids_to_inner_sorts bo) + ) ; + X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty) + >] + >], None + | A.AInductiveDefinition (id,tys,params,nparams) -> + let params' = param_attribute_of_params params in + [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; + X.xml_cdata ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^ + dtdname ^ "\">\n") ; + X.xml_nempty "InductiveDefinition" + ["noParams",string_of_int nparams ; + "id",id ; + "params",params'] + [< (List.fold_left + (fun i (id,typename,finite,arity,cons) -> + [< i ; + X.xml_nempty "InductiveType" + ["id",id ; "name",Names.string_of_id typename ; + "inductive",(string_of_bool finite) + ] + [< X.xml_nempty "arity" [] + (print_term ids_to_inner_sorts arity) ; + (List.fold_left + (fun i (name,lc) -> + [< i ; + X.xml_nempty "Constructor" + ["name",Names.string_of_id name] + (print_term ids_to_inner_sorts lc) + >]) [<>] cons + ) + >] + >] + ) [< >] tys + ) + >] + >], None + in + aux +;; + +let print_inner_types curi ids_to_inner_sorts ids_to_inner_types = + let module C2A = Cic2acic in + let module X = Xml in + [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; + X.xml_cdata ("<!DOCTYPE InnerTypes SYSTEM \"" ^ typesdtdname ^"\">\n"); + X.xml_nempty "InnerTypes" ["of",curi] + (Hashtbl.fold + (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x -> + [< x ; + X.xml_nempty "TYPE" ["of",id] + [< X.xml_nempty "synthesized" [] + (print_term ids_to_inner_sorts synty) ; + match expty with + None -> [<>] + | Some expty' -> + X.xml_nempty "expected" [] + (print_term ids_to_inner_sorts expty') + >] + >] + ) ids_to_inner_types [<>] + ) + >] +;; diff --git a/contrib/xml/cic.dtd b/contrib/xml/cic.dtd new file mode 100644 index 00000000..c8035cab --- /dev/null +++ b/contrib/xml/cic.dtd @@ -0,0 +1,259 @@ +<?xml encoding="ISO-8859-1"?> + +<!-- Copyright (C) 2000-2004, HELM Team --> +<!-- --> +<!-- This file is part of HELM, an Hypertextual, Electronic --> +<!-- Library of Mathematics, developed at the Computer Science --> +<!-- Department, University of Bologna, Italy. --> +<!-- --> +<!-- HELM is free software; you can redistribute it and/or --> +<!-- modify it under the terms of the GNU General Public License --> +<!-- as published by the Free Software Foundation; either version 2 --> +<!-- of the License, or (at your option) any later version. --> +<!-- --> +<!-- HELM is distributed in the hope that it will be useful, --> +<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of --> +<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --> +<!-- GNU General Public License for more details. --> +<!-- --> +<!-- You should have received a copy of the GNU General Public License --> +<!-- along with HELM; if not, write to the Free Software --> +<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, --> +<!-- MA 02111-1307, USA. --> +<!-- --> +<!-- For details, see the HELM World-Wide-Web page, --> +<!-- http://cs.unibo.it/helm/. --> + +<!-- DTD FOR CIC OBJECTS: --> + +<!-- CIC term declaration --> + +<!ENTITY % term '(LAMBDA|CAST|PROD|REL|SORT|APPLY|VAR|META|IMPLICIT|CONST| + LETIN|MUTIND|MUTCONSTRUCT|MUTCASE|FIX|COFIX|instantiate)'> + +<!-- CIC sorts --> + +<!ENTITY % sort '(Prop|Set|Type|CProp)'> + +<!-- CIC sequents --> + +<!ENTITY % sequent '((Decl|Def|Hidden)*,Goal)'> + +<!-- CIC objects: --> + +<!ELEMENT ConstantType %term;> +<!ATTLIST ConstantType + name CDATA #REQUIRED + params CDATA #REQUIRED + id ID #REQUIRED> + +<!ELEMENT ConstantBody %term;> +<!ATTLIST ConstantBody + for CDATA #REQUIRED + params CDATA #REQUIRED + id ID #REQUIRED> + +<!ELEMENT CurrentProof (Conjecture*,body)> +<!ATTLIST CurrentProof + of CDATA #REQUIRED + id ID #REQUIRED> + +<!ELEMENT InductiveDefinition (InductiveType+)> +<!ATTLIST InductiveDefinition + noParams NMTOKEN #REQUIRED + params CDATA #REQUIRED + id ID #REQUIRED> + +<!ELEMENT Variable (body?,type)> +<!ATTLIST Variable + name CDATA #REQUIRED + params CDATA #REQUIRED + id ID #REQUIRED> + +<!ELEMENT Sequent %sequent;> +<!ATTLIST Sequent + no NMTOKEN #REQUIRED + id ID #REQUIRED> + +<!-- Elements used in CIC objects, which are not terms: --> + +<!ELEMENT InductiveType (arity,Constructor*)> +<!ATTLIST InductiveType + name CDATA #REQUIRED + inductive (true|false) #REQUIRED + id ID #REQUIRED> + +<!ELEMENT Conjecture %sequent;> +<!ATTLIST Conjecture + no NMTOKEN #REQUIRED + id ID #REQUIRED> + +<!ELEMENT Constructor %term;> +<!ATTLIST Constructor + name CDATA #REQUIRED> + +<!ELEMENT Decl %term;> +<!ATTLIST Decl + name CDATA #IMPLIED + id ID #REQUIRED> + +<!ELEMENT Def %term;> +<!ATTLIST Def + name CDATA #IMPLIED + id ID #REQUIRED> + +<!ELEMENT Hidden EMPTY> +<!ATTLIST Hidden + id ID #REQUIRED> + +<!ELEMENT Goal %term;> + +<!-- CIC terms: --> + +<!ELEMENT LAMBDA (decl*,target)> +<!ATTLIST LAMBDA + sort %sort; #REQUIRED> + +<!ELEMENT LETIN (def*,target)> +<!ATTLIST LETIN + sort %sort; #REQUIRED> + +<!ELEMENT PROD (decl*,target)> +<!ATTLIST PROD + type %sort; #REQUIRED> + +<!ELEMENT CAST (term,type)> +<!ATTLIST CAST + id ID #REQUIRED + sort %sort; #REQUIRED> + +<!ELEMENT REL EMPTY> +<!ATTLIST REL + value NMTOKEN #REQUIRED + binder CDATA #REQUIRED + id ID #REQUIRED + idref IDREF #REQUIRED + sort %sort; #REQUIRED> + +<!ELEMENT SORT EMPTY> +<!ATTLIST SORT + value CDATA #REQUIRED + id ID #REQUIRED> + +<!ELEMENT APPLY (%term;)+> +<!ATTLIST APPLY + id ID #REQUIRED + sort %sort; #REQUIRED> + +<!ELEMENT VAR EMPTY> +<!ATTLIST VAR + uri CDATA #REQUIRED + id ID #REQUIRED + sort %sort; #REQUIRED> + +<!-- The substitutions are ordered by increasing DeBrujin --> +<!-- index. An empty substitution means that that index is --> +<!-- not accessible. --> +<!ELEMENT META (substitution*)> +<!ATTLIST META + no NMTOKEN #REQUIRED + id ID #REQUIRED + sort %sort; #REQUIRED> + +<!ELEMENT IMPLICIT EMPTY> +<!ATTLIST IMPLICIT + id ID #REQUIRED> + +<!ELEMENT CONST EMPTY> +<!ATTLIST CONST + uri CDATA #REQUIRED + id ID #REQUIRED + sort %sort; #REQUIRED> + +<!ELEMENT MUTIND EMPTY> +<!ATTLIST MUTIND + uri CDATA #REQUIRED + noType NMTOKEN #REQUIRED + id ID #REQUIRED> + +<!ELEMENT MUTCONSTRUCT EMPTY> +<!ATTLIST MUTCONSTRUCT + uri CDATA #REQUIRED + noType NMTOKEN #REQUIRED + noConstr NMTOKEN #REQUIRED + id ID #REQUIRED + sort %sort; #REQUIRED> + +<!ELEMENT MUTCASE (patternsType,inductiveTerm,pattern*)> +<!ATTLIST MUTCASE + uriType CDATA #REQUIRED + noType NMTOKEN #REQUIRED + id ID #REQUIRED + sort %sort; #REQUIRED> + +<!ELEMENT FIX (FixFunction+)> +<!ATTLIST FIX + noFun NMTOKEN #REQUIRED + id ID #REQUIRED + sort %sort; #REQUIRED> + +<!ELEMENT COFIX (CofixFunction+)> +<!ATTLIST COFIX + noFun NMTOKEN #REQUIRED + id ID #REQUIRED + sort %sort; #REQUIRED> + +<!-- Elements used in CIC terms: --> + +<!ELEMENT FixFunction (type,body)> +<!ATTLIST FixFunction + name CDATA #REQUIRED + id ID #REQUIRED + recIndex NMTOKEN #REQUIRED> + +<!ELEMENT CofixFunction (type,body)> +<!ATTLIST CofixFunction + id ID #REQUIRED + name CDATA #REQUIRED> + +<!ELEMENT substitution ((%term;)?)> + +<!-- Explicit named substitutions: --> + +<!ELEMENT instantiate ((CONST|MUTIND|MUTCONSTRUCT|VAR),arg+)> +<!ATTLIST instantiate + id ID #IMPLIED> + +<!-- Sintactic sugar for CIC terms and for CIC objects: --> + +<!ELEMENT arg %term;> +<!ATTLIST arg + relUri CDATA #REQUIRED> + +<!ELEMENT decl %term;> +<!ATTLIST decl + id ID #REQUIRED + type %sort; #REQUIRED + binder CDATA #IMPLIED> + +<!ELEMENT def %term;> +<!ATTLIST def + id ID #REQUIRED + sort %sort; #REQUIRED + binder CDATA #IMPLIED> + +<!ELEMENT target %term;> + +<!ELEMENT term %term;> + +<!ELEMENT type %term;> + +<!ELEMENT arity %term;> + +<!ELEMENT patternsType %term;> + +<!ELEMENT inductiveTerm %term;> + +<!ELEMENT pattern %term;> + +<!ELEMENT body %term;> diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml new file mode 100644 index 00000000..d820f9e5 --- /dev/null +++ b/contrib/xml/cic2acic.ml @@ -0,0 +1,946 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +(* Utility Functions *) + +exception TwoModulesWhoseDirPathIsOneAPrefixOfTheOther;; +let get_module_path_of_section_path path = + let dirpath = fst (Libnames.repr_path path) in + let modules = Lib.library_dp () :: (Library.loaded_libraries ()) in + match + List.filter + (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules + with + [modul] -> modul + | _ -> raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther +;; + +(*CSC: Problem: here we are using the wrong (???) hypothesis that there do *) +(*CSC: not exist two modules whose dir_paths are one a prefix of the other *) +let remove_module_dirpath_from_dirpath ~basedir dir = + let module Ln = Libnames in + if Ln.is_dirpath_prefix_of basedir dir then + let ids = Names.repr_dirpath dir in + let rec remove_firsts n l = + match n,l with + (0,l) -> l + | (n,he::tl) -> remove_firsts (n-1) tl + | _ -> assert false + in + let ids' = + List.rev + (remove_firsts + (List.length (Names.repr_dirpath basedir)) + (List.rev ids)) + in + ids' + else Names.repr_dirpath dir +;; + + +let get_uri_of_var v pvars = + let module D = Declare in + let module N = Names in + let rec search_in_pvars names = + function + [] -> None + | ((name,l)::tl) -> + let names' = name::names in + if List.mem v l then + Some names' + else + search_in_pvars names' tl + in + let rec search_in_open_sections = + function + [] -> Util.error "Variable not found" + | he::tl as modules -> + let dirpath = N.make_dirpath modules in + if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then + modules + else + search_in_open_sections tl + in + let path = + match search_in_pvars [] pvars with + None -> search_in_open_sections (N.repr_dirpath (Lib.cwd ())) + | Some path -> path + in + "cic:" ^ + List.fold_left + (fun i x -> "/" ^ N.string_of_id x ^ i) "" path +;; + +type tag = + Constant + | Inductive + | Variable +;; + +let ext_of_tag = + function + Constant -> "con" + | Inductive -> "ind" + | Variable -> "var" +;; + +exception FunctorsXMLExportationNotImplementedYet;; + +let subtract l1 l2 = + let l1' = List.rev (Names.repr_dirpath l1) in + let l2' = List.rev (Names.repr_dirpath l2) in + let rec aux = + function + he::tl when tl = l2' -> [he] + | he::tl -> he::(aux tl) + | [] -> assert (l2' = []) ; [] + in + Names.make_dirpath (List.rev (aux l1')) +;; + +(*CSC: Dead code to be removed +let token_list_of_kernel_name ~keep_sections kn tag = + let module N = Names in + let (modpath,dirpath,label) = Names.repr_kn kn in + let token_list_of_dirpath dirpath = + List.rev_map N.string_of_id (N.repr_dirpath dirpath) in + let rec token_list_of_modpath = + function + N.MPdot (path,label) -> + token_list_of_modpath path @ [N.string_of_label label] + | N.MPfile dirpath -> token_list_of_dirpath dirpath + | N.MPself self -> + if self = Names.initial_msid then + [ "Top" ] + else + let module_path = + let f = N.string_of_id (N.id_of_msid self) in + let _,longf = + System.find_file_in_path (Library.get_load_path ()) (f^".v") in + let ldir0 = Library.find_logical_path (Filename.dirname longf) in + let id = Names.id_of_string (Filename.basename f) in + Libnames.extend_dirpath ldir0 id + in + token_list_of_dirpath module_path + | N.MPbound _ -> raise FunctorsXMLExportationNotImplementedYet + in + token_list_of_modpath modpath @ + (if keep_sections then token_list_of_dirpath dirpath else []) @ + [N.string_of_label label ^ "." ^ (ext_of_tag tag)] +;; +*) + +let token_list_of_path dir id tag = + let module N = Names in + let token_list_of_dirpath dirpath = + List.rev_map N.string_of_id (N.repr_dirpath dirpath) in + token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)] + +let token_list_of_kernel_name kn tag = + let module N = Names in + let module LN = Libnames in + let dir = match tag with + | Variable -> + Lib.cwd () + | Constant -> + Lib.library_part (LN.ConstRef kn) + | Inductive -> + Lib.library_part (LN.IndRef (kn,0)) + in + let id = N.id_of_label (N.label kn) in + token_list_of_path dir id tag +;; + +let uri_of_kernel_name kn tag = + let tokens = token_list_of_kernel_name kn tag in + "cic:/" ^ String.concat "/" tokens + +let uri_of_declaration id tag = + let module LN = Libnames in + let dir = LN.extract_dirpath_prefix (Lib.sections_depth ()) (Lib.cwd ()) in + let tokens = token_list_of_path dir id tag in + "cic:/" ^ String.concat "/" tokens + +(* Special functions for handling of CCorn's CProp "sort" *) + +type sort = + Coq_sort of Term.sorts_family + | CProp +;; + +let prerr_endline _ = ();; + +let family_of_term ty = + match Term.kind_of_term ty with + Term.Sort s -> Coq_sort (Term.family_of_sort s) + | Term.Const _ -> CProp (* I could check that the constant is CProp *) + | _ -> Util.anomaly "family_of_term" +;; + +module CPropRetyping = + struct + module T = Term + + let outsort env sigma t = + family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma t) + + let rec subst_type env sigma typ = function + | [] -> typ + | h::rest -> + match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma typ) with + | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest + | _ -> Util.anomaly "Non-functional construction" + + + let sort_of_atomic_type env sigma ft args = + let rec concl_of_arity env ar = + match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with + | T.Prod (na, t, b) -> concl_of_arity (Environ.push_rel (na,None,t) env) b + | T.Sort s -> Coq_sort (T.family_of_sort s) + | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args)) + in concl_of_arity env ft + +let typeur sigma metamap = + let rec type_of env cstr= + match Term.kind_of_term cstr with + | T.Meta n -> + (try T.strip_outer_cast (List.assoc n metamap) + with Not_found -> Util.anomaly "type_of: this is not a well-typed term") + | T.Rel n -> + let (_,_,ty) = Environ.lookup_rel n env in + T.lift n ty + | T.Var id -> + (try + let (_,_,ty) = Environ.lookup_named id env in + T.body_of_type ty + with Not_found -> + Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound")) + | T.Const c -> + let cb = Environ.lookup_constant c env in + 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.Construct cstr -> + T.body_of_type (Inductive.type_of_constructor env cstr) + | T.Case (_,p,c,lf) -> + let Inductiveops.IndType(_,realargs) = + try Inductiveops.find_rectype env sigma (type_of env c) + with Not_found -> Util.anomaly "type_of: Bad recursive type" in + let t = Reductionops.whd_beta (T.applist (p, realargs)) in + (match Term.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma (type_of env t)) with + | T.Prod _ -> Reductionops.whd_beta (T.applist (t, [c])) + | _ -> t) + | T.Lambda (name,c1,c2) -> + T.mkProd (name, c1, type_of (Environ.push_rel (name,None,c1) env) c2) + | T.LetIn (name,b,c1,c2) -> + T.subst1 b (type_of (Environ.push_rel (name,Some b,c1) env) c2) + | T.Fix ((_,i),(_,tys,_)) -> tys.(i) + | T.CoFix (i,(_,tys,_)) -> tys.(i) + | T.App(f,args)-> + T.strip_outer_cast + (subst_type env sigma (type_of env f) (Array.to_list args)) + | T.Cast (c,t) -> t + | T.Sort _ | T.Prod _ -> + match sort_of env cstr with + Coq_sort T.InProp -> T.mkProp + | Coq_sort T.InSet -> T.mkSet + | Coq_sort T.InType -> T.mkType Univ.prop_univ (* ERROR HERE *) + | CProp -> T.mkConst DoubleTypeInference.cprop + + and sort_of env t = + match Term.kind_of_term t with + | T.Cast (c,s) when T.isSort s -> family_of_term s + | T.Sort (T.Prop c) -> Coq_sort T.InType + | T.Sort (T.Type u) -> Coq_sort T.InType + | T.Prod (name,t,c2) -> + (match sort_of env t,sort_of (Environ.push_rel (name,None,t) env) c2 with + | _, (Coq_sort T.InProp as s) -> s + | Coq_sort T.InProp, (Coq_sort T.InSet as s) + | Coq_sort T.InSet, (Coq_sort T.InSet as s) -> s + | Coq_sort T.InType, (Coq_sort T.InSet as s) + | CProp, (Coq_sort T.InSet as s) when + Environ.engagement env = Some Environ.ImpredicativeSet -> s + | Coq_sort T.InType, Coq_sort T.InSet + | CProp, Coq_sort T.InSet -> Coq_sort T.InType + | _, (Coq_sort T.InType as s) -> s (*Type Univ.dummy_univ*) + | _, (CProp as s) -> s) + | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args + | T.Lambda _ | T.Fix _ | T.Construct _ -> + Util.anomaly "sort_of: Not a type (1)" + | _ -> outsort env sigma (type_of env t) + + and sort_family_of env t = + match T.kind_of_term t with + | T.Cast (c,s) when T.isSort s -> family_of_term s + | T.Sort (T.Prop c) -> Coq_sort T.InType + | T.Sort (T.Type u) -> Coq_sort T.InType + | T.Prod (name,t,c2) -> sort_family_of (Environ.push_rel (name,None,t) env) c2 + | T.App(f,args) -> + sort_of_atomic_type env sigma (type_of env f) args + | T.Lambda _ | T.Fix _ | T.Construct _ -> + Util.anomaly "sort_of: Not a type (1)" + | _ -> outsort env sigma (type_of env t) + + in type_of, sort_of, sort_family_of + + let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c + let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c + + end +;; + +let get_sort_family_of env evar_map ty = + CPropRetyping.get_sort_family_of env evar_map ty +;; + +let type_as_sort env evar_map ty = +(* CCorn code *) + family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env evar_map ty) +;; + +let is_a_Prop = + function + "Prop" + | "CProp" -> true + | _ -> false +;; + +(* Main Functions *) + +type anntypes = + {annsynthesized : Acic.aconstr ; annexpected : Acic.aconstr option} +;; + +let gen_id seed = + let res = "i" ^ string_of_int !seed in + incr seed ; + res +;; + +let fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids = + fun father t -> + let res = gen_id seed in + Hashtbl.add ids_to_father_ids res father ; + Hashtbl.add ids_to_terms res t ; + Acic.CicHash.add constr_to_ids t res ; + res +;; + +let source_id_of_id id = "#source#" ^ id;; + +let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids + ids_to_father_ids ids_to_inner_sorts ids_to_inner_types + pvars ?(fake_dependent_products=false) env idrefs evar_map t expectedty += + let module D = DoubleTypeInference in + let module E = Environ in + let module N = Names in + let module A = Acic in + let module T = Term in + let fresh_id' = fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids in + (* CSC: do you have any reasonable substitute for 503? *) + let terms_to_types = Acic.CicHash.create 503 in + D.double_type_of env evar_map t expectedty terms_to_types ; + let rec aux computeinnertypes father passed_lambdas_or_prods_or_letins env + idrefs ?(subst=None,[]) tt + = + let fresh_id'' = fresh_id' father tt in + let aux' = aux computeinnertypes (Some fresh_id'') [] in + let string_of_sort_family = + function + Coq_sort T.InProp -> "Prop" + | Coq_sort T.InSet -> "Set" + | Coq_sort T.InType -> "Type" + | CProp -> "CProp" + in + let string_of_sort t = + string_of_sort_family + (type_as_sort env evar_map t) + in + let ainnertypes,innertype,innersort,expected_available = + let {D.synthesized = synthesized; D.expected = expected} = + if computeinnertypes then +try + Acic.CicHash.find terms_to_types tt +with _ -> +(*CSC: Warning: it really happens, for example in Ring_theory!!! *) +Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.prterm tt)) ; assert false + else + (* We are already in an inner-type and Coscoy's double *) + (* type inference algorithm has not been applied. *) + (* We need to refresh the universes because we are doing *) + (* type inference on an already inferred type. *) + {D.synthesized = + Reductionops.nf_beta + (CPropRetyping.get_type_of env evar_map + (Evarutil.refresh_universes tt)) ; + D.expected = None} + in +(* Debugging only: +print_endline "TERMINE:" ; flush stdout ; +Pp.ppnl (Printer.prterm tt) ; flush stdout ; +print_endline "TIPO:" ; flush stdout ; +Pp.ppnl (Printer.prterm 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 +(* Debugging only: +print_endline "PASSATO" ; flush stdout ; +*) + let ainnertypes,expected_available = + if computeinnertypes then + let annexpected,expected_available = + match expected with + None -> None,false + | Some expectedty' -> + Some (aux false (Some fresh_id'') [] env idrefs expectedty'), + true + in + Some + {annsynthesized = + aux false (Some fresh_id'') [] env idrefs synthesized ; + annexpected = annexpected + }, expected_available + else + None,false + in + ainnertypes,synthesized, string_of_sort_family innersort, + expected_available + in + let add_inner_type id = + match ainnertypes with + None -> () + | Some ainnertypes -> Hashtbl.add ids_to_inner_types id ainnertypes + in + + (* explicit_substitute_and_eta_expand_if_required h t t' *) + (* where [t] = [] and [tt] = [h]{[t']} ("{.}" denotes explicit *) + (* named substitution) or [tt] = (App [h]::[t]) (and [t'] = []) *) + (* check if [h] is a term that requires an explicit named *) + (* substitution and, in that case, uses the first arguments of *) + (* [t] as the actual arguments of the substitution. If there *) + (* are not enough parameters in the list [t], then eta-expansion *) + (* is performed. *) + let + explicit_substitute_and_eta_expand_if_required h t t' + compute_result_if_eta_expansion_not_required + = + let subst,residual_args,uninst_vars = + let variables,basedir = + try + let g = Libnames.reference_of_constr h in + let sp = + match g with + Libnames.ConstructRef ((induri,_),_) + | Libnames.IndRef (induri,_) -> + Nametab.sp_of_global (Libnames.IndRef (induri,0)) + | Libnames.VarRef id -> + (* Invariant: variables are never cooked in Coq *) + raise Not_found + | _ -> Nametab.sp_of_global g + in + Dischargedhypsmap.get_discharged_hyps sp, + get_module_path_of_section_path sp + with Not_found -> + (* no explicit substitution *) + [], Libnames.dirpath_of_string "dummy" + in + (* returns a triple whose first element is *) + (* an explicit named substitution of "type" *) + (* (variable * argument) list, whose *) + (* second element is the list of residual *) + (* arguments and whose third argument is *) + (* the list of uninstantiated variables *) + let rec get_explicit_subst variables arguments = + match variables,arguments with + [],_ -> [],arguments,[] + | _,[] -> [],[],variables + | he1::tl1,he2::tl2 -> + let subst,extra_args,uninst = get_explicit_subst tl1 tl2 in + let (he1_sp, he1_id) = Libnames.repr_path he1 in + let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in + let he1'' = + String.concat "/" + (List.map Names.string_of_id (List.rev he1')) ^ "/" + ^ (Names.string_of_id he1_id) ^ ".var" + in + (he1'',he2)::subst, extra_args, uninst + in + get_explicit_subst variables t' + in + let uninst_vars_length = List.length uninst_vars in + if uninst_vars_length > 0 then + (* Not enough arguments provided. We must eta-expand! *) + let un_args,_ = + T.decompose_prod_n uninst_vars_length + (CPropRetyping.get_type_of env evar_map tt) + in + let eta_expanded = + let arguments = + List.map (T.lift uninst_vars_length) t @ + Termops.rel_list 0 uninst_vars_length + in + Unshare.unshare + (T.lamn uninst_vars_length un_args + (T.applistc h arguments)) + in + D.double_type_of env evar_map eta_expanded + None terms_to_types ; + Hashtbl.remove ids_to_inner_types fresh_id'' ; + aux' env idrefs eta_expanded + else + compute_result_if_eta_expansion_not_required subst residual_args + in + + (* Now that we have all the auxiliary functions we *) + (* can finally proceed with the main case analysis. *) + match T.kind_of_term tt with + T.Rel n -> + let id = + match List.nth (E.rel_context env) (n - 1) with + (N.Name id,_,_) -> id + | (N.Anonymous,_,_) -> Nameops.make_ident "_" None + in + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + A.ARel (fresh_id'', n, List.nth idrefs (n-1), id) + | T.Var id -> + let path = get_uri_of_var (N.string_of_id id) pvars in + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + A.AVar + (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var") + | T.Evar (n,l) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + A.AEvar + (fresh_id'', n, Array.to_list (Array.map (aux' env idrefs) l)) + | T.Meta _ -> Util.anomaly "Meta met during exporting to XML" + | T.Sort s -> A.ASort (fresh_id'', s) + | T.Cast (v,t) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then + add_inner_type fresh_id'' ; + A.ACast (fresh_id'', aux' env idrefs v, aux' env idrefs t) + | T.Prod (n,s,t) -> + let n' = + match n with + N.Anonymous -> N.Anonymous + | _ -> + if not fake_dependent_products && T.noccurn 1 t then + N.Anonymous + else + N.Name + (Nameops.next_name_away n (Termops.ids_of_context env)) + in + Hashtbl.add ids_to_inner_sorts fresh_id'' + (string_of_sort innertype) ; + let sourcetype = CPropRetyping.get_type_of env evar_map s in + Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') + (string_of_sort sourcetype) ; + let new_passed_prods = + let father_is_prod = + match father with + None -> false + | Some father' -> + match + Term.kind_of_term (Hashtbl.find ids_to_terms father') + with + T.Prod _ -> true + | _ -> false + in + (fresh_id'', n', aux' env idrefs s):: + (if father_is_prod then + passed_lambdas_or_prods_or_letins + else []) + in + let new_env = E.push_rel (n', None, s) env in + let new_idrefs = fresh_id''::idrefs in + (match Term.kind_of_term t with + T.Prod _ -> + aux computeinnertypes (Some fresh_id'') new_passed_prods + new_env new_idrefs t + | _ -> + A.AProds (new_passed_prods, aux' new_env new_idrefs t)) + | T.Lambda (n,s,t) -> + let n' = + match n with + N.Anonymous -> N.Anonymous + | _ -> + N.Name (Nameops.next_name_away n (Termops.ids_of_context env)) + in + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + let sourcetype = CPropRetyping.get_type_of env evar_map s in + Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') + (string_of_sort sourcetype) ; + let father_is_lambda = + match father with + None -> false + | Some father' -> + match + Term.kind_of_term (Hashtbl.find ids_to_terms father') + with + T.Lambda _ -> true + | _ -> false + in + if is_a_Prop innersort && + ((not father_is_lambda) || expected_available) + then add_inner_type fresh_id'' ; + let new_passed_lambdas = + (fresh_id'',n', aux' env idrefs s):: + (if father_is_lambda then + passed_lambdas_or_prods_or_letins + else []) in + let new_env = E.push_rel (n', None, s) env in + let new_idrefs = fresh_id''::idrefs in + (match Term.kind_of_term t with + T.Lambda _ -> + aux computeinnertypes (Some fresh_id'') new_passed_lambdas + new_env new_idrefs t + | _ -> + let t' = aux' new_env new_idrefs t in + (* eta-expansion for explicit named substitutions *) + (* can create nested Lambdas. Here we perform the *) + (* flattening. *) + match t' with + A.ALambdas (lambdas, t'') -> + A.ALambdas (lambdas@new_passed_lambdas, t'') + | _ -> + A.ALambdas (new_passed_lambdas, t') + ) + | T.LetIn (n,s,t,d) -> + let n' = + match n with + N.Anonymous -> N.Anonymous + | _ -> + N.Name (Nameops.next_name_away n (Termops.ids_of_context env)) + in + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + let sourcesort = + get_sort_family_of env evar_map + (CPropRetyping.get_type_of env evar_map s) + in + Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'') + (string_of_sort_family sourcesort) ; + let father_is_letin = + match father with + None -> false + | Some father' -> + match + Term.kind_of_term (Hashtbl.find ids_to_terms father') + with + T.LetIn _ -> true + | _ -> false + in + if is_a_Prop innersort then + add_inner_type fresh_id'' ; + let new_passed_letins = + (fresh_id'',n', aux' env idrefs s):: + (if father_is_letin then + passed_lambdas_or_prods_or_letins + else []) in + let new_env = E.push_rel (n', Some s, t) env in + let new_idrefs = fresh_id''::idrefs in + (match Term.kind_of_term d with + T.LetIn _ -> + aux computeinnertypes (Some fresh_id'') new_passed_letins + new_env new_idrefs d + | _ -> A.ALetIns + (new_passed_letins, aux' new_env new_idrefs d)) + | T.App (h,t) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then + add_inner_type fresh_id'' ; + let + compute_result_if_eta_expansion_not_required subst residual_args + = + let residual_args_not_empty = List.length residual_args > 0 in + let h' = + if residual_args_not_empty then + aux' env idrefs ~subst:(None,subst) h + else + aux' env idrefs ~subst:(Some fresh_id'',subst) h + in + (* maybe all the arguments were used for the explicit *) + (* named substitution *) + if residual_args_not_empty then + A.AApp (fresh_id'', h'::residual_args) + else + h' + in + let t' = + Array.fold_right (fun x i -> (aux' env idrefs x)::i) t [] + in + explicit_substitute_and_eta_expand_if_required h + (Array.to_list t) t' + compute_result_if_eta_expansion_not_required + | T.Const kn -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + let compute_result_if_eta_expansion_not_required _ _ = + A.AConst (fresh_id'', subst, (uri_of_kernel_name kn Constant)) + in + let (_,subst') = subst in + explicit_substitute_and_eta_expand_if_required tt [] + (List.map snd subst') + compute_result_if_eta_expansion_not_required + | T.Ind (kn,i) -> + let compute_result_if_eta_expansion_not_required _ _ = + A.AInd (fresh_id'', subst, (uri_of_kernel_name kn Inductive), i) + in + let (_,subst') = subst in + explicit_substitute_and_eta_expand_if_required tt [] + (List.map snd subst') + compute_result_if_eta_expansion_not_required + | T.Construct ((kn,i),j) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort && expected_available then + add_inner_type fresh_id'' ; + let compute_result_if_eta_expansion_not_required _ _ = + A.AConstruct + (fresh_id'', subst, (uri_of_kernel_name kn Inductive), i, j) + in + let (_,subst') = subst in + explicit_substitute_and_eta_expand_if_required tt [] + (List.map snd subst') + compute_result_if_eta_expansion_not_required + | T.Case ({T.ci_ind=(kn,i)},ty,term,a) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then + add_inner_type fresh_id'' ; + let a' = + Array.fold_right (fun x i -> (aux' env idrefs x)::i) a [] + in + A.ACase + (fresh_id'', (uri_of_kernel_name kn Inductive), i, + aux' env idrefs ty, aux' env idrefs term, a') + | T.Fix ((ai,i),(f,t,b)) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then add_inner_type fresh_id'' ; + let fresh_idrefs = + Array.init (Array.length t) (function _ -> gen_id seed) in + let new_idrefs = + (List.rev (Array.to_list fresh_idrefs)) @ idrefs + in + let f' = + let ids = ref (Termops.ids_of_context env) in + Array.map + (function + N.Anonymous -> Util.error "Anonymous fix function met" + | N.Name id as n -> + let res = N.Name (Nameops.next_name_away n !ids) in + ids := id::!ids ; + res + ) f + in + A.AFix (fresh_id'', i, + Array.fold_right + (fun (id,fi,ti,bi,ai) i -> + let fi' = + match fi with + N.Name fi -> fi + | N.Anonymous -> Util.error "Anonymous fix function met" + in + (id, fi', ai, + aux' env idrefs ti, + aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i) + (Array.mapi + (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j),ai.(j))) f' + ) [] + ) + | T.CoFix (i,(f,t,b)) -> + Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ; + if is_a_Prop innersort then add_inner_type fresh_id'' ; + let fresh_idrefs = + Array.init (Array.length t) (function _ -> gen_id seed) in + let new_idrefs = + (List.rev (Array.to_list fresh_idrefs)) @ idrefs + in + let f' = + let ids = ref (Termops.ids_of_context env) in + Array.map + (function + N.Anonymous -> Util.error "Anonymous fix function met" + | N.Name id as n -> + let res = N.Name (Nameops.next_name_away n !ids) in + ids := id::!ids ; + res + ) f + in + A.ACoFix (fresh_id'', i, + Array.fold_right + (fun (id,fi,ti,bi) i -> + let fi' = + match fi with + N.Name fi -> fi + | N.Anonymous -> Util.error "Anonymous fix function met" + in + (id, fi', + aux' env idrefs ti, + aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i) + (Array.mapi + (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j)) ) f' + ) [] + ) + in + aux computeinnertypes None [] env idrefs t +;; + +let acic_of_cic_context metasenv context t = + let ids_to_terms = Hashtbl.create 503 in + let constr_to_ids = Acic.CicHash.create 503 in + let ids_to_father_ids = Hashtbl.create 503 in + let ids_to_inner_sorts = Hashtbl.create 503 in + let ids_to_inner_types = Hashtbl.create 503 in + let seed = ref 0 in + acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids + ids_to_inner_sorts ids_to_inner_types metasenv context t, + ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types +;; + +let acic_object_of_cic_object pvars sigma obj = + let module A = Acic in + let ids_to_terms = Hashtbl.create 503 in + let constr_to_ids = Acic.CicHash.create 503 in + let ids_to_father_ids = Hashtbl.create 503 in + let ids_to_inner_sorts = Hashtbl.create 503 in + let ids_to_inner_types = Hashtbl.create 503 in + let ids_to_conjectures = Hashtbl.create 11 in + let ids_to_hypotheses = Hashtbl.create 127 in + let hypotheses_seed = ref 0 in + let conjectures_seed = ref 0 in + let seed = ref 0 in + let acic_term_of_cic_term_context' = + acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids + ids_to_inner_sorts ids_to_inner_types pvars in +(*CSC: is this the right env to use? Hhmmm. There is a problem: in *) +(*CSC: Global.env () the object we are exporting is already defined, *) +(*CSC: either in the environment or in the named context (in the case *) +(*CSC: of variables. Is this a problem? *) + let env = Global.env () in + let acic_term_of_cic_term' ?fake_dependent_products = + acic_term_of_cic_term_context' ?fake_dependent_products env [] sigma in +(*CSC: the fresh_id is not stored anywhere. This _MUST_ be fixed using *) +(*CSC: a modified version of the already existent fresh_id function *) + let fresh_id () = + let res = "i" ^ string_of_int !seed in + incr seed ; + res + in + let aobj = + match obj with + A.Constant (id,bo,ty,params) -> + let abo = + match bo with + None -> None + | Some bo' -> Some (acic_term_of_cic_term' bo' (Some ty)) + in + let aty = acic_term_of_cic_term' ty None in + A.AConstant (fresh_id (),id,abo,aty,params) + | A.Variable (id,bo,ty,params) -> + let abo = + match bo with + Some bo -> Some (acic_term_of_cic_term' bo (Some ty)) + | None -> None + in + let aty = acic_term_of_cic_term' ty None in + A.AVariable (fresh_id (),id,abo,aty,params) + | A.CurrentProof (id,conjectures,bo,ty) -> + let aconjectures = + List.map + (function (i,canonical_context,term) as conjecture -> + let cid = "c" ^ string_of_int !conjectures_seed in + Hashtbl.add ids_to_conjectures cid conjecture ; + incr conjectures_seed ; + let canonical_env,idrefs',acanonical_context = + let rec aux env idrefs = + function + [] -> env,idrefs,[] + | ((n,decl_or_def) as hyp)::tl -> + let hid = "h" ^ string_of_int !hypotheses_seed in + let new_idrefs = hid::idrefs in + Hashtbl.add ids_to_hypotheses hid hyp ; + incr hypotheses_seed ; + match decl_or_def with + A.Decl t -> + let final_env,final_idrefs,atl = + aux (Environ.push_rel (Names.Name n,None,t) env) + new_idrefs tl + in + let at = + acic_term_of_cic_term_context' env idrefs sigma t None + in + final_env,final_idrefs,(hid,(n,A.Decl at))::atl + | A.Def (t,ty) -> + let final_env,final_idrefs,atl = + aux + (Environ.push_rel (Names.Name n,Some t,ty) env) + new_idrefs tl + in + let at = + acic_term_of_cic_term_context' env idrefs sigma t None + in + let dummy_never_used = + let s = "dummy_never_used" in + A.ARel (s,99,s,Names.id_of_string s) + in + final_env,final_idrefs, + (hid,(n,A.Def (at,dummy_never_used)))::atl + in + aux env [] canonical_context + in + let aterm = + acic_term_of_cic_term_context' canonical_env idrefs' sigma term + None + in + (cid,i,List.rev acanonical_context,aterm) + ) conjectures in + let abo = acic_term_of_cic_term_context' env [] sigma bo (Some ty) in + let aty = acic_term_of_cic_term_context' env [] sigma ty None in + A.ACurrentProof (fresh_id (),id,aconjectures,abo,aty) + | A.InductiveDefinition (tys,params,paramsno) -> + let env' = + List.fold_right + (fun (name,_,arity,_) env -> + Environ.push_rel (Names.Name name, None, arity) env + ) (List.rev tys) env in + let idrefs = List.map (function _ -> gen_id seed) tys in + let atys = + List.map2 + (fun id (name,inductive,ty,cons) -> + let acons = + List.map + (function (name,ty) -> + (name, + acic_term_of_cic_term_context' ~fake_dependent_products:true + env' idrefs Evd.empty ty None) + ) cons + in + let aty = + acic_term_of_cic_term' ~fake_dependent_products:true ty None + in + (id,name,inductive,aty,acons) + ) (List.rev idrefs) tys + in + A.AInductiveDefinition (fresh_id (),atys,params,paramsno) + in + aobj,ids_to_terms,constr_to_ids,ids_to_father_ids,ids_to_inner_sorts, + ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses +;; diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml new file mode 100644 index 00000000..f0e3f5e3 --- /dev/null +++ b/contrib/xml/doubleTypeInference.ml @@ -0,0 +1,288 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +(*CSC: tutto da rifare!!! Basarsi su Retyping che e' meno costoso! *) +type types = {synthesized : Term.types ; expected : Term.types option};; + +let prerr_endline _ = ();; + +let cprop = + let module N = Names in + N.make_kn + (N.MPfile + (Libnames.dirpath_of_string "CoRN.algebra.CLogic")) + (N.make_dirpath []) + (N.mk_label "CProp") +;; + +let whd_betadeltaiotacprop env evar_map ty = + let module R = Rawterm in + let red_exp = + R.Hnf (*** Instead CProp is made Opaque ***) +(* + R.Cbv + {R.rBeta = true ; R.rIota = true ; R.rDelta = true; R.rZeta=true ; + R.rConst = [Names.EvalConstRef cprop] + } +*) + in +Conv_oracle.set_opaque_const cprop; +prerr_endline "###whd_betadeltaiotacprop:" ; +let xxx = +(*Pp.msgerr (Printer.prterm_env env ty);*) +prerr_endline ""; + Tacred.reduction_of_redexp red_exp env evar_map ty +in +prerr_endline "###FINE" ; +(* +Pp.msgerr (Printer.prterm_env env xxx); +*) +prerr_endline ""; +Conv_oracle.set_transparent_const cprop; +xxx +;; + + +(* Code similar to the code in the Typing module, but: *) +(* - the term is already assumed to be well typed *) +(* - some checks have been removed *) +(* - both the synthesized and expected types of every *) +(* node are computed (Coscoy's double type inference) *) + +let assumption_of_judgment env sigma j = + Typeops.assumption_of_judgment env (Evarutil.j_nf_evar sigma j) +;; + +let type_judgment env sigma j = + Typeops.type_judgment env (Evarutil.j_nf_evar sigma j) +;; + +let type_judgment_cprop env sigma j = + match Term.kind_of_term(whd_betadeltaiotacprop env sigma (Term.body_of_type j.Environ.uj_type)) with + | Term.Sort s -> Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s } + | _ -> None (* None means the CProp constant *) +;; + +let double_type_of env sigma cstr expectedty subterms_to_types = + (*CSC: the code is inefficient because judgments are created just to be *) + (*CSC: destroyed using Environ.j_type. Moreover I am pretty sure that the *) + (*CSC: functions used do checks that we do not need *) + let rec execute env sigma cstr expectedty = + let module T = Term in + let module E = Environ in + (* the type part is the synthesized type *) + let judgement = + match T.kind_of_term cstr with + T.Meta n -> + Util.error + "DoubleTypeInference.double_type_of: found a non-instanciated goal" + + | T.Evar ((n,l) as ev) -> + let ty = Unshare.unshare (Instantiate.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 rec iter actual_args evar_context = + match actual_args,evar_context with + [],[] -> () + | he1::tl1,(n,_,ty)::tl2 -> + (* for side-effects *) + let _ = execute env sigma he1 (Some ty) in + let tl2' = + List.map + (function (m,bo,ty) -> + (* Warning: the substitution should be performed also on bo *) + (* This is not done since bo is not used later yet *) + (m,bo,Unshare.unshare (T.replace_vars [n,he1] ty)) + ) tl2 + in + iter tl1 tl2' + | _,_ -> assert false + in + (* for side effects only *) + iter (List.rev (Array.to_list l)) (List.rev evar_context) ; + E.make_judge cstr jty + + | T.Rel n -> + Typeops.judge_of_relative env n + + | T.Var id -> + Typeops.judge_of_variable env id + + | T.Const c -> + E.make_judge cstr (E.constant_type env c) + + | T.Ind ind -> + E.make_judge cstr (Inductive.type_of_inductive env ind) + + | T.Construct cstruct -> + E.make_judge cstr (Inductive.type_of_constructor env cstruct) + + | T.Case (ci,p,c,lf) -> + let expectedtype = + Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in + let cj = execute env sigma c (Some expectedtype) in + let pj = execute env sigma p None in + let (expectedtypes,_,_) = + let indspec = Inductive.find_rectype env cj.Environ.uj_type in + Inductive.type_case_branches env indspec pj cj.Environ.uj_val + in + let lfj = + execute_array env sigma lf + (Array.map (function x -> Some x) expectedtypes) in + let (j,_) = Typeops.judge_of_case env ci pj cj lfj in + j + + | T.Fix ((vn,i as vni),recdef) -> + let (_,tys,_ as recdef') = execute_recdef env sigma recdef in + let fix = (vni,recdef') in + E.make_judge (T.mkFix fix) tys.(i) + + | T.CoFix (i,recdef) -> + let (_,tys,_ as recdef') = execute_recdef env sigma recdef in + let cofix = (i,recdef') in + E.make_judge (T.mkCoFix cofix) tys.(i) + + | T.Sort (T.Prop c) -> + Typeops.judge_of_prop_contents c + + | T.Sort (T.Type u) -> +(*CSC: In case of need, I refresh the universe. But exportation of the *) +(*CSC: right universe level information is destroyed. It must be changed *) +(*CSC: again once Judicael will introduce his non-bugged algebraic *) +(*CSC: universes. *) +(try + Typeops.judge_of_type u + with _ -> (* Successor of a non universe-variable universe anomaly *) + (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ; + Typeops.judge_of_type (Termops.new_univ ()) +) + + | T.App (f,args) -> + let expected_head = + Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in + let j = execute env sigma f (Some expected_head) in + let expected_args = + let rec aux typ = + function + [] -> [] + | hj::restjl -> + match T.kind_of_term (Reduction.whd_betadeltaiota env typ) with + T.Prod (_,c1,c2) -> + (Some (Reductionops.nf_beta c1)) :: + (aux (T.subst1 hj c2) restjl) + | _ -> assert false + in + Array.of_list (aux j.Environ.uj_type (Array.to_list args)) + in + let jl = execute_array env sigma args expected_args in + let (j,_) = Typeops.judge_of_apply env j jl in + j + + | T.Lambda (name,c1,c2) -> + let j = execute env sigma c1 None in + let var = type_judgment env sigma j in + let env1 = E.push_rel (name,None,var.E.utj_val) env in + let expectedc2type = + match expectedty with + None -> None + | Some ety -> + match T.kind_of_term (Reduction.whd_betadeltaiota env ety) with + T.Prod (_,_,expected_target_type) -> + Some (Reductionops.nf_beta expected_target_type) + | _ -> assert false + in + let j' = execute env1 sigma c2 expectedc2type in + Typeops.judge_of_abstraction env1 name var j' + + | T.Prod (name,c1,c2) -> + let j = execute env sigma c1 None in + let varj = type_judgment env sigma j in + let env1 = E.push_rel (name,None,varj.E.utj_val) env in + let j' = execute env1 sigma c2 None in + (match type_judgment_cprop env1 sigma j' with + Some varj' -> Typeops.judge_of_product env name varj varj' + | None -> + (* CProp found *) + { Environ.uj_val = T.mkProd (name, j.Environ.uj_val, j'.Environ.uj_val); + Environ.uj_type = T.mkConst cprop }) + + | T.LetIn (name,c1,c2,c3) -> +(*CSC: What are the right expected types for the source and *) +(*CSC: target of a LetIn? None used. *) + let j1 = execute env sigma c1 None in + let j2 = execute env sigma c2 None in + let j2 = type_judgment env sigma j2 in + let env1 = + E.push_rel (name,Some j1.E.uj_val,j2.E.utj_val) env + in + let j3 = execute env1 sigma c3 None in + Typeops.judge_of_letin env name j1 j2 j3 + + | T.Cast (c,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 + j + in + let synthesized = E.j_type judgement in + let synthesized' = Reductionops.nf_beta synthesized in + let types,res = + match expectedty with + 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 + | 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 ) ; + Acic.CicHash.add subterms_to_types cstr types ; + E.make_judge cstr res + + + and execute_recdef env sigma (names,lar,vdef) = + let length = Array.length lar in + let larj = + execute_array env sigma lar (Array.make length None) in + let lara = Array.map (assumption_of_judgment env sigma) larj in + let env1 = Environ.push_rec_types (names,lara,vdef) env in + let expectedtypes = + Array.map (function i -> Some (Term.lift length i)) lar + in + let vdefj = execute_array env1 sigma vdef expectedtypes in + let vdefv = Array.map Environ.j_val vdefj in + (names,lara,vdefv) + + and execute_array env sigma v expectedtypes = + let jl = + execute_list env sigma (Array.to_list v) (Array.to_list expectedtypes) + in + Array.of_list jl + + and execute_list env sigma = + List.map2 (execute env sigma) + +in + ignore (execute env sigma cstr expectedty) +;; diff --git a/contrib/xml/doubleTypeInference.mli b/contrib/xml/doubleTypeInference.mli new file mode 100644 index 00000000..33d3e5cd --- /dev/null +++ b/contrib/xml/doubleTypeInference.mli @@ -0,0 +1,24 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +type types = { synthesized : Term.types; expected : Term.types option; } + +val cprop : Names.kernel_name + +val whd_betadeltaiotacprop : + Environ.env -> Evd.evar_map -> Term.constr -> Term.constr + +val double_type_of : + Environ.env -> Evd.evar_map -> Term.constr -> Term.constr option -> + types Acic.CicHash.t -> unit diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml new file mode 100644 index 00000000..165a456d --- /dev/null +++ b/contrib/xml/proof2aproof.ml @@ -0,0 +1,169 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +(* Note: we can not use the Set module here because we _need_ physical *) +(* equality and there exists no comparison function compatible with *) +(* physical equality. *) + +module S = + struct + let empty = [] + let mem = List.memq + let add x l = x::l + end +;; + +(* evar reduction that preserves some terms *) +let nf_evar sigma ~preserve = + let module T = Term in + let rec aux t = + if preserve t then t else + match T.kind_of_term t with + | T.Rel _ | T.Meta _ | T.Var _ | T.Sort _ | T.Const _ | T.Ind _ + | T.Construct _ -> t + | T.Cast (c1,c2) -> T.mkCast (aux c1, aux c2) + | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2) + | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c) + | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c) + | T.App (c,l) -> + let c' = aux c in + let l' = Array.map aux l in + (match T.kind_of_term c' with + T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l') + | T.Cast (he,_) -> + (match T.kind_of_term he with + T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l') + | _ -> T.mkApp (c', l') + ) + | _ -> T.mkApp (c', l')) + | T.Evar (e,l) when Evd.in_dom sigma e & Evd.is_defined sigma e -> + aux (Instantiate.existential_value sigma (e,l)) + | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l) + | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl) + | T.Fix (ln,(lna,tl,bl)) -> + T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl)) + | T.CoFix(ln,(lna,tl,bl)) -> + T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl)) + in + aux +;; + +(* Unshares a proof-tree. *) +(* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *) +let rec unshare_proof_tree = + let module PT = Proof_type in + function {PT.open_subgoals = status ; PT.goal = goal ; PT.ref = ref} -> + let unshared_ref = + match ref with + None -> None + | Some (rule,pfs) -> + let unshared_rule = + match rule with + PT.Prim prim -> PT.Prim prim + | PT.Change_evars -> PT.Change_evars + | PT.Tactic (tactic_expr, pf) -> + PT.Tactic (tactic_expr, unshare_proof_tree pf) + in + Some (unshared_rule, List.map unshare_proof_tree pfs) + in + {PT.open_subgoals = status ; PT.goal = goal ; PT.ref = unshared_ref} +;; + +module ProofTreeHash = + Hashtbl.Make + (struct + type t = Proof_type.proof_tree + let equal = (==) + let hash = Hashtbl.hash + end) +;; + + +let extract_open_proof sigma pf = + let module PT = Proof_type in + let module L = Logic in + let sigma = ref sigma in + let proof_tree_to_constr = ProofTreeHash.create 503 in + let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in + let unshared_constrs = ref S.empty in + let rec proof_extractor vl node = + let constr = + match node with + {PT.ref=Some(PT.Prim _,_)} as pf -> + L.prim_extractor proof_extractor vl pf + + | {PT.ref=Some(PT.Tactic (_,hidden_proof),spfl)} -> + let sgl,v = Refiner.frontier hidden_proof in + let flat_proof = v spfl in + ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ; + proof_extractor vl flat_proof + + | {PT.ref=Some(PT.Change_evars,[pf])} -> (proof_extractor vl) pf + + | {PT.ref=None;PT.goal=goal} -> + let visible_rels = + Util.map_succeed + (fun id -> + (* Section variables are in the [id] list but are not *) + (* lambda abstracted in the term [vl] *) + try let n = Util.list_index id vl in (n,id) + 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 + 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 + 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' ; + 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 + in + Unshare.unshare + ~already_unshared:(function e -> S.mem e !unshared_constrs) + evar_nf_constr + in +(*CSC: debugging stuff to be removed *) +if ProofTreeHash.mem proof_tree_to_constr node then + Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ") (Refiner.print_proof !sigma [] 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, + unshared_pf) +;; + +let extract_open_pftreestate pts = + extract_open_proof (Refiner.evc_of_pftreestate pts) + (Tacmach.proof_of_pftreestate pts) +;; diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4 new file mode 100644 index 00000000..b9b66774 --- /dev/null +++ b/contrib/xml/proofTree2Xml.ml4 @@ -0,0 +1,211 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";; + +let std_ppcmds_to_string s = + Pp.msg_with Format.str_formatter s; + Format.flush_str_formatter () +;; + +let idref_of_id id = "v" ^ id;; + +(* Transform a constr to an Xml.token Stream.t *) +(* env is a named context *) +(*CSC: in verita' dovrei "separare" le variabili vere e lasciarle come Var! *) +let constr_to_xml obj sigma env = + let ids_to_terms = Hashtbl.create 503 in + let constr_to_ids = Acic.CicHash.create 503 in + let ids_to_father_ids = Hashtbl.create 503 in + let ids_to_inner_sorts = Hashtbl.create 503 in + let ids_to_inner_types = Hashtbl.create 503 in + + let pvars = [] in + (* named_context holds section variables and local variables *) + let named_context = Environ.named_context env in + (* real_named_context holds only the section variables *) + let real_named_context = Environ.named_context (Global.env ()) in + (* named_context' holds only the local variables *) + let named_context' = + List.filter (function n -> not (List.mem n real_named_context)) named_context + in + let idrefs = + List.map + (function x,_,_ -> idref_of_id (Names.string_of_id x)) named_context' in + let rel_context = Sign.push_named_to_rel_context named_context' [] in + let rel_env = + Environ.push_rel_context rel_context + (Environ.reset_with_named_context real_named_context env) in + let obj' = + Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in + let seed = ref 0 in + try + let annobj = + Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids + ids_to_father_ids ids_to_inner_sorts ids_to_inner_types pvars rel_env + idrefs sigma (Unshare.unshare obj') None + in + Acic2Xml.print_term ids_to_inner_sorts annobj + with e -> + Util.anomaly + ("Problem during the conversion of constr into XML: " ^ + Printexc.to_string e) +(* CSC: debugging stuff +Pp.ppnl (Pp.str "Problem during the conversion of constr into XML") ; +Pp.ppnl (Pp.str "ENVIRONMENT:") ; +Pp.ppnl (Printer.pr_context_of rel_env) ; +Pp.ppnl (Pp.str "TERM:") ; +Pp.ppnl (Printer.prterm_env rel_env obj') ; +Pp.ppnl (Pp.str "RAW-TERM:") ; +Pp.ppnl (Printer.prterm obj') ; +Xml.xml_empty "MISSING TERM" [] (*; raise e*) +*) +;; + +let first_word s = + try let i = String.index s ' ' in + String.sub s 0 i + with _ -> s +;; + +let string_of_prim_rule x = match x with + | Proof_type.Intro _-> "Intro" + | Proof_type.Intro_replacing _-> "Intro_replacing" + | Proof_type.Cut (_,_,_) -> "Cut" + | Proof_type.FixRule (_,_,_) -> "FixRule" + | Proof_type.Cofix (_,_)-> "Cofix" + | Proof_type.Refine _ -> "Refine" + | Proof_type.Convert_concl _ -> "Convert_concl" + | Proof_type.Convert_hyp _->"Convert_hyp" + | Proof_type.Thin _ -> "Thin" + | Proof_type.ThinBody _-> "ThinBody" + | Proof_type.Move (_,_,_) -> "Move" + | Proof_type.Rename (_,_) -> "Rename" + + +let + print_proof_tree curi sigma0 pf proof_tree_to_constr + proof_tree_to_flattened_proof_tree constr_to_ids += + let module PT = Proof_type in + let module L = Logic in + let module X = Xml in + let module T = Tacexpr in + let ids_of_node node = + let constr = Proof2aproof.ProofTreeHash.find proof_tree_to_constr node in +(* +let constr = + try + Proof2aproof.ProofTreeHash.find proof_tree_to_constr node + with _ -> Pp.ppnl (Pp.(++) (Pp.str "Node of the proof-tree that generated +no lambda-term: ") (Refiner.print_script true (Evd.empty) +(Global.named_context ()) node)) ; assert false (* Closed bug, should not +happen any more *) +in +*) + try + Some (Acic.CicHash.find constr_to_ids constr) + with _ -> +Pp.ppnl (Pp.(++) (Pp.str +"The_generated_term_is_not_a_subterm_of_the_final_lambda_term") +(Printer.prterm constr)) ; + None + in + let rec aux node old_hyps = + let of_attribute = + match ids_of_node node with + None -> [] + | Some id -> ["of",id] + in + match node with + {PT.ref=Some(PT.Prim tactic_expr,nodes)} -> + let tac = string_of_prim_rule tactic_expr in + let of_attribute = ("name",tac)::of_attribute in + if nodes = [] then + X.xml_empty "Prim" of_attribute + else + X.xml_nempty "Prim" of_attribute + (List.fold_left + (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) + + | {PT.goal=goal; + PT.ref=Some(PT.Tactic (tactic_expr,hidden_proof),nodes)} -> + (* [hidden_proof] is the proof of the tactic; *) + (* [nodes] are the proof of the subgoals generated by the tactic; *) + (* [flat_proof] if the proof-tree obtained substituting [nodes] *) + (* for the holes in [hidden_proof] *) + let flat_proof = + Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node + in begin + match tactic_expr with + | T.TacArg (T.Tacexp _) -> + (* We don't need to keep the level of abstraction introduced at *) + (* user-level invocation of tactic... (see Tacinterp.hide_interp)*) + aux flat_proof old_hyps + | _ -> + (****** la tactique employee *) + let prtac = if !Options.v7 then Pptactic.pr_tactic else Pptacticnew.pr_tactic (Global.env()) in + let tac = std_ppcmds_to_string (prtac tactic_expr) in + let tacname= first_word tac in + let of_attribute = ("name",tacname)::("script",tac)::of_attribute in + + (****** le but *) + let {Evd.evar_concl=concl; + Evd.evar_hyps=hyps}=goal in + + let 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 xgoal = + X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in + + let rec build_hyps = + function + | [] -> xgoal + | (id,c,tid)::hyps1 -> + let id' = Names.string_of_id id in + [< build_hyps hyps1; + (X.xml_nempty "Hypothesis" + ["id",idref_of_id id' ; "name",id'] + (constr_to_xml tid sigma env)) + >] in + let old_names = List.map (fun (id,c,tid)->id) old_hyps in + let new_hyps = + List.filter (fun (id,c,tid)-> not (List.mem id old_names)) hyps in + + X.xml_nempty "Tactic" of_attribute + [<(build_hyps new_hyps) ; (aux flat_proof hyps)>] + end + + | {PT.ref=Some(PT.Change_evars,nodes)} -> + X.xml_nempty "Change_evars" of_attribute + (List.fold_left + (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) + + | {PT.ref=None;PT.goal=goal} -> + X.xml_empty "Open_goal" of_attribute + in + [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; + X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n"); + X.xml_nempty "ProofTree" ["of",curi] (aux pf []) + >] +;; + + +(* Hook registration *) +(* CSC: debranched since it is bugged +Xmlcommand.set_print_proof_tree print_proof_tree;; +*) diff --git a/contrib/xml/theoryobject.dtd b/contrib/xml/theoryobject.dtd new file mode 100644 index 00000000..953fe009 --- /dev/null +++ b/contrib/xml/theoryobject.dtd @@ -0,0 +1,62 @@ +<?xml encoding="ISO-8859-1"?> + +<!-- Copyright (C) 2000-2004, HELM Team --> +<!-- --> +<!-- This file is part of HELM, an Hypertextual, Electronic --> +<!-- Library of Mathematics, developed at the Computer Science --> +<!-- Department, University of Bologna, Italy. --> +<!-- --> +<!-- HELM is free software; you can redistribute it and/or --> +<!-- modify it under the terms of the GNU General Public License --> +<!-- as published by the Free Software Foundation; either version 2 --> +<!-- of the License, or (at your option) any later version. --> +<!-- --> +<!-- HELM is distributed in the hope that it will be useful, --> +<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of --> +<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --> +<!-- GNU General Public License for more details. --> +<!-- --> +<!-- You should have received a copy of the GNU General Public License --> +<!-- along with HELM; if not, write to the Free Software --> +<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, --> +<!-- MA 02111-1307, USA. --> +<!-- --> +<!-- For details, see the HELM World-Wide-Web page, --> +<!-- http://cs.unibo.it/helm/. --> + + + +<!-- Notice: the markup described in this DTD is meant to be embedded --> +<!-- in foreign markup (e.g. XHTML) --> + +<!ENTITY % theorystructure + '(ht:AXIOM|ht:DEFINITION|ht:THEOREM|ht:VARIABLE|ht:SECTION|ht:MUTUAL)*'> + +<!ELEMENT ht:SECTION (%theorystructure;)> +<!ATTLIST ht:SECTION + uri CDATA #REQUIRED> + +<!ELEMENT ht:MUTUAL (ht:DEFINITION,ht:DEFINITION+)> + +<!-- Theory Items --> + +<!ELEMENT ht:AXIOM (Axiom)> +<!ATTLIST ht:AXIOM + uri CDATA #REQUIRED + as (Axiom|Declaration) #REQUIRED> + +<!ELEMENT ht:DEFINITION (Definition|InductiveDefinition)> +<!ATTLIST ht:DEFINITION + uri CDATA #REQUIRED + as (Definition|InteractiveDefinition|Inductive|CoInductive + |Record) #REQUIRED> + +<!ELEMENT ht:THEOREM (type)> +<!ATTLIST ht:THEOREM + uri CDATA #REQUIRED + as (Theorem|Lemma|Corollary|Fact|Remark) #REQUIRED> + +<!ELEMENT ht:VARIABLE (Variable)> +<!ATTLIST ht:VARIABLE + uri CDATA #REQUIRED + as (Assumption|Hypothesis|LocalDefinition|LocalFact) #REQUIRED> diff --git a/contrib/xml/unshare.ml b/contrib/xml/unshare.ml new file mode 100644 index 00000000..f30f8230 --- /dev/null +++ b/contrib/xml/unshare.ml @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +exception CanNotUnshare;; + +(* [unshare t] gives back a copy of t where all sharing has been removed *) +(* Physical equality becomes meaningful on unshared terms. Hashtables that *) +(* use physical equality can now be used to associate information to evey *) +(* node of the term. *) +let unshare ?(already_unshared = function _ -> false) t = + let obj = Obj.repr t in + let rec aux obj = + if already_unshared (Obj.obj obj) then + obj + else + (if Obj.is_int obj then + obj + else if Obj.is_block obj then + begin + let tag = Obj.tag obj in + if tag < Obj.no_scan_tag then + begin + let size = Obj.size obj in + let new_obj = Obj.new_block 0 size in + Obj.set_tag new_obj tag ; + for i = 0 to size - 1 do + Obj.set_field new_obj i (aux (Obj.field obj i)) + done ; + new_obj + end + else if tag = Obj.string_tag then + obj + else + raise CanNotUnshare + end + else + raise CanNotUnshare + ) + in + Obj.obj (aux obj) +;; diff --git a/contrib/xml/unshare.mli b/contrib/xml/unshare.mli new file mode 100644 index 00000000..31ba9037 --- /dev/null +++ b/contrib/xml/unshare.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +exception CanNotUnshare;; + +(* [unshare t] gives back a copy of t where all sharing has been removed *) +(* Physical equality becomes meaningful on unshared terms. Hashtables that *) +(* use physical equality can now be used to associate information to evey *) +(* node of the term. *) +val unshare: ?already_unshared:('a -> bool) -> 'a -> 'a diff --git a/contrib/xml/xml.ml4 b/contrib/xml/xml.ml4 new file mode 100644 index 00000000..d0c64f30 --- /dev/null +++ b/contrib/xml/xml.ml4 @@ -0,0 +1,73 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +(* the type token for XML cdata, empty elements and not-empty elements *) +(* Usage: *) +(* Str cdata *) +(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *) +(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *) +(* content *) +type token = Str of string + | Empty of string * (string * string) list + | NEmpty of string * (string * string) list * token Stream.t +;; + +(* currified versions of the constructors make the code more readable *) +let xml_empty name attrs = [< 'Empty(name,attrs) >] +let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >] +let xml_cdata str = [< 'Str str >] + +(* Usage: *) +(* pp tokens None pretty prints the output on stdout *) +(* pp tokens (Some filename) pretty prints the output on the file filename *) +let pp strm fn = + let channel = ref stdout in + let rec pp_r m = + parser + [< 'Str a ; s >] -> + print_spaces m ; + fprint_string (a ^ "\n") ; + pp_r m s + | [< 'Empty(n,l) ; s >] -> + print_spaces m ; + fprint_string ("<" ^ n) ; + List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; + fprint_string "/>\n" ; + pp_r m s + | [< 'NEmpty(n,l,c) ; s >] -> + print_spaces m ; + fprint_string ("<" ^ n) ; + List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l; + fprint_string ">\n" ; + pp_r (m+1) c ; + print_spaces m ; + fprint_string ("</" ^ n ^ ">\n") ; + pp_r m s + | [< >] -> () + and print_spaces m = + for i = 1 to m do fprint_string " " done + and fprint_string str = + output_string !channel str + in + match fn with + Some filename -> + let filename = filename ^ ".xml" in + channel := open_out filename ; + pp_r 0 strm ; + close_out !channel ; + print_string ("\nWriting on file \"" ^ filename ^ "\" was succesful\n"); + flush stdout + | None -> + pp_r 0 strm +;; diff --git a/contrib/xml/xml.mli b/contrib/xml/xml.mli new file mode 100644 index 00000000..e65e6c81 --- /dev/null +++ b/contrib/xml/xml.mli @@ -0,0 +1,38 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +(*i $Id: xml.mli,v 1.5.2.2 2004/07/16 19:30:15 herbelin Exp $ i*) + +(* Tokens for XML cdata, empty elements and not-empty elements *) +(* Usage: *) +(* Str cdata *) +(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *) +(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *) +(* content *) +type token = + | Str of string + | Empty of string * (string * string) list + | NEmpty of string * (string * string) list * token Stream.t + +(* currified versions of the token constructors make the code more readable *) +val xml_empty : string -> (string * string) list -> token Stream.t +val xml_nempty : + string -> (string * string) list -> token Stream.t -> token Stream.t +val xml_cdata : string -> token Stream.t + +(* The pretty printer for streams of token *) +(* Usage: *) +(* pp tokens None pretty prints the output on stdout *) +(* pp tokens (Some filename) pretty prints the output on the file filename *) +val pp : token Stream.t -> string option -> unit diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml new file mode 100644 index 00000000..9fba5474 --- /dev/null +++ b/contrib/xml/xmlcommand.ml @@ -0,0 +1,706 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +(* CONFIGURATION PARAMETERS *) + +let verbose = ref false;; + +(* HOOKS *) +let print_proof_tree, set_print_proof_tree = + let print_proof_tree = ref (fun _ _ _ _ _ _ -> None) in + (fun () -> !print_proof_tree), + (fun f -> + print_proof_tree := + fun + curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree + constr_to_ids + -> + Some + (f curi sigma0 pf proof_tree_to_constr + proof_tree_to_flattened_proof_tree constr_to_ids)) +;; + +(* UTILITY FUNCTIONS *) + +let print_if_verbose s = if !verbose then print_string s;; + +(* Next exception is used only inside print_coq_object and tag_of_string_tag *) +exception Uninteresting;; + +(* Internally, for Coq V7, params of inductive types are associated *) +(* not to the whole block of mutual inductive (as it was in V6) but to *) +(* each member of the block; but externally, all params are required *) +(* to be the same; the following function checks that the parameters *) +(* of each inductive of a same block are all the same, then returns *) +(* this number; it fails otherwise *) +let extract_nparams pack = + let module D = Declarations in + let module U = Util in + let module S = Sign in + + let {D.mind_nparams=nparams0} = pack.(0) in + let arity0 = pack.(0).D.mind_user_arity in + let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in + for i = 1 to Array.length pack - 1 do + let {D.mind_nparams=nparamsi} = pack.(i) in + let arityi = pack.(i).D.mind_user_arity in + let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in + if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block" + done; + nparams0 + +(* could_have_namesakes sp = true iff o is an object that could be cooked and *) +(* than that could exists in cooked form with the same name in a super *) +(* section of the actual section *) +let could_have_namesakes o sp = (* namesake = omonimo in italian *) + let module DK = Decl_kinds in + let module D = Declare in + let tag = Libobject.object_tag o in + print_if_verbose ("Object tag: " ^ tag ^ "\n") ; + match tag with + "CONSTANT" -> + (match D.constant_strength sp with + | DK.Local -> false (* a local definition *) + | DK.Global -> true (* a non-local one *) + ) + | "INDUCTIVE" -> true (* mutual inductive types are never local *) + | "VARIABLE" -> false (* variables are local, so no namesakes *) + | _ -> false (* uninteresting thing that won't be printed*) +;; + + +(* A SIMPLE DATA STRUCTURE AND SOME FUNCTIONS TO MANAGE THE CURRENT *) +(* ENVIRONMENT (= [(name1,l1); ...;(namen,ln)] WHERE li IS THE LIST *) +(* OF VARIABLES DECLARED IN THE i-th SUPER-SECTION OF THE CURRENT *) +(* SECTION, WHOSE PATH IS namei *) + +let pvars = + ref ([Names.id_of_string "",[]] : (Names.identifier * string list) list);; +let cumenv = ref Environ.empty_env;; + +(* filter_params pvars hyps *) +(* filters out from pvars (which is a list of lists) all the variables *) +(* that does not belong to hyps (which is a simple list) *) +(* It returns a list of couples relative section path -- list of *) +(* variable names. *) +let filter_params pvars hyps = + let rec aux ids = + function + [] -> [] + | (id,he)::tl -> + let ids' = id::ids in + let ids'' = + "cic:/" ^ + String.concat "/" (List.rev (List.map Names.string_of_id ids')) in + let he' = + ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in + let tl' = aux ids' tl in + match he' with + _,[] -> tl' + | _,_ -> he'::tl' + in + let cwd = Lib.cwd () in + let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in + let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in + aux (Names.repr_dirpath modulepath) (List.rev pvars) +;; + +type variables_type = + Definition of string * Term.constr * Term.types + | Assumption of string * Term.constr +;; + +let add_to_pvars x = + let module E = Environ in + let v = + match x with + Definition (v, bod, typ) -> + cumenv := + E.push_named (Names.id_of_string v, Some bod, typ) !cumenv ; + v + | Assumption (v, typ) -> + cumenv := + E.push_named (Names.id_of_string v, None, typ) !cumenv ; + v + in + match !pvars with + [] -> assert false + | ((name,l)::tl) -> pvars := (name,v::l)::tl +;; + +(* The computation is very inefficient, but we can't do anything *) +(* better unless this function is reimplemented in the Declare *) +(* module. *) +let search_variables () = + let module N = Names in + let cwd = Lib.cwd () in + let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in + let modulepath = Cic2acic.get_module_path_of_section_path cwdsp in + let rec aux = + function + [] -> [] + | he::tl as modules -> + let one_section_variables = + let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in + let t = List.map N.string_of_id (Declare.last_section_hyps dirpath) in + [he,t] + in + one_section_variables @ aux tl + in + aux + (Cic2acic.remove_module_dirpath_from_dirpath + ~basedir:modulepath cwd) +;; + +(* FUNCTIONS TO PRINT A SINGLE OBJECT OF COQ *) + +let rec join_dirs cwd = + function + [] -> cwd + | he::tail -> + (try + Unix.mkdir cwd 0o775 + with _ -> () (* Let's ignore the errors on mkdir *) + ) ; + let newcwd = cwd ^ "/" ^ he in + join_dirs newcwd tail +;; + +let filename_of_path xml_library_root kn 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 + Some (join_dirs xml_library_root' tokens) +;; + +let body_filename_of_filename = + function + Some f -> Some (f ^ ".body") + | None -> None +;; + +let types_filename_of_filename = + function + Some f -> Some (f ^ ".types") + | None -> None +;; + +let prooftree_filename_of_filename = + function + Some f -> Some (f ^ ".proof_tree") + | None -> None +;; + +let theory_filename xml_library_root = + let module N = Names in + match xml_library_root with + None -> None (* stdout *) + | Some xml_library_root' -> + let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in + 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") + +let print_object uri obj sigma proof_tree_infos filename = + (* function to pretty print and compress an XML file *) +(*CSC: Unix.system "gzip ..." is an horrible non-portable solution. *) + let pp xml filename = + Xml.pp xml filename ; + match filename with + None -> () + | Some fn -> + let fn' = + let rec escape s n = + try + let p = String.index_from s n '\'' in + String.sub s n (p - n) ^ "\\'" ^ escape s (p+1) + with Not_found -> String.sub s n (String.length s - n) + in + escape fn 0 + in + ignore (Unix.system ("gzip " ^ fn' ^ ".xml")) + in + let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) = + Cic2acic.acic_object_of_cic_object !pvars sigma obj in + let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in + let xmltypes = + Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in + pp xml filename ; + begin + match xml' with + None -> () + | Some xml' -> pp xml' (body_filename_of_filename filename) + end ; + pp xmltypes (types_filename_of_filename filename) ; + match proof_tree_infos with + None -> () + | Some (sigma0,proof_tree,proof_tree_to_constr, + proof_tree_to_flattened_proof_tree) -> + let xmlprooftree = + print_proof_tree () + uri sigma0 proof_tree proof_tree_to_constr + proof_tree_to_flattened_proof_tree constr_to_ids + in + match xmlprooftree with + None -> () + | Some xmlprooftree -> + pp xmlprooftree (prooftree_filename_of_filename filename) +;; + +let string_list_of_named_context_list = + List.map + (function (n,_,_) -> Names.string_of_id n) +;; + +(* Function to collect the variables that occur in a term. *) +(* Used only for variables (since for constants and mutual *) +(* inductive types this information is already available. *) +let find_hyps t = + let module T = Term in + let rec aux l t = + match T.kind_of_term t with + T.Var id when not (List.mem id l) -> + let (_,bo,ty) = Global.lookup_named id in + let boids = + match bo with + Some bo' -> aux l bo' + | None -> l + in + id::(aux boids ty) + | T.Var _ + | T.Rel _ + | T.Meta _ + | T.Evar _ + | T.Sort _ -> l + | T.Cast (te,ty) -> aux (aux l te) ty + | T.Prod (_,s,t) -> aux (aux l s) t + | T.Lambda (_,s,t) -> aux (aux l s) t + | T.LetIn (_,s,_,t) -> aux (aux l s) t + | T.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl + | T.Const con -> + let hyps = (Global.lookup_constant con).Declarations.const_hyps in + map_and_filter l hyps @ l + | T.Ind ind + | T.Construct (ind,_) -> + let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in + map_and_filter l hyps @ l + | T.Case (_,t1,t2,b) -> + Array.fold_left (fun i x -> aux i x) (aux (aux l t1) t2) b + | T.Fix (_,(_,tys,bodies)) + | T.CoFix (_,(_,tys,bodies)) -> + let r = Array.fold_left (fun i x -> aux i x) l tys in + Array.fold_left (fun i x -> aux i x) r bodies + and map_and_filter l = + function + [] -> [] + | (n,_,_)::tl when not (List.mem n l) -> n::(map_and_filter l tl) + | _::tl -> map_and_filter l tl + in + aux [] t +;; + +(* Functions to construct an object *) + +let mk_variable_obj id body typ = + let hyps,unsharedbody = + match body with + None -> [],None + | Some bo -> find_hyps bo, Some (Unshare.unshare bo) + in + let hyps' = find_hyps typ @ hyps in + let hyps'' = List.map Names.string_of_id hyps' in + let variables = search_variables () in + let params = filter_params variables hyps'' in + Acic.Variable + (Names.string_of_id id, unsharedbody, + (Unshare.unshare (Term.body_of_type typ)), params) +;; + +(* Unsharing is not performed on the body, that must be already unshared. *) +(* The evar map and the type, instead, are unshared by this function. *) +let mk_current_proof_obj is_a_variable id bo ty evar_map env = + let unshared_ty = Unshare.unshare (Term.body_of_type ty) in + let metasenv = + List.map + (function + (n, {Evd.evar_concl = evar_concl ; + Evd.evar_hyps = evar_hyps} + ) -> + (* We map the named context to a rel context and every Var to a Rel *) + let final_var_ids,context = + let rec aux var_ids = + function + [] -> var_ids,[] + | (n,None,t)::tl -> + let final_var_ids,tl' = aux (n::var_ids) tl in + let t' = Term.subst_vars var_ids t in + final_var_ids,(n, Acic.Decl (Unshare.unshare t'))::tl' + | (n,Some b,t)::tl -> + let final_var_ids,tl' = aux (n::var_ids) tl in + let b' = Term.subst_vars var_ids b in + (* t will not be exported to XML. Thus no unsharing performed *) + final_var_ids,(n, Acic.Def (Unshare.unshare b',t))::tl' + in + aux [] (List.rev 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) + in + let id' = Names.string_of_id id in + if metasenv = [] then + let ids = + Names.Idset.union + (Environ.global_vars_set env bo) (Environ.global_vars_set env ty) in + let hyps0 = Environ.keep_hyps env ids in + let hyps = string_list_of_named_context_list hyps0 in + (* Variables are the identifiers of the variables in scope *) + let variables = search_variables () in + let params = filter_params variables hyps in + if is_a_variable then + Acic.Variable (id',Some bo,unshared_ty,params) + else + Acic.Constant (id',Some bo,unshared_ty,params) + else + Acic.CurrentProof (id',metasenv,bo,unshared_ty) +;; + +let mk_constant_obj id bo ty variables hyps = + let hyps = string_list_of_named_context_list hyps in + let ty = Unshare.unshare (Term.body_of_type ty) in + let params = filter_params variables hyps in + match bo with + None -> + Acic.Constant (Names.string_of_id id,None,ty,params) + | Some c -> + Acic.Constant + (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)), + ty,params) +;; + +let mk_inductive_obj sp packs variables hyps finite = + let module D = Declarations in + let hyps = string_list_of_named_context_list hyps in + let params = filter_params variables hyps in + let nparams = extract_nparams packs in + let tys = + let tyno = ref (Array.length packs) in + Array.fold_right + (fun p i -> + decr tyno ; + let {D.mind_consnames=consnames ; + D.mind_typename=typename ; + D.mind_nf_arity=arity} = p + in + let lc = Inductive.arities_of_constructors (Global.env ()) (sp,!tyno) in + let cons = + (Array.fold_right (fun (name,lc) i -> (name,lc)::i) + (Array.mapi + (fun j x ->(x,Unshare.unshare (Term.body_of_type lc.(j)))) consnames) + [] + ) + in + (typename,finite,Unshare.unshare arity,cons)::i + ) packs [] + in + Acic.InductiveDefinition (tys,params,nparams) +;; + +(* The current channel for .theory files *) +let theory_buffer = Buffer.create 4000;; + +let theory_output_string ?(do_not_quote = false) s = + (* prepare for coqdoc post-processing *) + let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in + print_if_verbose s; + Buffer.add_string theory_buffer s +;; + +let kind_of_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 + +let kind_of_inductive isrecord kn = + "DEFINITION", + if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite + then if isrecord then "Record" else "Inductive" + else "CoInductive" +;; + +let kind_of_variable id = + let module DK = Decl_kinds in + match Declare.variable_kind id with + | 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" +;; + +let kind_of_constant kn = + let module DK = Decl_kinds in + match Declare.constant_kind (Nametab.sp_of_global(Libnames.ConstRef kn)) with + | 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 +;; + +let kind_of_global r = + let module Ln = Libnames in + let module DK = Decl_kinds in + match r with + | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> + let isrecord = + try let _ = Recordops.find_structure kn in true + with Not_found -> false in + kind_of_inductive isrecord (fst kn) + | Ln.VarRef id -> kind_of_variable id + | Ln.ConstRef kn -> kind_of_constant kn +;; + +let print_object_kind uri (xmltag,variation) = + let s = + Printf.sprintf "<ht:%s uri=\"%s\" as=\"%s\"/>\n" xmltag uri variation + in + theory_output_string s +;; + +(* print id dest *) +(* where sp is the qualified identifier (section path) of a *) +(* definition/theorem, variable or inductive definition *) +(* and dest is either None (for stdout) or (Some filename) *) +(* pretty prints via Xml.pp the object whose identifier is id on dest *) +(* Note: it is printed only (and directly) the most cooked available *) +(* form of the definition (all the parameters are *) +(* lambda-abstracted, but the object can still refer to variables) *) +let print internal glob_ref kind xml_library_root = + let module D = Declarations in + let module De = Declare in + let module G = Global in + let module N = Names in + let module Nt = Nametab in + let module T = Term in + let module X = Xml in + let module Ln = Libnames in + (* Variables are the identifiers of the variables in scope *) + let variables = search_variables () in + let kn,tag,obj = + match glob_ref with + Ln.VarRef id -> + let sp = Declare.find_section_variable id in + (* this kn is fake since it is not provided by Coq *) + let kn = + let (mod_path,dir_path) = Lib.current_prefix () in + N.make_kn mod_path dir_path (N.label_of_id (Ln.basename sp)) + in + let (_,body,typ) = G.lookup_named id in + kn,Cic2acic.Variable,mk_variable_obj id body typ + | Ln.ConstRef kn -> + let id = N.id_of_label (N.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 + | Ln.IndRef (kn,_) -> + let {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 + | 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 + if not internal then print_object_kind uri kind; + print_object uri obj Evd.empty None fn +;; + +let print_ref qid fn = + let ref = Nametab.global qid in + print false ref (kind_of_global ref) fn + +(* show dest *) +(* where dest is either None (for stdout) or (Some filename) *) +(* pretty prints via Xml.pp the proof in progress on dest *) +let show_pftreestate internal fn (kind,pftst) id = + let str = Names.string_of_id id in + let pf = Tacmach.proof_of_pftreestate pftst in + let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in + let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree, + unshared_pf + = + Proof2aproof.extract_open_pftreestate pftst in + let kn = Lib.make_kn id in + let env = Global.env () in + let obj = + mk_current_proof_obj (kind = Decl_kinds.IsLocal) id val0 typ evar_map env in + let uri = + match kind with + Decl_kinds.IsLocal -> + let uri = + "cic:/" ^ String.concat "/" + (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.Variable) 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 + if not internal then print_object_kind uri (kind_of_global_goal kind); + uri + in + print_object uri obj evar_map + (Some (Tacmach.evc_of_pftreestate pftst,unshared_pf,proof_tree_to_constr, + proof_tree_to_flattened_proof_tree)) fn +;; + +let show fn = + let pftst = Pfedit.get_pftreestate () in + let (id,kind,_,_) = Pfedit.current_proof_statement () in + show_pftreestate false fn (kind,pftst) id +;; + + +(* Let's register the callbacks *) +let xml_library_root = + try + Some (Sys.getenv "COQ_XML_LIBRARY_ROOT") + with Not_found -> None +;; + +let proof_to_export = ref None (* holds the proof-tree to export *) +;; + +let _ = + Pfedit.set_xml_cook_proof + (function pftreestate -> proof_to_export := Some pftreestate) +;; + +let _ = + Declare.set_xml_declare_variable + (function (sp,kn) -> + let id = Libnames.basename sp in + print false (Libnames.VarRef id) (kind_of_variable id) xml_library_root ; + proof_to_export := None) +;; + +let _ = + Declare.set_xml_declare_constant + (function (internal,(sp,kn)) -> + match !proof_to_export with + None -> + print internal (Libnames.ConstRef kn) (kind_of_constant kn) + xml_library_root + | Some pftreestate -> + (* It is a proof. Let's export it starting from the proof-tree *) + (* I saved in the Pfedit.set_xml_cook_proof callback. *) + let fn = filename_of_path xml_library_root kn Cic2acic.Constant in + show_pftreestate internal fn pftreestate + (Names.id_of_label (Names.label kn)) ; + proof_to_export := None) +;; + +let _ = + Declare.set_xml_declare_inductive + (function (isrecord,(sp,kn)) -> + print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) + xml_library_root) +;; + +let _ = + Vernac.set_xml_start_library + (function () -> + Buffer.reset theory_buffer; + theory_output_string "<?xml version=\"1.0\" encoding=\"latin1\"?>\n"; + theory_output_string ("<!DOCTYPE html [\n" ^ + "<!ENTITY % xhtml-lat1.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-lat1.ent\">\n" ^ + "<!ENTITY % xhtml-special.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-special.ent\">\n" ^ + "<!ENTITY % xhtml-symbol.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-symbol.ent\">\n\n" ^ + "%xhtml-lat1.ent;\n" ^ + "%xhtml-special.ent;\n" ^ + "%xhtml-symbol.ent;\n" ^ + "]>\n\n"); + theory_output_string "<html xmlns=\"http://www.w3.org/1999/xhtml\" xmlns:ht=\"http://www.cs.unibo.it/helm/namespaces/helm-theory\" xmlns:helm=\"http://www.cs.unibo.it/helm\">\n"; + theory_output_string "<head></head>\n<body>\n") +;; + +let _ = + Vernac.set_xml_end_library + (function () -> + theory_output_string "</body>\n</html>\n"; + let ofn = theory_filename xml_library_root in + begin + match ofn with + None -> + Buffer.output_buffer stdout theory_buffer ; + | Some fn -> + let ch = open_out (fn ^ ".v") in + Buffer.output_buffer ch theory_buffer ; + close_out ch + end ; + Util.option_iter + (fun fn -> + let coqdoc = Coq_config.bindir^"/coqdoc" in + let options = " --html -s --body-only --no-index --latin1 --raw-comments" in + let dir = Util.out_some xml_library_root in + let command cmd = + if Sys.command cmd <> 0 then + Util.anomaly ("Error executing \"" ^ cmd ^ "\"") + in + command (coqdoc^options^" -d "^dir^" "^fn^".v"); + 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")) + ofn) +;; + +let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;; + +let uri_of_dirpath dir = + "/" ^ String.concat "/" + (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir))) +;; + +let _ = + Lib.set_xml_open_section + (fun _ -> + let s = "cic:" ^ uri_of_dirpath (Lib.cwd ()) in + theory_output_string ("<ht:SECTION uri=\""^s^"\">")) +;; + +let _ = + Lib.set_xml_close_section + (fun _ -> theory_output_string "</ht:SECTION>") +;; + +let _ = + Library.set_xml_require + (fun d -> theory_output_string + (Printf.sprintf "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>" + (uri_of_dirpath d) (Names.string_of_dirpath d))) +;; diff --git a/contrib/xml/xmlcommand.mli b/contrib/xml/xmlcommand.mli new file mode 100644 index 00000000..9a7464bd --- /dev/null +++ b/contrib/xml/xmlcommand.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +(*i $Id: xmlcommand.mli,v 1.18.2.2 2004/07/16 19:30:15 herbelin Exp $ i*) + +(* print_global qid fn *) +(* where qid is a long name denoting a definition/theorem or *) +(* an inductive definition *) +(* and dest is either None (for stdout) or (Some filename) *) +(* pretty prints via Xml.pp the object whose name is ref on dest *) +(* Note: it is printed only (and directly) the most discharged available *) +(* form of the definition (all the parameters are *) +(* lambda-abstracted, but the object can still refer to variables) *) +val print_ref : Libnames.reference -> string option -> unit + +(* show dest *) +(* where dest is either None (for stdout) or (Some filename) *) +(* pretty prints via Xml.pp the proof in progress on dest *) +val show : string option -> unit + +(* set_print_proof_tree f *) +(* sets a callback function f to export the proof_tree to XML *) +val set_print_proof_tree : + (string -> + Evd.evar_map -> + Proof_type.proof_tree -> + Term.constr Proof2aproof.ProofTreeHash.t -> + Proof_type.proof_tree Proof2aproof.ProofTreeHash.t -> + string Acic.CicHash.t -> Xml.token Stream.t) -> + unit diff --git a/contrib/xml/xmlentries.ml4 b/contrib/xml/xmlentries.ml4 new file mode 100644 index 00000000..2bc686f7 --- /dev/null +++ b/contrib/xml/xmlentries.ml4 @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * The HELM Project / The EU MoWGLI Project *) +(* * University of Bologna *) +(************************************************************************) +(* This file is distributed under the terms of the *) +(* GNU Lesser General Public License Version 2.1 *) +(* *) +(* Copyright (C) 2000-2004, HELM Team. *) +(* http://helm.cs.unibo.it *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* $Id: xmlentries.ml4,v 1.12.2.2 2004/07/16 19:30:15 herbelin Exp $ *) + +open Util;; +open Vernacinterp;; + +open Extend;; +open Genarg;; +open Pp;; +open Pcoq;; + +(* File name *) + +VERNAC ARGUMENT EXTEND filename +| [ "File" string(fn) ] -> [ Some fn ] +| [ ] -> [ None ] +END + +(* Print XML and Show XML *) + +VERNAC COMMAND EXTEND Xml +| [ "Print" "XML" filename(fn) global(qid) ] -> [ Xmlcommand.print_ref qid fn ] + +| [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ] +END |