diff options
author | Samuel Mimram <smimram@debian.org> | 2006-11-21 21:38:49 +0000 |
---|---|---|
committer | Samuel Mimram <smimram@debian.org> | 2006-11-21 21:38:49 +0000 |
commit | 208a0f7bfa5249f9795e6e225f309cbe715c0fad (patch) | |
tree | 591e9e512063e34099782e2518573f15ffeac003 /contrib | |
parent | de0085539583f59dc7c4bf4e272e18711d565466 (diff) |
Imported Upstream version 8.1~gammaupstream/8.1.gamma
Diffstat (limited to 'contrib')
89 files changed, 6557 insertions, 2751 deletions
diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml index 3e2d11a2..8bdae54b 100644 --- a/contrib/cc/ccalgo.ml +++ b/contrib/cc/ccalgo.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccalgo.ml 7298 2005-08-17 12:56:38Z corbinea $ *) +(* $Id: ccalgo.ml 9151 2006-09-19 13:32:22Z corbinea $ *) (* This file implements the basic congruence-closure algorithm by *) (* Downey,Sethi and Tarjan. *) @@ -55,6 +55,8 @@ module ST=struct Hashtbl.replace st.tosign t sign let query sign st=Hashtbl.find st.toterm sign + + let rev_query term st=Hashtbl.find st.tosign term let delete st t= try let sign=Hashtbl.find st.tosign t in @@ -72,10 +74,22 @@ type pa_constructor= arity : int; args : int list} +type pa_fun= + {fsym:int; + fnargs:int} + +type pa_mark= + Fmark of pa_fun + | Cmark of pa_constructor + module PacMap=Map.Make(struct type t=pa_constructor let compare=Pervasives.compare end) +module PafMap=Map.Make(struct + type t=pa_fun + let compare=Pervasives.compare end) + type cinfo= {ci_constr: constructor; (* inductive type *) ci_arity: int; (* # args *) @@ -87,16 +101,20 @@ type term= | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) +type ccpattern = + PApp of term * ccpattern list (* arguments are reversed *) + | PVar of int + type rule= Congruence - | Axiom of identifier * bool + | Axiom of constr * bool | Injection of int * pa_constructor * int * pa_constructor * int type from= Goal - | Hyp of identifier - | HeqG of identifier - | HeqnH of identifier * identifier + | Hyp of constr + | HeqG of constr + | HeqnH of constr * constr type 'a eq = {lhs:int;rhs:int;rule:'a} @@ -104,6 +122,15 @@ type equality = rule eq type disequality = from eq +type quant_eq = + {qe_hyp_id: identifier; + qe_pol: bool; + qe_nvars:int; + qe_lhs: ccpattern; + qe_lhs_valid:bool; + qe_rhs: ccpattern; + qe_rhs_valid:bool} + let swap eq : equality = let swap_rule=match eq.rule with Congruence -> Congruence @@ -122,6 +149,7 @@ type representative= mutable lfathers:Intset.t; mutable fathers:Intset.t; mutable inductive_status: inductive_status; + mutable functions: Intset.t PafMap.t; mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *) type cl = Rep of representative| Eqto of int*equality @@ -138,7 +166,7 @@ type forest= {mutable max_size:int; mutable size:int; mutable map: node array; - axioms: (identifier,term*term) Hashtbl.t; + axioms: (constr,term*term) Hashtbl.t; mutable epsilons: pa_constructor list; syms:(term,int) Hashtbl.t} @@ -147,9 +175,13 @@ type state = sigtable:ST.t; mutable terms: Intset.t; combine: equality Queue.t; - marks: (int * pa_constructor) Queue.t; + marks: (int * pa_mark) Queue.t; mutable diseq: disequality list; - mutable pa_classes: Intset.t} + mutable quant: quant_eq list; + mutable pa_classes: Intset.t; + q_history: (constr,unit) Hashtbl.t; + mutable rew_depth:int; + mutable changed:bool} let dummy_node = {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence}); @@ -157,7 +189,7 @@ let dummy_node = vertex=Leaf; term=Symb (mkRel min_int)} -let empty ():state = +let empty depth:state = {uf= {max_size=init_size; size=0; @@ -170,7 +202,11 @@ let empty ():state = marks=Queue.create (); sigtable=ST.empty (); diseq=[]; - pa_classes=Intset.empty} + quant=[]; + pa_classes=Intset.empty; + q_history=Hashtbl.create init_size; + rew_depth=depth; + changed=false} let forest state = state.uf @@ -221,11 +257,19 @@ let append_pac t p = let tail_pac p= {p with arity=succ p.arity;args=List.tl p.args} + +let fsucc paf = + {paf with fnargs=succ paf.fnargs} let add_pac rep pac t = if not (PacMap.mem pac rep.constructors) then rep.constructors<-PacMap.add pac t rep.constructors +let add_paf rep paf t = + let already = + try PafMap.find paf rep.functions with Not_found -> Intset.empty in + rep.functions<- PafMap.add paf (Intset.add t already) rep.functions + let term uf i=uf.map.(i).term let subterms uf i= @@ -256,8 +300,36 @@ let new_representative ()= lfathers=Intset.empty; fathers=Intset.empty; inductive_status=Unknown; + functions=PafMap.empty; constructors=PacMap.empty} +(* rebuild a constr from an applicative term *) + +let rec constr_of_term = function + Symb s->s + | Eps -> anomaly "epsilon constant has no value" + | Constructor cinfo -> mkConstruct cinfo.ci_constr + | Appli (s1,s2)-> + make_app [(constr_of_term s2)] s1 +and make_app l=function + Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 + | other -> applistc (constr_of_term other) l + +(* rebuild a term from a pattern and a substitution *) + +let build_subst uf subst = + Array.map (fun i -> + try term uf i + with _ -> anomaly "incomplete matching") subst + +let rec inst_pattern subst = function + PVar i -> + subst.(pred i) + | PApp (t, args) -> + List.fold_right + (fun spat f -> Appli (f,inst_pattern subst spat)) + args t + let rec add_term state t= let uf=state.uf in try Hashtbl.find uf.syms t with @@ -265,7 +337,16 @@ let rec add_term state t= let b=next uf in let new_node= match t with - Symb _ | Eps -> + Symb _ -> + let paf = + {fsym=b; + fnargs=0} in + Queue.add (b,Fmark paf) state.marks; + {clas= Rep (new_representative ()); + cpath= -1; + vertex= Leaf; + term= t} + | Eps -> {clas= Rep (new_representative ()); cpath= -1; vertex= Leaf; @@ -280,11 +361,15 @@ let rec add_term state t= vertex= Node(i1,i2); term= t} | Constructor cinfo -> + let paf = + {fsym=b; + fnargs=0} in + Queue.add (b,Fmark paf) state.marks; let pac = {cnode= b; arity= cinfo.ci_arity; args=[]} in - Queue.add (b,pac) state.marks; + Queue.add (b,Cmark pac) state.marks; {clas=Rep (new_representative ()); cpath= -1; vertex=Leaf; @@ -294,17 +379,54 @@ let rec add_term state t= Hashtbl.add uf.syms t b; b -let add_equality state id s t= +let add_equality state c s t= let i = add_term state s in let j = add_term state t in - Queue.add {lhs=i;rhs=j;rule=Axiom(id,false)} state.combine; - Hashtbl.add state.uf.axioms id (s,t) + Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine; + Hashtbl.add state.uf.axioms c (s,t) let add_disequality state from s t = let i = add_term state s in let j = add_term state t in state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq +let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) = + state.quant<- + {qe_hyp_id= id; + qe_pol= pol; + qe_nvars=nvars; + qe_lhs= patt1; + qe_lhs_valid=valid1; + qe_rhs= patt2; + qe_rhs_valid=valid2}::state.quant + +let add_inst state (inst,int_subst) = + if state.rew_depth > 0 then + let subst = build_subst (forest state) int_subst in + let prfhead= mkVar inst.qe_hyp_id in + let args = Array.map constr_of_term subst in + let _ = array_rev args in (* highest deBruijn index first *) + let prf= mkApp(prfhead,args) in + try Hashtbl.find state.q_history prf + with Not_found -> + (* this instance is new, we can go on *) + let s = inst_pattern subst inst.qe_lhs + and t = inst_pattern subst inst.qe_rhs in + state.changed<-true; + state.rew_depth<-pred state.rew_depth; + if inst.qe_pol then + begin + debug msgnl + (str "adding new equality, depth="++ int state.rew_depth); + add_equality state prf s t + end + else + begin + debug msgnl (str "adding new disequality, depth="++ + int state.rew_depth); + add_disequality state (Hyp prf) s t + end + let link uf i j eq = (* links i -> j *) let node=uf.map.(i) in node.clas<-Eqto (j,eq); @@ -336,7 +458,13 @@ let union state i1 i2 eq= r2.lfathers<-Intset.union r1.lfathers r2.lfathers; ST.delete_set state.sigtable r1.fathers; state.terms<-Intset.union state.terms r1.fathers; - PacMap.iter (fun pac b -> Queue.add (b,pac) state.marks) r1.constructors; + PacMap.iter + (fun pac b -> Queue.add (b,Cmark pac) state.marks) + r1.constructors; + PafMap.iter + (fun paf -> Intset.iter + (fun b -> Queue.add (b,Fmark paf) state.marks)) + r1.functions; match r1.inductive_status,r2.inductive_status with Unknown,_ -> () | Partial pac,Unknown -> @@ -351,7 +479,7 @@ let union state i1 i2 eq= state.pa_classes<-Intset.remove i2 state.pa_classes; r2.inductive_status<-Partial_applied | Total cpl,Unknown -> r2.inductive_status<-Total cpl; - | Total cpl,Total _ -> Queue.add cpl state.marks + | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks | _,_ -> () let merge eq state = (* merge and no-merge *) @@ -380,19 +508,22 @@ let update t state = (* update 1 and 2 *) | _ -> () end; PacMap.iter - (fun pac _ -> Queue.add (t,append_pac v pac) state.marks) + (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) rep.constructors; + PafMap.iter + (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) + rep.functions; try let s = ST.query sign state.sigtable in Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine with Not_found -> ST.enter t sign state.sigtable -let process_mark t pac state = - debug msgnl - (str "Processing mark for term " ++ int t ++ str "."); - let i=find state.uf t in - let rep=get_representative state.uf i in +let process_function_mark t rep paf state = + add_paf rep paf t; + state.terms<-Intset.union rep.lfathers state.terms + +let process_constructor_mark t i rep pac state = match rep.inductive_status with Total (s,opac) -> if pac.cnode <> opac.cnode then (* Conflict *) @@ -424,6 +555,15 @@ let process_mark t pac state = state.pa_classes<- Intset.add i state.pa_classes end +let process_mark t m state = + debug msgnl + (str "Processing mark for term " ++ int t ++ str "."); + let i=find state.uf t in + let rep=get_representative state.uf i in + match m with + Fmark paf -> process_function_mark t rep paf state + | Cmark pac -> process_constructor_mark t i rep pac state + type explanation = Discrimination of (int*pa_constructor*int*pa_constructor) | Contradiction of disequality @@ -447,15 +587,21 @@ let check_disequalities state = let one_step state = try let eq = Queue.take state.combine in - merge eq state + merge eq state; + true with Queue.Empty -> try let (t,m) = Queue.take state.marks in - process_mark t m state + process_mark t m state; + true with Queue.Empty -> + try let t = Intset.choose state.terms in state.terms<-Intset.remove t state.terms; - update t state + update t state; + true + with Not_found -> false + let complete_one_class state i= match (get_representative state.uf i).inductive_status with @@ -470,38 +616,162 @@ let complete_one_class state i= let complete state = Intset.iter (complete_one_class state) state.pa_classes +type matching_problem = +{mp_subst : int array; + mp_inst : quant_eq; + mp_stack : (ccpattern*int) list } + +let make_fun_table state = + let uf= state.uf in + let funtab=ref PafMap.empty in + for cl=0 to pred uf.size do + match uf.map.(cl).clas with + Rep rep -> + PafMap.iter + (fun paf _ -> + let elem = + try PafMap.find paf !funtab + with Not_found -> Intset.empty in + funtab:= PafMap.add paf (Intset.add cl elem) !funtab) + rep.functions + | _ -> () + done; + !funtab + + +let rec do_match state res pb_stack = + let mp=Stack.pop pb_stack in + match mp.mp_stack with + [] -> + res:= (mp.mp_inst,mp.mp_subst) :: !res + | (patt,cl)::remains -> + let uf=state.uf in + match patt with + PVar i -> + if mp.mp_subst.(pred i)<0 then + begin + mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *) + Stack.push {mp with mp_stack=remains} pb_stack + end + else + if mp.mp_subst.(pred i) = cl then + Stack.push {mp with mp_stack=remains} pb_stack + | PApp (f,[]) -> + begin + try let j=Hashtbl.find uf.syms f in + if find uf j =cl then + Stack.push {mp with mp_stack=remains} pb_stack + with Not_found -> () + end + | PApp(f, ((last_arg::rem_args) as args)) -> + try + let j=Hashtbl.find uf.syms f in + let paf={fsym=j;fnargs=List.length args} in + let rep=get_representative uf cl in + let good_terms = PafMap.find paf rep.functions in + let aux i = + let (s,t) = ST.rev_query i state.sigtable in + Stack.push + {mp with + mp_subst=Array.copy mp.mp_subst; + mp_stack= + (PApp(f,rem_args),s) :: + (last_arg,t) :: remains} pb_stack in + Intset.iter aux good_terms + with Not_found -> () + +let paf_of_patt syms = function + PVar _ -> invalid_arg "paf_of_patt: pattern is trivial" + | PApp (f,args) -> + {fsym=Hashtbl.find syms f; + fnargs=List.length args} + +let init_pb_stack state = + let syms= state.uf.syms in + let pb_stack = Stack.create () in + let funtab = make_fun_table state in + let aux inst = + begin + if inst.qe_lhs_valid then + try + let paf= paf_of_patt syms inst.qe_lhs in + let good_classes = PafMap.find paf funtab in + Intset.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); + mp_inst=inst; + mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes + with Not_found -> () + end; + begin + if inst.qe_rhs_valid then + try + let paf= paf_of_patt syms inst.qe_rhs in + let good_classes = PafMap.find paf funtab in + Intset.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); + mp_inst=inst; + mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes + with Not_found -> () + end in + List.iter aux state.quant; + pb_stack + +let find_instances state = + let pb_stack= init_pb_stack state in + let res =ref [] in + let _ = + debug msgnl (str "Running E-matching algorithm ... "); + try + while true do + do_match state res pb_stack + done; + anomaly "get out of here !" + with Stack.Empty -> () in + !res + let rec execute first_run state = debug msgnl (str "Executing ... "); try - while true do - one_step state + while one_step state do () done; - anomaly "keep out of here" - with - Discriminable(s,spac,t,tpac) -> - Some - begin - if first_run then - Discrimination (s,spac,t,tpac) - else - Incomplete - end - | Not_found -> - match check_disequalities state with - None -> - if not(Intset.is_empty state.pa_classes) then - begin - debug msgnl - (str "First run was incomplete, completing ... "); - complete state; - execute false state - end - else None - | Some dis -> Some - begin - if first_run then - Contradiction dis + match check_disequalities state with + None -> + if not(Intset.is_empty state.pa_classes) then + begin + debug msgnl (str "First run was incomplete, completing ... "); + complete state; + execute false state + end + else + if state.rew_depth>0 then + let l=find_instances state in + List.iter (add_inst state) l; + if state.changed then + begin + state.changed <- false; + execute true state + end else - Incomplete + begin + debug msgnl (str "Out of instances ... "); + None + end + else + begin + debug msgnl (str "Out of depth ... "); + None end + | Some dis -> Some + begin + if first_run then Contradiction dis + else Incomplete + end + with Discriminable(s,spac,t,tpac) -> Some + begin + if first_run then Discrimination (s,spac,t,tpac) + else Incomplete + end + diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli index 74132811..05a5c4d1 100644 --- a/contrib/cc/ccalgo.mli +++ b/contrib/cc/ccalgo.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccalgo.mli 7298 2005-08-17 12:56:38Z corbinea $ *) +(* $Id: ccalgo.mli 9151 2006-09-19 13:32:22Z corbinea $ *) open Util open Term @@ -23,6 +23,10 @@ type term = | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) +type ccpattern = + PApp of term * ccpattern list + | PVar of int + type pa_constructor = { cnode : int; arity : int; @@ -36,14 +40,14 @@ type state type rule= Congruence - | Axiom of identifier * bool + | Axiom of constr * bool | Injection of int * pa_constructor * int * pa_constructor * int type from= Goal - | Hyp of identifier - | HeqG of identifier - | HeqnH of identifier * identifier + | Hyp of constr + | HeqG of constr + | HeqnH of constr*constr type 'a eq = {lhs:int;rhs:int;rule:'a} @@ -56,22 +60,28 @@ type explanation = | Contradiction of disequality | Incomplete +val constr_of_term : term -> constr + val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit val forest : state -> forest -val axioms : forest -> (identifier, term * term) Hashtbl.t +val axioms : forest -> (constr, term * term) Hashtbl.t val epsilons : forest -> pa_constructor list -val empty : unit -> state +val empty : int -> state val add_term : state -> term -> int -val add_equality : state -> identifier -> term -> term -> unit +val add_equality : state -> constr -> term -> term -> unit val add_disequality : state -> from -> term -> term -> unit +val add_quant : state -> identifier -> bool -> + int * bool * ccpattern * bool * ccpattern -> unit + + val tail_pac : pa_constructor -> pa_constructor val find : forest -> int -> int @@ -87,6 +97,35 @@ val subterms : forest -> int -> int * int val join_path : forest -> int -> int -> ((int * int) * equality) list * ((int * int) * equality) list +type quant_eq= + {qe_hyp_id: identifier; + qe_pol: bool; + qe_nvars:int; + qe_lhs: ccpattern; + qe_lhs_valid:bool; + qe_rhs: ccpattern; + qe_rhs_valid:bool} + + +type pa_fun= + {fsym:int; + fnargs:int} + +type matching_problem + +module PafMap: Map.S with type key = pa_fun + +val make_fun_table : state -> Intset.t PafMap.t + +val do_match : state -> + (quant_eq * int array) list ref -> matching_problem Stack.t -> unit + +val init_pb_stack : state -> matching_problem Stack.t + +val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun + +val find_instances : state -> (quant_eq * int array) list + val execute : bool -> state -> explanation option diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml index 1200dc2e..1ffa347a 100644 --- a/contrib/cc/ccproof.ml +++ b/contrib/cc/ccproof.ml @@ -6,18 +6,19 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.ml 7298 2005-08-17 12:56:38Z corbinea $ *) +(* $Id: ccproof.ml 9151 2006-09-19 13:32:22Z corbinea $ *) (* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) open Util open Names +open Term open Ccalgo type proof= - Ax of identifier - | SymAx of identifier + Ax of constr + | SymAx of constr | Refl of term | Trans of proof*proof | Congr of proof*proof diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli index 18c745bf..abdd6fea 100644 --- a/contrib/cc/ccproof.mli +++ b/contrib/cc/ccproof.mli @@ -6,14 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.mli 7298 2005-08-17 12:56:38Z corbinea $ *) +(* $Id: ccproof.mli 9151 2006-09-19 13:32:22Z corbinea $ *) open Ccalgo open Names +open Term type proof = - Ax of identifier - | SymAx of identifier + Ax of constr + | SymAx of constr | Refl of term | Trans of proof * proof | Congr of proof * proof @@ -25,6 +26,6 @@ val build_proof : | `Prove of int * int ] -> proof val type_proof : - (identifier, (term * term)) Hashtbl.t -> proof -> term * term + (constr, (term * term)) Hashtbl.t -> proof -> term * term diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml index 4a719f38..ea8aceeb 100644 --- a/contrib/cc/cctac.ml +++ b/contrib/cc/cctac.ml @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: cctac.ml 7909 2006-01-21 11:09:18Z herbelin $ *) +(* $Id: cctac.ml 9151 2006-09-19 13:32:22Z corbinea $ *) (* This file is the interface between the c-c algorithm and Coq *) @@ -63,7 +63,7 @@ let rec decompose_term env t= Constructor {ci_constr=c; ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} - | _ ->(Symb t) + | _ ->if closed0 t then (Symb t) else raise Not_found (* decompose equality in members and type *) @@ -79,34 +79,72 @@ let atom_of_constr env term = else `Other (decompose_term env term) | _ -> `Other (decompose_term env term) -let rec litteral_of_constr env term= +let rec pattern_of_constr env c = + match kind_of_term (whd env c) with + App (f,args)-> + let pf = decompose_term env f in + let pargs,lrels = List.split + (array_map_to_list (pattern_of_constr env) args) in + PApp (pf,List.rev pargs), + List.fold_left Intset.union Intset.empty lrels + | Rel i -> PVar i,Intset.singleton i + | _ -> + let pf = decompose_term env c in + PApp (pf,[]),Intset.empty + +let non_trivial = function + PVar _ -> false + | _ -> true + +let patterns_of_constr env nrels term= + let f,args= + try destApp (whd_delta env term) with _ -> raise Not_found in + if eq_constr f (Lazy.force _eq) && (Array.length args)=3 + then + let patt1,rels1 = pattern_of_constr env args.(1) + and patt2,rels2 = pattern_of_constr env args.(2) in + let valid1 = (Intset.cardinal rels1 = nrels && non_trivial patt1) + and valid2 = (Intset.cardinal rels2 = nrels && non_trivial patt2) in + if valid1 || valid2 then + nrels,valid1,patt1,valid2,patt2 + else raise Not_found + else raise Not_found + +let rec quantified_atom_of_constr env nrels term = match kind_of_term (whd_delta env term) with Prod (_,atom,ff) -> if eq_constr ff (Lazy.force _False) then + let patts=patterns_of_constr env nrels atom in + `Nrule patts + else + quantified_atom_of_constr env (succ nrels) ff + | _ -> + let patts=patterns_of_constr env nrels term in + `Rule patts + +let litteral_of_constr env term= + match kind_of_term (whd_delta env term) with + | Prod (_,atom,ff) -> + if eq_constr ff (Lazy.force _False) then match (atom_of_constr env atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) - else - `Other (decompose_term env term) - | _ -> atom_of_constr env term + else + begin + try + quantified_atom_of_constr env 1 ff + with Not_found -> + `Other (decompose_term env term) + end + | _ -> + atom_of_constr env term -(* rebuild a term from applicative format *) - -let rec make_term = function - Symb s->s - | Eps -> anomaly "epsilon constant has no value" - | Constructor cinfo -> mkConstruct cinfo.ci_constr - | Appli (s1,s2)-> - make_app [(make_term s2)] s1 -and make_app l=function - Appli (s1,s2)->make_app ((make_term s2)::l) s1 - | other -> applistc (make_term other) l (* store all equalities from the context *) -let rec make_prb gls additionnal_terms = +let rec make_prb gls depth additionnal_terms = let env=pf_env gls in - let state = empty () in + let state = empty depth in let pos_hyps = ref [] in let neg_hyps =ref [] in List.iter @@ -116,21 +154,24 @@ let rec make_prb gls additionnal_terms = List.iter (fun (id,_,e) -> begin + let cid=mkVar id in match litteral_of_constr env e with - `Eq (t,a,b) -> add_equality state id a b - | `Neq (t,a,b) -> add_disequality state (Hyp id) a b + `Eq (t,a,b) -> add_equality state cid a b + | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> List.iter - (fun (idn,nh) -> - add_disequality state (HeqnH (id,idn)) ph nh) + (fun (cidn,nh) -> + add_disequality state (HeqnH (cid,cidn)) ph nh) !neg_hyps; - pos_hyps:=(id,ph):: !pos_hyps + pos_hyps:=(cid,ph):: !pos_hyps | `Nother nh -> List.iter - (fun (idp,ph) -> - add_disequality state (HeqnH (idp,id)) ph nh) + (fun (cidp,ph) -> + add_disequality state (HeqnH (cidp,cid)) ph nh) !pos_hyps; - neg_hyps:=(id,nh):: !neg_hyps + neg_hyps:=(cid,nh):: !neg_hyps + | `Rule patts -> add_quant state id true patts + | `Nrule patts -> add_quant state id false patts end) (Environ.named_context_of_val gls.it.evar_hyps); begin match atom_of_constr env gls.it.evar_concl with @@ -170,18 +211,18 @@ let build_projection intype outtype (cstr:constructor) special default gls= (* 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 + Ax c -> exact_check c + | SymAx c -> tclTHEN symmetry (exact_check c) + | Refl t -> reflexivity + | Trans (p1,p2)->let t=(constr_of_term (snd (type_proof axioms p1))) in (tclTHENS (transitivity t) [(proof_tac axioms p1);(proof_tac axioms p2)]) | Congr (p1,p2)-> fun gls-> let (f1,f2)=(type_proof axioms p1) and (x1,x2)=(type_proof axioms p2) in - let tf1=make_term f1 and tx1=make_term x1 - and tf2=make_term f2 and tx2=make_term x2 in + let tf1=constr_of_term f1 and tx1=constr_of_term x1 + and tf2=constr_of_term f2 and tx2=constr_of_term x2 in let typf=pf_type_of gls tf1 and typx=pf_type_of gls tx1 and typfx=pf_type_of gls (mkApp(tf1,[|tx1|])) in let id=pf_get_new_id (id_of_string "f") gls in @@ -204,52 +245,52 @@ let rec proof_tac axioms=function (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 cti=constr_of_term ti in + let ctj=constr_of_term tj in + let cai=constr_of_term ai in let intype=pf_type_of gls cti in let outtype=pf_type_of gls cai in let special=mkRel (1+nargs-argind) in - let default=make_term ai in + let default=constr_of_term ai in let proj=build_projection intype outtype cstr special default gls in let injt= mkApp (Lazy.force _f_equal,[|intype;outtype;proj;cti;ctj|]) in tclTHEN (apply injt) (proof_tac axioms prf) gls) -let refute_tac axioms id t1 t2 p gls = - let tt1=make_term t1 and tt2=make_term t2 in +let refute_tac axioms c t1 t2 p gls = + let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let intype=pf_type_of gls tt1 in let neweq= mkApp(Lazy.force _eq, [|intype;tt1;tt2|]) in let hid=pf_get_new_id (id_of_string "Heq") gls in - let false_t=mkApp (mkVar id,[|mkVar hid|]) in + let false_t=mkApp (c,[|mkVar hid|]) in tclTHENS (true_cut (Name hid) neweq) [proof_tac axioms p; simplest_elim false_t] gls -let convert_to_goal_tac axioms id t1 t2 p gls = - let tt1=make_term t1 and tt2=make_term t2 in +let convert_to_goal_tac axioms c t1 t2 p gls = + let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let sort=pf_type_of gls tt2 in let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in let e=pf_get_new_id (id_of_string "e") gls in let x=pf_get_new_id (id_of_string "X") gls in let identity=mkLambda (Name x,sort,mkRel 1) in let endt=mkApp (Lazy.force _eq_rect, - [|sort;tt1;identity;mkVar id;tt2;mkVar e|]) in + [|sort;tt1;identity;c;tt2;mkVar e|]) in tclTHENS (true_cut (Name e) neweq) [proof_tac axioms p;exact_check endt] gls -let convert_to_hyp_tac axioms id1 t1 id2 t2 p gls = - let tt2=make_term t2 in +let convert_to_hyp_tac axioms c1 t1 c2 t2 p gls = + let tt2=constr_of_term t2 in let h=pf_get_new_id (id_of_string "H") gls in - let false_t=mkApp (mkVar id2,[|mkVar h|]) in + let false_t=mkApp (c2,[|mkVar h|]) in tclTHENS (true_cut (Name h) tt2) - [convert_to_goal_tac axioms id1 t1 t2 p; + [convert_to_goal_tac axioms c1 t1 t2 p; simplest_elim false_t] gls let discriminate_tac axioms cstr p gls = let t1,t2=type_proof axioms p in - let tt1=make_term t1 and tt2=make_term t2 in + let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let intype=pf_type_of gls tt1 in let concl=pf_concl gls in let outsort=mkType (new_univ ()) in @@ -273,15 +314,15 @@ let discriminate_tac axioms cstr p gls = let build_term_to_complete uf meta pac = let cinfo = get_constructor_info uf pac.cnode in - let real_args = List.map (fun i -> make_term (term uf i)) pac.args in + let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in let dummy_args = List.rev (list_tabulate meta pac.arity) in let all_args = List.rev_append real_args dummy_args in applistc (mkConstruct cinfo.ci_constr) all_args -let cc_tactic additionnal_terms gls= +let cc_tactic depth additionnal_terms gls= Coqlib.check_required_library ["Coq";"Init";"Logic"]; let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in - let state = make_prb gls additionnal_terms in + let state = make_prb gls depth additionnal_terms in let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in let sol = execute true state in let _ = debug Pp.msgnl (Pp.str "Computation completed.") in @@ -334,3 +375,8 @@ let cc_tactic additionnal_terms gls= let cc_fail gls = errorlabstrm "Congruence" (Pp.str "congruence failed.") + +let congruence_tac depth l = + tclORELSE + (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) + cc_fail diff --git a/contrib/cc/cctac.mli b/contrib/cc/cctac.mli index 6082beb6..97fa4d77 100644 --- a/contrib/cc/cctac.mli +++ b/contrib/cc/cctac.mli @@ -6,11 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: cctac.mli 7298 2005-08-17 12:56:38Z corbinea $ *) +(* $Id: cctac.mli 9151 2006-09-19 13:32:22Z corbinea $ *) open Term open Proof_type -val cc_tactic : constr list -> tactic +val cc_tactic : int -> constr list -> tactic val cc_fail : tactic + +val congruence_tac : int -> constr list -> tactic diff --git a/contrib/cc/g_congruence.ml4 b/contrib/cc/g_congruence.ml4 index 0bdf7608..693aebb4 100644 --- a/contrib/cc/g_congruence.ml4 +++ b/contrib/cc/g_congruence.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_congruence.ml4 7734 2005-12-26 14:06:51Z herbelin $ *) +(* $Id: g_congruence.ml4 9151 2006-09-19 13:32:22Z corbinea $ *) open Cctac open Tactics @@ -17,13 +17,9 @@ open Tacticals (* Tactic registration *) TACTIC EXTEND cc - [ "congruence" ] -> [ tclORELSE - (tclTHEN (tclREPEAT introf) (cc_tactic [])) - cc_fail ] -END - -TACTIC EXTEND cc_with - [ "congruence" "with" ne_constr_list(l) ] -> [ tclORELSE - (tclTHEN (tclREPEAT introf) (cc_tactic l)) - cc_fail] + [ "congruence" ] -> [ congruence_tac 0 [] ] + |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] + |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 0 l ] + |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> + [ congruence_tac n l ] END diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml index c581c620..2d425e9f 100644 --- a/contrib/extraction/extract_env.ml +++ b/contrib/extraction/extract_env.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extract_env.ml 6328 2004-11-18 17:31:41Z sacerdot $ i*) +(*i $Id: extract_env.ml 9310 2006-10-28 19:35:09Z herbelin $ i*) open Term open Declarations @@ -74,7 +74,8 @@ let visit_ref v r = exception Impossible let check_arity env cb = - if Reduction.is_arity env cb.const_type then raise Impossible + let t = Typeops.type_of_constant_type env cb.const_type in + if Reduction.is_arity env t then raise Impossible let check_fix env cb i = match cb.const_body with diff --git a/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml index 2b4b7967..52e7f1dd 100644 --- a/contrib/extraction/extraction.ml +++ b/contrib/extraction/extraction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.ml 9032 2006-07-07 16:30:34Z herbelin $ i*) +(*i $Id: extraction.ml 9310 2006-10-28 19:35:09Z herbelin $ i*) (*i*) open Util @@ -225,7 +225,7 @@ let rec extract_type env db j c args = | Const kn -> let r = ConstRef kn in let cb = lookup_constant kn env in - let typ = cb.const_type in + let typ = Typeops.type_of_constant_type env cb.const_type in (match flag_of_type env typ with | (Info, TypeScheme) -> let mlt = extract_type_app env db (r, type_sign env typ) args in @@ -321,7 +321,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) Array.map (fun mip -> let b = snd (mind_arity mip) <> InProp in - let ar = Inductive.type_of_inductive (mib,mip) in + let ar = Inductive.type_of_inductive env (mib,mip) in let s,v = if b then type_sign_vl env ar else [],[] in let t = Array.make (Array.length mip.mind_nf_lc) [] in { ip_typename = mip.mind_typename; @@ -401,7 +401,8 @@ and extract_ind env kn = (* kn is supposed to be in long form *) (* Is this record officially declared with its projections ? *) (* If so, we use this information. *) begin try - let n = nb_default_params env (Inductive.type_of_inductive(mib,mip0)) + let n = nb_default_params env + (Inductive.type_of_inductive env (mib,mip0)) in List.iter (option_iter @@ -446,7 +447,7 @@ and mlt_env env r = match r with | _ -> None with Not_found -> let cb = Environ.lookup_constant kn env in - let typ = cb.const_type in + let typ = Typeops.type_of_constant_type env cb.const_type in match cb.const_body with | None -> None | Some l_body -> @@ -473,7 +474,7 @@ let record_constant_type env kn opt_typ = lookup_type kn with Not_found -> let typ = match opt_typ with - | None -> constant_type env kn + | None -> Typeops.type_of_constant env kn | Some typ -> typ in let mlt = extract_type env [] 1 typ [] in let schema = (type_maxvar mlt, mlt) @@ -814,7 +815,7 @@ let extract_fixpoint env vkn (fi,ti,ci) = let extract_constant env kn cb = let r = ConstRef kn in - let typ = cb.const_type in + let typ = Typeops.type_of_constant_type env cb.const_type in match cb.const_body with | None -> (* A logical axiom is risky, an informative one is fatal. *) (match flag_of_type env typ with @@ -846,7 +847,7 @@ let extract_constant env kn cb = let extract_constant_spec env kn cb = let r = ConstRef kn in - let typ = cb.const_type in + let typ = Typeops.type_of_constant_type env cb.const_type in match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) | (Logic, Default) -> Sval (r, Tdummy Kother) @@ -884,7 +885,7 @@ let extract_declaration env r = match r with type kind = Logical | Term | Type let constant_kind env cb = - match flag_of_type env cb.const_type with + match flag_of_type env (Typeops.type_of_constant_type env cb.const_type) with | (Logic,_) -> Logical | (Info,TypeScheme) -> Type | (Info,Default) -> Term diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml index bd4fe924..b1a3cb31 100644 --- a/contrib/extraction/table.ml +++ b/contrib/extraction/table.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.ml 6555 2005-01-03 19:25:36Z sacerdot $ i*) +(*i $Id: table.ml 9310 2006-10-28 19:35:09Z herbelin $ i*) open Names open Term @@ -140,16 +140,14 @@ let error_axiom_scheme r i = str " type variable(s).") let warning_info_ax r = - Options.if_verbose msg_warning - (str "You must realize axiom " ++ - pr_global r ++ str " in the extracted code.") + msg_warning (str "You must realize axiom " ++ + pr_global r ++ str " in the extracted code.") let warning_log_ax r = - Options.if_verbose msg_warning - (str "This extraction depends on logical axiom" ++ spc () ++ - pr_global r ++ str "." ++ spc() ++ - str "Having false logical axiom in the environment when extracting" ++ - spc () ++ str "may lead to incorrect or non-terminating ML terms.") + msg_warning (str "This extraction depends on logical axiom" ++ spc () ++ + pr_global r ++ str "." ++ spc() ++ + str "Having false logical axiom in the environment when extracting" ++ + spc () ++ str "may lead to incorrect or non-terminating ML terms.") let check_inside_module () = try @@ -443,7 +441,7 @@ let extract_constant_inline inline r ids s = match g with | ConstRef kn -> let env = Global.env () in - let typ = Environ.constant_type env kn in + let typ = Typeops.type_of_constant env kn in let typ = Reduction.whd_betadeltaiota env typ in if Reduction.is_arity env typ then begin diff --git a/contrib/field/LegacyField.v b/contrib/field/LegacyField.v new file mode 100644 index 00000000..08397d02 --- /dev/null +++ b/contrib/field/LegacyField.v @@ -0,0 +1,15 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* $Id: LegacyField.v 9273 2006-10-25 11:30:36Z barras $ *) + +Require Export LegacyField_Compl. +Require Export LegacyField_Theory. +Require Export LegacyField_Tactic. + +(* Command declarations are moved to the ML side *) diff --git a/contrib/field/Field_Compl.v b/contrib/field/LegacyField_Compl.v index f018359e..b37281e9 100644 --- a/contrib/field/Field_Compl.v +++ b/contrib/field/LegacyField_Compl.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field_Compl.v 8866 2006-05-28 16:21:04Z herbelin $ *) +(* $Id: LegacyField_Compl.v 9273 2006-10-25 11:30:36Z barras $ *) Require Import List. diff --git a/contrib/field/Field_Tactic.v b/contrib/field/LegacyField_Tactic.v index 8d727536..2b6ff5b4 100644 --- a/contrib/field/Field_Tactic.v +++ b/contrib/field/LegacyField_Tactic.v @@ -6,12 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field_Tactic.v 8866 2006-05-28 16:21:04Z herbelin $ *) +(* $Id: LegacyField_Tactic.v 9319 2006-10-30 12:41:21Z barras $ *) Require Import List. -Require Import Ring. -Require Export Field_Compl. -Require Export Field_Theory. +Require Import LegacyRing. +Require Export LegacyField_Compl. +Require Export LegacyField_Theory. (**** Interpretation A --> ExprA ****) @@ -184,15 +184,15 @@ Ltac multiply mul := match goal with | |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) => let AzeroT := get_component Azero FT in - (cut (interp_ExprA FT X2 mul <> AzeroT); - [ intro; let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id) - | weak_reduce; - let AoneT := get_component Aone ltac:(body_of FT) + cut (interp_ExprA FT X2 mul <> AzeroT); + [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id)) + | weak_reduce; + (let AoneT := get_component Aone ltac:(body_of FT) with AmultT := get_component Amult ltac:(body_of FT) in - (try + try match goal with | |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT) - end; clear FT X2) ]) + end; clear FT X2) ] end. Ltac apply_multiply FT lvar trm := @@ -279,7 +279,7 @@ Ltac field_gen_aux FT := let lvar := build_varlist FT (AplusT X1 X2) in let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in let mul := give_mult (EAplus trm1 trm2) in - (cut + cut (let ft := FT in let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2); [ compute in |- *; auto @@ -287,13 +287,14 @@ Ltac field_gen_aux FT := apply_simplif apply_assoc; multiply mul; [ apply_simplif apply_multiply; apply_simplif ltac:(apply_inverse mul); - let id := grep_mult in - clear id; weak_reduce; clear ft vm; first - [ inverse_test FT; ring | field_gen_aux FT ] - | idtac ] ]) + (let id := grep_mult in + clear id; weak_reduce; clear ft vm; first + [ inverse_test FT; legacy ring | field_gen_aux FT ]) + | idtac ] ] end. -Ltac field_gen FT := unfolds FT; (inverse_test FT; ring) || field_gen_aux FT. +Ltac field_gen FT := + unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT. (*****************************) (* Term Simplification *) @@ -429,4 +430,4 @@ Ltac field_term FT exp := simpl_all_monomials ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in - (replace exp with trep; [ ring trep | field_gen FT ]). + (replace exp with trep; [ legacy ring trep | field_gen FT ]). diff --git a/contrib/field/Field_Theory.v b/contrib/field/LegacyField_Theory.v index fff3c414..9c3a12fb 100644 --- a/contrib/field/Field_Theory.v +++ b/contrib/field/LegacyField_Theory.v @@ -6,12 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field_Theory.v 8866 2006-05-28 16:21:04Z herbelin $ *) +(* $Id: LegacyField_Theory.v 9288 2006-10-26 18:25:06Z herbelin $ *) Require Import List. Require Import Peano_dec. -Require Import Ring. -Require Import Field_Compl. +Require Import LegacyRing. +Require Import LegacyField_Compl. Record Field_Theory : Type := {A : Type; @@ -88,66 +88,66 @@ Let AinvT := Ainv T. Let RTT := RT T. Let Th_inv_defT := Th_inv_def T. -Add Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) ( +Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) ( Azero T) (Aopp T) (Aeq T) (RT T). -Add Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT. +Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT. (***************************) (* Lemmas to be used *) (***************************) -Lemma AplusT_sym : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1. +Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1. Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AplusT_assoc : forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3). Proof. - intros; ring. + intros; legacy ring. Qed. -Lemma AmultT_sym : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1. +Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1. Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AmultT_assoc : forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3). Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r. Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r. Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT. Proof. - intros; ring. + intros; legacy ring. Qed. Lemma AmultT_AplusT_distr : forall r1 r2 r3:AT, AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3). Proof. - intros; ring. + intros; legacy ring. Qed. Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2. Proof. intros; transitivity (AplusT (AplusT (AoppT r) r) r1). - ring. + legacy ring. transitivity (AplusT (AplusT (AoppT r) r) r2). repeat rewrite AplusT_assoc; rewrite <- H; reflexivity. - ring. + legacy ring. Qed. Lemma r_AmultT_mult : @@ -162,28 +162,28 @@ Qed. Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT. Proof. - intro; ring. + intro; legacy ring. Qed. Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT. Proof. - intro; ring. + intro; legacy ring. Qed. Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r. Proof. - intro; ring. + intro; legacy ring. Qed. Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT. Proof. - intros; rewrite AmultT_sym; apply Th_inv_defT; auto. + intros; rewrite AmultT_comm; apply Th_inv_defT; auto. Qed. Lemma Rmult_neq_0_reg : forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT. Proof. - intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; ring. + intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring. Qed. (************************) @@ -276,7 +276,7 @@ Lemma merge_mult_correct : interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2). Proof. simple induction e1; auto; intros. -elim e0; try (intros; simpl in |- *; ring). +elim e0; try (intros; simpl in |- *; legacy ring). unfold interp_ExprA in H2; fold interp_ExprA in H2; cut (AmultT (interp_ExprA lvar e2) @@ -286,8 +286,8 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2; (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4)) (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1; - simpl in |- *; ring. -ring. + simpl in |- *; legacy ring. +legacy ring. Qed. Lemma assoc_mult_correct1 : @@ -308,7 +308,7 @@ Lemma assoc_mult_correct : Proof. simple induction e; auto; intros. elim e0; intros. -intros; simpl in |- *; ring. +intros; simpl in |- *; legacy ring. simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1))); rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0. simpl in |- *; rewrite (H0 lvar); auto. @@ -317,9 +317,9 @@ simpl in |- *; rewrite merge_mult_correct; simpl in |- *; rewrite assoc_mult_correct1; rewrite H2; simpl in |- *; rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1; fold interp_ExprA in H1; rewrite (H0 lvar) in H1; - rewrite (AmultT_sym (interp_ExprA lvar e3) (interp_ExprA lvar e1)); + rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1)); rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; - ring. + legacy ring. simpl in |- *; rewrite (H0 lvar); auto. simpl in |- *; rewrite (H0 lvar); auto. simpl in |- *; rewrite (H0 lvar); auto. @@ -344,7 +344,7 @@ Lemma merge_plus_correct : interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2). Proof. simple induction e1; auto; intros. -elim e0; try intros; try (simpl in |- *; ring). +elim e0; try intros; try (simpl in |- *; legacy ring). unfold interp_ExprA in H2; fold interp_ExprA in H2; cut (AplusT (interp_ExprA lvar e2) @@ -354,8 +354,8 @@ unfold interp_ExprA in H2; fold interp_ExprA in H2; (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4)) (interp_ExprA lvar e2)) (interp_ExprA lvar e3)). intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1; - simpl in |- *; ring. -ring. + simpl in |- *; legacy ring. +legacy ring. Qed. Lemma assoc_plus_correct : @@ -387,7 +387,7 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3)) (interp_ExprA lvar e1))); rewrite <- AplusT_assoc; rewrite - (AplusT_sym (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) + (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; rewrite (H0 lvar); rewrite <- @@ -397,10 +397,10 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; rewrite (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1) (interp_ExprA lvar e3)); - rewrite (AplusT_sym (interp_ExprA lvar e1) (interp_ExprA lvar e3)); + rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3)); rewrite <- (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3) - (interp_ExprA lvar e1)); apply AplusT_sym. + (interp_ExprA lvar e1)); apply AplusT_comm. unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; fold interp_ExprA in |- *; rewrite assoc_mult_correct; rewrite (H0 lvar); simpl in |- *; auto. @@ -454,8 +454,8 @@ Lemma distrib_mult_right_correct : AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). Proof. simple induction e1; try intros; simpl in |- *; auto. -rewrite AmultT_sym; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar); - rewrite (H0 e2 lvar); ring. +rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar); + rewrite (H0 e2 lvar); legacy ring. Qed. Lemma distrib_mult_left_correct : @@ -466,18 +466,18 @@ Proof. simple induction e1; try intros; simpl in |- *. rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_Or. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. -rewrite AmultT_sym; +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite AmultT_comm; rewrite (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e) (interp_ExprA lvar e0)); - rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e)); - rewrite (AmultT_sym (interp_ExprA lvar e2) (interp_ExprA lvar e0)); + rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e)); + rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0)); rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_sym. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. Qed. Lemma distrib_correct : @@ -491,7 +491,7 @@ simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar); unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct. simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar); unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct; - simpl in |- *; fold AoppT in |- *; ring. + simpl in |- *; fold AoppT in |- *; legacy ring. Qed. (**** Multiplication by the inverse product ****) @@ -527,7 +527,7 @@ Lemma multiply_aux_correct : Proof. simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct; auto. - simpl in |- *; rewrite (H0 lvar); ring. + simpl in |- *; rewrite (H0 lvar); legacy ring. Qed. Lemma multiply_correct : @@ -595,8 +595,8 @@ simpl in |- *; case (eqExprA e0 (EAinv a)); intros. rewrite e2; simpl in |- *; fold AinvT in |- *. rewrite <- (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a)) - (interp_ExprA lvar e1)); rewrite AinvT_r; [ ring | assumption ]. -simpl in |- *; rewrite H0; auto; ring. + (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ]. +simpl in |- *; rewrite H0; auto; legacy ring. simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a)); intros; [ inversion e1 | simpl in |- *; trivial ]. unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros. @@ -619,7 +619,7 @@ simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct; elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1); intros. rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto. -ring. +legacy ring. Qed. Lemma monom_simplif_correct : @@ -644,3 +644,7 @@ unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto. Qed. End Theory_of_fields. + +(* Compatibility *) +Notation AplusT_sym := AplusT_comm (only parsing). +Notation AmultT_sym := AmultT_comm (only parsing). diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4 index 47e583fd..dab5a45c 100644 --- a/contrib/field/field.ml4 +++ b/contrib/field/field.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: field.ml4 8866 2006-05-28 16:21:04Z herbelin $ *) +(* $Id: field.ml4 9273 2006-10-25 11:30:36Z barras $ *) open Names open Pp @@ -86,7 +86,7 @@ let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth Ring.add_theory true true false a None None None aplus amult aone azero (Some aopp) aeq rth Quote.ConstrSet.empty with | UserError("Add Semi Ring",_) -> ()); - let th = mkApp ((constant ["Field_Theory"] "Build_Field_Theory"), + let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"), [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in begin let _ = type_of (Global.env ()) Evd.empty th in (); @@ -139,7 +139,7 @@ ARGUMENT EXTEND minus_div_arg END VERNAC COMMAND EXTEND Field - [ "Add" "Field" + [ "Add" "Legacy" "Field" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ] @@ -153,7 +153,7 @@ END (* Guesses the type and calls field_gen with the right theory *) let field g = - Coqlib.check_required_library ["Coq";"field";"Field"]; + Coqlib.check_required_library ["Coq";"field";"LegacyField"]; let typ = match Hipattern.match_with_equation (pf_concl g) with | Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t @@ -175,7 +175,7 @@ let guess_theory env evc = function (* Guesses the type and calls Field_Term with the right theory *) let field_term l g = - Coqlib.check_required_library ["Coq";"field";"Field"]; + Coqlib.check_required_library ["Coq";"field";"LegacyField"]; let env = (pf_env g) and evc = (project g) in let th = valueIn (VConstr (guess_theory env evc l)) @@ -187,7 +187,7 @@ let field_term l g = (* Declaration of Field *) -TACTIC EXTEND field -| [ "field" ] -> [ field ] -| [ "field" ne_constr_list(l) ] -> [ field_term l ] +TACTIC EXTEND legacy_field +| [ "legacy" "field" ] -> [ field ] +| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ] END diff --git a/contrib/first-order/formula.ml b/contrib/first-order/formula.ml index fde48d2b..0be468aa 100644 --- a/contrib/first-order/formula.ml +++ b/contrib/first-order/formula.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: formula.ml 7493 2005-11-02 22:12:16Z mohring $ *) +(* $Id: formula.ml 9154 2006-09-20 17:18:18Z corbinea $ *) open Hipattern open Names @@ -46,7 +46,6 @@ let rec nb_prod_after n c= | _ -> 0 let construct_nhyps ind gls = - let env=pf_env gls in let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in let hyp = nb_prod_after nparams in diff --git a/contrib/first-order/g_ground.ml4 b/contrib/first-order/g_ground.ml4 index f9c4cea2..366f563b 100644 --- a/contrib/first-order/g_ground.ml4 +++ b/contrib/first-order/g_ground.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_ground.ml4 8752 2006-04-27 19:37:33Z herbelin $ *) +(* $Id: g_ground.ml4 9154 2006-09-20 17:18:18Z corbinea $ *) open Formula open Sequent @@ -24,7 +24,7 @@ open Libnames (* declaring search depth as a global option *) -let ground_depth=ref 5 +let ground_depth=ref 3 let _= let gdopt= @@ -34,13 +34,28 @@ let _= optread=(fun ()->Some !ground_depth); optwrite= (function - None->ground_depth:=5 + None->ground_depth:=3 | Some i->ground_depth:=(max i 0))} in declare_int_option gdopt - + +let congruence_depth=ref 100 + +let _= + let gdopt= + { optsync=true; + optname="Congruence Depth"; + optkey=SecondaryTable("Congruence","Depth"); + optread=(fun ()->Some !congruence_depth); + optwrite= + (function + None->congruence_depth:=0 + | Some i->congruence_depth:=(max i 0))} + in + declare_int_option gdopt + let default_solver=(Tacinterp.interp <:tactic<auto with *>>) - + let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") type external_env= @@ -94,3 +109,19 @@ TACTIC EXTEND gintuition [ "gintuition" tactic_opt(t) ] -> [ gen_ground_tac false (option_map eval_tactic t) Void ] END + + +let default_declarative_automation gls = + tclORELSE + (Cctac.congruence_tac !congruence_depth []) + (gen_ground_tac true + (Some (tclTHEN + default_solver + (Cctac.congruence_tac !congruence_depth []))) + Void) gls + + + +let () = + Decl_proof_instr.register_automation_tac default_declarative_automation + diff --git a/contrib/fourier/Fourier.v b/contrib/fourier/Fourier.v index 8836b76e..1a1a5055 100644 --- a/contrib/fourier/Fourier.v +++ b/contrib/fourier/Fourier.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Fourier.v 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: Fourier.v 9178 2006-09-26 11:18:22Z barras $ *) (* "Fourier's method to solve linear inequations/equations systems.".*) @@ -17,7 +17,7 @@ Declare ML Module "fourierR". Declare ML Module "field". Require Export Fourier_util. -Require Export Field. +Require Export LegacyField. Require Export DiscrR. Ltac fourier := abstract (fourierz; field; discrR). diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml index 7977d4e0..14e2233f 100644 --- a/contrib/funind/functional_principles_proofs.ml +++ b/contrib/funind/functional_principles_proofs.ml @@ -39,12 +39,12 @@ let do_observe_tac s tac g = Cerrors.explain_exn e ++ str " on goal " ++ goal ); raise e;; - -let observe_tac s tac g = +let observe_tac_stream s tac g = if do_observe () - then do_observe_tac (str s) tac g + then do_observe_tac s tac g else tac g +let observe_tac s tac g = observe_tac_stream (str s) tac g let tclTRYD tac = if !Options.debug || do_observe () @@ -179,10 +179,11 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type = let nochange msg = begin -(* observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ); *) + observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ); failwith "NoChange"; end in + let eq_constr = Reductionops.is_conv env sigma in if not (noccurn 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp t) then nochange "not an equality"; @@ -194,6 +195,7 @@ let change_eq env sigma hyp_id (context:Sign.rel_context) x t end_of_type = in if not (closed0 t1) then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = + observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); if isRel t2 then let t2 = destRel t2 in @@ -313,9 +315,13 @@ let h_reduce_with_zeta = let rewrite_until_var arg_num eq_ids : tactic = + (* tests if the declares recursive argument is neither a Constructor nor + an applied Constructor since such a form for the recursive argument + will break the Guard when trying to save the Lemma. + *) let test_var g = let _,args = destApp (pf_concl g) in - not (isConstruct args.(arg_num)) + not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) in let rec do_rewrite eq_ids g = if test_var g @@ -499,7 +505,7 @@ let clean_goal_with_heq ptes_infos continue_tac dyn_infos = tclTHENLIST [ tac ; - (continue_tac new_infos) + observe_tac "clean_hyp_with_heq continue" (continue_tac new_infos) ] g @@ -779,7 +785,7 @@ let build_proof finish_proof dyn_infos) in observe_tac "build_proof" - (build_proof do_finish_proof dyn_infos) + (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) @@ -884,7 +890,8 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) - let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) f_def.const_type in + let type_ctxt,type_of_f = Sign.decompose_prod_n_assum (nb_params + nb_args) + (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in let f_id = id_of_label (con_label (destConst f)) in @@ -1332,10 +1339,11 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_constr eqs : tactic = h_intro hid; Elim.h_decompose_and (mkVar hid); backtrack_eqs_until_hrec hrec eqs; - tclCOMPLETE (tclTHENS (* We must have exactly ONE subgoal !*) - (apply (mkVar hrec)) - [ tclTHENSEQ - [ + observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) + (tclTHENS (* We must have exactly ONE subgoal !*) + (apply (mkVar hrec)) + [ tclTHENSEQ + [ thin [hrec]; apply (Lazy.force acc_inv); (fun g -> @@ -1344,11 +1352,12 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_constr eqs : tactic = unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] g else tclIDTAC g ); - tclTRY(Recdef.list_rewrite true eqs); - observe_tac "finishing" (tclCOMPLETE (Eauto.gen_eauto false (false,5) [] (Some []))) + observe_tac "rew_and_finish" + (tclTHEN + (tclTRY(Recdef.list_rewrite true eqs)) + (observe_tac "finishing" (tclCOMPLETE (Eauto.gen_eauto false (false,5) [] (Some []))))) ] - ] - ) + ]) ]) gls @@ -1371,7 +1380,7 @@ let is_valid_hypothesis predicates_name = | _ -> false in is_valid_hypothesis - +(* let fresh_id avoid na = let id = match na with @@ -1450,7 +1459,7 @@ let prove_principle_for_gen let wf_tac = if is_mes then - Recdef.tclUSER_if_not_mes + (fun b -> Recdef.tclUSER_if_not_mes b None) else fun _ -> prove_with_tcc tcc_lemma_ref [] in let start_tac g = @@ -1543,7 +1552,7 @@ let prove_principle_for_gen let pte_info = { proving_tac = (fun eqs -> - observe_tac "prove_with_tcc" + observe_tac "new_prove_with_tcc" (new_prove_with_tcc is_mes acc_inv hrec tcc_lemma_ref (List.map mkVar eqs)) ); is_valid = is_valid_hypothesis predicates_names @@ -1583,13 +1592,160 @@ let prove_principle_for_gen arg_tac; start_tac ] g +*) - - - - - - +let prove_principle_for_gen + (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes + rec_arg_num rec_arg_type relation gl = + let princ_type = pf_concl gl in + let princ_info = compute_elim_sig princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps gl) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (string_of_id id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id + in + let fresh_decl (na,b,t) = (fresh_id na,b,t) in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; + args = List.map fresh_decl princ_info.args + } + in + let wf_tac = + if is_mes + then + (fun b -> Recdef.tclUSER_if_not_mes b None) + else fun _ -> prove_with_tcc tcc_lemma_ref [] + in + let real_rec_arg_num = rec_arg_num - princ_info.nparams in + let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in + let (post_rec_arg,pre_rec_arg) = + Util.list_chop npost_rec_arg princ_info.args + in + let rec_arg_id = + match post_rec_arg with + | (Name id,_,_)::_ -> id + | _ -> assert false + in + let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in + let relation = substl subst_constrs relation in + let input_type = substl subst_constrs rec_arg_type in + let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in + let acc_rec_arg_id = + Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id))))) + in + let revert l = + tclTHEN (h_generalize (List.map mkVar l)) (clear l) + in + let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in + let prove_rec_arg_acc g = + (observe_tac "prove_rec_arg_acc" + (tclCOMPLETE + (tclTHEN + (forward + (Some ((fun g -> observe_tac "prove wf" (tclCOMPLETE (wf_tac is_mes)) g))) + (Genarg.IntroIdentifier wf_thm_id) + (mkApp (delayed_force well_founded,[|input_type;relation|]))) + ( + observe_tac + "apply wf_thm" + (h_apply ((mkApp(mkVar wf_thm_id, + [|mkVar rec_arg_id |])),Rawterm.NoBindings) + ) + ) + ) + ) + ) + g + in + let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in + tclTHENSEQ + [ + h_intros + (List.rev_map (fun (na,_,_) -> Nameops.out_name na) + (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) + ); + observe_tac "" (forward + (Some (prove_rec_arg_acc)) + (Genarg.IntroIdentifier acc_rec_arg_id) + (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + ); + observe_tac "reverting" (revert (List.rev (acc_rec_arg_id::args_ids))); + observe_tac "h_fix" (h_fix (Some fix_id) (real_rec_arg_num + 1)); + h_intros (List.rev (acc_rec_arg_id::args_ids)); + Equality.rewriteLR (mkConst eq_ref); + observe_tac "finish" (fun gl' -> + let body = + let _,args = destApp (pf_concl gl') in + array_last args + in + let body_info rec_hyps = + { + nb_rec_hyps = List.length rec_hyps; + rec_hyps = rec_hyps; + eq_hyps = []; + info = body + } + in + let acc_inv = + lazy ( + mkApp ( + delayed_force acc_inv_id, + [|input_type;relation;mkVar rec_arg_id|] + ) + ) + in + let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in + let predicates_names = + List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> + observe_tac "new_prove_with_tcc" + (new_prove_with_tcc + is_mes acc_inv fix_id tcc_lemma_ref (List.map mkVar eqs) + ) + ); + is_valid = is_valid_hypothesis predicates_names + } + in + let ptes_info : pte_info Idmap.t = + List.fold_left + (fun map pte_id -> + Idmap.add pte_id + pte_info + map + ) + Idmap.empty + predicates_names + in + let make_proof rec_hyps = + build_proof + false + [f_ref] + ptes_info + (body_info rec_hyps) + in + observe_tac "instanciate_hyps_with_args" + (instanciate_hyps_with_args + make_proof + (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches) + (List.rev args_ids) + ) + gl' + ) + + ] + gl diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml index f83eae8d..89ebb75a 100644 --- a/contrib/funind/functional_principles_types.ml +++ b/contrib/funind/functional_principles_types.ml @@ -301,9 +301,18 @@ let pp_dur time time' = str (string_of_float (System.time_difference time time')) (* let qed () = save_named true *) -let defined () = Command.save_named false - - +let defined () = + try + Command.save_named false + with + | UserError("extract_proof",msg) -> + Util.errorlabstrm + "defined" + ((try + str "On goal : " ++ fnl () ++ pr_open_subgoals () ++ fnl () + with _ -> mt () + ) ++msg) + | e -> raise e @@ -346,6 +355,7 @@ let generate_functional_principle interactive_proof old_princ_type sorts new_princ_name funs i proof_tac = + try let f = funs.(i) in let type_sort = Termops.new_sort_in_family InType in let new_sorts = @@ -384,6 +394,9 @@ let generate_functional_principle Decl_kinds.IsDefinition (Decl_kinds.Scheme) ) ); + Options.if_verbose + (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) + name; names := name :: !names in register_with_sort InProp; @@ -393,6 +406,10 @@ let generate_functional_principle build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook in save false new_princ_name entry g_kind hook + with + | Defining_principle _ as e -> raise e + | e -> raise (Defining_principle e) + (* defined () *) @@ -591,13 +608,6 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent const::other_result let build_scheme fas = -(* (fun (f,_) -> *) -(* try Libnames.constr_of_global (Nametab.global f) *) -(* with Not_found -> *) -(* Util.error ("Cannot find "^ Libnames.string_of_reference f) *) -(* ) *) -(* fas *) - let bodies_types = make_scheme (List.map diff --git a/contrib/funind/indfun.ml b/contrib/funind/indfun.ml index dffc8120..82bb2869 100644 --- a/contrib/funind/indfun.ml +++ b/contrib/funind/indfun.ml @@ -39,7 +39,8 @@ let functional_induction with_clean c princl pat = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' with Not_found -> - errorlabstrm "" (str "Cannot find induction information on "++Printer.pr_lconstr (mkConst c') ) + errorlabstrm "" (str "Cannot find induction information on "++ + Printer.pr_lconstr (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma @@ -49,8 +50,9 @@ let functional_induction with_clean c princl pat = let princ = (* then we get the principle *) try mkConst (out_some princ_option ) with Failure "out_some" -> - (*i If there is not default lemma defined then, we cross our finger and try to - find a lemma named f_ind (or f_rec, f_rect) i*) + (*i If there is not default lemma defined then, + we cross our finger and try to find a lemma named f_ind + (or f_rec, f_rect) i*) let princ_name = Indrec.make_elimination_ident (id_of_label (con_label c')) @@ -90,45 +92,45 @@ let functional_induction with_clean c princl pat = let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in let old_idl = Idset.diff old_idl princ_vars in let subst_and_reduce g = - let idl = - map_succeed - (fun id -> - if Idset.mem id old_idl then failwith "subst_and_reduce"; - id - ) - (Tacmach.pf_ids_of_hyps g) - in - let flag = - Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - } - in if with_clean then + let idl = + map_succeed + (fun id -> + if Idset.mem id old_idl then failwith "subst_and_reduce"; + id + ) + (Tacmach.pf_ids_of_hyps g) + in + let flag = + Rawterm.Cbv + {Rawterm.all_flags + with Rawterm.rDelta = false; + } + in Tacticals.tclTHEN (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl ) (Hiddentac.h_reduce flag Tacticals.allClauses) g else Tacticals.tclIDTAC g - + in Tacticals.tclTHEN (choose_dest_or_ind - princ_infos - args_as_induction_constr - princ' - pat) + princ_infos + args_as_induction_constr + princ' + pat) subst_and_reduce g - - + + type annot = Struct of identifier - | Wf of Topconstr.constr_expr * identifier option - | Mes of Topconstr.constr_expr * identifier option + | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list + | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list type newfixpoint_expr = @@ -184,7 +186,7 @@ let build_newrecursive States.unfreeze fs; raise e in States.unfreeze fs; def in - recdef + recdef,rec_impls let compute_annot (name,annot,args,types,body) = @@ -238,29 +240,47 @@ let prepare_body (name,annot,args,types,body) rt = (fun_args,rt') -let derive_inversion fix_names = - try - Invfun.derive_correctness - Functional_principles_types.make_scheme - functional_induction - (List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names) - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : register_built - i*) - (List.map (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) fix_names) - with e -> - msg_warning (str "Cannot define correction of function and graph" ++ Cerrors.explain_exn e) - +let derive_inversion fix_names = + try + (* we first transform the fix_names identifier into their corresponding constant *) + let fix_names_as_constant = + List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names + in + (* + Then we check that the graphs have been defined + If one of the graphs haven't been defined + we do nothing + *) + List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ; + try + Invfun.derive_correctness + Functional_principles_types.make_scheme + functional_induction + fix_names_as_constant + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : register_built + i*) + (List.map + (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) + fix_names + ) + with e -> + msg_warning + (str "Cannot built inversion information" ++ + if do_observe () then Cerrors.explain_exn e else mt ()) + with _ -> () + let generate_principle - do_built fix_rec_l recdefs interactive_proof parametrize - (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = + is_general do_built fix_rec_l recdefs interactive_proof + (continue_proof : int -> Names.constant array -> Term.constr array -> int -> + Tacmach.tactic) : unit = let names = List.map (function (name,_,_,_,_) -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in let funs_types = List.map (function (_,_,_,types,_) -> types) fix_rec_l in try (* We then register the Inductive graphs of the functions *) - Rawterm_to_relation.build_inductive parametrize names funs_args funs_types recdefs; + Rawterm_to_relation.build_inductive names funs_args funs_types recdefs; if do_built then begin @@ -286,8 +306,7 @@ let generate_principle list_map_i (fun i x -> let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in - let princ_type = - (Global.lookup_constant princ).Declarations.const_type + let princ_type = Typeops.type_of_constant (Global.env()) princ in Functional_principles_types.generate_functional_principle interactive_proof @@ -301,12 +320,22 @@ let generate_principle 0 fix_rec_l in - Array.iter add_Function funs_kn; + Array.iter (add_Function is_general) funs_kn; () end with e -> - Pp.msg_warning (Cerrors.explain_exn e) - + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) + | Defining_principle e -> + Pp.msg_warning + (str "Cannot define principle(s) for "++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + if do_observe () then Cerrors.explain_exn e else mt ()) + | _ -> anomaly "" let register_struct is_rec fixpoint_exprl = match fixpoint_exprl with @@ -330,7 +359,7 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation -let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body +let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body pre_hook = let type_of_f = Command.generalize_constr_expr ret_type args in @@ -349,13 +378,13 @@ let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body in let unbounded_eq = let f_app_args = - Topconstr.CApp + Topconstr.CAppExpl (dummy_loc, - (None,Topconstr.mkIdentC fname) , + (None,(Ident (dummy_loc,fname))) , (List.map (function | _,Anonymous -> assert false - | _,Name e -> (Topconstr.mkIdentC e,None) + | _,Name e -> (Topconstr.mkIdentC e) ) (Topconstr.names_of_local_assums args) ) @@ -365,7 +394,8 @@ let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body [(f_app_args,None);(body,None)]) in let eq = Command.generalize_constr_expr unbounded_eq args in - let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation = + let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type + nb_args relation = try pre_hook (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes @@ -377,15 +407,16 @@ let register_wf ?(is_mes=false) fname wf_rel_expr wf_arg args ret_type body () in Recdef.recursive_definition - is_mes fname + is_mes fname rec_impls type_of_f wf_rel_expr rec_arg_num eq hook + using_lemmas -let register_mes fname wf_mes_expr wf_arg args ret_type body = +let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = let wf_arg_type,wf_arg = match wf_arg with | None -> @@ -424,35 +455,38 @@ let register_mes fname wf_mes_expr wf_arg args ret_type body = let wf_rel_from_mes = Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) in - register_wf ~is_mes:true fname wf_rel_from_mes (Some wf_arg) args ret_type body + register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) + using_lemmas args ret_type body let do_generate_principle register_built interactive_proof fixpoint_exprl = - let recdefs = build_newrecursive fixpoint_exprl in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in let _is_struct = match fixpoint_exprl with - | [((name,Some (Wf (wf_rel,wf_x)),args,types,body))] -> + | [((name,Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> let pre_hook = generate_principle + true register_built fixpoint_exprl recdefs true - false in - if register_built then register_wf name wf_rel wf_x args types body pre_hook; + if register_built + then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook; false - | [((name,Some (Mes (wf_mes,wf_x)),args,types,body))] -> + | [((name,Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> let pre_hook = generate_principle + true register_built fixpoint_exprl recdefs true - false in - if register_built then register_mes name wf_mes wf_x args types body pre_hook; - false + if register_built + then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook; + true | _ -> let fix_names = List.map (function (name,_,_,_,_) -> name) fixpoint_exprl @@ -469,7 +503,9 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = in let annot = try Some (list_index (Name id) names - 1), Topconstr.CStructRec - with Not_found -> raise (UserError("",str "Cannot find argument " ++ Ppconstr.pr_id id)) + with Not_found -> + raise (UserError("",str "Cannot find argument " ++ + Ppconstr.pr_id id)) in (name,annot,args,types,body),(None:Vernacexpr.decl_notation) | (name,None,args,types,body),recdef -> @@ -479,10 +515,11 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = (dummy_loc,"Function", Pp.str "the recursive argument needs to be specified in Function") else - (name,(Some 0, Topconstr.CStructRec),args,types,body),(None:Vernacexpr.decl_notation) + (name,(Some 0, Topconstr.CStructRec),args,types,body), + (None:Vernacexpr.decl_notation) | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> error - ("Cannot use mutual definition with well-founded recursion") + ("Cannot use mutual definition with well-founded recursion or measure") ) (List.combine fixpoint_exprl recdefs) in @@ -493,13 +530,13 @@ let do_generate_principle register_built interactive_proof fixpoint_exprl = let is_rec = List.exists (is_rec fix_names) recdefs in if register_built then register_struct is_rec old_fixpoint_exprl; generate_principle + false register_built fixpoint_exprl recdefs interactive_proof - true (Functional_principles_proofs.prove_princ_for_struct interactive_proof); - if register_built then derive_inversion fix_names; + if register_built then derive_inversion fix_names; true; in () @@ -517,9 +554,13 @@ let rec add_args id new_args b = | CArrow(loc,b1,b2) -> CArrow(loc,add_args id new_args b1, add_args id new_args b2) | CProdN(loc,nal,b1) -> - CProdN(loc,List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, add_args id new_args b1) + CProdN(loc, + List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, + add_args id new_args b1) | CLambdaN(loc,nal,b1) -> - CLambdaN(loc,List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, add_args id new_args b1) + CLambdaN(loc, + List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal, + add_args id new_args b1) | CLetIn(loc,na,b1,b2) -> CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) | CAppExpl(loc,(pf,r),exprl) -> @@ -530,10 +571,13 @@ let rec add_args id new_args b = | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) end | CApp(loc,(pf,b),bl) -> - CApp(loc,(pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) + CApp(loc,(pf,add_args id new_args b), + List.map (fun (e,o) -> add_args id new_args e,o) bl) | CCases(loc,b_option,cel,cal) -> CCases(loc,option_map (add_args id new_args) b_option, - List.map (fun (b,(na,b_option)) -> add_args id new_args b,(na,option_map (add_args id new_args) b_option)) cel, + List.map (fun (b,(na,b_option)) -> + add_args id new_args b, + (na,option_map (add_args id new_args) b_option)) cel, List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal ) | CLetTuple(loc,nal,(na,b_option),b1,b2) -> @@ -558,7 +602,63 @@ let rec add_args id new_args b = | CPrim _ -> b | CDelimiters _ -> anomaly "add_args : CDelimiters" | CDynamic _ -> anomaly "add_args : CDynamic" +exception Stop of Topconstr.constr_expr + + +(* [chop_n_arrow n t] chops the [n] first arrows in [t] + Acts on Topconstr.constr_expr +*) +let rec chop_n_arrow n t = + if n <= 0 + then t (* If we have already removed all the arrows then return the type *) + else (* If not we check the form of [t] *) + match t with + | Topconstr.CArrow(_,_,t) -> (* If we have an arrow, we discard it and recall [chop_n_arrow] *) + chop_n_arrow (n-1) t + | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : + either we need to discard more than the number of arrows contained + in this product declaration then we just recall [chop_n_arrow] on + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows + than the number we need to chop and then we return the new type + *) + begin + try + let new_n = + let rec aux (n:int) = function + [] -> n + | (nal,t'')::nal_ta' -> + let nal_l = List.length nal in + if n >= nal_l + then + aux (n - nal_l) nal_ta' + else + let new_t' = Topconstr.CProdN(dummy_loc,((snd (list_chop n nal)),t'')::nal_ta',t') + in + raise (Stop new_t') + in + aux n nal_ta' + in + chop_n_arrow new_n t' + with Stop t -> t + end + | _ -> anomaly "Not enough products" + +let rec get_args b t : Topconstr.local_binder list * + Topconstr.constr_expr * Topconstr.constr_expr = + match b with + | Topconstr.CLambdaN (loc, (nal_ta), b') -> + begin + let n = + (List.fold_left (fun n (nal,_) -> + n+List.length nal) 0 nal_ta ) + in + let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in + (List.map (fun (nal,ta) -> + (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t'' + end + | _ -> [],b,t let make_graph (f_ref:global_reference) = @@ -578,68 +678,14 @@ let make_graph (f_ref:global_reference) = let env = Global.env () in let body = (force b) in let extern_body,extern_type = - let old_implicit_args = Impargs.is_implicit_args () - and old_strict_implicit_args = Impargs.is_strict_implicit_args () - and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in - let old_rawprint = !Options.raw_print in - Options.raw_print := true; - Impargs.make_implicit_args false; - Impargs.make_strict_implicit_args false; - Impargs.make_contextual_implicit_args false; - try - let res = Constrextern.extern_constr false env body in - let res' = Constrextern.extern_type false env c_body.const_type in - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Options.raw_print := old_rawprint; - res,res' - with - | UserError(s,msg) as e -> - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Options.raw_print := old_rawprint; - raise e - | e -> - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Options.raw_print := old_rawprint; - raise e - in - let rec get_args b t : Topconstr.local_binder list * - Topconstr.constr_expr * Topconstr.constr_expr = -(* Pp.msgnl (str "body: " ++Ppconstr.pr_lconstr_expr b); *) -(* Pp.msgnl (str "type: " ++ Ppconstr.pr_lconstr_expr t); *) -(* Pp.msgnl (fnl ()); *) - match b with - | Topconstr.CLambdaN (loc, (nal_ta), b') -> - begin - let n = - (List.fold_left (fun n (nal,_) -> - n+List.length nal) 0 nal_ta ) - in - let rec chop_n_arrow n t = - if n > 0 - then - match t with - | Topconstr.CArrow(_,_,t) -> chop_n_arrow (n-1) t - | Topconstr.CProdN(_,nal_ta',t') -> - let n' = - List.fold_left - (fun n (nal,t'') -> - n+List.length nal) n nal_ta' - in -(* assert (n'<= n); *) - chop_n_arrow (n - n') t' - | _ -> anomaly "Not enough products" - else t - in - let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in - (List.map (fun (nal,ta) -> (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t'' - end - | _ -> [],b,t + with_full_print + (fun () -> + (Constrextern.extern_constr false env body, + Constrextern.extern_type false env + (Typeops.type_of_constant_type env c_body.const_type) + ) + ) + () in let (nal_tas,b,t) = get_args extern_body extern_type in let expr_list = @@ -659,7 +705,8 @@ let make_graph (f_ref:global_reference) = ) in let rec_id = - match List.nth bl' (out_some n) with |(_,Name id) -> id | _ -> anomaly "" + match List.nth bl' (out_some n) with + |(_,Name id) -> id | _ -> anomaly "" in let new_args = List.flatten @@ -667,7 +714,10 @@ let make_graph (f_ref:global_reference) = (function | Topconstr.LocalRawDef (na,_)-> [] | Topconstr.LocalRawAssum (nal,_) -> - List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n))) nal + List.map + (fun (loc,n) -> + CRef(Libnames.Ident(loc, Nameops.out_name n))) + nal ) nal_tas ) @@ -685,7 +735,9 @@ let make_graph (f_ref:global_reference) = do_generate_principle false false expr_list; (* We register the infos *) let mp,dp,_ = repr_con c in - List.iter (fun (id,_,_,_,_) -> add_Function (make_con mp dp (label_of_id id))) expr_list + List.iter + (fun (id,_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) + expr_list (* let make_graph _ = assert false *) diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml index f41aac20..13b242d5 100644 --- a/contrib/funind/indfun_common.ml +++ b/contrib/funind/indfun_common.ml @@ -5,8 +5,8 @@ open Libnames let mk_prefix pre id = id_of_string (pre^(string_of_id id)) let mk_rel_id = mk_prefix "R_" -let mk_correct_id id = Nameops.add_suffix id "_correct" -let mk_complete_id id = Nameops.add_suffix id "_complete" +let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" +let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" let msgnl m = @@ -233,6 +233,32 @@ let get_proof_clean do_reduce = Pfedit.delete_current_proof (); result +let with_full_print f a = + let old_implicit_args = Impargs.is_implicit_args () + and old_strict_implicit_args = Impargs.is_strict_implicit_args () + and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in + let old_rawprint = !Options.raw_print in + Options.raw_print := true; + Impargs.make_implicit_args false; + Impargs.make_strict_implicit_args false; + Impargs.make_contextual_implicit_args false; + try + let res = f a in + Impargs.make_implicit_args old_implicit_args; + Impargs.make_strict_implicit_args old_strict_implicit_args; + Impargs.make_contextual_implicit_args old_contextual_implicit_args; + Options.raw_print := old_rawprint; + res + with + | e -> + Impargs.make_implicit_args old_implicit_args; + Impargs.make_strict_implicit_args old_strict_implicit_args; + Impargs.make_contextual_implicit_args old_contextual_implicit_args; + Options.raw_print := old_rawprint; + raise e + + + @@ -248,14 +274,18 @@ type function_info = rect_lemma : constant option; rec_lemma : constant option; prop_lemma : constant option; + is_general : bool; (* Has this function been defined using general recursive definition *) } -type function_db = function_info list +(* type function_db = function_info list *) + +(* let function_table = ref ([] : function_db) *) -let function_table = ref ([] : function_db) - +let from_function = ref Cmap.empty +let from_graph = ref Indmap.empty +(* let rec do_cache_info finfo = function | [] -> raise Not_found | (finfo'::finfos as l) -> @@ -274,6 +304,12 @@ let cache_Function (_,(finfos)) = in if new_tbl != !function_table then function_table := new_tbl +*) + +let cache_Function (_,finfos) = + from_function := Cmap.add finfos.function_constant finfos !from_function; + from_graph := Indmap.add finfos.graph_ind finfos !from_graph + let load_Function _ = cache_Function let open_Function _ = cache_Function @@ -307,6 +343,7 @@ let subst_Function (_,subst,finfos) = rect_lemma = rect_lemma' ; rec_lemma = rec_lemma'; prop_lemma = prop_lemma'; + is_general = finfos.is_general } let classify_Function (_,infos) = Libobject.Substitute infos @@ -342,6 +379,7 @@ let discharge_Function (_,finfos) = rect_lemma = rect_lemma'; rec_lemma = rec_lemma'; prop_lemma = prop_lemma' ; + is_general = finfos.is_general } open Term @@ -357,7 +395,8 @@ let pr_info f_info = str "prop_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++ str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () -let pr_table l = +let pr_table tb = + let l = Cmap.fold (fun k v acc -> v::acc) tb [] in Util.prlist_with_sep fnl pr_info l let in_Function,out_Function = @@ -376,17 +415,16 @@ let in_Function,out_Function = (* Synchronisation with reset *) let freeze () = - let tbl = !function_table in -(* Pp.msgnl (str "freezing function_table : " ++ pr_table tbl); *) - tbl - -let unfreeze l = + !from_function,!from_graph +let unfreeze (functions,graphs) = (* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *) - function_table := - l + from_function := functions; + from_graph := graphs + let init () = (* Pp.msgnl (str "reseting function_table"); *) - function_table := [] + from_function := Cmap.empty; + from_graph := Indmap.empty let _ = Summary.declare_summary "functions_db_sum" @@ -405,18 +443,18 @@ let find_or_none id = let find_Function_infos f = - List.find (fun finfo -> finfo.function_constant = f) !function_table + Cmap.find f !from_function let find_Function_of_graph ind = - List.find (fun finfo -> finfo.graph_ind = ind) !function_table + Indmap.find ind !from_graph let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) Lib.add_anonymous_leaf (in_Function finfo) -let add_Function f = +let add_Function is_general f = let f_id = id_of_label (con_label f) in let equation_lemma = find_or_none (mk_equation_id f_id) and correctness_lemma = find_or_none (mk_correct_id f_id) @@ -436,12 +474,14 @@ let add_Function f = rect_lemma = rect_lemma; rec_lemma = rec_lemma; prop_lemma = prop_lemma; - graph_ind = graph_ind + graph_ind = graph_ind; + is_general = is_general + } in update_Function finfos -let pr_table () = pr_table !function_table +let pr_table () = pr_table !from_function (*********************************) (* Debuging *) let function_debug = ref false @@ -464,3 +504,5 @@ let do_observe () = +exception Building_graph of exn +exception Defining_principle of exn diff --git a/contrib/funind/indfun_common.mli b/contrib/funind/indfun_common.mli index 00e1ce8d..7da1d6f0 100644 --- a/contrib/funind/indfun_common.mli +++ b/contrib/funind/indfun_common.mli @@ -73,6 +73,12 @@ val get_proof_clean : bool -> +(* [with_full_print f a] applies [f] to [a] in full printing environment + + This function preserves the print settings +*) +val with_full_print : ('a -> 'b) -> 'a -> 'b + (*****************) @@ -86,12 +92,13 @@ type function_info = rect_lemma : constant option; rec_lemma : constant option; prop_lemma : constant option; + is_general : bool; } val find_Function_infos : constant -> function_info val find_Function_of_graph : inductive -> function_info (* WARNING: To be used just after the graph definition !!! *) -val add_Function : constant -> unit +val add_Function : bool -> constant -> unit val update_Function : function_info -> unit @@ -101,5 +108,10 @@ val pr_info : function_info -> Pp.std_ppcmds val pr_table : unit -> Pp.std_ppcmds -val function_debug : bool ref +(* val function_debug : bool ref *) val do_observe : unit -> bool + +(* To localize pb *) +exception Building_graph of exn +exception Defining_principle of exn + diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/indfun_main.ml4 index 00b5f28c..26a1066c 100644 --- a/contrib/funind/indfun_main.ml4 +++ b/contrib/funind/indfun_main.ml4 @@ -103,10 +103,28 @@ TACTIC EXTEND snewfunind END +let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_coma prc + +ARGUMENT EXTEND constr_coma_sequence' + TYPED AS constr_list + PRINTED BY pr_constr_coma_sequence +| [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ] +| [ constr(c) ] -> [ [c] ] +END + +let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc + +ARGUMENT EXTEND auto_using' + TYPED AS constr_list + PRINTED BY pr_auto_using +| [ "using" constr_coma_sequence'(l) ] -> [ l ] +| [ ] -> [ [] ] +END + VERNAC ARGUMENT EXTEND rec_annotation2 [ "{" "struct" ident(id) "}"] -> [ Struct id ] -| [ "{" "wf" constr(r) ident_opt(id) "}" ] -> [ Wf(r,id) ] -| [ "{" "measure" constr(r) ident_opt(id) "}" ] -> [ Mes(r,id) ] +| [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ] +| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] END @@ -131,8 +149,8 @@ VERNAC ARGUMENT EXTEND rec_definition2 let check_exists_args an = try let id = match an with - | Struct id -> id | Wf(_,Some id) -> id | Mes(_,Some id) -> id - | Wf(_,None) | Mes(_,None) -> failwith "check_exists_args" + | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id + | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" in (try ignore(Util.list_index (Name id) names - 1); annot with Not_found -> Util.user_err_loc @@ -214,11 +232,17 @@ END (* FINDUCTION *) (* comment this line to see debug msgs *) -(* let msg x = () ;; let pr_lconstr c = str "" *) +let msg x = () ;; let pr_lconstr c = str "" (* uncomment this to see debugging *) let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) +let prNamedConstr s c = + begin + msg(str ""); + msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n"); + msg(str ""); + end @@ -266,6 +290,55 @@ let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = max_rel = max_rel; onlyvars = List.for_all isVar args } ::subres +let mkEq typ c1 c2 = + mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) + + +let poseq_unsafe idunsafe cstr gl = + let typ = Tacmach.pf_type_of gl cstr in + tclTHEN + (Tactics.letin_tac true (Name idunsafe) cstr allClauses) + (tclTHENFIRST + (Tactics.assert_as true IntroAnonymous (mkEq typ (mkVar idunsafe) cstr)) + Tactics.reflexivity) + gl + + +let poseq id cstr gl = + let x = Tactics.fresh_id [] id gl in + poseq_unsafe x cstr gl + +(* dirty? *) + +let list_constr_largs = ref [] + +let rec poseq_list_ids_rec lcstr gl = + match lcstr with + | [] -> tclIDTAC gl + | c::lcstr' -> + match kind_of_term c with + | Var _ -> + (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl) + | _ -> + let _ = prstr "c = " in + let _ = prconstr c in + let _ = prstr "\n" in + let typ = Tacmach.pf_type_of gl c in + let cname = Termops.id_of_name_using_hdchar (Global.env()) typ Anonymous in + let x = Tactics.fresh_id [] cname gl in + let _ = list_constr_largs:=mkVar x :: !list_constr_largs in + let _ = prstr " list_constr_largs = " in + let _ = prlistconstr !list_constr_largs in + let _ = prstr "\n" in + + tclTHEN + (poseq_unsafe x c) + (poseq_list_ids_rec lcstr') + gl + +let poseq_list_ids lcstr gl = + let _ = list_constr_largs := [] in + poseq_list_ids_rec lcstr gl (** [find_fapp test g] returns the list of [app_info] of all calls to functions that satisfy [test] in the conclusion of goal g. Trivial @@ -296,11 +369,17 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l if List.length ordered_info_list = 0 then Util.error "function not found in goal\n"; let taclist: Proof_type.tactic list = List.map - (fun info -> - (tclTHEN - (functional_induction true (applist (info.fname, info.largs)) - None IntroAnonymous) + (fun info -> + (tclTHEN + (tclTHEN (poseq_list_ids info.largs) + ( + fun gl -> + (functional_induction + true (applist (info.fname, List.rev !list_constr_largs)) + None IntroAnonymous) gl)) nexttac)) ordered_info_list in + (* we try each (f t u v) until one does not fail *) + (* TODO: try also to mix functional schemes *) tclFIRST taclist g @@ -313,9 +392,8 @@ let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = match oi with | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *) | None -> - (* Default heuristic: keep only occurrence where all arguments + (* Default heuristic: put first occurrences where all arguments are *bound* (meaning already introduced) variables *) - (* TODO: put other funcalls at the end instead of deleting them *) let ordering x y = if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *) else if x.free && x.onlyvars then -1 @@ -325,6 +403,7 @@ let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = List.sort ordering + TACTIC EXTEND finduction ["finduction" ident(id) natural_opt(oi)] -> [ @@ -353,3 +432,36 @@ TACTIC EXTEND fauto END + +TACTIC EXTEND poseq + [ "poseq" ident(x) constr(c) ] -> + [ poseq x c ] +END + +VERNAC COMMAND EXTEND Showindinfo + [ "showindinfo" ident(x) ] -> [ Merge.showind x ] +END + +VERNAC COMMAND EXTEND MergeFunind + [ "Mergeschemes" lconstr(c) "with" lconstr(c') "using" ident(id) ] -> + [ + let c1 = Constrintern.interp_constr Evd.empty (Global.env()) c in + let c2 = Constrintern.interp_constr Evd.empty (Global.env()) c' in + let id1,args1 = + try + let hd,args = destApp c1 in + if Term.isInd hd then hd , args + else raise (Util.error "Ill-formed (fst) argument") + with Invalid_argument _ + -> Util.error ("Bad argument form for merging schemes") in + let id2,args2 = + try + let hd,args = destApp c2 in + if isInd hd then hd , args + else raise (Util.error "Ill-formed (snd) argument") + with Invalid_argument _ + -> Util.error ("Bad argument form for merging schemes") in + (* TOFO: enlever le ignore et declarer l'inductif *) + ignore(Merge.merge c1 c2 args1 args2 id) + ] +END diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml index 084ec7e0..04110ea9 100644 --- a/contrib/funind/invfun.ml +++ b/contrib/funind/invfun.ml @@ -44,25 +44,6 @@ let pr_with_bindings prc prlc (c,bl) = let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = pr_with_bindings prc prc (c,bl) -let pr_elim_scheme el = - let env = Global.env () in - let msg = str "params := " ++ Printer.pr_rel_context env el.params in - let env = Environ.push_rel_context el.params env in - let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in - let env = Environ.push_rel_context el.predicates env in - let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in - let env = Environ.push_rel_context el.branches env in - let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in - let env = Environ.push_rel_context el.args env in - let msg = - Util.option_fold_right - (fun o msg -> msg ++ fnl () ++ str "indarg := " ++ Printer.pr_rel_context env [o]) - el.indarg - msg - in - let env = Util.option_fold_right (fun o env -> Environ.push_rel_context [o] env) el.indarg env in - msg ++ fnl () ++ str "concl := " ++ Printer.pr_lconstr_env env el.concl - (* The local debuging mechanism *) let msgnl = Pp.msgnl @@ -120,7 +101,7 @@ let id_to_constr id = let generate_type g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let graph_arity = Inductive.type_of_inductive (Global.lookup_inductive (destInd graph)) in + let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with @@ -443,17 +424,17 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let params_bindings,avoid = List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> - let id = Termops.next_global_ident_away false (Nameops.out_name x) avoid in + let id = Nameops.next_ident_away (Nameops.out_name x) avoid in (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid ) - ([],[]) + ([],pf_ids_of_hyps g) princ_infos.params (List.rev params) in let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> - let id = Termops.next_global_ident_away false (Nameops.out_name x) avoid in + let id = Nameops.next_ident_away (Nameops.out_name x) avoid in (dummy_loc,Rawterm.NamedHyp id,nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -471,7 +452,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (observe_tac "functional_induction" ( fun g -> observe - (str "princ" ++ pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); + (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); functional_induction false (applist(funs_constr.(i),List.map mkVar args_names)) (Some (mkVar principle_id,bindings)) pat g @@ -493,6 +474,31 @@ let generalize_depedent_of x hyp g = (pf_hyps g) g + + + + + +let rec reflexivity_with_destruct_cases g = + let destruct_case () = + try + match kind_of_term (snd (destApp (pf_concl g))).(2) with + | Case(_,_,v,_) -> + tclTHENSEQ[ + h_case (v,Rawterm.NoBindings); + intros; + observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases + ] + | _ -> reflexivity + with _ -> reflexivity + in + tclFIRST + [ reflexivity; + destruct_case () + ] + g + + (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] is the tactic used to prove completness lemma. @@ -567,11 +573,12 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = *) let rewrite_tac j ids : tactic = let graph_def = graphs.(j) in - if Rtree.is_infinite graph_def.mind_recargs + let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in + if infos.is_general || Rtree.is_infinite graph_def.mind_recargs then let eq_lemma = - try out_some (find_Function_infos (destConst funcs.(j))).equation_lemma - with Failure "out_some" | Not_found -> anomaly "Cannot find equation lemma" + try out_some (infos).equation_lemma + with Failure "out_some" -> anomaly "Cannot find equation lemma" in tclTHENSEQ[ tclMAP h_intro ids; @@ -677,8 +684,8 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); (* introduce hypothesis with some rewrite *) (intros_with_rewrite); - (* The proof is complete *) - observe_tac "reflexivity" (reflexivity) + (* The proof is (almost) complete *) + observe_tac "reflexivity" (reflexivity_with_destruct_cases) ] g in @@ -758,7 +765,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); - Pfedit.by (observe_tac ("procve correctness ("^(string_of_id f_id)^")") (proving_tac i)); + Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i)); do_save (); let finfo = find_Function_infos f_as_constant in update_Function @@ -968,10 +975,17 @@ let invfun qhyp f g = functional_inversion kn hid f2 f_correct g with | Failure "" -> - errorlabstrm "" (Ppconstr.pr_id hid ++ str " must contain at leat one function") + errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function") | Failure "out_some" -> - error "Cannot use equivalence with graph for any side of equality" - | Not_found -> error "No graph found for any side of equality" + if do_observe () + then + error "Cannot use equivalence with graph for any side of the equality" + else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + | Not_found -> + if do_observe () + then + error "No graph found for any side of equality" + else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") ) diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml new file mode 100644 index 00000000..1b796a81 --- /dev/null +++ b/contrib/funind/merge.ml @@ -0,0 +1,826 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* Merging of induction principles. *) + +(*i $Id: i*) + +open Util +open Topconstr +open Vernacexpr +open Pp +open Names +open Term +open Declarations +open Environ +open Rawterm +open Rawtermops + +(** {1 Utilities} *) + +(** {2 Useful operations on constr and rawconstr} *) + +(** Substitutions in constr *) +let compare_constr_nosub t1 t2 = + if compare_constr (fun _ _ -> false) t1 t2 + then true + else false + +let rec compare_constr' t1 t2 = + if compare_constr_nosub t1 t2 + then true + else (compare_constr (compare_constr') t1 t2) + +let rec substitterm prof t by_t in_u = + if (compare_constr' (lift prof t) in_u) + then (lift prof by_t) + else map_constr_with_binders succ + (fun i -> substitterm i t by_t) prof in_u + +let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl + +let understand = Pretyping.Default.understand Evd.empty (Global.env()) + +(** Operations on names and identifiers *) +let id_of_name = function + Anonymous -> id_of_string "H" + | Name id -> id;; +let name_of_string str = Name (id_of_string str) +let string_of_name nme = string_of_id (id_of_name nme) + +(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) +let isVarf f x = + match x with + | RVar (_,x) -> Pervasives.compare x f = 0 + | _ -> false + +(** [ident_global_exist id] returns true if identifier [id] is linked + in global environment. *) +let ident_global_exist id = + try + let ans = CRef (Libnames.Ident (dummy_loc,id)) in + let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in + true + with _ -> false + +(** [next_ident_fresh id] returns a fresh identifier (ie not linked in + global env) with base [id]. *) +let next_ident_fresh (id:identifier) = + let res = ref id in + while ident_global_exist !res do res := Nameops.lift_ident !res done; + !res + + +(** {2 Debugging} *) +(* comment this line to see debug msgs *) +let msg x = () ;; let pr_lconstr c = str "" +(* uncomment this to see debugging *) +let prconstr c = msg (str" " ++ Printer.pr_lconstr c) +let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") +let prlistconstr lc = List.iter prconstr lc +let prstr s = msg(str s) +let prNamedConstr s c = + begin + msg(str ""); + msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} "); + msg(str ""); + end +let prNamedRConstr s c = + begin + msg(str ""); + msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} "); + msg(str ""); + end +let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc +let prNamedLConstr s lc = + begin + prstr "[§§§ "; + prstr s; + prNamedLConstr_aux lc; + prstr " §§§]\n"; + end +let prNamedLDecl s lc = + begin + prstr s; prstr "\n"; + List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; + prstr "\n"; + end + +let showind (id:identifier) = + let cstrid = Tacinterp.constr_of_id (Global.env()) id in + let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in + let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in + List.iter (fun (nm, optcstr, tp) -> + print_string (string_of_name nm^":"); + prconstr tp; print_string "\n") + ib1.mind_arity_ctxt; + (match ib1.mind_arity with + | Monomorphic x -> + Printf.printf "arity :"; prconstr x.mind_user_arity + | Polymorphic x -> + Printf.printf "arity : universe?"); + Array.iteri + (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) + ib1.mind_user_lc + +(** {2 Misc} *) + +exception Found of int + +(* Array scanning *) +let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = + try + for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; + None + with Found i -> Some i + +let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = + try + for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; + Array.length arr (* all elt are positive *) + with Found i -> i + +let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = + let i = ref 0 in + Array.fold_left + (fun acc x -> + let res = f !i acc x in i := !i + 1; res) + acc arr + +(* Like list_chop but except that [i] is the size of the suffix of [l]. *) +let list_chop_end i l = + let size_prefix = List.length l -i in + if size_prefix < 0 then failwith "list_chop_end" + else list_chop size_prefix l + +let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = + let i = ref 0 in + List.fold_left + (fun acc x -> + let res = f !i acc x in i := !i + 1; res) + acc arr + +let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = + let i = ref 0 in + List.filter (fun x -> let res = f !i x in i := !i + 1; res) l + + +(** Iteration module *) +module For = +struct + let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f) + let rec foldup i j (f: 'a -> int -> 'a) acc = + if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc + let rec folddown i j (f: 'a -> int -> 'a) acc = + if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc + let fold i j = if i<j then foldup i j else folddown i j +end + + +(** {1 Parameters shifting and linking information} *) + +(** This type is used to deal with debruijn linked indices. When a + variable is linked to a previous one, we will ignore it and refer + to previous one. *) +type linked_var = + | Linked of int + | Unlinked + | Funres + +(** When merging two graphs, parameters may become regular arguments, + and thus be shifted. This type describe the result of computing + the changes. *) +type 'a shifted_params = + { + nprm1:'a; + nprm2:'a; + prm2_unlinked:'a list; (* ranks of unlinked params in nprms2 *) + nuprm1:'a; + nuprm2:'a; + nargs1:'a; + nargs2:'a; + } + + +let prlinked x = + match x with + | Linked i -> Printf.sprintf "Linked %d" i + | Unlinked -> Printf.sprintf "Unlinked" + | Funres -> Printf.sprintf "Funres" + +let linkmonad f lnkvar = + match lnkvar with + | Linked i -> Linked (f i) + | Unlinked -> Unlinked + | Funres -> Funres + +let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar + +(* This map is used to deal with debruijn linked indices. *) +module Link = Map.Make (struct type t = int let compare = Pervasives.compare end) + +let pr_links l = + Printf.printf "links:\n"; + Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l; + Printf.printf "_____________\n" + +type 'a merged_arg = + | Prm_stable of 'a + | Prm_linked of 'a + | Prm_arg of 'a + | Arg_stable of 'a + | Arg_linked of 'a + | Arg_funres + +type merge_infos = + { + ident:identifier; (* new inductive name *) + mib1: mutual_inductive_body; + oib1: one_inductive_body; + mib2: mutual_inductive_body; + oib2: one_inductive_body; + (* Array of links of the first inductive (should be all stable) *) + lnk1: int merged_arg array; + (* Array of links of the second inductive (point to the first ind param/args) *) + lnk2: int merged_arg array; + (* number of rec params of ind1 which remai rec param in merge *) + nrecprms1: int; + (* number of other rec params of ind1 (which become non parm) *) + notherprms1:int; + (* number of functional result params of ind2 (which become non parm) *) + nfunresprms1:int; + (* list of decl of rec parms from ind1 which remain parms *) + recprms1: rel_declaration list; + (* List of other rec parms from ind1 *) + otherprms1: rel_declaration list; (* parms that became args *) + funresprms1: rel_declaration list; (* parms that are functional result args *) + (* number of rec params of ind2 which remain rec param in merge (and not linked) *) + nrecprms2: int; + (* number of other params of ind2 (which become non rec parm) *) + notherprms2:int; + (* number of functional result params of ind2 (which become non parm) *) + nfunresprms2:int; + (* list of decl of rec parms from ind2 which remain parms (and not linked) *) + recprms2: rel_declaration list; + (* List of other rec parms from ind2 (which are linked or become non parm) *) + otherprms2: rel_declaration list; + funresprms2: rel_declaration list; (* parms that are functional result args *) + } + + +let pr_merginfo x = + let i,s= + match x with + | Prm_linked i -> Some i,"Prm_linked" + | Arg_linked i -> Some i,"Arg_linked" + | Prm_stable i -> Some i,"Prm_stable" + | Prm_arg i -> Some i,"Prm_arg" + | Arg_stable i -> Some i,"Arg_stable" + | Arg_funres -> None , "Arg_funres" in + match i with + | Some i -> Printf.sprintf "%s(%d)" s i + | None -> Printf.sprintf "%s" s + +let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false + +let isArg_stable x = match x with Arg_stable _ -> true | _ -> false + +let isArg_funres x = match x with Arg_funres -> true | _ -> false + +let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list = + let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in + let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in + let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in + prms@args@fres + +(** Reverse the link map, keeping only linked vars, elements are list + of int as several vars may be linked to the same var. *) +let revlinked lnk = + For.fold 0 (Array.length lnk - 1) + (fun acc k -> + match lnk.(k) with + | Unlinked | Funres -> acc + | Linked i -> + let old = try Link.find i acc with Not_found -> [] in + Link.add i (k::old) acc) + Link.empty + +let array_switch arr i j = + let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux + +let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = + let larr = Array.of_list l in + let _ = + Array.iteri + (fun j x -> + match x with + | Prm_linked i -> array_switch larr i j + | Arg_linked i -> array_switch larr i j + | Prm_stable i -> () + | Prm_arg i -> () + | Arg_stable i -> () + | Arg_funres -> () + ) lnk in + filter_shift_stable lnk (Array.to_list larr) + + + + +(** {1 Utilities for merging} *) + +let ind1name = id_of_string "__ind1" +let ind2name = id_of_string "__ind2" + +(** Performs verifications on two graphs before merging: they must not + be co-inductive, and for the moment they must not be mutual + either. *) +let verify_inds mib1 mib2 = + if not mib1.mind_finite then error "First argument is coinductive"; + if not mib2.mind_finite then error "Second argument is coinductive"; + if mib1.mind_ntypes <> 1 then error "First argument is mutual"; + if mib2.mind_ntypes <> 1 then error "Second argument is mutual"; + () + + +(** {1 Merging function graphs} *) + +(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec + uniform and ordinary ones) of mutual inductives [mib1] and [mib2] + remain uniform when linked by [lnk]. All parameters are + considered, ie we take parameters of the first inductive body of + [mib1] and [mib2]. + + Explanation: The two inductives have parameters, some of the first + are recursively uniform, some of the last are functional result of + the functional graph. + + (I x1 x2 ... xk ... xk' ... xn) + (J y1 y2 ... xl ... yl' ... ym) + + Problem is, if some rec unif params are linked to non rec unif + ones, they become non rec (and the following too). And functinal + argument have to be shifted at the end *) +let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id = + let linked_targets = revlinked lnk2 in + let is_param_of_mib1 x = x < mib1.mind_nparams_rec in + let is_param_of_mib2 x = x < mib2.mind_nparams_rec in + let is_targetted_by_non_recparam_lnk1 i = + try + let targets = Link.find i linked_targets in + List.exists (fun x -> not (is_param_of_mib2 x)) targets + with Not_found -> false in + let mlnk1 = + Array.mapi + (fun i lkv -> + let isprm = is_param_of_mib1 i in + let prmlost = is_targetted_by_non_recparam_lnk1 i in + match isprm , prmlost, lnk1.(i) with + | true , true , _ -> Prm_arg i (* recparam becoming ordinary *) + | true , false , _-> Prm_stable i (* recparam remains recparam*) + | false , false , Funres -> Arg_funres + | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *) + | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *) + lnk1 in + let mlnk2 = + Array.mapi + (fun i lkv -> + (* Is this correct if some param of ind2 is lost? *) + let isprm = is_param_of_mib2 i in + match isprm , lnk2.(i) with + | true , Linked j when not (is_param_of_mib1 j) -> + Prm_arg j (* recparam becoming ordinary *) + | true , Linked j -> Prm_linked j (*recparam linked to recparam*) + | true , Unlinked -> Prm_stable i (* recparam remains recparam*) + | false , Linked j -> Arg_linked j (* Args of lnk2 lost *) + | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *) + | false , Funres -> Arg_funres + | true , Funres -> assert false (* fun res cannot be a rec param *) + ) + lnk2 in + let oib1 = mib1.mind_packets.(0) in + let oib2 = mib2.mind_packets.(0) in + (* count params remaining params *) + let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in + let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in + let bldprms arity_ctxt mlnk = + list_fold_lefti + (fun i (acc1,acc2,acc3) x -> + match mlnk.(i) with + | Prm_stable _ -> x::acc1 , acc2 , acc3 + | Prm_arg _ | Arg_stable _ -> acc1 , x::acc2 , acc3 + | Arg_funres -> acc1 , acc2 , x::acc3 + | _ -> acc1 , acc2 , acc3) (* Prm_linked and Arg_xxx = forget it *) + ([],[],[]) arity_ctxt in + let recprms1,otherprms1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in + let recprms2,otherprms2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in + { + ident=id; + mib1=mib1; + oib1 = oib1; + mib2=mib2; + oib2 = oib2; + lnk1 = mlnk1; + lnk2 = mlnk2; + nrecprms1 = n_params1; + recprms1 = recprms1; + otherprms1 = otherprms1; + funresprms1 = funresprms1; + notherprms1 = Array.length mlnk1 - n_params1; + nfunresprms1 = List.length funresprms1; + nrecprms2 = n_params2; + recprms2 = recprms2; + otherprms2 = otherprms2; + funresprms2 = funresprms2; + notherprms2 = Array.length mlnk2 - n_params2; + nfunresprms2 = List.length funresprms2; + } + + + + +(** {1 Merging functions} *) + +exception NoMerge + +(* lnk is an link array of *all* args (from 1 and 2) *) +let merge_app c1 c2 id1 id2 shift filter_shift_stable = + let lnk = Array.append shift.lnk1 shift.lnk2 in + match c1 , c2 with + | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> + let args = filter_shift_stable lnk (arr1 @ arr2) in + RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args) + | RApp(_,f1, arr1), RApp(_,f2,arr2) -> raise NoMerge + | _ -> raise NoMerge + +let merge_app_unsafe c1 c2 shift filter_shift_stable = + let lnk = Array.append shift.lnk1 shift.lnk2 in + match c1 , c2 with + | RApp(_,f1, arr1), RApp(_,f2,arr2) -> + let args = filter_shift_stable lnk (arr1 @ arr2) in + RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args) + | _ -> raise NoMerge + + + +(* Heuristic when merging two lists of hypothesis: merge every rec + calls of nrach 1 with all rec calls of branch 2. *) +(* TODO: reecrire cette heuristique (jusqu'a merge_types) *) +let onefoud = ref false (* Ugly *) + +let rec merge_rec_hyps shift accrec (ltyp:(Names.name * Rawterm.rawconstr) list) + filter_shift_stable = + match ltyp with + | [] -> [] + | (nme,(RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> + let _ = onefoud := true in + let rechyps = + List.map + (fun (nme,ind) -> + match ind with + | RApp(_,i,args) -> + nme, merge_app_unsafe ind t shift filter_shift_stable + | _ -> assert false) + accrec in + rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable + | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable + + +let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = + List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec + + +let find_app (nme:identifier) (ltyp: (name * rawconstr) list) = + try + ignore + (List.map + (fun x -> + match x with + | _,(RApp(_,f,_)) when isVarf nme f -> raise (Found 0) + | _ -> ()) + ltyp); + false + with Found _ -> true + +let rec merge_types shift accrec1 (ltyp1:(name * rawconstr) list) + concl1 (ltyp2:(name * rawconstr) list) concl2 + : (name * rawconstr) list * rawconstr = + let _ = prstr "MERGE_TYPES\n" in + let _ = prstr "ltyp 1 : " in + let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp1 in + let _ = prstr "\nltyp 2 : " in + let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp2 in + let _ = prstr "\n" in + + + let res = + match ltyp1 with + | [] -> + let isrec1 = (accrec1<>[]) in + let isrec2 = find_app ind2name ltyp2 in + let _ = if isrec2 then prstr " ISREC2 TRUE" else prstr " ISREC2 FALSE" in + let _ = if isrec1 then prstr " ISREC1 TRUE\n" else prstr " ISREC1 FALSE\n" in + let rechyps = + if isrec1 && isrec2 + then merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable + else if isrec1 + (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) + then merge_rec_hyps shift accrec1 (ltyp2@[name_of_string "concl2",concl2]) + filter_shift_stable + else if isrec2 + then merge_rec_hyps shift [name_of_string "concl1",concl1] ltyp2 + filter_shift_stable_right + else [] in + let _ = prstr"\nrechyps : " in + let _ = List.iter + (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) rechyps in + let _ = prstr "MERGE CONCL : " in + let _ = prNamedRConstr "concl1" concl1 in + let _ = prstr " with " in + let _ = prNamedRConstr "concl2" concl2 in + let _ = prstr "\n" in + let concl = + merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in + let _ = prstr "FIN " in + let _ = prNamedRConstr "concl" concl in + let _ = prstr "\n" in + rechyps , concl + | (nme,t1)as e ::lt1 -> + match t1 with + | RApp(_,f,carr) when isVarf ind1name f -> + merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 + | _ -> + let recres, recconcl2 = + merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in + ((nme,t1) :: recres) , recconcl2 + in + res + + +(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of + linked args [allargs2] to target args of [allargs1] as specified + in [shift]. [allargs1] and [allargs2] are in reverse order. Also + returns the list of unlinked vars of [allargs2]. *) +let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array) + (lnk:int merged_arg array) = + array_fold_lefti + (fun i acc e -> + if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *) + else + match e with + | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc + | _ -> acc) + Idmap.empty lnk + +let build_link_map allargs1 allargs2 lnk = + let allargs1 = + Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs1)) in + let allargs2 = + Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs2)) in + build_link_map_aux allargs1 allargs2 lnk + + +(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two + constructor rawtypes [typcstr1] and [typcstr2]. [typcstr1] and + [typcstr2] contain all parameters (including rec. unif. ones) of + their inductive. + + if [typcstr1] and [typcstr2] are of the form: + + forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1) + forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2) + + we build: + + forall recparams1 (recparams2 without linked params), + forall ordparams1 (ordparams2 without linked params), + H1a' -> H2a' -> ... -> H2a' -> H2b' -> ... + -> (newI x1 ... z1 x2 y2 ...z2 without linked params) + + where Hix' have been adapted, ie: + - linked vars have been changed, + - rec calls to I1 and I2 have been replaced by rec calls to + newI. More precisely calls to I1 and I2 have been merge by an + experimental heuristic (in particular if n o rec calls for I1 + or I2 is found, we use the conclusion as a rec call). See + [merge_types] above. + + Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint. + + TODO: return nothing if equalities (after linking) are contradictory. *) +let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) + (typcstr2:rawconstr) : rawconstr = + (* FIXME: les noms des parametres corerspondent en principe au + parametres du niveau mib, mais il faudrait s'en assurer *) + (* shift.nfunresprmsx last args are functional result *) + let nargs1 = + shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in + let nargs2 = + shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in + let allargs1,rest1 = raw_decompose_prod_n nargs1 typcstr1 in + let allargs2,rest2 = raw_decompose_prod_n nargs2 typcstr2 in + (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) + let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in + let rest2 = change_vars linked_map rest2 in + let hyps1,concl1 = raw_decompose_prod rest1 in + let hyps2,concl2' = raw_decompose_prod rest2 in + let ltyp,concl2 = + merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in + let typ = raw_compose_prod concl2 (List.rev ltyp) in + let revargs1 = + list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in + let revargs2 = + list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in + let typwithprms = raw_compose_prod typ (List.rev revargs2 @ List.rev revargs1) in + typwithprms + + +(** constructor numbering *) +let fresh_cstror_suffix , cstror_suffix_init = + let cstror_num = ref 0 in + (fun () -> + let res = string_of_int !cstror_num in + cstror_num := !cstror_num + 1; + res) , + (fun () -> cstror_num := 0) + +(** [merge_constructor_id id1 id2 shift] returns the identifier of the + new constructor from the id of the two merged constructor and + the merging info. *) +let merge_constructor_id id1 id2 shift:identifier = + let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in + next_ident_fresh (id_of_string id) + + + +(** [merge_constructors lnk shift avoid] merges the two list of + constructor [(name*type)]. These are translated to rawterms + first, each of them having distinct var names. *) +let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) + (typcstr1:(identifier * types) list) + (typcstr2:(identifier * types) list) : (identifier * rawconstr) list = + List.flatten + (List.map + (fun (id1,typ1) -> + let typ1 = substitterm 0 (mkRel 1) (mkVar ind1name) typ1 in + let rawtyp1 = Detyping.detype false (Idset.elements avoid) [] typ1 in + let idsoftyp1:Idset.t = ids_of_rawterm rawtyp1 in + List.map + (fun (id2,typ2) -> + let typ2 = substitterm 0 (mkRel 1) (mkVar ind2name) typ2 in + (* Avoid also rawtyp1 names *) + let avoid2 = Idset.union avoid idsoftyp1 in + let rawtyp2 = Detyping.detype false (Idset.elements avoid2) [] typ2 in + let typ = merge_one_constructor shift rawtyp1 rawtyp2 in + let newcstror_id = merge_constructor_id id1 id2 shift in + newcstror_id , typ) + typcstr2) + typcstr1) + +(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two + inductive bodies [oib1] and [oib2], linking with [lnk], params + info in [shift], avoiding identifiers in [avoid]. *) +let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) + (oib2:one_inductive_body) : (identifier * rawconstr) list = + let lcstr1 = Array.to_list oib1.mind_user_lc in + let lcstr2 = Array.to_list oib2.mind_user_lc in + let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in + let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in + cstror_suffix_init(); + merge_constructors shift avoid lcstr1 lcstr2 + +(** [build_raw_params prms_decl avoid] returns a list of variables + attributed to the list of decl [prms_decl], avoiding names in + [avoid]. *) +let build_raw_params prms_decl avoid = + let dummy_constr = compose_prod prms_decl mkProp in + let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in + let res,_ = raw_decompose_prod dummy_rawconstr in + res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr))) + +(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual + inductive bodies [mib1] and [mib2] linking vars with + [lnk]. [shift] information on parameters of the new inductive. + For the moment, inductives are supposed to be non mutual. +*) +let rec merge_mutual_inductive_body + (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) + (shift:merge_infos) = + (* Mutual not treated, we take first ind body of each. *) + let nprms1 = mib1.mind_nparams_rec in (* n# of rec uniform parms of mib1 *) + let prms1 = (* rec uniform parms of mib1 *) + List.map (fun (x,_,y) -> x,y) (fst (list_chop nprms1 mib1.mind_params_ctxt)) in + + (* useless: *) + let prms1_named,avoid' = build_raw_params prms1 [] in + let prms2_named,avoid = build_raw_params prms1 avoid' in + let avoid:Idset.t = List.fold_right Idset.add avoid Idset.empty in + (* *** *) + + merge_inductive_body shift avoid mib1.mind_packets.(0) mib2.mind_packets.(0) + + + +let merge_rec_params_and_arity params1 params2 shift (concl:constr) = + let params = shift.recprms1 @ shift.recprms2 in + let resparams, _ = + List.fold_left + (fun (acc,env) (nme,_,tp) -> + let typ = Constrextern.extern_constr false env tp in + let newenv = Environ.push_rel (nme,None,tp) env in + LocalRawAssum ([(dummy_loc,nme)] , typ) :: acc , newenv) + ([],Global.env()) + params in + let concl = Constrextern.extern_constr false (Global.env()) concl in + let arity,_ = + List.fold_left + (fun (acc,env) (nm,_,c) -> + let typ = Constrextern.extern_constr false env c in + let newenv = Environ.push_rel (nm,None,c) env in + CProdN (dummy_loc, [[(dummy_loc,nm)],typ] , acc) , newenv) + (concl,Global.env()) + (shift.otherprms1@shift.otherprms2@shift.funresprms1@shift.funresprms2) in + resparams,arity + + + +(** [rawterm_list_to_inductive_expr ident rawlist] returns the + induct_expr corresponding to the the list of constructor types + [rawlist], named ident. + FIXME: params et cstr_expr (arity) *) +let rawterm_list_to_inductive_expr mib1 mib2 shift + (rawlist:(identifier * rawconstr) list):inductive_expr = + let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *) + Options.with_option Options.raw_print (Constrextern.extern_rawtype Idset.empty) x in + let lident = dummy_loc, shift.ident in + let bindlist , cstr_expr = (* params , arities *) + merge_rec_params_and_arity + mib1.mind_params_ctxt mib2.mind_params_ctxt shift mkSet in + let lcstor_expr : (bool * (lident * constr_expr)) list = + List.map (* zeta_normalize t ? *) + (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t)) + rawlist in + lident , bindlist , cstr_expr , lcstor_expr + +(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking + variables specified in [lnk]. Graphs are not supposed to be mutual + inductives for the moment. *) +let merge_inductive (ind1: inductive) (ind2: inductive) + (lnk1: linked_var array) (lnk2: linked_var array) id = + let env = Global.env() in + let mib1,_ = Inductive.lookup_mind_specif env ind1 in + let mib2,_ = Inductive.lookup_mind_specif env ind2 in + let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *) + (* compute params that become ordinary args (because linked to ord. args) *) + let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in + let rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in + let indexpr = rawterm_list_to_inductive_expr mib1 mib2 shift_prm rawlist in + (* Declare inductive *) + Command.build_mutual [(indexpr,None)] true (* means: not coinductive *) + + + +let merge (cstr1:constr) (cstr2:constr) (args1:constr array) (args2:constr array) id = + let env = Global.env() in + let ind1,_cstrlist1 = Inductiveops.find_inductive env Evd.empty cstr1 in + let ind2,_cstrlist2 = Inductiveops.find_inductive env Evd.empty cstr2 in + let lnk1 = (* args1 are unlinked. FIXME? mergescheme (G x x) ?? *) + Array.mapi (fun i c -> Unlinked) args1 in + let _ = lnk1.(Array.length lnk1 - 1) <- Funres in (* last arg is functional result *) + let lnk2 = (* args2 may be linked to args1 members. FIXME: same + as above: vars may be linked inside args2?? *) + Array.mapi + (fun i c -> + match array_find args1 (fun i x -> x=c) with + | Some j -> Linked j + | None -> Unlinked) + args2 in + let _ = lnk2.(Array.length lnk2 - 1) <- Funres in (* last arg is functional result *) + let resa = merge_inductive ind1 ind2 lnk1 lnk2 id in + resa + + + + + +(* @article{ bundy93rippling, + author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill", + title = "Rippling: A Heuristic for Guiding Inductive Proofs", + journal = "Artificial Intelligence", + volume = "62", + number = "2", + pages = "185-253", + year = "1993", + url = "citeseer.ist.psu.edu/bundy93rippling.html" } + + *) +(* +*** Local Variables: *** +*** compile-command: "make -C ../.. contrib/funind/merge.cmo" *** +*** indent-tabs-mode: nil *** +*** End: *** +*) diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml index dbf2f944..aca84f06 100644 --- a/contrib/funind/rawterm_to_relation.ml +++ b/contrib/funind/rawterm_to_relation.ml @@ -789,7 +789,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve avoid matched_expr in - (* We know create the precondition of this branch i.e. + (* We now create the precondition of this branch i.e. 1- the list of variable appearing in the different patterns of this branch and the list of equation stating than el = patl (List.flatten ...) @@ -1074,8 +1074,8 @@ let rec rebuild_return_type rt = | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None)) -let build_inductive - parametrize funnames (funsargs: (Names.name * rawconstr * bool) list list) +let do_build_inductive + funnames (funsargs: (Names.name * rawconstr * bool) list list) returned_types (rtl:rawconstr list) = let _time1 = System.get_time () in @@ -1085,7 +1085,7 @@ let build_inductive let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in (* alpha_renaming of the body to prevent variable capture during manipulation *) - let rtl_alpha = List.map (function rt -> (alpha_rt [] rt) ) rtl in + let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in let rta = Array.of_list rtl_alpha in (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious @@ -1108,19 +1108,7 @@ let build_inductive (function result (* (args',concl') *) -> let rt = compose_raw_context result.context result.value in let nb_args = List.length funsargs.(i) in -(* let old_implicit_args = Impargs.is_implicit_args () *) -(* and old_strict_implicit_args = Impargs.is_strict_implicit_args () *) -(* and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in *) -(* let old_rawprint = !Options.raw_print in *) -(* Options.raw_print := true; *) -(* Impargs.make_implicit_args false; *) -(* Impargs.make_strict_implicit_args false; *) -(* Impargs.make_contextual_implicit_args false; *) -(* Pp.msgnl (str "raw constr " ++ pr_rawconstr rt); *) -(* Impargs.make_implicit_args old_implicit_args; *) -(* Impargs.make_strict_implicit_args old_strict_implicit_args; *) -(* Impargs.make_contextual_implicit_args old_contextual_implicit_args; *) -(* Options.raw_print := old_rawprint; *) + (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *) fst ( rebuild_cons nb_args relnames.(i) [] @@ -1145,12 +1133,7 @@ let build_inductive in let rel_constructors = Array.mapi rel_constructors resa in (* Computing the set of parameters if asked *) - let rels_params = - if parametrize - then - compute_params_name relnames_as_set funsargs rel_constructors - else [] - in + let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in let nrel_params = List.length rels_params in let rel_constructors = (* Taking into account the parameters in constructors *) Array.map (List.map @@ -1182,8 +1165,6 @@ let build_inductive Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - let old_rawprint = !Options.raw_print in - Options.raw_print := true; let rel_params = List.map (fun (n,t,is_defined) -> @@ -1199,16 +1180,19 @@ let build_inductive let ext_rels_constructors = Array.map (List.map (fun (id,t) -> - false,((dummy_loc,id),Constrextern.extern_rawtype Idset.empty ((* zeta_normalize *) t)) + false,((dummy_loc,id), + Options.with_option + Options.raw_print + (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t) + ) )) (rel_constructors) in let rel_ind i ext_rel_constructors = - (dummy_loc,relnames.(i)), - None, + ((dummy_loc,relnames.(i)), rel_params, rel_arities.(i), - ext_rel_constructors + ext_rel_constructors),None in let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in let rel_inds = Array.to_list ext_rel_constructors in @@ -1232,58 +1216,36 @@ let build_inductive (* rel_inds *) (* ) *) (* in *) - let old_implicit_args = Impargs.is_implicit_args () - and old_strict_implicit_args = Impargs.is_strict_implicit_args () - and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in - Impargs.make_implicit_args false; - Impargs.make_strict_implicit_args false; - Impargs.make_contextual_implicit_args false; let _time2 = System.get_time () in -(* Pp.msgnl (str "Bulding Inductive : " ++ str (string_of_float (System.time_difference time1 time2))); *) try - Options.silently (Command.build_mutual rel_inds) true; - let _time3 = System.get_time () in -(* Pp.msgnl (str "Bulding Done: "++ str (string_of_float (System.time_difference time2 time3))); *) -(* let msg = *) -(* str "while trying to define"++ spc () ++ *) -(* Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () *) -(* in *) -(* Pp.msgnl msg; *) - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Options.raw_print := old_rawprint; - with - | UserError(s,msg) -> + with_full_print (Options.silently (Command.build_mutual rel_inds)) true + with + | UserError(s,msg) as e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Options.raw_print := old_rawprint; let msg = str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++ msg in observe (msg); - raise - (UserError(s, msg)) + raise e | e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - Impargs.make_implicit_args old_implicit_args; - Impargs.make_strict_implicit_args old_strict_implicit_args; - Impargs.make_contextual_implicit_args old_contextual_implicit_args; - Options.raw_print := old_rawprint; let msg = str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(true,rel_inds)) ++ fnl () ++ Cerrors.explain_exn e in observe msg; - raise - (UserError("",msg)) + raise e +let build_inductive funnames funsargs returned_types rtl = + try + do_build_inductive funnames funsargs returned_types rtl + with e -> raise (Building_graph e) + + diff --git a/contrib/funind/rawterm_to_relation.mli b/contrib/funind/rawterm_to_relation.mli index 9cd04123..0075fb0a 100644 --- a/contrib/funind/rawterm_to_relation.mli +++ b/contrib/funind/rawterm_to_relation.mli @@ -1,5 +1,6 @@ + (* [build_inductive parametrize funnames funargs returned_types bodies] constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments @@ -7,7 +8,6 @@ *) val build_inductive : - bool -> (* if true try to detect parameter. Always use it as true except for debug *) Names.identifier list -> (* The list of function name *) (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *) Topconstr.constr_expr list -> (* The list of function returned type *) diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml index 14805cf4..ed46ec72 100644 --- a/contrib/funind/rawtermops.ml +++ b/contrib/funind/rawtermops.ml @@ -35,6 +35,18 @@ let raw_decompose_prod = let raw_compose_prod = List.fold_left (fun b (n,t) -> mkRProd(n,t,b)) +let raw_decompose_prod_n n = + let rec raw_decompose_prod i args c = + if i<=0 then args,c + else + match c with + | RProd(_,n,t,b) -> + raw_decompose_prod (i-1) ((n,t)::args) b + | rt -> args,rt + in + raw_decompose_prod n [] + + let raw_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *) @@ -321,14 +333,6 @@ let rec alpha_rt excluded rt = List.map (alpha_rt excluded) args ) in - if Indfun_common.do_observe () && false - then - Pp.msgnl (str "debug: alpha_rt(" ++ str "[" ++ - prlist_with_sep (fun _ -> str";") Ppconstr.pr_id excluded ++ - str "]" ++ spc () ++ str "," ++ spc () ++ - Printer.pr_rawconstr rt ++ spc () ++ str ")" ++ spc () ++ str "=" ++ - spc () ++ Printer.pr_rawconstr new_rt - ); new_rt and alpha_br excluded (loc,ids,patl,res) = @@ -339,12 +343,6 @@ and alpha_br excluded (loc,ids,patl,res) = let new_res = alpha_rt new_excluded renamed_res in (loc,new_ids,new_patl,new_res) - - - - - - (* [is_free_in id rt] checks if [id] is a free variable in [rt] *) @@ -541,6 +539,33 @@ let ids_of_pat = in ids_of_pat Idset.empty +let id_of_name = function + | Names.Anonymous -> id_of_string "x" + | Names.Name x -> x + +(* TODO: finish Rec caes *) +let ids_of_rawterm c = + let rec ids_of_rawterm acc c = + let idof = id_of_name in + match c with + | RVar (_,id) -> id::acc + | RApp (loc,g,args) -> + ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc + | RLambda (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc + | RProd (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc + | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc + | RCast (loc,c,k,t) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc + | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc + | RLetTuple (_,nal,(na,po),b,c) -> + List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc + | RCases (loc,rtntypopt,tml,brchl) -> + List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl) + | RRec _ -> failwith "Fix inside a constructor branch" + | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> [] + in + (* build the set *) + List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c) + @@ -601,3 +626,46 @@ let zeta_normalize = (loc,idl,patl,zeta_normalize_term res) in zeta_normalize_term + + + + +let expand_as = + + let rec add_as map pat = + match pat with + | PatVar _ -> map + | PatCstr(_,_,patl,Name id) -> + Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) + | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl + in + let rec expand_as map rt = + match rt with + | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt + | RVar(_,id) -> + begin + try + Idmap.find id map + with Not_found -> rt + end + | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args) + | RLambda(loc,na,t,b) -> RLambda(loc,na,expand_as map t, expand_as map b) + | RProd(loc,na,t,b) -> RProd(loc,na,expand_as map t, expand_as map b) + | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b) + | RLetTuple(loc,nal,(na,po),v,b) -> + RLetTuple(loc,nal,(na,option_map (expand_as map) po), + expand_as map v, expand_as map b) + | RIf(loc,e,(na,po),br1,br2) -> + RIf(loc,expand_as map e,(na,option_map (expand_as map) po), + expand_as map br1, expand_as map br2) + | RRec _ -> error "Not handled RRec" + | RDynamic _ -> error "Not handled RDynamic" + | RCast(loc,b,kind,t) -> RCast(loc,expand_as map b,kind,expand_as map t) + | RCases(loc,po,el,brl) -> + RCases(loc, option_map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, + List.map (expand_as_br map) brl) + + and expand_as_br map (loc,idl,cpl,rt) = + (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) + in + expand_as Idmap.empty diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli index aa355485..9647640c 100644 --- a/contrib/funind/rawtermops.mli +++ b/contrib/funind/rawtermops.mli @@ -31,6 +31,7 @@ val mkRCast : rawconstr* rawconstr -> rawconstr These are analogous to the ones constrs *) val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr +val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list -> rawconstr val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list) @@ -107,8 +108,13 @@ val eq_cases_pattern : cases_pattern -> cases_pattern -> bool *) val ids_of_pat : cases_pattern -> Names.Idset.t +(* TODO: finish this function (Fix not treated) *) +val ids_of_rawterm: rawconstr -> Names.Idset.t (* removing let_in construction in a rawterm *) val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr + + +val expand_as : rawconstr -> rawconstr diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml index 2877c19d..ce775e0b 100644 --- a/contrib/funind/tacinvutils.ml +++ b/contrib/funind/tacinvutils.ml @@ -72,10 +72,11 @@ let rec mkevarmap_from_listex lex = let _ = prstr ("evar n. " ^ string_of_int ex ^ " ") in let _ = prstr "OF TYPE: " in let _ = prconstr typ in*) - let info ={ + let info = { evar_concl = typ; evar_hyps = empty_named_context_val; - evar_body = Evar_empty} in + evar_body = Evar_empty; + evar_extra = None} in Evd.add (mkevarmap_from_listex lex') ex info let mkEq typ c1 c2 = diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli index 8f880a76..b6cc55f6 100644 --- a/contrib/interface/ascent.mli +++ b/contrib/interface/ascent.mli @@ -21,7 +21,7 @@ and ct_BINDING = CT_binding of ct_ID_OR_INT * ct_FORMULA and ct_BINDING_LIST = CT_binding_list of ct_BINDING list -and ct_BOOL = +and t_BOOL = CT_false | CT_true and ct_CASE = @@ -46,7 +46,7 @@ and ct_COMMAND = | CT_coerce_THEOREM_GOAL_to_COMMAND of ct_THEOREM_GOAL | CT_abort of ct_ID_OPT_OR_ALL | CT_abstraction of ct_ID * ct_FORMULA * ct_INT_LIST - | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_BINDING_LIST + | CT_add_field of ct_FORMULA * ct_FORMULA * ct_FORMULA * ct_FORMULA_OPT | CT_add_natural_feature of ct_NATURAL_FEATURE * ct_ID | CT_addpath of ct_STRING * ct_ID_OPT | CT_arguments_scope of ct_ID * ct_ID_OPT_LIST @@ -684,7 +684,7 @@ and ct_TACTIC_COM = | CT_reflexivity | CT_rename of ct_ID * ct_ID | CT_repeat of ct_TACTIC_COM - | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_ID_OPT * ct_TACTIC_OPT + | CT_replace_with of ct_FORMULA * ct_FORMULA * ct_CLAUSE * ct_TACTIC_OPT | CT_rewrite_lr of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE | CT_rewrite_rl of ct_FORMULA * ct_SPEC_LIST * ct_CLAUSE | CT_right of ct_SPEC_LIST diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml index 9e450068..dc27cf98 100644 --- a/contrib/interface/blast.ml +++ b/contrib/interface/blast.ml @@ -92,7 +92,7 @@ let rec def_const_in_term_rec vl x = | 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 + | Const(c) -> def_const_in_term_rec vl (Typeops.type_of_constant vl c) | _ -> def_const_in_term_rec vl (type_of vl Evd.empty x) ;; let def_const_in_term_ x = diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4 index 8fcdb5d9..730e055b 100644 --- a/contrib/interface/centaur.ml4 +++ b/contrib/interface/centaur.ml4 @@ -396,7 +396,7 @@ let inspect n = let (_, _, v) = get_variable (basename sp) in add_search2 (Nametab.locate (qualid_of_sp sp)) v | (sp,kn), "CONSTANT" -> - let {const_type=typ} = Global.lookup_constant (constant_of_kn kn) in + let typ = Typeops.type_of_constant (Global.env()) (constant_of_kn kn) in add_search2 (Nametab.locate (qualid_of_sp sp)) typ | (sp,kn), "MUTUALINDUCTIVE" -> add_search2 (Nametab.locate (qualid_of_sp sp)) diff --git a/contrib/interface/dad.ml b/contrib/interface/dad.ml index 578abc49..8096bc31 100644 --- a/contrib/interface/dad.ml +++ b/contrib/interface/dad.ml @@ -73,7 +73,7 @@ let rec map_subst (env :env) (subst:patvar_map) = function | CPatVar (_,(_,i)) -> let constr = List.assoc i subst in extern_constr false env constr - | x -> map_constr_expr_with_binders (map_subst env) (fun _ x -> x) subst x;; + | x -> map_constr_expr_with_binders (fun _ x -> x) (map_subst env) subst x;; let map_subst_tactic env subst = function | TacExtend (loc,("Rewrite" as x),[b;cbl]) -> diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4 index e1b8e712..890bb3ce 100644 --- a/contrib/interface/debug_tac.ml4 +++ b/contrib/interface/debug_tac.ml4 @@ -336,7 +336,7 @@ let debug_tac = function add_tactic "DebugTac" debug_tac;; *) -Refiner.add_tactic "OnThen" on_then;; +Tacinterp.add_tactic "OnThen" on_then;; let rec clean_path tac l = match tac, l with diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml index b06ba199..9a503cfb 100644 --- a/contrib/interface/name_to_ast.ml +++ b/contrib/interface/name_to_ast.ml @@ -107,10 +107,10 @@ let convert_one_inductive sp tyi = let env = Global.env () in let envpar = push_rel_context params env in let sp = sp_of_global (IndRef (sp, tyi)) in - ((dummy_loc,basename sp), None, + (((dummy_loc,basename sp), convert_env(List.rev params), (extern_constr true envpar arity), - convert_constructors envpar cstrnames cstrtypes);; + convert_constructors envpar cstrnames cstrtypes), None);; (* This function converts a Mutual inductive definition to a Coqast.t. It is obtained directly from print_mutual in pretty.ml. However, all @@ -149,7 +149,7 @@ let make_definition_ast name c typ implicits = let constant_to_ast_list kn = let cb = Global.lookup_constant kn in let c = cb.const_body in - let typ = cb.const_type in + let typ = Typeops.type_of_constant_type (Global.env()) cb.const_type in let l = implicits_of_global (ConstRef kn) in (match c with None -> diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml index ce2ee1e7..4bec7350 100644 --- a/contrib/interface/showproof.ml +++ b/contrib/interface/showproof.ml @@ -156,16 +156,16 @@ let seq_to_lnhyp sign sign' cl = let rule_is_complex r = match r with - Tactic (TacArg (Tacexp t),_) -> true - | Tactic (TacAtom (_,TacAuto _), _) -> true - | Tactic (TacAtom (_,TacSymmetry _), _) -> true + Nested (Tactic + ((TacArg (Tacexp _) + |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true |_ -> false ;; let rule_to_ntactic r = let rt = (match r with - Tactic (t,_) -> t + Nested(Tactic (t,_),_) -> t | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h) | _ -> TacAtom (dummy_loc, TacIntroPattern [])) in if rule_is_complex r @@ -234,17 +234,17 @@ let to_nproof sigma osign pf = (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof) spfl) in (match r with - Tactic (TacAtom (_, TacAuto _),_) -> - if spfl=[] - then - {t_info="to_prove"; - t_goal= {newhyp=[]; - t_concl=concl ntree; - t_full_concl=ntree.t_goal.t_full_concl; - t_full_env=ntree.t_goal.t_full_env}; - t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])} - else ntree - | _ -> ntree)) + Nested(Tactic (TacAtom (_, TacAuto _),_),_) -> + if spfl=[] + then + {t_info="to_prove"; + t_goal= {newhyp=[]; + t_concl=concl ntree; + t_full_concl=ntree.t_goal.t_full_concl; + t_full_env=ntree.t_goal.t_full_env}; + t_proof= Proof (TacAtom (dummy_loc,TacExtend (dummy_loc,"InfoAuto",[])), [ntree])} + else ntree + | _ -> ntree)) else {t_info="to_prove"; t_goal=(seq_to_lnhyp oldsign nsign cl); @@ -725,7 +725,7 @@ let rec nsortrec vl x = | Case(_,x,t,a) -> nsortrec vl x | Cast(x,_, t)-> nsortrec vl t - | Const c -> nsortrec vl (lookup_constant c vl).const_type + | Const c -> nsortrec vl (Typeops.type_of_constant vl c) | _ -> nsortrec vl (type_of vl Evd.empty x) ;; let nsort x = diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml index 064d20ab..fe227f99 100644 --- a/contrib/interface/vtp.ml +++ b/contrib/interface/vtp.ml @@ -112,19 +112,12 @@ and fCOMMAND = function fFORMULA x2; fINT_LIST x3; fNODE "abstraction" 3 -| CT_add_field(x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) -> +| CT_add_field(x1, x2, x3, x4) -> fFORMULA x1; fFORMULA x2; fFORMULA x3; - fFORMULA x4; - fFORMULA x5; - fFORMULA x6; - fFORMULA x7; - fFORMULA x8; - fFORMULA x9; - fFORMULA x10; - fBINDING_LIST x11; - fNODE "add_field" 11 + fFORMULA_OPT x4; + fNODE "add_field" 4 | CT_add_natural_feature(x1, x2) -> fNATURAL_FEATURE x1; fID x2; @@ -1711,7 +1704,7 @@ and fTACTIC_COM = function | CT_replace_with(x1, x2,x3,x4) -> fFORMULA x1; fFORMULA x2; - fID_OPT x3; + fCLAUSE x3; fTACTIC_OPT x4; fNODE "replace_with" 4 | CT_rewrite_lr(x1, x2, x3) -> diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml index 024cb599..6c9e8239 100644 --- a/contrib/interface/xlate.ml +++ b/contrib/interface/xlate.ml @@ -497,6 +497,8 @@ let xlate_hyp_location = | (_, 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 @@ -724,7 +726,9 @@ and (xlate_call_or_tacarg:raw_tactic_arg -> ct_TACTIC_COM) = | Reference (Ident (_,s)) -> ident_tac s | ConstrMayEval(ConstrTerm a) -> CT_formula_marker(xlate_formula a) - | TacFreshId s -> CT_fresh(ctf_STRING_OPT s) + | TacFreshId [] -> CT_fresh(ctf_STRING_OPT None) + | TacFreshId [ArgArg s] -> CT_fresh(ctf_STRING_OPT (Some s)) + | TacFreshId _ -> xlate_error "TODO: fresh with many args" | t -> xlate_error "TODO LATER: result other than tactic or constr" and xlate_red_tactic = @@ -937,6 +941,8 @@ and xlate_tac = CT_injection_eq (xlate_quantified_hypothesis_opt (out_gen (wit_opt rawwit_quant_hyp) idopt)) + | TacExtend (_,"injection_as", [idopt;ipat]) -> + xlate_error "TODO: injection as" | TacFix (idopt, n) -> CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list []) | TacMutualFix (id, n, fixtac_list) -> @@ -972,22 +978,36 @@ and xlate_tac = | TacRight bindl -> CT_right (xlate_bindings bindl) | TacSplit (false,bindl) -> CT_split (xlate_bindings bindl) | TacSplit (true,bindl) -> CT_exists (xlate_bindings bindl) - | TacExtend (_,"replace", [c1; c2;id_opt;tac_opt]) -> + | TacExtend (_,"replace", [c1; c2;cl;tac_opt]) -> let c1 = xlate_formula (out_gen rawwit_constr c1) in let c2 = xlate_formula (out_gen rawwit_constr c2) in - let id_opt = - match out_gen Extratactics.rawwit_in_arg_hyp id_opt with - | None -> ctv_ID_OPT_NONE - | Some (_,id) -> ctf_ID_OPT_SOME (xlate_ident id) - in + let cl = + (* J.F. : 18/08/2006 + Hack to coerce the "clause" argument of replace to a real clause + To be remove if we can reuse the clause grammar entrie defined in g_tactic + *) + let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in + let cl_as_xlate_arg = + {cl_as_clause with + Tacexpr.onhyps = + option_map + (fun l -> + List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l + ) + cl_as_clause.Tacexpr.onhyps + } + in + cl_as_xlate_arg + in + let cl = xlate_clause cl in let tac_opt = - match out_gen (Extratactics.rawwit_by_arg_tac) tac_opt with + match out_gen (Extraargs.rawwit_by_arg_tac) tac_opt with | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none | Some tac -> let tac = xlate_tactic tac in CT_coerce_TACTIC_COM_to_TACTIC_OPT tac in - CT_replace_with (c1, c2,id_opt,tac_opt) + CT_replace_with (c1, c2,cl,tac_opt) | TacRewrite(b,cbindl,cl) -> let cl = xlate_clause cl and c = xlate_formula (fst cbindl) @@ -1077,12 +1097,12 @@ and xlate_tac = let first_n = match out_gen (wit_opt rawwit_int_or_var) nopt with | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s - | Some ArgArg n -> xlate_int_to_id_or_int_opt n + | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n | None -> none_in_id_or_int_opt in let second_n = match out_gen (wit_opt rawwit_int_or_var) popt with | Some (ArgVar(_, s)) -> xlate_id_to_id_or_int_opt s - | Some ArgArg n -> xlate_int_to_id_or_int_opt n + | Some (ArgArg n) -> xlate_int_to_id_or_int_opt n | None -> none_in_id_or_int_opt in let _lems = match out_gen Eauto.rawwit_auto_using lems with @@ -1625,6 +1645,15 @@ let rec xlate_vernac = CT_solve (CT_int n, xlate_tactic tac, if b then CT_dotdot else CT_coerce_NONE_to_DOTDOT_OPT CT_none) + +(* MMode *) + + | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> + anomaly "No MMode in CTcoq" + + +(* /MMode *) + | VernacFocus nopt -> CT_focus (xlate_int_opt nopt) | VernacUnfocus -> CT_unfocus |VernacExtend("Extraction", [f;l]) -> @@ -1645,27 +1674,14 @@ let rec xlate_vernac = CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, List.map loc_qualid_to_ct_ID l2)) | VernacExtend("Field", - [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl;minusdiv]) -> + [fth;ainv;ainvl;div]) -> (match List.map (fun v -> xlate_formula(out_gen rawwit_constr v)) - [a;aplus;amult;aone;azero;aopp;aeq;ainv;fth;ainvl] + [fth;ainv;ainvl] with - [a1;aplus1;amult1;aone1;azero1;aopp1;aeq1;ainv1;fth1;ainvl1] -> - let bind = - match out_gen Field.rawwit_minus_div_arg minusdiv with - None, None -> - CT_binding_list[] - | Some m, None -> - CT_binding_list[ - CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m)] - | None, Some d -> - CT_binding_list[ - CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] - | Some m, Some d -> - CT_binding_list[ - CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "minus"), xlate_formula m); - CT_binding(CT_coerce_ID_to_ID_OR_INT (CT_ident "div"), xlate_formula d)] in - CT_add_field(a1, aplus1, amult1, aone1, azero1, aopp1, aeq1, - ainv1, fth1, ainvl1, bind) + [fth1;ainv1;ainvl1] -> + let adiv1 = + xlate_formula_opt (out_gen (wit_opt rawwit_constr) div) in + CT_add_field(fth1, ainv1, ainvl1, adiv1) |_ -> assert false) | VernacExtend ("HintRewrite", o::f::([b]|[_;b] as args)) -> let orient = out_gen Extraargs.rawwit_orient o in @@ -1768,9 +1784,10 @@ let rec xlate_vernac = | VernacShow ShowExistentials -> CT_show_existentials | VernacShow ShowScript -> CT_show_script | VernacShow(ShowMatch _) -> xlate_error "TODO: VernacShow(ShowMatch _)" + | VernacShow(ShowThesis) -> xlate_error "TODO: VernacShow(ShowThesis _)" | VernacGo arg -> CT_go (xlate_locn arg) - | VernacShow ExplainProof l -> CT_explain_proof (nums_to_int_list l) - | VernacShow ExplainTree l -> + | VernacShow (ExplainProof l) -> CT_explain_proof (nums_to_int_list l) + | VernacShow (ExplainTree l) -> CT_explain_prooftree (nums_to_int_list l) | VernacCheckGuard -> CT_guarded | VernacPrint p -> @@ -1874,7 +1891,7 @@ let rec xlate_vernac = build_record_field_list field_list) | VernacInductive (isind, lmi) -> let co_or_ind = if isind then "Inductive" else "CoInductive" in - let strip_mutind ((_,s), notopt, parameters, c, constructors) = + let strip_mutind (((_,s), parameters, c, constructors), notopt) = CT_ind_spec (xlate_ident s, xlate_binder_list parameters, xlate_formula c, build_constructors constructors, @@ -1883,7 +1900,7 @@ let rec xlate_vernac = (CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi)) | VernacFixpoint ([],_) -> xlate_error "mutual recursive" | VernacFixpoint ((lm :: lmi),boxed) -> - let strip_mutrec ((fid, (n, ro), bl, arf, ardef), ntn) = + let strip_mutrec ((fid, (n, ro), bl, arf, ardef), _ntn) = let (struct_arg,bl,arf,ardef) = (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *) (* By the way, how could [bl = []] happen in V8 syntax ? *) @@ -1903,7 +1920,7 @@ let rec xlate_vernac = (CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi)) | VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive" | VernacCoFixpoint ((lm :: lmi),boxed) -> - let strip_mutcorec (fid, bl, arf, ardef) = + let strip_mutcorec ((fid, bl, arf, ardef), _ntn) = CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, xlate_formula arf, xlate_formula ardef) in CT_cofix_decl diff --git a/contrib/recdef/recdef.ml4 b/contrib/recdef/recdef.ml4 index ed2e5b5f..353fcdb3 100644 --- a/contrib/recdef/recdef.ml4 +++ b/contrib/recdef/recdef.ml4 @@ -119,8 +119,7 @@ let def_of_const t = let type_of_const t = match (kind_of_term t) with - Const sp -> - (Global.lookup_constant sp).const_type + Const sp -> Typeops.type_of_constant (Global.env()) sp |_ -> assert false let arg_type t = @@ -133,7 +132,17 @@ let evaluable_of_global_reference r = ConstRef sp -> EvalConstRef sp | VarRef id -> EvalVarRef id | _ -> assert false;; - + + +let rank_for_arg_list h = + let predicate a b = + try List.for_all2 eq_constr a b with + Invalid_argument _ -> false in + let rec rank_aux i = function + | [] -> None + | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in + rank_aux 0;; + let rec (find_call_occs: constr -> constr -> (constr list ->constr)*(constr list list)) = fun f expr -> @@ -144,19 +153,36 @@ let rec (find_call_occs: let (largs: constr list) = Array.to_list args in let rec find_aux = function [] -> (fun x -> []), [] - | a::tl -> - (match find_aux tl with - (cf, ((arg1::args) as opt_args)) -> + | a::upper_tl -> + (match find_aux upper_tl with + (cf, ((arg1::args) as args_for_upper_tl)) -> (match find_call_occs f a with cf2, (_ :: _ as other_args) -> - let len1 = List.length other_args in - (fun l -> - cf2 l::(cf (nthtl(l,len1)))), other_args@opt_args - | _, [] -> (fun x -> a::cf x), opt_args) + let rec avoid_duplicates args = + match args with + | [] -> (fun _ -> []), [] + | h::tl -> + let recomb_tl, args_for_tl = + avoid_duplicates tl in + match rank_for_arg_list h args_for_upper_tl with + | None -> + (fun l -> List.hd l::recomb_tl(List.tl l)), + h::args_for_tl + | Some i -> + (fun l -> List.nth l (i+List.length args_for_tl):: + recomb_tl l), + args_for_tl + in + let recombine, other_args' = + avoid_duplicates other_args in + let len1 = List.length other_args' in + (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))), + other_args'@args_for_upper_tl + | _, [] -> (fun x -> a::cf x), args_for_upper_tl) | _, [] -> (match find_call_occs f a with - cf, (arg1::args) -> (fun l -> cf l::tl), (arg1::args) - | _, [] -> (fun x -> a::tl), [])) in + cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args) + | _, [] -> (fun x -> a::upper_tl), [])) in begin match (find_aux largs) with cf, [] -> (fun l -> mkApp(g, args)), [] @@ -168,7 +194,7 @@ let rec (find_call_occs: | Meta(_) -> error "find_call_occs : Meta" | Evar(_) -> error "find_call_occs : Evar" | Sort(_) -> error "find_call_occs : Sort" - | Cast(_,_,_) -> error "find_call_occs : cast" + | Cast(b,_,_) -> find_call_occs f b | Prod(_,_,_) -> error "find_call_occs : Prod" | Lambda(_,_,_) -> error "find_call_occs : Lambda" | LetIn(_,_,_,_) -> error "find_call_occs : let in" @@ -182,6 +208,8 @@ let rec (find_call_occs: | Fix(_) -> error "find_call_occs : Fix" | CoFix(_) -> error "find_call_occs : CoFix";; + + let coq_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ Coqlib.arith_modules) s;; @@ -268,8 +296,17 @@ let rec mk_intros_and_continue (extra_eqn:bool) let teq = pf_get_new_id teq_id g in tclTHENLIST [ h_intro teq; - tclMAP (fun eq -> tclTRY (Equality.general_rewrite_in true teq eq)) (List.rev eqs); - cont_function (mkVar teq::eqs) expr + tclMAP + (fun eq -> tclTRY (Equality.general_rewrite_in true teq eq)) + (List.rev eqs); + (fun g1 -> + let ty_teq = pf_type_of g1 (mkVar teq) in + let teq_lhs,teq_rhs = + let _,args = destApp ty_teq in + args.(1),args.(2) + in + cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1 + ) ] g else @@ -285,16 +322,18 @@ let simpl_iter () = {rBeta=true;rIota=true;rZeta= true; rDelta=false; rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) onConcl - + +(* The boolean value is_mes expresses that the termination is expressed + using a measure function instead of a well-founded relation. *) let tclUSER is_mes l g = - let b,l = + let clear_tac = match l with - None -> true,[] - | Some l -> false,l + | None -> h_clear true [] + | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l) in tclTHENSEQ [ - (h_clear b l); + clear_tac; if is_mes then unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] else tclIDTAC @@ -473,12 +512,17 @@ let rec introduce_all_values is_mes acc_inv func context_fn (observe_tac "acc_inv" (apply (Lazy.force acc_inv))) [ observe_tac "h_assumption" h_assumption ; - observe_tac "user proof" (fun g -> - tclUSER - is_mes - (Some (hrec::hspec::(retrieve_acc_var g)@specs)) - g - ) + tclTHENLIST + [ + tclTRY(list_rewrite true eqs); + observe_tac "user proof" + (fun g -> + tclUSER + is_mes + (Some (hrec::hspec::(retrieve_acc_var g)@specs)) + g + ) + ] ] ) ]) g) @@ -574,13 +618,14 @@ let hyp_terminates func = -let tclUSER_if_not_mes is_mes = +let tclUSER_if_not_mes is_mes names_to_suppress = if is_mes then tclCOMPLETE (h_apply (delayed_force well_founded_ltof,Rawterm.NoBindings)) - else tclUSER is_mes None + else tclUSER is_mes names_to_suppress -let start is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_tac : tactic = +let termination_proof_header is_mes input_type ids args_id relation + rec_arg_num rec_arg_id tac wf_tac : tactic = begin fun g -> let nargs = List.length args_id in @@ -596,7 +641,8 @@ let start is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_t (id_of_string ("Acc_"^(string_of_id rec_arg_id))) (wf_thm::ids) in - let hrec = next_global_ident_away true hrec_id (wf_rec_arg::wf_thm::ids) in + let hrec = next_global_ident_away true hrec_id + (wf_rec_arg::wf_thm::ids) in let acc_inv = lazy ( mkApp ( @@ -630,9 +676,9 @@ let start is_mes input_type ids args_id relation rec_arg_num rec_arg_id tac wf_t ) ) [ - (* interactive proof of the well_foundness of the relation *) - wf_tac is_mes; - (* well_foundness -> Acc for any element *) + (* interactive proof that the relation is well_founded *) + observe_tac "wf_tac" (wf_tac is_mes (Some args_id)); + (* this gives the accessibility argument *) observe_tac "apply wf_thm" (h_apply ((mkApp(mkVar wf_thm, @@ -694,7 +740,7 @@ let whole_start is_mes func input_type relation rec_arg_num : tactic = in let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in - start + termination_proof_header is_mes input_type ids @@ -716,7 +762,7 @@ let whole_start is_mes func input_type relation rec_arg_num : tactic = ) g ) - tclUSER_if_not_mes + tclUSER_if_not_mes g end @@ -724,7 +770,7 @@ let whole_start is_mes func input_type relation rec_arg_num : tactic = let get_current_subgoals_types () = let pts = get_pftreestate () in let _,subs = extract_open_pftreestate pts in - List.map snd subs + List.map snd (List.sort (fun (x,_) (y,_) -> x -y )subs ) let build_and_l l = @@ -745,8 +791,31 @@ let build_and_l l = ],nb+1 in f l + +let is_rec_res id = + let rec_res_name = string_of_id rec_res_id in + let id_name = string_of_id id in + try + String.sub id_name 0 (String.length rec_res_name) = rec_res_name + with _ -> false + +let clear_goals = + let rec clear_goal t = + match kind_of_term t with + | Prod(Name id as na,t,b) -> + let b' = clear_goal b in + if noccurn 1 b' && (is_rec_res id) + then pop b' + else if b' == b then t + else mkProd(na,t,b') + | _ -> map_constr clear_goal t + in + List.map clear_goal + + let build_new_goal_type () = let sub_gls_types = get_current_subgoals_types () in + let sub_gls_types = clear_goals sub_gls_types in let res = build_and_l sub_gls_types in res @@ -767,7 +836,7 @@ let prove_with_tcc lemma _ : tactic = -let open_new_goal ref goal_name (gls_type,decompose_and_tac,nb_goal) = +let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal) = let current_proof_name = get_current_proof_name () in let name = match goal_name with | Some s -> s @@ -782,7 +851,11 @@ let open_new_goal ref goal_name (gls_type,decompose_and_tac,nb_goal) = Util.error "\"abstract\" cannot handle existentials"; let hook _ _ = let lemma = mkConst (Lib.make_con na) in - Array.iteri (fun i _ -> by (observe_tac "tac" (prove_with_tcc lemma i))) (Array.make nb_goal ()); + Array.iteri + (fun i _ -> + by (observe_tac ("reusing lemma "^(string_of_id na)) (prove_with_tcc lemma i))) + (Array.make nb_goal ()) + ; ref := Some lemma ; defined (); in @@ -792,8 +865,28 @@ let open_new_goal ref goal_name (gls_type,decompose_and_tac,nb_goal) = sign gls_type hook ; - by (decompose_and_tac); - if Options.is_verbose () then (pp (Printer.pr_open_subgoals())) + by ( + fun g -> + tclTHEN + (decompose_and_tac) + (tclORELSE + (tclFIRST + (List.map + (fun c -> + tclTHENSEQ + [intros; + h_apply (interp_constr Evd.empty (Global.env()) c,Rawterm.NoBindings); + tclCOMPLETE Auto.default_auto + ] + ) + using_lemmas) + ) tclIDTAC) + g); + try + by tclIDTAC; (* raises UserError _ if the proof is complete *) + if Options.is_verbose () then (pp (Printer.pr_open_subgoals())) + with UserError _ -> + defined () let com_terminate @@ -804,7 +897,7 @@ let com_terminate input_type relation rec_arg_num - thm_name hook = + thm_name using_lemmas hook = let (evmap, env) = Command.get_current_context() in start_proof thm_name (Global, Proof Lemma) (Environ.named_context_val env) @@ -813,7 +906,7 @@ let com_terminate input_type relation rec_arg_num )); try let new_goal_type = build_new_goal_type () in - open_new_goal tcc_lemma_ref + open_new_goal using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type) with Failure "empty list of subgoals!" -> @@ -895,9 +988,9 @@ let start_equation (f:global_reference) (term_f:global_reference) in tclTHENLIST [ h_intros x; - unfold_constr f; - simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))); - cont_tactic x] g + observe_tac "unfold_constr f" (unfold_constr f); + observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x)))); + observe_tac "prove_eq" (cont_tactic x)] g ;; let base_leaf_eq func eqs f_id g = @@ -1021,8 +1114,8 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) _,[] -> tclTHENS(mkCaseEq a)(* (simplest_case a) *) (List.map - (mk_intros_and_continue true - (prove_eq termine f functional) eqs) + (fun expr -> observe_tac "mk_intros_and_continue" (mk_intros_and_continue true + (prove_eq termine f functional) eqs expr)) (Array.to_list l)) | _,_::_ -> (match find_call_occs f expr with @@ -1045,13 +1138,13 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) let (com_eqn : identifier -> global_reference -> global_reference -> global_reference - -> constr_expr -> unit) = - fun eq_name functional_ref f_ref terminate_ref eq -> + -> constr -> unit) = + fun eq_name functional_ref f_ref terminate_ref equation_lemma_type -> let (evmap, env) = Command.get_current_context() in - let eq_constr = interp_constr evmap env eq in let f_constr = (constr_of_reference f_ref) in + let equation_lemma_type = subst1 f_constr equation_lemma_type in (start_proof eq_name (Global, Proof Lemma) - (Environ.named_context_val env) eq_constr (fun _ _ -> ()); + (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ()); by (start_equation f_ref terminate_ref (fun x -> @@ -1066,22 +1159,25 @@ let (com_eqn : identifier -> ) ) ); - defined (); + Options.silently defined (); );; -let recursive_definition is_mes function_name type_of_f r rec_arg_num eq - generate_induction_principle : unit = +let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq + generate_induction_principle using_lemmas : unit = let function_type = interp_constr Evd.empty (Global.env()) type_of_f in - let env = push_rel (Name function_name,None,function_type) (Global.env()) in - let res_vars,eq' = decompose_prod (interp_constr Evd.empty env eq) in + let env = push_named (function_name,None,function_type) (Global.env()) in +(* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) + let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in +(* Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *) + let res_vars,eq' = decompose_prod equation_lemma_type in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) (* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) match kind_of_term eq' with | App(e,[|_;_;eq_fix|]) -> - mkLambda (Name function_name,function_type,compose_lam res_vars eq_fix) + mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) | _ -> failwith "Recursive Definition (res not eq)" in let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in @@ -1106,9 +1202,11 @@ let recursive_definition is_mes function_name type_of_f r rec_arg_num eq let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in (* message "start second proof"; *) begin - try com_eqn equation_id functional_ref f_ref term_ref eq + try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) with e -> begin + if Tacinterp.get_debug () <> Tactic_debug.DebugOff + then anomalylabstrm "" (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e); ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); anomaly "Cannot create equation Lemma" end @@ -1134,6 +1232,7 @@ let recursive_definition is_mes function_name type_of_f r rec_arg_num eq rec_arg_type relation rec_arg_num term_id + using_lemmas hook with e -> begin @@ -1154,10 +1253,10 @@ VERNAC COMMAND EXTEND RecursiveDefinition | None -> 1 | Some n -> n in - recursive_definition false f type_of_f r rec_arg_num eq (fun _ _ _ _ _ _ _ _ -> ())] + recursive_definition false f [] type_of_f r rec_arg_num eq (fun _ _ _ _ _ _ _ _ -> ()) []] | [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf) "[" ne_constr_list(proof) "]" constr(eq) ] -> - [ ignore(proof);ignore(wf);recursive_definition false f type_of_f r 1 eq (fun _ _ _ _ _ _ _ _ -> ())] + [ ignore(proof);ignore(wf);recursive_definition false f [] type_of_f r 1 eq (fun _ _ _ _ _ _ _ _ -> ()) []] END diff --git a/contrib/ring/ArithRing.v b/contrib/ring/LegacyArithRing.v index 68464c10..e062b731 100644 --- a/contrib/ring/ArithRing.v +++ b/contrib/ring/LegacyArithRing.v @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ArithRing.v 6295 2004-11-12 16:40:39Z gregoire $ *) +(* $Id: LegacyArithRing.v 9179 2006-09-26 12:13:06Z barras $ *) (* Instantiation of the Ring tactic for the naturals of Arith $*) -Require Export Ring. +Require Import Bool. +Require Export LegacyRing. Require Export Arith. Require Import Eqdep_dec. @@ -36,12 +37,12 @@ Hint Resolve nateq_prop: arithring. Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq. split; intros; auto with arith arithring. - apply (fun n m p:nat => plus_reg_l m p n) with (n := n). - trivial. +(* apply (fun n m p:nat => plus_reg_l m p n) with (n := n). + trivial.*) Defined. -Add Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ]. +Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ]. Goal forall n:nat, S n = 1 + n. intro; reflexivity. diff --git a/contrib/ring/NArithRing.v b/contrib/ring/LegacyNArithRing.v index 878346ba..c689fc40 100644 --- a/contrib/ring/NArithRing.v +++ b/contrib/ring/LegacyNArithRing.v @@ -6,11 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: NArithRing.v 6295 2004-11-12 16:40:39Z gregoire $ *) +(* $Id: LegacyNArithRing.v 9179 2006-09-26 12:13:06Z barras $ *) (* Instantiation of the Ring tactic for the binary natural numbers *) -Require Export Ring. +Require Import Bool. +Require Export LegacyRing. Require Export ZArith_base. Require Import NArith. Require Import Eqdep_dec. @@ -37,8 +38,9 @@ Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq. apply Nmult_1_l. apply Nmult_0_l. apply Nmult_plus_distr_r. - apply Nplus_reg_l. +(* apply Nplus_reg_l.*) apply Neq_prop. Qed. -Add Semi Ring N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ]. +Add Legacy Semi Ring + N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ]. diff --git a/contrib/ring/Ring.v b/contrib/ring/LegacyRing.v index 6572e79a..dc8635bd 100644 --- a/contrib/ring/Ring.v +++ b/contrib/ring/LegacyRing.v @@ -9,7 +9,7 @@ (* $Id: Ring.v 5920 2004-07-16 20:01:26Z herbelin $ *) Require Export Bool. -Require Export Ring_theory. +Require Export LegacyRing_theory. Require Export Quote. Require Export Ring_normalize. Require Export Ring_abstract. @@ -32,5 +32,5 @@ destruct n; destruct m; destruct p; reflexivity. destruct x; destruct y; reflexivity || simpl in |- *; tauto. Defined. -Add Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory - [ true false ].
\ No newline at end of file +Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory + [ true false ]. diff --git a/contrib/ring/Ring_theory.v b/contrib/ring/LegacyRing_theory.v index 5536294e..5df927a6 100644 --- a/contrib/ring/Ring_theory.v +++ b/contrib/ring/LegacyRing_theory.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_theory.v 5920 2004-07-16 20:01:26Z herbelin $ *) +(* $Id: LegacyRing_theory.v 9179 2006-09-26 12:13:06Z barras $ *) Require Export Bool. @@ -39,7 +39,7 @@ Record Semi_Ring_Theory : Prop := SR_mult_one_left : forall n:A, 1 * n = n; SR_mult_zero_left : forall n:A, 0 * n = 0; SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p; - SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p; +(* SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*) SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}. Variable T : Semi_Ring_Theory. @@ -52,10 +52,10 @@ Let plus_zero_left := SR_plus_zero_left T. Let mult_one_left := SR_mult_one_left T. Let mult_zero_left := SR_mult_zero_left T. Let distr_left := SR_distr_left T. -Let plus_reg_left := SR_plus_reg_left T. +(*Let plus_reg_left := SR_plus_reg_left T.*) Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left - mult_one_left mult_zero_left distr_left plus_reg_left. + mult_one_left mult_zero_left distr_left (*plus_reg_left*). (* Lemmas whose form is x=y are also provided in form y=x because Auto does not symmetry *) @@ -126,11 +126,11 @@ Qed. Lemma SR_mult_one_right2 : forall n:A, n = n * 1. intro; elim mult_comm; auto. Qed. - +(* Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto. Qed. - +*) End Theory_of_semi_rings. Section Theory_of_rings. @@ -320,7 +320,7 @@ symmetry in |- *; apply Th_mult_opp_opp. Qed. Lemma Th_opp_zero : - 0 = 0. rewrite <- (plus_zero_left (- 0)). auto. Qed. - +(* Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p. intros; generalize (f_equal (fun z => - n + z) H). repeat rewrite plus_assoc. @@ -336,7 +336,7 @@ rewrite (plus_comm n m). rewrite (plus_comm n p). auto. Qed. - +*) Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p. intros. repeat rewrite (mult_comm n). @@ -349,7 +349,7 @@ Qed. End Theory_of_rings. -Hint Resolve Th_mult_zero_left Th_plus_reg_left: core. +Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core. Unset Implicit Arguments. @@ -373,4 +373,4 @@ End product_ring. Section power_ring. -End power_ring.
\ No newline at end of file +End power_ring. diff --git a/contrib/ring/ZArithRing.v b/contrib/ring/LegacyZArithRing.v index 3999b632..a410fbc5 100644 --- a/contrib/ring/ZArithRing.v +++ b/contrib/ring/LegacyZArithRing.v @@ -6,13 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ZArithRing.v 6295 2004-11-12 16:40:39Z gregoire $ *) +(* $Id: LegacyZArithRing.v 9181 2006-09-26 16:38:33Z barras $ *) (* Instantiation of the Ring tactic for the binary integers of ZArith *) -Require Export ArithRing. +Require Export LegacyArithRing. Require Export ZArith_base. Require Import Eqdep_dec. +Require Import LegacyRing. Unboxed Definition Zeq (x y:Z) := match (x ?= y)%Z with @@ -32,5 +33,5 @@ Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq. Qed. (* NatConstants and NatTheory are defined in Ring_theory.v *) -Add Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory +Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory [ Zpos Zneg 0%Z xO xI 1%positive ]. diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v index c0818da8..115ed5ca 100644 --- a/contrib/ring/Ring_abstract.v +++ b/contrib/ring/Ring_abstract.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_abstract.v 6295 2004-11-12 16:40:39Z gregoire $ *) +(* $Id: Ring_abstract.v 9179 2006-09-26 12:13:06Z barras $ *) -Require Import Ring_theory. +Require Import LegacyRing_theory. Require Import Quote. Require Import Ring_normalize. @@ -129,7 +129,7 @@ Hint Resolve (SR_mult_zero_left T). Hint Resolve (SR_mult_zero_left2 T). Hint Resolve (SR_distr_left T). Hint Resolve (SR_distr_left2 T). -Hint Resolve (SR_plus_reg_left T). +(*Hint Resolve (SR_plus_reg_left T).*) Hint Resolve (SR_plus_permute T). Hint Resolve (SR_mult_permute T). Hint Resolve (SR_distr_right T). @@ -140,7 +140,7 @@ Hint Resolve (SR_plus_zero_right T). Hint Resolve (SR_plus_zero_right2 T). Hint Resolve (SR_mult_one_right T). Hint Resolve (SR_mult_one_right2 T). -Hint Resolve (SR_plus_reg_right T). +(*Hint Resolve (SR_plus_reg_right T).*) Hint Resolve refl_equal sym_equal trans_equal. (*Hints Resolve refl_eqT sym_eqT trans_eqT.*) Hint Immediate T. @@ -439,7 +439,7 @@ Hint Resolve (Th_mult_zero_left T). Hint Resolve (Th_mult_zero_left2 T). Hint Resolve (Th_distr_left T). Hint Resolve (Th_distr_left2 T). -Hint Resolve (Th_plus_reg_left T). +(*Hint Resolve (Th_plus_reg_left T).*) Hint Resolve (Th_plus_permute T). Hint Resolve (Th_mult_permute T). Hint Resolve (Th_distr_right T). @@ -449,7 +449,7 @@ Hint Resolve (Th_plus_zero_right T). Hint Resolve (Th_plus_zero_right2 T). Hint Resolve (Th_mult_one_right T). Hint Resolve (Th_mult_one_right2 T). -Hint Resolve (Th_plus_reg_right T). +(*Hint Resolve (Th_plus_reg_right T).*) Hint Resolve refl_equal sym_equal trans_equal. (*Hints Resolve refl_eqT sym_eqT trans_eqT.*) Hint Immediate T. diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v index 7b40328a..4a082396 100644 --- a/contrib/ring/Ring_normalize.v +++ b/contrib/ring/Ring_normalize.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_normalize.v 6295 2004-11-12 16:40:39Z gregoire $ *) +(* $Id: Ring_normalize.v 9179 2006-09-26 12:13:06Z barras $ *) -Require Import Ring_theory. +Require Import LegacyRing_theory. Require Import Quote. Set Implicit Arguments. @@ -356,7 +356,7 @@ Hint Resolve (SR_mult_zero_left T). Hint Resolve (SR_mult_zero_left2 T). Hint Resolve (SR_distr_left T). Hint Resolve (SR_distr_left2 T). -Hint Resolve (SR_plus_reg_left T). +(*Hint Resolve (SR_plus_reg_left T).*) Hint Resolve (SR_plus_permute T). Hint Resolve (SR_mult_permute T). Hint Resolve (SR_distr_right T). @@ -367,7 +367,7 @@ Hint Resolve (SR_plus_zero_right T). Hint Resolve (SR_plus_zero_right2 T). Hint Resolve (SR_mult_one_right T). Hint Resolve (SR_mult_one_right2 T). -Hint Resolve (SR_plus_reg_right T). +(*Hint Resolve (SR_plus_reg_right T).*) Hint Resolve refl_equal sym_equal trans_equal. (* Hints Resolve refl_eqT sym_eqT trans_eqT. *) Hint Immediate T. @@ -785,7 +785,7 @@ Hint Resolve (Th_mult_zero_left T). Hint Resolve (Th_mult_zero_left2 T). Hint Resolve (Th_distr_left T). Hint Resolve (Th_distr_left2 T). -Hint Resolve (Th_plus_reg_left T). +(*Hint Resolve (Th_plus_reg_left T).*) Hint Resolve (Th_plus_permute T). Hint Resolve (Th_mult_permute T). Hint Resolve (Th_distr_right T). @@ -796,7 +796,7 @@ Hint Resolve (Th_plus_zero_right T). Hint Resolve (Th_plus_zero_right2 T). Hint Resolve (Th_mult_one_right T). Hint Resolve (Th_mult_one_right2 T). -Hint Resolve (Th_plus_reg_right T). +(*Hint Resolve (Th_plus_reg_right T).*) Hint Resolve refl_equal sym_equal trans_equal. (*Hints Resolve refl_eqT sym_eqT trans_eqT.*) Hint Immediate T. diff --git a/contrib/ring/g_ring.ml4 b/contrib/ring/g_ring.ml4 index dccd1944..2f964988 100644 --- a/contrib/ring/g_ring.ml4 +++ b/contrib/ring/g_ring.ml4 @@ -8,13 +8,14 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_ring.ml4 7734 2005-12-26 14:06:51Z herbelin $ *) +(* $Id: g_ring.ml4 9178 2006-09-26 11:18:22Z barras $ *) open Quote open Ring +open Tacticals TACTIC EXTEND ring - [ "ring" constr_list(l) ] -> [ polynom l ] +| [ "legacy" "ring" constr_list(l) ] -> [ polynom l ] END (* The vernac commands "Add Ring" and co *) @@ -23,7 +24,7 @@ let cset_of_constrarg_list l = List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty VERNAC COMMAND EXTEND AddRing - [ "Add" "Ring" + [ "Add" "Legacy" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory true false false @@ -40,7 +41,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Semi" "Ring" +| [ "Add" "Legacy" "Semi" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory false false false @@ -57,7 +58,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Abstract" "Ring" +| [ "Add" "Legacy" "Abstract" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(t) ] -> [ add_theory true true false @@ -74,7 +75,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) ConstrSet.empty ] -| [ "Add" "Abstract" "Semi" "Ring" +| [ "Add" "Legacy" "Abstract" "Semi" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aeq) constr(t) ] -> [ add_theory false true false @@ -91,7 +92,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) ConstrSet.empty ] -| [ "Add" "Setoid" "Ring" +| [ "Add" "Legacy" "Setoid" "Ring" constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm) constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] @@ -112,7 +113,7 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Semi" "Setoid" "Ring" +| [ "Add" "Legacy" "Semi" "Setoid" "Ring" constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aeq) constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml index 462e5ed8..e0a6cba3 100644 --- a/contrib/ring/quote.ml +++ b/contrib/ring/quote.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: quote.ml 7639 2005-12-02 10:01:15Z gregoire $ *) +(* $Id: quote.ml 9178 2006-09-26 11:18:22Z barras $ *) (* The `Quote' tactic *) @@ -298,7 +298,7 @@ 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 + | 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 diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml index 5251dcc5..6b82b75b 100644 --- a/contrib/ring/ring.ml +++ b/contrib/ring/ring.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ring.ml 7837 2006-01-11 09:47:32Z herbelin $ *) +(* $Id: ring.ml 9179 2006-09-26 12:13:06Z barras $ *) (* ML part of the Ring tactic *) @@ -43,7 +43,7 @@ let ring_dir = ["Coq";"ring"] let setoids_dir = ["Coq";"Setoids"] let ring_constant = Coqlib.gen_constant_in_modules "Ring" - [ring_dir@["Ring_theory"]; + [ring_dir@["LegacyRing_theory"]; ring_dir@["Setoid_ring_theory"]; ring_dir@["Ring_normalize"]; ring_dir@["Ring_abstract"]; @@ -885,7 +885,7 @@ let match_with_equiv c = match (kind_of_term c) with | _ -> None let polynom lc gl = - Coqlib.check_required_library ["Coq";"ring";"Ring"]; + Coqlib.check_required_library ["Coq";"ring";"LegacyRing"]; match lc with (* If no argument is given, try to recognize either an equality or a declared relation with arguments c1 ... cn, diff --git a/contrib/rtauto/refl_tauto.ml b/contrib/rtauto/refl_tauto.ml index 445dead2..a1f5e5aa 100644 --- a/contrib/rtauto/refl_tauto.ml +++ b/contrib/rtauto/refl_tauto.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: refl_tauto.ml 7639 2005-12-02 10:01:15Z gregoire $ *) +(* $Id: refl_tauto.ml 9154 2006-09-20 17:18:18Z corbinea $ *) module Search = Explore.Make(Proof_search) @@ -303,7 +303,6 @@ let rtauto_tac gls= end in let build_start_time=System.get_time () in let _ = step_count := 0; node_count := 0 in - let nhyps = List.length hyps in let main = mkApp (force node_count l_Reflect, [|build_env gamma; build_form formula; diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v new file mode 100644 index 00000000..5060bc69 --- /dev/null +++ b/contrib/setoid_ring/ArithRing.v @@ -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 *) +(************************************************************************) + +Require Import Mult. +Require Export Ring. +Set Implicit Arguments. + +Ltac isnatcst t := + let t := eval hnf in t in + match t with + O => true + | S ?p => isnatcst p + | _ => false + end. +Ltac natcst t := + match isnatcst t with + true => t + | _ => NotConstant + end. + +Ltac Ss_to_add f acc := + match f with + | S ?f1 => Ss_to_add f1 (S acc) + | _ => constr:(acc + f)%nat + end. + +Ltac natprering := + match goal with + |- context C [S ?p] => + match p with + O => fail 1 (* avoid replacing 1 with 1+0 ! *) + | p => match isnatcst p with + | true => fail 1 + | false => let v := Ss_to_add p (S 0) in + fold v; natprering + end + end + | _ => idtac + end. + + Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat). + Proof. + constructor. exact plus_0_l. exact plus_comm. exact plus_assoc. + exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc. + exact mult_plus_distr_r. + Qed. + + +Unboxed Fixpoint nateq (n m:nat) {struct m} : bool := + match n, m with + | O, O => true + | S n', S m' => nateq n' m' + | _, _ => false + end. + +Lemma nateq_ok : forall n m:nat, nateq n m = true -> n = m. +Proof. + simple induction n; simple induction m; simpl; intros; try discriminate. + trivial. + rewrite (H n1 H1). + trivial. +Qed. + +Add Ring natr : natSRth + (decidable nateq_ok, constants [natcst], preprocess [natprering]). diff --git a/contrib/setoid_ring/BinList.v b/contrib/setoid_ring/BinList.v index 0def087f..0d0fe5a4 100644 --- a/contrib/setoid_ring/BinList.v +++ b/contrib/setoid_ring/BinList.v @@ -1,46 +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 *) +(************************************************************************) + Set Implicit Arguments. Require Import BinPos. +Require Export List. +Require Export ListTactics. Open Scope positive_scope. +Section MakeBinList. + Variable A : Type. + Variable default : A. -Section LIST. - - Variable A:Type. - Variable default:A. - - Inductive list : Type := - | nil : list - | cons : A -> list -> list. - - Infix "::" := cons (at level 60, right associativity). - - Definition hd l := match l with hd :: _ => hd | _ => default end. - - Definition tl l := match l with _ :: tl => tl | _ => nil end. - - Fixpoint jump (p:positive) (l:list) {struct p} : list := + Fixpoint jump (p:positive) (l:list A) {struct p} : list A := match p with - | xH => tl l + | xH => tail l | xO p => jump p (jump p l) - | xI p => jump p (jump p (tl l)) + | xI p => jump p (jump p (tail l)) end. - Fixpoint nth (p:positive) (l:list) {struct p} : A:= + Fixpoint nth (p:positive) (l:list A) {struct p} : A:= match p with - | xH => hd l + | xH => hd default l | xO p => nth p (jump p l) - | xI p => nth p (jump p (tl l)) + | xI p => nth p (jump p (tail l)) end. - Fixpoint rev_append (rev l : list) {struct l} : list := - match l with - | nil => rev - | (cons h t) => rev_append (cons h rev) t - end. - - Definition rev l : list := rev_append nil l. - - Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l). + Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). Proof. induction j;simpl;intros. repeat rewrite IHj;trivial. @@ -71,7 +61,7 @@ Section LIST. Qed. Lemma jump_Pdouble_minus_one : forall i l, - (jump (Pdouble_minus_one i) (tl l)) = (jump i (jump i l)). + (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)). Proof. induction i;intros;simpl. repeat rewrite jump_tl;trivial. @@ -80,7 +70,7 @@ Section LIST. Qed. - Lemma nth_jump : forall p l, nth p (tl l) = hd (jump p l). + Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l). Proof. induction p;simpl;intros. rewrite <-jump_tl;rewrite IHp;trivial. @@ -89,7 +79,7 @@ Section LIST. Qed. Lemma nth_Pdouble_minus_one : - forall p l, nth (Pdouble_minus_one p) (tl l) = nth p (jump p l). + forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). Proof. induction p;simpl;intros. repeat rewrite jump_tl;trivial. @@ -98,4 +88,4 @@ Section LIST. trivial. Qed. -End LIST. +End MakeBinList. diff --git a/contrib/field/Field.v b/contrib/setoid_ring/Field.v index 3cc097fc..a944ba5f 100644 --- a/contrib/field/Field.v +++ b/contrib/setoid_ring/Field.v @@ -6,10 +6,5 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Field.v 5920 2004-07-16 20:01:26Z herbelin $ *) - -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 +Require Export Field_theory. +Require Export Field_tac. diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v new file mode 100644 index 00000000..786654ab --- /dev/null +++ b/contrib/setoid_ring/Field_tac.v @@ -0,0 +1,200 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Ring_tac BinList Ring_polynom InitialRing. +Require Export Field_theory. + + (* syntaxification *) + Ltac mkFieldexpr C Cst radd rmul rsub ropp rdiv rinv t fv := + let rec mkP t := + match Cst t with + | Ring_tac.NotConstant => + match t with + | (radd ?t1 ?t2) => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(FEadd e1 e2) + | (rmul ?t1 ?t2) => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(FEmul e1 e2) + | (rsub ?t1 ?t2) => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(FEsub e1 e2) + | (ropp ?t1) => + let e1 := mkP t1 in constr:(FEopp e1) + | (rdiv ?t1 ?t2) => + let e1 := mkP t1 in + let e2 := mkP t2 in constr:(FEdiv e1 e2) + | (rinv ?t1) => + let e1 := mkP t1 in constr:(FEinv e1) + | _ => + let p := Find_at t fv in constr:(@FEX C p) + end + | ?c => constr:(FEc c) + end + in mkP t. + +Ltac FFV Cst add mul sub opp div inv t fv := + let rec TFV t fv := + match Cst t with + | Ring_tac.NotConstant => + match t with + | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) + | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) + | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) + | (opp ?t1) => TFV t1 fv + | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) + | (inv ?t1) => TFV t1 fv + | _ => AddFvTail t fv + end + | _ => fv + end + in TFV t fv. + +Ltac ParseFieldComponents lemma req := + match type of lemma with + | context [@FEeval ?R ?rO ?add ?mul ?sub ?opp ?div ?inv ?C ?phi _ _] => + (fun f => f add mul sub opp div inv C) + | _ => fail 1 "field anomaly: bad correctness lemma (parse)" + end. + +(* simplifying the non-zero condition... *) + +Ltac fold_field_cond req := + let rec fold_concl t := + match t with + ?x /\ ?y => + let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy) + | req ?x ?y -> False => constr:(~ req x y) + | _ => t + end in + match goal with + |- ?t => let ft := fold_concl t in change ft + end. + +Ltac simpl_PCond req := + protect_fv "field_cond"; + try (exact I); + fold_field_cond req. + +(* Rewriting (field_simplify) *) +Ltac Field_simplify lemma Cond_lemma req Cst_tac := + let Make_tac := + match type of lemma with + | forall l fe nfe, + _ = nfe -> + PCond _ _ _ _ _ _ _ _ _ -> + req (FEeval ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv (C:=?C) ?phi l fe) + _ => + let mkFV := FFV Cst_tac radd rmul rsub ropp rdiv rinv in + let mkFE := mkFieldexpr C Cst_tac radd rmul rsub ropp rdiv rinv in + let simpl_field H := protect_fv "field" in H in + fun f rl => f mkFV mkFE simpl_field lemma req rl; + try (apply Cond_lemma; simpl_PCond req) + | _ => fail 1 "field anomaly: bad correctness lemma (rewr)" + end in + Make_tac ReflexiveRewriteTactic. +(* Pb: second rewrite are applied to non-zero condition of first rewrite... *) + +Tactic Notation (at level 0) "field_simplify" constr_list(rl) := + field_lookup + (fun req cst_tac _ _ field_simplify_ok cond_ok pre post rl => + pre(); Field_simplify field_simplify_ok cond_ok req cst_tac rl; post()). + + +(* Generic form of field tactics *) +Ltac Field_Scheme FV_tac SYN_tac SIMPL_tac lemma Cond_lemma req := + let R := match type of req with ?R -> _ => R end in + let rec ParseExpr ilemma := + match type of ilemma with + forall nfe, ?fe = nfe -> _ => + (fun t => + let x := fresh "fld_expr" in + let H := fresh "norm_fld_expr" in + compute_assertion H x fe; + ParseExpr (ilemma x H) t; + try clear x H) + | _ => (fun t => t ilemma) + end in + let Main r1 r2 := + let fv := FV_tac r1 (@List.nil R) in + let fv := FV_tac r2 fv in + let fe1 := SYN_tac r1 fv in + let fe2 := SYN_tac r2 fv in + ParseExpr (lemma fv fe1 fe2) + ltac:(fun ilemma => + apply ilemma || fail "field anomaly: failed in applying lemma"; + [ SIMPL_tac | apply Cond_lemma; simpl_PCond req]) in + OnEquation req Main. + +(* solve completely a field equation, leaving non-zero conditions to be + proved (field) *) +Ltac Field lemma Cond_lemma req Cst_tac := + let Main radd rmul rsub ropp rdiv rinv C := + let mkFV := FFV Cst_tac radd rmul rsub ropp rdiv rinv in + let mkFE := mkFieldexpr C Cst_tac radd rmul rsub ropp rdiv rinv in + let Simpl := + vm_compute; reflexivity || fail "not a valid field equation" in + Field_Scheme mkFV mkFE Simpl lemma Cond_lemma req in + ParseFieldComponents lemma req Main. + +Tactic Notation (at level 0) "field" := + field_lookup + (fun req cst_tac field_ok _ _ cond_ok pre post rl => + pre(); Field field_ok cond_ok req cst_tac; post()). + +(* transforms a field equation to an equivalent (simplified) ring equation, + and leaves non-zero conditions to be proved (field_simplify_eq) *) +Ltac Field_simplify_eq lemma Cond_lemma req Cst_tac := + let Main radd rmul rsub ropp rdiv rinv C := + let mkFV := FFV Cst_tac radd rmul rsub ropp rdiv rinv in + let mkFE := mkFieldexpr C Cst_tac radd rmul rsub ropp rdiv rinv in + let Simpl := (protect_fv "field") in + Field_Scheme mkFV mkFE Simpl lemma Cond_lemma req in + ParseFieldComponents lemma req Main. + +Tactic Notation (at level 0) "field_simplify_eq" := + field_lookup + (fun req cst_tac _ field_simplify_eq_ok _ cond_ok pre post rl => + pre(); Field_simplify_eq field_simplify_eq_ok cond_ok req cst_tac; + post()). + +(* Adding a new field *) + +Ltac ring_of_field f := + match type of f with + | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f) + | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f) + | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f) + end. + +Ltac coerce_to_almost_field set ext f := + match type of f with + | almost_field_theory _ _ _ _ _ _ _ _ _ => f + | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f) + | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f) + end. + +Ltac field_elements set ext fspec rk := + let afth := coerce_to_almost_field set ext fspec in + let rspec := ring_of_field fspec in + ring_elements set ext rspec rk + ltac:(fun arth ext_r morph f => f afth ext_r morph). + + +Ltac field_lemmas set ext inv_m fspec rk := + field_elements set ext fspec rk + ltac:(fun afth ext_r morph => + let field_ok := constr:(Field_correct set ext_r inv_m afth morph) in + let field_simpl_ok := + constr:(Pphi_dev_div_ok set ext_r inv_m afth morph) in + let field_simpl_eq_ok := + constr:(Field_simplify_eq_correct set ext_r inv_m afth morph) in + let cond1_ok := constr:(Pcond_simpl_gen set ext_r afth morph) in + let cond2_ok := constr:(Pcond_simpl_complete set ext_r afth morph) in + (fun f => f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok + cond1_ok cond2_ok)). diff --git a/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v new file mode 100644 index 00000000..f810859c --- /dev/null +++ b/contrib/setoid_ring/Field_theory.v @@ -0,0 +1,1460 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Ring. +Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List. +Require Import ZArith_base. +Set Implicit Arguments. + +Section MakeFieldPol. + +(* Field elements *) + Variable R:Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). + Variable (rdiv : R -> R -> R) (rinv : R -> R). + Variable req : R -> R -> Prop. + + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y). + Notation "- x" := (ropp x). Notation "/ x" := (rinv x). + Notation "x == y" := (req x y) (at level 70, no associativity). + + (* Equality properties *) + Variable Rsth : Setoid_Theory R req. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Variable SRinv_ext : forall p q, p == q -> / p == / q. + + (* Field properties *) + Record almost_field_theory : Prop := mk_afield { + AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; + AF_1_neq_0 : ~ 1 == 0; + AFdiv_def : forall p q, p / q == p * / q; + AFinv_l : forall p, ~ p == 0 -> / p * p == 1 + }. + +Section AlmostField. + + Variable AFth : almost_field_theory. + Let ARth := AFth.(AF_AR). + Let rI_neq_rO := AFth.(AF_1_neq_0). + Let rdiv_def := AFth.(AFdiv_def). + Let rinv_l := AFth.(AFinv_l). + + (* Coefficients *) + Variable C: Type. + Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). + Variable ceqb : C->C->bool. + Variable phi : C -> R. + + Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req + cO cI cadd cmul csub copp ceqb phi. + +Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type), + (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y). +Proof. +intros. +generalize (fun h => X (morph_eq CRmorph c1 c2 h)). +case (ceqb c1 c2); auto. +Qed. + + + (* C notations *) + Notation "x +! y" := (cadd x y) (at level 50). + Notation "x *! y " := (cmul x y) (at level 40). + Notation "x -! y " := (csub x y) (at level 50). + Notation "-! x" := (copp x) (at level 35). + Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity). + Notation "[ x ]" := (phi x) (at level 0). + + + (* Usefull tactics *) + Add Setoid R req Rsth as R_set1. + Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed. + +Let eq_trans := Setoid.Seq_trans _ _ Rsth. +Let eq_sym := Setoid.Seq_sym _ _ Rsth. +Let eq_refl := Setoid.Seq_refl _ _ Rsth. + +Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) . +Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe) + (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext. +Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) + (ARmul_1_l ARth) (ARmul_0_l ARth) + (ARmul_comm ARth) (ARmul_assoc ARth) (ARdistr_l ARth) + (ARopp_mul_l ARth) (ARopp_add ARth) + (ARsub_def ARth) . + +Notation NPEeval := (PEeval rO radd rmul rsub ropp phi). +Notation Nnorm := (norm cO cI cadd cmul csub copp ceqb). +Notation NPphi_dev := (Pphi_dev rO rI radd rmul cO cI ceqb phi). + +(* add abstract semi-ring to help with some proofs *) +Add Ring Rring : (ARth_SRth ARth). + + +(* additional ring properties *) + +Lemma rsub_0_l : forall r, 0 - r == - r. +intros; rewrite (ARsub_def ARth) in |- *; ring. +Qed. + +Lemma rsub_0_r : forall r, r - 0 == r. +intros; rewrite (ARsub_def ARth) in |- *. +rewrite (ARopp_zero Rsth Reqe ARth) in |- *; ring. +Qed. + +(*************************************************************************** + + Properties of division + + ***************************************************************************) + +Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p. +intros p q H. +rewrite rdiv_def in |- *. +transitivity (/ q * q * p); [ ring | idtac ]. +rewrite rinv_l in |- *; auto. +Qed. +Hint Resolve rdiv_simpl . + +Theorem SRdiv_ext: + forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 -> p1 / q1 == p2 / q2. +intros p1 p2 H q1 q2 H0. +transitivity (p1 * / q1); auto. +transitivity (p2 * / q2); auto. +Qed. +Hint Resolve SRdiv_ext . + + Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed. + +Lemma rmul_reg_l : forall p q1 q2, + ~ p == 0 -> p * q1 == p * q2 -> q1 == q2. +intros. +rewrite <- (@rdiv_simpl q1 p) in |- *; trivial. +rewrite <- (@rdiv_simpl q2 p) in |- *; trivial. +repeat rewrite rdiv_def in |- *. +repeat rewrite (ARmul_assoc ARth) in |- *. +auto. +Qed. + +Theorem field_is_integral_domain : forall r1 r2, + ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. +Proof. +red in |- *; intros. +apply H0. +transitivity (1 * r2); auto. +transitivity (/ r1 * r1 * r2); auto. +rewrite <- (ARmul_assoc ARth) in |- *. +rewrite H1 in |- *. +apply ARmul_0_r with (1 := Rsth) (2 := ARth). +Qed. + +Theorem ropp_neq_0 : forall r, + ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0. +intros. +setoid_replace (- r) with (- (1) * r). + apply field_is_integral_domain; trivial. + rewrite <- (ARopp_mul_l ARth) in |- *. + rewrite (ARmul_1_l ARth) in |- *. + reflexivity. +Qed. + +Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1. +intros. +rewrite (AFdiv_def AFth) in |- *. +rewrite (ARmul_comm ARth) in |- *. +apply (AFinv_l AFth). +trivial. +Qed. + +Theorem rdiv1: forall r, r == r / 1. +intros r; transitivity (1 * (r / 1)); auto. +Qed. + +Theorem rdiv2: + forall r1 r2 r3 r4, + ~ r2 == 0 -> + ~ r4 == 0 -> + r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4). +Proof. +intros r1 r2 r3 r4 H H0. +assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial). +apply rmul_reg_l with (r2 * r4); trivial. +rewrite rdiv_simpl in |- *; trivial. +rewrite (ARdistr_r Rsth Reqe ARth) in |- *. +apply (Radd_ext Reqe). + transitivity (r2 * (r1 / r2) * r4); [ ring | auto ]. + transitivity (r2 * (r4 * (r3 / r4))); auto. + transitivity (r2 * r3); auto. +Qed. + + +Theorem rdiv2b: + forall r1 r2 r3 r4 r5, + ~ (r2*r5) == 0 -> + ~ (r4*r5) == 0 -> + r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)). +Proof. +intros r1 r2 r3 r4 r5 H H0. +assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring). +assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring). +assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring). +assert (HH4: ~ r2 * (r4 * r5) == 0) + by complete (repeat apply field_is_integral_domain; trivial). +apply rmul_reg_l with (r2 * (r4 * r5)); trivial. +rewrite rdiv_simpl in |- *; trivial. +rewrite (ARdistr_r Rsth Reqe ARth) in |- *. +apply (Radd_ext Reqe). + transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [ ring | auto ]. + transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [ ring | auto ]. +Qed. + +Theorem rdiv5: forall r1 r2, - (r1 / r2) == - r1 / r2. +intros r1 r2. +transitivity (- (r1 * / r2)); auto. +transitivity (- r1 * / r2); auto. +Qed. +Hint Resolve rdiv5 . + +Theorem rdiv3: + forall r1 r2 r3 r4, + ~ r2 == 0 -> + ~ r4 == 0 -> + r1 / r2 - r3 / r4 == (r1 * r4 - r3 * r2) / (r2 * r4). +intros r1 r2 r3 r4 H H0. +assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). +transitivity (r1 / r2 + - (r3 / r4)); auto. +transitivity (r1 / r2 + - r3 / r4); auto. +transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)); auto. +apply rdiv2; auto. +apply SRdiv_ext; auto. +transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. +Qed. + + +Theorem rdiv3b: + forall r1 r2 r3 r4 r5, + ~ (r2 * r5) == 0 -> + ~ (r4 * r5) == 0 -> + r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)). +Proof. +intros r1 r2 r3 r4 r5 H H0. +transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto. +transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto. +transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))). +apply rdiv2b; auto; try ring. +apply (SRdiv_ext); auto. +transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. +Qed. + +Theorem rdiv6: + forall r1 r2, + ~ r1 == 0 -> ~ r2 == 0 -> / (r1 / r2) == r2 / r1. +intros r1 r2 H H0. +assert (~ r1 / r2 == 0) as Hk. + intros H1; case H. + transitivity (r2 * (r1 / r2)); auto. + rewrite H1 in |- *; ring. + apply rmul_reg_l with (r1 / r2); auto. + transitivity (/ (r1 / r2) * (r1 / r2)); auto. + transitivity 1; auto. + repeat rewrite rdiv_def in |- *. + transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac | ring ]. + repeat rewrite rinv_l in |- *; auto. +Qed. +Hint Resolve rdiv6 . + + Theorem rdiv4: + forall r1 r2 r3 r4, + ~ r2 == 0 -> + ~ r4 == 0 -> + (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4). +Proof. +intros r1 r2 r3 r4 H H0. +assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial). +apply rmul_reg_l with (r2 * r4); trivial. +rewrite rdiv_simpl in |- *; trivial. +transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ]. +repeat rewrite rdiv_simpl in |- *; trivial. +Qed. + + Theorem rdiv7: + forall r1 r2 r3 r4, + ~ r2 == 0 -> + ~ r3 == 0 -> + ~ r4 == 0 -> + (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3). +Proof. +intros. +rewrite (rdiv_def (r1 / r2)) in |- *. +rewrite rdiv6 in |- *; trivial. +apply rdiv4; trivial. +Qed. + +Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 -> r1 / r2 == 0. +intros r1 r2 H H0. +transitivity (r1 * / r2); auto. +transitivity (0 * / r2); auto. +Qed. + + +Theorem cross_product_eq : forall r1 r2 r3 r4, + ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4. +intros. +transitivity (r1 / r2 * (r4 / r4)). + rewrite rdiv_r_r in |- *; trivial. + symmetry in |- *. + apply (ARmul_1_r Rsth ARth). + rewrite rdiv4 in |- *; trivial. + rewrite H1 in |- *. + rewrite (ARmul_comm ARth r2 r4) in |- *. + rewrite <- rdiv4 in |- *; trivial. + rewrite rdiv_r_r in |- *. + trivial. + apply (ARmul_1_r Rsth ARth). +Qed. + +(*************************************************************************** + + Some equality test + + ***************************************************************************) + +Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool := + match p1, p2 with + xH, xH => true + | xO p3, xO p4 => positive_eq p3 p4 + | xI p3, xI p4 => positive_eq p3 p4 + | _, _ => false + end. + +Theorem positive_eq_correct: + forall p1 p2, if positive_eq p1 p2 then p1 = p2 else p1 <> p2. +intros p1; elim p1; + (try (intros p2; case p2; simpl; auto; intros; discriminate)). +intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. +generalize (rec p4); case (positive_eq p3 p4); auto. +intros H1; apply f_equal with ( f := xI ); auto. +intros H1 H2; case H1; injection H2; auto. +intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. +generalize (rec p4); case (positive_eq p3 p4); auto. +intros H1; apply f_equal with ( f := xO ); auto. +intros H1 H2; case H1; injection H2; auto. +Qed. + +(* equality test *) +Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := + match e1, e2 with + PEc c1, PEc c2 => ceqb c1 c2 + | PEX p1, PEX p2 => positive_eq p1 p2 + | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false + | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false + | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false + | PEopp e3, PEopp e4 => PExpr_eq e3 e4 + | _, _ => false + end. + +Theorem PExpr_eq_semi_correct: + forall l e1 e2, PExpr_eq e1 e2 = true -> NPEeval l e1 == NPEeval l e2. +intros l e1; elim e1. +intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)). +intros c2; apply (morph_eq CRmorph). +intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)). +intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2); + (try (intros; discriminate)); intros H; rewrite H; auto. +intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). +intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); + (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); + (try (intros; discriminate)); auto. +intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). +intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); + (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); + (try (intros; discriminate)); auto. +intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)). +intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4); + (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6); + (try (intros; discriminate)); auto. +intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))). +intros e4; generalize (rec e4); case (PExpr_eq e3 e4); + (try (intros; discriminate)); auto. +Qed. + +(* add *) +Definition NPEadd e1 e2 := + match e1, e2 with + PEc c1, PEc c2 => PEc (cadd c1 c2) + | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2 + | _, PEc c => if ceqb c cO then e1 else PEadd e1 e2 + | _, _ => PEadd e1 e2 + end. + +Theorem NPEadd_correct: + forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2). +Proof. +intros l e1 e2. +destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; + try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; + try rewrite (morph0 CRmorph) in |- *; try ring. +apply (morph_add CRmorph). +Qed. + +(* mul *) +Definition NPEmul x y := + match x, y with + PEc c1, PEc c2 => PEc (cmul c1 c2) + | PEc c, _ => + if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y + | _, PEc c => + if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y + | _, _ => PEmul x y + end. + +Theorem NPEmul_correct : forall l e1 e2, + NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). +intros l e1 e2. +destruct e1; destruct e2; simpl in |- *; try reflexivity; + repeat apply ceqb_rect; + try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; + try rewrite (morph0 CRmorph) in |- *; + try rewrite (morph1 CRmorph) in |- *; + try ring. +apply (morph_mul CRmorph). +Qed. + +(* sub *) +Definition NPEsub e1 e2 := + match e1, e2 with + PEc c1, PEc c2 => PEc (csub c1 c2) + | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2 + | _, PEc c => if ceqb c cO then e1 else PEsub e1 e2 + | _, _ => PEsub e1 e2 + end. + +Theorem NPEsub_correct: + forall l e1 e2, NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2). +intros l e1 e2. +destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; + try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; + try rewrite (morph0 CRmorph) in |- *; try reflexivity; + try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). +apply (morph_sub CRmorph). +Qed. + +(* opp *) +Definition NPEopp e1 := + match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end. + +Theorem NPEopp_correct: + forall l e1, NPEeval l (NPEopp e1) == NPEeval l (PEopp e1). +intros l e1; case e1; simpl; auto. +intros; apply (morph_opp CRmorph). +Qed. + +(* simplification *) +Fixpoint PExpr_simp (e : PExpr C) : PExpr C := + match e with + PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2) + | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2) + | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2) + | PEopp e1 => NPEopp (PExpr_simp e1) + | _ => e + end. + +Theorem PExpr_simp_correct: + forall l e, NPEeval l (PExpr_simp e) == NPEeval l e. +intros l e; elim e; simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEadd_correct. +simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEsub_correct. +simpl; auto. +intros e1 He1 e2 He2. +transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto. +apply NPEmul_correct. +simpl; auto. +intros e1 He1. +transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto. +apply NPEopp_correct. +simpl; auto. +Qed. + + +(**************************************************************************** + + Datastructure + + ***************************************************************************) + +(* The input: syntax of a field expression *) + +Inductive FExpr : Type := + FEc: C -> FExpr + | FEX: positive -> FExpr + | FEadd: FExpr -> FExpr -> FExpr + | FEsub: FExpr -> FExpr -> FExpr + | FEmul: FExpr -> FExpr -> FExpr + | FEopp: FExpr -> FExpr + | FEinv: FExpr -> FExpr + | FEdiv: FExpr -> FExpr -> FExpr . + +Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := + match pe with + | FEc c => phi c + | FEX x => BinList.nth 0 x l + | FEadd x y => FEeval l x + FEeval l y + | FEsub x y => FEeval l x - FEeval l y + | FEmul x y => FEeval l x * FEeval l y + | FEopp x => - FEeval l x + | FEinv x => / FEeval l x + | FEdiv x y => FEeval l x / FEeval l y + end. + +(* The result of the normalisation *) + +Record linear : Type := mk_linear { + num : PExpr C; + denum : PExpr C; + condition : list (PExpr C) }. + +(*************************************************************************** + + Semantics and properties of side condition + + ***************************************************************************) + +Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := + match le with + | nil => True + | e1 :: nil => ~ req (PEeval rO radd rmul rsub ropp phi l e1) rO + | e1 :: l1 => ~ req (PEeval rO radd rmul rsub ropp phi l e1) rO /\ PCond l l1 + end. + +Theorem PCond_cons_inv_l : + forall l a l1, PCond l (a::l1) -> ~ NPEeval l a == 0. +intros l a l1 H. +destruct l1; simpl in H |- *; trivial. +destruct H; trivial. +Qed. + +Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) -> PCond l l1. +intros l a l1 H. +destruct l1; simpl in H |- *; trivial. +destruct H; trivial. +Qed. + +Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l1. +intros l l1 l2; elim l1; simpl app in |- *. + simpl in |- *; auto. + destruct l0; simpl in *. + destruct l2; firstorder. + firstorder. +Qed. + +Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l2. +intros l l1 l2; elim l1; simpl app; auto. +intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ). +Qed. + +(* An unsatisfiable condition: issued when a division by zero is detected *) +Definition absurd_PCond := cons (PEc cO) nil. + +Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond. +unfold absurd_PCond in |- *; simpl in |- *. +red in |- *; intros. +apply H. +apply (morph0 CRmorph). +Qed. + +(*************************************************************************** + + Normalisation + + ***************************************************************************) + + +Fixpoint isIn (e1 e2: PExpr C) {struct e2}: option (PExpr C) := + match e2 with + | PEmul e3 e4 => + match isIn e1 e3 with + Some e5 => Some (NPEmul e5 e4) + | None => match isIn e1 e4 with + | Some e5 => Some (NPEmul e3 e5) + | None => None + end + end + | _ => + if PExpr_eq e1 e2 then Some (PEc cI) else None + end. + +Theorem isIn_correct: forall l e1 e2, + match isIn e1 e2 with + (Some e3) => NPEeval l e2 == NPEeval l (NPEmul e1 e3) + | _ => True + end. +Proof. +intros l e1 e2; elim e2; simpl; auto. + intros c; + generalize (PExpr_eq_semi_correct l e1 (PEc c)); + case (PExpr_eq e1 (PEc c)); simpl; auto; intros H. + rewrite NPEmul_correct; simpl; auto. + rewrite H; auto; simpl. + rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. + intros p; + generalize (PExpr_eq_semi_correct l e1 (PEX C p)); + case (PExpr_eq e1 (PEX C p)); simpl; auto; intros H. + rewrite NPEmul_correct; simpl; auto. + rewrite H; auto; simpl. + rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. + intros p Hrec p1 Hrec1. + generalize (PExpr_eq_semi_correct l e1 (PEadd p p1)); + case (PExpr_eq e1 (PEadd p p1)); simpl; auto; intros H. + rewrite NPEmul_correct; simpl; auto. + rewrite H; auto; simpl. + rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. + intros p Hrec p1 Hrec1. + generalize (PExpr_eq_semi_correct l e1 (PEsub p p1)); + case (PExpr_eq e1 (PEsub p p1)); simpl; auto; intros H. + rewrite NPEmul_correct; simpl; auto. + rewrite H; auto; simpl. + rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. + intros p; case (isIn e1 p). + intros p2 Hrec p1 Hrec1. + rewrite Hrec; auto; simpl. + repeat (rewrite NPEmul_correct; simpl; auto). + intros _ p1; case (isIn e1 p1); auto. + intros p2 H; rewrite H. + repeat (rewrite NPEmul_correct; simpl; auto). + ring. + intros p; + generalize (PExpr_eq_semi_correct l e1 (PEopp p)); + case (PExpr_eq e1 (PEopp p)); simpl; auto; intros H. + rewrite NPEmul_correct; simpl; auto. + rewrite H; auto; simpl. + rewrite (morph1 CRmorph); rewrite (ARmul_1_r Rsth ARth); auto. +Qed. + +Record rsplit : Type := mk_rsplit { + rsplit_left : PExpr C; + rsplit_common : PExpr C; + rsplit_right : PExpr C}. + +(* Stupid name clash *) +Let left := rsplit_left. +Let right := rsplit_right. +Let common := rsplit_common. + +Fixpoint split (e1 e2: PExpr C) {struct e1}: rsplit := + match e1 with + | PEmul e3 e4 => + let r1 := split e3 e2 in + let r2 := split e4 (right r1) in + mk_rsplit (NPEmul (left r1) (left r2)) + (NPEmul (common r1) (common r2)) + (right r2) + | _ => + match isIn e1 e2 with + Some e3 => mk_rsplit (PEc cI) e1 e3 + | None => mk_rsplit e1 (PEc cI) e2 + end + end. + +Theorem split_correct: forall l e1 e2, + NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) + (common (split e1 e2))) +/\ + NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2)) + (common (split e1 e2))). +Proof. +intros l e1; elim e1; simpl; auto. + intros c e2; generalize (isIn_correct l (PEc c) e2); + case (isIn (PEc c) e2); auto; intros p; + [intros Hp1; rewrite Hp1 | idtac]; + simpl left; simpl common; simpl right; auto; + repeat rewrite NPEmul_correct; simpl; split; + try rewrite (morph1 CRmorph); ring. + intros p e2; generalize (isIn_correct l (PEX C p) e2); + case (isIn (PEX C p) e2); auto; intros p1; + [intros Hp1; rewrite Hp1 | idtac]; + simpl left; simpl common; simpl right; auto; + repeat rewrite NPEmul_correct; simpl; split; + try rewrite (morph1 CRmorph); ring. + intros p1 _ p2 _ e2; generalize (isIn_correct l (PEadd p1 p2) e2); + case (isIn (PEadd p1 p2) e2); auto; intros p; + [intros Hp1; rewrite Hp1 | idtac]; + simpl left; simpl common; simpl right; auto; + repeat rewrite NPEmul_correct; simpl; split; + try rewrite (morph1 CRmorph); ring. + intros p1 _ p2 _ e2; generalize (isIn_correct l (PEsub p1 p2) e2); + case (isIn (PEsub p1 p2) e2); auto; intros p; + [intros Hp1; rewrite Hp1 | idtac]; + simpl left; simpl common; simpl right; auto; + repeat rewrite NPEmul_correct; simpl; split; + try rewrite (morph1 CRmorph); ring. + intros p1 Hp1 p2 Hp2 e2. + repeat rewrite NPEmul_correct; simpl; split. + case (Hp1 e2); case (Hp2 (right (split p1 e2))). + intros tmp1 _ tmp2 _; rewrite tmp1; rewrite tmp2. + repeat rewrite NPEmul_correct; simpl. + ring. + case (Hp1 e2); case (Hp2 (right (split p1 e2))). + intros _ tmp1 _ tmp2; rewrite tmp2; + repeat rewrite NPEmul_correct; simpl. + rewrite tmp1. + repeat rewrite NPEmul_correct; simpl. + ring. + intros p _ e2; generalize (isIn_correct l (PEopp p) e2); + case (isIn (PEopp p) e2); auto; intros p1; + [intros Hp1; rewrite Hp1 | idtac]; + simpl left; simpl common; simpl right; auto; + repeat rewrite NPEmul_correct; simpl; split; + try rewrite (morph1 CRmorph); ring. +Qed. + + +Theorem split_correct_l: forall l e1 e2, + NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) + (common (split e1 e2))). +Proof. +intros l e1 e2; case (split_correct l e1 e2); auto. +Qed. + +Theorem split_correct_r: forall l e1 e2, + NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2)) + (common (split e1 e2))). +Proof. +intros l e1 e2; case (split_correct l e1 e2); auto. +Qed. + +Fixpoint Fnorm (e : FExpr) : linear := + match e with + | FEc c => mk_linear (PEc c) (PEc cI) nil + | FEX x => mk_linear (PEX C x) (PEc cI) nil + | FEadd e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + let s := split (denum x) (denum y) in + mk_linear + (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) + (NPEmul (left s) (NPEmul (right s) (common s))) + (condition x ++ condition y) + + | FEsub e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + let s := split (denum x) (denum y) in + mk_linear + (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) + (NPEmul (left s) (NPEmul (right s) (common s))) + (condition x ++ condition y) + | FEmul e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + mk_linear (NPEmul (num x) (num y)) + (NPEmul (denum x) (denum y)) + (condition x ++ condition y) + | FEopp e1 => + let x := Fnorm e1 in + mk_linear (NPEopp (num x)) (denum x) (condition x) + | FEinv e1 => + let x := Fnorm e1 in + mk_linear (denum x) (num x) (num x :: condition x) + | FEdiv e1 e2 => + let x := Fnorm e1 in + let y := Fnorm e2 in + mk_linear (NPEmul (num x) (denum y)) + (NPEmul (denum x) (num y)) + (num y :: condition x ++ condition y) + end. + + +(* Example *) +(* +Eval compute + in (Fnorm + (FEdiv + (FEc cI) + (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))). +*) + +Theorem Pcond_Fnorm: + forall l e, + PCond l (condition (Fnorm e)) -> ~ NPEeval l (denum (Fnorm e)) == 0. +intros l e; elim e. + simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO. + simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + rewrite NPEmul_correct in |- *. + simpl in |- *. + apply field_is_integral_domain. + intros HH; case Hrec1; auto. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; case Hrec2; auto. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + rewrite NPEmul_correct in |- *. + simpl in |- *. + apply field_is_integral_domain. + intros HH; case Hrec1; auto. + apply PCond_app_inv_l with (1 := Hcond). + rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))). + rewrite NPEmul_correct; simpl; rewrite HH; ring. + intros HH; case Hrec2; auto. + apply PCond_app_inv_r with (1 := Hcond). + rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto. + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + rewrite NPEmul_correct in |- *. + simpl in |- *. + apply field_is_integral_domain. + apply Hrec1. + apply PCond_app_inv_l with (1 := Hcond). + apply Hrec2. + apply PCond_app_inv_r with (1 := Hcond). + intros e1 Hrec1 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + auto. + intros e1 Hrec1 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + apply PCond_cons_inv_l with (1:=Hcond). + intros e1 Hrec1 e2 Hrec2 Hcond. + simpl condition in Hcond. + simpl denum in |- *. + rewrite NPEmul_correct in |- *. + simpl in |- *. + apply field_is_integral_domain. + apply Hrec1. + specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. + apply PCond_app_inv_l with (1 := Hcond1). + apply PCond_cons_inv_l with (1:=Hcond). +Qed. +Hint Resolve Pcond_Fnorm. + + +(*************************************************************************** + + Main theorem + + ***************************************************************************) + +Theorem Fnorm_FEeval_PEeval: + forall l fe, + PCond l (condition (Fnorm fe)) -> + FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)). +Proof. +intros l fe; elim fe; simpl. +intros c H; rewrite CRmorph.(morph1); apply rdiv1. +intros p H; rewrite CRmorph.(morph1); apply rdiv1. +intros e1 He1 e2 He2 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_app_inv_l with ( 1 := HH ). +assert (HH2: PCond l (condition (Fnorm e2))). +apply PCond_app_inv_r with ( 1 := HH ). +rewrite (He1 HH1); rewrite (He2 HH2). +rewrite NPEadd_correct; simpl. +repeat rewrite NPEmul_correct; simpl. +generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). +repeat rewrite NPEmul_correct; simpl. +intros U1 U2; rewrite U1; rewrite U2. +apply rdiv2b; auto. + rewrite <- U1; auto. + rewrite <- U2; auto. + +intros e1 He1 e2 He2 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_app_inv_l with ( 1 := HH ). +assert (HH2: PCond l (condition (Fnorm e2))). +apply PCond_app_inv_r with ( 1 := HH ). +rewrite (He1 HH1); rewrite (He2 HH2). +rewrite NPEsub_correct; simpl. +repeat rewrite NPEmul_correct; simpl. +generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))) + (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))). +repeat rewrite NPEmul_correct; simpl. +intros U1 U2; rewrite U1; rewrite U2. +apply rdiv3b; auto. + rewrite <- U1; auto. + rewrite <- U2; auto. + +intros e1 He1 e2 He2 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_app_inv_l with ( 1 := HH ). +assert (HH2: PCond l (condition (Fnorm e2))). +apply PCond_app_inv_r with ( 1 := HH ). +rewrite (He1 HH1); rewrite (He2 HH2). +repeat rewrite NPEmul_correct; simpl. +apply rdiv4; auto. + +intros e1 He1 HH. +rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto. + +intros e1 He1 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_cons_inv_r with ( 1 := HH ). +rewrite (He1 HH1); apply rdiv6; auto. +apply PCond_cons_inv_l with ( 1 := HH ). + +intros e1 He1 e2 He2 HH. +assert (HH1: PCond l (condition (Fnorm e1))). +apply PCond_app_inv_l with (condition (Fnorm e2)). +apply PCond_cons_inv_r with ( 1 := HH ). +assert (HH2: PCond l (condition (Fnorm e2))). +apply PCond_app_inv_r with (condition (Fnorm e1)). +apply PCond_cons_inv_r with ( 1 := HH ). +rewrite (He1 HH1); rewrite (He2 HH2). +repeat rewrite NPEmul_correct;simpl. +apply rdiv7; auto. +apply PCond_cons_inv_l with ( 1 := HH ). +Qed. + +Theorem Fnorm_crossproduct: + forall l fe1 fe2, + let nfe1 := Fnorm fe1 in + let nfe2 := Fnorm fe2 in + NPEeval l (PEmul (num nfe1) (denum nfe2)) == + NPEeval l (PEmul (num nfe2) (denum nfe1)) -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2. +rewrite Fnorm_FEeval_PEeval in |- *. + apply PCond_app_inv_l with (1 := Hcond). + rewrite Fnorm_FEeval_PEeval in |- *. + apply PCond_app_inv_r with (1 := Hcond). + apply cross_product_eq; trivial. + apply Pcond_Fnorm. + apply PCond_app_inv_l with (1 := Hcond). + apply Pcond_Fnorm. + apply PCond_app_inv_r with (1 := Hcond). +Qed. + +(* Correctness lemmas of reflexive tactics *) + +Theorem Fnorm_correct: + forall l fe, + Peq ceqb (Nnorm (num (Fnorm fe))) (Pc cO) = true -> + PCond l (condition (Fnorm fe)) -> FEeval l fe == 0. +intros l fe H H1; + apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1). +apply rdiv8; auto. +transitivity (NPEeval l (PEc cO)); auto. +apply (ring_correct Rsth Reqe ARth CRmorph); auto. +simpl; apply (morph0 CRmorph); auto. +Qed. + +(* simplify a field expression into a fraction *) +(* TODO: simplify when den is constant... *) +Definition display_linear l num den := + NPphi_dev l num / NPphi_dev l den. + +Theorem Pphi_dev_div_ok: + forall l fe nfe, + Fnorm fe = nfe -> + PCond l (condition nfe) -> + FEeval l fe == display_linear l (Nnorm (num nfe)) (Nnorm (denum nfe)). +Proof. + intros l fe nfe eq_nfe H; subst nfe. + apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H). + unfold display_linear; apply SRdiv_ext; + apply (Pphi_dev_ok Rsth Reqe ARth CRmorph); reflexivity. +Qed. + +(* solving a field equation *) +Theorem Field_correct : + forall l fe1 fe2, + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + Peq ceqb (Nnorm (PEmul (num nfe1) (denum nfe2))) + (Nnorm (PEmul (num nfe2) (denum nfe1))) = true -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +Proof. +intros l fe1 fe2 nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2. +apply Fnorm_crossproduct; trivial. +apply (ring_correct Rsth Reqe ARth CRmorph); trivial. +Qed. + +(* simplify a field equation : generate the crossproduct and simplify + polynomials *) +Theorem Field_simplify_eq_old_correct : + forall l fe1 fe2 nfe1 nfe2, + Fnorm fe1 = nfe1 -> + Fnorm fe2 = nfe2 -> + NPphi_dev l (Nnorm (PEmul (num nfe1) (denum nfe2))) == + NPphi_dev l (Nnorm (PEmul (num nfe2) (denum nfe1))) -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +Proof. +intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2. +apply Fnorm_crossproduct; trivial. +rewrite (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in |- *. +rewrite (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in |- *. +trivial. +Qed. + +Theorem Field_simplify_eq_correct : + forall l fe1 fe2, + forall nfe1, Fnorm fe1 = nfe1 -> + forall nfe2, Fnorm fe2 = nfe2 -> + forall den, split (denum nfe1) (denum nfe2) = den -> + NPphi_dev l (Nnorm (PEmul (num nfe1) (right den))) == + NPphi_dev l (Nnorm (PEmul (num nfe2) (left den))) -> + PCond l (condition nfe1 ++ condition nfe2) -> + FEeval l fe1 == FEeval l fe2. +Proof. +intros l fe1 fe2 nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; + subst nfe1 nfe2 den. +apply Fnorm_crossproduct; trivial. +simpl in |- *. +elim (split_correct l (denum (Fnorm fe1)) (denum (Fnorm fe2))); intros. +rewrite H in |- *. +rewrite H0 in |- *. +clear H H0. +rewrite NPEmul_correct in |- *. +rewrite NPEmul_correct in |- *. +simpl in |- *. +repeat rewrite (ARmul_assoc ARth) in |- *. +rewrite <- (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in Hcrossprod. +rewrite <- (Pphi_dev_gen_ok Rsth Reqe ARth CRmorph) in Hcrossprod. +simpl in Hcrossprod. +rewrite Hcrossprod in |- *. +reflexivity. +Qed. + +Section Fcons_impl. + +Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C). + +Hypothesis PCond_fcons_inv : forall l a l1, + PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. + +Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := + match l with + | nil => m + | cons a l1 => Fcons a (Fapp l1 m) + end. + +Lemma fcons_correct : forall l l1, + PCond l (Fapp l1 nil) -> PCond l l1. +induction l1; simpl in |- *; intros. + trivial. + elim PCond_fcons_inv with (1 := H); intros. + destruct l1; auto. +Qed. + +End Fcons_impl. + +Section Fcons_simpl. + +(* Some general simpifications of the condition: eliminate duplicates, + split multiplications *) + +Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := + match l with + nil => cons e nil + | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1) + end. + +Theorem PFcons_fcons_inv: + forall l a l1, PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +intros l a l1; elim l1; simpl Fcons; auto. +simpl; auto. +intros a0 l0. +generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0). +intros H H0 H1; split; auto. +rewrite H; auto. +generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. +intros H H0 H1; + assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). +split. +generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. +apply H0. +generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. +generalize Hp; case l0; simpl; intuition. +Qed. + +(* equality of normal forms rather than syntactic equality *) +Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := + match l with + nil => cons e nil + | cons a l1 => + if Peq ceqb (Nnorm e) (Nnorm a) then l else cons a (Fcons0 e l1) + end. + +Theorem PFcons0_fcons_inv: + forall l a l1, PCond l (Fcons0 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +intros l a l1; elim l1; simpl Fcons0; auto. +simpl; auto. +intros a0 l0. +generalize (ring_correct Rsth Reqe ARth CRmorph l a a0); + case (Peq ceqb (Nnorm a) (Nnorm a0)). +intros H H0 H1; split; auto. +rewrite H; auto. +generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. +intros H H0 H1; + assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)). +split. +generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. +apply H0. +generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. +generalize Hp; case l0; simpl; intuition. +Qed. + +Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := + match e with + PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l) + | _ => Fcons0 e l + end. + +Theorem PFcons00_fcons_inv: + forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). + intros p H p0 H0 l1 H1. + simpl in H1. + case (H _ H1); intros H2 H3. + case (H0 _ H3); intros H4 H5; split; auto. + simpl in |- *. + apply field_is_integral_domain; trivial. +Qed. + + +Definition Pcond_simpl_gen := + fcons_correct _ PFcons00_fcons_inv. + + +(* Specific case when the equality test of coefs is complete w.r.t. the + field equality: non-zero coefs can be eliminated, and opposite can + be simplified (if -1 <> 0) *) + +Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true. + +Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type), + (phi c1 == phi c2 -> P x) -> + (~ phi c1 == phi c2 -> P y) -> + P (if ceqb c1 c2 then x else y). +Proof. +intros. +generalize (fun h => X (morph_eq CRmorph c1 c2 h)). +generalize (@ceqb_complete c1 c2). +case (c1 ?=! c2); auto; intros. +apply X0. +red in |- *; intro. +absurd (false = true); auto; discriminate. +Qed. + +Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := + match e with + PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) + | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l + | PEc c => if ceqb c cO then absurd_PCond else l + | _ => Fcons0 e l + end. + +Theorem PFcons1_fcons_inv: + forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). + simpl in |- *; intros c l1. + apply ceqb_rect_complete; intros. + elim (@absurd_PCond_bottom l H0). + split; trivial. + rewrite <- (morph0 CRmorph) in |- *; trivial. + intros p H p0 H0 l1 H1. + simpl in H1. + case (H _ H1); intros H2 H3. + case (H0 _ H3); intros H4 H5; split; auto. + simpl in |- *. + apply field_is_integral_domain; trivial. + simpl in |- *; intros p H l1. + apply ceqb_rect_complete; intros. + elim (@absurd_PCond_bottom l H1). + destruct (H _ H1). + split; trivial. + apply ropp_neq_0; trivial. + rewrite (morph_opp CRmorph) in H0. + rewrite (morph1 CRmorph) in H0. + rewrite (morph0 CRmorph) in H0. + trivial. +Qed. + +Definition Fcons2 e l := Fcons1 (PExpr_simp e) l. + +Theorem PFcons2_fcons_inv: + forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. +unfold Fcons2 in |- *; intros l a l1 H; split; + case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto. +intros H1 H2 H3; case H1. +transitivity (NPEeval l a); trivial. +apply PExpr_simp_correct. +Qed. + +Definition Pcond_simpl_complete := + fcons_correct _ PFcons2_fcons_inv. + +End Fcons_simpl. + +Let Mpc := MPcond_map cO cI cadd cmul csub copp ceqb. +Let Mp := MPcond_dev rO rI radd rmul req cO cI ceqb phi. +Let Subst := PNSubstL cO cI cadd cmul ceqb. + +(* simplification + rewriting *) +Theorem Field_subst_correct : +forall l ul fe m n, + PCond l (Fapp Fcons00 (condition (Fnorm fe)) nil) -> + Mp (Mpc ul) l -> + Peq ceqb (Subst (Nnorm (num (Fnorm fe))) (Mpc ul) m n) (Pc cO) = true -> + FEeval l fe == 0. +intros l ul fe m n H H1 H2. +assert (H3 := (Pcond_simpl_gen _ _ H)). +apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe + (Pcond_simpl_gen _ _ H)). +apply rdiv8; auto. +rewrite (PNSubstL_dev_ok Rsth Reqe ARth CRmorph m n + _ (num (Fnorm fe)) l H1). +rewrite <-(Ring_polynom.Pphi_Pphi_dev Rsth Reqe ARth CRmorph). +rewrite (fun x => Peq_ok Rsth Reqe CRmorph x (Pc cO)); auto. +simpl; apply (morph0 CRmorph); auto. +Qed. + + +End AlmostField. + +Section FieldAndSemiField. + + Record field_theory : Prop := mk_field { + F_R : ring_theory rO rI radd rmul rsub ropp req; + F_1_neq_0 : ~ 1 == 0; + Fdiv_def : forall p q, p / q == p * / q; + Finv_l : forall p, ~ p == 0 -> / p * p == 1 + }. + + Definition F2AF f := + mk_afield + (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l). + + Record semi_field_theory : Prop := mk_sfield { + SF_SR : semi_ring_theory rO rI radd rmul req; + SF_1_neq_0 : ~ 1 == 0; + SFdiv_def : forall p q, p / q == p * / q; + SFinv_l : forall p, ~ p == 0 -> / p * p == 1 + }. + +End FieldAndSemiField. + +End MakeFieldPol. + + Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth + (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := + mk_afield _ _ + (SRth_ARth Rsth sf.(SF_SR)) + sf.(SF_1_neq_0) + sf.(SFdiv_def) + sf.(SFinv_l). + + +Section Complete. + Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable (rdiv : R -> R -> R) (rinv : R -> R). + Variable req : R -> R -> Prop. + Notation "0" := rO. Notation "1" := rI. + Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). + Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). + Notation "x / y " := (rdiv x y). Notation "/ x" := (rinv x). + Notation "x == y" := (req x y) (at level 70, no associativity). + Variable Rsth : Setoid_Theory R req. + Add Setoid R req Rsth as R_setoid3. + Variable Reqe : ring_eq_ext radd rmul ropp req. + Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed. + +Section AlmostField. + + Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req. + Let ARth := AFth.(AF_AR). + Let rI_neq_rO := AFth.(AF_1_neq_0). + Let rdiv_def := AFth.(AFdiv_def). + Let rinv_l := AFth.(AFinv_l). + +Hypothesis S_inj : forall x y, 1+x==1+y -> x==y. + +Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. + +Lemma add_inj_r : forall p x y, + gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y. +intros p x y. +elim p using Pind; simpl in |- *; intros. + apply S_inj; trivial. + apply H. + apply S_inj. + repeat rewrite (ARadd_assoc ARth) in |- *. + rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth) in |- *; trivial. +Qed. + +Lemma gen_phiPOS_inj : forall x y, + gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y -> + x = y. +intros x y. +repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *. +ElimPcompare x y; intro. + intros. + apply Pcompare_Eq_eq; trivial. + intro. + elim gen_phiPOS_not_0 with (y - x)%positive. + apply add_inj_r with x. + symmetry in |- *. + rewrite (ARadd_0_r Rsth ARth) in |- *. + rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. + rewrite Pplus_minus in |- *; trivial. + change Eq with (CompOpp Eq) in |- *. + rewrite <- Pcompare_antisym in |- *; trivial. + rewrite H in |- *; trivial. + intro. + elim gen_phiPOS_not_0 with (x - y)%positive. + apply add_inj_r with y. + rewrite (ARadd_0_r Rsth ARth) in |- *. + rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. + rewrite Pplus_minus in |- *; trivial. +Qed. + + +Lemma gen_phiN_inj : forall x y, + gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> + x = y. +destruct x; destruct y; simpl in |- *; intros; trivial. + elim gen_phiPOS_not_0 with p. + symmetry in |- *. + rewrite (same_gen Rsth Reqe ARth) in |- *; trivial. + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *; trivial. + rewrite gen_phiPOS_inj with (1 := H) in |- *; trivial. +Qed. + +Lemma gen_phiN_complete : forall x y, + gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y -> + Neq_bool x y = true. +intros. + replace y with x. + unfold Neq_bool in |- *. + rewrite Ncompare_refl in |- *; trivial. + apply gen_phiN_inj; trivial. +Qed. + +End AlmostField. + +Section Field. + + Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req. + Let Rth := Fth.(F_R). + Let rI_neq_rO := Fth.(F_1_neq_0). + Let rdiv_def := Fth.(Fdiv_def). + Let rinv_l := Fth.(Finv_l). + Let AFth := F2AF Rsth Reqe Fth. + Let ARth := Rth_ARth Rsth Reqe Rth. + +Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y. +intros. +transitivity (x + (1 + - (1))). + rewrite (Ropp_def Rth) in |- *. + symmetry in |- *. + apply (ARadd_0_r Rsth ARth). + transitivity (y + (1 + - (1))). + repeat rewrite <- (ARplus_assoc ARth) in |- *. + repeat rewrite (ARadd_assoc ARth) in |- *. + apply (Radd_ext Reqe). + repeat rewrite <- (ARadd_comm ARth 1) in |- *. + trivial. + reflexivity. + rewrite (Ropp_def Rth) in |- *. + apply (ARadd_0_r Rsth ARth). +Qed. + + + Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0. + +Let gen_phiPOS_inject := + gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0. + +Lemma gen_phiPOS_discr_sgn : forall x y, + ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. +red in |- *; intros. +apply gen_phiPOS_not_0 with (y + x)%positive. +rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. +transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y). + apply (Radd_ext Reqe); trivial. + reflexivity. + rewrite (same_gen Rsth Reqe ARth) in |- *. + rewrite (same_gen Rsth Reqe ARth) in |- *. + trivial. + apply (Ropp_def Rth). +Qed. + +Lemma gen_phiZ_inj : forall x y, + gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> + x = y. +destruct x; destruct y; simpl in |- *; intros. + trivial. + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *. + symmetry in |- *; trivial. + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *. + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. + rewrite <- H in |- *. + apply (ARopp_zero Rsth Reqe ARth). + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *. + trivial. + rewrite gen_phiPOS_inject with (1 := H) in |- *; trivial. + elim gen_phiPOS_discr_sgn with (1 := H). + elim gen_phiPOS_not_0 with p. + rewrite (same_gen Rsth Reqe ARth) in |- *. + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. + rewrite H in |- *. + apply (ARopp_zero Rsth Reqe ARth). + elim gen_phiPOS_discr_sgn with p0 p. + symmetry in |- *; trivial. + replace p0 with p; trivial. + apply gen_phiPOS_inject. + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *. + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)) in |- *. + rewrite H in |- *; trivial. + reflexivity. +Qed. + +Lemma gen_phiZ_complete : forall x y, + gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y -> + Zeq_bool x y = true. +intros. + replace y with x. + unfold Zeq_bool in |- *. + rewrite Zcompare_refl in |- *; trivial. + apply gen_phiZ_inj; trivial. +Qed. + +End Field. + +End Complete. + diff --git a/contrib/setoid_ring/ZRing_th.v b/contrib/setoid_ring/InitialRing.v index 9060428b..7df68cc0 100644 --- a/contrib/setoid_ring/ZRing_th.v +++ b/contrib/setoid_ring/InitialRing.v @@ -1,11 +1,21 @@ -Require Import Ring_th. -Require Import Pol. -Require Import Ring_tac. +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + Require Import ZArith_base. Require Import BinInt. Require Import BinNat. Require Import Setoid. - Set Implicit Arguments. +Require Import Ring_theory. +Require Import Ring_tac. +Require Import Ring_polynom. +Set Implicit Arguments. + +Import RingSyntax. (** Z is a ring and a setoid*) @@ -187,7 +197,7 @@ Section ZMORPHISM. replace Eq with (CompOpp Eq);trivial. rewrite <- Pcompare_antisym;simpl. rewrite match_compOpp. - rewrite (Radd_sym Rth). + rewrite (Radd_comm Rth). apply gen_phiZ1_add_pos_neg. rewrite (ARgen_phiPOS_add ARth); norm. Qed. @@ -255,6 +265,14 @@ Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y. rewrite H;trivial. Qed. +Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y. + Proof. + intros x y;unfold Neq_bool. + assert (H:=Ncompare_Eq_eq x y); + destruct (Ncompare x y);intros;try discriminate. + rewrite H;trivial. + Qed. + (**Same as above : definition of two,extensionaly equal, generic morphisms *) (**from N to any semi-ring*) Section NMORPHISM. @@ -326,271 +344,9 @@ Section NMORPHISM. Qed. End NMORPHISM. -(* -Section NNMORPHISM. -Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid5. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext5. exact Reqe.(Radd_ext). Qed. - Add Morphism rmul : rmul_ext5. exact Reqe.(Rmul_ext). Qed. - Add Morphism ropp : ropp_ext5. exact Reqe.(Ropp_ext). Qed. - - Lemma SReqe : sring_eq_ext radd rmul req. - case Reqe; constructor; trivial. - Qed. - - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub : rsub_ext6. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - - Lemma SRth : semi_ring_theory 0 1 radd rmul req. - case ARth; constructor; trivial. - Qed. - - Definition NN := prod N N. - Definition gen_phiNN (x:NN) := - rsub (gen_phiN rO rI radd rmul (fst x)) (gen_phiN rO rI radd rmul (snd x)). - Notation "[ x ]" := (gen_phiNN x). - - Definition NNadd (x y : NN) : NN := - (fst x + fst y, snd x + snd y)%N. - Definition NNmul (x y : NN) : NN := - (fst x * fst y + snd x * snd y, fst y * snd x + fst x * snd y)%N. - Definition NNopp (x:NN) : NN := (snd x, fst x)%N. - Definition NNsub (x y:NN) : NN := (fst x + snd y, fst y + snd x)%N. - - - Lemma gen_phiNN_add : forall x y, [NNadd x y] == [x] + [y]. - Proof. -intros. -unfold NNadd, gen_phiNN in |- *; simpl in |- *. -repeat rewrite (gen_phiN_add Rsth SReqe SRth). -norm. -add_push (- gen_phiN 0 1 radd rmul (snd x)). -rrefl. -Qed. - - Hypothesis ropp_involutive : forall x, - - x == x. - - - Lemma gen_phiNN_mult : forall x y, [NNmul x y] == [x] * [y]. - Proof. -intros. -unfold NNmul, gen_phiNN in |- *; simpl in |- *. -repeat rewrite (gen_phiN_add Rsth SReqe SRth). -repeat rewrite (gen_phiN_mult Rsth SReqe SRth). -norm. -rewrite ropp_involutive. -add_push (- (gen_phiN 0 1 radd rmul (fst y) * gen_phiN 0 1 radd rmul (snd x))). -add_push ( gen_phiN 0 1 radd rmul (snd x) * gen_phiN 0 1 radd rmul (snd y)). -rewrite (ARmul_sym ARth (gen_phiN 0 1 radd rmul (fst y)) - (gen_phiN 0 1 radd rmul (snd x))). -rrefl. -Qed. - - Lemma gen_phiNN_sub : forall x y, [NNsub x y] == [x] - [y]. -intros. -unfold NNsub, gen_phiNN; simpl. -repeat rewrite (gen_phiN_add Rsth SReqe SRth). -repeat rewrite (ARsub_def ARth). -repeat rewrite (ARopp_add ARth). -repeat rewrite (ARadd_assoc ARth). -rewrite ropp_involutive. -add_push (- gen_phiN 0 1 radd rmul (fst y)). -add_push ( - gen_phiN 0 1 radd rmul (snd x)). -rrefl. -Qed. - - -Definition NNeqbool (x y: NN) := - andb (Neq_bool (fst x) (fst y)) (Neq_bool (snd x) (snd y)). - -Lemma NNeqbool_ok0 : forall x y, - NNeqbool x y = true -> x = y. -unfold NNeqbool in |- *. -intros. -assert (Neq_bool (fst x) (fst y) = true). - generalize H. - case (Neq_bool (fst x) (fst y)); simpl in |- *; trivial. - assert (Neq_bool (snd x) (snd y) = true). - rewrite H0 in H; simpl in |- *; trivial. - generalize H0 H1. - destruct x; destruct y; simpl in |- *. - intros. - replace n with n1. - replace n2 with n0; trivial. - apply Neq_bool_ok; trivial. - symmetry in |- *. - apply Neq_bool_ok; trivial. -Qed. - - -(*gen_phiN satisfies morphism specifications*) - Lemma gen_phiNN_morph : ring_morph 0 1 radd rmul rsub ropp req - (N0,N0) (Npos xH,N0) NNadd NNmul NNsub NNopp NNeqbool gen_phiNN. - Proof. - constructor;intros;simpl; try rrefl. - apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. - rewrite (Neq_bool_ok x y);trivial. rrefl. - Qed. - -End NNMORPHISM. - -Section NSTARMORPHISM. -Variable R : Type. - Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). - Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid3. - Ltac rrefl := gen_reflexivity Rsth. - Variable Reqe : ring_eq_ext radd rmul ropp req. - Add Morphism radd : radd_ext3. exact Reqe.(Radd_ext). Qed. - Add Morphism rmul : rmul_ext3. exact Reqe.(Rmul_ext). Qed. - Add Morphism ropp : ropp_ext3. exact Reqe.(Ropp_ext). Qed. - - Lemma SReqe : sring_eq_ext radd rmul req. - case Reqe; constructor; trivial. - Qed. - - Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. - Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth. - Ltac add_push := gen_add_push radd Rsth Reqe ARth. - - Lemma SRth : semi_ring_theory 0 1 radd rmul req. - case ARth; constructor; trivial. - Qed. - - Inductive Nword : Set := - Nlast (p:positive) - | Ndigit (n:N) (w:Nword). - - Fixpoint opp_iter (n:nat) (t:R) {struct n} : R := - match n with - O => t - | S k => ropp (opp_iter k t) - end. - - Fixpoint gen_phiNword (x:Nword) (n:nat) {struct x} : R := - match x with - Nlast p => opp_iter n (gen_phi_pos p) - | Ndigit N0 w => gen_phiNword w (S n) - | Ndigit m w => radd (opp_iter n (gen_phiN m)) (gen_phiNword w (S n)) - end. - Notation "[ x ]" := (gen_phiNword x). - - Fixpoint Nwadd (x y : Nword) {struct x} : Nword := - match x, y with - Nlast p1, Nlast p2 => Nlast (p1+p2)%positive - | Nlast p1, Ndigit n w => Ndigit (Npos p1 + n)%N w - | Ndigit n w, Nlast p1 => Ndigit (n + Npos p1)%N w - | Ndigit n1 w1, Ndigit n2 w2 => Ndigit (n1+n2)%N (Nwadd w1 w2) - end. - Fixpoint Nwmulp (x:positive) (y:Nword) {struct y} : Nword := - match y with - Nlast p => Nlast (x*p)%positive - | Ndigit n w => Ndigit (Npos x * n)%N (Nwmulp x w) - end. - Definition Nwmul (x y : Nword) {struct x} : Nword := - match x with - Nlast k => Nmulp k y - | Ndigit N0 w => Ndigit N0 (Nwmul w y) - | Ndigit (Npos k) w => - Nwadd (Nwmulp k y) (Ndigit N0 (Nwmul w y)) - end. - - Definition Nwopp (x:Nword) : Nword := Ndigit N0 x. - Definition Nwsub (x y:NN) : NN := (Nwadd x (Ndigit N0 y)). - - - Lemma gen_phiNN_add : forall x y, [NNadd x y] == [x] + [y]. - Proof. -intros. -unfold NNadd, gen_phiNN in |- *; simpl in |- *. -repeat rewrite (gen_phiN_add Rsth SReqe SRth). -norm. -add_push (- gen_phiN 0 1 radd rmul (snd x)). -rrefl. -Qed. - - Lemma gen_phiNN_mult : forall x y, [NNmul x y] == [x] * [y]. - Proof. -intros. -unfold NNmul, gen_phiNN in |- *; simpl in |- *. -repeat rewrite (gen_phiN_add Rsth SReqe SRth). -repeat rewrite (gen_phiN_mult Rsth SReqe SRth). -norm. -rewrite ropp_involutive. -add_push (- (gen_phiN 0 1 radd rmul (fst y) * gen_phiN 0 1 radd rmul (snd x))). -add_push ( gen_phiN 0 1 radd rmul (snd x) * gen_phiN 0 1 radd rmul (snd y)). -rewrite (ARmul_sym ARth (gen_phiN 0 1 radd rmul (fst y)) - (gen_phiN 0 1 radd rmul (snd x))). -rrefl. -Qed. - Lemma gen_phiNN_sub : forall x y, [NNsub x y] == [x] - [y]. -intros. -unfold NNsub, gen_phiNN; simpl. -repeat rewrite (gen_phiN_add Rsth SReqe SRth). -repeat rewrite (ARsub_def ARth). -repeat rewrite (ARopp_add ARth). -repeat rewrite (ARadd_assoc ARth). -rewrite ropp_involutive. -add_push (- gen_phiN 0 1 radd rmul (fst y)). -add_push ( - gen_phiN 0 1 radd rmul (snd x)). -rrefl. -Qed. - - -Definition NNeqbool (x y: NN) := - andb (Neq_bool (fst x) (fst y)) (Neq_bool (snd x) (snd y)). - -Lemma NNeqbool_ok0 : forall x y, - NNeqbool x y = true -> x = y. -unfold NNeqbool in |- *. -intros. -assert (Neq_bool (fst x) (fst y) = true). - generalize H. - case (Neq_bool (fst x) (fst y)); simpl in |- *; trivial. - assert (Neq_bool (snd x) (snd y) = true). - rewrite H0 in H; simpl in |- *; trivial. - generalize H0 H1. - destruct x; destruct y; simpl in |- *. - intros. - replace n with n1. - replace n2 with n0; trivial. - apply Neq_bool_ok; trivial. - symmetry in |- *. - apply Neq_bool_ok; trivial. -Qed. - - -(*gen_phiN satisfies morphism specifications*) - Lemma gen_phiNN_morph : ring_morph 0 1 radd rmul rsub ropp req - (N0,N0) (Npos xH,N0) NNadd NNmul NNsub NNopp NNeqbool gen_phiNN. - Proof. - constructor;intros;simpl; try rrefl. - apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. - rewrite (Neq_bool_ok x y);trivial. rrefl. - Qed. - -End NSTARMORPHISM. -*) - - (* syntaxification of constants in an abstract ring *) + (* syntaxification of constants in an abstract ring: + the inverse of gen_phiPOS *) Ltac inv_gen_phi_pos rI add mul t := let rec inv_cst t := match t with @@ -600,7 +356,7 @@ End NSTARMORPHISM. | (mul (add rI rI) ?p) => (* 2p *) match inv_cst p with NotConstant => NotConstant - | 1%positive => NotConstant + | 1%positive => NotConstant (* 2*1 is not convertible to 2 *) | ?p => constr:(xO p) end | (add rI (mul (add rI rI) ?p)) => (* 1+2p *) @@ -613,6 +369,7 @@ End NSTARMORPHISM. end in inv_cst t. +(* The inverse of gen_phiN *) Ltac inv_gen_phiN rO rI add mul t := match t with rO => constr:0%N @@ -623,6 +380,7 @@ End NSTARMORPHISM. end end. +(* The inverse of gen_phiZ *) Ltac inv_gen_phiZ rO rI add mul opp t := match t with rO => constr:0%Z @@ -637,6 +395,7 @@ End NSTARMORPHISM. | ?p => constr:(Zpos p) end end. + (* coefs = Z (abstract ring) *) Module Zpol. @@ -646,23 +405,15 @@ Definition ring_gen_correct (Rth_ARth rSet req_th Rth) Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool (@gen_phiZ R rO rI radd rmul ropp) - (@gen_phiZ_morph R rO rI radd rmul rsub ropp req rSet req_th Rth). + (gen_phiZ_morph rSet req_th Rth). Definition ring_rw_gen_correct R rO rI radd rmul rsub ropp req rSet req_th Rth := - @Pphi_dev_ok R rO rI radd rmul rsub ropp req rSet req_th - (Rth_ARth rSet req_th Rth) - Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool - (@gen_phiZ R rO rI radd rmul ropp) - (@gen_phiZ_morph R rO rI radd rmul rsub ropp req rSet req_th Rth). - -Definition ring_rw_gen_correct' - R rO rI radd rmul rsub ropp req rSet req_th Rth := - @Pphi_dev_ok' R rO rI radd rmul rsub ropp req rSet req_th + @Pphi_dev_ok R rO rI radd rmul rsub ropp req rSet req_th (Rth_ARth rSet req_th Rth) Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool (@gen_phiZ R rO rI radd rmul ropp) - (@gen_phiZ_morph R rO rI radd rmul rsub ropp req rSet req_th Rth). + (gen_phiZ_morph rSet req_th Rth). Definition ring_gen_eq_correct R rO rI radd rmul rsub ropp Rth := @ring_gen_correct @@ -672,10 +423,6 @@ Definition ring_rw_gen_eq_correct R rO rI radd rmul rsub ropp Rth := @ring_rw_gen_correct R rO rI radd rmul rsub ropp (@eq R) (Eqsth R) (Eq_ext _ _ _) Rth. -Definition ring_rw_gen_eq_correct' R rO rI radd rmul rsub ropp Rth := - @ring_rw_gen_correct' - R rO rI radd rmul rsub ropp (@eq R) (Eqsth R) (Eq_ext _ _ _) Rth. - End Zpol. (* coefs = N (abstract semi-ring) *) @@ -688,115 +435,77 @@ Definition ring_gen_correct (SRth_ARth rSet SRth) N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool (@gen_phiN R rO rI radd rmul) - (@gen_phiN_morph R rO rI radd rmul req rSet req_th SRth). + (gen_phiN_morph rSet req_th SRth). Definition ring_rw_gen_correct R rO rI radd rmul req rSet req_th SRth := - @Pphi_dev_ok R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet - (SReqe_Reqe req_th) - (SRth_ARth rSet SRth) - N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool - (@gen_phiN R rO rI radd rmul) - (@gen_phiN_morph R rO rI radd rmul req rSet req_th SRth). - -Definition ring_rw_gen_correct' - R rO rI radd rmul req rSet req_th SRth := - @Pphi_dev_ok' R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet + @Pphi_dev_ok R rO rI radd rmul (SRsub radd) (@SRopp R) req rSet (SReqe_Reqe req_th) (SRth_ARth rSet SRth) N 0%N 1%N Nplus Nmult (SRsub Nplus) (@SRopp N) Neq_bool (@gen_phiN R rO rI radd rmul) - (@gen_phiN_morph R rO rI radd rmul req rSet req_th SRth). + (gen_phiN_morph rSet req_th SRth). Definition ring_gen_eq_correct R rO rI radd rmul SRth := @ring_gen_correct R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth. -Definition ring_rw_gen_eq_correct R rO rI radd rmul SRth := - @ring_rw_gen_correct - R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth. - Definition ring_rw_gen_eq_correct' R rO rI radd rmul SRth := - @ring_rw_gen_correct' + @ring_rw_gen_correct R rO rI radd rmul (@eq R) (Eqsth R) (Eq_s_ext _ _) SRth. End Npol. -(* Z *) - -Ltac isZcst t := - match t with - Z0 => constr:true - | Zpos ?p => isZcst p - | Zneg ?p => isZcst p - | xI ?p => isZcst p - | xO ?p => isZcst p - | xH => constr:true - | _ => constr:false - end. -Ltac Zcst t := - match isZcst t with - true => t - | _ => NotConstant - end. - -Add New Ring Zr : Zth Computational Zeqb_ok Constant Zcst. -(* N *) - -Ltac isNcst t := - match t with - N0 => constr:true - | Npos ?p => isNcst p - | xI ?p => isNcst p - | xO ?p => isNcst p - | xH => constr:true - | _ => constr:false - end. -Ltac Ncst t := - match isNcst t with - true => t - | _ => NotConstant +Ltac coerce_to_almost_ring set ext rspec := + match type of rspec with + | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec) + | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec) + | almost_ring_theory _ _ _ _ _ _ _ => rspec + | _ => fail 1 "not a valid ring theory" end. -Add New Ring Nr : Nth Computational Neq_bool_ok Constant Ncst. - -(* nat *) - -Ltac isnatcst t := - match t with - O => true - | S ?p => isnatcst p - | _ => false - end. -Ltac natcst t := - match isnatcst t with - true => t - | _ => NotConstant +Ltac coerce_to_ring_ext ext := + match type of ext with + | ring_eq_ext _ _ _ _ => ext + | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext) + | _ => fail 1 "not a valid ring_eq_ext theory" end. - Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat). - Proof. - constructor. exact plus_0_l. exact plus_comm. exact plus_assoc. - exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc. - exact mult_plus_distr_r. - Qed. - - -Unboxed Fixpoint nateq (n m:nat) {struct m} : bool := - match n, m with - | O, O => true - | S n', S m' => nateq n' m' - | _, _ => false +Ltac abstract_ring_morphism set ext rspec := + match type of rspec with + | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec) + | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec) + | almost_ring_theory _ _ _ _ _ _ _ => + fail 1 "an almost ring cannot be abstract" + | _ => fail 1 "bad ring structure" end. -Lemma nateq_ok : forall n m:nat, nateq n m = true -> n = m. -Proof. - simple induction n; simple induction m; simpl; intros; try discriminate. - trivial. - rewrite (H n1 H1). - trivial. -Qed. +Ltac ring_elements set ext rspec rk := + let arth := coerce_to_almost_ring set ext rspec in + let ext_r := coerce_to_ring_ext ext in + let morph := + match rk with + | Abstract => abstract_ring_morphism set ext rspec + | @Computational ?reqb_ok => + match type of arth with + | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ => + constr:(IDmorph rO rI add mul sub opp set _ reqb_ok) + | _ => fail 2 "ring anomaly" + end + | @Morphism ?m => m + | _ => fail 1 "ill-formed ring kind" + end in + fun f => f arth ext_r morph. + +(* Given a ring structure and the kind of morphism, + returns 2 lemmas (one for ring, and one for ring_simplify). *) + +Ltac ring_lemmas set ext rspec rk := + ring_elements set ext rspec rk + ltac:(fun arth ext_r morph => + let lemma1 := constr:(ring_correct set ext_r arth morph) in + let lemma2 := constr:(Pphi_dev_ok set ext_r arth morph) in + fun f => f arth ext_r morph lemma1 lemma2). -Add New Ring natr : natSRth Computational nateq_ok Constant natcst. diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v new file mode 100644 index 00000000..33e3cb4e --- /dev/null +++ b/contrib/setoid_ring/NArithRing.v @@ -0,0 +1,31 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Export Ring. +Require Import BinPos BinNat. +Import InitialRing. + +Set Implicit Arguments. + +Ltac isNcst t := + let t := eval hnf in t in + match t with + N0 => constr:true + | Npos ?p => isNcst p + | xI ?p => isNcst p + | xO ?p => isNcst p + | xH => constr:true + | _ => constr:false + end. +Ltac Ncst t := + match isNcst t with + true => t + | _ => NotConstant + end. + +Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]). diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v new file mode 100644 index 00000000..13896123 --- /dev/null +++ b/contrib/setoid_ring/RealField.v @@ -0,0 +1,105 @@ +Require Import Raxioms. +Require Import Rdefinitions. +Require Export Ring Field. + +Open Local Scope R_scope. + +Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)). +Proof. +constructor. + intro; apply Rplus_0_l. + exact Rplus_comm. + symmetry in |- *; apply Rplus_assoc. + intro; apply Rmult_1_l. + exact Rmult_comm. + symmetry in |- *; apply Rmult_assoc. + intros m n p. + rewrite Rmult_comm in |- *. + rewrite (Rmult_comm n p) in |- *. + rewrite (Rmult_comm m p) in |- *. + apply Rmult_plus_distr_l. + reflexivity. + exact Rplus_opp_r. +Qed. + +Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)). +Proof. +constructor. + exact RTheory. + exact R1_neq_R0. + reflexivity. + exact Rinv_l. +Qed. + +Lemma Rlt_n_Sn : forall x, x < x + 1. +Proof. +intro. +elim archimed with x; intros. +destruct H0. + apply Rlt_trans with (IZR (up x)); trivial. + replace (IZR (up x)) with (x + (IZR (up x) - x))%R. + apply Rplus_lt_compat_l; trivial. + unfold Rminus in |- *. + rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *. + rewrite <- Rplus_assoc in |- *. + rewrite Rplus_opp_r in |- *. + apply Rplus_0_l. + elim H0. + unfold Rminus in |- *. + rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *. + rewrite <- Rplus_assoc in |- *. + rewrite Rplus_opp_r in |- *. + rewrite Rplus_0_l in |- *; trivial. +Qed. + +Notation Rset := (Eqsth R). +Notation Rext := (Eq_ext Rplus Rmult Ropp). + +Lemma Rlt_0_2 : 0 < 2. +apply Rlt_trans with (0 + 1). + apply Rlt_n_Sn. + rewrite Rplus_comm in |- *. + apply Rplus_lt_compat_l. + replace 1 with (0 + 1). + apply Rlt_n_Sn. + apply Rplus_0_l. +Qed. + +Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0. +unfold Rgt in |- *. +induction x; simpl in |- *; intros. + apply Rlt_trans with (1 + 0). + rewrite Rplus_comm in |- *. + apply Rlt_n_Sn. + apply Rplus_lt_compat_l. + rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. + rewrite Rmult_comm in |- *. + apply Rmult_lt_compat_l. + apply Rlt_0_2. + trivial. + rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. + rewrite Rmult_comm in |- *. + apply Rmult_lt_compat_l. + apply Rlt_0_2. + trivial. + replace 1 with (0 + 1). + apply Rlt_n_Sn. + apply Rplus_0_l. +Qed. + + +Lemma Rgen_phiPOS_not_0 : + forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0. +red in |- *; intros. +specialize (Rgen_phiPOS x). +rewrite H in |- *; intro. +apply (Rlt_asym 0 0); trivial. +Qed. + +Lemma Zeq_bool_complete : forall x y, + InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x = + InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y -> + Zeq_bool x y = true. +Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0. + +Add Field RField : Rfield (infinite Zeq_bool_complete). diff --git a/contrib/setoid_ring/Ring.v b/contrib/setoid_ring/Ring.v new file mode 100644 index 00000000..167e026f --- /dev/null +++ b/contrib/setoid_ring/Ring.v @@ -0,0 +1,43 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import Bool. +Require Export Ring_theory. +Require Export Ring_base. +Require Export Ring_tac. + +Lemma BoolTheory : + ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)). +split; simpl in |- *. +destruct x; reflexivity. +destruct x; destruct y; reflexivity. +destruct x; destruct y; destruct z; reflexivity. +reflexivity. +destruct x; destruct y; reflexivity. +destruct x; destruct y; reflexivity. +destruct x; destruct y; destruct z; reflexivity. +reflexivity. +destruct x; reflexivity. +Qed. + +Unboxed Definition bool_eq (b1 b2:bool) := + if b1 then b2 else negb b2. + +Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2. +destruct b1; destruct b2; auto. +Qed. + +Ltac bool_cst t := + let t := eval hnf in t in + match t with + true => constr:true + | false => constr:false + | _ => NotConstant + end. + +Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]). diff --git a/contrib/setoid_ring/Ring_base.v b/contrib/setoid_ring/Ring_base.v new file mode 100644 index 00000000..95b037e3 --- /dev/null +++ b/contrib/setoid_ring/Ring_base.v @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This module gathers the necessary base to build an instance of the + ring tactic. Abstract rings need more theory, depending on + ZArith_base. *) + +Declare ML Module "newring". +Require Export Ring_theory. +Require Export Ring_tac. +Require Import InitialRing. diff --git a/contrib/setoid_ring/Ring_equiv.v b/contrib/setoid_ring/Ring_equiv.v new file mode 100644 index 00000000..945f6c68 --- /dev/null +++ b/contrib/setoid_ring/Ring_equiv.v @@ -0,0 +1,74 @@ +Require Import Setoid_ring_theory. +Require Import LegacyRing_theory. +Require Import Ring_theory. + +Set Implicit Arguments. + +Section Old2New. + +Variable A : Type. + +Variable Aplus : A -> A -> A. +Variable Amult : A -> A -> A. +Variable Aone : A. +Variable Azero : A. +Variable Aopp : A -> A. +Variable Aeq : A -> A -> bool. +Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq. + +Let Aminus := fun x y => Aplus x (Aopp y). + +Lemma ring_equiv1 : + ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)). +Proof. +destruct R. +split; eauto. +Qed. + +End Old2New. + +Section New2OldRing. + Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)). + + Variable reqb : R -> R -> bool. + Variable reqb_ok : forall x y, reqb x y = true -> x = y. + + Lemma ring_equiv2 : + Ring_Theory radd rmul rI rO ropp reqb. +Proof. +elim Rth; intros; constructor; eauto. +intros. +apply reqb_ok. +destruct (reqb x y); trivial; intros. +elim H. +Qed. + + Definition default_eqb : R -> R -> bool := fun x y => false. + Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y. +Proof. +discriminate 1. +Qed. + +End New2OldRing. + +Section New2OldSemiRing. + Variable R : Type. + Variable (rO rI : R) (radd rmul: R->R->R). + Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)). + + Variable reqb : R -> R -> bool. + Variable reqb_ok : forall x y, reqb x y = true -> x = y. + + Lemma sring_equiv2 : + Semi_Ring_Theory radd rmul rI rO reqb. +Proof. +elim SRth; intros; constructor; eauto. +intros. +apply reqb_ok. +destruct (reqb x y); trivial; intros. +elim H. +Qed. + +End New2OldSemiRing. diff --git a/contrib/setoid_ring/Pol.v b/contrib/setoid_ring/Ring_polynom.v index 2bf2574f..7317ab21 100644 --- a/contrib/setoid_ring/Pol.v +++ b/contrib/setoid_ring/Ring_polynom.v @@ -1,9 +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 *) +(************************************************************************) + Set Implicit Arguments. Require Import Setoid. -Require Export BinList. +Require Import BinList. Require Import BinPos. Require Import BinInt. -Require Export Ring_th. +Require Export Ring_theory. + +Import RingSyntax. Section MakeRingPol. @@ -313,7 +323,13 @@ Section MakeRingPol. end. Notation "P ** P'" := (Pmul P P'). - (** Evaluation of a polynomial towards R *) + + (** Monomial **) + + Inductive Mon: Set := + mon0: Mon + | zmon: positive -> Mon -> Mon + | vmon: positive -> Mon -> Mon. Fixpoint pow (x:R) (i:positive) {struct i}: R := match i with @@ -322,6 +338,96 @@ Section MakeRingPol. | xI i => let p := pow x i in x * p * p end. + Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R := + match M with + mon0 => rI + | zmon j M1 => Mphi (jump j l) M1 + | vmon i M1 => + let x := hd 0 l in + let xi := pow x i in + (Mphi (tail l) M1) * xi + end. + + Definition zmon_pred j M := + match j with xH => M | _ => zmon (Ppred j) M end. + + Definition mkZmon j M := + match M with mon0 => mon0 | _ => zmon j M end. + + Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol := + match P, M with + _, mon0 => (Pc cO, P) + | Pc _, _ => (P, Pc cO) + | Pinj j1 P1, zmon j2 M1 => + match (j1 ?= j2) Eq with + Eq => let (R,S) := MFactor P1 M1 in + (mkPinj j1 R, mkPinj j1 S) + | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in + (mkPinj j1 R, mkPinj j1 S) + | Gt => (P, Pc cO) + end + | Pinj _ _, vmon _ _ => (P, Pc cO) + | PX P1 i Q1, zmon j M1 => + let M2 := zmon_pred j M1 in + let (R1, S1) := MFactor P1 M in + let (R2, S2) := MFactor Q1 M2 in + (mkPX R1 i R2, mkPX S1 i S2) + | PX P1 i Q1, vmon j M1 => + match (i ?= j) Eq with + Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in + (mkPX R1 i Q1, S1) + | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in + (mkPX R1 i Q1, S1) + | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in + (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO)) + end + end. + + Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol := + let (Q1,R1) := MFactor P1 M1 in + match R1 with + (Pc c) => if c ?=! cO then None + else Some (Padd Q1 (Pmul P2 R1)) + | _ => Some (Padd Q1 (Pmul P2 R1)) + end. + + Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol := + match POneSubst P1 M1 P2 with + Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end + | _ => P1 + end. + + Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol := + match POneSubst P1 M1 P2 with + Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end + | _ => None + end. + + Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: + Pol := + match LM1 with + cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n + | _ => P1 + end. + + Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol := + match LM1 with + cons (M1,P2) LM2 => + match PNSubst P1 M1 P2 n with + Some P3 => Some (PSubstL1 P3 LM2 n) + | None => PSubstL P1 LM2 n + end + | _ => None + end. + + Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol := + match PSubstL P1 LM1 n with + Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end + | _ => P1 + end. + + (** Evaluation of a polynomial towards R *) + Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R := match P with | Pc c => [c] @@ -329,7 +435,7 @@ Section MakeRingPol. | PX P i Q => let x := hd 0 l in let xi := pow x i in - (Pphi l P) * xi + (Pphi (tl l) Q) + (Pphi l P) * xi + (Pphi (tail l) Q) end. Reserved Notation "P @ l " (at level 10, no associativity). @@ -418,7 +524,7 @@ Section MakeRingPol. Qed. Lemma mkPX_ok : forall l P i Q, - (mkPX P i Q)@l == P@l*(pow (hd 0 l) i) + Q@(tl l). + (mkPX P i Q)@l == P@l*(pow (hd 0 l) i) + Q@(tail l). Proof. intros l P i Q;unfold mkPX. destruct P;try (simpl;rrefl). @@ -500,7 +606,7 @@ Section MakeRingPol. induction P';simpl;intros;Esimpl2. generalize P p l;clear P p l. induction P;simpl;intros. - Esimpl2;apply (ARadd_sym ARth). + Esimpl2;apply (ARadd_comm ARth). assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). rewrite H;Esimpl. rewrite IHP';rrefl. rewrite H;Esimpl. rewrite IHP';Esimpl. @@ -519,33 +625,33 @@ Section MakeRingPol. rsimpl;add_push (P'1@l * (pow (hd 0 l) p));rrefl. rewrite IHP'2;simpl. rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl. add_push (P @ (tl l));rrefl. + rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl. assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. rewrite IHP'1;rewrite IHP'2;rsimpl. - add_push (P3 @ (tl l));rewrite H;rrefl. + add_push (P3 @ (tail l));rewrite H;rrefl. rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. rewrite H;rewrite Pplus_comm. rewrite pow_Pplus;rsimpl. - add_push (P3 @ (tl l));rrefl. + add_push (P3 @ (tail l));rrefl. assert (forall P k l, (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow (hd 0 l) k). - induction P;simpl;intros;try apply (ARadd_sym ARth). - destruct p2;simpl;try apply (ARadd_sym ARth). - rewrite jump_Pdouble_minus_one;apply (ARadd_sym ARth). + induction P;simpl;intros;try apply (ARadd_comm ARth). + destruct p2;simpl;try apply (ARadd_comm ARth). + rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth). assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. - rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tl l0));rrefl. + rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. rewrite IHP'1;simpl;Esimpl. rewrite H1;rewrite Pplus_comm. rewrite pow_Pplus;simpl;Esimpl. - add_push (P5 @ (tl l0));rrefl. + add_push (P5 @ (tail l0));rrefl. rewrite IHP1;rewrite H1;rewrite Pplus_comm. rewrite pow_Pplus;simpl;rsimpl. - add_push (P5 @ (tl l0));rrefl. + add_push (P5 @ (tail l0));rrefl. rewrite H0;rsimpl. - add_push (P3 @ (tl l)). + add_push (P3 @ (tail l)). rewrite H;rewrite Pplus_comm. rewrite IHP'2;rewrite pow_Pplus;rsimpl. - add_push (P3 @ (tl l));rrefl. + add_push (P3 @ (tail l));rrefl. Qed. Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. @@ -553,7 +659,7 @@ Section MakeRingPol. induction P';simpl;intros;Esimpl2;trivial. generalize P p l;clear P p l. induction P;simpl;intros. - Esimpl2;apply (ARadd_sym ARth). + Esimpl2;apply (ARadd_comm ARth). assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). rewrite H;Esimpl. rewrite IHP';rsimpl. rewrite H;Esimpl. rewrite IHP';Esimpl. @@ -569,35 +675,35 @@ Section MakeRingPol. repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. destruct p0;simpl;Esimpl2. rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow (hd 0 l) p));trivial. - add_push (P @ (jump p0 (jump p0 (tl l))));rrefl. + add_push (P @ (jump p0 (jump p0 (tail l))));rrefl. rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl. add_push (- (P'1 @ l * pow (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl;add_push (P @ (tl l));rrefl. + rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl. assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. rewrite IHP'1; rewrite IHP'2;rsimpl. - add_push (P3 @ (tl l));rewrite H;rrefl. + add_push (P3 @ (tail l));rewrite H;rrefl. rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. rewrite H;rewrite Pplus_comm. rewrite pow_Pplus;rsimpl. - add_push (P3 @ (tl l));rrefl. + add_push (P3 @ (tail l));rrefl. assert (forall P k l, (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow (hd 0 l) k). induction P;simpl;intros. - rewrite Popp_ok;rsimpl;apply (ARadd_sym ARth);trivial. + rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. destruct p2;simpl;rewrite Popp_ok;rsimpl. - apply (ARadd_sym ARth);trivial. - rewrite jump_Pdouble_minus_one;apply (ARadd_sym ARth);trivial. - apply (ARadd_sym ARth);trivial. + apply (ARadd_comm ARth);trivial. + rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial. + apply (ARadd_comm ARth);trivial. assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. - rewrite IHP'1;rsimpl;add_push (P5 @ (tl l0));rewrite H1;rrefl. + rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl. rewrite IHP'1;rewrite H1;rewrite Pplus_comm. rewrite pow_Pplus;simpl;Esimpl. - add_push (P5 @ (tl l0));rrefl. + add_push (P5 @ (tail l0));rrefl. rewrite IHP1;rewrite H1;rewrite Pplus_comm. rewrite pow_Pplus;simpl;rsimpl. - add_push (P5 @ (tl l0));rrefl. + add_push (P5 @ (tail l0));rrefl. rewrite H0;rsimpl. - rewrite IHP'2;rsimpl;add_push (P3 @ (tl l)). + rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)). rewrite H;rewrite Pplus_comm. rewrite pow_Pplus;rsimpl. Qed. @@ -609,7 +715,7 @@ Section MakeRingPol. (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l). Proof. induction P;simpl;intros. - Esimpl2;apply (ARmul_sym ARth). + Esimpl2;apply (ARmul_comm ARth). assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. rewrite H1; rewrite H;rrefl. rewrite H1; rewrite H. @@ -639,13 +745,198 @@ Section MakeRingPol. Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. Proof. destruct P;simpl;intros. - Esimpl2;apply (ARmul_sym ARth). + Esimpl2;apply (ARmul_comm ARth). rewrite (PmulI_ok P (Pmul_aux_ok P)). - apply (ARmul_sym ARth). + apply (ARmul_comm ARth). rewrite Padd_ok; Esimpl2. rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. rewrite Pmul_aux_ok;mul_push (P' @ l). - rewrite (ARmul_sym ARth (P' @ l));rrefl. + rewrite (ARmul_comm ARth (P' @ l));rrefl. + Qed. + + + Lemma mkZmon_ok: forall M j l, + Mphi l (mkZmon j M) == Mphi l (zmon j M). + intros M j l; case M; simpl; intros; rsimpl. + Qed. + + Lemma Mphi_ok: forall P M l, + let (Q,R) := MFactor P M in + P@l == Q@l + (Mphi l M) * (R@l). + Proof. + intros P; elim P; simpl; auto; clear P. + intros c M l; case M; simpl; auto; try intro p; try intro m; + try rewrite (morph0 CRmorph); rsimpl. + + intros i P Hrec M l; case M; simpl; clear M. + rewrite (morph0 CRmorph); rsimpl. + intros j M. + case_eq ((i ?= j) Eq); intros He; simpl. + rewrite (Pcompare_Eq_eq _ _ He). + generalize (Hrec M (jump j l)); case (MFactor P M); + simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. + generalize (Hrec (zmon (j -i) M) (jump i l)); + case (MFactor P (zmon (j -i) M)); simpl. + intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. + rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). + rewrite Pplus_comm; rewrite jump_Pplus; auto. + rewrite (morph0 CRmorph); rsimpl. + intros P2 m; rewrite (morph0 CRmorph); rsimpl. + + intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto. + rewrite (morph0 CRmorph); rsimpl. + intros j M1. + generalize (Hrec1 (zmon j M1) l); + case (MFactor P2 (zmon j M1)). + intros R1 S1 H1. + generalize (Hrec2 (zmon_pred j M1) (List.tail l)); + case (MFactor Q2 (zmon_pred j M1)); simpl. + intros R2 S2 H2; rewrite H1; rewrite H2. + repeat rewrite mkPX_ok; simpl. + rsimpl. + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + case j; simpl; auto; try intros j1; rsimpl. + rewrite jump_Pdouble_minus_one; rsimpl. + intros j M1. + case_eq ((i ?= j) Eq); intros He; simpl. + rewrite (Pcompare_Eq_eq _ _ He). + generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + rewrite mkZmon_ok. + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + generalize (Hrec1 (vmon (j - i) M1) l); + case (MFactor P2 (vmon (j - i) M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. + rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + apply rmul_ext; rsimpl. + rewrite <- pow_Pplus. + rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. + generalize (Hrec1 (mkZmon 1 M1) l); + case (MFactor P2 (mkZmon 1 M1)); + simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. + rewrite H; rsimpl. + rewrite mkPX_ok; rsimpl. + repeat (rewrite <-(ARadd_assoc ARth)). + apply radd_ext; rsimpl. + rewrite (ARadd_comm ARth); rsimpl. + apply radd_ext; rsimpl. + rewrite mkZmon_ok. + repeat (rewrite <-(ARmul_assoc ARth)). + apply rmul_ext; rsimpl. + rewrite (ARmul_comm ARth); rsimpl. + rewrite mkPX_ok; simpl; rsimpl. + rewrite (morph0 CRmorph); rsimpl. + repeat (rewrite <-(ARmul_assoc ARth)). + rewrite (ARmul_comm ARth (Q3@l)); rsimpl. + apply rmul_ext; rsimpl. + rewrite <- pow_Pplus. + rewrite (Pplus_minus _ _ He); rsimpl. + Qed. + + + Lemma POneSubst_ok: forall P1 M1 P2 P3 l, + POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. + intros P2 M1 P3 P4 l; unfold POneSubst. + generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. + intros Q1 R1; case R1. + intros c H; rewrite H. + generalize (morph_eq CRmorph c cO); + case (c ?=! cO); simpl; auto. + intros H1 H2; rewrite H1; auto; rsimpl. + discriminate. + intros _ H1 H2; injection H1; intros; subst. + rewrite H2; rsimpl. + rewrite Padd_ok; rewrite Pmul_ok; rsimpl. + intros i P5 H; rewrite H. + intros HH H1; injection HH; intros; subst; rsimpl. + rewrite Padd_ok; rewrite Pmul_ok; rewrite H1; rsimpl. + intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. + injection H2; intros; subst; rsimpl. + rewrite Padd_ok; rewrite Pmul_ok; rsimpl. + Qed. + + + Lemma PNSubst1_ok: forall n P1 M1 P2 l, + Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. + Proof. + intros n; elim n; simpl; auto. + intros P2 M1 P3 l H. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. + intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl. + intros n1 Hrec P2 M1 P3 l H. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. + intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl. + Qed. + + Lemma PNSubst_ok: forall n P1 M1 P2 l P3, + PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. + Proof. + intros n P2 M1 P3 l P4; unfold PNSubst. + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + case (POneSubst P2 M1 P3); [idtac | intros; discriminate]. + intros P5 H1; case n; try (intros; discriminate). + intros n1 H2; injection H2; intros; subst. + rewrite <- PNSubst1_ok; auto. + Qed. + + Fixpoint MPcond (LM1: list (Mon * Pol)) (l: list R) {struct LM1} : Prop := + match LM1 with + cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l) + | _ => True + end. + + Lemma PSubstL1_ok: forall n LM1 P1 l, + MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l. + Proof. + intros n LM1; elim LM1; simpl; auto. + intros; rsimpl. + intros (M2,P2) LM2 Hrec P3 l [H H1]. + rewrite <- Hrec; auto. + apply PNSubst1_ok; auto. + Qed. + + Lemma PSubstL_ok: forall n LM1 P1 P2 l, + PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. + Proof. + intros n LM1; elim LM1; simpl; auto. + intros; discriminate. + intros (M2,P2) LM2 Hrec P3 P4 l. + generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n). + intros P5 H0 H1 [H2 H3]; injection H1; intros; subst. + rewrite <- PSubstL1_ok; auto. + intros l1 H [H1 H2]; auto. + Qed. + + Lemma PNSubstL_ok: forall m n LM1 P1 l, + MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. + Proof. + intros m; elim m; simpl; auto. + intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); + case (PSubstL P2 LM1 n); intros; rsimpl; auto. + intros m1 Hrec n LM1 P2 l H. + generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l); + case (PSubstL P2 LM1 n); intros; rsimpl; auto. + rewrite <- Hrec; auto. Qed. (** Definition of polynomial expressions *) @@ -714,7 +1005,7 @@ Section MakeRingPol. | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) | |- context [(norm (PEopp ?pe))@?l] => rewrite (norm_PEopp l pe) - end;Esimpl2;try rrefl;try apply (ARadd_sym ARth). + end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). Lemma norm_ok : forall l pe, PEeval l pe == (norm pe)@l. Proof. @@ -757,12 +1048,12 @@ Section MakeRingPol. Fixpoint add_mult_dev (rP:R) (P:Pol) (fv lm:list R) {struct P} : R := (* rP + P@l * lm *) match P with - | Pc c => if c ?=! cI then mkadd_mult rP (rev lm) - else mkadd_mult rP (cons [c] (rev lm)) + | Pc c => if c ?=! cI then mkadd_mult rP (rev' lm) + else mkadd_mult rP (cons [c] (rev' lm)) | Pinj j Q => add_mult_dev rP Q (jump j fv) lm | PX P i Q => let rP := add_mult_dev rP P fv (powl i (hd 0 fv) lm) in - if Q ?== P0 then rP else add_mult_dev rP Q (tl fv) lm + if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) lm end. Definition mkmult1 lm := @@ -774,14 +1065,14 @@ Section MakeRingPol. Fixpoint mult_dev (P:Pol) (fv lm : list R) {struct P} : R := (* P@l * lm *) match P with - | Pc c => if c ?=! cI then mkmult1 (rev lm) else mkmult [c] (rev lm) + | Pc c => if c ?=! cI then mkmult1 (rev' lm) else mkmult [c] (rev' lm) | Pinj j Q => mult_dev Q (jump j fv) lm | PX P i Q => let rP := mult_dev P fv (powl i (hd 0 fv) lm) in - if Q ?== P0 then rP else add_mult_dev rP Q (tl fv) lm + if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) lm end. - Definition Pphi_dev fv P := mult_dev P fv (nil R). + Definition Pphi_dev fv P := mult_dev P fv nil. Add Morphism mkmult : mkmult_ext. intros r r0 eqr l;generalize l r r0 eqr;clear l r r0 eqr; @@ -808,21 +1099,21 @@ Section MakeRingPol. Qed. Lemma mkmult_rev_append : forall lm l r, - mkmult r (rev_append l lm) == mkmult (mkmult r l) lm. + mkmult r (rev_append lm l) == mkmult (mkmult r l) lm. Proof. induction lm; simpl in |- *; intros. rrefl. rewrite IHlm; simpl in |- *. - repeat rewrite <- (ARmul_sym ARth a); rewrite <- mul_mkmult. + repeat rewrite <- (ARmul_comm ARth a); rewrite <- mul_mkmult. rrefl. Qed. Lemma powl_mkmult_rev : forall p r x lm, - mkmult r (rev (powl p x lm)) == mkmult (pow x p * r) (rev lm). + mkmult r (rev' (powl p x lm)) == mkmult (pow x p * r) (rev' lm). Proof. induction p;simpl;intros. repeat rewrite IHp. - unfold rev;simpl. + unfold rev';simpl. repeat rewrite mkmult_rev_append. simpl. setoid_replace (pow x p * (pow x p * r) * x) @@ -831,18 +1122,18 @@ Section MakeRingPol. repeat rewrite IHp. setoid_replace (pow x p * (pow x p * r) ) with (pow x p * pow x p * r);Esimpl. - unfold rev;simpl. repeat rewrite mkmult_rev_append;simpl. - rewrite (ARmul_sym ARth);rrefl. + unfold rev';simpl. repeat rewrite mkmult_rev_append;simpl. + rewrite (ARmul_comm ARth);rrefl. Qed. Lemma Pphi_add_mult_dev : forall P rP fv lm, - rP + P@fv * mkmult1 (rev lm) == add_mult_dev rP P fv lm. + rP + P@fv * mkmult1 (rev' lm) == add_mult_dev rP P fv lm. Proof. induction P;simpl;intros. assert (H := (morph_eq CRmorph) c cI). destruct (c ?=! cI). rewrite (H (refl_equal true));rewrite (morph1 CRmorph);Esimpl. - destruct (rev lm);Esimpl;rrefl. + destruct (rev' lm);Esimpl;rrefl. rewrite mkmult1_mkmult;rrefl. apply IHP. replace (match P3 with @@ -865,7 +1156,7 @@ Section MakeRingPol. Qed. Lemma Pphi_mult_dev : forall P fv lm, - P@fv * mkmult1 (rev lm) == mult_dev P fv lm. + P@fv * mkmult1 (rev' lm) == mult_dev P fv lm. Proof. induction P;simpl;intros. assert (H := (morph_eq CRmorph) c cI). @@ -898,298 +1189,44 @@ Section MakeRingPol. rewrite <- Pphi_mult_dev;simpl;Esimpl. Qed. - Lemma Pphi_dev_ok : forall l pe, PEeval l pe == Pphi_dev l (norm pe). + Lemma Pphi_dev_gen_ok : forall l pe, PEeval l pe == Pphi_dev l (norm pe). Proof. intros l pe;rewrite <- Pphi_Pphi_dev;apply norm_ok. Qed. - Lemma Pphi_dev_ok' : + Lemma Pphi_dev_ok : forall l pe npe, norm pe = npe -> PEeval l pe == Pphi_dev l npe. Proof. - intros l pe npe npe_eq; subst npe; apply Pphi_dev_ok. - Qed. - -(* The same but building a PExpr *) -(* - Fixpoint Pmkmult (r:PExpr) (lm:list PExpr) {struct lm}: PExpr := - match lm with - | nil => r - | cons h t => Pmkmult (PEmul r h) t - end. - - Definition Pmkadd_mult rP lm := - match lm with - | nil => PEadd rP (PEc cI) - | cons h t => PEadd rP (Pmkmult h t) - end. - - Fixpoint Ppowl (i:positive) (x:PExpr) (l:list PExpr) {struct i}: list PExpr := - match i with - | xH => cons x l - | xO i => Ppowl i x (Ppowl i x l) - | xI i => Ppowl i x (Ppowl i x (cons x l)) - end. - - Fixpoint Padd_mult_dev - (rP:PExpr) (P:Pol) (fv lm:list PExpr) {struct P} : PExpr := - (* rP + P@l * lm *) - match P with - | Pc c => if c ?=! cI then Pmkadd_mult rP (rev lm) - else Pmkadd_mult rP (cons [PEc c] (rev lm)) - | Pinj j Q => Padd_mult_dev rP Q (jump j fv) lm - | PX P i Q => - let rP := Padd_mult_dev rP P fv (Ppowl i (hd P0 fv) lm) in - if Q ?== P0 then rP else Padd_mult_dev rP Q (tl fv) lm - end. - - Definition Pmkmult1 lm := - match lm with - | nil => PEc cI - | cons h t => Pmkmult h t - end. - - Fixpoint Pmult_dev (P:Pol) (fv lm : list PExpr) {struct P} : PExpr := - (* P@l * lm *) - match P with - | Pc c => if c ?=! cI then Pmkmult1 (rev lm) else Pmkmult [PEc c] (rev lm) - | Pinj j Q => Pmult_dev Q (jump j fv) lm - | PX P i Q => - let rP := Pmult_dev P fv (Ppowl i (hd (PEc r0) fv) lm) in - if Q ?== P0 then rP else Padd_mult_dev rP Q (tl fv) lm - end. - - Definition Pphi_dev2 fv P := Pmult_dev P fv (nil PExpr). - -... -*) - (************************************************) - (* avec des parentheses mais un peu plus efficace *) - - - (************************************************** - - Fixpoint pow_mult (i:positive) (x r:R){struct i}:R := - match i with - | xH => r * x - | xO i => pow_mult i x (pow_mult i x r) - | xI i => pow_mult i x (pow_mult i x (r * x)) - end. - - Definition pow_dev i x := - match i with - | xH => x - | xO i => pow_mult (Pdouble_minus_one i) x x - | xI i => pow_mult (xO i) x x - end. - - Lemma pow_mult_pow : forall i x r, pow_mult i x r == pow x i * r. - Proof. - induction i;simpl;intros. - rewrite (IHi x (pow_mult i x (r * x)));rewrite (IHi x (r*x));rsimpl. - mul_push x;rrefl. - rewrite (IHi x (pow_mult i x r));rewrite (IHi x r);rsimpl. - apply ARth.(ARmul_sym). - Qed. - - Lemma pow_dev_pow : forall p x, pow_dev p x == pow x p. - Proof. - destruct p;simpl;intros. - rewrite (pow_mult_pow p x (pow_mult p x x)). - rewrite (pow_mult_pow p x x);rsimpl;mul_push x;rrefl. - rewrite (pow_mult_pow (Pdouble_minus_one p) x x). - rewrite (ARth.(ARmul_sym) (pow x (Pdouble_minus_one p)) x). - rewrite <- (pow_Psucc x (Pdouble_minus_one p)). - rewrite Psucc_o_double_minus_one_eq_xO;simpl; rrefl. - rrefl. - Qed. - - Fixpoint Pphi_dev (fv:list R) (P:Pol) {struct P} : R := - match P with - | Pc c => [c] - | Pinj j Q => Pphi_dev (jump j fv) Q - | PX P i Q => - let rP := mult_dev P fv (pow_dev i (hd 0 fv)) in - add_dev rP Q (tl fv) - end + intros l pe npe npe_eq; subst npe; apply Pphi_dev_gen_ok. + Qed. - with add_dev (ra:R) (P:Pol) (fv:list R) {struct P} : R := - match P with - | Pc c => if c ?=! cO then ra else ra + [c] - | Pinj j Q => add_dev ra Q (jump j fv) - | PX P i Q => - let ra := add_mult_dev ra P fv (pow_dev i (hd 0 fv)) in - add_dev ra Q (tl fv) - end - - with mult_dev (P:Pol) (fv:list R) (rm:R) {struct P} : R := - match P with - | Pc c => if c ?=! cI then rm else [c]*rm - | Pinj j Q => mult_dev Q (jump j fv) rm - | PX P i Q => - let ra := mult_dev P fv (pow_mult i (hd 0 fv) rm) in - add_mult_dev ra Q (tl fv) rm - end - - with add_mult_dev (ra:R) (P:Pol) (fv:list R) (rm:R) {struct P} : R := - match P with - | Pc c => if c ?=! cO then ra else ra + [c]*rm - | Pinj j Q => add_mult_dev ra Q (jump j fv) rm - | PX P i Q => - let rmP := pow_mult i (hd 0 fv) rm in - let raP := add_mult_dev ra P fv rmP in - add_mult_dev raP Q (tl fv) rm - end. - - Lemma Pphi_add_mult_dev : forall P ra fv rm, - add_mult_dev ra P fv rm == ra + P@fv * rm. - Proof. - induction P;simpl;intros. - assert (H := CRmorph.(morph_eq) c cO). - destruct (c ?=! cO). - rewrite (H (refl_equal true));rewrite CRmorph.(morph0);Esimpl. - rrefl. - apply IHP. - rewrite (IHP2 (add_mult_dev ra P2 fv (pow_mult p (hd 0 fv) rm)) (tl fv) rm). - rewrite (IHP1 ra fv (pow_mult p (hd 0 fv) rm)). - rewrite (pow_mult_pow p (hd 0 fv) rm);rsimpl. - Qed. - - Lemma Pphi_add_dev : forall P ra fv, add_dev ra P fv == ra + P@fv. - Proof. - induction P;simpl;intros. - assert (H := CRmorph.(morph_eq) c cO). - destruct (c ?=! cO). - rewrite (H (refl_equal true));rewrite CRmorph.(morph0);Esimpl. - rrefl. - apply IHP. - rewrite (IHP2 (add_mult_dev ra P2 fv (pow_dev p (hd 0 fv))) (tl fv)). - rewrite (Pphi_add_mult_dev P2 ra fv (pow_dev p (hd 0 fv))). - rewrite (pow_dev_pow p (hd 0 fv));rsimpl. - Qed. + Fixpoint MPcond_dev (LM1: list (Mon * Pol)) (l: list R) {struct LM1} : Prop := + match LM1 with + cons (M1,P2) LM2 => (Mphi l M1 == Pphi_dev l P2) /\ (MPcond_dev LM2 l) + | _ => True + end. - Lemma Pphi_mult_dev : forall P fv rm, mult_dev P fv rm == P@fv * rm. - Proof. - induction P;simpl;intros. - assert (H := CRmorph.(morph_eq) c cI). - destruct (c ?=! cI). - rewrite (H (refl_equal true));rewrite CRmorph.(morph1);Esimpl. - rrefl. - apply IHP. - rewrite (Pphi_add_mult_dev P3 - (mult_dev P2 fv (pow_mult p (hd 0 fv) rm)) (tl fv) rm). - rewrite (IHP1 fv (pow_mult p (hd 0 fv) rm)). - rewrite (pow_mult_pow p (hd 0 fv) rm);rsimpl. - Qed. + Fixpoint MPcond_map (LM1: list (Mon * PExpr)): list (Mon * Pol) := + match LM1 with + cons (M1,P2) LM2 => cons (M1, norm P2) (MPcond_map LM2) + | _ => nil + end. - Lemma Pphi_Pphi_dev : forall P fv, P@fv == Pphi_dev fv P. + Lemma MP_cond_dev_imp_MP_cond: forall LM1 l, + MPcond_dev LM1 l -> MPcond LM1 l. Proof. - induction P;simpl;intros. - rrefl. trivial. - rewrite (Pphi_add_dev P3 (mult_dev P2 fv (pow_dev p (hd 0 fv))) (tl fv)). - rewrite (Pphi_mult_dev P2 fv (pow_dev p (hd 0 fv))). - rewrite (pow_dev_pow p (hd 0 fv));rsimpl. + intros LM1; elim LM1; simpl; auto. + intros (M2,P2) LM2 Hrec l [H1 H2]; split; auto. + rewrite H1; rewrite Pphi_Pphi_dev; rsimpl. Qed. - Lemma Pphi_dev_ok : forall l pe, PEeval l pe == Pphi_dev l (norm pe). - Proof. - intros l pe;rewrite <- (Pphi_Pphi_dev (norm pe) l);apply norm_ok. + Lemma PNSubstL_dev_ok: forall m n lm pe l, + let LM := MPcond_map lm in + MPcond_dev LM l -> PEeval l pe == Pphi_dev l (PNSubstL (norm pe) LM m n). + intros m n lm p3 l LM H. + rewrite <- Pphi_Pphi_dev; rewrite <- PNSubstL_ok; auto. + apply MP_cond_dev_imp_MP_cond; auto. + rewrite Pphi_Pphi_dev; apply Pphi_dev_ok; auto. Qed. - Ltac Trev l := - let rec rev_append rev l := - match l with - | (nil _) => constr:(rev) - | (cons ?h ?t) => let rev := constr:(cons h rev) in rev_append rev t - end in - rev_append (nil R) l. - - Ltac TPphi_dev add mul := - let tl l := match l with (cons ?h ?t) => constr:(t) end in - let rec jump j l := - match j with - | xH => tl l - | (xO ?j) => let l := jump j l in jump j l - | (xI ?j) => let t := tl l in let l := jump j l in jump j l - end in - let rec pow_mult i x r := - match i with - | xH => constr:(mul r x) - | (xO ?i) => let r := pow_mult i x r in pow_mult i x r - | (xI ?i) => - let r := constr:(mul r x) in - let r := pow_mult i x r in - pow_mult i x r - end in - let pow_dev i x := - match i with - | xH => x - | (xO ?i) => - let i := eval compute in (Pdouble_minus_one i) in pow_mult i x x - | (xI ?i) => pow_mult (xO i) x x - end in - let rec add_mult_dev ra P fv rm := - match P with - | (Pc ?c) => - match eval compute in (c ?=! cO) with - | true => constr:ra - | _ => let rc := eval compute in [c] in constr:(add ra (mul rc rm)) - end - | (Pinj ?j ?Q) => - let fv := jump j fv in add_mult_dev ra Q fv rm - | (PX ?P ?i ?Q) => - match fv with - | (cons ?hd ?tl) => - let rmP := pow_mult i hd rm in - let raP := add_mult_dev ra P fv rmP in - add_mult_dev raP Q tl rm - end - end in - let rec mult_dev P fv rm := - match P with - | (Pc ?c) => - match eval compute in (c ?=! cI) with - | true => constr:rm - | false => let rc := eval compute in [c] in constr:(mul rc rm) - end - | (Pinj ?j ?Q) => let fv := jump j fv in mult_dev Q fv rm - | (PX ?P ?i ?Q) => - match fv with - | (cons ?hd ?tl) => - let rmP := pow_mult i hd rm in - let ra := mult_dev P fv rmP in - add_mult_dev ra Q tl rm - end - end in - let rec add_dev ra P fv := - match P with - | (Pc ?c) => - match eval compute in (c ?=! cO) with - | true => ra - | false => let rc := eval compute in [c] in constr:(add ra rc) - end - | (Pinj ?j ?Q) => let fv := jump j fv in add_dev ra Q fv - | (PX ?P ?i ?Q) => - match fv with - | (cons ?hd ?tl) => - let rmP := pow_dev i hd in - let ra := add_mult_dev ra P fv rmP in - add_dev ra Q tl - end - end in - let rec Pphi_dev fv P := - match P with - | (Pc ?c) => eval compute in [c] - | (Pinj ?j ?Q) => let fv := jump j fv in Pphi_dev fv Q - | (PX ?P ?i ?Q) => - match fv with - | (cons ?hd ?tl) => - let rm := pow_dev i hd in - let rP := mult_dev P fv rm in - add_dev rP Q tl - end - end in - Pphi_dev. - - **************************************************************) - End MakeRingPol. diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v index 6c3f87a5..95efde7f 100644 --- a/contrib/setoid_ring/Ring_tac.v +++ b/contrib/setoid_ring/Ring_tac.v @@ -1,76 +1,73 @@ Set Implicit Arguments. Require Import Setoid. -Require Import BinList. Require Import BinPos. -Require Import Pol. +Require Import Ring_polynom. +Require Import BinList. Declare ML Module "newring". -(* Some Tactics *) - -Ltac compute_assertion id t := - let t' := eval compute in t in - (assert (id : t = t'); [exact_no_check (refl_equal t')|idtac]). -Ltac compute_assertion' id id' t := - let t' := eval compute in t in +(* adds a definition id' on the normal form of t and an hypothesis id + stating that t = id' (tries to produces a proof as small as possible) *) +Ltac compute_assertion id id' t := + let t' := eval vm_compute in t in (pose (id' := t'); assert (id : t = id'); [exact_no_check (refl_equal id')|idtac]). -Ltac compute_replace' id t := - let t' := eval compute in t in - (replace t with t' in id; [idtac|exact_no_check (refl_equal t')]). +(********************************************************************) +(* Tacticals to build reflexive tactics *) -Ltac bin_list_fold_right fcons fnil l := - match l with - | (cons ?x ?tl) => fcons x ltac:(bin_list_fold_right fcons fnil tl) - | (nil _) => fnil +Ltac OnEquation req := + match goal with + | |- req ?lhs ?rhs => (fun f => f lhs rhs) + | _ => fail 1 "Goal is not an equation (of expected equality)" end. -Ltac bin_list_fold_left fcons fnil l := - match l with - | (cons ?x ?tl) => bin_list_fold_left fcons ltac:(fcons x fnil) tl - | (nil _) => fnil - end. -Ltac bin_list_iter f l := - match l with - | (cons ?x ?tl) => f x; bin_list_iter f tl - | (nil _) => idtac +Ltac OnMainSubgoal H ty := + match ty with + | _ -> ?ty' => + let subtac := OnMainSubgoal H ty' in + fun tac => lapply H; [clear H; intro H; subtac tac | idtac] + | _ => (fun tac => tac) end. - -(** A tactic that reverses a list *) -Ltac Trev R l := - let rec rev_append rev l := - match l with - | (nil _) => constr:(rev) - | (cons ?h ?t) => let rev := constr:(cons h rev) in rev_append rev t - end in - rev_append (nil R) l. -(* to avoid conflicts with Coq booleans*) +Ltac ApplyLemmaAndSimpl tac lemma pe:= + let npe := fresh "ast_nf" in + let H := fresh "eq_nf" in + let Heq := fresh "thm" in + let npe_spec := + match type of (lemma pe) with + forall npe, ?npe_spec = npe -> _ => npe_spec + | _ => fail 1 "ApplyLemmaAndSimpl: cannot find norm expression" + end in + (compute_assertion H npe npe_spec; + (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma"); + clear H; + OnMainSubgoal Heq ltac:(type of Heq) + ltac:(tac Heq; rewrite Heq; clear Heq npe)). + +(* General scheme of reflexive tactics using of correctness lemma + that involves normalisation of one expression *) +Ltac ReflexiveRewriteTactic FV_tac SYN_tac SIMPL_tac lemma2 req rl := + let R := match type of req with ?R -> _ => R end in + (* build the atom list *) + let fv := list_fold_left FV_tac (@List.nil R) rl in + (* some type-checking to avoid late errors *) + (check_fv fv; + (* rewrite steps *) + list_iter + ltac:(fun r => + let ast := SYN_tac r fv in + try ApplyLemmaAndSimpl SIMPL_tac (lemma2 fv) ast) + rl). + +(********************************************************) + +(* An object to return when an expression is not recognized as a constant *) Definition NotConstant := false. - -Ltac IN a l := - match l with - | (cons a ?l) => true - | (cons _ ?l) => IN a l - | (nil _) => false - end. - -Ltac AddFv a l := - match (IN a l) with - | true => l - | _ => constr:(cons a l) - end. - -Ltac Find_at a l := - match l with - | (nil _) => fail 1 "ring anomaly" - | (cons a _) => constr:1%positive - | (cons _ ?l) => let p := Find_at a l in eval compute in (Psucc p) - end. +(* Building the atom list of a ring expression *) Ltac FV Cst add mul sub opp t fv := let rec TFV t fv := match Cst t with @@ -80,13 +77,13 @@ Ltac FV Cst add mul sub opp t fv := | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv) | (opp ?t1) => TFV t1 fv - | _ => AddFv t fv + | _ => AddFvTail t fv end | _ => fv - end + end in TFV t fv. - (* syntaxification *) + (* syntaxification of ring expressions *) Ltac mkPolexpr C Cst radd rmul rsub ropp t fv := let rec mkP t := match Cst t with @@ -111,644 +108,53 @@ Ltac FV Cst add mul sub opp t fv := in mkP t. (* ring tactics *) -Ltac Make_ring_rewrite_step lemma pe:= - let npe := fresh "npe" in - let H := fresh "eq_npe" in - let Heq := fresh "ring_thm" in - let npe_spec := - match type of (lemma pe) with - forall (npe:_), ?npe_spec = npe -> _ => npe_spec - | _ => fail 1 "cannot find norm expression" - end in - (compute_assertion' H npe npe_spec; - assert (Heq:=lemma _ _ H); clear H; - protect_fv in Heq; - (rewrite Heq; clear Heq npe) || clear npe). - - -Ltac Make_ring_rw_list Cst_tac lemma req rl := - match type of lemma with - forall (l:list ?R) (pe:PExpr ?C) (npe:Pol ?C), - _ = npe -> - req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ => - let mkFV := FV Cst_tac add mul sub opp in - let mkPol := mkPolexpr C Cst_tac add mul sub opp in - (* build the atom list *) - let rfv := bin_list_fold_left mkFV (nil R) rl in - let fv := Trev R rfv in - (* rewrite *) - bin_list_iter - ltac:(fun r => - let pe := mkPol r fv in - Make_ring_rewrite_step (lemma fv) pe) - rl - | _ => fail 1 "bad lemma" - end. - -Ltac Make_ring_rw Cst_tac lemma req r := - Make_ring_rw_list Cst_tac lemma req (cons r (nil _)). - - (* Building the generic tactic *) - - Ltac Make_ring_tac Cst_tac lemma1 lemma2 req := - match type of lemma2 with - forall (l:list ?R) (pe:PExpr ?C) (npe:Pol ?C), - _ = npe -> - req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ => - match goal with - | |- req ?r1 ?r2 => - let mkFV := FV Cst_tac add mul sub opp in - let mkPol := mkPolexpr C Cst_tac add mul sub opp in - let rfv := mkFV (add r1 r2) (nil R) in - let fv := Trev R rfv in - let pe1 := mkPol r1 fv in - let pe2 := mkPol r2 fv in - ((apply (lemma1 fv pe1 pe2); - vm_compute; - exact (refl_equal true)) || - (Make_ring_rewrite_step (lemma2 fv) pe1; - Make_ring_rewrite_step (lemma2 fv) pe2)) - | _ => fail 1 "goal is not an equality from a declared ring" - end - end. - - -(* coefs belong to the same type as the target ring (concrete ring) *) -Definition ring_id_correct - R rO rI radd rmul rsub ropp req rSet req_th ARth reqb reqb_ok := - @ring_correct R rO rI radd rmul rsub ropp req rSet req_th ARth - R rO rI radd rmul rsub ropp reqb - (@IDphi R) - (@IDmorph R rO rI radd rmul rsub ropp req rSet reqb reqb_ok). - -Definition ring_rw_id_correct - R rO rI radd rmul rsub ropp req rSet req_th ARth reqb reqb_ok := - @Pphi_dev_ok R rO rI radd rmul rsub ropp req rSet req_th ARth - R rO rI radd rmul rsub ropp reqb - (@IDphi R) - (@IDmorph R rO rI radd rmul rsub ropp req rSet reqb reqb_ok). - -Definition ring_rw_id_correct' - R rO rI radd rmul rsub ropp req rSet req_th ARth reqb reqb_ok := - @Pphi_dev_ok' R rO rI radd rmul rsub ropp req rSet req_th ARth - R rO rI radd rmul rsub ropp reqb - (@IDphi R) - (@IDmorph R rO rI radd rmul rsub ropp req rSet reqb reqb_ok). - -Definition ring_id_eq_correct R rO rI radd rmul rsub ropp ARth reqb reqb_ok := - @ring_id_correct R rO rI radd rmul rsub ropp (@eq R) - (Eqsth R) (Eq_ext _ _ _) ARth reqb reqb_ok. - -Definition ring_rw_id_eq_correct - R rO rI radd rmul rsub ropp ARth reqb reqb_ok := - @ring_rw_id_correct R rO rI radd rmul rsub ropp (@eq R) - (Eqsth R) (Eq_ext _ _ _) ARth reqb reqb_ok. - -Definition ring_rw_id_eq_correct' - R rO rI radd rmul rsub ropp ARth reqb reqb_ok := - @ring_rw_id_correct' R rO rI radd rmul rsub ropp (@eq R) - (Eqsth R) (Eq_ext _ _ _) ARth reqb reqb_ok. - -(* -Require Import ZArith. -Require Import Setoid. -Require Import Ring_tac. -Import BinList. -Import Ring_th. -Open Scope Z_scope. - -Add New Ring Zr : (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) - Computational Zeqb_ok - Constant Zcst. - -Goal forall a b, (a+b*2)*(a+b*2)=1. -intros. - setoid ring ((a + b * 2) * (a + b * 2)). - - Make_ring_rw_list Zcst - (ring_rw_id_correct' (Eqsth Z) (Eq_ext _ _ _) - (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) - (eq (A:=Z)) - (cons ((a+b)*(a+b)) (nil _)). - - -Goal forall a b, (a+b)*(a+b)=1. -intros. -Ltac zringl := - Make_ring_rw3_list ltac:(inv_gen_phiZ 0 1 Zplus Zmult Zopp) - (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) - (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) - (eq (A:=Z)) -(BinList.cons ((a+b)*(a+b)) (BinList.nil _)). - -Open Scope Z_scope. - -let Cst_tac := inv_gen_phiZ 0 1 Zplus Zmult Zopp in -let lemma := - constr:(ring_rw_id_correct' (Eqsth Z) (Eq_ext _ _ _) - (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) in -let req := constr:(eq (A:=Z)) in -let rl := constr:(cons ((a+b)*(a+b)) (nil _)) in -Make_ring_rw_list Cst_tac lemma req rl. - -let fv := constr:(cons a (cons b (nil _))) in -let pe := - constr:(PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) in -Make_ring_rewrite_step (lemma fv) pe. - - - - -OK - -Lemma L0 : - forall (l : list Z) (pe : PExpr Z) pe', - pe' = norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe -> - PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe = - Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe'. -intros; subst pe'. -apply - (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) - (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok). -Qed. -Lemma L0' : - forall (l : list Z) (pe : PExpr Z) pe', - norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe = pe' -> - PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe = - Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe'. -intros; subst pe'. -apply - (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) - (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok). -Qed. - -pose (pe:=PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))). -compute_assertion ipattern:H (norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe). -let fv := constr:(cons a (cons b (nil _))) in -assert (Heq := L0 fv _ (sym_equal H)); clear H. - protect_fv' in Heq. - rewrite Heq; clear Heq; clear pe. - - -MIEUX (mais taille preuve = taille de pe + taille de nf(pe)... ): - - -Lemma L : - forall (l : list Z) (pe : PExpr Z) pe' (x y :Z), - pe' = norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe -> - x = PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe -> - y = Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe' -> - x=y. -intros; subst x y pe'. -apply - (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) - (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok). -Qed. -Lemma L' : - forall (l : list Z) (pe : PExpr Z) pe' (x y :Z), - Peq Zeq_bool pe' (norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool pe) = true -> - x = PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) l pe -> - y = Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) l pe' -> - forall (P:Z->Type), P y -> P x. -intros. - rewrite L with (2:=H0) (3:=H1); trivial. -apply (Peq_ok (Eqsth Z) (Eq_ext _ _ _) - (IDmorph 0 1 Zplus Zminus Zmult Zopp (Eqsth Z) Zeq_bool Zeqb_ok) ). - - (IDmorph (Eqsth Z) (Eq_ext _ _ _) Zeqb_ok). - - - (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth)). -Qed. - -eapply L' - with (x:=(a+b)*(a+b)) - (pe:=PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) - (l:=cons a (cons b (nil Z)));[compute;reflexivity|reflexivity|idtac|idtac];norm_evars;[protect_fv';reflexivity|idtac];norm_evars. - - - - - -set (x:=a). -set (x0:=b). -set (fv:=cons x (cons x0 (nil Z))). -let fv:=constr:(cons a (cons b (nil Z))) in -let lemma := constr : (ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) - (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) in -let pe := - constr : (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) in -assert (Heq := lemma fv pe). -set (npe:=norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool - (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2)))). -fold npe in Heq. -move npe after fv. -let fv' := eval red in fv in -compute in npe. -subst npe. -let fv' := eval red in fv in -compute_without_globals_of (fv',Zplus,0,1,Zmult,Zopp,Zminus) in Heq. -rewrite Heq. -clear Heq fv; subst x x0. - - -simpl in Heq. -unfold Pphi_dev in Heq. -unfold mult_dev in Heq. -unfold P0, Peq in *. -unfold Zeq_bool at 3, Zcompare, Pcompare in Heq. -unfold fv, hd, tl in Heq. -unfold powl, rev, rev_append in Heq. -unfold mkmult1 in Heq. -unfold mkmult in Heq. -unfold add_mult_dev in |- *. -unfold add_mult_dev at 2 in Heq. -unfold P0, Peq at 1 in Heq. -unfold Zeq_bool at 2 3 4 5 6, Zcompare, Pcompare in Heq. -unfold hd, powl, rev, rev_append in Heq. -unfold mkadd_mult in Heq. -unfold mkmult in Heq. -unfold add_mult_dev in Heq. -unfold P0, Peq in Heq. -unfold Zeq_bool, Zcompare, Pcompare in Heq. -unfold hd,powl, rev,rev_append in Heq. -unfold mkadd_mult in Heq. -unfold mkmult in Heq. -unfold IDphi in Heq. - - fv := cons x (cons x0 (nil Z)) - PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2)) - Heq : PEeval 0 Zplus Zmult Zminus Zopp (IDphi (R:=Z)) fv - (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2))) = - Pphi_dev 0 1 Zplus Zmult 0 1 Zeq_bool (IDphi (R:=Z)) fv - (norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool - (PEmul (PEadd (PEX Z 1) (PEX Z 2)) (PEadd (PEX Z 1) (PEX Z 2)))) - - -let Cst_tac := inv_gen_phiZ 0 1 Zplus Zmult Zopp in -let lemma := - constr:(ring_rw_id_correct (Eqsth Z) (Eq_ext _ _ _) - (Rth_ARth (Eqsth Z) (Eq_ext _ _ _) Zth) Zeq_bool Zeqb_ok) in -let req := constr:(eq (A:=Z)) in -let rl := constr:(BinList.cons ((a+b)*(a+b)) (BinList.nil _)) in - match type of lemma with - forall (l:list ?R) (pe:PExpr ?C), - req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ => - Constant natcst. - - -Require Import Setoid. -Open Scope nat_scope. - -Require Import Ring_th. -Require Import Arith. - -Add New Ring natr : (SRth_ARth (Eqsth nat) natSRth) - Computational nateq_ok - Constant natcst. - - -Require Import Rbase. -Open Scope R_scope. - - Lemma Rth : ring_theory 0 1 Rplus Rmult Rminus Ropp (@eq R). - Proof. - constructor. exact Rplus_0_l. exact Rplus_comm. - intros;symmetry;apply Rplus_assoc. - exact Rmult_1_l. exact Rmult_comm. - intros;symmetry;apply Rmult_assoc. - exact Rmult_plus_distr_r. trivial. exact Rplus_opp_r. - Qed. - -Add New Ring Rr : Rth Abstract. - -Goal forall a b, (a+b*10)*(a+b*10)=1. -intros. - -Module Zring. - Import Zpol. - Import BinPos. - Import BinInt. - -Ltac is_PCst p := - match p with - | xH => true - | (xO ?p') => is_PCst p' - | (xI ?p') => is_PCst p' - | _ => false - end. - -Ltac ZCst t := - match t with - | Z0 => constr:t - | (Zpos ?p) => - match (is_PCst p) with - | false => NotConstant - | _ => constr:t - end - | (Zneg ?p) => - match (is_PCst p) with - | false => NotConstant - | _ => constr:t - end - | _ => NotConstant - end. - -Ltac zring := - Make_ring_tac ZCst - (Zpol.ring_gen_eq_correct Zth) (Zpol.ring_rw_gen_eq_correct Zth) (@eq Z). - -Ltac zrewrite := - Make_ring_rw3 ZCst (Zpol.ring_rw_gen_eq_correct Zth) (@eq Z). - -Ltac zrewrite_list := - Make_ring_rw3_list ZCst (Zpol.ring_rw_gen_eq_correct Zth) (@eq Z). - -End Zring. -*) - - - -(* -(*** Intanciation for Z*) -Require Import ZArith. -Open Scope Z_scope. - -Module Zring. - Let R := Z. - Let rO := 0. - Let rI := 1. - Let radd := Zplus. - Let rmul := Zmult. - Let rsub := Zminus. - Let ropp := Zopp. - Let Rth := Zth. - Let reqb := Zeq_bool. - Let req_morph := Zeqb_ok. - - (* CE_Entries *) - Let C := R. - Let cO := rO. - Let cI := rI. - Let cadd := radd. - Let cmul := rmul. - Let csub := rsub. - Let copp := ropp. - Let req := (@eq R). - Let ceqb := reqb. - Let phi := @IDphi R. - Let Rsth : Setoid_Theory R req := Eqsth R. - Let Reqe : ring_eq_ext radd rmul ropp req := - (@Eq_ext R radd rmul ropp). - Let ARth : almost_ring_theory rO rI radd rmul rsub ropp req := - (@Rth_ARth R rO rI radd rmul rsub ropp req Rsth Reqe Rth). - Let CRmorph : ring_morph rO rI radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi := - (@IDmorph R rO rI radd rmul rsub ropp req Rsth reqb req_morph). - - Definition Peq := Eval red in (Pol.Peq ceqb). - Definition mkPinj := Eval red in (@Pol.mkPinj C). - Definition mkPX := - Eval red; - change (Pol.Peq ceqb) with Peq; - change (@Pol.mkPinj Z) with mkPinj in - (Pol.mkPX cO ceqb). - - Definition P0 := Eval red in (Pol.P0 cO). - Definition P1 := Eval red in (Pol.P1 cI). - - Definition X := - Eval red; change (Pol.P0 cO) with P0; change (Pol.P1 cI) with P1 in - (Pol.X cO cI). - - Definition mkX := - Eval red; change (Pol.X cO cI) with X in - (mkX cO cI). - - Definition PaddC - Definition PaddI - Definition PaddX - - Definition Padd := - Eval red in - - (Pol.Padd cO cadd ceqb) - - Definition PmulC - Definition PmulI - Definition Pmul_aux - Definition Pmul - - Definition PsubC - Definition PsubI - Definition PsubX - Definition Psub - - - - Definition norm := - Eval red; - change (Pol.Padd cO cadd ceqb) with Padd; - change (Pol.Pmul cO cI cadd cmul ceqb) with Pmul; - change (Pol.Psub cO cadd csub copp ceqb) with Psub; - change (Pol.Popp copp) with Psub; - - in - (Pol.norm cO cI cadd cmul csub copp ceqb). - - - -End Zring. - -Ltac is_PCst p := - match p with - | xH => true - | (xO ?p') => is_PCst p' - | (xI ?p') => is_PCst p' - | _ => false - end. - -Ltac ZCst t := - match t with - | Z0 => constr:t - | (Zpos ?p) => - match (is_PCst p) with - | false => NotConstant - | _ => t - end - | (Zneg ?p) => - match (is_PCst p) with - | false => NotConstant - | _ => t - end - | _ => NotConstant - end. - -Ltac zring := - Zring.Make_ring_tac Zplus Zmult Zminus Zopp (@eq Z) ZCst. - -Ltac zrewrite := - Zring.Make_ring_rw3 Zplus Zmult Zminus Zopp ZCst. -*) - -(* -(* Instanciation for Bool *) -Require Import Bool. - -Module BCE. - Definition R := bool. - Definition rO := false. - Definition rI := true. - Definition radd := xorb. - Definition rmul := andb. - Definition rsub := xorb. - Definition ropp b:bool := b. - Lemma Rth : ring_theory rO rI radd rmul rsub ropp (@eq bool). - Proof. - constructor. - exact false_xorb. - exact xorb_comm. - intros; symmetry in |- *; apply xorb_assoc. - exact andb_true_b. - exact andb_comm. - exact andb_assoc. - destruct x; destruct y; destruct z; reflexivity. - intros; reflexivity. - exact xorb_nilpotent. - Qed. - - Definition reqb := eqb. - Definition req_morph := eqb_prop. -End BCE. - -Module BEntries := CE_Entries BCE. - -Module Bring := MakeRingPol BEntries. - -Ltac BCst t := - match t with - | true => true - | false => false - | _ => NotConstant - end. - -Ltac bring := - Bring.Make_ring_tac xorb andb xorb (fun b:bool => b) (@eq bool) BCst. - -Ltac brewrite := - Zring.Make_ring_rw3 Zplus Zmult Zminus Zopp ZCst. -*) - -(*Module Rring. - -(* Instanciation for R *) -Require Import Rbase. -Open Scope R_scope. - - Lemma Rth : ring_theory 0 1 Rplus Rmult Rminus Ropp (@eq R). - Proof. - constructor. exact Rplus_0_l. exact Rplus_comm. - intros;symmetry;apply Rplus_assoc. - exact Rmult_1_l. exact Rmult_comm. - intros;symmetry;apply Rmult_assoc. - exact Rmult_plus_distr_r. trivial. exact Rplus_opp_r. - Qed. - -Ltac RCst := inv_gen_phiZ 0 1 Rplus Rmul Ropp. - -Ltac rring := - Make_ring_tac RCst - (Zpol.ring_gen_eq_correct Rth) (Zpol.ring_rw_gen_eq_correct Rth) (@eq R). - -Ltac rrewrite := - Make_ring_rw3 RCst (Zpol.ring_rw_gen_eq_correct Rth) (@eq R). - -Ltac rrewrite_list := - Make_ring_rw3_list RCst (Zpol.ring_rw_gen_eq_correct Rth) (@eq R). - -End Rring. -*) -(************************) -(* -(* Instanciation for N *) -Require Import NArith. -Open Scope N_scope. - -Module NCSE. - Definition R := N. - Definition rO := 0. - Definition rI := 1. - Definition radd := Nplus. - Definition rmul := Nmult. - Definition SRth := Nth. - Definition reqb := Neq_bool. - Definition req_morph := Neq_bool_ok. -End NCSE. - -Module NEntries := CSE_Entries NCSE. - -Module Nring := MakeRingPol NEntries. - -Ltac NCst := inv_gen_phiN 0 1 Nplus Nmult. - -Ltac nring := - Nring.Make_ring_tac Nplus Nmult (@SRsub N Nplus) (@SRopp N) (@eq N) NCst. - -Ltac nrewrite := - Nring.Make_ring_rw3 Nplus Nmult (@SRsub N Nplus) (@SRopp N) NCst. - -(* Instanciation for nat *) -Open Scope nat_scope. - -Module NatASE. - Definition R := nat. - Definition rO := 0. - Definition rI := 1. - Definition radd := plus. - Definition rmul := mult. - Lemma SRth : semi_ring_theory O (S O) plus mult (@eq nat). - Proof. - constructor. exact plus_0_l. exact plus_comm. exact plus_assoc. - exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc. - exact mult_plus_distr_r. - Qed. -End NatASE. - -Module NatEntries := ASE_Entries NatASE. + Ltac Ring Cst_tac lemma1 req := + let Make_tac := + match type of lemma1 with + | forall (l:list ?R) (pe1 pe2:PExpr ?C), + _ = true -> + req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe1) _ => + let mkFV := FV Cst_tac add mul sub opp in + let mkPol := mkPolexpr C Cst_tac add mul sub opp in + fun f => f R mkFV mkPol + | _ => fail 1 "ring anomaly: bad correctness lemma" + end in + let Main r1 r2 R mkFV mkPol := + let fv := mkFV r1 (@List.nil R) in + let fv := mkFV r2 fv in + check_fv fv; + (let pe1 := mkPol r1 fv in + let pe2 := mkPol r2 fv in + apply (lemma1 fv pe1 pe2) || fail "typing error while applying ring"; + vm_compute; + exact (refl_equal true) || fail "not a valid ring equation") in + Make_tac ltac:(OnEquation req Main). + +Ltac Ring_simplify Cst_tac lemma2 req rl := + let Make_tac := + match type of lemma2 with + forall (l:list ?R) (pe:PExpr ?C) (npe:Pol ?C), + _ = npe -> + req (PEeval ?rO ?add ?mul ?sub ?opp ?phi l pe) _ => + let mkFV := FV Cst_tac add mul sub opp in + let mkPol := mkPolexpr C Cst_tac add mul sub opp in + let simpl_ring H := protect_fv "ring" in H in + (fun tac => tac mkFV mkPol simpl_ring lemma2 req rl) + | _ => fail 1 "ring anomaly: bad correctness lemma" + end in + Make_tac ReflexiveRewriteTactic. -Module Natring := MakeRingPol NatEntries. -Ltac natCst t := - match t with - | O => N0 - | (S ?n) => - match (natCst n) with - | NotConstant => NotConstant - | ?p => constr:(Nsucc p) - end - | _ => NotConstant - end. - -Ltac natring := - Natring.Make_ring_tac plus mult (@SRsub nat plus) (@SRopp nat) (@eq nat) natCst. +Tactic Notation (at level 0) "ring" := + ring_lookup + (fun req sth ext morph arth cst_tac lemma1 lemma2 pre post rl => + pre(); Ring cst_tac lemma1 req). -Ltac natrewrite := - Natring.Make_ring_rw3 plus mult (@SRsub nat plus) (@SRopp nat) natCst. - -(* Generic tactic, checks the type of the terms and applies the -suitable instanciation*) - -Ltac newring := - match goal with - | |- (?r1 = ?r2) => - match (type of r1) with - | Z => zring - | R => rring - | bool => bring - | N => nring - | nat => natring - end - end. +Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := + ring_lookup + (fun req sth ext morph arth cst_tac lemma1 lemma2 pre post rl => + pre(); Ring_simplify cst_tac lemma2 req rl; post()) rl. -*) +(* A simple macro tactic to be prefered to ring_simplify *) +Ltac ring_replace t1 t2 := replace t1 with t2 by ring. diff --git a/contrib/setoid_ring/Ring_th.v b/contrib/setoid_ring/Ring_theory.v index 9583dd2d..2f7378eb 100644 --- a/contrib/setoid_ring/Ring_th.v +++ b/contrib/setoid_ring/Ring_theory.v @@ -1,7 +1,15 @@ -Require Import Setoid. - Set Implicit Arguments. +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +Require Import Setoid. +Set Implicit Arguments. +Module RingSyntax. Reserved Notation "x ?=! y" (at level 70, no associativity). Reserved Notation "x +! y " (at level 50, left associativity). Reserved Notation "x -! y" (at level 50, left associativity). @@ -11,14 +19,13 @@ Reserved Notation "-! x" (at level 35, right associativity). Reserved Notation "[ x ]" (at level 1, no associativity). Reserved Notation "x ?== y" (at level 70, no associativity). -Reserved Notation "x ++ y " (at level 50, left associativity). Reserved Notation "x -- y" (at level 50, left associativity). Reserved Notation "x ** y" (at level 40, left associativity). Reserved Notation "-- x" (at level 35, right associativity). Reserved Notation "x == y" (at level 70, no associativity). - - +End RingSyntax. +Import RingSyntax. Section DEFINITIONS. Variable R : Type. @@ -32,24 +39,24 @@ Section DEFINITIONS. (** Semi Ring *) Record semi_ring_theory : Prop := mk_srt { SRadd_0_l : forall n, 0 + n == n; - SRadd_sym : forall n m, n + m == m + n ; + SRadd_comm : forall n m, n + m == m + n ; SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; SRmul_1_l : forall n, 1*n == n; SRmul_0_l : forall n, 0*n == 0; - SRmul_sym : forall n m, n*m == m*n; + SRmul_comm : forall n m, n*m == m*n; SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p; SRdistr_l : forall n m p, (n + m)*p == n*p + m*p }. (** Almost Ring *) -(*Almost ring are no ring : Ropp_def is missi**) +(*Almost ring are no ring : Ropp_def is missing **) Record almost_ring_theory : Prop := mk_art { ARadd_0_l : forall x, 0 + x == x; - ARadd_sym : forall x y, x + y == y + x; + ARadd_comm : forall x y, x + y == y + x; ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z; ARmul_1_l : forall x, 1 * x == x; ARmul_0_l : forall x, 0 * x == 0; - ARmul_sym : forall x y, x * y == y * x; + ARmul_comm : forall x y, x * y == y * x; ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z; ARdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); ARopp_mul_l : forall x y, -(x * y) == -x * y; @@ -60,10 +67,10 @@ Section DEFINITIONS. (** Ring *) Record ring_theory : Prop := mk_rt { Radd_0_l : forall x, 0 + x == x; - Radd_sym : forall x y, x + y == y + x; + Radd_comm : forall x y, x + y == y + x; Radd_assoc : forall x y z, x + (y + z) == (x + y) + z; Rmul_1_l : forall x, 1 * x == x; - Rmul_sym : forall x y, x * y == y * x; + Rmul_comm : forall x y, x * y == y * x; Rmul_assoc : forall x y z, x * (y * z) == (x * y) * z; Rdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z); Rsub_def : forall x y, x - y == x + -y; @@ -193,9 +200,9 @@ Section ALMOST_RING. Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req. Proof (mk_art 0 1 radd rmul SRsub SRopp req - (SRadd_0_l SRth) (SRadd_sym SRth) (SRadd_assoc SRth) + (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth) (SRmul_1_l SRth) (SRmul_0_l SRth) - (SRmul_sym SRth) (SRmul_assoc SRth) (SRdistr_l SRth) + (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth) SRopp_mul_l SRopp_add SRsub_def). (** Identity morphism for semi-ring equipped with their almost-ring structure*) @@ -246,17 +253,17 @@ Section ALMOST_RING. rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth). rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). - rewrite (Radd_sym Rth); rewrite (Radd_0_l Rth);sreflexivity. + rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity. Qed. Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y. Proof. intros x y;rewrite <-(Radd_0_l Rth (- x * y)). - rewrite (Radd_sym Rth). + rewrite (Radd_comm Rth). rewrite <-(Ropp_def Rth (x*y)). rewrite (Radd_assoc Rth). rewrite <- (Rdistr_l Rth). - rewrite (Rth.(Radd_sym) (-x));rewrite (Ropp_def Rth). + rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth). rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity. Qed. @@ -266,17 +273,17 @@ Section ALMOST_RING. rewrite <- ((Ropp_def Rth) x). rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))). rewrite <- ((Ropp_def Rth) y). - rewrite ((Radd_sym Rth) x). - rewrite ((Radd_sym Rth) y). + rewrite ((Radd_comm Rth) x). + rewrite ((Radd_comm Rth) y). rewrite <- ((Radd_assoc Rth) (-y)). rewrite <- ((Radd_assoc Rth) (- x)). rewrite ((Radd_assoc Rth) y). - rewrite ((Radd_sym Rth) y). + rewrite ((Radd_comm Rth) y). rewrite <- ((Radd_assoc Rth) (- x)). rewrite ((Radd_assoc Rth) y). - rewrite ((Radd_sym Rth) y);rewrite (Ropp_def Rth). - rewrite ((Radd_sym Rth) (-x) 0);rewrite (Radd_0_l Rth). - apply (Radd_sym Rth). + rewrite ((Radd_comm Rth) y);rewrite (Ropp_def Rth). + rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth). + apply (Radd_comm Rth). Qed. Lemma Ropp_opp : forall x, - -x == x. @@ -284,13 +291,13 @@ Section ALMOST_RING. intros x; rewrite <- (Radd_0_l Rth (- -x)). rewrite <- (Ropp_def Rth x). rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). - rewrite ((Radd_sym Rth) x);apply (Radd_0_l Rth). + rewrite ((Radd_comm Rth) x);apply (Radd_0_l Rth). Qed. Lemma Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Proof - (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_sym Rth) (Radd_assoc Rth) - (Rmul_1_l Rth) Rmul_0_l (Rmul_sym Rth) (Rmul_assoc Rth) (Rdistr_l Rth) + (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth) + (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth) Ropp_mul_l Ropp_add (Rsub_def Rth)). (** Every semi morphism between two rings is a morphism*) @@ -315,12 +322,12 @@ Section ALMOST_RING. Proof. intros x;rewrite <- (Rth.(Radd_0_l) [-!x]). rewrite <- ((Ropp_def Rth) [x]). - rewrite ((Radd_sym Rth) [x]). + rewrite ((Radd_comm Rth) [x]). rewrite <- (Radd_assoc Rth). rewrite <- (Smorph_add Smorph). rewrite (Ropp_def Cth). rewrite (Smorph0 Smorph). - rewrite (Radd_sym Rth (-[x])). + rewrite (Radd_comm Rth (-[x])). apply (Radd_0_l Rth);sreflexivity. Qed. @@ -343,6 +350,12 @@ Section ALMOST_RING. (** Usefull lemmas on almost ring *) Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. + Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req. +Proof. +elim ARth; intros. +constructor; trivial. +Qed. + Lemma ARsub_ext : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. Proof. @@ -358,15 +371,15 @@ Section ALMOST_RING. Ltac mrewrite := repeat first [ rewrite (ARadd_0_l ARth) - | rewrite <- ((ARadd_sym ARth) 0) + | rewrite <- ((ARadd_comm ARth) 0) | rewrite (ARmul_1_l ARth) - | rewrite <- ((ARmul_sym ARth) 1) + | rewrite <- ((ARmul_comm ARth) 1) | rewrite (ARmul_0_l ARth) - | rewrite <- ((ARmul_sym ARth) 0) + | rewrite <- ((ARmul_comm ARth) 0) | rewrite (ARdistr_l ARth) | sreflexivity | match goal with - | |- context [?z * (?x + ?y)] => rewrite ((ARmul_sym ARth) z (x+y)) + | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) end]. Lemma ARadd_0_r : forall x, (x + 0) == x. @@ -381,37 +394,37 @@ Section ALMOST_RING. Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y. Proof. intros;mrewrite. - repeat rewrite (ARth.(ARmul_sym) z);sreflexivity. + repeat rewrite (ARth.(ARmul_comm) z);sreflexivity. Qed. Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x. Proof. intros;rewrite <-(ARth.(ARadd_assoc) x). - rewrite (ARth.(ARadd_sym) x);sreflexivity. + rewrite (ARth.(ARadd_comm) x);sreflexivity. Qed. Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x. Proof. intros; repeat rewrite <- (ARadd_assoc ARth); - rewrite ((ARadd_sym ARth) x); sreflexivity. + rewrite ((ARadd_comm ARth) x); sreflexivity. Qed. Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x. Proof. intros;rewrite <-((ARmul_assoc ARth) x). - rewrite ((ARmul_sym ARth) x);sreflexivity. + rewrite ((ARmul_comm ARth) x);sreflexivity. Qed. Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x. Proof. intros; repeat rewrite <- (ARmul_assoc ARth); - rewrite ((ARmul_sym ARth) x); sreflexivity. + rewrite ((ARmul_comm ARth) x); sreflexivity. Qed. Lemma ARopp_mul_r : forall x y, - (x * y) == x * -y. Proof. - intros;rewrite ((ARmul_sym ARth) x y); - rewrite (ARopp_mul_l ARth); apply (ARmul_sym ARth). + intros;rewrite ((ARmul_comm ARth) x y); + rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth). Qed. Lemma ARopp_zero : -0 == 0. @@ -420,8 +433,37 @@ Section ALMOST_RING. repeat rewrite ARmul_0_r; sreflexivity. Qed. + + End ALMOST_RING. +Section AddRing. + + Variable R : Type. + Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). + Variable req : R -> R -> Prop. + +Inductive ring_kind : Type := +| Abstract +| Computational + (R:Type) + (req : R -> R -> Prop) + (reqb : R -> R -> bool) + (_ : forall x y, (reqb x y) = true -> req x y) +| Morphism + (R : Type) + (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R) + (req : R -> R -> Prop) + (C : Type) + (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C) + (ceqb : C->C->bool) + phi + (_ : ring_morph rO rI radd rmul rsub ropp req + cO cI cadd cmul csub copp ceqb phi). + +End AddRing. + + (** Some simplification tactics*) Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth). diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v new file mode 100644 index 00000000..4f47fff0 --- /dev/null +++ b/contrib/setoid_ring/ZArithRing.v @@ -0,0 +1,33 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Export Ring. +Require Import ZArith_base. +Import InitialRing. + +Set Implicit Arguments. + +Ltac isZcst t := + let t := eval hnf in t in + match t with + Z0 => constr:true + | Zpos ?p => isZcst p + | Zneg ?p => isZcst p + | xI ?p => isZcst p + | xO ?p => isZcst p + | xH => constr:true + | _ => constr:false + end. +Ltac Zcst t := + match isZcst t with + true => t + | _ => NotConstant + end. + +Add Ring Zr : Zth + (decidable Zeqb_ok, constants [Zcst], preprocess [unfold Zsucc]). diff --git a/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4 index bc2bcb0c..daa2fedb 100644 --- a/contrib/setoid_ring/newring.ml4 +++ b/contrib/setoid_ring/newring.ml4 @@ -8,7 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: newring.ml4 8878 2006-05-30 16:44:25Z herbelin $ i*) +(*i $Id: newring.ml4 9302 2006-10-27 21:21:17Z barras $ i*) open Pp open Util @@ -16,6 +16,7 @@ open Names open Term open Closure open Environ +open Libnames open Tactics open Rawterm open Tacticals @@ -27,139 +28,53 @@ open Setoid_replace open Proof_type open Coqlib open Tacmach -open Ppconstr open Mod_subst open Tacinterp open Libobject open Printer - -(****************************************************************************) -(* Library linking *) - -let contrib_name = "setoid_ring" - - -let ring_dir = ["Coq";contrib_name] -let setoids_dir = ["Coq";"Setoids"] -let ring_modules = - [ring_dir@["BinList"];ring_dir@["Ring_th"];ring_dir@["Pol"]; - ring_dir@["Ring_tac"];ring_dir@["ZRing_th"]] -let stdlib_modules = [setoids_dir@["Setoid"]] - -let coq_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) -let ring_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" ring_modules c) -let ringtac_constant m c = - lazy (Coqlib.gen_constant_in_modules "Ring" [ring_dir@["ZRing_th";m]] c) - -let new_ring_path = - make_dirpath (List.map id_of_string ["Ring_tac";contrib_name;"Coq"]) -let ltac s = - lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s)) -let znew_ring_path = - make_dirpath (List.map id_of_string ["ZRing_th";contrib_name;"Coq"]) -let zltac s = - lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s)) -let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) - -let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);; -let pol_cst s = mk_cst [contrib_name;"Pol"] s ;; - -let ic c = - let env = Global.env() and sigma = Evd.empty in - Constrintern.interp_constr sigma env c - - -(* Ring theory *) - -(* almost_ring defs *) -let coq_almost_ring_theory = ring_constant "almost_ring_theory" -let coq_ring_lemma1 = ring_constant "ring_correct" -let coq_ring_lemma2 = ring_constant "Pphi_dev_ok'" -let ring_comp1 = ring_constant "ring_id_correct" -let ring_comp2 = ring_constant "ring_rw_id_correct'" -let ring_abs1 = ringtac_constant "Zpol" "ring_gen_correct" -let ring_abs2 = ringtac_constant "Zpol" "ring_rw_gen_correct'" -let sring_abs1 = ringtac_constant "Npol" "ring_gen_correct" -let sring_abs2 = ringtac_constant "Npol" "ring_rw_gen_correct'" - -(* setoid and morphism utilities *) -let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" -let coq_eq_setoid = ring_constant "Eqsth" -let coq_eq_morph = ring_constant "Eq_ext" - -(* ring -> almost_ring utilities *) -let coq_ring_theory = ring_constant "ring_theory" -let coq_ring_morph = ring_constant "ring_morph" -let coq_Rth_ARth = ring_constant "Rth_ARth" -let coq_mk_reqe = ring_constant "mk_reqe" - -(* semi_ring -> almost_ring utilities *) -let coq_semi_ring_theory = ring_constant "semi_ring_theory" -let coq_SRth_ARth = ring_constant "SRth_ARth" -let coq_sring_morph = ring_constant "semi_morph" -let coq_SRmorph_Rmorph = ring_constant "SRmorph_Rmorph" -let coq_mk_seqe = ring_constant "mk_seqe" -let coq_SRsub = ring_constant "SRsub" -let coq_SRopp = ring_constant "SRopp" -let coq_SReqe_Reqe = ring_constant "SReqe_Reqe" - -let ltac_setoid_ring = ltac"Make_ring_tac" -let ltac_setoid_ring_rewrite = ltac"Make_ring_rw_list" -let ltac_inv_morphZ = zltac"inv_gen_phiZ" -let ltac_inv_morphN = zltac"inv_gen_phiN" - -let coq_cons = ring_constant "cons" -let coq_nil = ring_constant "nil" - -let lapp f args = mkApp(Lazy.force f,args) - -let dest_rel t = - match kind_of_term t with - App(f,args) when Array.length args >= 2 -> - mkApp(f,Array.sub args 0 (Array.length args - 2)) - | _ -> failwith "cannot find relation" +open Declare +open Decl_kinds +open Entries (****************************************************************************) (* controlled reduction *) -let mark_arg i c = mkEvar(i,[|c|]);; +let mark_arg i c = mkEvar(i,[|c|]) let unmark_arg f c = match destEvar c with | (i,[|c|]) -> f i c - | _ -> assert false;; + | _ -> assert false -type protect_flag = Eval|Prot|Rec ;; +type protect_flag = Eval|Prot|Rec -let tag_arg tag_rec map i c = +let tag_arg tag_rec map subs i c = match map i with - Eval -> inject c + Eval -> mk_clos subs c | Prot -> mk_atom c - | Rec -> if i = -1 then inject c else tag_rec c + | Rec -> if i = -1 then mk_clos subs c else tag_rec c -let rec mk_clos_but f_map t = +let rec mk_clos_but f_map subs t = match f_map t with - | Some map -> tag_arg (mk_clos_but f_map) map (-1) t + | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t | None -> (match kind_of_term t with - App(f,args) -> mk_clos_app_but f_map f args 0 - (* unspecified constants are evaluated *) - | _ -> inject t) + App(f,args) -> mk_clos_app_but f_map subs f args 0 + | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t + | _ -> mk_atom t) -and mk_clos_app_but f_map f args n = - if n >= Array.length args then inject(mkApp(f, args)) +and mk_clos_app_but f_map subs f args n = + if n >= Array.length args then mk_atom(mkApp(f, args)) else let fargs, args' = array_chop n args in let f' = mkApp(f,fargs) in match f_map f' with Some map -> mk_clos_deep - (fun _ -> unmark_arg (tag_arg (mk_clos_but f_map) map)) - (Esubst.ESID 0) + (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s')) + subs (mkApp (mark_arg (-1) f', Array.mapi mark_arg args')) - | None -> mk_clos_app_but f_map f args (n+1) -;; + | None -> mk_clos_app_but f_map subs f args (n+1) + let interp_map l c = try @@ -174,98 +89,320 @@ let interp_map l c = let interp_map l t = try Some(List.assoc t l) with Not_found -> None -let arg_map = - [mk_cst [contrib_name;"BinList"] "cons",(function -1->Eval|2->Rec|_->Prot); - mk_cst [contrib_name;"BinList"] "nil", (function -1->Eval|_ -> Prot); - (* Pphi_dev: evaluate polynomial and coef operations, protect - ring operations and make recursive call on morphism and var map *) - pol_cst "Pphi_dev", (function -1|6|7|8|11->Eval|9|10->Rec|_->Prot); - (* PEeval: evaluate polynomial, protect ring operations - and make recursive call on morphism and var map *) - pol_cst "PEeval", (function -1|9->Eval|7|8->Rec|_->Prot); - (* Do not evaluate ring operations... *) - ring_constant "gen_phiZ", (function -1|6->Eval|_->Prot); - ring_constant "gen_phiN", (function -1|5->Eval|_->Prot); -];; +let protect_maps = ref ([]:(string*(constr->'a)) list) +let add_map s m = protect_maps := (s,m) :: !protect_maps +let lookup_map map = + try List.assoc map !protect_maps + with Not_found -> + errorlabstrm"lookup_map"(str"map "++qs map++str"not found") -(* Equality: do not evaluate but make recursive call on both sides *) -let is_ring_thm req = - interp_map - ((req,(function -1->Prot|_->Rec)):: - List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) -;; - -let protect_red env sigma c = - let req = dest_rel c in +let protect_red map env sigma c = kl (create_clos_infos betadeltaiota env) - (mk_clos_but (is_ring_thm req) c);; + (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);; -let protect_tac = - Tactics.reduct_option (protect_red,DEFAULTcast) None ;; +let protect_tac map = + Tactics.reduct_option (protect_red map,DEFAULTcast) None ;; -let protect_tac_in id = - Tactics.reduct_option (protect_red,DEFAULTcast) (Some(([],id),InHyp));; +let protect_tac_in map id = + Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(([],id),InHyp));; TACTIC EXTEND protect_fv - [ "protect_fv" "in" ident(id) ] -> - [ protect_tac_in id ] -| [ "protect_fv" ] -> - [ protect_tac ] + [ "protect_fv" string(map) "in" ident(id) ] -> + [ protect_tac_in map id ] +| [ "protect_fv" string(map) ] -> + [ protect_tac map ] END;; (****************************************************************************) -(* Ring database *) + +let closed_term t l = + let l = List.map constr_of_global l in + let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in + if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt()) +;; + +TACTIC EXTEND closed_term + [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] -> + [ closed_term t l ] +END +;; +(* +let closed_term_ast l = + TacFun([Some(id_of_string"t")], + TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", + [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t")); + Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l]))) +*) +let closed_term_ast l = + let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in + TacFun([Some(id_of_string"t")], + TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term", + [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None); + Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l]))) +(* +let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term" +*) + +(****************************************************************************) + +let ic c = + let env = Global.env() and sigma = Evd.empty in + Constrintern.interp_constr sigma env c let ty c = Typing.type_of (Global.env()) Evd.empty c +let decl_constant na c = + mkConst(declare_constant (id_of_string na) (DefinitionEntry + { const_entry_body = c; + const_entry_type = None; + const_entry_opaque = true; + const_entry_boxed = true}, + IsProof Lemma)) + +let ltac_call tac args = + TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)) + +let ltac_lcall tac args = + TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args)) + +let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) + +let dummy_goal env = + {Evd.it= + {Evd.evar_concl=mkProp; + Evd.evar_hyps=named_context_val env; + Evd.evar_body=Evd.Evar_empty; + Evd.evar_extra=None}; + Evd.sigma=Evd.empty} + +let exec_tactic env n f args = + let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in + let res = ref [||] in + let get_res ist = + let l = List.map (fun id -> List.assoc id ist.lfun) lid in + res := Array.of_list l; + TacId[] in + let getter = + Tacexp(TacFun(List.map(fun id -> Some id) lid, + glob_tactic(tacticIn get_res))) in + let _ = + Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in + !res + +let constr_of = function + | VConstr c -> c + | _ -> failwith "Ring.exec_tactic: anomaly" + +let stdlib_modules = + [["Coq";"Setoids";"Setoid"]; + ["Coq";"Lists";"List"] + ] + +let coq_constant c = + lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) + +let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" +let coq_cons = coq_constant "cons" +let coq_nil = coq_constant "nil" + +let lapp f args = mkApp(Lazy.force f,args) + +let rec dest_rel t = + match kind_of_term t with + App(f,args) when Array.length args >= 2 -> + let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in + if closed0 rel then + (rel,args.(Array.length args - 2),args.(Array.length args - 1)) + else error "ring: cannot find relation (not closed)" + | Prod(_,_,c) -> dest_rel c + | _ -> error "ring: cannot find relation" + +(****************************************************************************) +(* Library linking *) + +let contrib_name = "setoid_ring" + +let cdir = ["Coq";contrib_name] +let contrib_modules = + List.map (fun d -> cdir@d) + [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"]; + ["Field_tac"]; ["Field_theory"] + ] + +let my_constant c = + lazy (Coqlib.gen_constant_in_modules "Ring" contrib_modules c) + +let new_ring_path = + make_dirpath (List.map id_of_string ["Ring_tac";contrib_name;"Coq"]) +let ltac s = + lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s)) +let znew_ring_path = + make_dirpath (List.map id_of_string ["InitialRing";contrib_name;"Coq"]) +let zltac s = + lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s)) + +let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);; +let pol_cst s = mk_cst [contrib_name;"Ring_polynom"] s ;; + +(* Ring theory *) + +(* almost_ring defs *) +let coq_almost_ring_theory = my_constant "almost_ring_theory" + +(* setoid and morphism utilities *) +let coq_eq_setoid = my_constant "Eqsth" +let coq_eq_morph = my_constant "Eq_ext" +let coq_eq_smorph = my_constant "Eq_s_ext" + +(* ring -> almost_ring utilities *) +let coq_ring_theory = my_constant "ring_theory" +let coq_mk_reqe = my_constant "mk_reqe" + +(* semi_ring -> almost_ring utilities *) +let coq_semi_ring_theory = my_constant "semi_ring_theory" +let coq_mk_seqe = my_constant "mk_seqe" + +let ltac_inv_morphZ = zltac"inv_gen_phiZ" +let ltac_inv_morphN = zltac"inv_gen_phiN" + +let coq_abstract = my_constant"Abstract" +let coq_comp = my_constant"Computational" +let coq_morph = my_constant"Morphism" + +(* Equality: do not evaluate but make recursive call on both sides *) +let map_with_eq arg_map c = + let (req,_,_) = dest_rel c in + interp_map + ((req,(function -1->Prot|_->Rec)):: + List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) + +let _ = add_map "ring" + (map_with_eq + [coq_cons,(function -1->Eval|2->Rec|_->Prot); + coq_nil, (function -1->Eval|_ -> Prot); + (* Pphi_dev: evaluate polynomial and coef operations, protect + ring operations and make recursive call on the var map *) + pol_cst "Pphi_dev", (function -1|6|7|8|9|11->Eval|10->Rec|_->Prot); + (* PEeval: evaluate morphism and polynomial, protect ring + operations and make recursive call on the var map *) + pol_cst "PEeval", (function -1|7|9->Eval|8->Rec|_->Prot)]) + +(****************************************************************************) +(* Ring database *) type ring_info = { ring_carrier : types; ring_req : constr; + ring_setoid : constr; + ring_ext : constr; + ring_morph : constr; + ring_th : constr; ring_cst_tac : glob_tactic_expr; ring_lemma1 : constr; - ring_lemma2 : constr } + ring_lemma2 : constr; + ring_pre_tac : glob_tactic_expr; + ring_post_tac : glob_tactic_expr } module Cmap = Map.Make(struct type t = constr let compare = compare end) let from_carrier = ref Cmap.empty let from_relation = ref Cmap.empty +let from_name = ref Spmap.empty + +let ring_for_carrier r = Cmap.find r !from_carrier +let ring_for_relation rel = Cmap.find rel !from_relation +let ring_lookup_by_name ref = + Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) !from_name + + +let find_ring_structure env sigma l cl oname = + match oname, l with + Some rf, _ -> + (try ring_lookup_by_name rf + with Not_found -> + errorlabstrm "ring" + (str "found no ring named "++pr_reference rf)) + | None, t::cl' -> + let ty = Retyping.get_type_of env sigma t in + let check c = + let ty' = Retyping.get_type_of env sigma c in + if not (Reductionops.is_conv env sigma ty ty') then + errorlabstrm "ring" + (str"arguments of ring_simplify do not have all the same type") + in + List.iter check cl'; + (try ring_for_carrier ty + with Not_found -> + errorlabstrm "ring" + (str"cannot find a declared ring structure over"++ + spc()++str"\""++pr_constr ty++str"\"")) + | None, [] -> + let (req,_,_) = dest_rel cl in + (try ring_for_relation req + with Not_found -> + errorlabstrm "ring" + (str"cannot find a declared ring structure for equality"++ + spc()++str"\""++pr_constr req++str"\"")) let _ = Summary.declare_summary "tactic-new-ring-table" - { Summary.freeze_function = (fun () -> !from_carrier,!from_relation); + { Summary.freeze_function = + (fun () -> !from_carrier,!from_relation,!from_name); Summary.unfreeze_function = - (fun (ct,rt) -> from_carrier := ct; from_relation := rt); + (fun (ct,rt,nt) -> + from_carrier := ct; from_relation := rt; from_name := nt); Summary.init_function = - (fun () -> from_carrier := Cmap.empty; from_relation := Cmap.empty); + (fun () -> + from_carrier := Cmap.empty; from_relation := Cmap.empty; + from_name := Spmap.empty); Summary.survive_module = false; Summary.survive_section = false } -let add_entry _ e = - let _ = ty e.ring_lemma1 in +let add_entry (sp,_kn) e = +(* let _ = ty e.ring_lemma1 in let _ = ty e.ring_lemma2 in +*) from_carrier := Cmap.add e.ring_carrier e !from_carrier; - from_relation := Cmap.add e.ring_req e !from_relation + from_relation := Cmap.add e.ring_req e !from_relation; + from_name := Spmap.add sp e !from_name let subst_th (_,subst,th) = let c' = subst_mps subst th.ring_carrier in let eq' = subst_mps subst th.ring_req in + let set' = subst_mps subst th.ring_setoid in + let ext' = subst_mps subst th.ring_ext in + let morph' = subst_mps subst th.ring_morph in + let th' = subst_mps subst th.ring_th in let thm1' = subst_mps subst th.ring_lemma1 in let thm2' = subst_mps subst th.ring_lemma2 in let tac'= subst_tactic subst th.ring_cst_tac in + let pretac'= subst_tactic subst th.ring_pre_tac in + let posttac'= subst_tactic subst th.ring_post_tac in if c' == th.ring_carrier && eq' == th.ring_req && + set' = th.ring_setoid && + ext' == th.ring_ext && + morph' == th.ring_morph && + th' == th.ring_th && thm1' == th.ring_lemma1 && thm2' == th.ring_lemma2 && - tac' == th.ring_cst_tac then th + tac' == th.ring_cst_tac && + pretac' == th.ring_pre_tac && + posttac' == th.ring_post_tac then th else { ring_carrier = c'; ring_req = eq'; + ring_setoid = set'; + ring_ext = ext'; + ring_morph = morph'; + ring_th = th'; ring_cst_tac = tac'; ring_lemma1 = thm1'; - ring_lemma2 = thm2' } + ring_lemma2 = thm2'; + ring_pre_tac = pretac'; + ring_post_tac = posttac' } let (theory_to_obj, obj_to_theory) = @@ -280,10 +417,6 @@ let (theory_to_obj, obj_to_theory) = export_function = export_th } -let ring_for_carrier r = Cmap.find r !from_carrier - -let ring_for_relation rel = Cmap.find rel !from_relation - let setoid_of_relation r = lapp coq_mk_Setoid [|r.rel_a; r.rel_aeq; @@ -293,43 +426,19 @@ let op_morph r add mul opp req m1 m2 m3 = lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] let op_smorph r add mul req m1 m2 = - lapp coq_SReqe_Reqe - [| r;add;mul;req;lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |]|] - -let sr_sub r add = lapp coq_SRsub [|r;add|] -let sr_opp r = lapp coq_SRopp [|r|] + lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] -let dest_morphism kind th sth = - let th_typ = Retyping.get_type_of (Global.env()) Evd.empty th in - match kind_of_term th_typ with - App(f,[|_;_;_;_;_;_;_;_;c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) - when f = Lazy.force coq_ring_morph -> - (th,[|c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) - | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) - when f = Lazy.force coq_sring_morph && kind=Some true-> - let th = - lapp coq_SRmorph_Rmorph - [|r;zero;one;add;mul;req;sth;c;czero;cone;cadd;cmul;ceqb;phi;th|]in - (th,[|c;czero;cone;cadd;cmul;cadd;sr_opp c;ceqb;phi|]) - | _ -> failwith "bad ring_morph lemma" - -let dest_eq_test th = - let th_typ = Retyping.get_type_of (Global.env()) Evd.empty th in - match decompose_prod th_typ with - (_,h)::_,_ -> - (match snd(destApplication h) with - [|_;lhs;_|] -> fst(destApplication lhs) - | _ -> failwith "bad lemma for decidability of equality") - | _ -> failwith "bad lemma for decidability of equality" - -let default_ring_equality is_semi (r,add,mul,opp,req) = +let default_ring_equality (r,add,mul,opp,req) = let is_setoid = function {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true | _ -> false in match default_relation_for_carrier ~filter:is_setoid r with Leibniz _ -> let setoid = lapp coq_eq_setoid [|r|] in - let op_morph = lapp coq_eq_morph [|r;add;mul;opp|] in + let op_morph = + match opp with + Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] + | None -> lapp coq_eq_smorph [|r;add;mul|] in (setoid,op_morph) | Relation rel -> let setoid = setoid_of_relation rel in @@ -347,8 +456,12 @@ let default_ring_equality is_semi (r,add,mul,opp,req) = with Not_found -> error "ring multiplication should be declared as a morphism" in let op_morph = - if is_semi <> Some true then - (let opp_m = default_morphism ~filter:is_endomorphism opp in + match opp with + | Some opp -> + (let opp_m = + try default_morphism ~filter:is_endomorphism opp + with Not_found -> + error "ring opposite should be declared as a morphism" in let op_morph = op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in msgnl @@ -358,7 +471,7 @@ let default_ring_equality is_semi (r,add,mul,opp,req) = str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ str"\""); op_morph) - else + | None -> (msgnl (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ str"and morphisms \""++pr_constr add_m.morphism_theory++ @@ -367,159 +480,475 @@ let default_ring_equality is_semi (r,add,mul,opp,req) = op_smorph r add mul req add_m.lem mul_m.lem) in (setoid,op_morph) -let build_setoid_params is_semi r add mul opp req eqth = +let build_setoid_params r add mul opp req eqth = match eqth with Some th -> th - | None -> default_ring_equality is_semi (r,add,mul,opp,req) + | None -> default_ring_equality (r,add,mul,opp,req) -let dest_ring th_spec = - let th_typ = Retyping.get_type_of (Global.env()) Evd.empty th_spec in +let dest_ring env sigma th_spec = + let th_typ = Retyping.get_type_of env sigma th_spec in match kind_of_term th_typ with App(f,[|r;zero;one;add;mul;sub;opp;req|]) when f = Lazy.force coq_almost_ring_theory -> - (None,r,zero,one,add,mul,sub,opp,req) + (None,r,zero,one,add,mul,Some sub,Some opp,req) | App(f,[|r;zero;one;add;mul;req|]) when f = Lazy.force coq_semi_ring_theory -> - (Some true,r,zero,one,add,mul,sr_sub r add,sr_opp r,req) + (Some true,r,zero,one,add,mul,None,None,req) | App(f,[|r;zero;one;add;mul;sub;opp;req|]) when f = Lazy.force coq_ring_theory -> - (Some false,r,zero,one,add,mul,sub,opp,req) + (Some false,r,zero,one,add,mul,Some sub,Some opp,req) | _ -> error "bad ring structure" -let build_almost_ring kind r zero one add mul sub opp req sth morph th = - match kind with - None -> th - | Some true -> - lapp coq_SRth_ARth [|r;zero;one;add;mul;req;sth;th|] - | Some false -> - lapp coq_Rth_ARth [|r;zero;one;add;mul;sub;opp;req;sth;morph;th|] - type coeff_spec = Computational of constr (* equality test *) | Abstract (* coeffs = Z *) | Morphism of constr (* general morphism *) + +let reflect_coeff rkind = + (* We build an ill-typed terms on purpose... *) + match rkind with + Abstract -> Lazy.force coq_abstract + | Computational c -> lapp coq_comp [|c|] + | Morphism m -> lapp coq_morph [|m|] + type cst_tac_spec = CstTac of raw_tactic_expr - | Closed of constr list - - -let add_theory name rth eqth morphth cst_tac = - Coqlib.check_required_library ["Coq";"setoid_ring";"Ring_tac"]; - let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring rth in - let (sth,morph) = build_setoid_params kind r add mul opp req eqth in - let args0 = [|r;zero;one;add;mul;sub;opp;req;sth;morph|] in - let (lemma1,lemma2) = - match morphth with - | Computational c -> - let reqb = dest_eq_test c in - let rth = - build_almost_ring - kind r zero one add mul sub opp req sth morph rth in - let args = Array.append args0 [|rth;reqb;c|] in - (lapp ring_comp1 args, lapp ring_comp2 args) - | Morphism m -> - let (m,args1) = dest_morphism kind m sth in - let rth = - build_almost_ring - kind r zero one add mul sub opp req sth morph rth in - let args = Array.concat [args0;[|rth|]; args1; [|m|]] in - (lapp coq_ring_lemma1 args, lapp coq_ring_lemma2 args) - | Abstract -> - Coqlib.check_required_library ["Coq";"setoid_ring";"ZRing_th"]; - let args1 = Array.append args0 [|rth|] in - (match kind with - None -> error "an almost_ring cannot be abstract" - | Some true -> - (lapp sring_abs1 args1, lapp sring_abs2 args1) - | Some false -> - (lapp ring_abs1 args1, lapp ring_abs2 args1)) in - let cst_tac = match cst_tac with + | Closed of reference list + +let interp_cst_tac kind (zero,one,add,mul,opp) cst_tac = + match cst_tac with Some (CstTac t) -> Tacinterp.glob_tactic t - | Some (Closed lc) -> failwith "TODO" + | Some (Closed lc) -> closed_term_ast (List.map Nametab.global lc) | None -> - (match kind with - Some true -> + (match opp, kind with + None, _ -> let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) - | Some false -> + | Some opp, Some _ -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) - | _ -> error"a tactic must be specified for an almost_ring") in + | _ -> error"a tactic must be specified for an almost_ring") + +let add_theory name rth eqth morphth cst_tac (pre,post) = + let env = Global.env() in + let sigma = Evd.empty in + let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in + let (sth,ext) = build_setoid_params r add mul opp req eqth in + let rk = reflect_coeff morphth in + let params = + exec_tactic env 5 (zltac"ring_lemmas") (List.map carg[sth;ext;rth;rk]) in + let lemma1 = constr_of params.(3) in + let lemma2 = constr_of params.(4) in + + let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in + let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in + let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in + let pretac = + match pre with + Some t -> Tacinterp.glob_tactic t + | _ -> TacId [] in + let posttac = + match post with + Some t -> Tacinterp.glob_tactic t + | _ -> TacId [] in let _ = Lib.add_leaf name (theory_to_obj { ring_carrier = r; ring_req = req; + ring_setoid = sth; + ring_ext = constr_of params.(1); + ring_morph = constr_of params.(2); + ring_th = constr_of params.(0); ring_cst_tac = cst_tac; ring_lemma1 = lemma1; - ring_lemma2 = lemma2 }) in + ring_lemma2 = lemma2; + ring_pre_tac = pretac; + ring_post_tac = posttac }) in () -VERNAC ARGUMENT EXTEND ring_coefs -| [ "Computational" constr(c)] -> [ Computational (ic c) ] -| [ "Abstract" ] -> [ Abstract ] -| [ "Coefficients" constr(m)] -> [ Morphism (ic m) ] -| [ ] -> [ Abstract ] +type ring_mod = + Ring_kind of coeff_spec + | Const_tac of cst_tac_spec + | Pre_tac of raw_tactic_expr + | Post_tac of raw_tactic_expr + | Setoid of Topconstr.constr_expr * Topconstr.constr_expr + +VERNAC ARGUMENT EXTEND ring_mod + | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ] + | [ "abstract" ] -> [ Ring_kind Abstract ] + | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ] + | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ] + | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ] + | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] + | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ] + | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] END -VERNAC ARGUMENT EXTEND ring_cst_tac -| [ "Constant" tactic(c)] -> [ Some(CstTac c) ] -| [ "[" ne_constr_list(l) "]" ] -> [ Some(Closed (List.map ic l)) ] -| [ ] -> [ None ] -END +let set_once s r v = + if !r = None then r := Some v else error (s^" cannot be set twice") + +let process_ring_mods l = + let kind = ref None in + let set = ref None in + let cst_tac = ref None in + let pre = ref None in + let post = ref None in + List.iter(function + Ring_kind k -> set_once "ring kind" kind k + | Const_tac t -> set_once "tactic recognizing constants" cst_tac t + | Pre_tac t -> set_once "preprocess tactic" pre t + | Post_tac t -> set_once "postprocess tactic" post t + | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext)) l; + let k = match !kind with Some k -> k | None -> Abstract in + (k, !set, !cst_tac, !pre, !post) VERNAC COMMAND EXTEND AddSetoidRing -| [ "Add" "New" "Ring" ident(id) ":" constr(t) ring_coefs(c) - "Setoid" constr(e) constr(m) ring_cst_tac(tac) ] -> - [ add_theory id (ic t) (Some (ic e, ic m)) c tac ] -| [ "Add" "New" "Ring" ident(id) ":" constr(t) ring_coefs(c) - ring_cst_tac(tac) ] -> - [ add_theory id (ic t) None c tac ] + | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] -> + [ let (k,set,cst,pre,post) = process_ring_mods l in + add_theory id (ic t) set k cst (pre,post) ] END - (*****************************************************************************) (* The tactics consist then only in a lookup in the ring database and call the appropriate ltac. *) -let ring gl = - let req = dest_rel (pf_concl gl) in - let e = - try ring_for_relation req - with Not_found -> - errorlabstrm "ring" - (str"cannot find a declared ring structure for equality"++ - spc()++str"\""++pr_constr req++str"\"") in - Tacinterp.eval_tactic - (TacArg(TacCall(dummy_loc, - ArgArg(dummy_loc, Lazy.force ltac_setoid_ring), - Tacexp e.ring_cst_tac:: - List.map carg [e.ring_lemma1;e.ring_lemma2;e.ring_req]))) - gl - -let ring_rewrite rl = - let ty = Retyping.get_type_of (Global.env()) Evd.empty (List.hd rl) in - let e = - try ring_for_carrier ty - with Not_found -> - errorlabstrm "ring" - (str"cannot find a declared ring structure over"++ - spc()++str"\""++pr_constr ty++str"\"") in - let rl = List.fold_right (fun x l -> lapp coq_cons [|ty;x;l|]) rl - (lapp coq_nil [|ty|]) in +let make_term_list carrier rl gl = + let rl = + match rl with + [] -> let (_,t1,t2) = dest_rel (pf_concl gl) in [t1;t2] + | _ -> rl in + List.fold_right + (fun x l -> lapp coq_cons [|carrier;x;l|]) rl + (lapp coq_nil [|carrier|]) + +let ring_lookup (f:glob_tactic_expr) rl gl = + let env = pf_env gl in + let sigma = project gl in + let e = find_ring_structure env sigma rl (pf_concl gl) None in + let rl = carg (make_term_list e.ring_carrier rl gl) in + let req = carg e.ring_req in + let sth = carg e.ring_setoid in + let ext = carg e.ring_ext in + let morph = carg e.ring_morph in + let th = carg e.ring_th in + let cst_tac = Tacexp e.ring_cst_tac in + let lemma1 = carg e.ring_lemma1 in + let lemma2 = carg e.ring_lemma2 in + let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in + let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in Tacinterp.eval_tactic - (TacArg(TacCall(dummy_loc, - ArgArg(dummy_loc, Lazy.force ltac_setoid_ring_rewrite), - Tacexp e.ring_cst_tac::List.map carg [e.ring_lemma2;e.ring_req;rl]))) + (TacLetIn + ([(dummy_loc,id_of_string"f"),None,Tacexp f], + ltac_lcall "f" + [req;sth;ext;morph;th;cst_tac;lemma1;lemma2;pretac;posttac;rl])) gl + +TACTIC EXTEND ring_lookup +| [ "ring_lookup" tactic(f) constr_list(l) ] -> [ ring_lookup (fst f) l ] +END + +(***********************************************************************) + +let new_field_path = + make_dirpath (List.map id_of_string ["Field_tac";contrib_name;"Coq"]) + +let field_ltac s = + lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s)) + + +let _ = add_map "field" + (map_with_eq + [coq_cons,(function -1->Eval|2->Rec|_->Prot); + coq_nil, (function -1->Eval|_ -> Prot); + (* display_linear: evaluate polynomials and coef operations, protect + field operations and make recursive call on the var map *) + my_constant "display_linear", + (function -1|7|8|9|10|12|13->Eval|11->Rec|_->Prot); + (* Pphi_dev: evaluate polynomial and coef operations, protect + ring operations and make recursive call on the var map *) + my_constant "Pphi_dev", (function -1|6|7|8|9|11->Eval|10->Rec|_->Prot); + (* PEeval: evaluate morphism and polynomial, protect ring + operations and make recursive call on the var map *) + my_constant "FEeval", (function -1|9|11->Eval|10->Rec|_->Prot)]);; + + +let _ = add_map "field_cond" + (map_with_eq + [coq_cons,(function -1->Eval|2->Rec|_->Prot); + coq_nil, (function -1->Eval|_ -> Prot); + (* PCond: evaluate morphism and denum list, protect ring + operations and make recursive call on the var map *) + my_constant "PCond", (function -1|8|10->Eval|9->Rec|_->Prot)]);; + + +let afield_theory = my_constant "almost_field_theory" +let field_theory = my_constant "field_theory" +let sfield_theory = my_constant "semi_field_theory" +let af_ar = my_constant"AF_AR" +let f_r = my_constant"F_R" +let sf_sr = my_constant"SF_SR" +let dest_field env sigma th_spec = + let th_typ = Retyping.get_type_of env sigma th_spec in + match kind_of_term th_typ with + | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) + when f = Lazy.force afield_theory -> + let rth = lapp af_ar + [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in + (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) + | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) + when f = Lazy.force field_theory -> + let rth = + lapp f_r + [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in + (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) + | App(f,[|r;zero;one;add;mul;div;inv;req|]) + when f = Lazy.force sfield_theory -> + let rth = lapp sf_sr + [|r;zero;one;add;mul;div;inv;req;th_spec|] in + (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) + | _ -> error "bad field structure" + +type field_info = + { field_carrier : types; + field_req : constr; + field_cst_tac : glob_tactic_expr; + field_ok : constr; + field_simpl_eq_ok : constr; + field_simpl_ok : constr; + field_cond : constr; + field_pre_tac : glob_tactic_expr; + field_post_tac : glob_tactic_expr } + +let field_from_carrier = ref Cmap.empty +let field_from_relation = ref Cmap.empty +let field_from_name = ref Spmap.empty + + +let field_for_carrier r = Cmap.find r !field_from_carrier +let field_for_relation rel = Cmap.find rel !field_from_relation +let field_lookup_by_name ref = + Spmap.find (Nametab.locate_obj (snd(qualid_of_reference ref))) + !field_from_name + + +let find_field_structure env sigma l cl oname = + check_required_library (cdir@["Field_tac"]); + match oname, l with + Some rf, _ -> + (try field_lookup_by_name rf + with Not_found -> + errorlabstrm "field" + (str "found no field named "++pr_reference rf)) + | None, t::cl' -> + let ty = Retyping.get_type_of env sigma t in + let check c = + let ty' = Retyping.get_type_of env sigma c in + if not (Reductionops.is_conv env sigma ty ty') then + errorlabstrm "field" + (str"arguments of field_simplify do not have all the same type") + in + List.iter check cl'; + (try field_for_carrier ty + with Not_found -> + errorlabstrm "field" + (str"cannot find a declared field structure over"++ + spc()++str"\""++pr_constr ty++str"\"")) + | None, [] -> + let (req,_,_) = dest_rel cl in + (try field_for_relation req + with Not_found -> + errorlabstrm "field" + (str"cannot find a declared field structure for equality"++ + spc()++str"\""++pr_constr req++str"\"")) + +let _ = + Summary.declare_summary "tactic-new-field-table" + { Summary.freeze_function = + (fun () -> !field_from_carrier,!field_from_relation,!field_from_name); + Summary.unfreeze_function = + (fun (ct,rt,nt) -> + field_from_carrier := ct; field_from_relation := rt; + field_from_name := nt); + Summary.init_function = + (fun () -> + field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty; + field_from_name := Spmap.empty); + Summary.survive_module = false; + Summary.survive_section = false } + +let add_field_entry (sp,_kn) e = +(* + let _ = ty e.field_ok in + let _ = ty e.field_simpl_eq_ok in + let _ = ty e.field_simpl_ok in + let _ = ty e.field_cond in +*) + field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; + field_from_relation := Cmap.add e.field_req e !field_from_relation; + field_from_name := Spmap.add sp e !field_from_name + +let subst_th (_,subst,th) = + let c' = subst_mps subst th.field_carrier in + let eq' = subst_mps subst th.field_req in + let thm1' = subst_mps subst th.field_ok in + let thm2' = subst_mps subst th.field_simpl_eq_ok in + let thm3' = subst_mps subst th.field_simpl_ok in + let thm4' = subst_mps subst th.field_cond in + let tac'= subst_tactic subst th.field_cst_tac in + let pretac'= subst_tactic subst th.field_pre_tac in + let posttac'= subst_tactic subst th.field_post_tac in + if c' == th.field_carrier && + eq' == th.field_req && + thm1' == th.field_ok && + thm2' == th.field_simpl_eq_ok && + thm3' == th.field_simpl_ok && + thm4' == th.field_cond && + tac' == th.field_cst_tac && + pretac' == th.field_pre_tac && + posttac' == th.field_post_tac then th + else + { field_carrier = c'; + field_req = eq'; + field_cst_tac = tac'; + field_ok = thm1'; + field_simpl_eq_ok = thm2'; + field_simpl_ok = thm3'; + field_cond = thm4'; + field_pre_tac = pretac'; + field_post_tac = posttac' } + +let (ftheory_to_obj, obj_to_ftheory) = + let cache_th (name,th) = add_field_entry name th + and export_th x = Some x in + declare_object + {(default_object "tactic-new-field-theory") with + open_function = (fun i o -> if i=1 then cache_th o); + cache_function = cache_th; + subst_function = subst_th; + classify_function = (fun (_,x) -> Substitute x); + export_function = export_th } -let setoid_ring = function - | [] -> ring - | l -> ring_rewrite l +let default_field_equality r inv req = + let is_setoid = function + {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true + | _ -> false in + match default_relation_for_carrier ~filter:is_setoid r with + Leibniz _ -> + mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) + | Relation rel -> + let is_endomorphism = function + { args=args } -> List.for_all + (function (var,Relation rel) -> + var=None && eq_constr req rel + | _ -> false) args in + let inv_m = + try default_morphism ~filter:is_endomorphism inv + with Not_found -> + error "field inverse should be declared as a morphism" in + inv_m.lem + +let add_field_theory name fth eqth morphth cst_tac inj (pre,post) = + let env = Global.env() in + let sigma = Evd.empty in + let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = + dest_field env sigma fth in + let (sth,ext) = build_setoid_params r add mul opp req eqth in + let eqth = Some(sth,ext) in + let _ = add_theory name rth eqth morphth cst_tac (None,None) in + let inv_m = default_field_equality r inv req in + let rk = reflect_coeff morphth in + let params = + exec_tactic env 8 (field_ltac"field_lemmas") + (List.map carg[sth;ext;inv_m;fth;rk]) in + let lemma1 = constr_of params.(3) in + let lemma2 = constr_of params.(4) in + let lemma3 = constr_of params.(5) in + let cond_lemma = + match inj with + | Some thm -> mkApp(constr_of params.(7),[|thm|]) + | None -> constr_of params.(6) in + let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in + let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in + let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in + let cond_lemma = decl_constant (string_of_id name^"_lemma4") cond_lemma in + let cst_tac = interp_cst_tac kind (zero,one,add,mul,opp) cst_tac in + let pretac = + match pre with + Some t -> Tacinterp.glob_tactic t + | _ -> TacId [] in + let posttac = + match post with + Some t -> Tacinterp.glob_tactic t + | _ -> TacId [] in + let _ = + Lib.add_leaf name + (ftheory_to_obj + { field_carrier = r; + field_req = req; + field_cst_tac = cst_tac; + field_ok = lemma1; + field_simpl_eq_ok = lemma2; + field_simpl_ok = lemma3; + field_cond = cond_lemma; + field_pre_tac = pretac; + field_post_tac = posttac }) in () + +type field_mod = + Ring_mod of ring_mod + | Inject of Topconstr.constr_expr + +VERNAC ARGUMENT EXTEND field_mod + | [ ring_mod(m) ] -> [ Ring_mod m ] + | [ "infinite" constr(inj) ] -> [ Inject inj ] +END -TACTIC EXTEND setoid_ring - [ "setoid" "ring" constr_list(l) ] -> [ setoid_ring l ] +let process_field_mods l = + let kind = ref None in + let set = ref None in + let cst_tac = ref None in + let pre = ref None in + let post = ref None in + let inj = ref None in + List.iter(function + Ring_mod(Ring_kind k) -> set_once "field kind" kind k + | Ring_mod(Const_tac t) -> + set_once "tactic recognizing constants" cst_tac t + | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t + | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t + | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext) + | Inject i -> set_once "infinite property" inj (ic i)) l; + let k = match !kind with Some k -> k | None -> Abstract in + (k, !set, !inj, !cst_tac, !pre, !post) + +VERNAC COMMAND EXTEND AddSetoidField +| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> + [ let (k,set,inj,cst_tac,pre,post) = process_field_mods l in + add_field_theory id (ic t) set k cst_tac inj (pre,post) ] END +let field_lookup (f:glob_tactic_expr) rl gl = + let env = pf_env gl in + let sigma = project gl in + let e = find_field_structure env sigma rl (pf_concl gl) None in + let rl = carg (make_term_list e.field_carrier rl gl) in + let req = carg e.field_req in + let cst_tac = Tacexp e.field_cst_tac in + let field_ok = carg e.field_ok in + let field_simpl_ok = carg e.field_simpl_ok in + let field_simpl_eq_ok = carg e.field_simpl_eq_ok in + let cond_ok = carg e.field_cond in + let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in + let posttac = Tacexp(TacFun([None],e.field_post_tac)) in + Tacinterp.eval_tactic + (TacLetIn + ([(dummy_loc,id_of_string"f"),None,Tacexp f], + ltac_lcall "f" + [req;cst_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;cond_ok; + pretac;posttac;rl])) gl + +TACTIC EXTEND field_lookup +| [ "field_lookup" tactic(f) constr_list(l) ] -> [ field_lookup (fst f) l ] +END diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v index b1694d7c..219cd75b 100644 --- a/contrib/subtac/Utils.v +++ b/contrib/subtac/Utils.v @@ -4,7 +4,7 @@ Notation "'fun' { x : A | P } => Q" := (fun x:{x:A|P} => Q) (at level 200, x ident, right associativity). -Notation "( x & y )" := (@existS _ _ x y) : core_scope. +Notation "( x & ? )" := (@exist _ _ x _) : core_scope. Definition ex_pi1 (A : Prop) (P : A -> Prop) (t : ex P) : A. intros. @@ -44,3 +44,4 @@ end. Ltac destruct_exists := repeat (destruct_one_pair) . +Extraction Inline proj1_sig. diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml index 859f9013..790e61a0 100644 --- a/contrib/subtac/eterm.ml +++ b/contrib/subtac/eterm.ml @@ -32,47 +32,48 @@ let list_assoc_index x l = | [] -> raise Not_found in aux 0 l + (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) -let subst_evars evs n t = +let subst_evar_constr evs n t = + let seen = ref Intset.empty in let evar_info id = let rec aux i = function - (k, h, v) :: tl -> - trace (str "Searching for " ++ int id ++ str " found: " ++ int k); - if k = id then (i, h, v) else aux (succ i) tl + (k, x) :: tl -> + if k = id then x else aux (succ i) tl | [] -> raise Not_found - in - let (idx, hyps, v) = aux 0 evs in - n + idx + 1, hyps + in aux 0 evs in let rec substrec depth c = match kind_of_term c with | Evar (k, args) -> - (let index, hyps = - try evar_info k - with Not_found -> - anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") - in - (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ - int (List.length hyps) ++ str " hypotheses"); with _ -> () ); - let ex = mkRel (index + depth) in - (* Evar arguments are created in inverse order, - and we must not apply to defined ones (i.e. LetIn's) - *) - let args = - let rec aux hyps args acc = + let (id, idstr), hyps, _, _ = + try evar_info k + with Not_found -> + anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") + in + seen := Intset.add id !seen; + (try trace (str "Evar " ++ int k ++ str " found, applied to " ++ int (Array.length args) ++ str "arguments," ++ + int (List.length hyps) ++ str " hypotheses"); with _ -> () ); + (* Evar arguments are created in inverse order, + and we must not apply to defined ones (i.e. LetIn's) + *) + let args = + let rec aux hyps args acc = match hyps, args with ((_, None, _) :: tlh), (c :: tla) -> aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc) | ((_, Some _, _) :: tlh), (_ :: tla) -> aux tlh tla acc | [], [] -> acc - | _, _ -> failwith "subst_evars: invalid argument" + | _, _ -> acc (*failwith "subst_evars: invalid argument"*) in aux hyps (Array.to_list args) [] in - mkApp (ex, Array.of_list args)) + mkApp (mkVar idstr, Array.of_list args) | _ -> map_constr_with_binders succ substrec depth c in - substrec 0 t + let t' = substrec 0 t in + t', !seen + (** Substitute variable references in t using De Bruijn indices, where n binders were passed through. *) @@ -89,73 +90,80 @@ let subst_vars acc n t = (** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) to a product : forall H1 : t1, ..., forall Hn : tn, concl. - Changes evars and hypothesis references to De Bruijn indices. + Changes evars and hypothesis references to variable references. *) let etype_of_evar evs ev hyps = let rec aux acc n = function (id, copt, t) :: tl -> - let t' = subst_evars evs n t in + let t', s = subst_evar_constr evs n t in let t'' = subst_vars acc 0 t' in - mkNamedProd_or_LetIn (id, copt, t'') (aux (id :: acc) (succ n) tl) + let copt', s = + match copt with + Some c -> + let c', s' = subst_evar_constr evs n c in + Some c', Intset.union s s' + | None -> None, s + in + let copt' = option_map (subst_vars acc 0) copt' in + let rest, s' = aux (id :: acc) (succ n) tl in + mkNamedProd_or_LetIn (id, copt', t'') rest, Intset.union s' s | [] -> - let t' = subst_evars evs n ev.evar_concl in - subst_vars acc 0 t' + let t', s = subst_evar_constr evs n ev.evar_concl in + subst_vars acc 0 t', s in aux [] 0 (rev hyps) open Tacticals -let eterm_term evm t tycon = +let rec take n l = + if n = 0 then [] else List.hd l :: take (pred n) (List.tl l) + +let trunc_named_context n ctx = + let len = List.length ctx in + take (len - n) ctx + +let eterm_obligations name nclen evm t tycon = (* 'Serialize' the evars, we assume that the types of the existentials refer to previous existentials in the list only *) let evl = List.rev (to_list evm) in - trace (str "Eterm, transformed to list"); + trace (str "Eterm, transformed to list"); + let evn = + let i = ref (-1) in + List.rev_map (fun (id, ev) -> incr i; + (id, (!i, id_of_string (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), ev)) evl + in let evts = (* Remove existential variables in types and build the corresponding products *) fold_right - (fun (id, ev) l -> + (fun (id, (n, nstr), ev) l -> trace (str "Eterm: " ++ str "treating evar: " ++ int id); let hyps = Environ.named_context_of_val ev.evar_hyps in - let y' = (id, hyps, etype_of_evar l ev hyps) in + let hyps = trunc_named_context nclen hyps in + trace (str "Named context is: " ++ Printer.pr_named_context (Global.env ()) hyps); + let evtyp, deps = etype_of_evar l ev hyps in + trace (str "Evar " ++ str (string_of_int n) ++ str "'s type is: " ++ Termops.print_constr_env (Global.env ()) evtyp); + let y' = (id, ((n, nstr), hyps, evtyp, deps)) in y' :: l) - evl [] + evn [] in - let t' = (* Substitute evar refs in the term by De Bruijn indices *) - subst_evars evts 0 t - in - let evar_names = - List.map (fun (id, _, c) -> (id_of_string ("Evar" ^ string_of_int id)), c) evts - in - let evar_bl = - List.map (fun (id, c) -> Name id, None, c) evar_names - in - let anon_evar_bl = List.map (fun (_, x, y) -> (Anonymous, x, y)) evar_bl in - (* Generalize over the existential variables *) - let t'' = Termops.it_mkLambda_or_LetIn t' evar_bl - and tycon = option_map - (fun typ -> Termops.it_mkProd_wo_LetIn typ anon_evar_bl) tycon - in - let _declare_evar (id, c) = - let id = id_of_string ("Evar" ^ string_of_int id) in - ignore(Declare.declare_variable id (Names.empty_dirpath, Declare.SectionLocalAssum c, - Decl_kinds.IsAssumption Decl_kinds.Definitional)) + let t', _ = (* Substitute evar refs in the term by variables *) + subst_evar_constr evts 0 t in - let _declare_assert acc (id, c) = - let id = id_of_string ("Evar" ^ string_of_int id) in - tclTHEN acc (Tactics.assert_tac false (Name id) c) + let evars = + List.map (fun (_, ((_, name), _, typ, deps)) -> name, typ, deps) evts in (try trace (str "Term given to eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t); + Termops.print_constr_env (Global.env ()) t); trace (str "Term constructed in eterm" ++ spc () ++ - Termops.print_constr_env (Global.env ()) t''); - ignore(option_map - (fun typ -> - trace (str "Type :" ++ spc () ++ - Termops.print_constr_env (Global.env ()) typ)) - tycon); + Termops.print_constr_env (Global.env ()) t'); + ignore(iter + (fun (name, typ, deps) -> + trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++ + Termops.print_constr_env (Global.env ()) typ)) + evars); with _ -> ()); - t'', tycon, evar_names + Array.of_list (List.rev evars), t' let mkMetas n = let rec aux i acc = @@ -163,12 +171,12 @@ let mkMetas n = else acc in aux n [] -let eterm evm t (tycon : types option) = - let t, tycon, evs = eterm_term evm t tycon in - match tycon with - Some typ -> Tactics.apply_term (mkCast (t, DEFAULTcast, typ)) [] - | None -> Tactics.apply_term t (mkMetas (List.length evs)) +(* let eterm evm t (tycon : types option) = *) +(* let t, tycon, evs = eterm_term evm t tycon in *) +(* match tycon with *) +(* Some typ -> Tactics.apply_term (mkCast (t, DEFAULTcast, typ)) [] *) +(* | None -> Tactics.apply_term t (mkMetas (List.length evs)) *) -open Tacmach +(* open Tacmach *) -let etermtac (evm, t) = eterm evm t None +let etermtac (evm, t) = assert(false) (*eterm evm t None *) diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli index fbe2ac1d..3a571ee1 100644 --- a/contrib/subtac/eterm.mli +++ b/contrib/subtac/eterm.mli @@ -6,15 +6,19 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: eterm.mli 8688 2006-04-07 15:08:12Z msozeau $ i*) +(*i $Id: eterm.mli 9326 2006-10-31 12:57:26Z msozeau $ i*) open Tacmach open Term open Evd open Names +open Util val mkMetas : int -> constr list -val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list +(* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *) + +val eterm_obligations : identifier -> int -> evar_map -> constr -> types option -> + (identifier * types * Intset.t) array * constr (* Obl. name, type as product and dependencies as indexes into the array *) val etermtac : open_constr -> tactic diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4 index b56ecc3d..243cb191 100644 --- a/contrib/subtac/g_subtac.ml4 +++ b/contrib/subtac/g_subtac.ml4 @@ -10,7 +10,7 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) -(* $Id: g_subtac.ml4 8917 2006-06-07 16:59:05Z herbelin $ *) +(* $Id: g_subtac.ml4 9326 2006-10-31 12:57:26Z msozeau $ *) (*i camlp4deps: "parsing/grammar.cma" i*) @@ -30,6 +30,7 @@ open Topconstr module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ +module Tactic = Pcoq.Tactic module SubtacGram = struct @@ -40,15 +41,31 @@ end open SubtacGram open Util +open Pcoq + +let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig")) GEXTEND Gram - GLOBAL: subtac_gallina_loc; + GLOBAL: subtac_gallina_loc Constr.binder_let Constr.binder; subtac_gallina_loc: [ [ g = Vernac.gallina -> loc, g ] ] ; + + Constr.binder_let: + [ [ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], t, c)]) in + LocalRawAssum ([id], typ) + ] ]; + + Constr.binder: + [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], c, p)]) in + ([id], typ) ] ]; + END + type ('a,'b) gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a, 'b) Genarg.abstract_argument_type let (wit_subtac_gallina_loc : (Genarg.tlevel, Proof_type.tactic) gallina_loc_argtype), @@ -57,6 +74,11 @@ let (wit_subtac_gallina_loc : (Genarg.tlevel, Proof_type.tactic) gallina_loc_arg Genarg.create_arg "subtac_gallina_loc" VERNAC COMMAND EXTEND Subtac -[ "Program" subtac_gallina_loc(g) ] -> - [ Subtac.subtac g ] +[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ] +| [ "Obligation" integer(num) "of" ident(name) ] -> [ Subtac_obligations.subtac_obligation (num, Some name) ] +| [ "Obligation" integer(num) ] -> [ Subtac_obligations.subtac_obligation (num, None) ] +| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations (Some name) (Tacinterp.interp t) ] +| [ "Solve" "Obligations" "using" tactic(t) ] -> [ Subtac_obligations.solve_obligations None (Tacinterp.interp t) ] +| [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ] +| [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ] END diff --git a/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml index ffb16a19..26e8f715 100644 --- a/contrib/subtac/subtac.ml +++ b/contrib/subtac/subtac.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac.ml 8964 2006-06-20 13:52:21Z msozeau $ *) +(* $Id: subtac.ml 9284 2006-10-26 12:06:57Z msozeau $ *) open Global open Pp @@ -156,19 +156,19 @@ let subtac (loc, command) = match command with VernacDefinition (defkind, (locid, id), expr, hook) -> (match expr with - ProveBody (bl, c) -> - let evm, c, ctyp = Subtac_pretyping.subtac_process env isevars id bl c None in - trace (str "Starting proof"); - Command.start_proof id goal_kind c hook; - trace (str "Started proof"); + ProveBody (bl, c) -> Subtac_pretyping.subtac_proof env isevars id bl c None +(* let evm, c, ctyp = in *) +(* trace (str "Starting proof"); *) +(* Command.start_proof id goal_kind c hook; *) +(* trace (str "Started proof"); *) | DefineBody (bl, _, c, tycon) -> - let evm, c, ctyp = Subtac_pretyping.subtac_process env isevars id bl c tycon in - let tac = Eterm.etermtac (evm, c) in - trace (str "Starting proof"); - Command.start_proof id goal_kind ctyp hook; - trace (str "Started proof"); - Pfedit.by tac) + Subtac_pretyping.subtac_proof env isevars id bl c tycon + (* let tac = Eterm.etermtac (evm, c) in *) + (* trace (str "Starting proof"); *) + (* Command.start_proof id goal_kind ctyp hook; *) + (* trace (str "Started proof"); *) + (* Pfedit.by tac) *)) | VernacFixpoint (l, b) -> let _ = trace (str "Building fixpoint") in ignore(Subtac_command.build_recursive l b) @@ -223,24 +223,30 @@ let subtac (loc, command) = ++ x ++ spc () ++ str "and" ++ spc () ++ y in msg_warning cmds - | Type_errors.TypeError (env, e) -> - debug 2 (Himsg.explain_type_error env e) + | Type_errors.TypeError (env, exn) as e -> + debug 2 (Himsg.explain_type_error env exn); + raise e - | Pretype_errors.PretypeError (env, e) -> - debug 2 (Himsg.explain_pretype_error env e) + | Pretype_errors.PretypeError (env, exn) as e -> + debug 2 (Himsg.explain_pretype_error env exn); + raise e - | Stdpp.Exc_located (loc, e) -> + | (Stdpp.Exc_located (loc, e')) as e -> debug 2 (str "Parsing exception: "); - (match e with - | Type_errors.TypeError (env, e) -> - debug 2 (Himsg.explain_type_error env e) + (match e' with + | Type_errors.TypeError (env, exn) -> + debug 2 (Himsg.explain_type_error env exn); + raise e - | Pretype_errors.PretypeError (env, e) -> - debug 2 (Himsg.explain_pretype_error env e) + | Pretype_errors.PretypeError (env, exn) -> + debug 2 (Himsg.explain_pretype_error env exn); + raise e - | e -> msg_warning (str "Unexplained exception: " ++ Cerrors.explain_exn e)) + | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e''); + raise e) | e -> - msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e) + msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e); + raise e diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml index 78c3c70b..da5c497c 100644 --- a/contrib/subtac/subtac_coercion.ml +++ b/contrib/subtac/subtac_coercion.ml @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_coercion.ml 8964 2006-06-20 13:52:21Z msozeau $ *) +(* $Id: subtac_coercion.ml 9284 2006-10-26 12:06:57Z msozeau $ *) open Util open Names @@ -91,7 +91,9 @@ module Coercion = struct let hnf env isevars c = whd_betadeltaiota env (evars_of !isevars) c let rec mu env isevars t = + let isevars = ref isevars in let rec aux v = + let v = hnf env isevars v in match disc_subset v with Some (u, p) -> let f, ct = aux u in @@ -135,8 +137,9 @@ module Coercion = struct | Type x, Type y when x = y -> None (* false *) | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> - let c1 = coerce_unify env a' a in + let name' = Name (Nameops.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in let env' = push_rel (name', None, a') env in + let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in let c2 = coerce_unify env' b b' in (match c1, c2 with None, None -> failwith "subtac.coerce': Should have detected equivalence earlier" diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml index c738d7a6..b433af2c 100644 --- a/contrib/subtac/subtac_command.ml +++ b/contrib/subtac/subtac_command.ml @@ -43,6 +43,7 @@ open Notation module SPretyping = Subtac_pretyping.Pretyping open Subtac_utils open Pretyping +open Subtac_obligations (*********************************************************************) (* Functions to parse and interpret constructions *) @@ -149,15 +150,6 @@ let collect_non_rec env = in searchrec [] -let definition_message id = - Options.if_verbose message ((string_of_id id) ^ " is defined") - -let recursive_message v = - match Array.length v with - | 0 -> error "no recursive definition" - | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined") - | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++ - spc () ++ str "are recursively defined") let filter_map f l = let rec aux acc = function @@ -190,9 +182,12 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = let env = Global.env() in let pr c = my_print_constr env c in let prr = Printer.pr_rel_context env in + let prn = Printer.pr_named_context env in let pr_rel env = Printer.pr_rel_context env in + let nc = named_context env in + let nc_len = named_context_length nc in let _ = - try debug 2 (str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ + try debug 2 (str "In named context: " ++ prn (named_context env) ++ str "Rewriting fixpoint: " ++ Ppconstr.pr_id recname ++ Ppconstr.pr_binders bl ++ str " : " ++ Ppconstr.pr_constr_expr arityc ++ str " := " ++ spc () ++ Ppconstr.pr_constr_expr body) @@ -204,25 +199,35 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = let argid = match argname with Name n -> n | _ -> assert(false) in let _liftafter = lift_binders 1 after_length after in let envwf = push_rel_context before env in - let wf_rel, measure_fn = - let rconstr = interp_constr isevars envwf r in - if measure then - let lt_rel = constr_of_global (Lazy.force lt_ref) in - let name s = Name (id_of_string s) in - mkLambda (name "x", argtyp, - mkLambda (name "y", argtyp, - mkApp (lt_rel, - [| mkApp (rconstr, [| mkRel 2 |]) ; - mkApp (rconstr, [| mkRel 1 |]) |]))), - Some rconstr - else rconstr, None + let wf_rel, wf_rel_fun, measure_fn = + let rconstr_body, rconstr = + let app = mkAppC (r, [mkIdentC (id_of_name argname)]) in + let env = push_rel_context [arg] envwf in + let capp = interp_constr isevars env app in + capp, mkLambda (argname, argtyp, capp) + in + if measure then + let lt_rel = constr_of_global (Lazy.force lt_ref) in + let name s = Name (id_of_string s) in + let wf_rel_fun = + (fun x y -> + mkApp (lt_rel, [| subst1 x rconstr_body; + subst1 y rconstr_body |])) + in + let wf_rel = + mkLambda (name "x", argtyp, + mkLambda (name "y", lift 1 argtyp, + wf_rel_fun (mkRel 2) (mkRel 1))) + in + wf_rel, wf_rel_fun , Some rconstr + else rconstr, (fun x y -> mkApp (rconstr, [|x; y|])), None in let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) in let argid' = id_of_string (string_of_id argid ^ "'") in let wfarg len = (Name argid', None, - mkSubset (Name argid') argtyp - (mkApp (wf_rel, [|mkRel 1; mkRel (len + 1)|]))) + mkSubset (Name argid') argtyp + (wf_rel_fun (mkRel 1) (mkRel (len + 1)))) in let top_bl = after @ (arg :: before) in let intern_bl = after @ (wfarg 1 :: arg :: before) in @@ -234,7 +239,7 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = let projection = mkApp (proj, [| argtyp ; (mkLambda (Name argid', argtyp, - (mkApp (wf_rel, [|mkRel 1; mkRel 3|])))) ; + (wf_rel_fun (mkRel 1) (mkRel 3)))) ; mkRel 1 |]) in @@ -299,40 +304,16 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed = in let evm = non_instanciated_map env isevars in let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in - let evars_def, evars_typ, evars = Eterm.eterm_term evm fullcoqc (Some fullctyp) in - let evars_typ = out_some evars_typ in - (try trace (str "Building evars sum for : "); - List.iter - (fun (n, t) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t)) - evars; - with _ -> ()); - let (sum_tac, sumg) = Subtac_utils.build_dependent_sum evars in - (try trace (str "Evars sum: " ++ my_print_constr env sumg); - trace (str "Evars type: " ++ my_print_constr env evars_typ); - with _ -> ()); - let proofid = id_of_string (string_of_id recname ^ "_evars_proof") in - Command.start_proof proofid goal_proof_kind sumg - (fun strength gr -> - debug 2 (str "Proof finished"); - let def = constr_of_global gr in - let args = Subtac_utils.destruct_ex def sumg in - let _, newdef = decompose_lam_n (List.length args) evars_def in - let constr = Term.substl (List.rev args) newdef in - debug 2 (str "Applied existentials : " ++ my_print_constr env constr); - let ce = - { const_entry_body = constr; - const_entry_type = Some fullctyp; - const_entry_opaque = false; - const_entry_boxed = boxed} - in - let _constant = Declare.declare_constant - recname (DefinitionEntry ce,IsDefinition Definition) - in - definition_message recname); - trace (str "Started existentials proof"); - Pfedit.by sum_tac; - trace (str "Applied sum tac") - + let evars, evars_def = Eterm.eterm_obligations recname nc_len evm fullcoqc (Some fullctyp) in + (try trace (str "Generated obligations : "); + Array.iter + (fun (n, t, _) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t)) + evars; + with _ -> ()); + trace (str "Adding to obligations list"); + Subtac_obligations.add_entry recname evars_def fullctyp evars; + trace (str "Added to obligations list") +(* let build_mutrec l boxed = let sigma = Evd.empty and env0 = Global.env() @@ -543,7 +524,7 @@ let build_mutrec l boxed = Environ.NoBody -> trace (str "Constant has no body") | Environ.Opaque -> trace (str "Constant is opaque") ) - +*) let out_n = function Some n -> n | None -> 0 @@ -563,8 +544,8 @@ let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed errorlabstrm "Subtac_command.build_recursive" (str "Well-founded fixpoints not allowed in mutually recursive blocks")) lnameargsardef - in - build_mutrec lnameargsardef boxed; - assert(false) + in assert(false) + (*build_mutrec lnameargsardef boxed*) + diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli index 90ffb892..846e06cf 100644 --- a/contrib/subtac/subtac_command.mli +++ b/contrib/subtac/subtac_command.mli @@ -37,7 +37,6 @@ val interp_constr_judgment : env -> constr_expr -> unsafe_judgment val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list -val recursive_message : global_reference array -> std_ppcmds val build_recursive : (fixpoint_expr * decl_notation) list -> bool -> unit diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml new file mode 100644 index 00000000..7b13b402 --- /dev/null +++ b/contrib/subtac/subtac_obligations.ml @@ -0,0 +1,249 @@ +open Printf +open Pp +open Subtac_utils + +open Term +open Names +open Libnames +open Summary +open Libobject +open Entries +open Decl_kinds +open Util +open Evd + +type obligation = + { obl_name : identifier; + obl_type : types; + obl_body : constr option; + obl_deps : Intset.t; + } + +type obligations = (obligation array * int) + +type program_info = { + prg_name: identifier; + prg_body: constr; + prg_type: types; + prg_obligations: obligations; +} + +let evar_of_obligation o = { evar_hyps = Environ.empty_named_context_val ; + evar_concl = o.obl_type ; + evar_body = Evar_empty ; + evar_extra = None } + +module ProgMap = Map.Make(struct type t = identifier let compare = compare end) + +let map_replace k v m = ProgMap.add k v (ProgMap.remove k m) + +let map_cardinal m = + let i = ref 0 in + ProgMap.iter (fun _ _ -> incr i) m; + !i + +exception Found of program_info + +let map_first m = + try + ProgMap.iter (fun _ v -> raise (Found v)) m; + assert(false) + with Found x -> x + +let from_prg : program_info ProgMap.t ref = ref ProgMap.empty + +let _ = + Summary.declare_summary "program-tcc-table" + { Summary.freeze_function = (fun () -> !from_prg); + Summary.unfreeze_function = + (fun v -> from_prg := v); + Summary.init_function = + (fun () -> from_prg := ProgMap.empty); + Summary.survive_module = false; + Summary.survive_section = false } + +let declare_definition prg = +(* let obls_constrs = + Array.fold_right (fun x acc -> (out_some x.obl_evar.evar_body) :: acc) (fst prg.prg_obligations) [] + in*) + let ce = + { const_entry_body = prg.prg_body; + const_entry_type = Some prg.prg_type; + const_entry_opaque = false; + const_entry_boxed = false} + in + let _constant = Declare.declare_constant + prg.prg_name (DefinitionEntry ce,IsDefinition Definition) + in + Subtac_utils.definition_message prg.prg_name + +open Evd + +let terms_of_evar ev = + match ev.evar_body with + Evar_defined b -> + let nc = Environ.named_context_of_val ev.evar_hyps in + let body = Termops.it_mkNamedLambda_or_LetIn b nc in + let typ = Termops.it_mkNamedProd_or_LetIn ev.evar_concl nc in + body, typ + | _ -> assert(false) + +let declare_obligation obl body = + let ce = + { const_entry_body = body; + const_entry_type = Some obl.obl_type; + const_entry_opaque = true; + const_entry_boxed = false} + in + let constant = Declare.declare_constant obl.obl_name (DefinitionEntry ce,IsProof Property) + in + Subtac_utils.definition_message obl.obl_name; + { obl with obl_body = Some (mkConst constant) } + +let try_tactics obls = + Array.map + (fun obl -> + match obl.obl_body with + None -> + (try + let ev = evar_of_obligation obl in + let c = Subtac_utils.solve_by_tac ev Auto.default_full_auto in + declare_obligation obl c + with _ -> obl) + | _ -> obl) + obls + +let add_entry n b t obls = + Options.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); + let init_obls e = + Array.map + (fun (n, t, d) -> + { obl_name = n ; obl_body = None; obl_type = t; obl_deps = d }) + e + in + if Array.length obls = 0 then ( + Options.if_verbose ppnl (str "."); + declare_definition { prg_name = n ; prg_body = b ; prg_type = t ; prg_obligations = ([||], 0) } ) + else ( + let len = Array.length obls in + let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in + let obls = init_obls obls in + let rem = Array.fold_left (fun acc obl -> if obl.obl_body = None then succ acc else acc) 0 obls in + let prg = { prg_name = n ; prg_body = b ; prg_type = t ; prg_obligations = (obls, rem) } in + if rem < len then + Options.if_verbose ppnl (int rem ++ str " obligation(s) remaining."); + if rem = 0 then + declare_definition prg + else + from_prg := ProgMap.add n prg !from_prg) + +let error s = Util.error s + +let get_prog name = + let prg_infos = !from_prg in + match name with + Some n -> ProgMap.find n prg_infos + | None -> + (let n = map_cardinal prg_infos in + match n with + 0 -> error "No obligations remaining" + | 1 -> map_first prg_infos + | _ -> error "More than one program with unsolved obligations") + +let update_obls prg obls rem = + let prg' = { prg with prg_obligations = (obls, rem) } in + if rem > 1 then ( + debug 2 (int rem ++ str " obligations remaining"); + from_prg := map_replace prg.prg_name prg' !from_prg) + else ( + declare_definition prg'; + from_prg := ProgMap.remove prg.prg_name !from_prg + ) + +let is_defined obls x = obls.(x).obl_body <> None + +let deps_remaining obls x = + let deps = obls.(x).obl_deps in + Intset.fold + (fun x acc -> + if is_defined obls x then acc + else x :: acc) + deps [] + +let subst_deps obls obl = + let t' = + Intset.fold + (fun x acc -> + let xobl = obls.(x) in + let oblb = out_some xobl.obl_body in + Term.subst1 oblb (Term.subst_var xobl.obl_name acc)) + obl.obl_deps obl.obl_type + in { obl with obl_type = t' } + +let subtac_obligation (user_num, name) = + let num = pred user_num in + let prg = get_prog name in + let obls, rem = prg.prg_obligations in + if num < Array.length obls then + let obl = obls.(num) in + match obl.obl_body with + None -> + (match deps_remaining obls num with + [] -> + let obl = subst_deps obls obl in + Command.start_proof obl.obl_name Subtac_utils.goal_proof_kind obl.obl_type + (fun strength gr -> + debug 2 (str "Proof of obligation " ++ int user_num ++ str " finished"); + let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + update_obls prg obls (pred rem)); + trace (str "Started obligation " ++ int user_num ++ str " proof") + | l -> msgnl (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " + ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))) + | Some r -> error "Obligation already solved" + else error (sprintf "Unknown obligation number %i" (succ num)) + + +let obligations_of_evars evars = + let arr = + Array.of_list + (List.map + (fun (n, t) -> + { obl_name = n; + obl_type = t; + obl_body = None; + obl_deps = Intset.empty; + }) evars) + in arr, Array.length arr + +let solve_obligations n tac = + let prg = get_prog n in + let obls, rem = prg.prg_obligations in + let rem = ref rem in + let obls' = + Array.map (fun x -> + match x.obl_body with + Some _ -> x + | None -> + try + let t = Subtac_utils.solve_by_tac (evar_of_obligation x) tac in + decr rem; + { x with obl_body = Some t } + with _ -> x) + obls + in + update_obls prg obls' !rem + +open Pp +let show_obligations n = + let prg = get_prog n in + let obls, rem = prg.prg_obligations in + msgnl (int rem ++ str " obligation(s) remaining: "); + Array.iteri (fun i x -> + match x.obl_body with + None -> msgnl (int (succ i) ++ str " : " ++ spc () ++ + my_print_constr (Global.env ()) x.obl_type) + | Some _ -> ()) + obls + diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli new file mode 100644 index 00000000..7d93d57b --- /dev/null +++ b/contrib/subtac/subtac_obligations.mli @@ -0,0 +1,10 @@ +open Util + +val add_entry : Names.identifier -> Term.constr -> Term.types -> + (Names.identifier * Term.types * Intset.t) array -> unit + +val subtac_obligation : int * Names.identifier option -> unit + +val solve_obligations : Names.identifier option -> Proof_type.tactic -> unit + +val show_obligations : Names.identifier option -> unit diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml index 261e0c5b..a243ba34 100644 --- a/contrib/subtac/subtac_pretyping.ml +++ b/contrib/subtac/subtac_pretyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping.ml 8889 2006-06-01 20:23:56Z msozeau $ *) +(* $Id: subtac_pretyping.ml 9326 2006-10-31 12:57:26Z msozeau $ *) open Global open Pp @@ -151,3 +151,13 @@ let subtac_process env isevars id l c tycon = let evm = non_instanciated_map env isevars in let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in evm, fullcoqc, fullctyp + +open Subtac_obligations + +let subtac_proof env isevars id l c tycon = + let nc = named_context env in + let nc_len = named_context_length nc in + let evm, coqc, coqt = subtac_process env isevars id l c tycon in + let evars, def = Eterm.eterm_obligations id nc_len evm coqc (Some coqt) in + trace (str "Adding to obligations list"); + add_entry id def coqt evars diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli index 97e56ecb..b62a8766 100644 --- a/contrib/subtac/subtac_pretyping.mli +++ b/contrib/subtac/subtac_pretyping.mli @@ -10,3 +10,6 @@ module Pretyping : Pretyping.S val subtac_process : env -> evar_defs ref -> identifier -> local_binder list -> constr_expr -> constr_expr option -> evar_map * constr * types + +val subtac_proof : env -> evar_defs ref -> identifier -> local_binder list -> + constr_expr -> constr_expr option -> unit diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml index 65952750..46af5886 100644 --- a/contrib/subtac/subtac_pretyping_F.ml +++ b/contrib/subtac/subtac_pretyping_F.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping_F.ml 8889 2006-06-01 20:23:56Z msozeau $ *) +(* $Id: subtac_pretyping_F.ml 9316 2006-10-29 22:49:11Z herbelin $ *) open Pp open Util @@ -315,12 +315,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in let resj = match kind_of_term resj.uj_val with - | App (f,args) when isInd f -> + | App (f,args) when isInd f or isConst f -> let sigma = evars_of !isevars in - let t = Retyping.type_of_inductive_knowing_parameters env sigma (destInd f) args in - let s = snd (splay_arity env sigma t) in - on_judgment_type (set_inductive_level env s) resj - (* Rem: no need to send sigma: no head evar, it's an arity *) + let c = mkApp (f,Array.map (whd_evar sigma) args) in + let t = Retyping.get_type_of env sigma c in + make_judge c t | _ -> resj in inh_conv_coerce_to_tycon loc env isevars resj tycon @@ -557,35 +556,6 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (pretype_type empty_valcon env isevars lvar c).utj_val in nf_evar (evars_of !isevars) c' - (* [check_evars] fails if some unresolved evar remains *) - (* it assumes that the defined existentials have already been substituted - (should be done in unsafe_infer and unsafe_infer_type) *) - - let check_evars env initial_sigma isevars c = - let sigma = evars_of !isevars in - let rec proc_rec c = - match kind_of_term c with - | Evar (ev,args) -> - assert (Evd.mem sigma ev); - if not (Evd.mem initial_sigma ev) then - let (loc,k) = evar_source ev !isevars in - error_unsolvable_implicit loc env sigma k - | _ -> iter_constr proc_rec c - in - proc_rec c(*; - let (_,pbs) = get_conv_pbs !isevars (fun _ -> true) in - if pbs <> [] then begin - pperrnl - (str"TYPING OF "++Termops.print_constr_env env c++fnl()++ - prlist_with_sep fnl - (fun (pb,c1,c2) -> - Termops.print_constr c1 ++ - (if pb=Reduction.CUMUL then str " <="++ spc() - else str" =="++spc()) ++ - Termops.print_constr c2) - pbs ++ fnl()) - end*) - (* TODO: comment faire remonter l'information si le typage a resolu des variables du sigma original. il faudrait que la fonction de typage retourne aussi le nouveau sigma... @@ -595,6 +565,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let isevars = ref (create_evar_defs sigma) in let j = pretype empty_tycon env isevars ([],[]) c in let j = j_nf_evar (evars_of !isevars) j in + let isevars,_ = consider_remaining_unif_problems env !isevars in check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type)); j @@ -611,8 +582,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let ise_pretype_gen fail_evar sigma env lvar kind c = let isevars = ref (Evd.create_evar_defs sigma) in let c = pretype_gen isevars env lvar kind c in + let isevars,_ = consider_remaining_unif_problems env !isevars in + let c = nf_evar (evars_of isevars) c in if fail_evar then check_evars env sigma isevars c; - !isevars, c + isevars, c (** Entry points of the high-level type synthesis algorithm *) diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml index d4db7c27..7b96758a 100644 --- a/contrib/subtac/subtac_utils.ml +++ b/contrib/subtac/subtac_utils.ml @@ -80,25 +80,34 @@ open Pp let my_print_constr = Termops.print_constr_env let my_print_constr_expr = Ppconstr.pr_constr_expr let my_print_context = Termops.print_rel_context +let my_print_named_context = Termops.print_named_context let my_print_env = Termops.print_env let my_print_rawconstr = Printer.pr_rawconstr_env let my_print_evardefs = Evd.pr_evar_defs let my_print_tycon_type = Evarutil.pr_tycon_type -let debug_level = 2 +let debug_level = 1 + +let debug_on = true let debug n s = - if !Options.debug && n >= debug_level then - msgnl s + if debug_on then + if !Options.debug && n >= debug_level then + msgnl s + else () else () let debug_msg n s = - if !Options.debug && n >= debug_level then s + if debug_on then + if !Options.debug && n >= debug_level then s + else mt () else mt () let trace s = - if !Options.debug && debug_level > 0 then msgnl s + if debug_on then + if !Options.debug && debug_level > 0 then msgnl s + else () else () let wf_relations = Hashtbl.create 10 @@ -167,30 +176,6 @@ let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixp open Tactics open Tacticals -let build_dependent_sum l = - let rec aux (tac, typ) = function - (n, t) :: tl -> - let t' = mkLambda (Name n, t, typ) in - trace (spc () ++ str ("treating evar " ^ string_of_id n)); - (try trace (str " assert: " ++ my_print_constr (Global.env ()) t) - with _ -> ()); - let tac' = - tclTHENS (assert_tac true (Name n) t) - ([intros; - (tclTHENSEQ - [constructor_tac (Some 1) 1 - (Rawterm.ImplicitBindings [mkVar n]); - tac]); - ]) - in - let newt = mkApp (Lazy.force ex_ind, [| t; t'; |]) in - aux (tac', newt) tl - | [] -> tac, typ - in - match l with - (_, hd) :: tl -> aux (intros, hd) tl - | [] -> raise (Invalid_argument "build_dependent_sum") - let id x = x let build_dependent_sum l = @@ -438,3 +423,32 @@ let rewrite_cases env c = let c' = rewrite_cases c in let _ = trace (str "Rewrote cases: " ++ spc () ++ my_print_rawconstr env c') in c' + +let id_of_name = function + Name n -> n + | Anonymous -> raise (Invalid_argument "id_of_name") + +let definition_message id = + Options.if_verbose message ((string_of_id id) ^ " is defined") + +let recursive_message v = + match Array.length v with + | 0 -> error "no recursive definition" + | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined") + | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++ + spc () ++ str "are recursively defined") + +(* Solve an obligation using tactics, return the corresponding proof term *) +let solve_by_tac ev t = + debug 1 (str "Solving goal using tactics: " ++ Evd.pr_evar_info ev); + let goal = Proof_trees.mk_goal ev.evar_hyps ev.evar_concl None in + let ts = Tacmach.mk_pftreestate goal in + let solved_state = Tacmach.solve_pftreestate t ts in + let c = Tacmach.extract_pftreestate solved_state in + debug 1 (str "Term constructed in solve by tac: " ++ my_print_constr (Global.env ()) c); + c + +let rec string_of_list sep f = function + [] -> "" + | x :: [] -> f x + | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli index 4a7e8177..ebfc5123 100644 --- a/contrib/subtac/subtac_utils.mli +++ b/contrib/subtac/subtac_utils.mli @@ -10,6 +10,7 @@ open Rawterm open Util open Evarutil open Names +open Sign val contrib_name : string val subtac_dir : string list @@ -51,6 +52,7 @@ val my_print_constr : env -> constr -> std_ppcmds val my_print_constr_expr : constr_expr -> std_ppcmds val my_print_evardefs : evar_defs -> std_ppcmds val my_print_context : env -> std_ppcmds +val my_print_named_context : env -> std_ppcmds val my_print_env : env -> std_ppcmds val my_print_rawconstr : env -> rawconstr -> std_ppcmds val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds @@ -88,3 +90,11 @@ val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> val destruct_ex : constr -> constr -> constr list val rewrite_cases : Environ.env -> Rawterm.rawconstr -> Rawterm.rawconstr +val id_of_name : name -> identifier + +val definition_message : identifier -> unit +val recursive_message : global_reference array -> std_ppcmds + +val solve_by_tac : evar_info -> Tacmach.tactic -> constr + +val string_of_list : string -> ('a -> string) -> 'a list -> string diff --git a/contrib/subtac/test/ListDep.v b/contrib/subtac/test/ListDep.v new file mode 100644 index 00000000..7ab720f6 --- /dev/null +++ b/contrib/subtac/test/ListDep.v @@ -0,0 +1,86 @@ +Require Import List. +Require Import Coq.subtac.Utils. + +Set Implicit Arguments. + +Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l. + +Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'. +Proof. + intros. + inversion H. + split. + intros. + apply H0. + auto with datatypes. + auto with arith. +Qed. + +Section Map_DependentRecursor. + Variable U V : Set. + Variable l : list U. + Variable f : { x : U | In x l } -> V. + + Program Fixpoint map_rec ( l' : list U | sub_list l' l ) + { measure l' length } : { r : list V | length r = length l' } := + match l' with + nil => nil + | cons x tl => let tl' := map_rec tl in + f x :: tl' + end. + + Obligation 1. + intros. + destruct tl' ; simpl ; simpl in e. + subst x0 tl0. + rewrite <- Heql'. + rewrite e. + auto. + Qed. + + Obligation 2. + simpl. + intros. + destruct l'. + simpl in Heql'. + destruct x0 ; simpl ; try discriminate. + inversion Heql'. + inversion s. + apply H. + auto with datatypes. + Qed. + + + Obligation 3 of map_rec. + simpl. + intros. + rewrite <- Heql'. + simpl ; auto with arith. + Qed. + + Obligation 4. + simpl. + intros. + destruct l'. + simpl in Heql'. + destruct x0 ; simpl ; try discriminate. + inversion Heql'. + subst x tl. + apply sub_list_tl with u ; auto. + Qed. + + Obligation 5. + intros. + rewrite <- Heql' ; auto. + Qed. + + Program Definition map : list V := map_rec l. + Obligation 1. + split ; auto. + Qed. + +End Map_DependentRecursor. + +Extraction map. +Extraction map_rec. + diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml index f217b037..ff07c3c4 100644 --- a/contrib/xml/cic2acic.ml +++ b/contrib/xml/cic2acic.ml @@ -241,7 +241,7 @@ let typeur sigma metamap = Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound")) | T.Const c -> let cb = Environ.lookup_constant c env in - T.body_of_type cb.Declarations.const_type + Typeops.type_of_constant_type env (cb.Declarations.const_type) | T.Evar ev -> Evd.existential_type sigma ev | T.Ind ind -> T.body_of_type (Inductiveops.type_of_inductive env ind) | T.Construct cstr -> diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml index a3336817..c7d3b4ff 100644 --- a/contrib/xml/doubleTypeInference.ml +++ b/contrib/xml/doubleTypeInference.ml @@ -122,7 +122,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Typeops.judge_of_variable env id | T.Const c -> - E.make_judge cstr (E.constant_type env c) + E.make_judge cstr (Typeops.type_of_constant env c) | T.Ind ind -> E.make_judge cstr (Inductiveops.type_of_inductive env ind) diff --git a/contrib/xml/proof2aproof.ml b/contrib/xml/proof2aproof.ml index 678b650c..92cbf6df 100644 --- a/contrib/xml/proof2aproof.ml +++ b/contrib/xml/proof2aproof.ml @@ -63,21 +63,24 @@ let nf_evar sigma ~preserve = (* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *) let rec unshare_proof_tree = let module PT = Proof_type in - function {PT.open_subgoals = status ; PT.goal = goal ; PT.ref = ref} -> + function {PT.open_subgoals = status ; + PT.goal = goal ; + PT.ref = ref} -> let unshared_ref = match ref with None -> None | Some (rule,pfs) -> let unshared_rule = match rule with - PT.Prim prim -> PT.Prim prim - | PT.Change_evars -> PT.Change_evars - | PT.Tactic (tactic_expr, pf) -> - PT.Tactic (tactic_expr, unshare_proof_tree pf) - in + PT.Nested (cmpd, pf) -> + PT.Nested (cmpd, unshare_proof_tree pf) + | other -> other + in Some (unshared_rule, List.map unshare_proof_tree pfs) in - {PT.open_subgoals = status ; PT.goal = goal ; PT.ref = unshared_ref} + {PT.open_subgoals = status ; + PT.goal = goal ; + PT.ref = unshared_ref} ;; module ProofTreeHash = @@ -103,7 +106,7 @@ let extract_open_proof sigma pf = {PT.ref=Some(PT.Prim _,_)} as pf -> L.prim_extractor proof_extractor vl pf - | {PT.ref=Some(PT.Tactic (_,hidden_proof),spfl)} -> + | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} -> let sgl,v = Refiner.frontier hidden_proof in let flat_proof = v spfl in ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ; diff --git a/contrib/xml/proofTree2Xml.ml4 b/contrib/xml/proofTree2Xml.ml4 index 578c1ed2..dbdc79a8 100644 --- a/contrib/xml/proofTree2Xml.ml4 +++ b/contrib/xml/proofTree2Xml.ml4 @@ -141,7 +141,7 @@ Pp.ppnl (Pp.(++) (Pp.str (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) | {PT.goal=goal; - PT.ref=Some(PT.Tactic (tactic_expr,hidden_proof),nodes)} -> + PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} -> (* [hidden_proof] is the proof of the tactic; *) (* [nodes] are the proof of the subgoals generated by the tactic; *) (* [flat_proof] if the proof-tree obtained substituting [nodes] *) @@ -194,6 +194,12 @@ Pp.ppnl (Pp.(++) (Pp.str (List.fold_left (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes) + | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} -> + Util.anomaly "Not Implemented" + + | {PT.ref=Some(PT.Daimon,_)} -> + X.xml_empty "Hidden_open_goal" of_attribute + | {PT.ref=None;PT.goal=goal} -> X.xml_empty "Open_goal" of_attribute in diff --git a/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml index b6b1c7b6..f286d2c8 100644 --- a/contrib/xml/xmlcommand.ml +++ b/contrib/xml/xmlcommand.ml @@ -408,7 +408,7 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite = let {D.mind_consnames=consnames ; D.mind_typename=typename } = p in - let arity = Inductive.type_of_inductive (mib,p) in + let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in let cons = (Array.fold_right (fun (name,lc) i -> (name,lc)::i) @@ -522,6 +522,7 @@ let print internal glob_ref kind xml_library_root = let id = N.id_of_label (N.con_label kn) in let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} = G.lookup_constant kn in + let typ = Typeops.type_of_constant_type (Global.env()) typ in Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps | Ln.IndRef (kn,_) -> let mib = G.lookup_mind kn in @@ -531,7 +532,7 @@ let print internal glob_ref kind xml_library_root = D.mind_finite=finite} = mib in Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite | Ln.ConstructRef _ -> - Util.anomaly ("print: this should not happen") + Util.error ("a single constructor cannot be printed in XML") in let fn = filename_of_path xml_library_root tag in let uri = Cic2acic.uri_of_kernel_name tag in @@ -547,14 +548,12 @@ let print_ref qid fn = (* where dest is either None (for stdout) or (Some filename) *) (* pretty prints via Xml.pp the proof in progress on dest *) let show_pftreestate internal fn (kind,pftst) id = - let str = Names.string_of_id id in let pf = Tacmach.proof_of_pftreestate pftst in let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree, unshared_pf = Proof2aproof.extract_open_pftreestate pftst in - let kn = Lib.make_kn id in let env = Global.env () in let obj = mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in |