diff options
Diffstat (limited to 'plugins')
238 files changed, 19389 insertions, 12794 deletions
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 3c40cfb9..1c021eee 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccalgo.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - (* This file implements the basic congruence-closure algorithm by *) (* Downey,Sethi and Tarjan. *) @@ -30,6 +28,7 @@ let debug f x = let _= let gdopt= { optsync=true; + optdepr=false; optname="Congruence Verbose"; optkey=["Congruence";"Verbose"]; optread=(fun ()-> !cc_verbose); @@ -105,6 +104,26 @@ type term= | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) +let rec term_equal t1 t2 = + match t1, t2 with + | Symb c1, Symb c2 -> eq_constr c1 c2 + | Product (s1, t1), Product (s2, t2) -> s1 = s2 && t1 = t2 + | Eps i1, Eps i2 -> id_ord i1 i2 = 0 + | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2 + | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1}, + Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} -> + i1 = i2 && j1 = j2 && eq_constructor c1 c2 + | _ -> t1 = t2 + +open Hashtbl_alt.Combine + +let rec hash_term = function + | Symb c -> combine 1 (hash_constr c) + | Product (s1, s2) -> combine3 2 (Hashtbl.hash s1) (Hashtbl.hash s2) + | Eps i -> combine 3 (Hashtbl.hash i) + | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) + | Constructor {ci_constr=c; ci_arity=i; ci_nhyps=j} -> combine4 5 (Hashtbl.hash c) i j + type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) | PVar of int @@ -172,13 +191,32 @@ type node = vertex:vertex; term:term} +module Constrhash = Hashtbl.Make + (struct type t = constr + let equal = eq_constr + let hash = hash_constr + end) +module Typehash = Constrhash + +module Termhash = Hashtbl.Make + (struct type t = term + let equal = term_equal + let hash = hash_term + end) + +module Identhash = Hashtbl.Make + (struct type t = identifier + let equal = Pervasives.(=) + let hash = Hashtbl.hash + end) + type forest= {mutable max_size:int; mutable size:int; mutable map: node array; - axioms: (constr,term*term) Hashtbl.t; + axioms: (term*term) Constrhash.t; mutable epsilons: pa_constructor list; - syms:(term,int) Hashtbl.t} + syms: int Termhash.t} type state = {uf: forest; @@ -189,10 +227,10 @@ type state = mutable diseq: disequality list; mutable quant: quant_eq list; mutable pa_classes: Intset.t; - q_history: (identifier,int array) Hashtbl.t; + q_history: (int array) Identhash.t; mutable rew_depth:int; mutable changed:bool; - by_type: (types,Intset.t) Hashtbl.t; + by_type: Intset.t Typehash.t; mutable gls:Proof_type.goal Tacmach.sigma} let dummy_node = @@ -207,8 +245,8 @@ let empty depth gls:state = size=0; map=Array.create init_size dummy_node; epsilons=[]; - axioms=Hashtbl.create init_size; - syms=Hashtbl.create init_size}; + axioms=Constrhash.create init_size; + syms=Termhash.create init_size}; terms=Intset.empty; combine=Queue.create (); marks=Queue.create (); @@ -216,9 +254,9 @@ let empty depth gls:state = diseq=[]; quant=[]; pa_classes=Intset.empty; - q_history=Hashtbl.create init_size; + q_history=Identhash.create init_size; rew_depth=depth; - by_type=Hashtbl.create init_size; + by_type=Constrhash.create init_size; changed=false; gls=gls} @@ -366,7 +404,8 @@ let rec canonize_name c = let build_subst uf subst = Array.map (fun i -> try term uf i - with _ -> anomaly "incomplete matching") subst + with e when Errors.noncritical e -> + anomaly "incomplete matching") subst let rec inst_pattern subst = function PVar i -> @@ -384,7 +423,7 @@ let pr_term t = str "[" ++ let rec add_term state t= let uf=state.uf in - try Hashtbl.find uf.syms t with + try Termhash.find uf.syms t with Not_found -> let b=next uf in let typ = pf_type_of state.gls (constr_of_term t) in @@ -430,10 +469,10 @@ let rec add_term state t= term=t} in uf.map.(b)<-new_node; - Hashtbl.add uf.syms t b; - Hashtbl.replace state.by_type typ + Termhash.add uf.syms t b; + Typehash.replace state.by_type typ (Intset.add b - (try Hashtbl.find state.by_type typ with + (try Typehash.find state.by_type typ with Not_found -> Intset.empty)); b @@ -441,7 +480,7 @@ let add_equality state c s t= let i = add_term state s in let j = add_term state t in Queue.add {lhs=i;rhs=j;rule=Axiom(c,false)} state.combine; - Hashtbl.add state.uf.axioms c (s,t) + Constrhash.add state.uf.axioms c (s,t) let add_disequality state from s t = let i = add_term state s in @@ -461,7 +500,7 @@ let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) = let is_redundant state id args = try let norm_args = Array.map (find state.uf) args in - let prev_args = Hashtbl.find_all state.q_history id in + let prev_args = Identhash.find_all state.q_history id in List.exists (fun old_args -> Util.array_for_all2 (fun i j -> i = find state.uf j) @@ -476,7 +515,7 @@ let add_inst state (inst,int_subst) = debug msgnl (str "discarding redundant (dis)equality") else begin - Hashtbl.add state.q_history inst.qe_hyp_id int_subst; + Identhash.add state.q_history inst.qe_hyp_id int_subst; let subst = build_subst (forest state) int_subst in let prfhead= mkVar inst.qe_hyp_id in let args = Array.map constr_of_term subst in @@ -532,9 +571,9 @@ let union state i1 i2 eq= let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in link state.uf i1 i2 eq; - Hashtbl.replace state.by_type r1.class_type + Constrhash.replace state.by_type r1.class_type (Intset.remove i1 - (try Hashtbl.find state.by_type r1.class_type with + (try Constrhash.find state.by_type r1.class_type with Not_found -> Intset.empty)); let f= Intset.union r1.fathers r2.fathers in r2.weight<-Intset.cardinal f; @@ -691,11 +730,9 @@ let __eps__ = id_of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in - state.gls<- - {state.gls with it = - {state.gls.it with evar_hyps = - Environ.push_named_context_val (id,None,typ) - state.gls.it.evar_hyps}}; + let {it=gl ; sigma=sigma} = state.gls in + let gls = Goal.V82.new_goal_with sigma gl [id,None,typ] in + state.gls<- gls; id let complete_one_class state i= @@ -763,14 +800,14 @@ let rec do_match state res pb_stack = else (* mismatch for non-linear variable in pattern *) () | PApp (f,[]) -> begin - try let j=Hashtbl.find uf.syms f in + try let j=Termhash.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 j=Termhash.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 @@ -788,7 +825,7 @@ let rec do_match state res pb_stack = let paf_of_patt syms = function PVar _ -> invalid_arg "paf_of_patt: pattern is trivial" | PApp (f,args) -> - {fsym=Hashtbl.find syms f; + {fsym=Termhash.find syms f; fnargs=List.length args} let init_pb_stack state = @@ -810,7 +847,7 @@ let init_pb_stack state = | Trivial typ -> begin try - Hashtbl.find state.by_type typ + Typehash.find state.by_type typ with Not_found -> Intset.empty end in Intset.iter (fun i -> @@ -833,7 +870,7 @@ let init_pb_stack state = | Trivial typ -> begin try - Hashtbl.find state.by_type typ + Typehash.find state.by_type typ with Not_found -> Intset.empty end in Intset.iter (fun i -> diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 8786c907..9653da2c 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccalgo.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - open Util open Term open Names @@ -24,6 +22,8 @@ type term = | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) +val term_equal : term -> term -> bool + type patt_kind = Normal | Trivial of types @@ -66,13 +66,16 @@ type explanation = | Contradiction of disequality | Incomplete +module Constrhash : Hashtbl.S with type key = constr +module Termhash : Hashtbl.S with type key = term + val constr_of_term : term -> constr val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit val forest : state -> forest -val axioms : forest -> (constr, term * term) Hashtbl.t +val axioms : forest -> (term * term) Constrhash.t val epsilons : forest -> pa_constructor list @@ -127,7 +130,7 @@ val do_match : state -> val init_pb_stack : state -> matching_problem Stack.t -val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun +val paf_of_patt : int Termhash.t -> ccpattern -> pa_fun val find_instances : state -> (quant_eq * int array) list diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 6981c5a0..c5bbd105 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - (* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) @@ -45,7 +43,7 @@ let rec ptrans p1 p3= | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) -> ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 | _, _ -> - if p1.p_rhs = p3.p_lhs then + if term_equal p1.p_rhs p3.p_lhs then {p_lhs=p1.p_lhs; p_rhs=p3.p_rhs; p_rule=Trans (p1,p3)} @@ -70,13 +68,13 @@ let rec psym p = | Congr (p1,p2)-> pcongr (psym p1) (psym p2) let pax axioms s = - let l,r = Hashtbl.find axioms s in + let l,r = Constrhash.find axioms s in {p_lhs=l; p_rhs=r; p_rule=Ax s} let psymax axioms s = - let l,r = Hashtbl.find axioms s in + let l,r = Constrhash.find axioms s in {p_lhs=r; p_rhs=l; p_rule=SymAx s} diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index a58637f9..b8a8d229 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ccproof.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - open Ccalgo open Names open Term diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 5b477b4d..764e36b0 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: cctac.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - (* This file is the interface between the c-c algorithm and Coq *) open Evd @@ -20,7 +18,6 @@ open Nameops open Inductiveops open Declarations open Term -open Termops open Tacmach open Tactics open Tacticals @@ -38,11 +35,11 @@ let _f_equal = constant ["Init";"Logic"] "f_equal" let _eq_rect = constant ["Init";"Logic"] "eq_rect" -let _refl_equal = constant ["Init";"Logic"] "refl_equal" +let _refl_equal = constant ["Init";"Logic"] "eq_refl" -let _sym_eq = constant ["Init";"Logic"] "sym_eq" +let _sym_eq = constant ["Init";"Logic"] "eq_sym" -let _trans_eq = constant ["Init";"Logic"] "trans_eq" +let _trans_eq = constant ["Init";"Logic"] "eq_trans" let _eq = constant ["Init";"Logic"] "eq" @@ -66,8 +63,8 @@ let rec decompose_term env sigma t= let tf=decompose_term env sigma f in let targs=Array.map (decompose_term env sigma) args in Array.fold_left (fun s t->Appli (s,t)) tf targs - | Prod (_,a,_b) when not (dependent (mkRel 1) _b) -> - let b = pop _b in + | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> + let b = Termops.pop _b in let sort_b = sf_of env sigma b in let sort_a = sf_of env sigma a in Appli(Appli(Product (sort_a,sort_b) , @@ -113,8 +110,8 @@ let rec pattern_of_constr env sigma c = (array_map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), List.fold_left Intset.union Intset.empty lrels - | Prod (_,a,_b) when not (dependent (mkRel 1) _b) -> - let b =pop _b in + | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> + let b = Termops.pop _b in let pa,sa = pattern_of_constr env sigma a in let pb,sb = pattern_of_constr env sigma b in let sort_b = sf_of env sigma b in @@ -132,7 +129,9 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= - try destApp (whd_delta env term) with _ -> raise Not_found in + try destApp (whd_delta env term) + with e when Errors.noncritical e -> raise Not_found + in if eq_constr f (Lazy.force _eq) && (Array.length args)=3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) @@ -214,9 +213,9 @@ let rec make_prb gls depth additionnal_terms = 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); + end) (Environ.named_context_of_val (Goal.V82.hyps gls.sigma gls.it)); begin - match atom_of_constr env sigma gls.it.evar_concl with + match atom_of_constr env sigma (pf_concl gls) with `Eq (t,a,b) -> add_disequality state Goal a b | `Other g -> List.iter @@ -260,19 +259,19 @@ let rec proof_tac p gls = | SymAx c -> let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in - let typ = refresh_universes (pf_type_of gls l) in + let typ = Termops.refresh_universes (pf_type_of gls l) in exact_check (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls | Refl t -> let lr = constr_of_term t in - let typ = refresh_universes (pf_type_of gls lr) in + let typ = Termops.refresh_universes (pf_type_of gls lr) in exact_check (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in - let typ = refresh_universes (pf_type_of gls t2) in + let typ = Termops.refresh_universes (pf_type_of gls t2) in let prf = mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls @@ -281,9 +280,9 @@ let rec proof_tac p gls = and tx1=constr_of_term p2.p_lhs and tf2=constr_of_term p1.p_rhs and tx2=constr_of_term p2.p_rhs in - let typf = refresh_universes (pf_type_of gls tf1) in - let typx = refresh_universes (pf_type_of gls tx1) in - let typfx = refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in + let typf = Termops.refresh_universes (pf_type_of gls tf1) in + let typx = Termops.refresh_universes (pf_type_of gls tx1) in + let typfx = Termops.refresh_universes (pf_type_of gls (mkApp (tf1,[|tx1|]))) in let id = pf_get_new_id (id_of_string "f") gls in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = @@ -311,8 +310,8 @@ let rec proof_tac p gls = let ti=constr_of_term prf.p_lhs in let tj=constr_of_term prf.p_rhs in let default=constr_of_term p.p_lhs in - let intype=refresh_universes (pf_type_of gls ti) in - let outtype=refresh_universes (pf_type_of gls default) in + let intype = Termops.refresh_universes (pf_type_of gls ti) in + let outtype = Termops.refresh_universes (pf_type_of gls default) in let special=mkRel (1+nargs-argind) in let proj=build_projection intype outtype cstr special default gls in let injt= @@ -321,7 +320,7 @@ let rec proof_tac p gls = let refute_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let intype=refresh_universes (pf_type_of gls tt1) in + let intype = Termops.refresh_universes (pf_type_of gls tt1) in let neweq= mkApp(Lazy.force _eq, [|intype;tt1;tt2|]) in @@ -332,7 +331,7 @@ let refute_tac c t1 t2 p gls = let convert_to_goal_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let sort=refresh_universes (pf_type_of gls tt2) in + let sort = Termops.refresh_universes (pf_type_of gls tt2) in let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in let e=pf_get_new_id (id_of_string "e") gls in let x=pf_get_new_id (id_of_string "X") gls in @@ -352,14 +351,14 @@ let convert_to_hyp_tac c1 t1 c2 t2 p gls = let discriminate_tac cstr p gls = let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in - let intype=refresh_universes (pf_type_of gls t1) in + let intype = Termops.refresh_universes (pf_type_of gls t1) in let concl=pf_concl gls in - let outsort=mkType (new_univ ()) in + let outsort = mkType (Termops.new_univ ()) in let xid=pf_get_new_id (id_of_string "X") gls in let tid=pf_get_new_id (id_of_string "t") gls in let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in let trivial=pf_type_of gls identity in - let outtype=mkType (new_univ ()) in + let outtype = mkType (Termops.new_univ ()) in let pred=mkLambda(Name xid,outtype,mkRel 1) in let hid=pf_get_new_id (id_of_string "Heq") gls in let proj=build_projection intype outtype cstr trivial concl gls in @@ -414,7 +413,7 @@ let cc_tactic depth additionnal_terms gls= str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ pr_spc () ++ str "(") - (print_constr_env (pf_env gls)) + (Termops.print_constr_env (pf_env gls)) terms_to_complete ++ str ")\"," end); @@ -456,7 +455,7 @@ let simple_reflexivity () = apply (Lazy.force _refl_equal) let f_equal gl = let cut_eq c1 c2 = - let ty = refresh_universes (pf_type_of gl c1) in + let ty = Termops.refresh_universes (pf_type_of gl c1) in tclTHENTRY (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) (simple_reflexivity ()) diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index b3d5c16b..365c172c 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: cctac.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - open Term open Proof_type diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index eb58c5eb..c9805f02 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_congruence.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Cctac open Tactics open Tacticals diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli new file mode 100644 index 00000000..69b0a0e3 --- /dev/null +++ b/plugins/decl_mode/decl_expr.mli @@ -0,0 +1,103 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Util +open Tacexpr + +type 'it statement = + {st_label:name; + st_it:'it} + +type thesis_kind = + Plain + | For of identifier + +type 'this or_thesis = + This of 'this + | Thesis of thesis_kind + +type side = Lhs | Rhs + +type elim_type = + ET_Case_analysis + | ET_Induction + +type block_type = + B_proof + | B_claim + | B_focus + | B_elim of elim_type + +type ('it,'constr,'tac) cut = + {cut_stat: 'it; + cut_by: 'constr list option; + cut_using: 'tac option} + +type ('var,'constr) hyp = + Hvar of 'var + | Hprop of 'constr statement + +type ('constr,'tac) casee = + Real of 'constr + | Virtual of ('constr statement,'constr,'tac) cut + +type ('hyp,'constr,'pat,'tac) bare_proof_instr = + | Pthen of ('hyp,'constr,'pat,'tac) bare_proof_instr + | Pthus of ('hyp,'constr,'pat,'tac) bare_proof_instr + | Phence of ('hyp,'constr,'pat,'tac) bare_proof_instr + | Pcut of ('constr or_thesis statement,'constr,'tac) cut + | Prew of side * ('constr statement,'constr,'tac) cut + | Psuffices of ((('hyp,'constr) hyp list * 'constr or_thesis),'constr,'tac) cut + | Passume of ('hyp,'constr) hyp list + | Plet of ('hyp,'constr) hyp list + | Pgiven of ('hyp,'constr) hyp list + | Pconsider of 'constr*('hyp,'constr) hyp list + | Pclaim of 'constr statement + | Pfocus of 'constr statement + | Pdefine of identifier * 'hyp list * 'constr + | Pcast of identifier or_thesis * 'constr + | Psuppose of ('hyp,'constr) hyp list + | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list) + | Ptake of 'constr list + | Pper of elim_type * ('constr,'tac) casee + | Pend of block_type + | Pescape + +type emphasis = int + +type ('hyp,'constr,'pat,'tac) gen_proof_instr= + {emph: emphasis; + instr: ('hyp,'constr,'pat,'tac) bare_proof_instr } + + +type raw_proof_instr = + ((identifier*(Topconstr.constr_expr option)) located, + Topconstr.constr_expr, + Topconstr.cases_pattern_expr, + raw_tactic_expr) gen_proof_instr + +type glob_proof_instr = + ((identifier*(Genarg.glob_constr_and_expr option)) located, + Genarg.glob_constr_and_expr, + Topconstr.cases_pattern_expr, + Tacexpr.glob_tactic_expr) gen_proof_instr + +type proof_pattern = + {pat_vars: Term.types statement list; + pat_aliases: (Term.constr*Term.types) statement list; + pat_constr: Term.constr; + pat_typ: Term.types; + pat_pat: Glob_term.cases_pattern; + pat_expr: Topconstr.cases_pattern_expr} + +type proof_instr = + (Term.constr statement, + Term.constr, + proof_pattern, + Tacexpr.glob_tactic_expr) gen_proof_instr diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml new file mode 100644 index 00000000..7637fed2 --- /dev/null +++ b/plugins/decl_mode/decl_interp.ml @@ -0,0 +1,471 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Topconstr +open Tacinterp +open Tacmach +open Decl_expr +open Decl_mode +open Pretyping.Default +open Glob_term +open Term +open Pp +open Compat + +(* INTERN *) + +let glob_app (loc,hd,args) = if args =[] then hd else GApp(loc,hd,args) + +let intern_justification_items globs = + Option.map (List.map (intern_constr globs)) + +let intern_justification_method globs = + Option.map (intern_pure_tactic globs) + +let intern_statement intern_it globs st = + {st_label=st.st_label; + st_it=intern_it globs st.st_it} + +let intern_no_bind intern_it globs x = + globs,intern_it globs x + +let intern_constr_or_thesis globs = function + Thesis n -> Thesis n + | This c -> This (intern_constr globs c) + +let add_var id globs= + let l1,l2=globs.ltacvars in + {globs with ltacvars= (id::l1),(id::l2)} + +let add_name nam globs= + match nam with + Anonymous -> globs + | Name id -> add_var id globs + +let intern_hyp iconstr globs = function + Hvar (loc,(id,topt)) -> add_var id globs, + Hvar (loc,(id,Option.map (intern_constr globs) topt)) + | Hprop st -> add_name st.st_label globs, + Hprop (intern_statement iconstr globs st) + +let intern_hyps iconstr globs hyps = + snd (list_fold_map (intern_hyp iconstr) globs hyps) + +let intern_cut intern_it globs cut= + let nglobs,nstat=intern_it globs cut.cut_stat in + {cut_stat=nstat; + cut_by=intern_justification_items nglobs cut.cut_by; + cut_using=intern_justification_method nglobs cut.cut_using} + +let intern_casee globs = function + Real c -> Real (intern_constr globs c) + | Virtual cut -> Virtual + (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) + +let intern_hyp_list args globs = + let intern_one globs (loc,(id,opttyp)) = + (add_var id globs), + (loc,(id,Option.map (intern_constr globs) opttyp)) in + list_fold_map intern_one globs args + +let intern_suffices_clause globs (hyps,c) = + let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in + nglobs,(nhyps,intern_constr_or_thesis nglobs c) + +let intern_fundecl args body globs= + let nglobs,nargs = intern_hyp_list args globs in + nargs,intern_constr nglobs body + +let rec add_vars_of_simple_pattern globs = function + CPatAlias (loc,p,id) -> + add_vars_of_simple_pattern (add_var id globs) p +(* Loc.raise loc + (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) + | CPatOr (loc, _)-> + Loc.raise loc + (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) + | CPatDelimiters (_,_,p) -> + add_vars_of_simple_pattern globs p + | CPatCstr (_,_,pl) | CPatCstrExpl (_,_,pl) -> + List.fold_left add_vars_of_simple_pattern globs pl + | CPatNotation(_,_,(pl,pll)) -> + List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) + | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs + | _ -> globs + +let rec intern_bare_proof_instr globs = function + Pthus i -> Pthus (intern_bare_proof_instr globs i) + | Pthen i -> Pthen (intern_bare_proof_instr globs i) + | Phence i -> Phence (intern_bare_proof_instr globs i) + | Pcut c -> Pcut + (intern_cut + (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c) + | Psuffices c -> + Psuffices (intern_cut intern_suffices_clause globs c) + | Prew (s,c) -> Prew + (s,intern_cut + (intern_no_bind (intern_statement intern_constr)) globs c) + | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps) + | Pcase (params,pat,hyps) -> + let nglobs,nparams = intern_hyp_list params globs in + let nnglobs= add_vars_of_simple_pattern nglobs pat in + let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in + Pcase (nparams,pat,nhyps) + | Ptake witl -> Ptake (List.map (intern_constr globs) witl) + | Pconsider (c,hyps) -> Pconsider (intern_constr globs c, + intern_hyps intern_constr globs hyps) + | Pper (et,c) -> Pper (et,intern_casee globs c) + | Pend bt -> Pend bt + | Pescape -> Pescape + | Passume hyps -> Passume (intern_hyps intern_constr globs hyps) + | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps) + | Plet hyps -> Plet (intern_hyps intern_constr globs hyps) + | Pclaim st -> Pclaim (intern_statement intern_constr globs st) + | Pfocus st -> Pfocus (intern_statement intern_constr globs st) + | Pdefine (id,args,body) -> + let nargs,nbody = intern_fundecl args body globs in + Pdefine (id,nargs,nbody) + | Pcast (id,typ) -> + Pcast (id,intern_constr globs typ) + +let rec intern_proof_instr globs instr= + {emph = instr.emph; + instr = intern_bare_proof_instr globs instr.instr} + +(* INTERP *) + +let interp_justification_items sigma env = + Option.map (List.map (fun c ->understand sigma env (fst c))) + +let interp_constr check_sort sigma env c = + if check_sort then + understand_type sigma env (fst c) + else + understand sigma env (fst c) + +let special_whd env = + let infos=Closure.create_clos_infos Closure.betadeltaiota env in + (fun t -> Closure.whd_val infos (Closure.inject t)) + +let _eq = Libnames.constr_of_global (Coqlib.glob_eq) + +let decompose_eq env id = + let typ = Environ.named_type id env in + let whd = special_whd env typ in + match kind_of_term whd with + App (f,args)-> + if eq_constr f _eq && (Array.length args)=3 + then args.(0) + else error "Previous step is not an equality." + | _ -> error "Previous step is not an equality." + +let get_eq_typ info env = + let typ = decompose_eq env (get_last env) in + typ + +let interp_constr_in_type typ sigma env c = + understand sigma env (fst c) ~expected_type:typ + +let interp_statement interp_it sigma env st = + {st_label=st.st_label; + st_it=interp_it sigma env st.st_it} + +let interp_constr_or_thesis check_sort sigma env = function + Thesis n -> Thesis n + | This c -> This (interp_constr check_sort sigma env c) + +let abstract_one_hyp inject h glob = + match h with + Hvar (loc,(id,None)) -> + GProd (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob) + | Hvar (loc,(id,Some typ)) -> + GProd (dummy_loc,Name id, Explicit, fst typ, glob) + | Hprop st -> + GProd (dummy_loc,st.st_label, Explicit, inject st.st_it, glob) + +let glob_constr_of_hyps inject hyps head = + List.fold_right (abstract_one_hyp inject) hyps head + +let glob_prop = GSort (dummy_loc,GProp Null) + +let rec match_hyps blend names constr = function + [] -> [],substl names constr + | hyp::q -> + let (name,typ,body)=destProd constr in + let st= {st_label=name;st_it=substl names typ} in + let qnames= + match name with + Anonymous -> mkMeta 0 :: names + | Name id -> mkVar id :: names in + let qhyp = match hyp with + Hprop st' -> Hprop (blend st st') + | Hvar _ -> Hvar st in + let rhyps,head = match_hyps blend qnames body q in + qhyp::rhyps,head + +let interp_hyps_gen inject blend sigma env hyps head = + let constr=understand sigma env (glob_constr_of_hyps inject hyps head) in + match_hyps blend [] constr hyps + +let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop) + +let dummy_prefix= id_of_string "__" + +let rec deanonymize ids = + function + PatVar (loc,Anonymous) -> + let (found,known) = !ids in + let new_id=Namegen.next_ident_away dummy_prefix known in + let _= ids:= (loc,new_id) :: found , new_id :: known in + PatVar (loc,Name new_id) + | PatVar (loc,Name id) as pat -> + let (found,known) = !ids in + let _= ids:= (loc,id) :: found , known in + pat + | PatCstr(loc,cstr,lpat,nam) -> + PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam) + +let rec glob_of_pat = + function + PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" + | PatVar (loc,Name id) -> + GVar (loc,id) + | PatCstr(loc,((ind,_) as cstr),lpat,_) -> + let mind= fst (Global.lookup_inductive ind) in + let rec add_params n q = + if n<=0 then q else + add_params (pred n) (GHole(dummy_loc, + Evd.TomatchTypeParameter(ind,n))::q) in + let args = List.map glob_of_pat lpat in + glob_app(loc,GRef(dummy_loc,Libnames.ConstructRef cstr), + add_params mind.Declarations.mind_nparams args) + +let prod_one_hyp = function + (loc,(id,None)) -> + (fun glob -> + GProd (dummy_loc,Name id, Explicit, + GHole (loc,Evd.BinderType (Name id)), glob)) + | (loc,(id,Some typ)) -> + (fun glob -> + GProd (dummy_loc,Name id, Explicit, fst typ, glob)) + +let prod_one_id (loc,id) glob = + GProd (dummy_loc,Name id, Explicit, + GHole (loc,Evd.BinderType (Name id)), glob) + +let let_in_one_alias (id,pat) glob = + GLetIn (dummy_loc,Name id, glob_of_pat pat, glob) + +let rec bind_primary_aliases map pat = + match pat with + PatVar (_,_) -> map + | PatCstr(loc,_,lpat,nam) -> + let map1 = + match nam with + Anonymous -> map + | Name id -> (id,pat)::map + in + List.fold_left bind_primary_aliases map1 lpat + +let bind_secondary_aliases map subst = + List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst + +let bind_aliases patvars subst patt = + let map = bind_primary_aliases [] patt in + let map1 = bind_secondary_aliases map subst in + List.rev map1 + +let interp_pattern env pat_expr = + let patvars,pats = Constrintern.intern_pattern env pat_expr in + match pats with + [] -> anomaly "empty pattern list" + | [subst,patt] -> + (patvars,bind_aliases patvars subst patt,patt) + | _ -> anomaly "undetected disjunctive pattern" + +let rec match_args dest names constr = function + [] -> [],names,substl names constr + | _::q -> + let (name,typ,body)=dest constr in + let st={st_label=name;st_it=substl names typ} in + let qnames= + match name with + Anonymous -> assert false + | Name id -> mkVar id :: names in + let args,bnames,body = match_args dest qnames body q in + st::args,bnames,body + +let rec match_aliases names constr = function + [] -> [],names,substl names constr + | _::q -> + let (name,c,typ,body)=destLetIn constr in + let st={st_label=name;st_it=(substl names c,substl names typ)} in + let qnames= + match name with + Anonymous -> assert false + | Name id -> mkVar id :: names in + let args,bnames,body = match_aliases qnames body q in + st::args,bnames,body + +let detype_ground c = Detyping.detype false [] [] c + +let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = + let et,pinfo = + match info.pm_stack with + Per(et,pi,_,_)::_ -> et,pi + | _ -> error "No proof per cases/induction/inversion in progress." in + let mib,oib=Global.lookup_inductive pinfo.per_ind in + let num_params = pinfo.per_nparams in + let _ = + let expected = mib.Declarations.mind_nparams - num_params in + if List.length params <> expected then + errorlabstrm "suppose it is" + (str "Wrong number of extra arguments: " ++ + (if expected = 0 then str "none" else int expected) ++ spc () ++ + str "expected.") in + let app_ind = + let rind = GRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in + let rparams = List.map detype_ground pinfo.per_params in + let rparams_rec = + List.map + (fun (loc,(id,_)) -> + GVar (loc,id)) params in + let dum_args= + list_tabulate (fun _ -> GHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) + oib.Declarations.mind_nrealargs in + glob_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in + let pat_vars,aliases,patt = interp_pattern env pat in + let inject = function + Thesis (Plain) -> Glob_term.GSort(dummy_loc,GProp Null) + | Thesis (For rec_occ) -> + if not (List.mem rec_occ pat_vars) then + errorlabstrm "suppose it is" + (str "Variable " ++ Nameops.pr_id rec_occ ++ + str " does not occur in pattern."); + Glob_term.GSort(dummy_loc,GProp Null) + | This (c,_) -> c in + let term1 = glob_constr_of_hyps inject hyps glob_prop in + let loc_ids,npatt = + let rids=ref ([],pat_vars) in + let npatt= deanonymize rids patt in + List.rev (fst !rids),npatt in + let term2 = + GLetIn(dummy_loc,Anonymous, + GCast(dummy_loc,glob_of_pat npatt, + CastConv (DEFAULTcast,app_ind)),term1) in + let term3=List.fold_right let_in_one_alias aliases term2 in + let term4=List.fold_right prod_one_id loc_ids term3 in + let term5=List.fold_right prod_one_hyp params term4 in + let constr = understand sigma env term5 in + let tparams,nam4,rest4 = match_args destProd [] constr params in + let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in + let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in + let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in + let blend st st' = + match st'.st_it with + Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} + | This _ -> {st_it = This st.st_it;st_label=st.st_label} in + let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in + tparams,{pat_vars=tpatvars; + pat_aliases=taliases; + pat_constr=pat_pat; + pat_typ=pat_typ; + pat_pat=patt; + pat_expr=pat},thyps + +let interp_cut interp_it sigma env cut= + let nenv,nstat = interp_it sigma env cut.cut_stat in + {cut with + cut_stat=nstat; + cut_by=interp_justification_items sigma nenv cut.cut_by} + +let interp_no_bind interp_it sigma env x = + env,interp_it sigma env x + +let interp_suffices_clause sigma env (hyps,cot)= + let (locvars,_) as res = + match cot with + This (c,_) -> + let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in + nhyps,This nc + | Thesis Plain as th -> interp_hyps sigma env hyps,th + | Thesis (For n) -> error "\"thesis for\" is not applicable here." in + let push_one hyp env0 = + match hyp with + (Hprop st | Hvar st) -> + match st.st_label with + Name id -> Environ.push_named (id,None,st.st_it) env0 + | _ -> env in + let nenv = List.fold_right push_one locvars env in + nenv,res + +let interp_casee sigma env = function + Real c -> Real (understand sigma env (fst c)) + | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) + +let abstract_one_arg = function + (loc,(id,None)) -> + (fun glob -> + GLambda (dummy_loc,Name id, Explicit, + GHole (loc,Evd.BinderType (Name id)), glob)) + | (loc,(id,Some typ)) -> + (fun glob -> + GLambda (dummy_loc,Name id, Explicit, fst typ, glob)) + +let glob_constr_of_fun args body = + List.fold_right abstract_one_arg args (fst body) + +let interp_fun sigma env args body = + let constr=understand sigma env (glob_constr_of_fun args body) in + match_args destLambda [] constr args + +let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function + Pthus i -> Pthus (interp_bare_proof_instr info sigma env i) + | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i) + | Phence i -> Phence (interp_bare_proof_instr info sigma env i) + | Pcut c -> Pcut (interp_cut + (interp_no_bind (interp_statement + (interp_constr_or_thesis true))) + sigma env c) + | Psuffices c -> + Psuffices (interp_cut interp_suffices_clause sigma env c) + | Prew (s,c) -> Prew (s,interp_cut + (interp_no_bind (interp_statement + (interp_constr_in_type (get_eq_typ info env)))) + sigma env c) + + | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps) + | Pcase (params,pat,hyps) -> + let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in + Pcase (tparams,tpat,thyps) + | Ptake witl -> + Ptake (List.map (fun c -> understand sigma env (fst c)) witl) + | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, + interp_hyps sigma env hyps) + | Pper (et,c) -> Pper (et,interp_casee sigma env c) + | Pend bt -> Pend bt + | Pescape -> Pescape + | Passume hyps -> Passume (interp_hyps sigma env hyps) + | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps) + | Plet hyps -> Plet (interp_hyps sigma env hyps) + | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st) + | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st) + | Pdefine (id,args,body) -> + let nargs,_,nbody = interp_fun sigma env args body in + Pdefine (id,nargs,nbody) + | Pcast (id,typ) -> + Pcast(id,interp_constr true sigma env typ) + +let rec interp_proof_instr info sigma env instr= + {emph = instr.emph; + instr = interp_bare_proof_instr info sigma env instr.instr} + + + diff --git a/plugins/decl_mode/decl_interp.mli b/plugins/decl_mode/decl_interp.mli new file mode 100644 index 00000000..bd6ed064 --- /dev/null +++ b/plugins/decl_mode/decl_interp.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Tacinterp +open Decl_expr +open Mod_subst + + +val intern_proof_instr : glob_sign -> raw_proof_instr -> glob_proof_instr +val interp_proof_instr : Decl_mode.pm_info -> + Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml new file mode 100644 index 00000000..da88d48d --- /dev/null +++ b/plugins/decl_mode/decl_mode.ml @@ -0,0 +1,123 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Term +open Evd +open Util + + +let daimon_flag = ref false + +let set_daimon_flag () = daimon_flag:=true +let clear_daimon_flag () = daimon_flag:=false +let get_daimon_flag () = !daimon_flag + + + +(* Information associated to goals. *) +open Store.Field + +type split_tree= + Skip_patt of Idset.t * split_tree + | Split_patt of Idset.t * inductive * + (bool array * (Idset.t * split_tree) option) array + | Close_patt of split_tree + | End_patt of (identifier * (int * int)) + +type elim_kind = + EK_dep of split_tree + | EK_nodep + | EK_unknown + +type recpath = int option*Declarations.wf_paths + +type per_info = + {per_casee:constr; + per_ctype:types; + per_ind:inductive; + per_pred:constr; + per_args:constr list; + per_params:constr list; + per_nparams:int; + per_wf:recpath} + +type stack_info = + Per of Decl_expr.elim_type * per_info * elim_kind * identifier list + | Suppose_case + | Claim + | Focus_claim + +type pm_info = + { pm_stack : stack_info list} +let info = Store.field () + + +(* Current proof mode *) + +type command_mode = + Mode_tactic + | Mode_proof + | Mode_none + +let mode_of_pftreestate pts = + (* spiwack: it used to be "top_goal_..." but this should be fine *) + let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in + let goal = List.hd goals in + if info.get (Goal.V82.extra sigma goal) = None then + Mode_tactic + else + Mode_proof + +let get_current_mode () = + try + mode_of_pftreestate (Pfedit.get_pftreestate ()) + with e when Errors.noncritical e -> Mode_none + +let check_not_proof_mode str = + if get_current_mode () = Mode_proof then + error str + +let get_info sigma gl= + match info.get (Goal.V82.extra sigma gl) with + | None -> invalid_arg "get_info" + | Some pm -> pm + +let try_get_info sigma gl = + info.get (Goal.V82.extra sigma gl) + +let get_stack pts = + let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in + let info = get_info sigma (List.hd goals) in + info.pm_stack + + +let proof_focus = Proof.new_focus_kind () +let proof_cond = Proof.no_cond proof_focus + +let focus p = + let inf = get_stack p in + Proof.focus proof_cond inf 1 p + +let unfocus = Proof.unfocus proof_focus + +let maximal_unfocus = Proof_global.maximal_unfocus proof_focus + +let get_top_stack pts = + try + Proof.get_at_focus proof_focus pts + with Proof.NoSuchFocus -> + let { it = gl ; sigma = sigma } = Proof.V82.top_goal pts in + let info = get_info sigma gl in + info.pm_stack + +let get_last env = + try + let (id,_,_) = List.hd (Environ.named_context env) in id + with Invalid_argument _ -> error "no previous statement to use" + diff --git a/plugins/decl_mode/decl_mode.mli b/plugins/decl_mode/decl_mode.mli new file mode 100644 index 00000000..f23a97b4 --- /dev/null +++ b/plugins/decl_mode/decl_mode.mli @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Term +open Evd +open Tacmach + +val set_daimon_flag : unit -> unit +val clear_daimon_flag : unit -> unit +val get_daimon_flag : unit -> bool + +type command_mode = + Mode_tactic + | Mode_proof + | Mode_none + +val mode_of_pftreestate : Proof.proof -> command_mode + +val get_current_mode : unit -> command_mode + +val check_not_proof_mode : string -> unit + +type split_tree= + Skip_patt of Idset.t * split_tree + | Split_patt of Idset.t * inductive * + (bool array * (Idset.t * split_tree) option) array + | Close_patt of split_tree + | End_patt of (identifier * (int * int)) + +type elim_kind = + EK_dep of split_tree + | EK_nodep + | EK_unknown + +type recpath = int option*Declarations.wf_paths + +type per_info = + {per_casee:constr; + per_ctype:types; + per_ind:inductive; + per_pred:constr; + per_args:constr list; + per_params:constr list; + per_nparams:int; + per_wf:recpath} + +type stack_info = + Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list + | Suppose_case + | Claim + | Focus_claim + +type pm_info = + {pm_stack : stack_info list } + +val info : pm_info Store.Field.t + +val get_info : Evd.evar_map -> Proof_type.goal -> pm_info + +val try_get_info : Evd.evar_map -> Proof_type.goal -> pm_info option + +val get_stack : Proof.proof -> stack_info list + +val get_top_stack : Proof.proof -> stack_info list + +val get_last: Environ.env -> identifier + +val focus : Proof.proof -> unit + +val unfocus : Proof.proof -> unit + +val maximal_unfocus : Proof.proof -> unit diff --git a/plugins/decl_mode/decl_mode_plugin.mllib b/plugins/decl_mode/decl_mode_plugin.mllib new file mode 100644 index 00000000..39342dbd --- /dev/null +++ b/plugins/decl_mode/decl_mode_plugin.mllib @@ -0,0 +1,6 @@ +Decl_mode +Decl_interp +Decl_proof_instr +Ppdecl_proof +G_decl_mode +Decl_mode_plugin_mod diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml new file mode 100644 index 00000000..ab161b35 --- /dev/null +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -0,0 +1,1504 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open Evd + +open Refiner +open Proof_type +open Tacmach +open Tacinterp +open Decl_expr +open Decl_mode +open Decl_interp +open Glob_term +open Names +open Nameops +open Declarations +open Tactics +open Tacticals +open Term +open Termops +open Namegen +open Reductionops +open Goptions + + +(* Strictness option *) + +let get_its_info gls = get_info gls.sigma gls.it + +let get_strictness,set_strictness = + let strictness = ref false in + (fun () -> (!strictness)),(fun b -> strictness:=b) + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "strict mode"; + optkey = ["Strict";"Proofs"]; + optread = get_strictness; + optwrite = set_strictness } + +let tcl_change_info_gen info_gen = + (fun gls -> + let concl = pf_concl gls in + let hyps = Goal.V82.hyps (project gls) (sig_it gls) in + let extra = Goal.V82.extra (project gls) (sig_it gls) in + let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in + let sigma = Goal.V82.partial_solution sigma (sig_it gls) ev in + { it = [gl] ; sigma= sigma } ) + +open Store.Field + +let tcl_change_info info gls = + let info_gen = Decl_mode.info.set info in + tcl_change_info_gen info_gen gls + +let tcl_erase_info gls = tcl_change_info_gen (Decl_mode.info.remove) gls + +let special_whd gl= + let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in + (fun t -> Closure.whd_val infos (Closure.inject t)) + +let special_nf gl= + let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in + (fun t -> Closure.norm_val infos (Closure.inject t)) + +let is_good_inductive env ind = + let mib,oib = Inductive.lookup_mind_specif env ind in + oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib)) + +let check_not_per pts = + if not (Proof.is_done pts) then + match get_stack pts with + Per (_,_,_,_)::_ -> + error "You are inside a proof per cases/induction.\n\ +Please \"suppose\" something or \"end\" it now." + | _ -> () + +let mk_evd metalist gls = + let evd0= create_goal_evar_defs (sig_sig gls) in + let add_one (meta,typ) evd = + meta_declare meta typ evd in + List.fold_right add_one metalist evd0 + +let is_tmp id = (string_of_id id).[0] = '_' + +let tmp_ids gls = + let ctx = pf_hyps gls in + match ctx with + [] -> [] + | _::q -> List.filter is_tmp (ids_of_named_context q) + +let clean_tmp gls = + let clean_id id0 gls0 = + tclTRY (clear [id0]) gls0 in + let rec clean_all = function + [] -> tclIDTAC + | id :: rest -> tclTHEN (clean_id id) (clean_all rest) + in + clean_all (tmp_ids gls) gls + +let assert_postpone id t = + assert_tac (Name id) t + +(* start a proof *) + + +let start_proof_tac gls= + let info={pm_stack=[]} in + tcl_change_info info gls + +let go_to_proof_mode () = + Pfedit.by start_proof_tac; + let p = Proof_global.give_me_the_proof () in + Decl_mode.focus p + +(* closing gaps *) + +let daimon_tac gls = + set_daimon_flag (); + {it=[];sigma=sig_sig gls} + + +(* marking closed blocks *) + +let rec is_focussing_instr = function + Pthus i | Pthen i | Phence i -> is_focussing_instr i + | Pescape | Pper _ | Pclaim _ | Pfocus _ + | Psuppose _ | Pcase (_,_,_) -> true + | _ -> false + +let mark_rule_as_done = function + Decl_proof true -> Decl_proof false + | Decl_proof false -> + anomaly "already marked as done" + | _ -> anomaly "mark_rule_as_done" + + +(* post-instruction focus management *) + +(* spiwack: This used to fail if there was no focusing command + above, but I don't think it ever happened. I hope it doesn't mess + things up*) +let goto_current_focus pts = + Decl_mode.maximal_unfocus pts + +let goto_current_focus_or_top pts = + goto_current_focus pts + +(* return *) + +let close_tactic_mode pts = + try goto_current_focus pts + with Not_found -> + error "\"return\" cannot be used outside of Declarative Proof Mode." + +let return_from_tactic_mode () = + close_tactic_mode (Proof_global.give_me_the_proof ()) + +(* end proof/claim *) + +let close_block bt pts = + if Proof.no_focused_goal pts then + goto_current_focus pts + else + let stack = + if Proof.is_done pts then + get_top_stack pts + else + get_stack pts + in + match bt,stack with + B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> + (goto_current_focus pts) + | _, Claim::_ -> + error "\"end claim\" expected." + | _, Focus_claim::_ -> + error "\"end focus\" expected." + | _, [] -> + error "\"end proof\" expected." + | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) -> + begin + match et with + ET_Case_analysis -> error "\"end cases\" expected." + | ET_Induction -> error "\"end induction\" expected." + end + | _,_ -> anomaly "Lonely suppose on stack." + + +(* utility for suppose / suppose it is *) + +let close_previous_case pts = + if + Proof.is_done pts + then + match get_top_stack pts with + Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." + | Suppose_case :: Per (et,_,_,_) :: _ -> + goto_current_focus (pts) + | _ -> error "Not inside a proof per cases or induction." + else + match get_stack pts with + Per (et,_,_,_) :: _ -> () + | Suppose_case :: Per (et,_,_,_) :: _ -> + goto_current_focus ((pts)) + | _ -> error "Not inside a proof per cases or induction." + +(* Proof instructions *) + +(* automation *) + +let filter_hyps f gls = + let filter_aux (id,_,_) = + if f id then + tclIDTAC + else + tclTRY (clear [id]) in + tclMAP filter_aux (pf_hyps gls) gls + +let local_hyp_prefix = id_of_string "___" + +let add_justification_hyps keep items gls = + let add_aux c gls= + match kind_of_term c with + Var id -> + keep:=Idset.add id !keep; + tclIDTAC gls + | _ -> + let id=pf_get_new_id local_hyp_prefix gls in + keep:=Idset.add id !keep; + tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) + (thin_body [id]) gls in + tclMAP add_aux items gls + +let prepare_goal items gls = + let tokeep = ref Idset.empty in + let auxres = add_justification_hyps tokeep items gls in + tclTHENLIST + [ (fun _ -> auxres); + filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls + +let my_automation_tac = ref + (fun gls -> anomaly "No automation registered") + +let register_automation_tac tac = my_automation_tac:= tac + +let automation_tac gls = !my_automation_tac gls + +let justification tac gls= + tclORELSE + (tclSOLVE [tclTHEN tac assumption]) + (fun gls -> + if get_strictness () then + error "Insufficient justification." + else + begin + msg_warning (str "Insufficient justification."); + daimon_tac gls + end) gls + +let default_justification elems gls= + justification (tclTHEN (prepare_goal elems) automation_tac) gls + +(* code for conclusion refining *) + +let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s) + +let _and = constant ["Init";"Logic"] "and" + +let _and_rect = constant ["Init";"Logic"] "and_rect" + +let _prod = constant ["Init";"Datatypes"] "prod" + +let _prod_rect = constant ["Init";"Datatypes"] "prod_rect" + +let _ex = constant ["Init";"Logic"] "ex" + +let _ex_ind = constant ["Init";"Logic"] "ex_ind" + +let _sig = constant ["Init";"Specif"] "sig" + +let _sig_rect = constant ["Init";"Specif"] "sig_rect" + +let _sigT = constant ["Init";"Specif"] "sigT" + +let _sigT_rect = constant ["Init";"Specif"] "sigT_rect" + +type stackd_elt = +{se_meta:metavariable; + se_type:types; + se_last_meta:metavariable; + se_meta_list:(metavariable*types) list; + se_evd: evar_map} + +let rec replace_in_list m l = function + [] -> raise Not_found + | c::q -> if m=fst c then l@q else c::replace_in_list m l q + +let enstack_subsubgoals env se stack gls= + let hd,params = decompose_app (special_whd gls se.se_type) in + match kind_of_term hd with + Ind ind when is_good_inductive env ind -> + let mib,oib= + Inductive.lookup_mind_specif env ind in + let gentypes= + Inductive.arities_of_constructors ind (mib,oib) in + let process i gentyp = + let constructor = mkConstruct(ind,succ i) + (* constructors numbering*) in + let appterm = applist (constructor,params) in + let apptype = Term.prod_applist gentyp params in + let rc,_ = Reduction.dest_prod env apptype in + let rec meta_aux last lenv = function + [] -> (last,lenv,[]) + | (nam,_,typ)::q -> + let nlast=succ last in + let (llast,holes,metas) = + meta_aux nlast (mkMeta nlast :: lenv) q in + (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in + let (nlast,holes,nmetas) = + meta_aux se.se_last_meta [] (List.rev rc) in + let refiner = applist (appterm,List.rev holes) in + let evd = meta_assign se.se_meta + (refiner,(Conv,TypeProcessed (* ? *))) se.se_evd in + let ncreated = replace_in_list + se.se_meta nmetas se.se_meta_list in + let evd0 = List.fold_left + (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in + List.iter (fun (m,typ) -> + Stack.push + {se_meta=m; + se_type=typ; + se_evd=evd0; + se_meta_list=ncreated; + se_last_meta=nlast} stack) (List.rev nmetas) + in + Array.iteri process gentypes + | _ -> () + +let rec nf_list evd = + function + [] -> [] + | (m,typ)::others -> + if meta_defined evd m then + nf_list evd others + else + (m,nf_meta evd typ)::nf_list evd others + +let find_subsubgoal c ctyp skip submetas gls = + let env= pf_env gls in + let concl = pf_concl gls in + let evd = mk_evd ((0,concl)::submetas) gls in + let stack = Stack.create () in + let max_meta = + List.fold_left (fun a (m,_) -> max a m) 0 submetas in + let _ = Stack.push + {se_meta=0; + se_type=concl; + se_last_meta=max_meta; + se_meta_list=[0,concl]; + se_evd=evd} stack in + let rec dfs n = + let se = Stack.pop stack in + try + let unifier = + Unification.w_unify env se.se_evd Reduction.CUMUL + ~flags:Unification.elim_flags ctyp se.se_type in + if n <= 0 then + {se with + se_evd=meta_assign se.se_meta + (c,(Conv,TypeNotProcessed (* ?? *))) unifier; + se_meta_list=replace_in_list + se.se_meta submetas se.se_meta_list} + else + dfs (pred n) + with e when Errors.noncritical e -> + begin + enstack_subsubgoals env se stack gls; + dfs n + end in + let nse= try dfs skip with Stack.Empty -> raise Not_found in + nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0) + +let concl_refiner metas body gls = + let concl = pf_concl gls in + let evd = sig_sig gls in + let env = pf_env gls in + let sort = family_of_sort (Typing.sort_of env evd concl) in + let rec aux env avoid subst = function + [] -> anomaly "concl_refiner: cannot happen" + | (n,typ)::rest -> + let _A = subst_meta subst typ in + let x = id_of_name_using_hdchar env _A Anonymous in + let _x = fresh_id avoid x gls in + let nenv = Environ.push_named (_x,None,_A) env in + let asort = family_of_sort (Typing.sort_of nenv evd _A) in + let nsubst = (n,mkVar _x)::subst in + if rest = [] then + asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) + else + let bsort,_B,nbody = + aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in + let body = mkNamedLambda _x _A nbody in + if occur_term (mkVar _x) _B then + begin + let _P = mkNamedLambda _x _A _B in + match bsort,sort with + InProp,InProp -> + let _AxB = mkApp(Lazy.force _ex,[|_A;_P|]) in + InProp,_AxB, + mkApp(Lazy.force _ex_ind,[|_A;_P;concl;body|]) + | InProp,_ -> + let _AxB = mkApp(Lazy.force _sig,[|_A;_P|]) in + let _P0 = mkLambda(Anonymous,_AxB,concl) in + InType,_AxB, + mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|]) + | _,_ -> + let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in + let _P0 = mkLambda(Anonymous,_AxB,concl) in + InType,_AxB, + mkApp(Lazy.force _sigT_rect,[|_A;_P;_P0;body|]) + end + else + begin + match asort,bsort with + InProp,InProp -> + let _AxB = mkApp(Lazy.force _and,[|_A;_B|]) in + InProp,_AxB, + mkApp(Lazy.force _and_rect,[|_A;_B;concl;body|]) + |_,_ -> + let _AxB = mkApp(Lazy.force _prod,[|_A;_B|]) in + let _P0 = mkLambda(Anonymous,_AxB,concl) in + InType,_AxB, + mkApp(Lazy.force _prod_rect,[|_A;_B;_P0;body|]) + end + in + let (_,_,prf) = aux env [] [] metas in + mkApp(prf,[|mkMeta 1|]) + +let thus_tac c ctyp submetas gls = + let list,proof = + try + find_subsubgoal c ctyp 0 submetas gls + with Not_found -> + error "I could not relate this statement to the thesis." in + if list = [] then + exact_check proof gls + else + let refiner = concl_refiner list proof gls in + Tactics.refine refiner gls + +(* general forward step *) + +let mk_stat_or_thesis info gls = function + This c -> c + | Thesis (For _ ) -> + error "\"thesis for ...\" is not applicable here." + | Thesis Plain -> pf_concl gls + +let just_tac _then cut info gls0 = + let last_item = if _then then + let last_id = try get_last (pf_env gls0) with Failure _ -> + error "\"then\" and \"hence\" require at least one previous fact" in + [mkVar last_id] + else [] + in + let items_tac gls = + match cut.cut_by with + None -> tclIDTAC gls + | Some items -> prepare_goal (last_item@items) gls in + let method_tac gls = + match cut.cut_using with + None -> + automation_tac gls + | Some tac -> + (Tacinterp.eval_tactic tac) gls in + justification (tclTHEN items_tac method_tac) gls0 + +let instr_cut mkstat _thus _then cut gls0 = + let info = get_its_info gls0 in + let stat = cut.cut_stat in + let (c_id,_) = match stat.st_label with + Anonymous -> + pf_get_new_id (id_of_string "_fact") gls0,false + | Name id -> id,true in + let c_stat = mkstat info gls0 stat.st_it in + let thus_tac gls= + if _thus then + thus_tac (mkVar c_id) c_stat [] gls + else tclIDTAC gls in + tclTHENS (assert_postpone c_id c_stat) + [tclTHEN tcl_erase_info (just_tac _then cut info); + thus_tac] gls0 + + + +(* iterated equality *) +let _eq = Libnames.constr_of_global (Coqlib.glob_eq) + +let decompose_eq id gls = + let typ = pf_get_hyp_typ gls id in + let whd = (special_whd gls typ) in + match kind_of_term whd with + App (f,args)-> + if eq_constr f _eq && (Array.length args)=3 + then (args.(0), + args.(1), + args.(2)) + else error "Previous step is not an equality." + | _ -> error "Previous step is not an equality." + +let instr_rew _thus rew_side cut gls0 = + let last_id = + try get_last (pf_env gls0) + with e when Errors.noncritical e -> + error "No previous equality." + in + let typ,lhs,rhs = decompose_eq last_id gls0 in + let items_tac gls = + match cut.cut_by with + None -> tclIDTAC gls + | Some items -> prepare_goal items gls in + let method_tac gls = + match cut.cut_using with + None -> + automation_tac gls + | Some tac -> + (Tacinterp.eval_tactic tac) gls in + let just_tac gls = + justification (tclTHEN items_tac method_tac) gls in + let (c_id,_) = match cut.cut_stat.st_label with + Anonymous -> + pf_get_new_id (id_of_string "_eq") gls0,false + | Name id -> id,true in + let thus_tac new_eq gls= + if _thus then + thus_tac (mkVar c_id) new_eq [] gls + else tclIDTAC gls in + match rew_side with + Lhs -> + let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in + tclTHENS (assert_postpone c_id new_eq) + [tclTHEN tcl_erase_info + (tclTHENS (transitivity lhs) + [just_tac;exact_check (mkVar last_id)]); + thus_tac new_eq] gls0 + | Rhs -> + let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in + tclTHENS (assert_postpone c_id new_eq) + [tclTHEN tcl_erase_info + (tclTHENS (transitivity rhs) + [exact_check (mkVar last_id);just_tac]); + thus_tac new_eq] gls0 + + + +(* tactics for claim/focus *) + +let instr_claim _thus st gls0 = + let info = get_its_info gls0 in + let (id,_) = match st.st_label with + Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false + | Name id -> id,true in + let thus_tac gls= + if _thus then + thus_tac (mkVar id) st.st_it [] gls + else tclIDTAC gls in + let ninfo1 = {pm_stack= + (if _thus then Focus_claim else Claim)::info.pm_stack} in + tclTHENS (assert_postpone id st.st_it) + [thus_tac; + tcl_change_info ninfo1] gls0 + +(* tactics for assume *) + +let push_intro_tac coerce nam gls = + let (hid,_) = + match nam with + Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false + | Name id -> id,true in + tclTHENLIST + [intro_mustbe_force hid; + coerce hid] + gls + +let assume_tac hyps gls = + List.fold_right + (fun (Hvar st | Hprop st) -> + tclTHEN + (push_intro_tac + (fun id -> + convert_hyp (id,None,st.st_it)) st.st_label)) + hyps tclIDTAC gls + +let assume_hyps_or_theses hyps gls = + List.fold_right + (function + (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> + tclTHEN + (push_intro_tac + (fun id -> + convert_hyp (id,None,c)) nam) + | Hprop {st_label=nam;st_it=Thesis (tk)} -> + tclTHEN + (push_intro_tac + (fun id -> tclIDTAC) nam)) + hyps tclIDTAC gls + +let assume_st hyps gls = + List.fold_right + (fun st -> + tclTHEN + (push_intro_tac + (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) + hyps tclIDTAC gls + +let assume_st_letin hyps gls = + List.fold_right + (fun st -> + tclTHEN + (push_intro_tac + (fun id -> + convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label)) + hyps tclIDTAC gls + +(* suffices *) + +let rec metas_from n hyps = + match hyps with + _ :: q -> n :: metas_from (succ n) q + | [] -> [] + +let rec build_product args body = + match args with + (Hprop st| Hvar st )::rest -> + let pprod= lift 1 (build_product rest body) in + let lbody = + match st.st_label with + Anonymous -> pprod + | Name id -> subst_term (mkVar id) pprod in + mkProd (st.st_label, st.st_it, lbody) + | [] -> body + +let rec build_applist prod = function + [] -> [],prod + | n::q -> + let (_,typ,_) = destProd prod in + let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in + (n,typ)::ctx,head + +let instr_suffices _then cut gls0 = + let info = get_its_info gls0 in + let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in + let ctx,hd = cut.cut_stat in + let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in + let metas = metas_from 1 ctx in + let c_ctx,c_head = build_applist c_stat metas in + let c_term = applist (mkVar c_id,List.map mkMeta metas) in + let thus_tac gls= + thus_tac c_term c_head c_ctx gls in + tclTHENS (assert_postpone c_id c_stat) + [tclTHENLIST + [ assume_tac ctx; + tcl_erase_info; + just_tac _then cut info]; + thus_tac] gls0 + +(* tactics for consider/given *) + +let conjunction_arity id gls = + let typ = pf_get_hyp_typ gls id in + let hd,params = decompose_app (special_whd gls typ) in + let env =pf_env gls in + match kind_of_term hd with + Ind ind when is_good_inductive env ind -> + let mib,oib= + Inductive.lookup_mind_specif env ind in + let gentypes= + Inductive.arities_of_constructors ind (mib,oib) in + let _ = if Array.length gentypes <> 1 then raise Not_found in + let apptype = Term.prod_applist gentypes.(0) params in + let rc,_ = Reduction.dest_prod env apptype in + List.length rc + | _ -> raise Not_found + +let rec intron_then n ids ltac gls = + if n<=0 then + ltac ids gls + else + let id = pf_get_new_id (id_of_string "_tmp") gls in + tclTHEN + (intro_mustbe_force id) + (intron_then (pred n) (id::ids) ltac) gls + + +let rec consider_match may_intro introduced available expected gls = + match available,expected with + [],[] -> + tclIDTAC gls + | _,[] -> error "Last statements do not match a complete hypothesis." + (* should tell which ones *) + | [],hyps -> + if may_intro then + begin + let id = pf_get_new_id (id_of_string "_tmp") gls in + tclIFTHENELSE + (intro_mustbe_force id) + (consider_match true [] [id] hyps) + (fun _ -> + error "Not enough sub-hypotheses to match statements.") + gls + end + else + error "Not enough sub-hypotheses to match statements." + (* should tell which ones *) + | id::rest_ids,(Hvar st | Hprop st)::rest -> + tclIFTHENELSE (convert_hyp (id,None,st.st_it)) + begin + match st.st_label with + Anonymous -> + consider_match may_intro ((id,false)::introduced) rest_ids rest + | Name hid -> + tclTHENLIST + [rename_hyp [id,hid]; + consider_match may_intro ((hid,true)::introduced) rest_ids rest] + end + begin + (fun gls -> + let nhyps = + try conjunction_arity id gls with + Not_found -> error "Matching hypothesis not found." in + tclTHENLIST + [general_case_analysis false (mkVar id,NoBindings); + intron_then nhyps [] + (fun l -> consider_match may_intro introduced + (List.rev_append l rest_ids) expected)] gls) + end + gls + +let consider_tac c hyps gls = + match kind_of_term (strip_outer_cast c) with + Var id -> + consider_match false [] [id] hyps gls + | _ -> + let id = pf_get_new_id (id_of_string "_tmp") gls in + tclTHEN + (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) + (consider_match false [] [id] hyps) gls + + +let given_tac hyps gls = + consider_match true [] [] hyps gls + +(* tactics for take *) + +let rec take_tac wits gls = + match wits with + [] -> tclIDTAC gls + | wit::rest -> + let typ = pf_type_of gls wit in + tclTHEN (thus_tac wit typ []) (take_tac rest) gls + + +(* tactics for define *) + +let rec build_function args body = + match args with + st::rest -> + let pfun= lift 1 (build_function rest body) in + let id = match st.st_label with + Anonymous -> assert false + | Name id -> id in + mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) + | [] -> body + +let define_tac id args body gls = + let t = build_function args body in + letin_tac None (Name id) t None Tacexpr.nowhere gls + +(* tactics for reconsider *) + +let cast_tac id_or_thesis typ gls = + match id_or_thesis with + This id -> + let (_,body,_) = pf_get_hyp gls id in + convert_hyp (id,body,typ) gls + | Thesis (For _ ) -> + error "\"thesis for ...\" is not applicable here." + | Thesis Plain -> + convert_concl typ DEFAULTcast gls + +(* per cases *) + +let is_rec_pos (main_ind,wft) = + match main_ind with + None -> false + | Some index -> + match fst (Rtree.dest_node wft) with + Mrec (_,i) when i = index -> true + | _ -> false + +let rec constr_trees (main_ind,wft) ind = + match Rtree.dest_node wft with + Norec,_ -> + let itree = + (snd (Global.lookup_inductive ind)).mind_recargs in + constr_trees (None,itree) ind + | _,constrs -> main_ind,constrs + +let ind_args rp ind = + let main_ind,constrs = constr_trees rp ind in + let args ctree = + Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in + Array.map args constrs + +let init_tree ids ind rp nexti = + let indargs = ind_args rp ind in + let do_i i arp = (Array.map is_rec_pos arp),nexti i arp in + Split_patt (ids,ind,Array.mapi do_i indargs) + +let map_tree_rp rp id_fun mapi = function + Split_patt (ids,ind,branches) -> + let indargs = ind_args rp ind in + let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in + Split_patt (id_fun ids,ind,Array.mapi do_i branches) + | _ -> failwith "map_tree_rp: not a splitting node" + +let map_tree id_fun mapi = function + Split_patt (ids,ind,branches) -> + let do_i i (recargs,bri) = recargs,mapi i bri in + Split_patt (id_fun ids,ind,Array.mapi do_i branches) + | _ -> failwith "map_tree: not a splitting node" + + +let start_tree env ind rp = + init_tree Idset.empty ind rp (fun _ _ -> None) + +let build_per_info etype casee gls = + let concl=pf_concl gls in + let env=pf_env gls in + let ctyp=pf_type_of gls casee in + let is_dep = dependent casee concl in + let hd,args = decompose_app (special_whd gls ctyp) in + let ind = + try + destInd hd + with e when Errors.noncritical e -> + error "Case analysis must be done on an inductive object." in + let mind,oind = Global.lookup_inductive ind in + let nparams,index = + match etype with + ET_Induction -> mind.mind_nparams_rec,Some (snd ind) + | _ -> mind.mind_nparams,None in + let params,real_args = list_chop nparams args in + let abstract_obj c body = + let typ=pf_type_of gls c in + lambda_create env (typ,subst_term c body) in + let pred= List.fold_right abstract_obj + real_args (lambda_create env (ctyp,subst_term casee concl)) in + is_dep, + {per_casee=casee; + per_ctype=ctyp; + per_ind=ind; + per_pred=pred; + per_args=real_args; + per_params=params; + per_nparams=nparams; + per_wf=index,oind.mind_recargs} + +let per_tac etype casee gls= + let env=pf_env gls in + let info = get_its_info gls in + match casee with + Real c -> + let is_dep,per_info = build_per_info etype c gls in + let ek = + if is_dep then + EK_dep (start_tree env per_info.per_ind per_info.per_wf) + else EK_unknown in + tcl_change_info + {pm_stack= + Per(etype,per_info,ek,[])::info.pm_stack} gls + | Virtual cut -> + assert (cut.cut_stat.st_label=Anonymous); + let id = pf_get_new_id (id_of_string "anonymous_matched") gls in + let c = mkVar id in + let modified_cut = + {cut with cut_stat={cut.cut_stat with st_label=Name id}} in + tclTHEN + (instr_cut (fun _ _ c -> c) false false modified_cut) + (fun gls0 -> + let is_dep,per_info = build_per_info etype c gls0 in + assert (not is_dep); + tcl_change_info + {pm_stack= + Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0) + gls + +(* suppose *) + +let register_nodep_subcase id= function + Per(et,pi,ek,clauses)::s -> + begin + match ek with + EK_unknown -> clauses,Per(et,pi,EK_nodep,id::clauses)::s + | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s + | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"." + end + | _ -> anomaly "wrong stack state" + +let suppose_tac hyps gls0 = + let info = get_its_info gls0 in + let thesis = pf_concl gls0 in + let id = pf_get_new_id (id_of_string "subcase_") gls0 in + let clause = build_product hyps thesis in + let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in + let old_clauses,stack = register_nodep_subcase id info.pm_stack in + let ninfo2 = {pm_stack=stack} in + tclTHENS (assert_postpone id clause) + [tclTHENLIST [tcl_change_info ninfo1; + assume_tac hyps; + clear old_clauses]; + tcl_change_info ninfo2] gls0 + +(* suppose it is ... *) + +(* pattern matching compiling *) + +let rec skip_args rest ids n = + if n <= 0 then + Close_patt rest + else + Skip_patt (ids,skip_args rest ids (pred n)) + +let rec tree_of_pats ((id,_) as cpl) pats = + match pats with + [] -> End_patt cpl + | args::stack -> + match args with + [] -> Close_patt (tree_of_pats cpl stack) + | (patt,rp) :: rest_args -> + match patt with + PatVar (_,v) -> + Skip_patt (Idset.singleton id, + tree_of_pats cpl (rest_args::stack)) + | PatCstr (_,(ind,cnum),args,nam) -> + let nexti i ati = + if i = pred cnum then + let nargs = + list_map_i (fun j a -> (a,ati.(j))) 0 args in + Some (Idset.singleton id, + tree_of_pats cpl (nargs::rest_args::stack)) + else None + in init_tree Idset.empty ind rp nexti + +let rec add_branch ((id,_) as cpl) pats tree= + match pats with + [] -> + begin + match tree with + End_patt cpl0 -> End_patt cpl0 + (* this ensures precedence for overlapping patterns *) + | _ -> anomaly "tree is expected to end here" + end + | args::stack -> + match args with + [] -> + begin + match tree with + Close_patt t -> + Close_patt (add_branch cpl stack t) + | _ -> anomaly "we should pop here" + end + | (patt,rp) :: rest_args -> + match patt with + PatVar (_,v) -> + begin + match tree with + Skip_patt (ids,t) -> + Skip_patt (Idset.add id ids, + add_branch cpl (rest_args::stack) t) + | Split_patt (_,_,_) -> + map_tree (Idset.add id) + (fun i bri -> + append_branch cpl 1 (rest_args::stack) bri) + tree + | _ -> anomaly "No pop/stop expected here" + end + | PatCstr (_,(ind,cnum),args,nam) -> + match tree with + Skip_patt (ids,t) -> + let nexti i ati = + if i = pred cnum then + let nargs = + list_map_i (fun j a -> (a,ati.(j))) 0 args in + Some (Idset.add id ids, + add_branch cpl (nargs::rest_args::stack) + (skip_args t ids (Array.length ati))) + else + Some (ids, + skip_args t ids (Array.length ati)) + in init_tree ids ind rp nexti + | Split_patt (_,ind0,_) -> + if (ind <> ind0) then error + (* this can happen with coercions *) + "Case pattern belongs to wrong inductive type."; + let mapi i ati bri = + if i = pred cnum then + let nargs = + list_map_i (fun j a -> (a,ati.(j))) 0 args in + append_branch cpl 0 + (nargs::rest_args::stack) bri + else bri in + map_tree_rp rp (fun ids -> ids) mapi tree + | _ -> anomaly "No pop/stop expected here" +and append_branch ((id,_) as cpl) depth pats = function + Some (ids,tree) -> + Some (Idset.add id ids,append_tree cpl depth pats tree) + | None -> + Some (Idset.singleton id,tree_of_pats cpl pats) +and append_tree ((id,_) as cpl) depth pats tree = + if depth<=0 then add_branch cpl pats tree + else match tree with + Close_patt t -> + Close_patt (append_tree cpl (pred depth) pats t) + | Skip_patt (ids,t) -> + Skip_patt (Idset.add id ids,append_tree cpl depth pats t) + | End_patt _ -> anomaly "Premature end of branch" + | Split_patt (_,_,_) -> + map_tree (Idset.add id) + (fun i bri -> append_branch cpl (succ depth) pats bri) tree + +(* suppose it is *) + +let rec st_assoc id = function + [] -> raise Not_found + | st::_ when st.st_label = id -> st.st_it + | _ :: rest -> st_assoc id rest + +let thesis_for obj typ per_info env= + let rc,hd1=decompose_prod typ in + let cind,all_args=decompose_app typ in + let ind = destInd cind in + let _ = if ind <> per_info.per_ind then + errorlabstrm "thesis_for" + ((Printer.pr_constr_env env obj) ++ spc () ++ + str"cannot give an induction hypothesis (wrong inductive type).") in + let params,args = list_chop per_info.per_nparams all_args in + let _ = if not (List.for_all2 eq_constr params per_info.per_params) then + errorlabstrm "thesis_for" + ((Printer.pr_constr_env env obj) ++ spc () ++ + str "cannot give an induction hypothesis (wrong parameters).") in + let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in + compose_prod rc (whd_beta Evd.empty hd2) + +let rec build_product_dep pat_info per_info args body gls = + match args with + (Hprop {st_label=nam;st_it=This c} + | Hvar {st_label=nam;st_it=c})::rest -> + let pprod= + lift 1 (build_product_dep pat_info per_info rest body gls) in + let lbody = + match nam with + Anonymous -> body + | Name id -> subst_var id pprod in + mkProd (nam,c,lbody) + | Hprop ({st_it=Thesis tk} as st)::rest -> + let pprod= + lift 1 (build_product_dep pat_info per_info rest body gls) in + let lbody = + match st.st_label with + Anonymous -> body + | Name id -> subst_var id pprod in + let ptyp = + match tk with + For id -> + let obj = mkVar id in + let typ = + try st_assoc (Name id) pat_info.pat_vars + with Not_found -> + snd (st_assoc (Name id) pat_info.pat_aliases) in + thesis_for obj typ per_info (pf_env gls) + | Plain -> pf_concl gls in + mkProd (st.st_label,ptyp,lbody) + | [] -> body + +let build_dep_clause params pat_info per_info hyps gls = + let concl= + thesis_for pat_info.pat_constr pat_info.pat_typ per_info (pf_env gls) in + let open_clause = + build_product_dep pat_info per_info hyps concl gls in + let prod_one st body = + match st.st_label with + Anonymous -> mkProd(Anonymous,st.st_it,lift 1 body) + | Name id -> mkNamedProd id st.st_it (lift 1 body) in + let let_one_in st body = + match st.st_label with + Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body) + | Name id -> + mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in + let aliased_clause = + List.fold_right let_one_in pat_info.pat_aliases open_clause in + List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause + +let rec register_dep_subcase id env per_info pat = function + EK_nodep -> error "Only \"suppose it is\" can be used here." + | EK_unknown -> + register_dep_subcase id env per_info pat + (EK_dep (start_tree env per_info.per_ind per_info.per_wf)) + | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree) + +let case_tac params pat_info hyps gls0 = + let info = get_its_info gls0 in + let id = pf_get_new_id (id_of_string "subcase_") gls0 in + let et,per_info,ek,old_clauses,rest = + match info.pm_stack with + Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) + | _ -> anomaly "wrong place for cases" in + let clause = build_dep_clause params pat_info per_info hyps gls0 in + let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in + let nek = + register_dep_subcase (id,(List.length params,List.length hyps)) + (pf_env gls0) per_info pat_info.pat_pat ek in + let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in + tclTHENS (assert_postpone id clause) + [tclTHENLIST + [tcl_change_info ninfo1; + assume_st (params@pat_info.pat_vars); + assume_st_letin pat_info.pat_aliases; + assume_hyps_or_theses hyps; + clear old_clauses]; + tcl_change_info ninfo2] gls0 + +(* end cases *) + +type instance_stack = + (constr option*(constr list) list) list + +let initial_instance_stack ids = + List.map (fun id -> id,[None,[]]) ids + +let push_one_arg arg = function + [] -> anomaly "impossible" + | (head,args) :: ctx -> + ((head,(arg::args)) :: ctx) + +let push_arg arg stacks = + List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks + + +let push_one_head c ids (id,stack) = + let head = if Idset.mem id ids then Some c else None in + id,(head,[]) :: stack + +let push_head c ids stacks = + List.map (push_one_head c ids) stacks + +let pop_one (id,stack) = + let nstack= + match stack with + [] -> anomaly "impossible" + | [c] as l -> l + | (Some head,args)::(head0,args0)::ctx -> + let arg = applist (head,(List.rev args)) in + (head0,(arg::args0))::ctx + | (None,args)::(head0,args0)::ctx -> + (head0,(args@args0))::ctx + in id,nstack + +let pop_stacks stacks = + List.map pop_one stacks + +let hrec_for fix_id per_info gls obj_id = + let obj=mkVar obj_id in + let typ=pf_get_hyp_typ gls obj_id in + let rc,hd1=decompose_prod typ in + let cind,all_args=decompose_app typ in + let ind = destInd cind in assert (ind=per_info.per_ind); + let params,args= list_chop per_info.per_nparams all_args in + assert begin + try List.for_all2 eq_constr params per_info.per_params with + Invalid_argument _ -> false end; + let hd2 = applist (mkVar fix_id,args@[obj]) in + compose_lam rc (whd_beta gls.sigma hd2) + + +let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = + match tree, objs with + Close_patt t,_ -> + let args0 = pop_stacks args in + execute_cases fix_name per_info tacnext args0 objs nhrec t gls + | Skip_patt (_,t),skipped::next_objs -> + let args0 = push_arg skipped args in + execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls + | End_patt (id,(nparams,nhyps)),[] -> + begin + match List.assoc id args with + [None,br_args] -> + let all_metas = + list_tabulate (fun n -> mkMeta (succ n)) (nparams + nhyps) in + let param_metas,hyp_metas = list_chop nparams all_metas in + tclTHEN + (tclDO nhrec introf) + (tacnext + (applist (mkVar id, + List.append param_metas + (List.rev_append br_args hyp_metas)))) gls + | _ -> anomaly "wrong stack size" + end + | Split_patt (ids,ind,br), casee::next_objs -> + let (mind,oind) as spec = Global.lookup_inductive ind in + let nparams = mind.mind_nparams in + let concl=pf_concl gls in + let env=pf_env gls in + let ctyp=pf_type_of gls casee in + let hd,all_args = decompose_app (special_whd gls ctyp) in + let _ = assert (destInd hd = ind) in (* just in case *) + let params,real_args = list_chop nparams all_args in + let abstract_obj c body = + let typ=pf_type_of gls c in + lambda_create env (typ,subst_term c body) in + let elim_pred = List.fold_right abstract_obj + real_args (lambda_create env (ctyp,subst_term casee concl)) in + let case_info = Inductiveops.make_case_info env ind RegularStyle in + let gen_arities = Inductive.arities_of_constructors ind spec in + let f_ids typ = + let sign = + (prod_assum (Term.prod_applist typ params)) in + find_intro_names sign gls in + let constr_args_ids = Array.map f_ids gen_arities in + let case_term = + mkCase(case_info,elim_pred,casee, + Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in + let branch_tac i (recargs,bro) gls0 = + let args_ids = constr_args_ids.(i) in + let rec aux n = function + [] -> + assert (n=Array.length recargs); + next_objs,[],nhrec + | id :: q -> + let objs,recs,nrec = aux (succ n) q in + if recargs.(n) + then (mkVar id::objs),(id::recs),succ nrec + else (mkVar id::objs),recs,nrec in + let objs,recs,nhrec = aux 0 args_ids in + tclTHENLIST + [tclMAP intro_mustbe_force args_ids; + begin + fun gls1 -> + let hrecs = + List.map + (fun id -> + hrec_for (out_name fix_name) per_info gls1 id) + recs in + generalize hrecs gls1 + end; + match bro with + None -> + msg_warning (str "missing case"); + tacnext (mkMeta 1) + | Some (sub_ids,tree) -> + let br_args = + List.filter + (fun (id,_) -> Idset.mem id sub_ids) args in + let construct = + applist (mkConstruct(ind,succ i),params) in + let p_args = + push_head construct ids br_args in + execute_cases fix_name per_info tacnext + p_args objs nhrec tree] gls0 in + tclTHENSV + (refine case_term) + (Array.mapi branch_tac br) gls + | Split_patt (_, _, _) , [] -> + anomaly "execute_cases : Nothing to split" + | Skip_patt _ , [] -> + anomaly "execute_cases : Nothing to skip" + | End_patt (_,_) , _ :: _ -> + anomaly "execute_cases : End of branch with garbage left" + +let understand_my_constr c gls = + let env = pf_env gls in + let nc = names_of_rel_context env in + let rawc = Detyping.detype false [] nc c in + let rec frob = function GEvar _ -> GHole (dummy_loc,QuestionMark Expand) | rc -> map_glob_constr frob rc in + Pretyping.Default.understand_tcc (sig_sig gls) env ~expected_type:(pf_concl gls) (frob rawc) + +let my_refine c gls = + let oc = understand_my_constr c gls in + Refine.refine oc gls + +(* end focus/claim *) + +let end_tac et2 gls = + let info = get_its_info gls in + let et1,pi,ek,clauses = + match info.pm_stack with + Suppose_case::_ -> + anomaly "This case should already be trapped" + | Claim::_ -> + error "\"end claim\" expected." + | Focus_claim::_ -> + error "\"end focus\" expected." + | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) + | [] -> + anomaly "This case should already be trapped" in + let et = + if et1 <> et2 then + match et1 with + ET_Case_analysis -> + error "\"end cases\" expected." + | ET_Induction -> + error "\"end induction\" expected." + else et1 in + tclTHEN + tcl_erase_info + begin + match et,ek with + _,EK_unknown -> + tclSOLVE [simplest_elim pi.per_casee] + | ET_Case_analysis,EK_nodep -> + tclTHEN + (general_case_analysis false (pi.per_casee,NoBindings)) + (default_justification (List.map mkVar clauses)) + | ET_Induction,EK_nodep -> + tclTHENLIST + [generalize (pi.per_args@[pi.per_casee]); + simple_induct (AnonHyp (succ (List.length pi.per_args))); + default_justification (List.map mkVar clauses)] + | ET_Case_analysis,EK_dep tree -> + execute_cases Anonymous pi + (fun c -> tclTHENLIST + [my_refine c; + clear clauses; + justification assumption]) + (initial_instance_stack clauses) [pi.per_casee] 0 tree + | ET_Induction,EK_dep tree -> + let nargs = (List.length pi.per_args) in + tclTHEN (generalize (pi.per_args@[pi.per_casee])) + begin + fun gls0 -> + let fix_id = + pf_get_new_id (id_of_string "_fix") gls0 in + let c_id = + pf_get_new_id (id_of_string "_main_arg") gls0 in + tclTHENLIST + [fix (Some fix_id) (succ nargs); + tclDO nargs introf; + intro_mustbe_force c_id; + execute_cases (Name fix_id) pi + (fun c -> + tclTHENLIST + [clear [fix_id]; + my_refine c; + clear clauses; + justification assumption]) + (initial_instance_stack clauses) + [mkVar c_id] 0 tree] gls0 + end + end gls + +(* escape *) + +let escape_tac gls = + (* spiwack: sets an empty info stack to avoid interferences. + We could erase the info altogether, but that doesn't play + well with the Decl_mode.focus (used in post_processing). *) + let info={pm_stack=[]} in + tcl_change_info info gls + +(* General instruction engine *) + +let rec do_proof_instr_gen _thus _then instr = + match instr with + Pthus i -> + assert (not _thus); + do_proof_instr_gen true _then i + | Pthen i -> + assert (not _then); + do_proof_instr_gen _thus true i + | Phence i -> + assert (not (_then || _thus)); + do_proof_instr_gen true true i + | Pcut c -> + instr_cut mk_stat_or_thesis _thus _then c + | Psuffices c -> + instr_suffices _then c + | Prew (s,c) -> + assert (not _then); + instr_rew _thus s c + | Pconsider (c,hyps) -> consider_tac c hyps + | Pgiven hyps -> given_tac hyps + | Passume hyps -> assume_tac hyps + | Plet hyps -> assume_tac hyps + | Pclaim st -> instr_claim false st + | Pfocus st -> instr_claim true st + | Ptake witl -> take_tac witl + | Pdefine (id,args,body) -> define_tac id args body + | Pcast (id,typ) -> cast_tac id typ + | Pper (et,cs) -> per_tac et cs + | Psuppose hyps -> suppose_tac hyps + | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps + | Pend (B_elim et) -> end_tac et + | Pend _ -> anomaly "Not applicable" + | Pescape -> escape_tac + +let eval_instr {instr=instr} = + do_proof_instr_gen false false instr + +let rec preprocess pts instr = + match instr with + Phence i |Pthus i | Pthen i -> preprocess pts i + | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ + | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ + | Pdefine (_,_,_) | Pper _ | Prew _ -> + check_not_per pts; + true + | Pescape -> + check_not_per pts; + true + | Pcase _ | Psuppose _ | Pend (B_elim _) -> + close_previous_case pts ; + true + | Pend bt -> + close_block bt pts ; + false + +let rec postprocess pts instr = + match instr with + Phence i | Pthus i | Pthen i -> postprocess pts i + | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_) + | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> () + | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ -> + Decl_mode.focus pts + | Pescape -> + Decl_mode.focus pts; + Proof_global.set_proof_mode "Classic" + | Pend (B_elim ET_Induction) -> + begin + let pfterm = List.hd (Proof.partial_proof pts) in + let { it = gls ; sigma = sigma } = Proof.V82.subgoals pts in + let env = try + Goal.V82.env sigma (List.hd gls) + with Failure "hd" -> + Global.env () + in + try + Inductiveops.control_only_guard env pfterm; + goto_current_focus_or_top pts + with + Type_errors.TypeError(env, + Type_errors.IllFormedRecBody(_,_,_,_,_)) -> + anomaly "\"end induction\" generated an ill-formed fixpoint" + end + | Pend _ -> + goto_current_focus_or_top (pts) + +let do_instr raw_instr pts = + let has_tactic = preprocess pts raw_instr.instr in + begin + if has_tactic then + let { it=gls ; sigma=sigma } = Proof.V82.subgoals pts in + let gl = { it=List.hd gls ; sigma=sigma } in + let env= pf_env gl in + let ist = {ltacvars = ([],[]); ltacrecvars = []; + gsigma = sigma; genv = env} in + let glob_instr = intern_proof_instr ist raw_instr in + let instr = + interp_proof_instr (get_its_info gl) sigma env glob_instr in + Pfedit.by (tclTHEN (eval_instr instr) clean_tmp) + else () end; + postprocess pts raw_instr.instr; + (* spiwack: this should restore a compatible semantics with + v8.3 where we never stayed focused on 0 goal. *) + Decl_mode.maximal_unfocus pts + +let proof_instr raw_instr = + let p = Proof_global.give_me_the_proof () in + do_instr raw_instr p + +(* + +(* STUFF FOR ITERATED RELATIONS *) +let decompose_bin_app t= + let hd,args = destApp + +let identify_transitivity_lemma c = + let varx,tx,c1 = destProd c in + let vary,ty,c2 = destProd (pop c1) in + let varz,tz,c3 = destProd (pop c2) in + let _,p1,c4 = destProd (pop c3) in + let _,lp2,lp3 = destProd (pop c4) in + let p2=pop lp2 in + let p3=pop lp3 in +*) + diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli new file mode 100644 index 00000000..775d2f53 --- /dev/null +++ b/plugins/decl_mode/decl_proof_instr.mli @@ -0,0 +1,109 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Refiner +open Names +open Term +open Tacmach +open Decl_mode + +val go_to_proof_mode: unit -> unit +val return_from_tactic_mode: unit -> unit + +val register_automation_tac: tactic -> unit + +val automation_tac : tactic + +val concl_refiner: + Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr + +val do_instr: Decl_expr.raw_proof_instr -> Proof.proof -> unit +val proof_instr: Decl_expr.raw_proof_instr -> unit + +val tcl_change_info : Decl_mode.pm_info -> tactic + +val execute_cases : + Names.name -> + Decl_mode.per_info -> + (Term.constr -> Proof_type.tactic) -> + (Names.Idset.elt * (Term.constr option * Term.constr list) list) list -> + Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic + +val tree_of_pats : + identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> + split_tree + +val add_branch : + identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> + split_tree -> split_tree + +val append_branch : + identifier *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> + (Names.Idset.t * Decl_mode.split_tree) option -> + (Names.Idset.t * Decl_mode.split_tree) option + +val append_tree : + identifier * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> + split_tree -> split_tree + +val build_dep_clause : Term.types Decl_expr.statement list -> + Decl_expr.proof_pattern -> + Decl_mode.per_info -> + (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis) + Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types + +val register_dep_subcase : + Names.identifier * (int * int) -> + Environ.env -> + Decl_mode.per_info -> + Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind + +val thesis_for : Term.constr -> + Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr + +val close_previous_case : Proof.proof -> unit + +val pop_stacks : + (Names.identifier * + (Term.constr option * Term.constr list) list) list -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list + +val push_head : Term.constr -> + Names.Idset.t -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list + +val push_arg : Term.constr -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list -> + (Names.identifier * + (Term.constr option * Term.constr list) list) list + +val hrec_for: + Names.identifier -> + Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> + Names.identifier -> Term.constr + +val consider_match : + bool -> + (Names.Idset.elt*bool) list -> + Names.Idset.elt list -> + (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list -> + Proof_type.tactic + +val init_tree: + Names.Idset.t -> + Names.inductive -> + int option * Declarations.wf_paths -> + (int -> + (int option * Declarations.recarg Rtree.t) array -> + (Names.Idset.t * Decl_mode.split_tree) option) -> + Decl_mode.split_tree diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 new file mode 100644 index 00000000..5699c1bf --- /dev/null +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -0,0 +1,409 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "parsing/grammar.cma" i*) + +(* arnaud: veiller à l'aspect tutorial des commentaires *) + +open Pp +open Tok +open Decl_expr +open Names +open Term +open Genarg +open Pcoq + +open Pcoq.Constr +open Pcoq.Tactic +open Pcoq.Vernac_ + +let pr_goal gs = + let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in + let env = Goal.V82.unfiltered_env sigma g in + let preamb,thesis,penv,pc = + (str " *** Declarative Mode ***" ++ fnl ()++fnl ()), + (str "thesis := " ++ fnl ()), + Printer.pr_context_of env, + Printer.pr_goal_concl_style_env env (Goal.V82.concl sigma g) + in + preamb ++ + str" " ++ hv 0 (penv ++ fnl () ++ + str (Printer.emacs_str "") ++ + str "============================" ++ fnl () ++ + thesis ++ str " " ++ pc) ++ fnl () + +(* arnaud: rebrancher ça +let pr_open_subgoals () = + let p = Proof_global.give_me_the_proof () in + let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in + let close_cmd = Decl_mode.get_end_command p in + pr_subgoals close_cmd sigma goals +*) + +let pr_proof_instr instr = + Util.anomaly "Cannot print a proof_instr" + (* arnaud: Il nous faut quelque chose de type extr_genarg_printer si on veut aller + dans cette direction + Ppdecl_proof.pr_proof_instr (Global.env()) instr + *) +let pr_raw_proof_instr instr = + Util.anomaly "Cannot print a raw proof_instr" +let pr_glob_proof_instr instr = + Util.anomaly "Cannot print a non-interpreted proof_instr" + +let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }= + Decl_interp.interp_proof_instr + (Decl_mode.get_info sigma gl) + (sigma) + (Goal.V82.env sigma gl) + +let vernac_decl_proof () = + let pf = Proof_global.give_me_the_proof () in + if Proof.is_done pf then + Util.error "Nothing left to prove here." + else + Proof.transaction pf begin fun () -> + Decl_proof_instr.go_to_proof_mode () ; + Proof_global.set_proof_mode "Declarative" ; + Vernacentries.print_subgoals () + end + +(* spiwack: some bureaucracy is not performed here *) +let vernac_return () = + Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () -> + Decl_proof_instr.return_from_tactic_mode () ; + Proof_global.set_proof_mode "Declarative" ; + Vernacentries.print_subgoals () + end + +let vernac_proof_instr instr = + Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () -> + Decl_proof_instr.proof_instr instr; + Vernacentries.print_subgoals () + end + +(* We create a new parser entry [proof_mode]. The Declarative proof mode + will replace the normal parser entry for tactics with this one. *) +let proof_mode = Gram.entry_create "vernac:proof_command" +(* Auxiliary grammar entry. *) +let proof_instr = Gram.entry_create "proofmode:instr" + +(* Before we can write an new toplevel command (see below) + which takes a [proof_instr] as argument, we need to declare + how to parse it, print it, globalise it and interprete it. + Normally we could do that easily through ARGUMENT EXTEND, + but as the parsing is fairly complicated we will do it manually to + indirect through the [proof_instr] grammar entry. *) +(* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *) + +(* [Genarg.create_arg] creates a new embedding into Genarg. *) +let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) = + Genarg.create_arg None "proof_instr" +let _ = Tacinterp.add_interp_genarg "proof_instr" + begin + begin fun e x -> (* declares the globalisation function *) + Genarg.in_gen globwit_proof_instr + (Decl_interp.intern_proof_instr e (Genarg.out_gen rawwit_proof_instr x)) + end, + begin fun ist gl x -> (* declares the interpretation function *) + Tacmach.project gl , + Genarg.in_gen wit_proof_instr + (interp_proof_instr ist gl (Genarg.out_gen globwit_proof_instr x)) + end, + begin fun _ x -> x end (* declares the substitution function, irrelevant in our case *) + end + +let _ = Pptactic.declare_extra_genarg_pprule + (rawwit_proof_instr, pr_raw_proof_instr) + (globwit_proof_instr, pr_glob_proof_instr) + (wit_proof_instr, pr_proof_instr) + +(* We use the VERNAC EXTEND facility with a custom non-terminal + to populate [proof_mode] with a new toplevel interpreter. + The "-" indicates that the rule does not start with a distinguished + string. *) +VERNAC proof_mode EXTEND ProofInstr + [ - proof_instr(instr) ] -> [ vernac_proof_instr instr ] +END + +(* It is useful to use GEXTEND directly to call grammar entries that have been + defined previously VERNAC EXTEND. In this case we allow, in proof mode, + the use of commands like Check or Print. VERNAC EXTEND does quite a bit of + bureaucracy for us, but it is not needed in this sort of case, and it would require + to have an ARGUMENT EXTEND version of the "proof_mode" grammar entry. *) +GEXTEND Gram + GLOBAL: proof_mode ; + + proof_mode: LAST + [ [ c=G_vernac.subgoal_command -> c (Some 1) ] ] + ; +END + +(* We register a new proof mode here *) + +let _ = + Proof_global.register_proof_mode { Proof_global. + name = "Declarative" ; (* name for identifying and printing *) + (* function [set] goes from No Proof Mode to + Declarative Proof Mode performing side effects *) + set = begin fun () -> + (* We set the command non terminal to + [proof_mode] (which we just defined). *) + G_vernac.set_command_entry proof_mode ; + (* We substitute the goal printer, by the one we built + for the proof mode. *) + Printer.set_printer_pr { Printer.default_printer_pr with + Printer.pr_goal = pr_goal } + end ; + (* function [reset] goes back to No Proof Mode from + Declarative Proof Mode *) + reset = begin fun () -> + (* We restore the command non terminal to + [noedit_mode]. *) + G_vernac.set_command_entry G_vernac.noedit_mode ; + (* We restore the goal printer to default *) + Printer.set_printer_pr Printer.default_printer_pr + end + } + +(* Two new vernacular commands *) +VERNAC COMMAND EXTEND DeclProof + [ "proof" ] -> [ vernac_decl_proof () ] +END +VERNAC COMMAND EXTEND DeclReturn + [ "return" ] -> [ vernac_return () ] +END + +let none_is_empty = function + None -> [] + | Some l -> l + +GEXTEND Gram +GLOBAL: proof_instr; + thesis : + [[ "thesis" -> Plain + | "thesis"; "for"; i=ident -> (For i) + ]]; + statement : + [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} + | i=ident -> {st_label=Anonymous; + st_it=Topconstr.CRef (Libnames.Ident (loc, i))} + | c=constr -> {st_label=Anonymous;st_it=c} + ]]; + constr_or_thesis : + [[ t=thesis -> Thesis t ] | + [ c=constr -> This c + ]]; + statement_or_thesis : + [ + [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] + | + [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} + | i=ident -> {st_label=Anonymous; + st_it=This (Topconstr.CRef (Libnames.Ident (loc, i)))} + | c=constr -> {st_label=Anonymous;st_it=This c} + ] + ]; + justification_items : + [[ -> Some [] + | "by"; l=LIST1 constr SEP "," -> Some l + | "by"; "*" -> None ]] + ; + justification_method : + [[ -> None + | "using"; tac = tactic -> Some tac ]] + ; + simple_cut_or_thesis : + [[ ls = statement_or_thesis; + j = justification_items; + taco = justification_method + -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] + ; + simple_cut : + [[ ls = statement; + j = justification_items; + taco = justification_method + -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] + ; + elim_type: + [[ IDENT "induction" -> ET_Induction + | IDENT "cases" -> ET_Case_analysis ]] + ; + block_type : + [[ IDENT "claim" -> B_claim + | IDENT "focus" -> B_focus + | IDENT "proof" -> B_proof + | et=elim_type -> B_elim et ]] + ; + elim_obj: + [[ IDENT "on"; c=constr -> Real c + | IDENT "of"; c=simple_cut -> Virtual c ]] + ; + elim_step: + [[ IDENT "consider" ; + h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h) + | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj) + | IDENT "suffices"; ls=suff_clause; + j = justification_items; + taco = justification_method + -> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] + ; + rew_step : + [[ "~=" ; c=simple_cut -> (Rhs,c) + | "=~" ; c=simple_cut -> (Lhs,c)]] + ; + cut_step: + [[ "then"; tt=elim_step -> Pthen tt + | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c) + | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) + | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c) + | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c) + | tt=elim_step -> tt + | tt=rew_step -> let s,c=tt in Prew (s,c); + | IDENT "have"; c=simple_cut_or_thesis -> Pcut c; + | IDENT "claim"; c=statement -> Pclaim c; + | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c; + | "end"; bt = block_type -> Pend bt; + | IDENT "escape" -> Pescape ]] + ; + (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*) + loc_id: + [[ id=ident -> fun x -> (loc,(id,x)) ]]; + hyp: + [[ id=loc_id -> id None ; + | id=loc_id ; ":" ; c=constr -> id (Some c)]] + ; + consider_vars: + [[ name=hyp -> [Hvar name] + | name=hyp; ","; v=consider_vars -> (Hvar name) :: v + | name=hyp; + IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h + ]] + ; + consider_hyps: + [[ st=statement; IDENT "and"; h=consider_hyps -> Hprop st::h + | st=statement; IDENT "and"; + IDENT "consider" ; v=consider_vars -> Hprop st::v + | st=statement -> [Hprop st] + ]] + ; + assume_vars: + [[ name=hyp -> [Hvar name] + | name=hyp; ","; v=assume_vars -> (Hvar name) :: v + | name=hyp; + IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h + ]] + ; + assume_hyps: + [[ st=statement; IDENT "and"; h=assume_hyps -> Hprop st::h + | st=statement; IDENT "and"; + IDENT "we"; IDENT "have" ; v=assume_vars -> Hprop st::v + | st=statement -> [Hprop st] + ]] + ; + assume_clause: + [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v + | h=assume_hyps -> h ]] + ; + suff_vars: + [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> + [Hvar name],c + | name=hyp; ","; v=suff_vars -> + let (q,c) = v in ((Hvar name) :: q),c + | name=hyp; + IDENT "such"; IDENT "that"; h=suff_hyps -> + let (q,c) = h in ((Hvar name) :: q),c + ]]; + suff_hyps: + [[ st=statement; IDENT "and"; h=suff_hyps -> + let (q,c) = h in (Hprop st::q),c + | st=statement; IDENT "and"; + IDENT "to" ; IDENT "have" ; v=suff_vars -> + let (q,c) = v in (Hprop st::q),c + | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> + [Hprop st],c + ]] + ; + suff_clause: + [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v + | h=suff_hyps -> h ]] + ; + let_vars: + [[ name=hyp -> [Hvar name] + | name=hyp; ","; v=let_vars -> (Hvar name) :: v + | name=hyp; IDENT "be"; + IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h + ]] + ; + let_hyps: + [[ st=statement; IDENT "and"; h=let_hyps -> Hprop st::h + | st=statement; IDENT "and"; "let"; v=let_vars -> Hprop st::v + | st=statement -> [Hprop st] + ]]; + given_vars: + [[ name=hyp -> [Hvar name] + | name=hyp; ","; v=given_vars -> (Hvar name) :: v + | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h + ]] + ; + given_hyps: + [[ st=statement; IDENT "and"; h=given_hyps -> Hprop st::h + | st=statement; IDENT "and"; IDENT "given"; v=given_vars -> Hprop st::v + | st=statement -> [Hprop st] + ]]; + suppose_vars: + [[name=hyp -> [Hvar name] + |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v + |name=hyp; OPT[IDENT "be"]; + IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h + ]] + ; + suppose_hyps: + [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h + | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have"; + v=suppose_vars -> Hprop st::v + | st=statement_or_thesis -> [Hprop st] + ]] + ; + suppose_clause: + [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v; + | h=suppose_hyps -> h ]] + ; + intro_step: + [[ IDENT "suppose" ; h=assume_clause -> Psuppose h + | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ; + po=OPT[ "with"; p=LIST1 hyp SEP ","-> p ] ; + ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> + Pcase (none_is_empty po,c,none_is_empty ho) + | "let" ; v=let_vars -> Plet v + | IDENT "take"; witnesses = LIST1 constr SEP "," -> Ptake witnesses + | IDENT "assume"; h=assume_clause -> Passume h + | IDENT "given"; h=given_vars -> Pgiven h + | IDENT "define"; id=ident; args=LIST0 hyp; + "as"; body=constr -> Pdefine(id,args,body) + | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ) + | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ) + ]] + ; + emphasis : + [[ -> 0 + | "*" -> 1 + | "**" -> 2 + | "***" -> 3 + ]] + ; + bare_proof_instr: + [[ c = cut_step -> c ; + | i = intro_step -> i ]] + ; + proof_instr : + [[ e=emphasis;i=bare_proof_instr;"." -> {emph=e;instr=i}]] + ; +END;; + + diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml new file mode 100644 index 00000000..7ba0d4ff --- /dev/null +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -0,0 +1,188 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open Decl_expr +open Names +open Nameops + +let pr_constr = Printer.pr_constr_env +let pr_tac = Pptactic.pr_glob_tactic +let pr_pat mpat = Ppconstr.pr_cases_pattern_expr mpat.pat_expr + +let pr_label = function + Anonymous -> mt () + | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () + +let pr_justification_items env = function + Some [] -> mt () + | Some (_::_ as l) -> + spc () ++ str "by" ++ spc () ++ + prlist_with_sep (fun () -> str ",") (pr_constr env) l + | None -> spc () ++ str "by *" + +let pr_justification_method env = function + None -> mt () + | Some tac -> + spc () ++ str "using" ++ spc () ++ pr_tac env tac + +let pr_statement pr_it env st = + pr_label st.st_label ++ pr_it env st.st_it + +let pr_or_thesis pr_this env = function + Thesis Plain -> str "thesis" + | Thesis (For id) -> + str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id + | This c -> pr_this env c + +let pr_cut pr_it env c = + hov 1 (pr_it env c.cut_stat) ++ + pr_justification_items env c.cut_by ++ + pr_justification_method env c.cut_using + +let type_or_thesis = function + Thesis _ -> Term.mkProp + | This c -> c + +let _I x = x + +let rec print_hyps pconstr gtyp env sep _be _have hyps = + let pr_sep = if sep then str "and" ++ spc () else mt () in + match hyps with + (Hvar _ ::_) as rest -> + spc () ++ pr_sep ++ str _have ++ + print_vars pconstr gtyp env false _be _have rest + | Hprop st :: rest -> + begin + let nenv = + match st.st_label with + Anonymous -> env + | Name id -> Environ.push_named (id,None,gtyp st.st_it) env in + spc() ++ pr_sep ++ pr_statement pconstr env st ++ + print_hyps pconstr gtyp nenv true _be _have rest + end + | [] -> mt () + +and print_vars pconstr gtyp env sep _be _have vars = + match vars with + Hvar st :: rest -> + begin + let nenv = + match st.st_label with + Anonymous -> anomaly "anonymous variable" + | Name id -> Environ.push_named (id,None,st.st_it) env in + let pr_sep = if sep then pr_comma () else mt () in + spc() ++ pr_sep ++ + pr_statement pr_constr env st ++ + print_vars pconstr gtyp nenv true _be _have rest + end + | (Hprop _ :: _) as rest -> + let _st = if _be then + str "be such that" + else + str "such that" in + spc() ++ _st ++ print_hyps pconstr gtyp env false _be _have rest + | [] -> mt () + +let pr_suffices_clause env (hyps,c) = + print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++ + str "to show" ++ spc () ++ pr_or_thesis pr_constr env c + +let pr_elim_type = function + ET_Case_analysis -> str "cases" + | ET_Induction -> str "induction" + +let pr_casee env =function + Real c -> str "on" ++ spc () ++ pr_constr env c + | Virtual cut -> str "of" ++ spc () ++ pr_cut (pr_statement pr_constr) env cut + +let pr_side = function + Lhs -> str "=~" + | Rhs -> str "~=" + +let rec pr_bare_proof_instr _then _thus env = function + | Pescape -> str "escape" + | Pthen i -> pr_bare_proof_instr true _thus env i + | Pthus i -> pr_bare_proof_instr _then true env i + | Phence i -> pr_bare_proof_instr true true env i + | Pcut c -> + begin + match _then,_thus with + false,false -> str "have" ++ spc () ++ + pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + | false,true -> str "thus" ++ spc () ++ + pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + | true,false -> str "then" ++ spc () ++ + pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + | true,true -> str "hence" ++ spc () ++ + pr_cut (pr_statement (pr_or_thesis pr_constr)) env c + end + | Psuffices c -> + str "suffices" ++ pr_cut pr_suffices_clause env c + | Prew (sid,c) -> + (if _thus then str "thus" else str " ") ++ spc () ++ + pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c + | Passume hyps -> + str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps + | Plet hyps -> + str "let" ++ print_vars pr_constr _I env false true "let" hyps + | Pclaim st -> + str "claim" ++ spc () ++ pr_statement pr_constr env st + | Pfocus st -> + str "focus on" ++ spc () ++ pr_statement pr_constr env st + | Pconsider (id,hyps) -> + str "consider" ++ print_vars pr_constr _I env false false "consider" hyps + ++ spc () ++ str "from " ++ pr_constr env id + | Pgiven hyps -> + str "given" ++ print_vars pr_constr _I env false false "given" hyps + | Ptake witl -> + str "take" ++ spc () ++ + prlist_with_sep pr_comma (pr_constr env) witl + | Pdefine (id,args,body) -> + str "define" ++ spc () ++ pr_id id ++ spc () ++ + prlist_with_sep spc + (fun st -> str "(" ++ + pr_statement pr_constr env st ++ str ")") args ++ spc () ++ + str "as" ++ (pr_constr env body) + | Pcast (id,typ) -> + str "reconsider" ++ spc () ++ + pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ + str "as" ++ spc () ++ (pr_constr env typ) + | Psuppose hyps -> + str "suppose" ++ + print_hyps pr_constr _I env false false "we have" hyps + | Pcase (params,pat,hyps) -> + str "suppose it is" ++ spc () ++ pr_pat pat ++ + (if params = [] then mt () else + (spc () ++ str "with" ++ spc () ++ + prlist_with_sep spc + (fun st -> str "(" ++ + pr_statement pr_constr env st ++ str ")") params ++ spc ())) + ++ + (if hyps = [] then mt () else + (spc () ++ str "and" ++ + print_hyps (pr_or_thesis pr_constr) type_or_thesis + env false false "we have" hyps)) + | Pper (et,c) -> + str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ + pr_casee env c + | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et + | _ -> anomaly "unprintable instruction" + +let pr_emph = function + 0 -> str " " + | 1 -> str "* " + | 2 -> str "** " + | 3 -> str "*** " + | _ -> anomaly "unknown emphasis" + +let pr_proof_instr env instr = + pr_emph instr.emph ++ spc () ++ + pr_bare_proof_instr false false env instr.instr + diff --git a/plugins/decl_mode/ppdecl_proof.mli b/plugins/decl_mode/ppdecl_proof.mli new file mode 100644 index 00000000..fd6fb663 --- /dev/null +++ b/plugins/decl_mode/ppdecl_proof.mli @@ -0,0 +1,2 @@ + +val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v deleted file mode 100644 index 5ddc4452..00000000 --- a/plugins/dp/Dp.v +++ /dev/null @@ -1,120 +0,0 @@ -(* Calls to external decision procedures *) - -Require Export ZArith. -Require Export Classical. - -(* Zenon *) - -(* Copyright 2004 INRIA *) -(* $Id: Dp.v 12337 2009-09-17 15:58:14Z glondu $ *) - -Lemma zenon_nottrue : - (~True -> False). -Proof. tauto. Qed. - -Lemma zenon_noteq : forall (T : Type) (t : T), - ((t <> t) -> False). -Proof. tauto. Qed. - -Lemma zenon_and : forall P Q : Prop, - (P -> Q -> False) -> (P /\ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_or : forall P Q : Prop, - (P -> False) -> (Q -> False) -> (P \/ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_imply : forall P Q : Prop, - (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_equiv : forall P Q : Prop, - (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notand : forall P Q : Prop, - (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notor : forall P Q : Prop, - (~P -> ~Q -> False) -> (~(P \/ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notimply : forall P Q : Prop, - (P -> ~Q -> False) -> (~(P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notequiv : forall P Q : Prop, - (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_ex : forall (T : Type) (P : T -> Prop), - (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), - ((P t) -> False) -> ((forall x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), - (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notall : forall (T : Type) (P : T -> Prop), - (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). -Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. - -Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. -Proof. auto. Qed. - -Lemma zenon_equal_step : - forall (S T : Type) (fa fb : S -> T) (a b : S), - (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). -Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. - -Lemma zenon_pnotp : forall P Q : Prop, - (P = Q) -> (P -> ~Q -> False). -Proof. intros P Q Ha. rewrite Ha. auto. Qed. - -Lemma zenon_notequal : forall (T : Type) (a b : T), - (a = b) -> (a <> b -> False). -Proof. auto. Qed. - -Ltac zenon_intro id := - intro id || let nid := fresh in (intro nid; clear nid) -. - -Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. -Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. -Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. -Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. -Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. -Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. -Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. -Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. -Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. -Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. - -Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. -Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. - -(* Ergo *) - -Set Implicit Arguments. -Section congr. - Variable t:Type. -Lemma ergo_eq_concat_1 : - forall (P:t -> Prop) (x y:t), - P x -> x = y -> P y. -Proof. - intros; subst; auto. -Qed. - -Lemma ergo_eq_concat_2 : - forall (P:t -> t -> Prop) (x1 x2 y1 y2:t), - P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2. -Proof. - intros; subst; auto. -Qed. - -End congr. diff --git a/plugins/dp/TODO b/plugins/dp/TODO deleted file mode 100644 index 44349e21..00000000 --- a/plugins/dp/TODO +++ /dev/null @@ -1,24 +0,0 @@ - -TODO ----- - -- axiomes pour les prédicats récursifs comme - - Fixpoint even (n:nat) : Prop := - match n with - O => True - | S O => False - | S (S p) => even p - end. - - ou encore In sur les listes du module Coq List. - -- discriminate - -- inversion (Set et Prop) - - -BUGS ----- - - diff --git a/plugins/dp/dp.ml b/plugins/dp/dp.ml deleted file mode 100644 index ceadd26e..00000000 --- a/plugins/dp/dp.ml +++ /dev/null @@ -1,1134 +0,0 @@ -(* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *) -(* Tactics to call decision procedures *) - -(* Works in two steps: - - - first the Coq context and the current goal are translated in - Polymorphic First-Order Logic (see fol.mli in this directory) - - - then the resulting query is passed to the Why tool that translates - it to the syntax of the selected prover (Simplify, CVC Lite, haRVey, - Zenon) -*) - -open Util -open Pp -open Libobject -open Summary -open Term -open Tacmach -open Tactics -open Tacticals -open Fol -open Names -open Nameops -open Namegen -open Termops -open Coqlib -open Hipattern -open Libnames -open Declarations -open Dp_why - -let debug = ref false -let set_debug b = debug := b -let trace = ref false -let set_trace b = trace := b -let timeout = ref 10 -let set_timeout n = timeout := n - -let (dp_timeout_obj,_) = - declare_object - {(default_object "Dp_timeout") with - cache_function = (fun (_,x) -> set_timeout x); - load_function = (fun _ (_,x) -> set_timeout x)} - -let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x) - -let (dp_debug_obj,_) = - declare_object - {(default_object "Dp_debug") with - cache_function = (fun (_,x) -> set_debug x); - load_function = (fun _ (_,x) -> set_debug x)} - -let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x) - -let (dp_trace_obj,_) = - declare_object - {(default_object "Dp_trace") with - cache_function = (fun (_,x) -> set_trace x); - load_function = (fun _ (_,x) -> set_trace x)} - -let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x) - -let logic_dir = ["Coq";"Logic";"Decidable"] -let coq_modules = - init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules - @ [["Coq"; "ZArith"; "BinInt"]; - ["Coq"; "Reals"; "Rdefinitions"]; - ["Coq"; "Reals"; "Raxioms";]; - ["Coq"; "Reals"; "Rbasic_fun";]; - ["Coq"; "Reals"; "R_sqrt";]; - ["Coq"; "Reals"; "Rfunctions";]] - @ [["Coq"; "omega"; "OmegaLemmas"]] - -let constant = gen_constant_in_modules "dp" coq_modules - -(* integers constants and operations *) -let coq_Z = lazy (constant "Z") -let coq_Zplus = lazy (constant "Zplus") -let coq_Zmult = lazy (constant "Zmult") -let coq_Zopp = lazy (constant "Zopp") -let coq_Zminus = lazy (constant "Zminus") -let coq_Zdiv = lazy (constant "Zdiv") -let coq_Zs = lazy (constant "Zs") -let coq_Zgt = lazy (constant "Zgt") -let coq_Zle = lazy (constant "Zle") -let coq_Zge = lazy (constant "Zge") -let coq_Zlt = lazy (constant "Zlt") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") -let coq_xH = lazy (constant "xH") -let coq_xI = lazy (constant "xI") -let coq_xO = lazy (constant "xO") -let coq_iff = lazy (constant "iff") - -(* real constants and operations *) -let coq_R = lazy (constant "R") -let coq_R0 = lazy (constant "R0") -let coq_R1 = lazy (constant "R1") -let coq_Rgt = lazy (constant "Rgt") -let coq_Rle = lazy (constant "Rle") -let coq_Rge = lazy (constant "Rge") -let coq_Rlt = lazy (constant "Rlt") -let coq_Rplus = lazy (constant "Rplus") -let coq_Rmult = lazy (constant "Rmult") -let coq_Ropp = lazy (constant "Ropp") -let coq_Rminus = lazy (constant "Rminus") -let coq_Rdiv = lazy (constant "Rdiv") -let coq_powerRZ = lazy (constant "powerRZ") - -(* not Prop typed expressions *) -exception NotProp - -(* not first-order expressions *) -exception NotFO - -(* Renaming of Coq globals *) - -let global_names = Hashtbl.create 97 -let used_names = Hashtbl.create 97 - -let rename_global r = - try - Hashtbl.find global_names r - with Not_found -> - let rec loop id = - if Hashtbl.mem used_names id then - loop (lift_subscript id) - else begin - Hashtbl.add used_names id (); - let s = string_of_id id in - Hashtbl.add global_names r s; - s - end - in - loop (Nametab.basename_of_global r) - -let foralls = - List.fold_right - (fun (x,t) p -> Forall (x, t, p)) - -let fresh_var = function - | Anonymous -> rename_global (VarRef (id_of_string "x")) - | Name x -> rename_global (VarRef x) - -(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of - env names, and returns the new variables together with the new - environment *) -let coq_rename_vars env vars = - let avoid = ref (ids_of_named_context (Environ.named_context env)) in - List.fold_right - (fun (na,t) (newvars, newenv) -> - let id = next_name_away na !avoid in - avoid := id :: !avoid; - id :: newvars, Environ.push_named (id, None, t) newenv) - vars ([],env) - -(* extract the prenex type quantifications i.e. - type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *) -let decomp_type_quantifiers env t = - let rec loop vars t = match kind_of_term t with - | Prod (n, a, t) when is_Set a || is_Type a -> - loop ((n,a) :: vars) t - | _ -> - let vars, env = coq_rename_vars env vars in - let t = substl (List.map mkVar vars) t in - List.rev vars, env, t - in - loop [] t - -(* same thing with lambda binders (for axiomatize body) *) -let decomp_type_lambdas env t = - let rec loop vars t = match kind_of_term t with - | Lambda (n, a, t) when is_Set a || is_Type a -> - loop ((n,a) :: vars) t - | _ -> - let vars, env = coq_rename_vars env vars in - let t = substl (List.map mkVar vars) t in - List.rev vars, env, t - in - loop [] t - -let decompose_arrows = - let rec arrows_rec l c = match kind_of_term c with - | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c - | Cast (c,_,_) -> arrows_rec l c - | _ -> List.rev l, c - in - arrows_rec [] - -let rec eta_expanse t vars env i = - assert (i >= 0); - if i = 0 then - t, vars, env - else - match kind_of_term (Typing.type_of env Evd.empty t) with - | Prod (n, a, b) when not (dependent (mkRel 1) b) -> - let avoid = ids_of_named_context (Environ.named_context env) in - let id = next_name_away n avoid in - let env' = Environ.push_named (id, None, a) env in - let t' = mkApp (t, [| mkVar id |]) in - eta_expanse t' (id :: vars) env' (pred i) - | _ -> - assert false - -let rec skip_k_args k cl = match k, cl with - | 0, _ -> cl - | _, _ :: cl -> skip_k_args (k-1) cl - | _, [] -> raise NotFO - -(* Coq global references *) - -type global = Gnot_fo | Gfo of Fol.decl - -let globals = ref Refmap.empty -let globals_stack = ref [] - -(* synchronization *) -let () = - Summary.declare_summary "Dp globals" - { Summary.freeze_function = (fun () -> !globals, !globals_stack); - Summary.unfreeze_function = - (fun (g,s) -> globals := g; globals_stack := s); - Summary.init_function = (fun () -> ()) } - -let add_global r d = globals := Refmap.add r d !globals -let mem_global r = Refmap.mem r !globals -let lookup_global r = match Refmap.find r !globals with - | Gnot_fo -> raise NotFO - | Gfo d -> d - -let locals = Hashtbl.create 97 - -let lookup_local r = match Hashtbl.find locals r with - | Gnot_fo -> raise NotFO - | Gfo d -> d - -let iter_all_constructors i f = - let _, oib = Global.lookup_inductive i in - Array.iteri - (fun j tj -> f j (mkConstruct (i, j+1))) - oib.mind_nf_lc - - -(* injection c [t1,...,tn] adds the injection axiom - forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. - c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *) - -let injection c l = - let i = ref 0 in - let var s = incr i; id_of_string (s ^ string_of_int !i) in - let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in - i := 0; - let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in - let f = - List.fold_right2 - (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p)) - xl yl True - in - let vars = List.map (fun (x,_) -> App(x,[])) in - let f = Imp (Fatom (Eq (App (c, vars xl), App (c, vars yl))), f) in - let foralls = List.fold_right (fun (x,t) p -> Forall (x, t, p)) in - let f = foralls xl (foralls yl f) in - let ax = Axiom ("injection_" ^ c, f) in - globals_stack := ax :: !globals_stack - -(* rec_names_for c [|n1;...;nk|] builds the list of constant names for - identifiers n1...nk with the same path as c, if they exist; otherwise - raises Not_found *) -let rec_names_for c = - let mp,dp,_ = Names.repr_con c in - array_map_to_list - (function - | Name id -> - let c' = Names.make_con mp dp (label_of_id id) in - ignore (Global.lookup_constant c'); - msgnl (Printer.pr_constr (mkConst c')); - c' - | Anonymous -> - raise Not_found) - -(* abstraction tables *) - -let term_abstractions = Hashtbl.create 97 - -let new_abstraction = - let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r - -(* Arithmetic constants *) - -exception NotArithConstant - -(* translates a closed Coq term p:positive into a FOL term of type int *) - -let big_two = Big_int.succ_big_int Big_int.unit_big_int - -let rec tr_positive p = match kind_of_term p with - | Term.Construct _ when p = Lazy.force coq_xH -> - Big_int.unit_big_int - | Term.App (f, [|a|]) when f = Lazy.force coq_xI -> -(* - Plus (Mult (Cst 2, tr_positive a), Cst 1) -*) - Big_int.succ_big_int (Big_int.mult_big_int big_two (tr_positive a)) - | Term.App (f, [|a|]) when f = Lazy.force coq_xO -> -(* - Mult (Cst 2, tr_positive a) -*) - Big_int.mult_big_int big_two (tr_positive a) - | Term.Cast (p, _, _) -> - tr_positive p - | _ -> - raise NotArithConstant - -(* translates a closed Coq term t:Z or R into a FOL term of type int or real *) -let rec tr_arith_constant t = match kind_of_term t with - | Term.Construct _ when t = Lazy.force coq_Z0 -> - Cst Big_int.zero_big_int - | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> - Cst (tr_positive a) - | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> - Cst (Big_int.minus_big_int (tr_positive a)) - | Term.Const _ when t = Lazy.force coq_R0 -> - RCst Big_int.zero_big_int - | Term.Const _ when t = Lazy.force coq_R1 -> - RCst Big_int.unit_big_int - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> - let ta = tr_arith_constant a in - let tb = tr_arith_constant b in - begin match ta,tb with - | RCst na, RCst nb -> RCst (Big_int.add_big_int na nb) - | _ -> raise NotArithConstant - end - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> - let ta = tr_arith_constant a in - let tb = tr_arith_constant b in - begin match ta,tb with - | RCst na, RCst nb -> RCst (Big_int.mult_big_int na nb) - | _ -> raise NotArithConstant - end - | Term.App (f, [|a;b|]) when f = Lazy.force coq_powerRZ -> - tr_powerRZ a b - | Term.Cast (t, _, _) -> - tr_arith_constant t - | _ -> - raise NotArithConstant - -(* translates a constant of the form (powerRZ 2 int_constant) *) -and tr_powerRZ a b = - (* checking first that a is (R1 + R1) *) - match kind_of_term a with - | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus -> - begin - match kind_of_term c,kind_of_term d with - | Term.Const _, Term.Const _ - when c = Lazy.force coq_R1 && d = Lazy.force coq_R1 -> - begin - match tr_arith_constant b with - | Cst n -> Power2 n - | _ -> raise NotArithConstant - end - | _ -> raise NotArithConstant - end - | _ -> raise NotArithConstant - - -(* translate a Coq term t:Set into a FOL type expression; - tv = list of type variables *) -and tr_type tv env t = - let t = Reductionops.nf_betadeltaiota env Evd.empty t in - if t = Lazy.force coq_Z then - Tid ("int", []) - else if t = Lazy.force coq_R then - Tid ("real", []) - else match kind_of_term t with - | Var x when List.mem x tv -> - Tvar (string_of_id x) - | _ -> - let f, cl = decompose_app t in - begin try - let r = global_of_constr f in - match tr_global env r with - | DeclType (id, k) -> - assert (k = List.length cl); (* since t:Set *) - Tid (id, List.map (tr_type tv env) cl) - | _ -> - raise NotFO - with - | Not_found -> - raise NotFO - | NotFO -> - (* we need to abstract some part of (f cl) *) - (*TODO*) - raise NotFO - end - -and make_term_abstraction tv env c = - let ty = Typing.type_of env Evd.empty c in - let id = new_abstraction () in - match tr_decl env id ty with - | DeclFun (id,_,_,_) as _d -> - raise NotFO - (* [CM 07/09/2009] deactivated because it generates - unbound identifiers 'abstraction_<number>' - begin try - Hashtbl.find term_abstractions c - with Not_found -> - Hashtbl.add term_abstractions c id; - globals_stack := d :: !globals_stack; - id - end - *) - | _ -> - raise NotFO - -(* translate a Coq declaration id:ty in a FOL declaration, that is either - - a type declaration : DeclType (id, n) where n:int is the type arity - - a function declaration : DeclFun (id, tl, t) ; that includes constants - - a predicate declaration : DeclPred (id, tl) - - an axiom : Axiom (id, p) - *) -and tr_decl env id ty = - let tv, env, t = decomp_type_quantifiers env ty in - if is_Set t || is_Type t then - DeclType (id, List.length tv) - else if is_Prop t then - DeclPred (id, List.length tv, []) - else - let s = Typing.type_of env Evd.empty t in - if is_Prop s then - Axiom (id, tr_formula tv [] env t) - else - let l, t = decompose_arrows t in - let l = List.map (tr_type tv env) l in - if is_Prop t then - DeclPred(id, List.length tv, l) - else - let s = Typing.type_of env Evd.empty t in - if is_Set s || is_Type s then - DeclFun (id, List.length tv, l, tr_type tv env t) - else - raise NotFO - -(* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *) -and tr_global env r = match r with - | VarRef id -> - lookup_local id - | r -> - try - lookup_global r - with Not_found -> - try - let ty = Global.type_of_global r in - let id = rename_global r in - let d = tr_decl env id ty in - (* r can be already declared if it is a constructor *) - if not (mem_global r) then begin - add_global r (Gfo d); - globals_stack := d :: !globals_stack - end; - begin try axiomatize_body env r id d with NotFO -> () end; - d - with NotFO -> - add_global r Gnot_fo; - raise NotFO - -and axiomatize_body env r id d = match r with - | VarRef _ -> - assert false - | ConstRef c -> - begin match (Global.lookup_constant c).const_body with - | Some b -> - let b = force b in - let axioms = - (match d with - | DeclPred (id, _, []) -> - let tv, env, b = decomp_type_lambdas env b in - let value = tr_formula tv [] env b in - [id, Iff (Fatom (Pred (id, [])), value)] - | DeclFun (id, _, [], _) -> - let tv, env, b = decomp_type_lambdas env b in - let value = tr_term tv [] env b in - [id, Fatom (Eq (Fol.App (id, []), value))] - | DeclFun (id, _, l, _) | DeclPred (id, _, l) -> - (*Format.eprintf "axiomatize_body %S@." id;*) - let b = match kind_of_term b with - (* a single recursive function *) - | Fix (_, (_,_,[|b|])) -> - subst1 (mkConst c) b - (* mutually recursive functions *) - | Fix ((_,i), (names,_,bodies)) -> - (* we only deal with named functions *) - begin try - let l = rec_names_for c names in - substl (List.rev_map mkConst l) bodies.(i) - with Not_found -> - b - end - | _ -> - b - in - let tv, env, b = decomp_type_lambdas env b in - let vars, t = decompose_lam b in - let n = List.length l in - let k = List.length vars in - assert (k <= n); - let vars, env = coq_rename_vars env vars in - let t = substl (List.map mkVar vars) t in - let t, vars, env = eta_expanse t vars env (n-k) in - let vars = List.rev vars in - let bv = vars in - let vars = List.map (fun x -> string_of_id x) vars in - let fol_var x = Fol.App (x, []) in - let fol_vars = List.map fol_var vars in - let vars = List.combine vars l in - begin match d with - | DeclFun (_, _, _, ty) -> - begin match kind_of_term t with - | Case (ci, _, e, br) -> - equations_for_case env id vars tv bv ci e br - | _ -> - let t = tr_term tv bv env t in - let ax = - add_proof (Fun_def (id, vars, ty, t)) - in - let p = Fatom (Eq (App (id, fol_vars), t)) in - [ax, foralls vars p] - end - | DeclPred _ -> - let value = tr_formula tv bv env t in - let p = Iff (Fatom (Pred (id, fol_vars)), value) in - [id, foralls vars p] - | _ -> - assert false - end - | DeclType _ -> - raise NotFO - | Axiom _ -> assert false) - in - let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in - globals_stack := axioms @ !globals_stack - | None -> - () (* Coq axiom *) - end - | IndRef i -> - iter_all_constructors i - (fun _ c -> - let rc = global_of_constr c in - try - begin match tr_global env rc with - | DeclFun (_, _, [], _) -> () - | DeclFun (idc, _, al, _) -> injection idc al - | _ -> () - end - with NotFO -> - ()) - | _ -> () - -and equations_for_case env id vars tv bv ci e br = match kind_of_term e with - | Var x when List.exists (fun (y, _) -> string_of_id x = y) vars -> - let eqs = ref [] in - iter_all_constructors ci.ci_ind - (fun j cj -> - try - let cjr = global_of_constr cj in - begin match tr_global env cjr with - | DeclFun (idc, _, l, _) -> - let b = br.(j) in - let rec_vars, b = decompose_lam b in - let rec_vars, env = coq_rename_vars env rec_vars in - let coq_rec_vars = List.map mkVar rec_vars in - let b = substl coq_rec_vars b in - let rec_vars = List.rev rec_vars in - let coq_rec_term = applist (cj, List.rev coq_rec_vars) in - let b = replace_vars [x, coq_rec_term] b in - let bv = bv @ rec_vars in - let rec_vars = List.map string_of_id rec_vars in - let fol_var x = Fol.App (x, []) in - let fol_rec_vars = List.map fol_var rec_vars in - let fol_rec_term = App (idc, fol_rec_vars) in - let rec_vars = List.combine rec_vars l in - let fol_vars = List.map fst vars in - let fol_vars = List.map fol_var fol_vars in - let fol_vars = List.map (fun y -> match y with - | App (id, _) -> - if id = string_of_id x - then fol_rec_term - else y - | _ -> y) - fol_vars in - let vars = vars @ rec_vars in - let rec remove l e = match l with - | [] -> [] - | (y, t)::l' -> if y = string_of_id e then l' - else (y, t)::(remove l' e) in - let vars = remove vars x in - let p = - Fatom (Eq (App (id, fol_vars), - tr_term tv bv env b)) - in - eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs - | _ -> - assert false end - with NotFO -> - ()); - !eqs - | _ -> - raise NotFO - -(* assumption: t:T:Set *) -and tr_term tv bv env t = - try - tr_arith_constant t - with NotArithConstant -> - match kind_of_term t with - (* binary operations on integers *) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> - Plus (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> - Moins (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> - Mult (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> - Div (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp -> - Opp (tr_term tv bv env a) - (* binary operations on reals *) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> - Plus (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus -> - Moins (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> - Mult (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv -> - Div (tr_term tv bv env a, tr_term tv bv env b) - | Term.Var id when List.mem id bv -> - App (string_of_id id, []) - | _ -> - let f, cl = decompose_app t in - begin try - let r = global_of_constr f in - match tr_global env r with - | DeclFun (s, k, _, _) -> - let cl = skip_k_args k cl in - Fol.App (s, List.map (tr_term tv bv env) cl) - | _ -> - raise NotFO - with - | Not_found -> - raise NotFO - | NotFO -> (* we need to abstract some part of (f cl) *) - let rec abstract app = function - | [] -> - Fol.App (make_term_abstraction tv env app, []) - | x :: l as args -> - begin try - let s = make_term_abstraction tv env app in - Fol.App (s, List.map (tr_term tv bv env) args) - with NotFO -> - abstract (applist (app, [x])) l - end - in - let app,l = match cl with - | x :: l -> applist (f, [x]), l | [] -> raise NotFO - in - abstract app l - end - -and quantifiers n a b tv bv env = - let vars, env = coq_rename_vars env [n,a] in - let id = match vars with [x] -> x | _ -> assert false in - let b = subst1 (mkVar id) b in - let t = tr_type tv env a in - let bv = id :: bv in - id, t, bv, env, b - -(* assumption: f is of type Prop *) -and tr_formula tv bv env f = - let c, args = decompose_app f in - match kind_of_term c, args with - | Var id, [] -> - Fatom (Pred (rename_global (VarRef id), [])) - | _, [t;a;b] when c = build_coq_eq () -> - let ty = Typing.type_of env Evd.empty t in - if is_Set ty || is_Type ty then - let _ = tr_type tv env t in - Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b)) - else - raise NotFO - (* comparisons on integers *) - | _, [a;b] when c = Lazy.force coq_Zle -> - Fatom (Le (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Zlt -> - Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Zge -> - Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Zgt -> - Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b)) - (* comparisons on reals *) - | _, [a;b] when c = Lazy.force coq_Rle -> - Fatom (Le (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Rlt -> - Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Rge -> - Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b)) - | _, [a;b] when c = Lazy.force coq_Rgt -> - Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b)) - | _, [] when c = build_coq_False () -> - False - | _, [] when c = build_coq_True () -> - True - | _, [a] when c = build_coq_not () -> - Not (tr_formula tv bv env a) - | _, [a;b] when c = build_coq_and () -> - And (tr_formula tv bv env a, tr_formula tv bv env b) - | _, [a;b] when c = build_coq_or () -> - Or (tr_formula tv bv env a, tr_formula tv bv env b) - | _, [a;b] when c = Lazy.force coq_iff -> - Iff (tr_formula tv bv env a, tr_formula tv bv env b) - | Prod (n, a, b), _ -> - if is_Prop (Typing.type_of env Evd.empty a) then - Imp (tr_formula tv bv env a, tr_formula tv bv env b) - else - let id, t, bv, env, b = quantifiers n a b tv bv env in - Forall (string_of_id id, t, tr_formula tv bv env b) - | _, [_; a] when c = build_coq_ex () -> - begin match kind_of_term a with - | Lambda(n, a, b) -> - let id, t, bv, env, b = quantifiers n a b tv bv env in - Exists (string_of_id id, t, tr_formula tv bv env b) - | _ -> - (* unusual case of the shape (ex p) *) - raise NotFO (* TODO: we could eta-expanse *) - end - | _ -> - begin try - let r = global_of_constr c in - match tr_global env r with - | DeclPred (s, k, _) -> - let args = skip_k_args k args in - Fatom (Pred (s, List.map (tr_term tv bv env) args)) - | _ -> - raise NotFO - with Not_found -> - raise NotFO - end - - -let tr_goal gl = - Hashtbl.clear locals; - let tr_one_hyp (id, ty) = - try - let s = rename_global (VarRef id) in - let d = tr_decl (pf_env gl) s ty in - Hashtbl.add locals id (Gfo d); - d - with NotFO -> - Hashtbl.add locals id Gnot_fo; - raise NotFO - in - let hyps = - List.fold_right - (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc) - (pf_hyps_types gl) [] - in - let c = tr_formula [] [] (pf_env gl) (pf_concl gl) in - let hyps = List.rev_append !globals_stack (List.rev hyps) in - hyps, c - - -type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy | CVC3 | Z3 - -let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ()) - -let sprintf = Format.sprintf - -let file_contents f = - let buf = Buffer.create 1024 in - try - let c = open_in f in - begin try - while true do - let s = input_line c in Buffer.add_string buf s; - Buffer.add_char buf '\n' - done; - assert false - with End_of_file -> - close_in c; - Buffer.contents buf - end - with _ -> - sprintf "(cannot open %s)" f - -let timeout_sys_command cmd = - if !debug then Format.eprintf "command line: %s@." cmd; - let out = Filename.temp_file "out" "" in - let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in - let ret = Sys.command cmd in - if !debug then - Format.eprintf "Output file %s:@.%s@." out (file_contents out); - ret, out - -let timeout_or_failure c cmd out = - if c = 152 then - Timeout - else - Failure - (sprintf "command %s failed with output:\n%s " cmd (file_contents out)) - -let call_prover ?(opt="") file = - if !debug then Format.eprintf "calling prover on %s@." file; - let out = Filename.temp_file "out" "" in - let cmd = - sprintf "why-dp -timeout %d -batch %s > %s 2>&1" !timeout file out in - match Sys.command cmd with - 0 -> Valid None - | 1 -> Failure (sprintf "could not run why-dp\n%s" (file_contents out)) - | 2 -> Invalid - | 3 -> DontKnow - | 4 -> Timeout - | 5 -> Failure (sprintf "prover failed:\n%s" (file_contents out)) - | n -> Failure (sprintf "Unknown exit status of why-dp: %d" n) - -let prelude_files = ref ([] : string list) - -let set_prelude l = prelude_files := l - -let (dp_prelude_obj,_) = - declare_object - {(default_object "Dp_prelude") with - cache_function = (fun (_,x) -> set_prelude x); - load_function = (fun _ (_,x) -> set_prelude x)} - -let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x) - -let why_files f = String.concat " " (!prelude_files @ [f]) - -let call_simplify fwhy = - let cmd = - sprintf "why --simplify %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in -(* - let cmd = - sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out" - !timeout fsx - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in -*) - let r = call_prover fsx in - if not !debug then remove_files [fwhy; fsx]; - r - -let call_ergo fwhy = - let cmd = sprintf "why --alt-ergo %s" (why_files fwhy) in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in - (*let ftrace = Filename.temp_file "ergo_trace" "" in*) - (*NB: why-dp can't handle -cctrace - let cmd = - if !trace then - sprintf "alt-ergo -cctrace %s %s" ftrace fwhy - - else - sprintf "alt-ergo %s" fwhy - in*) - let r = call_prover fwhy in - if not !debug then remove_files [fwhy; (*out*)]; - r - - -let call_zenon fwhy = - let cmd = - sprintf "why --no-zenon-prelude --zenon %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in -(* why-dp won't let us having coqterm... - let out = Filename.temp_file "dp_out" "" in - let cmd = - sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out - in - let c = Sys.command cmd in - if not !debug then remove_files [fwhy; fznn]; - if c = 137 then - Timeout - else begin - if c <> 0 then anomaly ("command failed: " ^ cmd); - if Sys.command (sprintf "grep -q -w Error %s" out) = 0 then - error "Zenon failed"; - let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in - if c = 0 then Valid (Some out) else Invalid - end - *) - let r = call_prover fznn in - if not !debug then remove_files [fwhy; fznn]; - r - -let call_smt ~smt fwhy = - let cmd = - sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in - let opt = "-smt-solver " ^ smt in - let r = call_prover ~opt fsmt in - if not !debug then remove_files [fwhy; fsmt]; - r - -(* -let call_yices fwhy = - let cmd = - sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in - let cmd = - sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out" - !timeout fsmt - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in - if not !debug then remove_files [fwhy; fsmt]; - r - -let call_cvc3 fwhy = - let cmd = - sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in - let cmd = - sprintf "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out" - !timeout fsmt - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in - if not !debug then remove_files [fwhy; fsmt]; - r -*) - -let call_cvcl fwhy = - let cmd = - sprintf "why --cvcl --encoding sstrat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in -(* - let cmd = - sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out" - !timeout fcvc - in - let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout - in -*) - let r = call_prover fcvc in - if not !debug then remove_files [fwhy; fcvc]; - r - -let call_harvey fwhy = - let cmd = - sprintf "why --harvey --encoding strat %s" (why_files fwhy) - in - if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); - let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in -(* - let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in - if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed"); - let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in - let outf = Filename.temp_file "rv" ".out" in - let out = - Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" - !timeout f outf) - in - let r = - if out <> 0 then - Timeout - else - let cmd = - sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf - in - if Sys.command cmd = 0 then Valid None else Invalid - in - if not !debug then remove_files [fwhy; frv; outf]; -*) - let r = call_prover frv in - if not !debug then remove_files [fwhy; frv]; - r - -let call_gwhy fwhy = - let cmd = sprintf "gwhy %s" (why_files fwhy) in - if Sys.command cmd <> 0 then ignore (Sys.command (sprintf "emacs %s" fwhy)); - NoAnswer - -let ergo_proof_from_file f gl = - let s = - let buf = Buffer.create 1024 in - let c = open_in f in - try - while true do Buffer.add_string buf (input_line c) done; assert false - with End_of_file -> - close_in c; - Buffer.contents buf - in - let parsed_constr = Pcoq.parse_string Pcoq.Constr.constr s in - let t = Constrintern.interp_constr (project gl) (pf_env gl) parsed_constr in - exact_check t gl - -let call_prover prover q = - let fwhy = Filename.temp_file "coq_dp" ".why" in - Dp_why.output_file fwhy q; - match prover with - | Simplify -> call_simplify fwhy - | Ergo -> call_ergo fwhy - | CVC3 -> call_smt ~smt:"cvc3" fwhy - | Yices -> call_smt ~smt:"yices" fwhy - | Z3 -> call_smt ~smt:"z3" fwhy - | Zenon -> call_zenon fwhy - | CVCLite -> call_cvcl fwhy - | Harvey -> call_harvey fwhy - | Gwhy -> call_gwhy fwhy - -let dp prover gl = - Coqlib.check_required_library ["Coq";"ZArith";"ZArith"]; - let concl_type = pf_type_of gl (pf_concl gl) in - if not (is_Prop concl_type) then error "Conclusion is not a Prop"; - try - let q = tr_goal gl in - begin match call_prover prover q with - | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl - | Valid (Some f) when prover = Ergo -> ergo_proof_from_file f gl - | Valid _ -> Tactics.admit_as_an_axiom gl - | Invalid -> error "Invalid" - | DontKnow -> error "Don't know" - | Timeout -> error "Timeout" - | Failure s -> error s - | NoAnswer -> Tacticals.tclIDTAC gl - end - with NotFO -> - error "Not a first order goal" - - -let simplify = tclTHEN intros (dp Simplify) -let ergo = tclTHEN intros (dp Ergo) -let cvc3 = tclTHEN intros (dp CVC3) -let yices = tclTHEN intros (dp Yices) -let z3 = tclTHEN intros (dp Z3) -let cvc_lite = tclTHEN intros (dp CVCLite) -let harvey = dp Harvey -let zenon = tclTHEN intros (dp Zenon) -let gwhy = tclTHEN intros (dp Gwhy) - -let dp_hint l = - let env = Global.env () in - let one_hint (qid,r) = - if not (mem_global r) then begin - let ty = Global.type_of_global r in - let s = Typing.type_of env Evd.empty ty in - if is_Prop s then - try - let id = rename_global r in - let tv, env, ty = decomp_type_quantifiers env ty in - let d = Axiom (id, tr_formula tv [] env ty) in - add_global r (Gfo d); - globals_stack := d :: !globals_stack - with NotFO -> - add_global r Gnot_fo; - msg_warning - (pr_reference qid ++ - str " ignored (not a first order proposition)") - else begin - add_global r Gnot_fo; - msg_warning - (pr_reference qid ++ str " ignored (not a proposition)") - end - end - in - List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l) - -let (dp_hint_obj,_) = - declare_object - {(default_object "Dp_hint") with - cache_function = (fun (_,l) -> dp_hint l); - load_function = (fun _ (_,l) -> dp_hint l)} - -let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l) - -let dp_predefined qid s = - let r = Nametab.global qid in - let ty = Global.type_of_global r in - let env = Global.env () in - let id = rename_global r in - try - let d = match tr_decl env id ty with - | DeclType (_, n) -> DeclType (s, n) - | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty) - | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) - | Axiom _ as d -> d - in - match d with - | Axiom _ -> msg_warning (str " ignored (axiom)") - | d -> add_global r (Gfo d) - with NotFO -> - msg_warning (str " ignored (not a first order declaration)") - -let (dp_predefined_obj,_) = - declare_object - {(default_object "Dp_predefined") with - cache_function = (fun (_,(id,s)) -> dp_predefined id s); - load_function = (fun _ (_,(id,s)) -> dp_predefined id s)} - -let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s)) - -let _ = declare_summary "Dp options" - { freeze_function = - (fun () -> !debug, !trace, !timeout, !prelude_files); - unfreeze_function = - (fun (d,tr,tm,pr) -> - debug := d; trace := tr; timeout := tm; prelude_files := pr); - init_function = - (fun () -> - debug := false; trace := false; timeout := 10; - prelude_files := []) } diff --git a/plugins/dp/dp.mli b/plugins/dp/dp.mli deleted file mode 100644 index f40f8688..00000000 --- a/plugins/dp/dp.mli +++ /dev/null @@ -1,20 +0,0 @@ - -open Libnames -open Proof_type - -val simplify : tactic -val ergo : tactic -val cvc3 : tactic -val yices : tactic -val cvc_lite : tactic -val harvey : tactic -val zenon : tactic -val gwhy : tactic -val z3: tactic - -val dp_hint : reference list -> unit -val dp_timeout : int -> unit -val dp_debug : bool -> unit -val dp_trace : bool -> unit -val dp_prelude : string list -> unit -val dp_predefined : reference -> string -> unit diff --git a/plugins/dp/dp_plugin.mllib b/plugins/dp/dp_plugin.mllib deleted file mode 100644 index 63252d6a..00000000 --- a/plugins/dp/dp_plugin.mllib +++ /dev/null @@ -1,5 +0,0 @@ -Dp_why -Dp_zenon -Dp -G_dp -Dp_plugin_mod diff --git a/plugins/dp/dp_why.ml b/plugins/dp/dp_why.ml deleted file mode 100644 index 199c3087..00000000 --- a/plugins/dp/dp_why.ml +++ /dev/null @@ -1,185 +0,0 @@ - -(* Pretty-print PFOL (see fol.mli) in Why syntax *) - -open Format -open Fol - -type proof = - | Immediate of Term.constr - | Fun_def of string * (string * typ) list * typ * term - -let proofs = Hashtbl.create 97 -let proof_name = - let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r - -let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n - -let find_proof = Hashtbl.find proofs - -let rec print_list sep print fmt = function - | [] -> () - | [x] -> print fmt x - | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - -let space fmt () = fprintf fmt "@ " -let comma fmt () = fprintf fmt ",@ " - -let is_why_keyword = - let h = Hashtbl.create 17 in - List.iter - (fun s -> Hashtbl.add h s ()) - ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin"; - "bool"; "do"; "done"; "else"; "end"; "exception"; "exists"; - "external"; "false"; "for"; "forall"; "fun"; "function"; "goal"; - "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not"; - "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises"; - "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try"; - "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; - Hashtbl.mem h - -let ident fmt s = - if is_why_keyword s then fprintf fmt "coq__%s" s else fprintf fmt "%s" s - -let rec print_typ fmt = function - | Tvar x -> fprintf fmt "'%a" ident x - | Tid ("int", []) -> fprintf fmt "int" - | Tid ("real", []) -> fprintf fmt "real" - | Tid (x, []) -> fprintf fmt "%a" ident x - | Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x - | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x - -let print_arg fmt (id,typ) = fprintf fmt "%a: %a" ident id print_typ typ - -let rec print_term fmt = function - | Cst n -> - fprintf fmt "%s" (Big_int.string_of_big_int n) - | RCst s -> - fprintf fmt "%s.0" (Big_int.string_of_big_int s) - | Power2 n -> - fprintf fmt "0x1p%s" (Big_int.string_of_big_int n) - | Plus (a, b) -> - fprintf fmt "@[(%a +@ %a)@]" print_term a print_term b - | Moins (a, b) -> - fprintf fmt "@[(%a -@ %a)@]" print_term a print_term b - | Mult (a, b) -> - fprintf fmt "@[(%a *@ %a)@]" print_term a print_term b - | Div (a, b) -> - fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b - | Opp (a) -> - fprintf fmt "@[(-@ %a)@]" print_term a - | App (id, []) -> - fprintf fmt "%a" ident id - | App (id, tl) -> - fprintf fmt "@[%a(%a)@]" ident id print_terms tl - -and print_terms fmt tl = - print_list comma print_term fmt tl - -let rec print_predicate fmt p = - let pp = print_predicate in - match p with - | True -> - fprintf fmt "true" - | False -> - fprintf fmt "false" - | Fatom (Eq (a, b)) -> - fprintf fmt "@[(%a =@ %a)@]" print_term a print_term b - | Fatom (Le (a, b)) -> - fprintf fmt "@[(%a <=@ %a)@]" print_term a print_term b - | Fatom (Lt (a, b))-> - fprintf fmt "@[(%a <@ %a)@]" print_term a print_term b - | Fatom (Ge (a, b)) -> - fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b - | Fatom (Gt (a, b)) -> - fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b - | Fatom (Pred (id, [])) -> - fprintf fmt "%a" ident id - | Fatom (Pred (id, tl)) -> - fprintf fmt "@[%a(%a)@]" ident id print_terms tl - | Imp (a, b) -> - fprintf fmt "@[(%a ->@ %a)@]" pp a pp b - | Iff (a, b) -> - fprintf fmt "@[(%a <->@ %a)@]" pp a pp b - | And (a, b) -> - fprintf fmt "@[(%a and@ %a)@]" pp a pp b - | Or (a, b) -> - fprintf fmt "@[(%a or@ %a)@]" pp a pp b - | Not a -> - fprintf fmt "@[(not@ %a)@]" pp a - | Forall (id, t, p) -> - fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p - | Exists (id, t, p) -> - fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p - -let rec remove_iff args = function - Forall (id,t,p) -> remove_iff ((id,t)::args) p - | Iff(_,b) -> List.rev args, b - | _ -> raise Not_found - -let print_query fmt (decls,concl) = - let find_declared_preds l = - function - DeclPred (id,_,args) -> (id,args) :: l - | _ -> l - in - let find_defined_preds declared l = function - Axiom(id,f) -> - (try - let _decl = List.assoc id declared in - (id,remove_iff [] f)::l - with Not_found -> l) - | _ -> l - in - let declared_preds = - List.fold_left find_declared_preds [] decls in - let defined_preds = - List.fold_left (find_defined_preds declared_preds) [] decls - in - let print_dtype = function - | DeclType (id, 0) -> - fprintf fmt "@[type %a@]@\n@\n" ident id - | DeclType (id, 1) -> - fprintf fmt "@[type 'a %a@]@\n@\n" ident id - | DeclType (id, n) -> - fprintf fmt "@[type ("; - for i = 1 to n do - fprintf fmt "'a%d" i; if i < n then fprintf fmt ", " - done; - fprintf fmt ") %a@]@\n@\n" ident id - | DeclFun _ | DeclPred _ | Axiom _ -> - () - in - let print_dvar_dpred = function - | DeclFun (id, _, [], t) -> - fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t - | DeclFun (id, _, l, t) -> - fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" - ident id (print_list comma print_typ) l print_typ t - | DeclPred (id, _, []) when not (List.mem_assoc id defined_preds) -> - fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id - | DeclPred (id, _, l) when not (List.mem_assoc id defined_preds) -> - fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" - ident id (print_list comma print_typ) l - | DeclType _ | Axiom _ | DeclPred _ -> - () - in - let print_assert = function - | Axiom(id,_) when List.mem_assoc id defined_preds -> - let args, def = List.assoc id defined_preds in - fprintf fmt "@[predicate %a(%a) =@\n%a@]@\n" ident id - (print_list comma print_arg) args print_predicate def - | Axiom (id, f) -> - fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f - | DeclType _ | DeclFun _ | DeclPred _ -> - () - in - List.iter print_dtype decls; - List.iter print_dvar_dpred decls; - List.iter print_assert decls; - fprintf fmt "@[<hov 2>goal coq___goal: %a@]" print_predicate concl - -let output_file f q = - let c = open_out f in - let fmt = formatter_of_out_channel c in - fprintf fmt "@[%a@]@." print_query q; - close_out c diff --git a/plugins/dp/dp_why.mli b/plugins/dp/dp_why.mli deleted file mode 100644 index 0efa24a2..00000000 --- a/plugins/dp/dp_why.mli +++ /dev/null @@ -1,17 +0,0 @@ - -open Fol - -(* generation of the Why file *) - -val output_file : string -> query -> unit - -(* table to translate the proofs back to Coq (used in dp_zenon) *) - -type proof = - | Immediate of Term.constr - | Fun_def of string * (string * typ) list * typ * term - -val add_proof : proof -> string -val find_proof : string -> proof - - diff --git a/plugins/dp/dp_zenon.mli b/plugins/dp/dp_zenon.mli deleted file mode 100644 index 0a727d1f..00000000 --- a/plugins/dp/dp_zenon.mli +++ /dev/null @@ -1,7 +0,0 @@ - -open Fol - -val set_debug : bool -> unit - -val proof_from_file : string -> Proof_type.tactic - diff --git a/plugins/dp/dp_zenon.mll b/plugins/dp/dp_zenon.mll deleted file mode 100644 index 949e91e3..00000000 --- a/plugins/dp/dp_zenon.mll +++ /dev/null @@ -1,189 +0,0 @@ - -{ - - open Lexing - open Pp - open Util - open Names - open Tacmach - open Dp_why - open Tactics - open Tacticals - - let debug = ref false - let set_debug b = debug := b - - let buf = Buffer.create 1024 - - let string_of_global env ref = - Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref) - - let axioms = ref [] - - (* we cannot interpret the terms as we read them (since some lemmas - may need other lemmas to be already interpreted) *) - type lemma = { l_id : string; l_type : string; l_proof : string } - type zenon_proof = lemma list * string - -} - -let ident = ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']+ -let space = [' ' '\t' '\r'] - -rule start = parse -| "(* BEGIN-PROOF *)" "\n" { scan lexbuf } -| _ { start lexbuf } -| eof { anomaly "malformed Zenon proof term" } - -(* here we read the lemmas and the main proof term; - meanwhile we maintain the set of axioms that were used *) - -and scan = parse -| "Let" space (ident as id) space* ":" - { let t = read_coq_term lexbuf in - let p = read_lemma_proof lexbuf in - let l,pr = scan lexbuf in - { l_id = id; l_type = t; l_proof = p } :: l, pr } -| "Definition theorem:" - { let t = read_main_proof lexbuf in [], t } -| _ | eof - { anomaly "malformed Zenon proof term" } - -and read_coq_term = parse -| "." "\n" - { let s = Buffer.contents buf in Buffer.clear buf; s } -| "coq__" (ident as id) (* a Why keyword renamed *) - { Buffer.add_string buf id; read_coq_term lexbuf } -| ("dp_axiom__" ['0'-'9']+) as id - { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf } -| _ as c - { Buffer.add_char buf c; read_coq_term lexbuf } -| eof - { anomaly "malformed Zenon proof term" } - -and read_lemma_proof = parse -| "Proof" space - { read_coq_term lexbuf } -| _ | eof - { anomaly "malformed Zenon proof term" } - -(* skip the main proof statement and then read its term *) -and read_main_proof = parse -| ":=" "\n" - { read_coq_term lexbuf } -| _ - { read_main_proof lexbuf } -| eof - { anomaly "malformed Zenon proof term" } - - -{ - - let read_zenon_proof f = - Buffer.clear buf; - let c = open_in f in - let lb = from_channel c in - let p = start lb in - close_in c; - if not !debug then begin try Sys.remove f with _ -> () end; - p - - let constr_of_string gl s = - let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in - Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s) - - (* we are lazy here: we build strings containing Coq terms using a *) - (* pretty-printer Fol -> Coq *) - module Coq = struct - open Format - open Fol - - let rec print_list sep print fmt = function - | [] -> () - | [x] -> print fmt x - | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - - let space fmt () = fprintf fmt "@ " - let comma fmt () = fprintf fmt ",@ " - - let rec print_typ fmt = function - | Tvar x -> fprintf fmt "%s" x - | Tid ("int", []) -> fprintf fmt "Z" - | Tid (x, []) -> fprintf fmt "%s" x - | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t - | Tid (x,tl) -> - fprintf fmt "(%s %a)" x (print_list comma print_typ) tl - - let rec print_term fmt = function - | Cst n -> - fprintf fmt "%s" (Big_int.string_of_big_int n) - | RCst s -> - fprintf fmt "%s" (Big_int.string_of_big_int s) - | Power2 n -> - fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n) - - (* TODO: bug, it might be operations on reals *) - | Plus (a, b) -> - fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b - | Moins (a, b) -> - fprintf fmt "@[(Zminus %a %a)@]" print_term a print_term b - | Mult (a, b) -> - fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b - | Div (a, b) -> - fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b - | Opp (a) -> - fprintf fmt "@[(Zopp %a)@]" print_term a - | App (id, []) -> - fprintf fmt "%s" id - | App (id, tl) -> - fprintf fmt "@[(%s %a)@]" id print_terms tl - - and print_terms fmt tl = - print_list space print_term fmt tl - - (* builds the text for "forall vars, f vars = t" *) - let fun_def_axiom f vars t = - let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in - fprintf str_formatter - "@[(forall %a, %s %a = %a)@]@." - (print_list space binder) vars f - (print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars - print_term t; - flush_str_formatter () - - end - - let prove_axiom id = match Dp_why.find_proof id with - | Immediate t -> - exact_check t - | Fun_def (f, vars, ty, t) -> - tclTHENS - (fun gl -> - let s = Coq.fun_def_axiom f vars t in - if !debug then Format.eprintf "axiom fun def = %s@." s; - let c = constr_of_string gl s in - assert_tac (Name (id_of_string id)) c gl) - [tclTHEN intros reflexivity; tclIDTAC] - - let exact_string s gl = - let c = constr_of_string gl s in - exact_check c gl - - let interp_zenon_proof (ll,p) = - let interp_lemma l gl = - let ty = constr_of_string gl l.l_type in - tclTHENS - (assert_tac (Name (id_of_string l.l_id)) ty) - [exact_string l.l_proof; tclIDTAC] - gl - in - tclTHEN (tclMAP interp_lemma ll) (exact_string p) - - let proof_from_file f = - axioms := []; - msgnl (str "proof_from_file " ++ str f); - let zp = read_zenon_proof f in - msgnl (str "proof term is " ++ str (snd zp)); - tclTHEN (tclMAP prove_axiom !axioms) (interp_zenon_proof zp) - -} diff --git a/plugins/dp/fol.mli b/plugins/dp/fol.mli deleted file mode 100644 index 4fb763a6..00000000 --- a/plugins/dp/fol.mli +++ /dev/null @@ -1,58 +0,0 @@ - -(* Polymorphic First-Order Logic (that is Why's input logic) *) - -type typ = - | Tvar of string - | Tid of string * typ list - -type term = - | Cst of Big_int.big_int - | RCst of Big_int.big_int - | Power2 of Big_int.big_int - | Plus of term * term - | Moins of term * term - | Mult of term * term - | Div of term * term - | Opp of term - | App of string * term list - -and atom = - | Eq of term * term - | Le of term * term - | Lt of term * term - | Ge of term * term - | Gt of term * term - | Pred of string * term list - -and form = - | Fatom of atom - | Imp of form * form - | Iff of form * form - | And of form * form - | Or of form * form - | Not of form - | Forall of string * typ * form - | Exists of string * typ * form - | True - | False - -(* the integer indicates the number of type variables *) -type decl = - | DeclType of string * int - | DeclFun of string * int * typ list * typ - | DeclPred of string * int * typ list - | Axiom of string * form - -type query = decl list * form - - -(* prover result *) - -type prover_answer = - | Valid of string option - | Invalid - | DontKnow - | Timeout - | NoAnswer - | Failure of string - diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4 deleted file mode 100644 index fc957ea6..00000000 --- a/plugins/dp/g_dp.ml4 +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "parsing/grammar.cma" i*) - -(* $Id: g_dp.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - -open Dp - -TACTIC EXTEND Simplify - [ "simplify" ] -> [ simplify ] -END - -TACTIC EXTEND Ergo - [ "ergo" ] -> [ ergo ] -END - -TACTIC EXTEND Yices - [ "yices" ] -> [ yices ] -END - -TACTIC EXTEND CVC3 - [ "cvc3" ] -> [ cvc3 ] -END - -TACTIC EXTEND Z3 - [ "z3" ] -> [ z3 ] -END - -TACTIC EXTEND CVCLite - [ "cvcl" ] -> [ cvc_lite ] -END - -TACTIC EXTEND Harvey - [ "harvey" ] -> [ harvey ] -END - -TACTIC EXTEND Zenon - [ "zenon" ] -> [ zenon ] -END - -TACTIC EXTEND Gwhy - [ "gwhy" ] -> [ gwhy ] -END - -(* should be part of basic tactics syntax *) -TACTIC EXTEND admit - [ "admit" ] -> [ Tactics.admit_as_an_axiom ] -END - -VERNAC COMMAND EXTEND Dp_hint - [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ] -END - -VERNAC COMMAND EXTEND Dp_timeout -| [ "Dp_timeout" natural(n) ] -> [ dp_timeout n ] -END - -VERNAC COMMAND EXTEND Dp_prelude -| [ "Dp_prelude" string_list(l) ] -> [ dp_prelude l ] -END - -VERNAC COMMAND EXTEND Dp_predefined -| [ "Dp_predefined" global(g) "=>" string(s) ] -> [ dp_predefined g s ] -END - -VERNAC COMMAND EXTEND Dp_debug -| [ "Dp_debug" ] -> [ dp_debug true; Dp_zenon.set_debug true ] -END - -VERNAC COMMAND EXTEND Dp_trace -| [ "Dp_trace" ] -> [ dp_trace true ] -END - diff --git a/plugins/dp/test2.v b/plugins/dp/test2.v deleted file mode 100644 index 0940b135..00000000 --- a/plugins/dp/test2.v +++ /dev/null @@ -1,80 +0,0 @@ -Require Import ZArith. -Require Import Classical. -Require Import List. - -Open Scope list_scope. -Open Scope Z_scope. - -Dp_debug. -Dp_timeout 3. -Require Export zenon. - -Definition neg (z:Z) : Z := match z with - | Z0 => Z0 - | Zpos p => Zneg p - | Zneg p => Zpos p - end. - -Goal forall z, neg (neg z) = z. - Admitted. - -Open Scope nat_scope. -Print plus. - -Goal forall x, x+0=x. - induction x; ergo. - (* simplify resoud le premier, pas le second *) - Admitted. - -Goal 1::2::3::nil = 1::2::(1+2)::nil. - zenon. - Admitted. - -Definition T := nat. -Parameter fct : T -> nat. -Goal fct O = O. - Admitted. - -Fixpoint even (n:nat) : Prop := - match n with - O => True - | S O => False - | S (S p) => even p - end. - -Goal even 4%nat. - try zenon. - Admitted. - -Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil. - -Definition head := -fun (A : Set) (l : list A) => -match l with -| nil => None (A:=A) -| x :: _ => Some x -end. - -Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. - -Admitted. - -(* -BUG avec head prédéfini : manque eta-expansion sur A:Set - -Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. - -Print value. -Print Some. - -zenon. -*) - -Inductive IN (A:Set) : A -> list A -> Prop := - | IN1 : forall x l, IN A x (x::l) - | IN2: forall x l, IN A x l -> forall y, IN A x (y::l). -Implicit Arguments IN [A]. - -Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l). - zenon. -Print In. diff --git a/plugins/dp/tests.v b/plugins/dp/tests.v deleted file mode 100644 index dc85d2ee..00000000 --- a/plugins/dp/tests.v +++ /dev/null @@ -1,300 +0,0 @@ - -Require Import ZArith. -Require Import Classical. -Require Export Reals. - - -(* real numbers *) - -Lemma real_expr: (0 <= 9 * 4)%R. -ergo. -Qed. - -Lemma powerRZ_translation: (powerRZ 2 15 < powerRZ 2 17)%R. -ergo. -Qed. - -Dp_debug. -Dp_timeout 3. - -(* module renamings *) - -Module M. - Parameter t : Set. -End M. - -Lemma test_module_0 : forall x:M.t, x=x. -ergo. -Qed. - -Module N := M. - -Lemma test_module_renaming_0 : forall x:N.t, x=x. -ergo. -Qed. - -Dp_predefined M.t => "int". - -Lemma test_module_renaming_1 : forall x:N.t, x=x. -ergo. -Qed. - -(* Coq lists *) - -Require Export List. - -Lemma test_pol_0 : forall l:list nat, l=l. -ergo. -Qed. - -Parameter nlist: list nat -> Prop. - -Lemma poly_1 : forall l, nlist l -> True. -intros. -simplify. -Qed. - -(* user lists *) - -Inductive list (A:Set) : Set := -| nil : list A -| cons: forall a:A, list A -> list A. - -Fixpoint app (A:Set) (l m:list A) {struct l} : list A := -match l with -| nil => m -| cons a l1 => cons A a (app A l1 m) -end. - -Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. -intros; ergo. -Qed. - -(* polymorphism *) -Require Import List. - -Inductive mylist (A:Set) : Set := - mynil : mylist A -| mycons : forall a:A, mylist A -> mylist A. - -Parameter my_nlist: mylist nat -> Prop. - - Goal forall l, my_nlist l -> True. - intros. - simplify. -Qed. - -(* First example with the 0 and the equality translated *) - -Goal 0 = 0. -simplify. -Qed. - -(* Examples in the Propositional Calculus - and theory of equality *) - -Parameter A C : Prop. - -Goal A -> A. -simplify. -Qed. - - -Goal A -> (A \/ C). - -simplify. -Qed. - - -Parameter x y z : Z. - -Goal x = y -> y = z -> x = z. -ergo. -Qed. - - -Goal ((((A -> C) -> A) -> A) -> C) -> C. - -ergo. -Qed. - -(* Arithmetic *) -Open Scope Z_scope. - -Goal 1 + 1 = 2. -yices. -Qed. - - -Goal 2*x + 10 = 18 -> x = 4. - -simplify. -Qed. - - -(* Universal quantifier *) - -Goal (forall (x y : Z), x = y) -> 0=1. -try zenon. -ergo. -Qed. - -Goal forall (x: nat), (x + 0 = x)%nat. - -induction x0; ergo. -Qed. - - -(* No decision procedure can solve this problem - Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a. -*) - - -(* Functions definitions *) - -Definition fst (x y : Z) : Z := x. - -Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x. - -simplify. -Qed. - - -(* Eta-expansion example *) - -Definition snd_of_3 (x y z : Z) : Z := y. - -Definition f : Z -> Z -> Z := snd_of_3 0. - -Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1. - -simplify. -Qed. - - -(* Inductive types definitions - call to dp/injection function *) - -Inductive even : Z -> Prop := -| even_0 : even 0 -| even_plus2 : forall z : Z, even z -> even (z + 2). - - -(* Simplify and Zenon can't prove this goal before the timeout - unlike CVC Lite *) - -Goal even 4. -ergo. -Qed. - - -Definition skip_z (z : Z) (n : nat) := n. - -Definition skip_z1 := skip_z. - -Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n. -yices. -Qed. - - -(* Axioms definitions and dp_hint *) - -Parameter add : nat -> nat -> nat. -Axiom add_0 : forall (n : nat), add 0%nat n = n. -Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2). - -Dp_hint add_0. -Dp_hint add_S. - -(* Simplify can't prove this goal before the timeout - unlike zenon *) - -Goal forall n : nat, add n 0 = n. -induction n ; yices. -Qed. - - -Definition pred (n : nat) : nat := match n with - | 0%nat => 0%nat - | S n' => n' -end. - -Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat. -yices. -(*zenon.*) -Qed. - - -Fixpoint plus (n m : nat) {struct n} : nat := - match n with - | 0%nat => m - | S n' => S (plus n' m) -end. - -Goal forall n : nat, plus n 0%nat = n. - -induction n; ergo. -Qed. - - -(* Mutually recursive functions *) - -Fixpoint even_b (n : nat) : bool := match n with - | O => true - | S m => odd_b m -end -with odd_b (n : nat) : bool := match n with - | O => false - | S m => even_b m -end. - -Goal even_b (S (S O)) = true. -ergo. -(* -simplify. -zenon. -*) -Qed. - - -(* sorts issues *) - -Parameter foo : Set. -Parameter ff : nat -> foo -> foo -> nat. -Parameter g : foo -> foo. -Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O. -yices. -(*zenon.*) -Qed. - - - -(* abstractions *) - -Parameter poly_f : forall A:Set, A->A. - -Goal forall x:nat, poly_f nat x = poly_f nat x. -ergo. -(*zenon.*) -Qed. - - - -(* Anonymous mutually recursive functions : no equations are produced - -Definition mrf := - fix even2 (n : nat) : bool := match n with - | O => true - | S m => odd2 m - end - with odd2 (n : nat) : bool := match n with - | O => false - | S m => even2 m - end for even. - - Thus this goal is unsolvable - -Goal mrf (S (S O)) = true. - -zenon. - -*) diff --git a/plugins/dp/vo.itarget b/plugins/dp/vo.itarget deleted file mode 100644 index 4d282709..00000000 --- a/plugins/dp/vo.itarget +++ /dev/null @@ -1 +0,0 @@ -Dp.vo diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v deleted file mode 100644 index f2400a7f..00000000 --- a/plugins/dp/zenon.v +++ /dev/null @@ -1,94 +0,0 @@ -(* Copyright 2004 INRIA *) -(* $Id: zenon.v 11996 2009-03-20 01:22:58Z letouzey $ *) - -Require Export Classical. - -Lemma zenon_nottrue : - (~True -> False). -Proof. tauto. Qed. - -Lemma zenon_noteq : forall (T : Type) (t : T), - ((t <> t) -> False). -Proof. tauto. Qed. - -Lemma zenon_and : forall P Q : Prop, - (P -> Q -> False) -> (P /\ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_or : forall P Q : Prop, - (P -> False) -> (Q -> False) -> (P \/ Q -> False). -Proof. tauto. Qed. - -Lemma zenon_imply : forall P Q : Prop, - (~P -> False) -> (Q -> False) -> ((P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_equiv : forall P Q : Prop, - (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notand : forall P Q : Prop, - (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notor : forall P Q : Prop, - (~P -> ~Q -> False) -> (~(P \/ Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notimply : forall P Q : Prop, - (P -> ~Q -> False) -> (~(P -> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_notequiv : forall P Q : Prop, - (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False). -Proof. tauto. Qed. - -Lemma zenon_ex : forall (T : Type) (P : T -> Prop), - (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T), - ((P t) -> False) -> ((forall x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T), - (~(P t) -> False) -> (~(exists x : T, (P x)) -> False). -Proof. firstorder. Qed. - -Lemma zenon_notall : forall (T : Type) (P : T -> Prop), - (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False). -Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed. - -Lemma zenon_equal_base : forall (T : Type) (f : T), f = f. -Proof. auto. Qed. - -Lemma zenon_equal_step : - forall (S T : Type) (fa fb : S -> T) (a b : S), - (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)). -Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed. - -Lemma zenon_pnotp : forall P Q : Prop, - (P = Q) -> (P -> ~Q -> False). -Proof. intros P Q Ha. rewrite Ha. auto. Qed. - -Lemma zenon_notequal : forall (T : Type) (a b : T), - (a = b) -> (a <> b -> False). -Proof. auto. Qed. - -Ltac zenon_intro id := - intro id || let nid := fresh in (intro nid; clear nid) -. - -Definition zenon_and_s := fun P Q a b => zenon_and P Q b a. -Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a. -Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a. -Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a. -Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a. -Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a. -Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a. -Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a. -Definition zenon_ex_s := fun T P a b => zenon_ex T P b a. -Definition zenon_notall_s := fun T P a b => zenon_notall T P b a. - -Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b. -Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v index eab2f67c..3a54b252 100644 --- a/plugins/extraction/ExtrOcamlBasic.v +++ b/plugins/extraction/ExtrOcamlBasic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (** Extraction to Ocaml : use of basic Ocaml types *) -Scheme Equality for nat. - Extract Inductive bool => bool [ true false ]. Extract Inductive option => option [ Some None ]. Extract Inductive unit => unit [ "()" ]. diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v index e38d41e3..265fbc52 100644 --- a/plugins/extraction/ExtrOcamlBigIntConv.v +++ b/plugins/extraction/ExtrOcamlBigIntConv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v index b059b2a0..cb866dc8 100644 --- a/plugins/extraction/ExtrOcamlIntConv.v +++ b/plugins/extraction/ExtrOcamlIntConv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v index 1fb83c5b..fb45a8be 100644 --- a/plugins/extraction/ExtrOcamlNatBigInt.v +++ b/plugins/extraction/ExtrOcamlNatBigInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,7 @@ (** Extraction of [nat] into Ocaml's [big_int] *) -Require Import Arith Even Div2 EqNat MinMax Euclid. +Require Import Arith Even Div2 EqNat Euclid. Require Import ExtrOcamlBasic. (** NB: The extracted code should be linked with [nums.cm(x)a] @@ -36,7 +36,7 @@ Extract Constant pred => "fun n -> Big.max Big.zero (Big.pred n)". Extract Constant minus => "fun n m -> Big.max Big.zero (Big.sub n m)". Extract Constant max => "Big.max". Extract Constant min => "Big.min". -Extract Constant nat_beq => "Big.eq". +(*Extract Constant nat_beq => "Big.eq".*) Extract Constant EqNat.beq_nat => "Big.eq". Extract Constant EqNat.eq_nat_decide => "Big.eq". diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v index e577ebe1..956ece79 100644 --- a/plugins/extraction/ExtrOcamlNatInt.v +++ b/plugins/extraction/ExtrOcamlNatInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,12 +8,16 @@ (** Extraction of [nat] into Ocaml's [int] *) -Require Import Arith Even Div2 EqNat MinMax Euclid. +Require Import Arith Even Div2 EqNat Euclid. Require Import ExtrOcamlBasic. (** Disclaimer: trying to obtain efficient certified programs by extracting [nat] into [int] is definitively *not* a good idea: + - This is just a syntactic adaptation, many things can go wrong, + such as name captures (e.g. if you have a constant named "int" + in your development, or a module named "Pervasives"). See bug #2878. + - Since [int] is bounded while [nat] is (theoretically) infinite, you have to make sure by yourself that your program will not manipulate numbers greater than [max_int]. Otherwise you should @@ -34,18 +38,18 @@ Require Import ExtrOcamlBasic. (** Mapping of [nat] into [int]. The last string corresponds to a [nat_case], see documentation of [Extract Inductive]. *) -Extract Inductive nat => int [ "0" "succ" ] +Extract Inductive nat => int [ "0" "Pervasives.succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))". (** Efficient (but uncertified) versions for usual [nat] functions *) Extract Constant plus => "(+)". -Extract Constant pred => "fun n -> max 0 (n-1)". -Extract Constant minus => "fun n m -> max 0 (n-m)". +Extract Constant pred => "fun n -> Pervasives.max 0 (n-1)". +Extract Constant minus => "fun n m -> Pervasives.max 0 (n-m)". Extract Constant mult => "( * )". -Extract Inlined Constant max => max. -Extract Inlined Constant min => min. -Extract Inlined Constant nat_beq => "(=)". +Extract Inlined Constant max => "Pervasives.max". +Extract Inlined Constant min => "Pervasives.min". +(*Extract Inlined Constant nat_beq => "(=)".*) Extract Inlined Constant EqNat.beq_nat => "(=)". Extract Inlined Constant EqNat.eq_nat_decide => "(=)". @@ -72,4 +76,4 @@ Definition test n m (H:m>0) := nat_compare n (q*m+r). Recursive Extraction test fact. -*)
\ No newline at end of file +*) diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index 48260e3d..3d86d712 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v index 5ca6bd7b..a6ba9aa2 100644 --- a/plugins/extraction/ExtrOcamlZBigInt.v +++ b/plugins/extraction/ExtrOcamlZBigInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,7 @@ (** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *) -Require Import ZArith NArith ZOdiv_def. +Require Import ZArith NArith. Require Import ExtrOcamlBasic. (** NB: The extracted code should be linked with [nums.cm(x)a] @@ -36,50 +36,52 @@ Extract Inductive N => "Big.big_int" (** Efficient (but uncertified) versions for usual functions *) -Extract Constant Pplus => "Big.add". -Extract Constant Psucc => "Big.succ". -Extract Constant Ppred => "fun n -> Big.max Big.one (Big.pred n)". -Extract Constant Pminus => "fun n m -> Big.max Big.one (Big.sub n m)". -Extract Constant Pmult => "Big.mult". -Extract Constant Pmin => "Big.min". -Extract Constant Pmax => "Big.max". -Extract Constant Pcompare => +Extract Constant Pos.add => "Big.add". +Extract Constant Pos.succ => "Big.succ". +Extract Constant Pos.pred => "fun n -> Big.max Big.one (Big.pred n)". +Extract Constant Pos.sub => "fun n m -> Big.max Big.one (Big.sub n m)". +Extract Constant Pos.mul => "Big.mult". +Extract Constant Pos.min => "Big.min". +Extract Constant Pos.max => "Big.max". +Extract Constant Pos.compare => + "fun x y -> Big.compare_case Eq Lt Gt x y". +Extract Constant Pos.compare_cont => "fun x y c -> Big.compare_case c Lt Gt x y". -Extract Constant Nplus => "Big.add". -Extract Constant Nsucc => "Big.succ". -Extract Constant Npred => "fun n -> Big.max Big.zero (Big.pred n)". -Extract Constant Nminus => "fun n m -> Big.max Big.zero (Big.sub n m)". -Extract Constant Nmult => "Big.mult". -Extract Constant Nmin => "Big.min". -Extract Constant Nmax => "Big.max". -Extract Constant Ndiv => +Extract Constant N.add => "Big.add". +Extract Constant N.succ => "Big.succ". +Extract Constant N.pred => "fun n -> Big.max Big.zero (Big.pred n)". +Extract Constant N.sub => "fun n m -> Big.max Big.zero (Big.sub n m)". +Extract Constant N.mul => "Big.mult". +Extract Constant N.min => "Big.min". +Extract Constant N.max => "Big.max". +Extract Constant N.div => "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b". -Extract Constant Nmod => +Extract Constant N.modulo => "fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b". -Extract Constant Ncompare => "Big.compare_case Eq Lt Gt". - -Extract Constant Zplus => "Big.add". -Extract Constant Zsucc => "Big.succ". -Extract Constant Zpred => "Big.pred". -Extract Constant Zminus => "Big.sub". -Extract Constant Zmult => "Big.mult". -Extract Constant Zopp => "Big.opp". -Extract Constant Zabs => "Big.abs". -Extract Constant Zmin => "Big.min". -Extract Constant Zmax => "Big.max". -Extract Constant Zcompare => "Big.compare_case Eq Lt Gt". - -Extract Constant Z_of_N => "fun p -> p". -Extract Constant Zabs_N => "Big.abs". - -(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod). +Extract Constant N.compare => "Big.compare_case Eq Lt Gt". + +Extract Constant Z.add => "Big.add". +Extract Constant Z.succ => "Big.succ". +Extract Constant Z.pred => "Big.pred". +Extract Constant Z.sub => "Big.sub". +Extract Constant Z.mul => "Big.mult". +Extract Constant Z.opp => "Big.opp". +Extract Constant Z.abs => "Big.abs". +Extract Constant Z.min => "Big.min". +Extract Constant Z.max => "Big.max". +Extract Constant Z.compare => "Big.compare_case Eq Lt Gt". + +Extract Constant Z.of_N => "fun p -> p". +Extract Constant Z.abs_N => "Big.abs". + +(** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) (** Test: Require Import ZArith NArith. Extraction "/tmp/test.ml" - Pplus Ppred Pminus Pmult Pcompare Npred Nminus Ndiv Nmod Ncompare - Zplus Zmult BinInt.Zcompare Z_of_N Zabs_N Zdiv.Zdiv Zmod. + Pos.add Pos.pred Pos.sub Pos.mul Pos.compare N.pred N.sub N.div N.modulo N.compare + Z.add Z.mul Z.compare Z.of_N Z.abs_N Z.div Z.modulo. *) diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v index a7046626..ab634329 100644 --- a/plugins/extraction/ExtrOcamlZInt.v +++ b/plugins/extraction/ExtrOcamlZInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,7 @@ (** Extraction of [positive], [N] and [Z] into Ocaml's [int] *) -Require Import ZArith NArith ZOdiv_def. +Require Import ZArith NArith. Require Import ExtrOcamlBasic. (** Disclaimer: trying to obtain efficient certified programs @@ -33,46 +33,48 @@ Extract Inductive N => int [ "0" "" ] (** Efficient (but uncertified) versions for usual functions *) -Extract Constant Pplus => "(+)". -Extract Constant Psucc => "succ". -Extract Constant Ppred => "fun n -> max 1 (n-1)". -Extract Constant Pminus => "fun n m -> max 1 (n-m)". -Extract Constant Pmult => "( * )". -Extract Constant Pmin => "min". -Extract Constant Pmax => "max". -Extract Constant Pcompare => +Extract Constant Pos.add => "(+)". +Extract Constant Pos.succ => "Pervasives.succ". +Extract Constant Pos.pred => "fun n -> Pervasives.max 1 (n-1)". +Extract Constant Pos.sub => "fun n m -> Pervasives.max 1 (n-m)". +Extract Constant Pos.mul => "( * )". +Extract Constant Pos.min => "Pervasives.min". +Extract Constant Pos.max => "Pervasives.max". +Extract Constant Pos.compare => + "fun x y -> if x=y then Eq else if x<y then Lt else Gt". +Extract Constant Pos.compare_cont => "fun x y c -> if x=y then c else if x<y then Lt else Gt". -Extract Constant Nplus => "(+)". -Extract Constant Nsucc => "succ". -Extract Constant Npred => "fun n -> max 0 (n-1)". -Extract Constant Nminus => "fun n m -> max 0 (n-m)". -Extract Constant Nmult => "( * )". -Extract Constant Nmin => "min". -Extract Constant Nmax => "max". -Extract Constant Ndiv => "fun a b -> if b=0 then 0 else a/b". -Extract Constant Nmod => "fun a b -> if b=0 then a else a mod b". -Extract Constant Ncompare => +Extract Constant N.add => "(+)". +Extract Constant N.succ => "Pervasives.succ". +Extract Constant N.pred => "fun n -> Pervasives.max 0 (n-1)". +Extract Constant N.sub => "fun n m -> Pervasives.max 0 (n-m)". +Extract Constant N.mul => "( * )". +Extract Constant N.min => "Pervasives.min". +Extract Constant N.max => "Pervasives.max". +Extract Constant N.div => "fun a b -> if b=0 then 0 else a/b". +Extract Constant N.modulo => "fun a b -> if b=0 then a else a mod b". +Extract Constant N.compare => "fun x y -> if x=y then Eq else if x<y then Lt else Gt". -Extract Constant Zplus => "(+)". -Extract Constant Zsucc => "succ". -Extract Constant Zpred => "pred". -Extract Constant Zminus => "(-)". -Extract Constant Zmult => "( * )". -Extract Constant Zopp => "(~-)". -Extract Constant Zabs => "abs". -Extract Constant Zmin => "min". -Extract Constant Zmax => "max". -Extract Constant Zcompare => +Extract Constant Z.add => "(+)". +Extract Constant Z.succ => "Pervasives.succ". +Extract Constant Z.pred => "Pervasives.pred". +Extract Constant Z.sub => "(-)". +Extract Constant Z.mul => "( * )". +Extract Constant Z.opp => "(~-)". +Extract Constant Z.abs => "Pervasives.abs". +Extract Constant Z.min => "Pervasives.min". +Extract Constant Z.max => "Pervasives.max". +Extract Constant Z.compare => "fun x y -> if x=y then Eq else if x<y then Lt else Gt". -Extract Constant Z_of_N => "fun p -> p". -Extract Constant Zabs_N => "abs". +Extract Constant Z.of_N => "fun p -> p". +Extract Constant Z.abs_N => "Pervasives.abs". -(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod). +(** Z.div and Z.modulo are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml index ae04ba6d..ddb57a25 100644 --- a/plugins/extraction/big.ml +++ b/plugins/extraction/big.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 9713fcd2..92b5949e 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pp open Util open Names @@ -35,17 +33,41 @@ let is_mp_bound = function MPbound _ -> true | _ -> false let pp_par par st = if par then str "(" ++ st ++ str ")" else st +(** [pp_apply] : a head part applied to arguments, possibly with parenthesis *) + let pp_apply st par args = match args with | [] -> st | _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args)) +(** Same as [pp_apply], but with also protection of the head by parenthesis *) + +let pp_apply2 st par args = + let par' = args <> [] || par in + pp_apply (pp_par par' st) par args + let pr_binding = function | [] -> mt () | l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l +let pp_tuple_light f = function + | [] -> mt () + | [x] -> f true x + | l -> + pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l) + +let pp_tuple f = function + | [] -> mt () + | [x] -> f x + | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l) + +let pp_boxed_tuple f = function + | [] -> mt () + | [x] -> f x + | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l)) + (** By default, in module Format, you can do horizontal placing of blocks even if they include newlines, as long as the number of chars in the - blocks are less that a line length. To avoid this awkward situation, + blocks is less that a line length. To avoid this awkward situation, we attach a big virtual size to [fnl] newlines. *) let fnl () = stras (1000000,"") ++ fnl () @@ -54,8 +76,6 @@ let fnl2 () = fnl () ++ fnl () let space_if = function true -> str " " | false -> mt () -let sec_space_if = function true -> spc () | false -> mt () - let is_digit = function | '0'..'9' -> true | _ -> false @@ -177,7 +197,7 @@ let empty_env () = [], get_global_ids () let mktable autoclean = let h = Hashtbl.create 97 in if autoclean then register_cleanup (fun () -> Hashtbl.clear h); - (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h) + (Hashtbl.replace h, Hashtbl.find h, fun () -> Hashtbl.clear h) (* We might have built [global_reference] whose canonical part is inaccurate. We must hence compare only the user part, @@ -352,12 +372,13 @@ let ref_renaming_fun (k,r) = let l = mp_renaming mp in let l = if lang () <> Ocaml && not (modular ()) then [""] else l in let s = + let idg = safe_basename_of_global r in if l = [""] (* this happens only at toplevel of the monolithic case *) then let globs = Idset.elements (get_global_ids ()) in - let id = next_ident_away (kindcase_id k (safe_basename_of_global r)) globs in + let id = next_ident_away (kindcase_id k idg) globs in string_of_id id - else modular_rename k (safe_basename_of_global r) + else modular_rename k idg in add_global_ids (id_of_string s); s::l diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 22bad6cd..f5d90a43 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: common.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Names open Libnames open Miniml @@ -22,10 +20,19 @@ open Pp val fnl : unit -> std_ppcmds val fnl2 : unit -> std_ppcmds val space_if : bool -> std_ppcmds -val sec_space_if : bool -> std_ppcmds val pp_par : bool -> std_ppcmds -> std_ppcmds + +(** [pp_apply] : a head part applied to arguments, possibly with parenthesis *) val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds + +(** Same as [pp_apply], but with also protection of the head by parenthesis *) +val pp_apply2 : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds + +val pp_tuple_light : (bool -> 'a -> std_ppcmds) -> 'a list -> std_ppcmds +val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds +val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds + val pr_binding : identifier list -> std_ppcmds val rename_id : identifier -> Idset.t -> identifier diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 3fa674d3..b7ee3c1a 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extract_env.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Term open Declarations open Names @@ -40,21 +38,19 @@ let toplevel_env () = in l,seb | _ -> failwith "caught" in - match current_toplevel () with - | _ -> SEBstruct (List.rev (map_succeed get_reference seg)) - + SEBstruct (List.rev (map_succeed get_reference seg)) + let environment_until dir_opt = let rec parse = function | [] when dir_opt = None -> [current_toplevel (), toplevel_env ()] | [] -> [] | d :: l -> - let mb = Global.lookup_module (MPfile d) in - (* If -dont-load-proof has been used, mod_expr is None, - we try with mod_type *) - let meb = Option.default mb.mod_type mb.mod_expr in - if dir_opt = Some d then [MPfile d, meb] - else (MPfile d, meb) :: (parse l) + match (Global.lookup_module (MPfile d)).mod_expr with + | Some meb -> + if dir_opt = Some d then [MPfile d, meb] + else (MPfile d, meb) :: (parse l) + | _ -> assert false in parse (Library.loaded_libraries ()) @@ -68,6 +64,9 @@ module type VISIT = sig (* Add the module_path and all its prefixes to the mp visit list *) val add_mp : module_path -> unit + (* Same, but we'll keep all fields of these modules *) + val add_mp_all : module_path -> unit + (* Add kernel_name / constant / reference / ... in the visit lists. These functions silently add the mp of their arg in the mp list *) val add_ind : mutual_inductive -> unit @@ -81,6 +80,7 @@ module type VISIT = sig val needed_ind : mutual_inductive -> bool val needed_con : constant -> bool val needed_mp : module_path -> bool + val needed_mp_all : module_path -> bool end module Visit : VISIT = struct @@ -88,16 +88,26 @@ module Visit : VISIT = struct (for inductives and modules names) and a Cset_env for constants (and still the remaining MPset) *) type must_visit = - { mutable ind : KNset.t; mutable con : KNset.t; mutable mp : MPset.t } + { mutable ind : KNset.t; mutable con : KNset.t; + mutable mp : MPset.t; mutable mp_all : MPset.t } (* the imperative internal visit lists *) - let v = { ind = KNset.empty ; con = KNset.empty ; mp = MPset.empty } + let v = { ind = KNset.empty ; con = KNset.empty ; + mp = MPset.empty; mp_all = MPset.empty } (* the accessor functions *) - let reset () = v.ind <- KNset.empty; v.con <- KNset.empty; v.mp <- MPset.empty + let reset () = + v.ind <- KNset.empty; + v.con <- KNset.empty; + v.mp <- MPset.empty; + v.mp_all <- MPset.empty let needed_ind i = KNset.mem (user_mind i) v.ind let needed_con c = KNset.mem (user_con c) v.con - let needed_mp mp = MPset.mem mp v.mp + let needed_mp mp = MPset.mem mp v.mp || MPset.mem mp v.mp_all + let needed_mp_all mp = MPset.mem mp v.mp_all let add_mp mp = check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp + let add_mp_all mp = + check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp; + v.mp_all <- MPset.add mp v.mp_all let add_ind i = let kn = user_mind i in v.ind <- KNset.add kn v.ind; add_mp (modpath kn) @@ -120,12 +130,17 @@ let check_arity env cb = let check_fix env cb i = match cb.const_body with - | None -> raise Impossible - | Some lbody -> - match kind_of_term (Declarations.force lbody) with + | Def lbody -> + (match kind_of_term (Declarations.force lbody) with | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd) | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd) - | _ -> raise Impossible + | _ -> raise Impossible) + | Undef _ | OpaqueDef _ -> raise Impossible + +let prec_declaration_equal (na1, ca1, ta1) (na2, ca2, ta2) = + na1 = na2 && + array_equal eq_constr ca1 ca2 && + array_equal eq_constr ta1 ta2 let factor_fix env l cb msb = let _,recd as check = check_fix env cb 0 in @@ -139,7 +154,10 @@ let factor_fix env l cb msb = (fun j -> function | (l,SFBconst cb') -> - if check <> check_fix env cb' (j+1) then raise Impossible; + let check' = check_fix env cb' (j+1) in + if not (fst check = fst check' && + prec_declaration_equal (snd check) (snd check')) + then raise Impossible; labels.(j+1) <- l; | _ -> raise Impossible) msb'; labels, recd, msb'' @@ -157,7 +175,8 @@ let rec seb2mse = function let expand_seb env mp seb = let seb,_,_,_ = - Mod_typing.translate_struct_module_entry env mp true (seb2mse seb) + let inl = Some (Flags.get_inline_level()) in + Mod_typing.translate_struct_module_entry env mp inl (seb2mse seb) in seb (** When possible, we use the nicer, shorter, algebraic type structures @@ -179,13 +198,14 @@ let rec msid_of_seb = function | SEBwith (seb,_) -> msid_of_seb seb | _ -> assert false -let env_for_mtb_with env mp seb idl = +let env_for_mtb_with_def env mp seb idl = let sig_b = match seb with | SEBstruct(sig_b) -> sig_b | _ -> assert false in let l = label_of_id (List.hd idl) in - let before = fst (list_split_when (fun (l',_) -> l=l') sig_b) in + let spot = function (l',SFBconst _) -> l = l' | _ -> false in + let before = fst (list_split_when spot sig_b) in Modops.add_signature mp before empty_delta_resolver env (* From a [structure_body] (i.e. a list of [structure_field_body]) @@ -200,9 +220,8 @@ let rec extract_sfb_spec env mp = function if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end | (l,SFBmind _) :: msig -> - let kn = make_kn mp empty_dirpath l in - let mind = mind_of_kn kn in - let s = Sind (kn, extract_inductive env mind) in + let mind = make_mind mp empty_dirpath l in + let s = Sind (mind, extract_inductive env mind) in let specs = extract_sfb_spec env mp msig in if logical_spec s then specs else begin Visit.add_spec_deps s; (l,Spec s) :: specs end @@ -223,15 +242,15 @@ let rec extract_sfb_spec env mp = function *) and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with - | SEBident mp -> Visit.add_mp mp; MTident mp + | SEBident mp -> Visit.add_mp_all mp; MTident mp | SEBwith(seb',With_definition_body(idl,cb))-> - let env' = env_for_mtb_with env (msid_of_seb seb') seb idl in + let env' = env_for_mtb_with_def env (msid_of_seb seb') seb idl in let mt = extract_seb_spec env mp1 (seb,seb') in (match extract_with_type env' cb with (* cb peut contenir des kn *) | None -> mt | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ))) | SEBwith(seb',With_module_body(idl,mp))-> - Visit.add_mp mp; + Visit.add_mp_all mp; MTwith(extract_seb_spec env mp1 (seb,seb'), ML_With_module(idl,mp)) | SEBfunctor (mbid, mtb, seb_alg') -> @@ -283,11 +302,10 @@ let rec extract_sfb env mp all = function else ms) | (l,SFBmind mib) :: msb -> let ms = extract_sfb env mp all msb in - let kn = make_kn mp empty_dirpath l in - let mind = mind_of_kn kn in + let mind = make_mind mp empty_dirpath l in let b = Visit.needed_ind mind in if all || b then - let d = Dind (kn, extract_inductive env mind) in + let d = Dind (mind, extract_inductive env mind) in if (not b) && (logical_decl d) then ms else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end else ms @@ -312,7 +330,7 @@ and extract_seb env mp all = function extract_seb env mp all (expand_seb env mp seb) | SEBident mp -> if is_modfile mp && not (modular ()) then error_MPfile_as_mod mp false; - Visit.add_mp mp; MEident mp + Visit.add_mp_all mp; MEident mp | SEBapply (meb, meb',_) -> MEapply (extract_seb env mp true meb, extract_seb env mp true meb') @@ -346,11 +364,12 @@ let unpack = function MEstruct (_,sel) -> sel | _ -> assert false let mono_environment refs mpl = Visit.reset (); List.iter Visit.add_ref refs; - List.iter Visit.add_mp mpl; + List.iter Visit.add_mp_all mpl; let env = Global.env () in let l = List.rev (environment_until None) in List.rev_map - (fun (mp,m) -> mp, unpack (extract_seb env mp false m)) l + (fun (mp,m) -> mp, unpack (extract_seb env mp (Visit.needed_mp_all mp) m)) + l (**************************************) (*S Part II : Input/Output primitives *) @@ -378,8 +397,10 @@ let mono_filename f = in let id = if lang () <> Haskell then default_id - else try id_of_string (Filename.basename f) - with _ -> error "Extraction: provided filename is not a valid identifier" + else + try id_of_string (Filename.basename f) + with e when Errors.noncritical e -> + error "Extraction: provided filename is not a valid identifier" in Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id @@ -454,8 +475,8 @@ let print_structure_to_file (fn,si,mo) dry struc = msg_with ft (d.preamble mo opened unsafe_needs); msg_with ft (d.pp_struct struc); Option.iter close_out cout; - with e -> - Option.iter close_out cout; raise e + with reraise -> + Option.iter close_out cout; raise reraise end; if not dry then Option.iter info_file fn; (* Now, let's print the signature *) @@ -468,8 +489,8 @@ let print_structure_to_file (fn,si,mo) dry struc = msg_with ft (d.sig_preamble mo opened unsafe_needs); msg_with ft (d.pp_sig (signature_of_structure struc)); close_out cout; - with e -> - close_out cout; raise e + with reraise -> + close_out cout; raise reraise end; info_file si) (if dry then None else si); @@ -488,13 +509,18 @@ let print_structure_to_file (fn,si,mo) dry struc = let reset () = Visit.reset (); reset_tables (); reset_renaming_tables Everything -let init modular = +let init modular library = check_inside_section (); check_inside_module (); set_keywords (descr ()).keywords; set_modular modular; + set_library library; reset (); if modular && lang () = Scheme then error_scheme () +let warns () = + warning_opaques (access_opaque ()); + warning_axioms () + (* From a list of [reference], let's retrieve whether they correspond to modules or [global_reference]. Warn the user if both is possible. *) @@ -503,7 +529,10 @@ let rec locate_ref = function | r::l -> let q = snd (qualid_of_reference r) in let mpo = try Some (Nametab.locate_module q) with Not_found -> None - and ro = try Some (Nametab.locate q) with Not_found -> None in + and ro = + try Some (Smartlocate.global_with_alias r) + with e when Errors.noncritical e -> None + in match mpo, ro with | None, None -> Nametab.error_global_not_found q | None, Some r -> let refs,mps = locate_ref l in r::refs,mps @@ -518,25 +547,43 @@ let rec locate_ref = function \verb!Extraction "file"! [qualid1] ... [qualidn]. *) let full_extr f (refs,mps) = - init false; + init false false; List.iter (fun mp -> if is_modfile mp then error_MPfile_as_mod mp true) mps; - let struc = optimize_struct refs (mono_environment refs mps) in - warning_axioms (); + let struc = optimize_struct (refs,mps) (mono_environment refs mps) in + warns (); print_structure_to_file (mono_filename f) false struc; reset () let full_extraction f lr = full_extr f (locate_ref lr) +(*s Separate extraction is similar to recursive extraction, with the output + decomposed in many files, one per Coq .v file *) + +let separate_extraction lr = + init true false; + let refs,mps = locate_ref lr in + let struc = optimize_struct (refs,mps) (mono_environment refs mps) in + warns (); + let print = function + | (MPfile dir as mp, sel) as e -> + print_structure_to_file (module_filename mp) false [e] + | _ -> assert false + in + List.iter print struc; + reset () + (*s Simple extraction in the Coq toplevel. The vernacular command is \verb!Extraction! [qualid]. *) -let simple_extraction r = match locate_ref [r] with +let simple_extraction r = + Vernacentries.dump_global (Genarg.AN r); + match locate_ref [r] with | ([], [mp]) as p -> full_extr None p | [r],[] -> - init false; - let struc = optimize_struct [r] (mono_environment [r] []) in + init false false; + let struc = optimize_struct ([r],[]) (mono_environment [r] []) in let d = get_decl_in_structure r struc in - warning_axioms (); + warns (); if is_custom r then msgnl (str "(** User defined extraction *)"); print_one_decl struc (modpath_of_r r) d; reset () @@ -547,12 +594,12 @@ let simple_extraction r = match locate_ref [r] with \verb!(Recursive) Extraction Library! [M]. *) let extraction_library is_rec m = - init true; + init true true; let dir_m = let q = qualid_of_ident m in try Nametab.full_name_module q with Not_found -> error_unknown_module q in - Visit.add_mp (MPfile dir_m); + Visit.add_mp_all (MPfile dir_m); let env = Global.env () in let l = List.rev (environment_until (Some dir_m)) in let select l (mp,meb) = @@ -561,8 +608,8 @@ let extraction_library is_rec m = else l in let struc = List.fold_left select [] l in - let struc = optimize_struct [] struc in - warning_axioms (); + let struc = optimize_struct ([],[]) struc in + warns (); let print = function | (MPfile dir as mp, sel) as e -> let dry = not is_rec && dir <> dir_m in diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli index 145cd6b3..75ac111d 100644 --- a/plugins/extraction/extract_env.mli +++ b/plugins/extraction/extract_env.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extract_env.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*s This module declares the extraction commands. *) open Names @@ -15,9 +13,15 @@ open Libnames val simple_extraction : reference -> unit val full_extraction : string option -> reference list -> unit +val separate_extraction : reference list -> unit val extraction_library : bool -> identifier -> unit (* For debug / external output via coqtop.byte + Drop : *) val mono_environment : global_reference list -> module_path list -> Miniml.ml_structure + +(* Used by the Relation Extraction plugin *) + +val print_one_decl : + Miniml.ml_structure -> module_path -> Miniml.ml_decl -> unit diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 27f32a4a..e5357336 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.ml 14786 2011-12-10 12:55:19Z letouzey $ i*) - (*i*) open Util open Names @@ -48,8 +46,6 @@ let sort_of env c = Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c) with SingletonInductiveBecomesProp id -> error_singleton_become_prop id -let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None - (*S Generation of flags and signatures. *) (* The type [flag] gives us information about any Coq term: @@ -134,7 +130,7 @@ let rec nb_default_params env c = (* Enriching a signature with implicit information *) -let sign_with_implicits r s = +let sign_with_implicits r s nb_params = let implicits = implicits_of_global r in let rec add_impl i = function | [] -> [] @@ -143,7 +139,7 @@ let sign_with_implicits r s = if sign = Keep && List.mem i implicits then Kill Kother else sign in sign' :: add_impl (succ i) s in - add_impl 1 s + add_impl (1+nb_params) s (* Enriching a exception message *) @@ -153,7 +149,7 @@ let rec handle_exn r n fn_name = function (fun i -> assert ((0 < i) && (i <= n)); MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i))) - with _ -> MLexn s) + with e when Errors.noncritical e -> MLexn s) | a -> ast_map (handle_exn r n fn_name) a (*S Management of type variable contexts. *) @@ -197,6 +193,27 @@ let parse_ind_args si args relmax = | _ -> parse (i+1) (j+1) s) in parse 1 1 si +let oib_equal o1 o2 = + id_ord o1.mind_typename o2.mind_typename = 0 && + list_equal eq_rel_declaration o1.mind_arity_ctxt o2.mind_arity_ctxt && + begin match o1.mind_arity, o2.mind_arity with + | Monomorphic {mind_user_arity=c1; mind_sort=s1}, + Monomorphic {mind_user_arity=c2; mind_sort=s2} -> + eq_constr c1 c2 && s1 = s2 + | ma1, ma2 -> ma1 = ma2 end && + o1.mind_consnames = o2.mind_consnames + +let mib_equal m1 m2 = + array_equal oib_equal m1.mind_packets m1.mind_packets && + m1.mind_record = m2.mind_record && + m1.mind_finite = m2.mind_finite && + m1.mind_ntypes = m2.mind_ntypes && + list_equal eq_named_declaration m1.mind_hyps m2.mind_hyps && + m1.mind_nparams = m2.mind_nparams && + m1.mind_nparams_rec = m2.mind_nparams_rec && + list_equal eq_rel_declaration m1.mind_params_ctxt m2.mind_params_ctxt && + m1.mind_constraints = m2.mind_constraints + (*S Extraction of a type. *) (* [extract_type env db c args] is used to produce an ML type from the @@ -215,7 +232,7 @@ let rec extract_type env db j c args = extract_type env db j d (Array.to_list args' @ args) | Lambda (_,_,d) -> (match args with - | [] -> assert false (* otherwise the lambda would be reductible. *) + | [] -> assert false (* A lambda cannot be a type. *) | a :: args -> extract_type env db j (subst1 a d) args) | Prod (n,t,d) -> assert (args = []); @@ -255,12 +272,13 @@ let rec extract_type env db j c args = let cb = lookup_constant kn env in let typ = Typeops.type_of_constant_type env cb.const_type in (match flag_of_type env typ with + | (Logic,_) -> assert false (* Cf. logical cases above *) | (Info, TypeScheme) -> let mlt = extract_type_app env db (r, type_sign env typ) args in (match cb.const_body with - | None -> mlt - | Some _ when is_custom r -> mlt - | Some lbody -> + | Undef _ | OpaqueDef _ -> mlt + | Def _ when is_custom r -> mlt + | Def lbody -> let newc = applist (Declarations.force lbody, args) in let mlt' = extract_type env db j newc [] in (* ML type abbreviations interact badly with Coq *) @@ -269,10 +287,11 @@ let rec extract_type env db j c args = (* The shortest is [mlt], which use abbreviations *) (* If possible, we take [mlt], otherwise [mlt']. *) if expand env mlt = expand env mlt' then mlt else mlt') - | _ -> (* only other case here: Info, Default, i.e. not an ML type *) + | (Info, Default) -> + (* Not an ML type, for example [(c:forall X, X->X) Type nat] *) (match cb.const_body with - | None -> Tunknown (* Brutal approximation ... *) - | Some lbody -> + | Undef _ | OpaqueDef _ -> Tunknown (* Brutal approx ... *) + | Def lbody -> (* We try to reduce. *) let newc = applist (Declarations.force lbody, args) in extract_type env db j newc [])) @@ -282,14 +301,6 @@ let rec extract_type env db j c args = | Case _ | Fix _ | CoFix _ -> Tunknown | _ -> assert false -(* [extract_maybe_type] calls [extract_type] when used on a Coq type, - and otherwise returns [Tdummy] or [Tunknown] *) - -and extract_maybe_type env db c = - let t = whd_betadeltaiota env none (type_of env c) in - if isSort t then extract_type env db 0 c [] - else if sort_of env t = InProp then Tdummy Kother else Tunknown - (*s Auxiliary function dealing with type application. Precondition: [r] is a type scheme represented by the signature [s], and is completely applied: [List.length args = List.length s]. *) @@ -337,13 +348,18 @@ and extract_ind env kn = (* kn is supposed to be in long form *) We hence check that the mib has not changed from recording time to retrieving time. Ideally we should also check the env. *) let (mib0,ml_ind) = lookup_ind kn in - if not (mib = mib0) then raise Not_found; + if not (mib_equal mib mib0) then raise Not_found; ml_ind with Not_found -> - (* First, if this inductive is aliased via a Module, *) - (* we process the original inductive. *) - let equiv = - if (canonical_mind kn) = (user_mind kn) then + (* First, if this inductive is aliased via a Module, + we process the original inductive if possible. + When at toplevel of the monolithic case, we cannot do much + (cf Vector and bug #2570) *) + let equiv = + if lang () <> Ocaml || + (not (modular ()) && at_toplevel (mind_modpath kn)) || + kn_ord (canonical_mind kn) (user_mind kn) = 0 + then NoEquiv else begin @@ -370,8 +386,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) ip_logical = (not b); ip_sign = s; ip_vars = v; - ip_types = t; - ip_optim_id_ok = None }) + ip_types = t }) mib.mind_packets in @@ -412,7 +427,8 @@ and extract_ind env kn = (* kn is supposed to be in long form *) if Array.length p.ip_types <> 1 then raise (I Standard); let typ = p.ip_types.(0) in let l = List.filter (fun t -> not (isDummy (expand env t))) typ in - if List.length l = 1 && not (type_mem_kn kn (List.hd l)) + if not (keep_singleton ()) && + List.length l = 1 && not (type_mem_kn kn (List.hd l)) then raise (I Singleton); if l = [] then raise (I Standard); if not mib.mind_record then raise (I Standard); @@ -464,6 +480,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *) ind_equiv = equiv } in add_ind kn mib i; + add_inductive_kind kn i.ind_kind; i (*s [extract_type_cons] extracts the type of an inductive @@ -496,8 +513,8 @@ and mlt_env env r = match r with let cb = Environ.lookup_constant kn env in let typ = Typeops.type_of_constant_type env cb.const_type in match cb.const_body with - | None -> None - | Some l_body -> + | Undef _ | OpaqueDef _ -> None + | Def l_body -> (match flag_of_type env typ with | Info,TypeScheme -> let body = Declarations.force l_body in @@ -560,6 +577,8 @@ let rec extract_term env mle mlt c args = | LetIn (n, c1, t1, c2) -> let id = id_of_name n in let env' = push_rel (Name id, Some c1, t1) env in + (* We directly push the args inside the [LetIn]. + TODO: the opt_let_app flag is supposed to prevent that *) let args' = List.map (lift 1) args in (try check_default env t1; @@ -648,20 +667,23 @@ and extract_cst_app env mle mlt kn args = let head = put_magic_if magic1 (MLglob (ConstRef kn)) in (* Now, the extraction of the arguments. *) let s_full = type2signature env (snd schema) in - let s_full = sign_with_implicits (ConstRef kn) s_full in + let s_full = sign_with_implicits (ConstRef kn) s_full 0 in let s = sign_no_final_keeps s_full in let ls = List.length s in let la = List.length args in (* The ml arguments, already expunged from known logical ones *) let mla = make_mlargs env mle s args metas in let mla = - if not magic1 then + if magic1 || lang () <> Ocaml then mla + else try + (* for better optimisations later, we discard dependent args + of projections and replace them by fake args that will be + removed during final pretty-print. *) let l,l' = list_chop (projection_arity (ConstRef kn)) mla in if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla - with _ -> mla - else mla + with e when Errors.noncritical e -> mla in (* For strict languages, purely logical signatures with at least one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left @@ -707,7 +729,7 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = let type_cons = instantiation (nb_tvars, type_cons) in (* Then, the usual variables [s], [ls], [la], ... *) let s = List.map (type2sign env) types in - let s = sign_with_implicits (ConstructRef cp) s in + let s = sign_with_implicits (ConstructRef cp) s params_nb in let ls = List.length s in let la = List.length args in assert (la <= ls + params_nb); @@ -727,8 +749,8 @@ and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args = | Tglob (_,l) -> List.map type_simpl l | _ -> assert false in - let info = {c_kind = mi.ind_kind; c_typs = typeargs} in - put_magic_if magic1 (MLcons (info, ConstructRef cp, mla)) + let typ = Tglob(IndRef ip, typeargs) in + put_magic_if magic1 (MLcons (typ, ConstructRef cp, mla)) in (* Different situations depending of the number of arguments: *) if la < params_nb then @@ -786,28 +808,28 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = let l = List.map f oi.ip_types.(i) in (* the corresponding signature *) let s = List.map (type2sign env) oi.ip_types.(i) in - let s = sign_with_implicits r s in + let s = sign_with_implicits r s mi.ind_nparams in (* Extraction of the branch (in functional form). *) let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in (* We suppress dummy arguments according to signature. *) let ids,e = case_expunge s e in let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in - (r, List.rev ids, e') + (List.rev ids, Pusual r, e') in if mi.ind_kind = Singleton then begin (* Informative singleton case: *) (* [match c with C i -> t] becomes [let i = c' in t'] *) assert (br_size = 1); - let (_,ids,e') = extract_branch 0 in + let (ids,_,e') = extract_branch 0 in assert (List.length ids = 1); MLletin (tmp_id (List.hd ids),a,e') end else (* Standard case: we apply [extract_branch]. *) let typs = List.map type_simpl (Array.to_list metas) in - let info = { m_kind = mi.ind_kind; m_typs = typs; m_same = BranchNone } - in MLcase (info, a, Array.init br_size extract_branch) + let typ = Tglob (IndRef ip,typs) in + MLcase (typ, a, Array.init br_size extract_branch) (*s Extraction of a (co)-fixpoint. *) @@ -857,7 +879,7 @@ let extract_std_constant env kn body typ = let l,t' = type_decomp (expand env (var2var' t)) in let s = List.map (type2sign env) l in (* Check for user-declared implicit information *) - let s = sign_with_implicits (ConstRef kn) s in + let s = sign_with_implicits (ConstRef kn) s 0 in (* Decomposing the top level lambdas of [body]. If there isn't enough, it's ok, as long as remaining args aren't to be pruned (and initial lambdas aren't to be all @@ -869,7 +891,7 @@ let extract_std_constant env kn body typ = and m = nb_lam body in if n <= m then decompose_lam_n n body else - let s,s' = list_split_at m s in + let s,s' = list_chop m s in if List.for_all ((=) Keep) s' && (lang () = Haskell || sign_kind s <> UnsafeLogicalSig) then decompose_lam_n m body @@ -878,7 +900,7 @@ let extract_std_constant env kn body typ = (* Should we do one eta-expansion to avoid non-generalizable '_a ? *) let rels, c = let n = List.length rels in - let s,s' = list_split_at n s in + let s,s' = list_chop n s in let k = sign_kind s in let empty_s = (k = EmptySig || k = SafeLogicalSig) in if lang () = Ocaml && empty_s && not (gentypvar_ok c) @@ -888,7 +910,7 @@ let extract_std_constant env kn body typ = in let n = List.length rels in let s = list_firstn n s in - let l,l' = list_split_at n l in + let l,l' = list_chop n l in let t' = type_recomp (l',t') in (* The initial ML environment. *) let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in @@ -904,6 +926,19 @@ let extract_std_constant env kn body typ = in trm, type_expunge_from_sign env s t +(* Extracts the type of an axiom, honors the Extraction Implicit declaration. *) +let extract_axiom env kn typ = + reset_meta_count (); + (* The short type [t] (i.e. possibly with abbreviations). *) + let t = snd (record_constant_type env kn (Some typ)) in + (* The real type [t']: without head products, expanded, *) + (* and with [Tvar] translated to [Tvar'] (not instantiable). *) + let l,_ = type_decomp (expand env (var2var' t)) in + let s = List.map (type2sign env) l in + (* Check for user-declared implicit information *) + let s = sign_with_implicits (ConstRef kn) s 0 in + type_expunge_from_sign env s t + let extract_fixpoint env vkn (fi,ti,ci) = let n = Array.length vkn in let types = Array.make n (Tdummy Kother) @@ -925,34 +960,45 @@ let extract_fixpoint env vkn (fi,ti,ci) = let extract_constant env kn cb = let r = ConstRef kn in let typ = Typeops.type_of_constant_type env cb.const_type in - match cb.const_body with - | None -> (* A logical axiom is risky, an informative one is fatal. *) - (match flag_of_type env typ with - | (Info,TypeScheme) -> - if not (is_custom r) then add_info_axiom r; - let n = type_scheme_nb_args env typ in - let ids = iterate (fun l -> anonymous_name::l) n [] in - Dtype (r, ids, Taxiom) - | (Info,Default) -> - if not (is_custom r) then add_info_axiom r; - let t = snd (record_constant_type env kn (Some typ)) in - Dterm (r, MLaxiom, type_expunge env t) - | (Logic,TypeScheme) -> - add_log_axiom r; Dtype (r, [], Tdummy Ktype) - | (Logic,Default) -> - add_log_axiom r; Dterm (r, MLdummy, Tdummy Kother)) - | Some body -> - (match flag_of_type env typ with - | (Logic, Default) -> Dterm (r, MLdummy, Tdummy Kother) - | (Logic, TypeScheme) -> Dtype (r, [], Tdummy Ktype) - | (Info, Default) -> - let e,t = extract_std_constant env kn (force body) typ in - Dterm (r,e,t) - | (Info, TypeScheme) -> - let s,vl = type_sign_vl env typ in - let db = db_from_sign s in - let t = extract_type_scheme env db (force body) (List.length s) - in Dtype (r, vl, t)) + let warn_info () = if not (is_custom r) then add_info_axiom r in + let warn_log () = if not (constant_has_body cb) then add_log_axiom r + in + let mk_typ_ax () = + let n = type_scheme_nb_args env typ in + let ids = iterate (fun l -> anonymous_name::l) n [] in + Dtype (r, ids, Taxiom) + in + let mk_typ c = + let s,vl = type_sign_vl env typ in + let db = db_from_sign s in + let t = extract_type_scheme env db c (List.length s) + in Dtype (r, vl, t) + in + let mk_ax () = + let t = extract_axiom env kn typ in + Dterm (r, MLaxiom, t) + in + let mk_def c = + let e,t = extract_std_constant env kn c typ in + Dterm (r,e,t) + in + match flag_of_type env typ with + | (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype) + | (Logic,Default) -> warn_log (); Dterm (r, MLdummy, Tdummy Kother) + | (Info,TypeScheme) -> + (match cb.const_body with + | Undef _ -> warn_info (); mk_typ_ax () + | Def c -> mk_typ (force c) + | OpaqueDef c -> + add_opaque r; + if access_opaque () then mk_typ (force_opaque c) else mk_typ_ax ()) + | (Info,Default) -> + (match cb.const_body with + | Undef _ -> warn_info (); mk_ax () + | Def c -> mk_def (force c) + | OpaqueDef c -> + add_opaque r; + if access_opaque () then mk_def (force_opaque c) else mk_ax ()) let extract_constant_spec env kn cb = let r = ConstRef kn in @@ -963,8 +1009,8 @@ let extract_constant_spec env kn cb = | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in (match cb.const_body with - | None -> Stype (r, vl, None) - | Some body -> + | Undef _ | OpaqueDef _ -> Stype (r, vl, None) + | Def body -> let db = db_from_sign s in let t = extract_type_scheme env db (force body) (List.length s) in Stype (r, vl, Some t)) @@ -977,9 +1023,13 @@ let extract_with_type env cb = match flag_of_type env typ with | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in - let body = Option.get cb.const_body in let db = db_from_sign s in - let t = extract_type_scheme env db (force body) (List.length s) in + let c = match cb.const_body with + | Def body -> force body + (* A "with Definition ..." is necessarily transparent *) + | Undef _ | OpaqueDef _ -> assert false + in + let t = extract_type_scheme env db c (List.length s) in Some (vl, t) | _ -> None @@ -995,7 +1045,7 @@ let extract_inductive env kn = let l' = filter (succ i) l in if isDummy (expand env t) || List.mem i implicits then l' else t::l' - in filter 1 l + in filter (1+ind.ind_nparams) l in let packets = Array.mapi (fun i p -> { p with ip_types = Array.mapi (f i) p.ip_types }) diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli index 8a2125fe..1eb9ca8e 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: extraction.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*s Extraction from Coq terms to Miniml. *) open Names diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index ebd4de0d..7dabb560 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -63,6 +63,12 @@ VERNAC COMMAND EXTEND Extraction -> [ full_extraction (Some f) l ] END +VERNAC COMMAND EXTEND SeparateExtraction +(* Same, with content splitted in several files *) +| [ "Separate" "Extraction" ne_global_list(l) ] + -> [ separate_extraction l ] +END + (* Modular extraction (one Coq library = one ML module) *) VERNAC COMMAND EXTEND ExtractionLibrary | [ "Extraction" "Library" ident(m) ] diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index aeacef93..b6fc5ac8 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: haskell.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*s Production of Haskell syntax. *) open Pp @@ -47,15 +45,15 @@ let preamble mod_name used_modules usf = (if used_modules = [] then mt () else fnl ()) ++ (if not usf.magic then mt () else str "\ -unsafeCoerce :: a -> b -#ifdef __GLASGOW_HASKELL__ -import qualified GHC.Base -unsafeCoerce = GHC.Base.unsafeCoerce# -#else --- HUGS -import qualified IOExts -unsafeCoerce = IOExts.unsafeCoerce -#endif" ++ fnl2 ()) +\nunsafeCoerce :: a -> b\ +\n#ifdef __GLASGOW_HASKELL__\ +\nimport qualified GHC.Base\ +\nunsafeCoerce = GHC.Base.unsafeCoerce#\ +\n#else\ +\n-- HUGS\ +\nimport qualified IOExts\ +\nunsafeCoerce = IOExts.unsafeCoerce\ +\n#endif" ++ fnl2 ()) ++ (if not usf.mldummy then mt () else str "__ :: any" ++ fnl () ++ @@ -78,17 +76,19 @@ let pp_global k r = let kn_sig = let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in - make_kn specif empty_dirpath (mk_label "sig") + make_mind specif empty_dirpath (mk_label "sig") let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ -> assert false - | Tvar i -> (try pr_id (List.nth vl (pred i)) with _ -> (str "a" ++ int i)) + | Tvar i -> + (try pr_id (List.nth vl (pred i)) + with e when Errors.noncritical e -> (str "a" ++ int i)) | Tglob (r,[]) -> pp_global Type r - | Tglob (r,l) -> - if r = IndRef (mind_of_kn kn_sig,0) then + | Tglob (IndRef(kn,0),l) + when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" -> pp_type true vl (List.hd l) - else + | Tglob (r,l) -> pp_par par (pp_global Type r ++ spc () ++ prlist_with_sep spc (pp_type true vl) l) @@ -113,8 +113,8 @@ let expr_needs_par = function let rec pp_expr par env args = - let par' = args <> [] || par - and apply st = pp_apply st par args in + let apply st = pp_apply st par args + and apply2 st = pp_apply2 st par args in function | MLrel n -> let id = get_db_name n env in apply (pr_id id) @@ -125,7 +125,7 @@ let rec pp_expr par env args = let fl,a' = collect_lams a in let fl,env' = push_vars (List.map id_of_mlid fl) env in let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in - apply (pp_par par' st) + apply2 st | MLletin (id,a1,a2) -> let i,env' = push_vars [id_of_mlid id] env in let pp_id = pr_id (List.hd i) @@ -135,37 +135,42 @@ let rec pp_expr par env args = str "let {" ++ cut () ++ hov 1 (pp_id ++ str " = " ++ pp_a1 ++ str "}") in - apply - (pp_par par' - (hv 0 (hv 0 (hv 1 pp_def ++ spc () ++ str "in") ++ - spc () ++ hov 0 pp_a2))) + apply2 (hv 0 (hv 0 (hv 1 pp_def ++ spc () ++ str "in") ++ + spc () ++ hov 0 pp_a2)) | MLglob r -> apply (pp_global Term r) - | MLcons _ as c when is_native_char c -> assert (args=[]); pp_native_char c - | MLcons (_,r,[]) -> - assert (args=[]); pp_global Cons r - | MLcons (_,r,[a]) -> - assert (args=[]); - pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) - | MLcons (_,r,args') -> - assert (args=[]); - pp_par par (pp_global Cons r ++ spc () ++ - prlist_with_sep spc (pp_expr true env []) args') + | MLcons (_,r,a) as c -> + assert (args=[]); + begin match a with + | _ when is_native_char c -> pp_native_char c + | [] -> pp_global Cons r + | [a] -> + pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a) + | _ -> + pp_par par (pp_global Cons r ++ spc () ++ + prlist_with_sep spc (pp_expr true env []) a) + end + | MLtuple l -> + assert (args=[]); + pp_boxed_tuple (pp_expr true env []) l | MLcase (_,t, pv) when is_custom_match pv -> - let mkfun (_,ids,e) = + if not (is_regular_match pv) then + error "Cannot mix yet user-given match and general patterns."; + let mkfun (ids,_,e) = if ids <> [] then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in - apply - (pp_par par' - (hov 2 - (str (find_custom_match pv) ++ fnl () ++ - prvect (fun tr -> pp_expr true env [] (mkfun tr) ++ fnl ()) pv - ++ pp_expr true env [] t))) - | MLcase (info,t, pv) -> - apply (pp_par par' - (v 0 (str "case " ++ pp_expr false env [] t ++ str " of {" ++ - fnl () ++ pp_pat env info pv))) + let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in + let inner = + str (find_custom_match pv) ++ fnl () ++ + prvect pp_branch pv ++ + pp_expr true env [] t + in + apply2 (hov 2 inner) + | MLcase (typ,t,pv) -> + apply2 + (v 0 (str "case " ++ pp_expr false env [] t ++ str " of {" ++ + fnl () ++ pp_pat env pv)) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args @@ -178,44 +183,31 @@ let rec pp_expr par env args = pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") -and pp_pat env info pv = - let pp_one_pat (name,ids,t) = - let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in - let par = expr_needs_par t in - hov 2 (str " " ++ pp_global Cons name ++ - (match ids with - | [] -> mt () - | _ -> (str " " ++ - prlist_with_sep spc pr_id (List.rev ids))) ++ - str " ->" ++ spc () ++ pp_expr par env' [] t) - in - let factor_br, factor_set = try match info.m_same with - | BranchFun ints -> - let i = Intset.choose ints in - branch_as_fun info.m_typs pv.(i), ints - | BranchCst ints -> - let i = Intset.choose ints in - ast_pop (branch_as_cst pv.(i)), ints - | BranchNone -> MLdummy, Intset.empty - with _ -> MLdummy, Intset.empty - in - let last = Array.length pv - 1 in +and pp_cons_pat par r ppl = + pp_par par + (pp_global Cons r ++ space_if (ppl<>[]) ++ prlist_with_sep spc identity ppl) + +and pp_gen_pat par ids env = function + | Pcons (r,l) -> pp_cons_pat par r (List.map (pp_gen_pat true ids env) l) + | Pusual r -> pp_cons_pat par r (List.map pr_id ids) + | Ptuple l -> pp_boxed_tuple (pp_gen_pat false ids env) l + | Pwild -> str "_" + | Prel n -> pr_id (get_db_name n env) + +and pp_one_pat env (ids,p,t) = + let ids',env' = push_vars (List.rev_map id_of_mlid ids) env in + hov 2 (str " " ++ + pp_gen_pat false (List.rev ids') env' p ++ + str " ->" ++ spc () ++ + pp_expr (expr_needs_par t) env' [] t) + +and pp_pat env pv = prvecti - (fun i x -> if Intset.mem i factor_set then mt () else - (pp_one_pat pv.(i) ++ - if i = last && Intset.is_empty factor_set then str "}" else - (str ";" ++ fnl ()))) pv - ++ - if Intset.is_empty factor_set then mt () else - let par = expr_needs_par factor_br in - match info.m_same with - | BranchFun _ -> - let ids, env' = push_vars [anonymous_name] env in - hov 2 (str " " ++ pr_id (List.hd ids) ++ str " ->" ++ spc () ++ - pp_expr par env' [] factor_br ++ str "}") - | BranchCst _ -> - hov 2 (str " _ ->" ++ spc () ++ pp_expr par env [] factor_br ++ str "}") - | BranchNone -> mt () + (fun i x -> + pp_one_pat env pv.(i) ++ + if i = Array.length pv - 1 then str "}" else + (str ";" ++ fnl ())) + pv (*s names of the functions ([ids]) are already pushed in [env], and passed here just for convenience. *) @@ -293,12 +285,10 @@ let rec pp_ind first kn i ind = (*s Pretty-printing of a declaration. *) -let pp_string_parameters ids = prlist (fun id -> str id ++ str " ") - let pp_decl = function | Dind (kn,i) when i.ind_kind = Singleton -> - pp_singleton (mind_of_kn kn) i.ind_packets.(0) ++ fnl () - | Dind (kn,i) -> hov 0 (pp_ind true (mind_of_kn kn) 0 i) + pp_singleton kn i.ind_packets.(0) ++ fnl () + | Dind (kn,i) -> hov 0 (pp_ind true kn 0 i) | Dtype (r, l, t) -> if is_inline_custom r then mt () else diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli index eb774db7..5e76be48 100644 --- a/plugins/extraction/haskell.mli +++ b/plugins/extraction/haskell.mli @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: haskell.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - val haskell_descr : Miniml.language_descr diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index aaf2d0c3..856a481e 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: miniml.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*s Target language for extraction: a core ML called MiniML. *) open Pp @@ -73,8 +71,7 @@ type ml_ind_packet = { ip_logical : bool; ip_sign : signature; ip_vars : identifier list; - ip_types : (ml_type list) array; - mutable ip_optim_id_ok : bool option + ip_types : (ml_type list) array } (* [ip_nparams] contains the number of parameters. *) @@ -99,28 +96,17 @@ type ml_ident = | Tmp of identifier (** We now store some typing information on constructors - and cases to avoid type-unsafe optimisations. - For cases, we also store the set of branches to merge - in a common pattern, either "_ -> c" or "x -> f x" + and cases to avoid type-unsafe optimisations. This will be + either the type of the applied constructor or the type + of the head of the match. *) -type constructor_info = { - c_kind : inductive_kind; - c_typs : ml_type list; -} - -type branch_same = - | BranchNone - | BranchFun of Intset.t - | BranchCst of Intset.t +(** Nota : the constructor [MLtuple] and the extension of [MLcase] + to general patterns have been proposed by P.N. Tollitte for + his Relation Extraction plugin. [MLtuple] is currently not + used by the main extraction, as well as deep patterns. *) -type match_info = { - m_kind : inductive_kind; - m_typs : ml_type list; - m_same : branch_same -} - -type ml_branch = global_reference * ml_ident list * ml_ast +type ml_branch = ml_ident list * ml_pattern * ml_ast and ml_ast = | MLrel of int @@ -128,24 +114,32 @@ and ml_ast = | MLlam of ml_ident * ml_ast | MLletin of ml_ident * ml_ast * ml_ast | MLglob of global_reference - | MLcons of constructor_info * global_reference * ml_ast list - | MLcase of match_info * ml_ast * ml_branch array + | MLcons of ml_type * global_reference * ml_ast list + | MLtuple of ml_ast list + | MLcase of ml_type * ml_ast * ml_branch array | MLfix of int * identifier array * ml_ast array | MLexn of string | MLdummy | MLaxiom | MLmagic of ml_ast +and ml_pattern = + | Pcons of global_reference * ml_pattern list + | Ptuple of ml_pattern list + | Prel of int (** Cf. the idents in the branch. [Prel 1] is the last one. *) + | Pwild + | Pusual of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **) + (*s ML declarations. *) type ml_decl = - | Dind of kernel_name * ml_ind + | Dind of mutual_inductive * ml_ind | Dtype of global_reference * identifier list * ml_type | Dterm of global_reference * ml_ast * ml_type | Dfix of global_reference array * ml_ast array * ml_type array type ml_spec = - | Sind of kernel_name * ml_ind + | Sind of mutual_inductive * ml_ind | Stype of global_reference * identifier list * ml_type option | Sval of global_reference * ml_type diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 3c7ee0f2..d0bf387a 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mlutil.ml 14786 2011-12-10 12:55:19Z letouzey $ i*) - (*i*) open Pp open Util @@ -56,18 +54,6 @@ let new_meta _ = incr meta_count; Tmeta {id = !meta_count; contents = None} -(*s Sustitution of [Tvar i] by [t] in a ML type. *) - -let type_subst i t0 t = - let rec subst t = match t with - | Tvar j when i = j -> t0 - | Tmeta {contents=None} -> t - | Tmeta {contents=Some u} -> subst u - | Tarr (a,b) -> Tarr (subst a, subst b) - | Tglob (r, l) -> Tglob (r, List.map subst l) - | a -> a - in subst t - (* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *) let type_subst_list l t = @@ -378,54 +364,61 @@ let ast_iter_rel f = | MLlam (_,a) -> iter (n+1) a | MLletin (_,a,b) -> iter n a; iter (n+1) b | MLcase (_,a,v) -> - iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v + iter n a; Array.iter (fun (l,_,t) -> iter (n + (List.length l)) t) v | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v | MLapp (a,l) -> iter n a; List.iter (iter n) l - | MLcons (_,_,l) -> List.iter (iter n) l + | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l | MLmagic a -> iter n a | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () in iter 0 (*s Map over asts. *) -let ast_map_case f (c,ids,a) = (c,ids,f a) +let ast_map_branch f (c,ids,a) = (c,ids,f a) + +(* Warning: in [ast_map] we assume that [f] does not change the type + of [MLcons] and of [MLcase] heads *) let ast_map f = function | MLlam (i,a) -> MLlam (i, f a) | MLletin (i,a,b) -> MLletin (i, f a, f b) - | MLcase (i,a,v) -> MLcase (i,f a, Array.map (ast_map_case f) v) + | MLcase (typ,a,v) -> MLcase (typ,f a, Array.map (ast_map_branch f) v) | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v) | MLapp (a,l) -> MLapp (f a, List.map f l) - | MLcons (i,c,l) -> MLcons (i,c, List.map f l) + | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l) + | MLtuple l -> MLtuple (List.map f l) | MLmagic a -> MLmagic (f a) | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a (*s Map over asts, with binding depth as parameter. *) -let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a) +let ast_map_lift_branch f n (ids,p,a) = (ids,p, f (n+(List.length ids)) a) + +(* Same warning as for [ast_map]... *) let ast_map_lift f n = function | MLlam (i,a) -> MLlam (i, f (n+1) a) | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b) - | MLcase (i,a,v) -> MLcase (i,f n a,Array.map (ast_map_lift_case f n) v) + | MLcase (typ,a,v) -> MLcase (typ,f n a,Array.map (ast_map_lift_branch f n) v) | MLfix (i,ids,v) -> let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v) | MLapp (a,l) -> MLapp (f n a, List.map (f n) l) - | MLcons (i,c,l) -> MLcons (i,c, List.map (f n) l) + | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l) + | MLtuple l -> MLtuple (List.map (f n) l) | MLmagic a -> MLmagic (f n a) | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a (*s Iter over asts. *) -let ast_iter_case f (c,ids,a) = f a +let ast_iter_branch f (c,ids,a) = f a let ast_iter f = function | MLlam (i,a) -> f a | MLletin (i,a,b) -> f a; f b - | MLcase (_,a,v) -> f a; Array.iter (ast_iter_case f) v + | MLcase (_,a,v) -> f a; Array.iter (ast_iter_branch f) v | MLfix (i,ids,v) -> Array.iter f v | MLapp (a,l) -> f a; List.iter f l - | MLcons (_,c,l) -> List.iter f l + | MLcons (_,_,l) | MLtuple l -> List.iter f l | MLmagic a -> f a | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> () @@ -446,15 +439,6 @@ let ast_occurs_itvl k k' t = ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false with Found -> true -(*s Number of occurences of [Rel k] (resp. [Rel 1]) in [t]. *) - -let nb_occur_k k t = - let cpt = ref 0 in - ast_iter_rel (fun i -> if i = k then incr cpt) t; - !cpt - -let nb_occur t = nb_occur_k 1 t - (* Number of occurences of [Rel 1] in [t], with special treatment of match: occurences in different branches aren't added, but we rather use max. *) @@ -464,13 +448,13 @@ let nb_occur_match = | MLcase(_,a,v) -> (nb k a) + Array.fold_left - (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v + (fun r (ids,_,a) -> max r (nb (k+(List.length ids)) a)) 0 v | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b) | MLfix (_,ids,v) -> let k = k+(Array.length ids) in Array.fold_left (fun r a -> r+(nb k a)) 0 v | MLlam (_,a) -> nb (k+1) a | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l - | MLcons (_,_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l + | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l | MLmagic a -> nb k a | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0 in nb 1 @@ -530,6 +514,39 @@ let gen_subst v d t = | a -> ast_map_lift subst n a in subst 0 t +(*S Operations concerning match patterns *) + +let is_basic_pattern = function + | Prel _ | Pwild -> true + | Pusual _ | Pcons _ | Ptuple _ -> false + +let has_deep_pattern br = + let deep = function + | Pcons (_,l) | Ptuple l -> not (List.for_all is_basic_pattern l) + | Pusual _ | Prel _ | Pwild -> false + in + array_exists (function (_,pat,_) -> deep pat) br + +let is_regular_match br = + if Array.length br = 0 then false (* empty match becomes MLexn *) + else + try + let get_r (ids,pat,c) = + match pat with + | Pusual r -> r + | Pcons (r,l) -> + if not (list_for_all_i (fun i -> (=) (Prel i)) 1 (List.rev l)) + then raise Impossible; + r + | _ -> raise Impossible + in + let ind = match get_r br.(0) with + | ConstructRef (ind,_) -> ind + | _ -> raise Impossible + in + array_for_all_i (fun i tr -> get_r tr = ConstructRef (ind,i+1)) 0 br + with Impossible -> false + (*S Operations concerning lambdas. *) (*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns @@ -577,7 +594,6 @@ let rec many_lams id a = function | 0 -> a | n -> many_lams id (MLlam (id,a)) (pred n) -let anonym_lams a n = many_lams anonymous a n let anonym_tmp_lams a n = many_lams (Tmp anonymous_name) a n let dummy_lams a n = many_lams Dummy a n @@ -679,26 +695,31 @@ let rec ast_glob_subst s t = match t with expansion of type definitions. *) -(*s [branch_as_function b typs (r,l,c)] tries to see branch [c] +(*s [branch_as_function b typ (l,p,c)] tries to see branch [c] as a function [f] applied to [MLcons(r,l)]. For that it transforms any [MLcons(r,l)] in [MLrel 1] and raises [Impossible] if any variable in [l] occurs outside such a [MLcons] *) -let branch_as_fun typs (r,l,c) = +let branch_as_fun typ (l,p,c) = let nargs = List.length l in + let cons = match p with + | Pusual r -> MLcons (typ, r, eta_args nargs) + | Pcons (r,pl) -> + let pat2rel = function Prel i -> MLrel i | _ -> raise Impossible in + MLcons (typ, r, List.map pat2rel pl) + | _ -> raise Impossible + in let rec genrec n = function | MLrel i as c -> let i' = i-n in if i'<1 then c else if i'>nargs then MLrel (i-nargs+1) else raise Impossible - | MLcons(i,r',args) when - r=r' && (test_eta_args_lift n nargs args) && typs = i.c_typs -> - MLrel (n+1) + | MLcons _ as cons' when cons' = ast_lift n cons -> MLrel (n+1) | a -> ast_map_lift genrec n a in genrec 0 c -(*s [branch_as_cst (r,l,c)] tries to see branch [c] as a constant +(*s [branch_as_cst (l,p,c)] tries to see branch [c] as a constant independent from the pattern [MLcons(r,l)]. For that is raises [Impossible] if any variable in [l] occurs in [c], and otherwise returns [c] lifted to appear like a function with one arg (for uniformity with [branch_as_fun]). @@ -706,7 +727,7 @@ let branch_as_fun typs (r,l,c) = empty, i.e. when [r] is a constant constructor *) -let branch_as_cst (_,l,c) = +let branch_as_cst (l,_,c) = let n = List.length l in if ast_occurs_itvl 1 n c then raise Impossible; ast_lift (1-n) c @@ -745,20 +766,27 @@ let census_add, census_max, census_clean = constant. *) -let factor_branches o typs br = - census_clean (); - for i = 0 to Array.length br - 1 do - if o.opt_case_idr then - (try census_add (branch_as_fun typs br.(i)) i with Impossible -> ()); - if o.opt_case_cst then - (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); - done; - let br_factor, br_set = census_max MLdummy in - census_clean (); - let n = Intset.cardinal br_set in - if n = 0 then None - else if Array.length br >= 2 && n < 2 then None - else Some (br_factor, br_set) +let is_opt_pat (_,p,_) = match p with + | Prel _ | Pwild -> true + | _ -> false + +let factor_branches o typ br = + if array_exists is_opt_pat br then None (* already optimized *) + else begin + census_clean (); + for i = 0 to Array.length br - 1 do + if o.opt_case_idr then + (try census_add (branch_as_fun typ br.(i)) i with Impossible -> ()); + if o.opt_case_cst then + (try census_add (branch_as_cst br.(i)) i with Impossible -> ()); + done; + let br_factor, br_set = census_max MLdummy in + census_clean (); + let n = Intset.cardinal br_set in + if n = 0 then None + else if Array.length br >= 2 && n < 2 then None + else Some (br_factor, br_set) + end (*s If all branches are functions, try to permut the case and the functions. *) @@ -781,14 +809,14 @@ let rec permut_case_fun br acc = let br = Array.copy br in let ids = ref [] in for i = 0 to Array.length br - 1 do - let (r,l,t) = br.(i) in + let (l,p,t) = br.(i) in let local_nb = nb_lams t in if local_nb < !nb then (* t = MLexn ... *) - br.(i) <- (r,l,remove_n_lams local_nb t) + br.(i) <- (l,p,remove_n_lams local_nb t) else begin let local_ids,t = collect_n_lams !nb t in ids := merge_ids !ids local_ids; - br.(i) <- (r,l,permut_rels !nb (List.length l) t) + br.(i) <- (l,p,permut_rels !nb (List.length l) t) end done; (!ids,br) @@ -796,32 +824,43 @@ let rec permut_case_fun br acc = (*S Generalized iota-reduction. *) -(* Definition of a generalized iota-redex: it's a [MLcase(e,_)] - with [(is_iota_gen e)=true]. Any generalized iota-redex is - transformed into beta-redexes. *) - -let rec is_iota_gen = function - | MLcons _ -> true - | MLcase(_,_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br - | _ -> false - -let constructor_index = function - | ConstructRef (_,j) -> pred j - | _ -> assert false - -let iota_gen br = +(* Definition of a generalized iota-redex: it's a [MLcase(e,br)] + where the head [e] is a [MLcons] or made of [MLcase]'s with + [MLcons] as leaf branches. + A generalized iota-redex is transformed into beta-redexes. *) + +(* In [iota_red], we try to simplify a [MLcase(_,MLcons(typ,r,a),br)]. + Argument [i] is the branch we consider, we should lift what + comes from [br] by [lift] *) + +let rec iota_red i lift br ((typ,r,a) as cons) = + if i >= Array.length br then raise Impossible; + let (ids,p,c) = br.(i) in + match p with + | Pusual r' | Pcons (r',_) when r'<>r -> iota_red (i+1) lift br cons + | Pusual r' -> + let c = named_lams (List.rev ids) c in + let c = ast_lift lift c + in MLapp (c,a) + | Prel 1 when List.length ids = 1 -> + let c = MLlam (List.hd ids, c) in + let c = ast_lift lift c + in MLapp(c,[MLcons(typ,r,a)]) + | Pwild when ids = [] -> ast_lift lift c + | _ -> raise Impossible (* TODO: handle some more cases *) + +(* [iota_gen] is an extension of [iota_red] where we allow to + traverse matches in the head of the first match *) + +let iota_gen br hd = let rec iota k = function - | MLcons (i,r,a) -> - let (_,ids,c) = br.(constructor_index r) in - let c = List.fold_right (fun id t -> MLlam (id,t)) ids c in - let c = ast_lift k c in - MLapp (c,a) - | MLcase(i,e,br') -> + | MLcons (typ,r,a) -> iota_red 0 k br (typ,r,a) + | MLcase(typ,e,br') -> let new_br = - Array.map (fun (n,i,c)->(n,i,iota (k+(List.length i)) c)) br' - in MLcase(i,e, new_br) - | _ -> assert false - in iota 0 + Array.map (fun (i,p,c)->(i,p,iota (k+(List.length i)) c)) br' + in MLcase(typ,e,new_br) + | _ -> raise Impossible + in iota 0 hd let is_atomic = function | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true @@ -840,7 +879,7 @@ let is_program_branch = function (try ignore (int_of_string (String.sub s n (String.length s - n))); String.sub s 0 n = br - with _ -> false) + with e when Errors.noncritical e -> false) | Tmp _ | Dummy -> false let expand_linear_let o id e = @@ -853,9 +892,9 @@ let expand_linear_let o id e = let rec simpl o = function | MLapp (f, []) -> simpl o f | MLapp (f, a) -> simpl_app o (List.map (simpl o) a) (simpl o f) - | MLcase (i,e,br) -> - let br = Array.map (fun (n,l,t) -> (n,l,simpl o t)) br in - simpl_case o i br (simpl o e) + | MLcase (typ,e,br) -> + let br = Array.map (fun (l,p,t) -> (l,p,simpl o t)) br in + simpl_case o typ br (simpl o e) | MLletin(Dummy,_,e) -> simpl o (ast_pop e) | MLletin(id,c,e) -> let e = simpl o e in @@ -891,40 +930,50 @@ and simpl_app o a = function | MLletin (id,e1,e2) when o.opt_let_app -> (* Application of a letin: we push arguments inside *) MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a))) - | MLcase (i,e,br) when o.opt_case_app -> + | MLcase (typ,e,br) when o.opt_case_app -> (* Application of a case: we push arguments inside *) let br' = Array.map - (fun (n,l,t) -> + (fun (l,p,t) -> let k = List.length l in let a' = List.map (ast_lift k) a in - (n, l, simpl o (MLapp (t,a')))) br - in simpl o (MLcase (i,e,br')) + (l, p, simpl o (MLapp (t,a')))) br + in simpl o (MLcase (typ,e,br')) | (MLdummy | MLexn _) as e -> e (* We just discard arguments in those cases. *) | f -> MLapp (f,a) (* Invariant : all empty matches should now be [MLexn] *) -and simpl_case o i br e = - if o.opt_case_iot && (is_iota_gen e) then (* Generalized iota-redex *) +and simpl_case o typ br e = + try + (* Generalized iota-redex *) + if not o.opt_case_iot then raise Impossible; simpl o (iota_gen br e) - else + with Impossible -> (* Swap the case and the lam if possible *) let ids,br = if o.opt_case_fun then permut_case_fun br [] else [],br in let n = List.length ids in if n <> 0 then - simpl o (named_lams ids (MLcase (i,ast_lift n e, br))) + simpl o (named_lams ids (MLcase (typ, ast_lift n e, br))) else (* Can we merge several branches as the same constant or function ? *) - match factor_branches o i.m_typs br with + if lang() = Scheme || is_custom_match br + then MLcase (typ, e, br) + else match factor_branches o typ br with | Some (f,ints) when Intset.cardinal ints = Array.length br -> - (* If all branches have been factorized, we remove the match *) - simpl o (MLletin (Tmp anonymous_name, e, f)) + (* If all branches have been factorized, we remove the match *) + simpl o (MLletin (Tmp anonymous_name, e, f)) | Some (f,ints) -> - let same = if ast_occurs 1 f then BranchFun ints else BranchCst ints - in MLcase ({i with m_same=same}, e, br) - | None -> MLcase (i, e, br) + let last_br = + if ast_occurs 1 f then ([Tmp anonymous_name], Prel 1, f) + else ([], Pwild, ast_pop f) + in + let brl = Array.to_list br in + let brl_opt = list_filter_i (fun i _ -> not (Intset.mem i ints)) brl in + let brl_opt = brl_opt @ [last_br] in + MLcase (typ, e, Array.of_list brl_opt) + | None -> MLcase (typ, e, br) (*S Local prop elimination. *) (* We try to eliminate as many [prop] as possible inside an [ml_ast]. *) @@ -1149,28 +1198,24 @@ let optimize_fix a = (* Utility functions used in the decision of inlining. *) +let ml_size_branch size pv = Array.fold_left (fun a (_,_,t) -> a + size t) 0 pv + let rec ml_size = function | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l | MLlam(_,t) -> 1 + ml_size t - | MLcons(_,_,l) -> ml_size_list l - | MLcase(_,t,pv) -> - 1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0) + | MLcons(_,_,l) | MLtuple l -> ml_size_list l + | MLcase(_,t,pv) -> 1 + ml_size t + ml_size_branch ml_size pv | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t - | _ -> 0 + | MLglob _ | MLrel _ | MLexn _ | MLdummy | MLaxiom -> 0 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l -and ml_size_array l = Array.fold_left (fun a t -> a + ml_size t) 0 l +and ml_size_array a = Array.fold_left (fun a t -> a + ml_size t) 0 a let is_fix = function MLfix _ -> true | _ -> false -let rec is_constr = function - | MLcons _ -> true - | MLlam(_,t) -> is_constr t - | _ -> false - (*s Strictness *) (* A variable is strict if the evaluation of the whole term implies @@ -1219,7 +1264,7 @@ let rec non_stricts add cand = function (* so we make an union (in fact a merge). *) let cand = non_stricts false cand t in Array.fold_left - (fun c (_,i,t)-> + (fun c (i,_,t)-> let n = List.length i in let cand = lift n cand in let cand = pop n (non_stricts add cand t) in @@ -1265,12 +1310,14 @@ let inline_test r t = if not (auto_inline ()) then false else let c = match r with ConstRef c -> c | _ -> assert false in - let body = try (Global.lookup_constant c).const_body with _ -> None in - if body = None then false - else - let t1 = eta_red t in - let t2 = snd (collect_lams t1) in - not (is_fix t2) && ml_size t < 12 && is_not_strict t + let has_body = + try constant_has_body (Global.lookup_constant c) + with e when Errors.noncritical e -> false + in + has_body && + (let t1 = eta_red t in + let t2 = snd (collect_lams t1) in + not (is_fix t2) && ml_size t < 12 && is_not_strict t) let con_of_string s = let null = empty_dirpath in diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli index 54a1baaa..e10b6070 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mlutil.mli 14786 2011-12-10 12:55:19Z letouzey $ i*) - open Util open Names open Term @@ -20,7 +18,6 @@ open Table val reset_meta_count : unit -> unit val new_meta : 'a -> ml_type -val type_subst : int -> ml_type -> ml_type -> ml_type val type_subst_list : ml_type list -> ml_type -> ml_type val type_subst_vect : ml_type array -> ml_type -> ml_type @@ -118,9 +115,11 @@ val normalize : ml_ast -> ml_ast val optimize_fix : ml_ast -> ml_ast val inline : global_reference -> ml_ast -> bool +val is_basic_pattern : ml_pattern -> bool +val has_deep_pattern : ml_branch array -> bool +val is_regular_match : ml_branch array -> bool + exception Impossible -val branch_as_fun : ml_type list -> ml_branch -> ml_ast -val branch_as_cst : ml_branch -> ml_ast (* Classification of signatures *) diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index ffa38def..bd997d2d 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Names open Declarations open Environ @@ -28,9 +26,9 @@ let rec msid_of_mt = function (*s Apply some functions upon all [ml_decl] and [ml_spec] found in a [ml_structure]. *) -let struct_iter do_decl do_spec s = +let se_iter do_decl do_spec do_mp = let rec mt_iter = function - | MTident _ -> () + | MTident mp -> do_mp mp | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' | MTwith (mt,ML_With_type(idl,l,t))-> let mp_mt = msid_of_mt mt in @@ -40,7 +38,12 @@ let struct_iter do_decl do_spec s = in let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in mt_iter mt; do_decl (Dtype(r,l,t)) - | MTwith (mt,_)->mt_iter mt + | MTwith (mt,ML_With_module(idl,mp))-> + let mp_mt = msid_of_mt mt in + let mp_w = + List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl + in + mt_iter mt; do_mp mp_w; do_mp mp | MTsig (_, sign) -> List.iter spec_iter sign and spec_iter = function | (_,Spec s) -> do_spec s @@ -53,12 +56,16 @@ let struct_iter do_decl do_spec s = me_iter m.ml_mod_expr; mt_iter m.ml_mod_type | (_,SEmodtype m) -> mt_iter m and me_iter = function - | MEident _ -> () + | MEident mp -> do_mp mp | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt | MEapply (me,me') -> me_iter me; me_iter me' | MEstruct (msid, sel) -> List.iter se_iter sel in - List.iter (function (_,sel) -> List.iter se_iter sel) s + se_iter + +let struct_iter do_decl do_spec do_mp s = + List.iter + (function (_,sel) -> List.iter (se_iter do_decl do_spec do_mp) sel) s (*s Apply some fonctions upon all references in [ml_type], [ml_ast], [ml_decl], [ml_spec] and [ml_structure]. *) @@ -76,18 +83,26 @@ let type_iter_references do_type t = | _ -> () in iter t +let patt_iter_references do_cons p = + let rec iter = function + | Pcons (r,l) -> do_cons r; List.iter iter l + | Pusual r -> do_cons r + | Ptuple l -> List.iter iter l + | Prel _ | Pwild -> () + in iter p + let ast_iter_references do_term do_cons do_type a = let rec iter a = ast_iter iter a; match a with | MLglob r -> do_term r - | MLcons (i,r,_) -> - if lang () = Ocaml then record_iter_references do_term i.c_kind; - do_cons r - | MLcase (i,_,v) -> - if lang () = Ocaml then record_iter_references do_term i.m_kind; - Array.iter (fun (r,_,_) -> do_cons r) v - | _ -> () + | MLcons (_,r,_) -> do_cons r + | MLcase (ty,_,v) -> + type_iter_references do_type ty; + Array.iter (fun (_,p,_) -> patt_iter_references do_cons p) v + + | MLrel _ | MLlam _ | MLapp _ | MLletin _ | MLtuple _ | MLfix _ | MLexn _ + | MLdummy | MLaxiom | MLmagic _ -> () in iter a let ind_iter_references do_term do_cons do_type kn ind = @@ -108,15 +123,14 @@ let decl_iter_references do_term do_cons do_type = let type_iter = type_iter_references do_type and ast_iter = ast_iter_references do_term do_cons do_type in function - | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type - (mind_of_kn kn) ind + | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind | Dtype (r,_,t) -> do_type r; type_iter t | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t | Dfix(rv,c,t) -> Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t let spec_iter_references do_term do_cons do_type = function - | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type (mind_of_kn kn) ind + | Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind | Stype (r,_,ot) -> do_type r; Option.iter (type_iter_references do_type) ot | Sval (r,t) -> do_term r; type_iter_references do_type t @@ -133,7 +147,7 @@ let decl_ast_search f = function | _ -> () let struct_ast_search f s = - try struct_iter (decl_ast_search f) (fun _ -> ()) s; false + try struct_iter (decl_ast_search f) (fun _ -> ()) (fun _ -> ()) s; false with Found -> true let rec type_search f = function @@ -157,7 +171,9 @@ let spec_type_search f = function | Sval (_,u) -> type_search f u let struct_type_search f s = - try struct_iter (decl_type_search f) (spec_type_search f) s; false + try + struct_iter (decl_type_search f) (spec_type_search f) (fun _ -> ()) s; + false with Found -> true @@ -186,6 +202,15 @@ let signature_of_structure s = (*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *) +let is_modular = function + | SEdecl _ -> false + | SEmodule _ | SEmodtype _ -> true + +let rec search_structure l m = function + | [] -> raise Not_found + | (lab,d)::_ when lab=l && is_modular d = m -> d + | _::fields -> search_structure l m fields + let get_decl_in_structure r struc = try let base_mp,ll = labels_of_ref r in @@ -194,7 +219,7 @@ let get_decl_in_structure r struc = let rec go ll sel = match ll with | [] -> assert false | l :: ll -> - match List.assoc l sel with + match search_structure l (ll<>[]) sel with | SEdecl d -> d | SEmodtype m -> assert false | SEmodule m -> @@ -230,34 +255,32 @@ let dfix_to_mlfix rv av i = let c = Array.map (subst 0) av in MLfix(i, ids, c) +(* [optim_se] applies the [normalize] function everywhere and does the + inlining of code. The inlined functions are kept for the moment in + order to preserve the global interface, later [depcheck_se] will get + rid of them if possible *) + let rec optim_se top to_appear s = function | [] -> [] | (l,SEdecl (Dterm (r,a,t))) :: lse -> let a = normalize (ast_glob_subst !s a) in let i = inline r a in if i then s := Refmap'.add r a !s; - if top && i && not (modular ()) && not (List.mem r to_appear) - then optim_se top to_appear s lse - else - let d = match optimize_fix a with - | MLfix (0, _, [|c|]) -> - Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) - | a -> Dterm (r, a, t) - in (l,SEdecl d) :: (optim_se top to_appear s lse) + let d = match optimize_fix a with + | MLfix (0, _, [|c|]) -> + Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|]) + | a -> Dterm (r, a, t) + in + (l,SEdecl d) :: (optim_se top to_appear s lse) | (l,SEdecl (Dfix (rv,av,tv))) :: lse -> let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in - let all = ref true in (* This fake body ensures that no fixpoint will be auto-inlined. *) let fake_body = MLfix (0,[||],[||]) in for i = 0 to Array.length rv - 1 do if inline rv.(i) fake_body then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s - else all := false done; - if !all && top && not (modular ()) - && (array_for_all (fun r -> not (List.mem r to_appear)) rv) - then optim_se top to_appear s lse - else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) + (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse) | (l,SEmodule m) :: lse -> let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr} in (l,SEmodule m) :: (optim_se top to_appear s lse) @@ -271,7 +294,8 @@ and optim_me to_appear s = function | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me to_appear s me) (* After these optimisations, some dependencies may not be needed anymore. - For monolithic extraction, we recompute a minimal set of dependencies. *) + For non-library extraction, we recompute a minimal set of dependencies + for first-level definitions (no module pruning yet). *) exception NoDepCheck @@ -281,15 +305,19 @@ let base_r = function | ConstructRef ((kn,_),_) -> IndRef (kn,0) | _ -> assert false -let reset_needed, add_needed, found_needed, is_needed = - let needed = ref Refset'.empty in - ((fun l -> needed := Refset'.empty), +let reset_needed, add_needed, add_needed_mp, found_needed, is_needed = + let needed = ref Refset'.empty + and needed_mps = ref MPset.empty in + ((fun l -> needed := Refset'.empty; needed_mps := MPset.empty), (fun r -> needed := Refset'.add (base_r r) !needed), + (fun mp -> needed_mps := MPset.add mp !needed_mps), (fun r -> needed := Refset'.remove (base_r r) !needed), - (fun r -> Refset'.mem (base_r r) !needed)) + (fun r -> + let r = base_r r in + Refset'.mem r !needed || MPset.mem (modpath_of_r r) !needed_mps)) let declared_refs = function - | Dind (kn,_) -> [IndRef (mind_of_kn kn,0)] + | Dind (kn,_) -> [IndRef (kn,0)] | Dtype (r,_,_) -> [r] | Dterm (r,_,_) -> [r] | Dfix (rv,_,_) -> Array.to_list rv @@ -300,7 +328,7 @@ let declared_refs = function let compute_deps_decl = function | Dind (kn,ind) -> (* Todo Later : avoid dependencies when Extract Inductive *) - ind_iter_references add_needed add_needed add_needed (mind_of_kn kn) ind + ind_iter_references add_needed add_needed add_needed kn ind | Dtype (r,ids,t) -> if not (is_custom r) then type_iter_references add_needed t | Dterm (r,u,t) -> @@ -310,6 +338,15 @@ let compute_deps_decl = function | Dfix _ as d -> decl_iter_references add_needed add_needed add_needed d +let compute_deps_spec = function + | Sind (kn,ind) -> + (* Todo Later : avoid dependencies when Extract Inductive *) + ind_iter_references add_needed add_needed add_needed kn ind + | Stype (r,ids,t) -> + if not (is_custom r) then Option.iter (type_iter_references add_needed) t + | Sval (r,t) -> + type_iter_references add_needed t + let rec depcheck_se = function | [] -> [] | ((l,SEdecl d) as t) :: se -> @@ -317,7 +354,9 @@ let rec depcheck_se = function let refs = declared_refs d in let refs' = List.filter is_needed refs in if refs' = [] then - (List.iter remove_info_axiom refs; se') + (List.iter remove_info_axiom refs; + List.iter remove_opaque refs; + se') else begin List.iter found_needed refs'; (* Hack to avoid extracting unused part of a Dfix *) @@ -327,14 +366,17 @@ let rec depcheck_se = function ((l,SEdecl (Dfix (rv,trms',tys))) :: se') | _ -> (compute_deps_decl d; t::se') end - | _ -> raise NoDepCheck + | t :: se -> + let se' = depcheck_se se in + se_iter compute_deps_decl compute_deps_spec add_needed_mp t; + t :: se' let rec depcheck_struct = function | [] -> [] | (mp,lse)::struc -> let struc' = depcheck_struct struc in let lse' = depcheck_se lse in - (mp,lse')::struc' + if lse' = [] then struc' else (mp,lse')::struc' let check_implicits = function | MLexn s -> @@ -350,13 +392,15 @@ let check_implicits = function let optimize_struct to_appear struc = let subst = ref (Refmap'.empty : ml_ast Refmap'.t) in let opt_struc = - List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc + List.map (fun (mp,lse) -> (mp, optim_se true (fst to_appear) subst lse)) + struc in - let opt_struc = List.filter (fun (_,lse) -> lse<>[]) opt_struc in ignore (struct_ast_search check_implicits opt_struc); - try - if modular () then raise NoDepCheck; + if library () then + List.filter (fun (_,lse) -> lse<>[]) opt_struc + else begin reset_needed (); - List.iter add_needed to_appear; + List.iter add_needed (fst to_appear); + List.iter add_needed_mp (snd to_appear); depcheck_struct opt_struc - with NoDepCheck -> opt_struc + end diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli index 26d07872..fb8d5e1b 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modutil.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Names open Declarations open Environ @@ -38,4 +36,5 @@ val get_decl_in_structure : global_reference -> ml_structure -> ml_decl optimizations. The first argument is the list of objects we want to appear. *) -val optimize_struct : global_reference list -> ml_structure -> ml_structure +val optimize_struct : global_reference list * module_path list -> + ml_structure -> ml_structure diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index c07a1758..4e8d8145 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ocaml.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*s Production of Ocaml syntax. *) open Pp @@ -31,22 +29,6 @@ let pp_tvar id = then str ("'"^s) else str ("' "^s) -let pp_tuple_light f = function - | [] -> mt () - | [x] -> f true x - | l -> - pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l) - -let pp_tuple f = function - | [] -> mt () - | [x] -> f x - | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l) - -let pp_boxed_tuple f = function - | [] -> mt () - | [x] -> f x - | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l)) - let pp_abst = function | [] -> mt () | l -> @@ -59,6 +41,10 @@ let pp_parameters l = let pp_string_parameters l = (pp_boxed_tuple str l ++ space_if (l<>[])) +let pp_letin pat def body = + let fstline = str "let " ++ pat ++ str " =" ++ spc () ++ def in + hv 0 (hv 0 (hov 2 fstline ++ spc () ++ str "in") ++ spc () ++ hov 0 body) + (*s Ocaml renaming issues. *) let keywords = @@ -133,11 +119,13 @@ let rec pp_type par vl t = let rec pp_rec par = function | Tmeta _ | Tvar' _ | Taxiom -> assert false | Tvar i -> (try pp_tvar (List.nth vl (pred i)) - with _ -> (str "'a" ++ int i)) + with e when Errors.noncritical e -> + (str "'a" ++ int i)) | Tglob (r,[a1;a2]) when is_infix r -> pp_par par (pp_rec true a1 ++ str (get_infix r) ++ pp_rec true a2) | Tglob (r,[]) -> pp_global Type r - | Tglob (IndRef(kn,0),l) when kn = mk_ind "Coq.Init.Specif" "sig" -> + | Tglob (IndRef(kn,0),l) + when not (keep_singleton ()) && kn = mk_ind "Coq.Init.Specif" "sig" -> pp_tuple_light pp_rec l | Tglob (r,l) -> pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r @@ -154,10 +142,19 @@ let rec pp_type par vl t = de Bruijn variables. [args] is the list of collected arguments (already pretty-printed). *) +let is_bool_patt p s = + try + let r = match p with + | Pusual r -> r + | Pcons (r,[]) -> r + | _ -> raise Not_found + in + find_custom r = s + with Not_found -> false + + let is_ifthenelse = function - | [|(r1,[],_);(r2,[],_)|] -> - (try (find_custom r1 = "true") && (find_custom r2 = "false") - with Not_found -> false) + | [|([],p1,_);([],p2,_)|] -> is_bool_patt p1 "true" && is_bool_patt p2 "false" | _ -> false let expr_needs_par = function @@ -167,8 +164,8 @@ let expr_needs_par = function | _ -> false let rec pp_expr par env args = - let par' = args <> [] || par - and apply st = pp_apply st par args in + let apply st = pp_apply st par args + and apply2 st = pp_apply2 st par args in function | MLrel n -> let id = get_db_name n env in apply (pr_id id) @@ -179,109 +176,23 @@ let rec pp_expr par env args = let fl,a' = collect_lams a in let fl = List.map id_of_mlid fl in let fl,env' = push_vars fl env in - let st = (pp_abst (List.rev fl) ++ pp_expr false env' [] a') in - apply (pp_par par' st) + let st = pp_abst (List.rev fl) ++ pp_expr false env' [] a' in + apply2 st | MLletin (id,a1,a2) -> let i,env' = push_vars [id_of_mlid id] env in let pp_id = pr_id (List.hd i) and pp_a1 = pp_expr false env [] a1 and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in - hv 0 - (apply - (pp_par par' - (hv 0 - (hov 2 - (str "let " ++ pp_id ++ str " =" ++ spc () ++ pp_a1) ++ - spc () ++ str "in") ++ - spc () ++ hov 0 pp_a2))) + hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2)) | MLglob r -> (try let args = list_skipn (projection_arity r) args in let record = List.hd args in pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) - with _ -> apply (pp_global Term r)) - | MLcons _ as c when is_native_char c -> assert (args=[]); pp_native_char c - | MLcons ({c_kind = Coinductive},r,[]) -> - assert (args=[]); - pp_par par (str "lazy " ++ pp_global Cons r) - | MLcons ({c_kind = Coinductive},r,args') -> - assert (args=[]); - let tuple = pp_tuple (pp_expr true env []) args' in - pp_par par (str "lazy (" ++ pp_global Cons r ++ spc() ++ tuple ++str ")") - | MLcons (_,r,[]) -> - assert (args=[]); - pp_global Cons r - | MLcons ({c_kind = Record fields}, r, args') -> - assert (args=[]); - pp_record_pat (pp_fields r fields, List.map (pp_expr true env []) args') - | MLcons (_,r,[arg1;arg2]) when is_infix r -> - assert (args=[]); - pp_par par - ((pp_expr true env [] arg1) ++ str (get_infix r) ++ - (pp_expr true env [] arg2)) - | MLcons (_,r,args') -> - assert (args=[]); - let tuple = pp_tuple (pp_expr true env []) args' in - if str_global Cons r = "" (* hack Extract Inductive prod *) - then tuple - else pp_par par (pp_global Cons r ++ spc () ++ tuple) - | MLcase (_, t, pv) when is_custom_match pv -> - let mkfun (_,ids,e) = - if ids <> [] then named_lams (List.rev ids) e - else dummy_lams (ast_lift 1 e) 1 - in - apply - (pp_par par' - (hov 2 - (str (find_custom_match pv) ++ fnl () ++ - prvect (fun tr -> pp_expr true env [] (mkfun tr) ++ fnl ()) pv - ++ pp_expr true env [] t))) - | MLcase (info, t, pv) -> - let expr = if info.m_kind = Coinductive then - (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) - else - (pp_expr false env [] t) - in - (try - (* First, can this match be printed as a mere record projection ? *) - let fields = - match info.m_kind with Record f -> f | _ -> raise Impossible - in - let (r, ids, c) = pv.(0) in - let n = List.length ids in - let free_of_patvar a = not (List.exists (ast_occurs_itvl 1 n) a) in - let proj_hd i = - pp_expr true env [] t ++ str "." ++ pp_field r fields i - in - match c with - | MLrel i when i <= n -> apply (pp_par par' (proj_hd (n-i))) - | MLapp (MLrel i, a) when (i <= n) && (free_of_patvar a) -> - let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in - (pp_apply (proj_hd (n-i)) - par ((List.map (pp_expr true env' []) a) @ args)) - | _ -> raise Impossible - with Impossible -> - (* Second, can this match be printed as a let-in ? *) - if Array.length pv = 1 then - let s1,s2 = pp_one_pat env info pv.(0) in - apply - (hv 0 - (pp_par par' - (hv 0 - (hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr) - ++ spc () ++ str "in") ++ - spc () ++ hov 0 s2))) - else - (* Otherwise, standard match *) - apply - (pp_par par' - (try pp_ifthenelse par' env expr pv - with Not_found -> - v 0 (str "match " ++ expr ++ str " with" ++ fnl () ++ - pp_pat env info pv)))) + with e when Errors.noncritical e -> apply (pp_global Term r)) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in - pp_fix par env' i (Array.of_list (List.rev ids'),defs) args + pp_fix par env' i (Array.of_list (List.rev ids'),defs) args | MLexn s -> (* An [MLexn] may be applied, but I don't really care. *) pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)")) @@ -291,7 +202,96 @@ let rec pp_expr par env args = pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args) | MLaxiom -> pp_par par (str "failwith \"AXIOM TO BE REALIZED\"") - + | MLcons (_,r,a) as c -> + assert (args=[]); + begin match a with + | _ when is_native_char c -> pp_native_char c + | [a1;a2] when is_infix r -> + let pp = pp_expr true env [] in + pp_par par (pp a1 ++ str (get_infix r) ++ pp a2) + | _ when is_coinductive r -> + let ne = (a<>[]) in + let tuple = space_if ne ++ pp_tuple (pp_expr true env []) a in + pp_par par (str "lazy " ++ pp_par ne (pp_global Cons r ++ tuple)) + | [] -> pp_global Cons r + | _ -> + let fds = get_record_fields r in + if fds <> [] then + pp_record_pat (pp_fields r fds, List.map (pp_expr true env []) a) + else + let tuple = pp_tuple (pp_expr true env []) a in + if str_global Cons r = "" (* hack Extract Inductive prod *) + then tuple + else pp_par par (pp_global Cons r ++ spc () ++ tuple) + end + | MLtuple l -> + assert (args = []); + pp_boxed_tuple (pp_expr true env []) l + | MLcase (_, t, pv) when is_custom_match pv -> + if not (is_regular_match pv) then + error "Cannot mix yet user-given match and general patterns."; + let mkfun (ids,_,e) = + if ids <> [] then named_lams (List.rev ids) e + else dummy_lams (ast_lift 1 e) 1 + in + let pp_branch tr = pp_expr true env [] (mkfun tr) ++ fnl () in + let inner = + str (find_custom_match pv) ++ fnl () ++ + prvect pp_branch pv ++ + pp_expr true env [] t + in + apply2 (hov 2 inner) + | MLcase (typ, t, pv) -> + let head = + if not (is_coinductive_type typ) then pp_expr false env [] t + else (str "Lazy.force" ++ spc () ++ pp_expr true env [] t) + in + (* First, can this match be printed as a mere record projection ? *) + (try pp_record_proj par env typ t pv args + with Impossible -> + (* Second, can this match be printed as a let-in ? *) + if Array.length pv = 1 then + let s1,s2 = pp_one_pat env pv.(0) in + hv 0 (apply2 (pp_letin s1 head s2)) + else + (* Third, can this match be printed as [if ... then ... else] ? *) + (try apply2 (pp_ifthenelse env head pv) + with Not_found -> + (* Otherwise, standard match *) + apply2 + (v 0 (str "match " ++ head ++ str " with" ++ fnl () ++ + pp_pat env pv)))) + +and pp_record_proj par env typ t pv args = + (* Can a match be printed as a mere record projection ? *) + let fields = record_fields_of_type typ in + if fields = [] then raise Impossible; + if Array.length pv <> 1 then raise Impossible; + if has_deep_pattern pv then raise Impossible; + let (ids,pat,body) = pv.(0) in + let n = List.length ids in + let no_patvar a = not (List.exists (ast_occurs_itvl 1 n) a) in + let rel_i,a = match body with + | MLrel i when i <= n -> i,[] + | MLapp(MLrel i, a) when i<=n && no_patvar a -> i,a + | _ -> raise Impossible + in + let rec lookup_rel i idx = function + | Prel j :: l -> if i = j then idx else lookup_rel i (idx+1) l + | Pwild :: l -> lookup_rel i (idx+1) l + | _ -> raise Impossible + in + let r,idx = match pat with + | Pusual r -> r, n-rel_i + | Pcons (r,l) -> r, lookup_rel rel_i 0 l + | _ -> raise Impossible + in + if is_infix r then raise Impossible; + let env' = snd (push_vars (List.rev_map id_of_mlid ids) env) in + let pp_args = (List.map (pp_expr true env' []) a) @ args in + let pp_head = pp_expr true env [] t ++ str "." ++ pp_field r fields idx + in + pp_apply pp_head par pp_args and pp_record_pat (fields, args) = str "{ " ++ @@ -300,9 +300,27 @@ and pp_record_pat (fields, args) = (List.combine fields args) ++ str " }" -and pp_ifthenelse par env expr pv = match pv with - | [|(tru,[],the);(fal,[],els)|] when - (find_custom tru = "true") && (find_custom fal = "false") +and pp_cons_pat r ppl = + if is_infix r && List.length ppl = 2 then + List.hd ppl ++ str (get_infix r) ++ List.hd (List.tl ppl) + else + let fields = get_record_fields r in + if fields <> [] then pp_record_pat (pp_fields r fields, ppl) + else if str_global Cons r = "" then + pp_boxed_tuple identity ppl (* Hack Extract Inductive prod *) + else + pp_global Cons r ++ space_if (ppl<>[]) ++ pp_boxed_tuple identity ppl + +and pp_gen_pat ids env = function + | Pcons (r, l) -> pp_cons_pat r (List.map (pp_gen_pat ids env) l) + | Pusual r -> pp_cons_pat r (List.map pr_id ids) + | Ptuple l -> pp_boxed_tuple (pp_gen_pat ids env) l + | Pwild -> str "_" + | Prel n -> pr_id (get_db_name n env) + +and pp_ifthenelse env expr pv = match pv with + | [|([],tru,the);([],fal,els)|] when + (is_bool_patt tru "true") && (is_bool_patt fal "false") -> hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++ hov 2 (str "then " ++ @@ -311,66 +329,34 @@ and pp_ifthenelse par env expr pv = match pv with hov 2 (pp_expr (expr_needs_par els) env [] els))) | _ -> raise Not_found -and pp_one_pat env info (r,ids,t) = - let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in - let expr = pp_expr (expr_needs_par t) env' [] t in - let patt = match info.m_kind with - | Record fields -> - pp_record_pat (pp_fields r fields, List.rev_map pr_id ids) - | _ -> match List.rev ids with - | [i1;i2] when is_infix r -> pr_id i1 ++ str (get_infix r) ++ pr_id i2 - | [] -> pp_global Cons r - | ids -> - (* hack Extract Inductive prod *) - (if str_global Cons r = "" then mt () else pp_global Cons r ++ spc ()) - ++ pp_boxed_tuple pr_id ids - in - patt, expr - -and pp_pat env info pv = - let factor_br, factor_set = try match info.m_same with - | BranchFun ints -> - let i = Intset.choose ints in - branch_as_fun info.m_typs pv.(i), ints - | BranchCst ints -> - let i = Intset.choose ints in - ast_pop (branch_as_cst pv.(i)), ints - | BranchNone -> MLdummy, Intset.empty - with _ -> MLdummy, Intset.empty - in - let last = Array.length pv - 1 in +and pp_one_pat env (ids,p,t) = + let ids',env' = push_vars (List.rev_map id_of_mlid ids) env in + pp_gen_pat (List.rev ids') env' p, + pp_expr (expr_needs_par t) env' [] t + +and pp_pat env pv = prvecti - (fun i x -> if Intset.mem i factor_set then mt () else - let s1,s2 = pp_one_pat env info x in + (fun i x -> + let s1,s2 = pp_one_pat env x in hv 2 (hov 4 (str "| " ++ s1 ++ str " ->") ++ spc () ++ hov 2 s2) ++ - if i = last && Intset.is_empty factor_set then mt () else fnl ()) + if i = Array.length pv - 1 then mt () else fnl ()) pv - ++ - if Intset.is_empty factor_set then mt () else - let par = expr_needs_par factor_br in - match info.m_same with - | BranchFun _ -> - let ids, env' = push_vars [anonymous_name] env in - hv 2 (str "| " ++ pr_id (List.hd ids) ++ str " ->" ++ spc () ++ - hov 2 (pp_expr par env' [] factor_br)) - | BranchCst _ -> - hv 2 (str "| _ ->" ++ spc () ++ hov 2 (pp_expr par env [] factor_br)) - | BranchNone -> mt () and pp_function env t = let bl,t' = collect_lams t in let bl,env' = push_vars (List.map id_of_mlid bl) env in match t' with - | MLcase(i,MLrel 1,pv) when - i.m_kind = Standard && not (is_custom_match pv) -> - if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then + | MLcase(Tglob(r,_),MLrel 1,pv) when + not (is_coinductive r) && get_record_fields r = [] && + not (is_custom_match pv) -> + if not (ast_occurs 1 (MLcase(Tunknown,MLdummy,pv))) then pr_binding (List.rev (List.tl bl)) ++ str " = function" ++ fnl () ++ - v 0 (pp_pat env' i pv) + v 0 (pp_pat env' pv) else pr_binding (List.rev bl) ++ str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++ - v 0 (pp_pat env' i pv) + v 0 (pp_pat env' pv) | _ -> pr_binding (List.rev bl) ++ str " =" ++ fnl () ++ str " " ++ @@ -451,7 +437,7 @@ let pp_logical_ind packet = fnl () let pp_singleton kn packet = - let name = pp_global Type (IndRef (mind_of_kn kn,0)) in + let name = pp_global Type (IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ @@ -459,7 +445,7 @@ let pp_singleton kn packet = pr_id packet.ip_consnames.(0))) let pp_record kn fields ip_equiv packet = - let ind = IndRef (mind_of_kn kn,0) in + let ind = IndRef (kn,0) in let name = pp_global Type ind in let fieldnames = pp_fields ind fields in let l = List.combine fieldnames packet.ip_types.(0) in @@ -482,20 +468,20 @@ let pp_ind co kn ind = let init= ref (str "type ") in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else - pp_global Type (IndRef (mind_of_kn kn,i))) + pp_global Type (IndRef (kn,i))) ind.ind_packets in let cnames = Array.mapi (fun i p -> if p.ip_logical then [||] else - Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((mind_of_kn kn,i),j+1))) + Array.mapi (fun j _ -> pp_global Cons (ConstructRef ((kn,i),j+1))) p.ip_types) ind.ind_packets in let rec pp i = if i >= Array.length ind.ind_packets then mt () else - let ip = (mind_of_kn kn,i) in + let ip = (kn,i) in let ip_equiv = ind.ind_equiv, i in let p = ind.ind_packets.(i) in if is_custom (IndRef ip) then pp (i+1) diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli index c0b4e5b3..f55e2fd6 100644 --- a/plugins/extraction/ocaml.mli +++ b/plugins/extraction/ocaml.mli @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: ocaml.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - val ocaml_descr : Miniml.language_descr diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index 1f04ca59..7915bc82 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: scheme.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*s Production of Scheme syntax. *) open Pp @@ -87,7 +85,7 @@ let rec pp_expr env args = ++ spc () ++ hov 0 (pp_expr env' [] a2))))) | MLglob r -> apply (pp_global Term r) - | MLcons (info,r,args') -> + | MLcons (_,r,args') -> assert (args=[]); let st = str "`" ++ @@ -95,9 +93,12 @@ let rec pp_expr env args = (if args' = [] then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args') in - if info.c_kind = Coinductive then paren (str "delay " ++ st) else st + if is_coinductive r then paren (str "delay " ++ st) else st + | MLtuple _ -> error "Cannot handle tuples in Scheme yet." + | MLcase (_,_,pv) when not (is_regular_match pv) -> + error "Cannot handle general patterns in Scheme yet." | MLcase (_,t,pv) when is_custom_match pv -> - let mkfun (_,ids,e) = + let mkfun (ids,_,e) = if ids <> [] then named_lams (List.rev ids) e else dummy_lams (ast_lift 1 e) 1 in @@ -107,9 +108,9 @@ let rec pp_expr env args = (str (find_custom_match pv) ++ fnl () ++ prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv ++ pp_expr env [] t))) - | MLcase (info,t, pv) -> - let e = - if info.m_kind <> Coinductive then pp_expr env [] t + | MLcase (typ,t, pv) -> + let e = + if not (is_coinductive_type typ) then pp_expr env [] t else paren (str "force" ++ spc () ++ pp_expr env [] t) in apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv))) @@ -126,14 +127,18 @@ let rec pp_expr env args = | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"") and pp_cons_args env = function - | MLcons (info,r,args) when info.c_kind<>Coinductive -> + | MLcons (_,r,args) when is_coinductive r -> paren (pp_global Cons r ++ (if args = [] then mt () else spc ()) ++ prlist_with_sep spc (pp_cons_args env) args) | e -> str "," ++ pp_expr env [] e - -and pp_one_pat env (r,ids,t) = +and pp_one_pat env (ids,p,t) = + let r = match p with + | Pusual r -> r + | Pcons (r,l) -> r (* cf. the check [is_regular_match] above *) + | _ -> assert false + in let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in let args = if ids = [] then mt () diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli index c7c3d8b5..405842f0 100644 --- a/plugins/extraction/scheme.mli +++ b/plugins/extraction/scheme.mli @@ -1,11 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: scheme.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - val scheme_descr : Miniml.language_descr diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 67cf2210..497ddf03 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Names open Term open Declarations @@ -21,23 +19,11 @@ open Util open Pp open Miniml -(** Sets and maps for [global_reference] that work modulo equivalent - on the user part of the name (otherwise use Refset / Refmap ) *) - -module RefOrd = struct - type t = global_reference - let compare x y = - let make_name = function - | ConstRef con -> ConstRef(constant_of_kn(user_con con)) - | IndRef (kn,i) -> IndRef(mind_of_kn(user_mind kn),i) - | ConstructRef ((kn,i),j)-> ConstructRef((mind_of_kn(user_mind kn),i),j) - | VarRef id -> VarRef id - in - Pervasives.compare (make_name x) (make_name y) -end +(** Sets and maps for [global_reference] that use the "user" [kernel_name] + instead of the canonical one *) -module Refmap' = Map.Make(RefOrd) -module Refset' = Set.Make(RefOrd) +module Refmap' = Map.Make(RefOrdered_env) +module Refset' = Set.Make(RefOrdered_env) (*S Utilities about [module_path] and [kernel_names] and [global_reference] *) @@ -71,11 +57,6 @@ let raw_string_of_modfile = function | MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f))) | _ -> assert false -let rec modfile_of_mp = function - | (MPfile _) as mp -> mp - | MPdot (mp,_) -> modfile_of_mp mp - | _ -> raise Not_found - let current_toplevel () = fst (Lib.current_prefix ()) let is_toplevel mp = @@ -109,12 +90,6 @@ let common_prefix_from_list mp0 mpl = | mp :: l -> if MPset.mem mp prefixes then Some mp else f l in f mpl -let rec parse_labels ll = function - | MPdot (mp,l) -> parse_labels (l::ll) mp - | mp -> mp,ll - -let labels_of_mp mp = parse_labels [] mp - let rec parse_labels2 ll mp1 = function | mp when mp1=mp -> mp,ll | MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp @@ -125,10 +100,6 @@ let labels_of_ref r = let mp,_,l = repr_of_r r in parse_labels2 [l] mp_top mp -let rec add_labels_mp mp = function - | [] -> mp - | l :: ll -> add_labels_mp (MPdot (mp,l)) ll - (*S The main tables: constants, inductives, records, ... *) @@ -156,6 +127,39 @@ let add_ind kn mib ml_ind = inductives := Mindmap_env.add kn (mib,ml_ind) !inductives let lookup_ind kn = Mindmap_env.find kn !inductives +let inductive_kinds = + ref (Mindmap_env.empty : inductive_kind Mindmap_env.t) +let init_inductive_kinds () = inductive_kinds := Mindmap_env.empty +let add_inductive_kind kn k = + inductive_kinds := Mindmap_env.add kn k !inductive_kinds +let is_coinductive r = + let kn = match r with + | ConstructRef ((kn,_),_) -> kn + | IndRef (kn,_) -> kn + | _ -> assert false + in + try Mindmap_env.find kn !inductive_kinds = Coinductive + with Not_found -> false + +let is_coinductive_type = function + | Tglob (r,_) -> is_coinductive r + | _ -> false + +let get_record_fields r = + let kn = match r with + | ConstructRef ((kn,_),_) -> kn + | IndRef (kn,_) -> kn + | _ -> assert false + in + try match Mindmap_env.find kn !inductive_kinds with + | Record f -> f + | _ -> [] + with Not_found -> [] + +let record_fields_of_type = function + | Tglob (r,_) -> get_record_fields r + | _ -> [] + (*s Recursors table. *) (* NB: here we can use the equivalence between canonical @@ -203,29 +207,55 @@ let add_info_axiom r = info_axioms := Refset'.add r !info_axioms let remove_info_axiom r = info_axioms := Refset'.remove r !info_axioms let add_log_axiom r = log_axioms := Refset'.add r !log_axioms -(*s Extraction mode: modular or monolithic *) +let opaques = ref Refset'.empty +let init_opaques () = opaques := Refset'.empty +let add_opaque r = opaques := Refset'.add r !opaques +let remove_opaque r = opaques := Refset'.remove r !opaques + +(*s Extraction modes: modular or monolithic, library or minimal ? + +Nota: + - Recursive Extraction : monolithic, minimal + - Separate Extraction : modular, minimal + - Extraction Library : modular, library +*) let modular_ref = ref false +let library_ref = ref false let set_modular b = modular_ref := b let modular () = !modular_ref +let set_library b = library_ref := b +let library () = !library_ref + (*s Printing. *) (* The following functions work even on objects not in [Global.env ()]. - WARNING: for inductive objects, an extract_inductive must have been - done before. *) - -let safe_basename_of_global = function - | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l - | IndRef (kn,i) -> (snd (lookup_ind kn)).ind_packets.(i).ip_typename - | ConstructRef ((kn,i),j) -> - (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) - | _ -> assert false + Warning: for inductive objects, this only works if an [extract_inductive] + have been done earlier, otherwise we can only ask the Nametab about + currently visible objects. *) + +let safe_basename_of_global r = + let last_chance r = + try Nametab.basename_of_global r + with Not_found -> + anomaly "Inductive object unknown to extraction and not globally visible" + in + match r with + | ConstRef kn -> id_of_label (con_label kn) + | IndRef (kn,0) -> id_of_label (mind_label kn) + | IndRef (kn,i) -> + (try (snd (lookup_ind kn)).ind_packets.(i).ip_typename + with Not_found -> last_chance r) + | ConstructRef ((kn,i),j) -> + (try (snd (lookup_ind kn)).ind_packets.(i).ip_consnames.(j-1) + with Not_found -> last_chance r) + | VarRef _ -> assert false let string_of_global r = try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r) - with _ -> string_of_id (safe_basename_of_global r) + with e when Errors.noncritical e -> string_of_id (safe_basename_of_global r) let safe_pr_global r = str (string_of_global r) @@ -233,7 +263,7 @@ let safe_pr_global r = str (string_of_global r) let safe_pr_long_global r = try Printer.pr_global r - with _ -> match r with + with e when Errors.noncritical e -> match r with | ConstRef kn -> let mp,_,l = repr_con kn in str ((string_of_mp mp)^"."^(string_of_label l)) @@ -272,7 +302,28 @@ let warning_axioms () = str "Having invalid logical axiom in the environment when extracting" ++ spc () ++ str "may lead to incorrect or non-terminating ML terms." ++ fnl ()) - end + end; + if !Flags.load_proofs = Flags.Dont && info_axioms@log_axioms <> [] then + msg_warning + (str "Some of these axioms might be due to option -dont-load-proofs.") + +let warning_opaques accessed = + let opaques = Refset'.elements !opaques in + if opaques = [] then () + else + let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in + if accessed then + msg_warning + (str "The extraction is currently set to bypass opacity,\n" ++ + str "the following opaque constant bodies have been accessed :" ++ + lst ++ str "." ++ fnl ()) + else + msg_warning + (str "The extraction now honors the opacity constraints by default,\n" ++ + str "the following opaque constants have been extracted as axioms :" ++ + lst ++ str "." ++ fnl () ++ + str "If necessary, use \"Set Extraction AccessOpaque\" to change this." + ++ fnl ()) let warning_both_mod_and_cst q mp r = msg_warning @@ -386,31 +437,34 @@ let info_file f = (* The objects defined below should survive an arbitrary time, so we register them to coq save/undo mechanism. *) -(*s Extraction AutoInline *) +let my_bool_option name initval = + let flag = ref initval in + let access = fun () -> !flag in + let _ = declare_bool_option + {optsync = true; + optdepr = false; + optname = "Extraction "^name; + optkey = ["Extraction"; name]; + optread = access; + optwrite = (:=) flag } + in + access -let auto_inline_ref = ref false +(*s Extraction AccessOpaque *) -let auto_inline () = !auto_inline_ref +let access_opaque = my_bool_option "AccessOpaque" true -let _ = declare_bool_option - {optsync = true; - optname = "Extraction AutoInline"; - optkey = ["Extraction"; "AutoInline"]; - optread = auto_inline; - optwrite = (:=) auto_inline_ref} +(*s Extraction AutoInline *) + +let auto_inline = my_bool_option "AutoInline" false (*s Extraction TypeExpand *) -let type_expand_ref = ref true +let type_expand = my_bool_option "TypeExpand" true -let type_expand () = !type_expand_ref +(*s Extraction KeepSingleton *) -let _ = declare_bool_option - {optsync = true; - optname = "Extraction TypeExpand"; - optkey = ["Extraction"; "TypeExpand"]; - optread = type_expand; - optwrite = (:=) type_expand_ref} +let keep_singleton = my_bool_option "KeepSingleton" false (*s Extraction Optimize *) @@ -461,6 +515,7 @@ let optims () = !opt_flag_ref let _ = declare_bool_option {optsync = true; + optdepr = false; optname = "Extraction Optimize"; optkey = ["Extraction"; "Optimize"]; optread = (fun () -> !int_flag_ref <> 0); @@ -468,6 +523,7 @@ let _ = declare_bool_option let _ = declare_int_option { optsync = true; + optdepr = false; optname = "Extraction Flag"; optkey = ["Extraction";"Flag"]; optread = (fun _ -> Some !int_flag_ref); @@ -484,7 +540,7 @@ let lang_ref = ref Ocaml let lang () = !lang_ref -let (extr_lang,_) = +let extr_lang : lang -> obj = declare_object {(default_object "Extraction Lang") with cache_function = (fun (_,l) -> lang_ref := l); @@ -516,12 +572,14 @@ let add_inline_entries b l = (* Registration of operations for rollback. *) -let (inline_extraction,_) = +let inline_extraction : bool * global_reference list -> obj = declare_object {(default_object "Extraction Inline") with cache_function = (fun (_,(b,l)) -> add_inline_entries b l); load_function = (fun _ (_,(b,l)) -> add_inline_entries b l); classify_function = (fun o -> Substitute o); + discharge_function = + (fun (_,(b,l)) -> Some (b, List.map pop_global_reference l)); subst_function = (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l))) } @@ -534,8 +592,7 @@ let _ = declare_summary "Extraction Inline" (* Grammar entries. *) let extraction_inline b l = - check_inside_section (); - let refs = List.map Nametab.global l in + let refs = List.map Smartlocate.global_with_alias l in List.iter (fun r -> match r with | ConstRef _ -> () @@ -559,7 +616,7 @@ let print_extraction_inline () = (* Reset part *) -let (reset_inline,_) = +let reset_inline : unit -> obj = declare_object {(default_object "Reset Extraction Inline") with cache_function = (fun (_,_)-> inline_table := empty_inline_table); @@ -598,7 +655,7 @@ let add_implicits r l = (* Registration of operations for rollback. *) -let (implicit_extraction,_) = +let implicit_extraction : global_reference * int_or_id list -> obj = declare_object {(default_object "Extraction Implicit") with cache_function = (fun (_,(r,l)) -> add_implicits r l); @@ -616,7 +673,7 @@ let _ = declare_summary "Extraction Implicit" let extraction_implicit r l = check_inside_section (); - Lib.add_anonymous_leaf (implicit_extraction (Nametab.global r,l)) + Lib.add_anonymous_leaf (implicit_extraction (Smartlocate.global_with_alias r,l)) (*s Extraction Blacklist of filenames not to use while extracting *) @@ -658,12 +715,11 @@ let add_blacklist_entries l = (* Registration of operations for rollback. *) -let (blacklist_extraction,_) = +let blacklist_extraction : string list -> obj = declare_object {(default_object "Extraction Blacklist") with cache_function = (fun (_,l) -> add_blacklist_entries l); load_function = (fun _ (_,l) -> add_blacklist_entries l); - classify_function = (fun o -> Libobject.Keep o); subst_function = (fun (_,x) -> x) } @@ -686,7 +742,7 @@ let print_extraction_blacklist () = (* Reset part *) -let (reset_blacklist,_) = +let reset_blacklist : unit -> obj = declare_object {(default_object "Reset Extraction Blacklist") with cache_function = (fun (_,_)-> blacklist_table := Idset.empty); @@ -719,8 +775,10 @@ let add_custom_match r s = let indref_of_match pv = if Array.length pv = 0 then raise Not_found; - match pv.(0) with - | (ConstructRef (ip,_), _, _) -> IndRef ip + let (_,pat,_) = pv.(0) in + match pat with + | Pusual (ConstructRef (ip,_)) -> IndRef ip + | Pcons (ConstructRef (ip,_),_) -> IndRef ip | _ -> raise Not_found let is_custom_match pv = @@ -732,7 +790,7 @@ let find_custom_match pv = (* Registration of operations for rollback. *) -let (in_customs,_) = +let in_customs : global_reference * string list * string -> obj = declare_object {(default_object "ML extractions") with cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s); @@ -747,7 +805,7 @@ let _ = declare_summary "ML extractions" unfreeze_function = ((:=) customs); init_function = (fun () -> customs := Refmap'.empty) } -let (in_custom_matchs,_) = +let in_custom_matchs : global_reference * string -> obj = declare_object {(default_object "ML extractions custom matchs") with cache_function = (fun (_,(r,s)) -> add_custom_match r s); @@ -765,7 +823,7 @@ let _ = declare_summary "ML extractions custom match" let extract_constant_inline inline r ids s = check_inside_section (); - let g = Nametab.global r in + let g = Smartlocate.global_with_alias r in match g with | ConstRef kn -> let env = Global.env () in @@ -783,7 +841,8 @@ let extract_constant_inline inline r ids s = let extract_inductive r s l optstr = check_inside_section (); - let g = Nametab.global r in + let g = Smartlocate.global_with_alias r in + Dumpglob.add_glob (loc_of_reference r) g; match g with | IndRef ((kn,i) as ip) -> let mib = Global.lookup_mind kn in @@ -805,5 +864,6 @@ let extract_inductive r s l optstr = (*s Tables synchronization. *) let reset_tables () = - init_terms (); init_types (); init_inductives (); init_recursors (); - init_projs (); init_axioms (); reset_modfile () + init_terms (); init_types (); init_inductives (); + init_inductive_kinds (); init_recursors (); + init_projs (); init_axioms (); init_opaques (); reset_modfile () diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index b70d3efa..192426c3 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: table.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Names open Libnames open Miniml @@ -21,6 +19,7 @@ val safe_basename_of_global : global_reference -> identifier (*s Warning and Error messages. *) val warning_axioms : unit -> unit +val warning_opaques : bool -> unit val warning_both_mod_and_cst : qualid -> module_path -> global_reference -> unit val warning_id : string -> unit @@ -59,10 +58,8 @@ val at_toplevel : module_path -> bool val visible_con : constant -> bool val mp_length : module_path -> int val prefixes_mp : module_path -> MPset.t -val modfile_of_mp : module_path -> module_path val common_prefix_from_list : module_path -> module_path list -> module_path option -val add_labels_mp : module_path -> label list -> module_path val get_nth_label_mp : int -> module_path -> label val labels_of_ref : global_reference -> module_path * label list @@ -77,6 +74,14 @@ val lookup_type : constant -> ml_schema val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind +val add_inductive_kind : mutual_inductive -> inductive_kind -> unit +val is_coinductive : global_reference -> bool +val is_coinductive_type : ml_type -> bool +(* What are the fields of a record (empty for a non-record) *) +val get_record_fields : + global_reference -> global_reference option list +val record_fields_of_type : ml_type -> global_reference option list + val add_recursors : Environ.env -> mutual_inductive -> unit val is_recursor : global_reference -> bool @@ -88,8 +93,15 @@ val add_info_axiom : global_reference -> unit val remove_info_axiom : global_reference -> unit val add_log_axiom : global_reference -> unit +val add_opaque : global_reference -> unit +val remove_opaque : global_reference -> unit + val reset_tables : unit -> unit +(*s AccessOpaque parameter *) + +val access_opaque : unit -> bool + (*s AutoInline parameter *) val auto_inline : unit -> bool @@ -98,6 +110,10 @@ val auto_inline : unit -> bool val type_expand : unit -> bool +(*s KeepSingleton parameter *) + +val keep_singleton : unit -> bool + (*s Optimize parameter *) type opt_flag = @@ -120,11 +136,20 @@ val optims : unit -> opt_flag type lang = Ocaml | Haskell | Scheme val lang : unit -> lang -(*s Extraction mode: modular or monolithic *) +(*s Extraction modes: modular or monolithic, library or minimal ? + +Nota: + - Recursive Extraction : monolithic, minimal + - Separate Extraction : modular, minimal + - Extraction Library : modular, library +*) val set_modular : bool -> unit val modular : unit -> bool +val set_library : bool -> unit +val library : unit -> bool + (*s Table for custom inlining *) val to_inline : global_reference -> bool @@ -158,6 +183,7 @@ val extract_constant_inline : val extract_inductive : reference -> string -> string list -> string option -> unit + type int_or_id = ArgInt of int | ArgId of identifier val extraction_implicit : reference -> int_or_id list -> unit diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v index 9017f8d5..504304c6 100644 --- a/plugins/field/LegacyField.v +++ b/plugins/field/LegacyField.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyField.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export LegacyField_Compl. Require Export LegacyField_Theory. Require Export LegacyField_Tactic. diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v index 52e049a5..5e9ae430 100644 --- a/plugins/field/LegacyField_Compl.v +++ b/plugins/field/LegacyField_Compl.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyField_Compl.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import List. Definition assoc_2nd := diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v index f6626e4a..41d2998c 100644 --- a/plugins/field/LegacyField_Tactic.v +++ b/plugins/field/LegacyField_Tactic.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyField_Tactic.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import List. Require Import LegacyRing. Require Export LegacyField_Compl. @@ -152,7 +150,7 @@ Ltac apply_assoc FT lvar trm := match constr:(t = trm) with | (?X1 = ?X1) => idtac | _ => - rewrite <- (assoc_correct FT trm); change (assoc trm) with t in |- * + rewrite <- (assoc_correct FT trm); change (assoc trm) with t end. (**** Distribution *****) @@ -163,7 +161,7 @@ Ltac apply_distrib FT lvar trm := | (?X1 = ?X1) => idtac | _ => rewrite <- (distrib_correct FT trm); - change (distrib trm) with t in |- * + change (distrib trm) with t end. (**** Multiplication by the inverse product ****) @@ -177,7 +175,7 @@ Ltac weak_reduce := | |- context [(interp_ExprA ?X1 ?X2 _)] => cbv beta iota zeta delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero - Aone Aplus Amult Aopp Ainv] in |- * + Aone Aplus Amult Aopp Ainv] end. Ltac multiply mul := @@ -201,7 +199,7 @@ Ltac apply_multiply FT lvar trm := | (?X1 = ?X1) => idtac | _ => rewrite <- (multiply_correct FT trm); - change (multiply trm) with t in |- * + change (multiply trm) with t end. (**** Permutations and simplification ****) @@ -212,7 +210,7 @@ Ltac apply_inverse mul FT lvar trm := | (?X1 = ?X1) => idtac | _ => rewrite <- (inverse_correct FT trm mul); - [ change (inverse_simplif mul trm) with t in |- * | assumption ] + [ change (inverse_simplif mul trm) with t | assumption ] end. (**** Inverse test ****) @@ -254,11 +252,11 @@ Ltac apply_simplif sfun := Ltac unfolds FT := match get_component Aminus FT with - | Some ?X1 => unfold X1 in |- * + | Some ?X1 => unfold X1 | _ => idtac end; match get_component Adiv FT with - | Some ?X1 => unfold X1 in |- * + | Some ?X1 => unfold X1 | _ => idtac end. @@ -269,8 +267,8 @@ Ltac reduce FT := with AmultT := get_component Amult FT with AoppT := get_component Aopp FT with AinvT := get_component Ainv FT in - (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] in |- * || - compute in |- *). + (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] || + compute). Ltac field_gen_aux FT := let AplusT := get_component Aplus FT in @@ -282,7 +280,7 @@ Ltac field_gen_aux FT := cut (let ft := FT in let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2); - [ compute in |- *; auto + [ compute; auto | intros ft vm; apply_simplif apply_distrib; apply_simplif apply_assoc; multiply mul; [ apply_simplif apply_multiply; diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v index 8d10bc8e..1d581a8f 100644 --- a/plugins/field/LegacyField_Theory.v +++ b/plugins/field/LegacyField_Theory.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyField_Theory.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import List. Require Import Peano_dec. Require Import LegacyRing. @@ -46,20 +44,20 @@ Proof. elim (H1 e0); intro y; elim (H2 e); intro y0; try (left; rewrite y; rewrite y0; auto) || - (right; red in |- *; intro; inversion H3; auto). + (right; red; intro; inversion H3; auto). elim (H1 e0); intro y; elim (H2 e); intro y0; try (left; rewrite y; rewrite y0; auto) || - (right; red in |- *; intro; inversion H3; auto). + (right; red; intro; inversion H3; auto). elim (H0 e); intro y. left; rewrite y; auto. - right; red in |- *; intro; inversion H1; auto. + right; red; intro; inversion H1; auto. elim (H0 e); intro y. left; rewrite y; auto. - right; red in |- *; intro; inversion H1; auto. + right; red; intro; inversion H1; auto. elim (eq_nat_dec n n0); intro y. left; rewrite y; auto. - right; red in |- *; intro; inversion H; auto. + right; red; intro; inversion H; auto. Defined. Definition eq_nat_dec := Eval compute in eq_nat_dec. @@ -154,7 +152,7 @@ Lemma r_AmultT_mult : forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2. Proof. intros; transitivity (AmultT (AmultT (AinvT r) r) r1). - rewrite Th_inv_defT; [ symmetry in |- *; apply AmultT_1l; auto | auto ]. + rewrite Th_inv_defT; [ symmetry ; apply AmultT_1l; auto | auto ]. transitivity (AmultT (AmultT (AinvT r) r) r2). repeat rewrite AmultT_assoc; rewrite H; trivial. rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ]. @@ -183,7 +181,7 @@ Qed. Lemma Rmult_neq_0_reg : forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT. Proof. - intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring. + intros r1 r2 H; split; red; intro; apply H; rewrite H0; legacy ring. Qed. (************************) @@ -264,11 +262,11 @@ Lemma merge_mult_correct1 : Proof. intros e1 e2; generalize e1; generalize e2; clear e1 e2. simple induction e2; auto; intros. -unfold merge_mult at 1 in |- *; fold merge_mult in |- *; - unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *; - rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *; - fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *; - fold interp_ExprA in |- *; auto. +unfold merge_mult at 1; fold merge_mult; + unfold interp_ExprA at 2; fold interp_ExprA; + rewrite (H0 e e3 lvar); unfold interp_ExprA at 1; + fold interp_ExprA; unfold interp_ExprA at 5; + fold interp_ExprA; auto. Qed. Lemma merge_mult_correct : @@ -276,7 +274,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 |- *; legacy ring). +elim e0; try (intros; simpl; legacy ring). unfold interp_ExprA in H2; fold interp_ExprA in H2; cut (AmultT (interp_ExprA lvar e2) @@ -286,7 +284,7 @@ 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 |- *; legacy ring. + simpl; legacy ring. legacy ring. Qed. @@ -297,8 +295,8 @@ Lemma assoc_mult_correct1 : interp_ExprA lvar (assoc_mult (EAmult e1 e2)). Proof. simple induction e1; auto; intros. -rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct; - simpl in |- *; rewrite merge_mult_correct; simpl in |- *; +rewrite <- (H e0 lvar); simpl; rewrite merge_mult_correct; + simpl; rewrite merge_mult_correct; simpl; auto. Qed. @@ -308,21 +306,21 @@ Lemma assoc_mult_correct : Proof. simple induction e; auto; intros. elim e0; intros. -intros; simpl in |- *; legacy ring. -simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1))); +intros; simpl; legacy ring. +simpl; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1))); rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite merge_mult_correct; simpl in |- *; - rewrite merge_mult_correct; simpl in |- *; rewrite AmultT_assoc; - rewrite assoc_mult_correct1; rewrite H2; simpl in |- *; +simpl; rewrite (H0 lvar); auto. +simpl; rewrite merge_mult_correct; simpl; + rewrite merge_mult_correct; simpl; rewrite AmultT_assoc; + rewrite assoc_mult_correct1; rewrite H2; simpl; rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1; fold interp_ExprA in H1; rewrite (H0 lvar) in H1; rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1)); rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; legacy ring. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. +simpl; rewrite (H0 lvar); auto. +simpl; rewrite (H0 lvar); auto. +simpl; rewrite (H0 lvar); auto. Qed. Lemma merge_plus_correct1 : @@ -332,11 +330,11 @@ Lemma merge_plus_correct1 : Proof. intros e1 e2; generalize e1; generalize e2; clear e1 e2. simple induction e2; auto; intros. -unfold merge_plus at 1 in |- *; fold merge_plus in |- *; - unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *; - rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *; - fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *; - fold interp_ExprA in |- *; auto. +unfold merge_plus at 1; fold merge_plus; + unfold interp_ExprA at 2; fold interp_ExprA; + rewrite (H0 e e3 lvar); unfold interp_ExprA at 1; + fold interp_ExprA; unfold interp_ExprA at 5; + fold interp_ExprA; auto. Qed. Lemma merge_plus_correct : @@ -344,7 +342,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 |- *; legacy ring). +elim e0; try intros; try (simpl; legacy ring). unfold interp_ExprA in H2; fold interp_ExprA in H2; cut (AplusT (interp_ExprA lvar e2) @@ -354,7 +352,7 @@ 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 |- *; legacy ring. + simpl; legacy ring. legacy ring. Qed. @@ -364,8 +362,8 @@ Lemma assoc_plus_correct : interp_ExprA lvar (assoc (EAplus e1 e2)). Proof. simple induction e1; auto; intros. -rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct; - simpl in |- *; rewrite merge_plus_correct; simpl in |- *; +rewrite <- (H e0 lvar); simpl; rewrite merge_plus_correct; + simpl; rewrite merge_plus_correct; simpl; auto. Qed. @@ -375,11 +373,11 @@ Lemma assoc_correct : Proof. simple induction e; auto; intros. elim e0; intros. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite merge_plus_correct; simpl in |- *; - rewrite merge_plus_correct; simpl in |- *; rewrite AplusT_assoc; - rewrite assoc_plus_correct; rewrite H2; simpl in |- *; +simpl; rewrite (H0 lvar); auto. +simpl; rewrite (H0 lvar); auto. +simpl; rewrite merge_plus_correct; simpl; + rewrite merge_plus_correct; simpl; rewrite AplusT_assoc; + rewrite assoc_plus_correct; rewrite H2; simpl; apply (r_AplusT_plus (interp_ExprA lvar (assoc e1)) (AplusT (interp_ExprA lvar (assoc e2)) @@ -388,7 +386,7 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; (interp_ExprA lvar e1))); rewrite <- AplusT_assoc; rewrite (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) - ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; + ; rewrite assoc_plus_correct; rewrite H1; simpl; rewrite (H0 lvar); rewrite <- (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1)) @@ -401,15 +399,15 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; rewrite <- (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3) (interp_ExprA lvar e1)); apply AplusT_comm. -unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; - fold interp_ExprA in |- *; rewrite assoc_mult_correct; - rewrite (H0 lvar); simpl in |- *; auto. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. -simpl in |- *; rewrite (H0 lvar); auto. -unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; - fold interp_ExprA in |- *; rewrite assoc_mult_correct; - simpl in |- *; auto. +unfold assoc; fold assoc; unfold interp_ExprA; + fold interp_ExprA; rewrite assoc_mult_correct; + rewrite (H0 lvar); simpl; auto. +simpl; rewrite (H0 lvar); auto. +simpl; rewrite (H0 lvar); auto. +simpl; rewrite (H0 lvar); auto. +unfold assoc; fold assoc; unfold interp_ExprA; + fold interp_ExprA; rewrite assoc_mult_correct; + simpl; auto. Qed. (**** Distribution *****) @@ -453,7 +451,7 @@ Lemma distrib_mult_right_correct : interp_ExprA lvar (distrib_mult_right e1 e2) = AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). Proof. -simple induction e1; try intros; simpl in |- *; auto. +simple induction e1; try intros; simpl; auto. rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar); rewrite (H0 e2 lvar); legacy ring. Qed. @@ -463,10 +461,10 @@ Lemma distrib_mult_left_correct : interp_ExprA lvar (distrib_mult_left e1 e2) = AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2). Proof. -simple induction e1; try intros; simpl in |- *. -rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *; +simple induction e1; try intros; simpl. +rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl; apply AmultT_Or. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. rewrite AmultT_comm; rewrite (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e) @@ -474,10 +472,10 @@ rewrite AmultT_comm; rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e)); rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0)); rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl; apply AmultT_comm. Qed. Lemma distrib_correct : @@ -485,13 +483,13 @@ Lemma distrib_correct : interp_ExprA lvar (distrib e) = interp_ExprA lvar e. Proof. simple induction e; intros; auto. -simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar); - unfold distrib in |- *; simpl in |- *; auto. -simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar); - unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct. -simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar); - unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct; - simpl in |- *; fold AoppT in |- *; legacy ring. +simpl; rewrite <- (H lvar); rewrite <- (H0 lvar); + unfold distrib; simpl; auto. +simpl; rewrite <- (H lvar); rewrite <- (H0 lvar); + unfold distrib; simpl; apply distrib_mult_left_correct. +simpl; fold AoppT; rewrite <- (H lvar); + unfold distrib; simpl; rewrite distrib_mult_right_correct; + simpl; fold AoppT; legacy ring. Qed. (**** Multiplication by the inverse product ****) @@ -502,7 +500,7 @@ Lemma mult_eq : interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) -> interp_ExprA lvar e1 = interp_ExprA lvar e2. Proof. - simpl in |- *; intros; + simpl; intros; apply (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1) (interp_ExprA lvar e2)); assumption. @@ -525,16 +523,16 @@ Lemma multiply_aux_correct : interp_ExprA lvar (multiply_aux a e) = AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). Proof. -simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct; +simple induction e; simpl; intros; try rewrite merge_mult_correct; auto. - simpl in |- *; rewrite (H0 lvar); legacy ring. + simpl; rewrite (H0 lvar); legacy ring. Qed. Lemma multiply_correct : forall (e:ExprA) (lvar:list (AT * nat)), interp_ExprA lvar (multiply e) = interp_ExprA lvar e. Proof. - simple induction e; simpl in |- *; auto. + simple induction e; simpl; auto. intros; apply multiply_aux_correct. Qed. @@ -585,27 +583,27 @@ Lemma monom_remove_correct : AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). Proof. simple induction e; intros. -simpl in |- *; case (eqExprA EAzero (EAinv a)); intros; - [ inversion e0 | simpl in |- *; trivial ]. -simpl in |- *; case (eqExprA EAone (EAinv a)); intros; - [ inversion e0 | simpl in |- *; trivial ]. -simpl in |- *; case (eqExprA (EAplus e0 e1) (EAinv a)); intros; - [ inversion e2 | simpl in |- *; trivial ]. -simpl in |- *; case (eqExprA e0 (EAinv a)); intros. -rewrite e2; simpl in |- *; fold AinvT in |- *. +simpl; case (eqExprA EAzero (EAinv a)); intros; + [ inversion e0 | simpl; trivial ]. +simpl; case (eqExprA EAone (EAinv a)); intros; + [ inversion e0 | simpl; trivial ]. +simpl; case (eqExprA (EAplus e0 e1) (EAinv a)); intros; + [ inversion e2 | simpl; trivial ]. +simpl; case (eqExprA e0 (EAinv a)); intros. +rewrite e2; simpl; fold AinvT. rewrite <- (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a)) (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ]. -simpl in |- *; rewrite H0; auto; legacy ring. -simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a)); - intros; [ inversion e1 | simpl in |- *; trivial ]. -unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros. +simpl; rewrite H0; auto; legacy ring. +simpl; fold AoppT; case (eqExprA (EAopp e0) (EAinv a)); + intros; [ inversion e1 | simpl; trivial ]. +unfold monom_remove; case (eqExprA (EAinv e0) (EAinv a)); intros. case (eqExprA e0 a); intros. -rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto. -inversion e1; simpl in |- *; exfalso; auto. -simpl in |- *; trivial. -unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros; - [ inversion e0 | simpl in |- *; trivial ]. +rewrite e2; simpl; fold AinvT; rewrite AinvT_r; auto. +inversion e1; simpl; exfalso; auto. +simpl; trivial. +unfold monom_remove; case (eqExprA (EAvar n) (EAinv a)); intros; + [ inversion e0 | simpl; trivial ]. Qed. Lemma monom_simplif_rem_correct : @@ -614,7 +612,7 @@ Lemma monom_simplif_rem_correct : interp_ExprA lvar (monom_simplif_rem a e) = AmultT (interp_ExprA lvar a) (interp_ExprA lvar e). Proof. -simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct; +simple induction a; simpl; intros; try rewrite monom_remove_correct; auto. elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1); intros. @@ -628,9 +626,9 @@ Lemma monom_simplif_correct : interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e. Proof. simple induction e; intros; auto. -simpl in |- *; case (eqExprA a e0); intros. +simpl; case (eqExprA a e0); intros. rewrite <- e2; apply monom_simplif_rem_correct; auto. -simpl in |- *; trivial. +simpl; trivial. Qed. Lemma inverse_correct : @@ -639,8 +637,8 @@ Lemma inverse_correct : interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e. Proof. simple induction e; intros; auto. -simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto. -unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto. +simpl; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto. +unfold inverse_simplif; rewrite monom_simplif_correct; auto. Qed. End Theory_of_fields. diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4 index 37aa457d..6c9fd325 100644 --- a/plugins/field/field.ml4 +++ b/plugins/field/field.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: field.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Names open Pp open Proof_type @@ -39,18 +37,20 @@ let constr_of_opt a opt = | None -> mkApp (init_constant "None",[|ac3|]) | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|]) +module Cmap = Map.Make(struct type t = constr let compare = constr_ord end) + (* Table of theories *) -let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t) +let th_tab = ref (Cmap.empty : constr Cmap.t) let lookup env typ = - try Gmap.find typ !th_tab + try Cmap.find typ !th_tab with Not_found -> errorlabstrm "field" (str "No field is declared for type" ++ spc() ++ Printer.pr_lconstr_env env typ) let _ = - let init () = th_tab := Gmap.empty in + let init () = th_tab := Cmap.empty in let freeze () = !th_tab in let unfreeze fs = th_tab := fs in Summary.declare_summary "field" @@ -59,7 +59,7 @@ let _ = Summary.init_function = init } let load_addfield _ = () -let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab +let cache_addfield (_,(typ,th)) = th_tab := Cmap.add typ th !th_tab let subst_addfield (subst,(typ,th as obj)) = let typ' = subst_mps subst typ in let th' = subst_mps subst th in @@ -67,7 +67,7 @@ let subst_addfield (subst,(typ,th as obj)) = (typ',th') (* Declaration of the Add Field library object *) -let (in_addfield,out_addfield)= +let in_addfield : types * constr -> Libobject.obj = Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with Libobject.open_function = (fun i o -> if i=1 then cache_addfield o); Libobject.cache_function = cache_addfield; diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 1f3fd595..f0043140 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: formula.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Hipattern open Names open Term diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index a831c087..fe6238ab 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: formula.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - open Term open Names open Libnames diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 8e68506c..29d41b81 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_ground.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Formula open Sequent open Ground @@ -29,6 +27,7 @@ let ground_depth=ref 3 let _= let gdopt= { optsync=true; + optdepr=false; optname="Firstorder Depth"; optkey=["Firstorder";"Depth"]; optread=(fun ()->Some !ground_depth); @@ -44,6 +43,7 @@ let congruence_depth=ref 100 let _= let gdopt= { optsync=true; + optdepr=false; optname="Congruence Depth"; optkey=["Congruence";"Depth"]; optread=(fun ()->Some !congruence_depth); @@ -85,7 +85,7 @@ let gen_ground_tac flag taco ids bases gl= extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in let result=ground_tac solver startseq gl in qflag:=backup;result - with e ->qflag:=backup;raise e + with reraise ->qflag:=backup;raise reraise (* special for compatibility with Intuition @@ -111,7 +111,6 @@ let pr_firstorder_using_glob _ _ _ = prlist_with_sep pr_comma (pr_or_var (pr_loc let pr_firstorder_using_typed _ _ _ = prlist_with_sep pr_comma pr_global ARGUMENT EXTEND firstorder_using - TYPED AS reference_list PRINTED BY pr_firstorder_using_typed RAW_TYPED AS reference_list RAW_PRINTED BY pr_firstorder_using_raw @@ -135,8 +134,6 @@ TACTIC EXTEND firstorder | [ "firstorder" tactic_opt(t) firstorder_using(l) "with" ne_preident_list(l') ] -> [ gen_ground_tac true (Option.map eval_tactic t) l l' ] -| [ "firstorder" tactic_opt(t) ] -> - [ gen_ground_tac true (Option.map eval_tactic t) [] [] ] END TACTIC EXTEND gintuition diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 163b9891..4d907b2c 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ground.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Formula open Sequent open Rules @@ -18,32 +16,6 @@ open Tactics open Tacticals open Libnames -(* -let old_search=ref !Auto.searchtable - -(* I use this solution as a means to know whether hints have changed, -but this prevents the GC from collecting the previous table, -resulting in some limited space wasting*) - -let update_flags ()= - if not ( !Auto.searchtable == !old_search ) then - begin - old_search:=!Auto.searchtable; - let predref=ref Names.KNpred.empty in - let f p_a_t = - match p_a_t.Auto.code with - Auto.Unfold_nth (ConstRef kn)-> - predref:=Names.KNpred.add kn !predref - | _ ->() in - let g _ l=List.iter f l in - let h _ hdb=Auto.Hint_db.iter g hdb in - Util.Stringmap.iter h !Auto.searchtable; - red_flags:= - Closure.RedFlags.red_add_transparent - Closure.betaiotazeta (Names.Idpred.full,!predref) - end -*) - let update_flags ()= let predref=ref Names.Cpred.empty in let f coe= @@ -61,7 +33,7 @@ let ground_tac solver startseq gl= update_flags (); let rec toptac skipped seq gl= if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 - then Pp.msgnl (Printer.pr_goal (sig_it gl)); + then Pp.msgnl (Printer.pr_goal gl); tclORELSE (axiom_tac seq.gl seq) begin try diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli index 8328bb3a..8b2ba20c 100644 --- a/plugins/firstorder/ground.mli +++ b/plugins/firstorder/ground.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ground.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - val ground_tac: Tacmach.tactic -> (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 4802aaa3..4b07c609 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -1,20 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: instances.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Formula open Sequent open Unify open Rules open Util open Term -open Rawterm +open Glob_term open Tacmach open Tactics open Tacticals @@ -35,11 +33,11 @@ let compare_instance inst1 inst2= | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1 | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1 -let compare_gr id1 id2= +let compare_gr id1 id2 = if id1==id2 then 0 else if id1==dummy_id then 1 else if id2==dummy_id then -1 - else Pervasives.compare id1 id2 + else Libnames.RefOrdered.compare id1 id2 module OrderedInstance= struct @@ -125,13 +123,13 @@ let mk_open_instance id gl m t= let rec raux n t= if n=0 then t else match t with - RLambda(loc,name,k,_,t0)-> + GLambda(loc,name,k,_,t0)-> let t1=raux (n-1) t0 in - RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1) + GLambda(loc,name,k,GHole (dummy_loc,Evd.BinderType name),t1) | _-> anomaly "can't happen" in let ntt=try Pretyping.Default.understand evmap env (raux m rawt) - with _ -> + with e when Errors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in decompose_lam_n_assum m ntt @@ -181,12 +179,12 @@ let right_instance_tac inst continue seq= [tclTHENLIST [introf; (fun gls-> - split (Rawterm.ImplicitBindings + split (Glob_term.ImplicitBindings [mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls); tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY assumption] | Real ((0,t),_) -> - (tclTHEN (split (Rawterm.ImplicitBindings [t])) + (tclTHEN (split (Glob_term.ImplicitBindings [t])) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index 537e40e7..edccf213 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: instances.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Term open Tacmach open Names diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index e6d73fb6..33bb522f 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rules.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Util open Names open Term diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index a5a6b614..d56efbcb 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: rules.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - open Term open Tacmach open Names diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index faac286e..43de96ab 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: sequent.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Term open Util open Formula @@ -59,71 +57,10 @@ struct (priority e1.pat) - (priority e2.pat) end -(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare - the immediate subterms of [c1] of [c2] if needed; Cast's, - application associativity, binders name and Cases annotations are - not taken into account *) - -let rec compare_list f l1 l2= - match l1,l2 with - [],[]-> 0 - | [],_ -> -1 - | _,[] -> 1 - | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2 - -let compare_array f v1 v2= - let l=Array.length v1 in - let c=l - Array.length v2 in - if c=0 then - let rec comp_aux i= - if i<0 then 0 - else - let ci=f v1.(i) v2.(i) in - if ci=0 then - comp_aux (i-1) - else ci - in comp_aux (l-1) - else c - -let compare_constr_int f t1 t2 = - match kind_of_term t1, kind_of_term t2 with - | Rel n1, Rel n2 -> n1 - n2 - | Meta m1, Meta m2 -> m1 - m2 - | Var id1, Var id2 -> Pervasives.compare id1 id2 - | Sort s1, Sort s2 -> Pervasives.compare s1 s2 - | Cast (c1,_,_), _ -> f c1 t2 - | _, Cast (c2,_,_) -> f t1 c2 - | Prod (_,t1,c1), Prod (_,t2,c2) - | Lambda (_,t1,c1), Lambda (_,t2,c2) -> - (f =? f) t1 t2 c1 c2 - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> - ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 - | App (_,_), App (_,_) -> - let c1,l1=decompose_app t1 - and c2,l2=decompose_app t2 in - (f =? (compare_list f)) c1 c2 l1 l2 - | Evar (e1,l1), Evar (e2,l2) -> - ((-) =? (compare_array f)) e1 e2 l1 l2 - | Const c1, Const c2 -> Pervasives.compare c1 c2 - | Ind c1, Ind c2 -> Pervasives.compare c1 c2 - | Construct c1, Construct c2 -> Pervasives.compare c1 c2 - | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> - ((f =? f) ==? (compare_array f)) p1 p2 c1 c2 bl1 bl2 - | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> - ((Pervasives.compare =? (compare_array f)) ==? (compare_array f)) - ln1 ln2 tl1 tl2 bl1 bl2 - | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> - ((Pervasives.compare =? (compare_array f)) ==? (compare_array f)) - ln1 ln2 tl1 tl2 bl1 bl2 - | _ -> Pervasives.compare t1 t2 - -let rec compare_constr m n= - compare_constr_int compare_constr m n - module OrderedConstr= struct type t=constr - let compare=compare_constr + let compare=constr_ord end type h_item = global_reference * (int*constr) option @@ -132,7 +69,7 @@ module Hitem= struct type t = h_item let compare (id1,co1) (id2,co2)= - (Pervasives.compare + (Libnames.RefOrdered.compare =? (fun oc1 oc2 -> match oc1,oc2 with Some (m1,c1),Some (m2,c2) -> @@ -283,7 +220,7 @@ let extend_with_auto_hints l seq gl= seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) | _-> () in - let g _ l=List.iter f l in + let g _ l = List.iter f l in let h dbname= let hdb= try diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index ef052605..9e99e23b 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: sequent.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - open Term open Util open Formula diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 4e0ad108..73c7f79c 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: unify.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Util open Formula open Tacmach @@ -91,9 +89,8 @@ let unif t1 t2= let value i t= let add x y= if x<0 then y else if y<0 then x else x+y in - let tref=mkMeta i in let rec vaux term= - if term=tref then 0 else + if isMeta term && destMeta term = i then 0 else let f v t=add v (vaux t) in let vr=fold_constr f (-1) term in if vr<0 then -1 else vr+1 in diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli index 4e0d88d3..a13709f4 100644 --- a/plugins/firstorder/unify.mli +++ b/plugins/firstorder/unify.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: unify.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - open Term exception UFAIL of constr*constr diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v index d6447111..f37d0027 100644 --- a/plugins/fourier/Fourier.v +++ b/plugins/fourier/Fourier.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Fourier.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (* "Fourier's method to solve linear inequations/equations systems.".*) Require Export LegacyRing. diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v index 7c5b5ed7..b10c304c 100644 --- a/plugins/fourier/Fourier_util.v +++ b/plugins/fourier/Fourier_util.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Fourier_util.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export Rbase. Comments "Lemmas used by the tactic Fourier". @@ -18,7 +16,7 @@ intros; apply Rmult_lt_compat_l; assumption. Qed. Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. -red in |- *. +red. intros. case H; auto with real. Qed. @@ -65,19 +63,19 @@ Lemma Rfourier_le_le : x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. intros x1 y1 x2 y2 a H H0 H1; try assumption. case H0; intros. -red in |- *. +red. left; try assumption. apply Rfourier_le_lt; auto with real. rewrite H2. case H; intros. -red in |- *. +red. left; try assumption. rewrite (Rplus_comm x1 (a * y2)). rewrite (Rplus_comm y1 (a * y2)). apply Rplus_lt_compat_l. try exact H3. rewrite H3. -red in |- *. +red. right; try assumption. auto with real. Qed. @@ -86,7 +84,7 @@ Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. intros x H; try assumption. rewrite Rplus_comm. apply Rle_lt_0_plus_1. -red in |- *; auto with real. +red; auto with real. Qed. Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. @@ -103,12 +101,12 @@ Qed. Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. intros x H; try assumption. case H; intros. -red in |- *. +red. left; try assumption. apply Rlt_zero_pos_plus1; auto with real. rewrite <- H0. replace (1 + 0) with 1. -red in |- *; left. +red; left. exact Rlt_zero_1. ring. Qed. @@ -116,28 +114,28 @@ Qed. Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. intros x y H H0; try assumption. case H; intros. -red in |- *; left. +red; left. apply Rlt_mult_inv_pos; auto with real. rewrite <- H1. -red in |- *; right; ring. +red; right; ring. Qed. Lemma Rle_zero_1 : 0 <= 1. -red in |- *; left. +red; left. exact Rlt_zero_1. Qed. Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. -intros n d H; red in |- *; intros H0; try exact H0. +intros n d H; red; intros H0; try exact H0. generalize (Rgt_not_le 0 (n * / d)). intros H1; elim H1; try assumption. replace (n * / d) with (- - (n * / d)). replace 0 with (- -0). replace (- (n * / d)) with (- n * / d). replace (-0) with 0. -red in |- *. +red. apply Ropp_gt_lt_contravar. -red in |- *. +red. exact H0. ring. ring. @@ -164,7 +162,7 @@ ring. Qed. Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. -unfold not in |- *; intros. +unfold not; intros. apply H. apply Rplus_lt_reg_r with x. replace (x + 0) with x. @@ -175,7 +173,7 @@ ring. Qed. Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. -unfold not in |- *; intros. +unfold not; intros. apply H. case H0; intros. left. @@ -190,7 +188,7 @@ rewrite H1; ring. Qed. Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. -unfold Rgt in |- *; intros; assumption. +unfold Rgt; intros; assumption. Qed. Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml index 1a92c716..1574e21e 100644 --- a/plugins/fourier/fourier.ml +++ b/plugins/fourier/fourier.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: fourier.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - (* Méthode d'élimination de Fourier *) (* Référence: Auteur(s) : Fourier, Jean-Baptiste-Joseph @@ -177,7 +175,7 @@ let unsolvable lie = raise (Failure "contradiction found")) |_->assert false) lr) - with _ -> ()); + with e when Errors.noncritical e -> ()); !res ;; diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 2cabcf52..e0e4f7d6 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: fourierR.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - (* La tactique Fourier ne fonctionne de manière sûre que si les coefficients @@ -31,17 +29,23 @@ qui donne le coefficient d'un terme du calcul des constructions, qui est zéro si le terme n'y est pas. *) -type flin = {fhom:(constr , rational)Hashtbl.t; +module Constrhash = Hashtbl.Make + (struct type t = constr + let equal = eq_constr + let hash = hash_constr + end) + +type flin = {fhom: rational Constrhash.t; fcste:rational};; -let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};; +let flin_zero () = {fhom=Constrhash.create 50;fcste=r0};; -let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;; +let flin_coef f x = try (Constrhash.find f.fhom x) with Not_found -> r0;; let flin_add f x c = let cx = flin_coef f x in - Hashtbl.remove f.fhom x; - Hashtbl.add f.fhom x (rplus cx c); + Constrhash.remove f.fhom x; + Constrhash.add f.fhom x (rplus cx c); f ;; let flin_add_cste f c = @@ -53,20 +57,20 @@ let flin_one () = flin_add_cste (flin_zero()) r1;; let flin_plus f1 f2 = let f3 = flin_zero() in - Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; + Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; + Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; ;; let flin_minus f1 f2 = let f3 = flin_zero() in - Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; - Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; + Constrhash.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; + Constrhash.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste); ;; let flin_emult a f = let f2 = flin_zero() in - Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; + Constrhash.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; flin_add_cste f2 (rmult a f.fcste); ;; @@ -137,10 +141,12 @@ let rec flin_of_constr c = (try (let a=(rational_of_constr args.(0)) in try (let b = (rational_of_constr args.(1)) in (flin_add_cste (flin_zero()) (rmult a b))) - with _-> (flin_add (flin_zero()) + with e when Errors.noncritical e -> + (flin_add (flin_zero()) args.(1) a)) - with _-> (flin_add (flin_zero()) + with e when Errors.noncritical e -> + (flin_add (flin_zero()) args.(0) (rational_of_constr args.(1)))) | "Rinv"-> @@ -150,7 +156,8 @@ let rec flin_of_constr c = (let b=(rational_of_constr args.(1)) in try (let a = (rational_of_constr args.(0)) in (flin_add_cste (flin_zero()) (rdiv a b))) - with _-> (flin_add (flin_zero()) + with e when Errors.noncritical e -> + (flin_add (flin_zero()) args.(0) (rinv b))) |_->assert false) @@ -160,14 +167,15 @@ let rec flin_of_constr c = |"R0" -> flin_zero () |_-> assert false) |_-> assert false) - with _ -> flin_add (flin_zero()) + with e when Errors.noncritical e -> + flin_add (flin_zero()) c r1 ;; let flin_to_alist f = let res=ref [] in - Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f; + Constrhash.iter (fun x c -> res:=(c,x)::(!res)) f; !res ;; @@ -256,17 +264,17 @@ let ineq1_of_constr (h,t) = let fourier_lineq lineq1 = let nvar=ref (-1) in - let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *) + let hvar=Constrhash.create 50 in (* la table des variables des inéquations *) List.iter (fun f -> - Hashtbl.iter (fun x _ -> if not (Hashtbl.mem hvar x) then begin + Constrhash.iter (fun x _ -> if not (Constrhash.mem hvar x) then begin nvar:=(!nvar)+1; - Hashtbl.add hvar x (!nvar) + Constrhash.add hvar x (!nvar) end) f.hflin.fhom) lineq1; let sys= List.map (fun h-> let v=Array.create ((!nvar)+1) r0 in - Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) + Constrhash.iter (fun x c -> v.(Constrhash.find hvar x)<-c) h.hflin.fhom; ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) lineq1 in @@ -490,13 +498,13 @@ let rec fourier gl= |_->assert false) |_->assert false in tac gl) - with _ -> + with e when Errors.noncritical e -> (* les hypothèses *) let hyps = List.map (fun (h,t)-> (mkVar h,t)) (list_of_sign (pf_hyps gl)) in let lineq =ref [] in List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) - with _ -> ()) + with e when Errors.noncritical e -> ()) hyps; (* lineq = les inéquations découlant des hypothèses *) if !lineq=[] then Util.error "No inequalities"; diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index ea766830..7c7cf64f 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/fourier/g_fourier.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_fourier.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open FourierR TACTIC EXTEND fourier diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v index 763ed82f..b2955e90 100644 --- a/plugins/funind/Recdef.v +++ b/plugins/funind/Recdef.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 3590e698..48205019 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,7 +1,6 @@ open Printer open Util open Term -open Termops open Namegen open Names open Declarations @@ -34,10 +33,14 @@ let observennl strm = let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v - with e -> - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + with reraise -> + let e = Cerrors.process_vernac_interp_error reraise in + let goal = + try (Printer.pr_goal g) + with e when Errors.noncritical e -> assert false + in msgnl (str "observation "++ s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); + Errors.print e ++ str " on goal " ++ goal ); raise e;; let observe_tac_stream s tac g = @@ -119,7 +122,7 @@ let is_trivial_eq t = eq_constr t1 t2 && eq_constr a1 a2 | _ -> false end - with _ -> false + with e when Errors.noncritical e -> false in (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res @@ -145,7 +148,7 @@ let is_incompatible_eq t = (eq_constr u1 u2 && incompatible_constructor_terms t1 t2) | _ -> false - with _ -> false + with e when Errors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); res @@ -232,7 +235,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = then (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) else nochange "not an equality" - with _ -> nochange "not an equality" + with e when Errors.noncritical e -> nochange "not an equality" in if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = @@ -263,7 +266,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = in let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) + let end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *) let new_end_of_type = (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 Can be safely replaced by the next comment for Ocaml >= 3.08.4 @@ -286,7 +289,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = try let witness = Intmap.find i sub in if b' <> None then anomaly "can not redefine a rel!"; - (pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) + (Termops.pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -350,9 +353,9 @@ let isLetIn t = let h_reduce_with_zeta = h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; + (Glob_term.Cbv + {Glob_term.all_flags + with Glob_term.rDelta = false; }) @@ -388,7 +391,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let coq_I = Coqlib.build_coq_I () in let rec scan_type context type_of_hyp : tactic = if isLetIn type_of_hyp then - let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in + let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = @@ -406,13 +409,13 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = then begin let (x,t_x,t') = destProd type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in + let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in if is_property ptes_infos t_x actual_real_type_of_hyp then begin let pte,pte_args = (destApp t_x) in let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in + let popped_t' = Termops.pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = let context_length = List.length context in tclTHENLIST @@ -461,9 +464,9 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) - let popped_t' = pop t' in + let popped_t' = Termops.pop t' in let real_type_of_hyp = - it_mkProd_or_LetIn ~init:popped_t' context + it_mkProd_or_LetIn popped_t' context in let prove_trivial = let nb_intro = List.length context in @@ -489,9 +492,9 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ] else if is_trivial_eq t_x then (* t_x := t = t => we remove this precond *) - let popped_t' = pop t' in + let popped_t' = Termops.pop t' in let real_type_of_hyp = - it_mkProd_or_LetIn ~init:popped_t' context + it_mkProd_or_LetIn popped_t' context in let hd,args = destApp t_x in let get_args hd args = @@ -589,7 +592,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let fun_body = mkLambda(Anonymous, pf_type_of g' term, - replace_term term (mkRel 1) dyn_infos.info + Termops.replace_term term (mkRel 1) dyn_infos.info ) in let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in @@ -608,8 +611,8 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let my_orelse tac1 tac2 g = try tac1 g - with e -> -(* observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *) + with e when Errors.noncritical e -> +(* observe (str "using snd tac since : " ++ Errors.print e); *) tac2 g let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = @@ -909,8 +912,8 @@ let generalize_non_dep hyp g = let to_revert,_ = Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> if List.mem hyp hyps - or List.exists (occur_var_in_decl env hyp) keep - or occur_var env hyp hyp_typ + or List.exists (Termops.occur_var_in_decl env hyp) keep + or Termops.occur_var env hyp hyp_typ or Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) @@ -936,7 +939,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let f_def = Global.lookup_constant (destConst f) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in let f_body = - force (Option.get f_def.const_body) + force (Option.get (body_of_constant f_def)) in let params,f_body_with_params = decompose_lam_n nb_params f_body in let (_,num),(_,_,bodies) = destFix f_body_with_params in @@ -954,7 +957,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let type_ctxt,type_of_f = 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 lemma_type = it_mkProd_or_LetIn eqn type_ctxt in let f_id = id_of_label (con_label (destConst f)) in let prove_replacement = tclTHENSEQ @@ -964,7 +967,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = let rec_id = pf_nth_hyp_id g 1 in tclTHENSEQ [(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id); - (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Rawterm.NoBindings)); + (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Glob_term.NoBindings)); intros_reflexivity] g ) ] @@ -1009,7 +1012,7 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = | _ -> () in - Tacinterp.constr_of_id (pf_env g) equation_lemma_id + Constrintern.construct_reference (pf_hyps g) equation_lemma_id in let nb_intro_to_do = nb_prod (pf_concl g) in tclTHEN @@ -1052,7 +1055,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : } in let get_body const = - match (Global.lookup_constant const ).const_body with + match body_of_constant (Global.lookup_constant const) with | Some b -> let body = force b in Tacred.cbv_norm_flags @@ -1212,7 +1215,11 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in let pte,pte_args = (decompose_app pte_app) in try - let pte = try destVar pte with _ -> anomaly "Property is not a variable" in + let pte = + try destVar pte + with e when Errors.noncritical e -> + anomaly "Property is not a variable" + in let fix_info = Idmap.find pte ptes_to_fix in let nb_args = fix_info.nb_realargs in tclTHENSEQ @@ -1300,7 +1307,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : in let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ - [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)]; + [unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef fname)]; let do_prove = build_proof interactive_proof @@ -1371,7 +1378,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) (* rewrite *) (* ) *) - Eauto.gen_eauto false (false,5) [] (Some []) + Eauto.gen_eauto (false,5) [] (Some []) ] gls @@ -1400,10 +1407,10 @@ let build_clause eqs = { Tacexpr.onhyps = Some (List.map - (fun id -> (Rawterm.all_occurrences_expr,id),InHyp) + (fun id -> (Glob_term.all_occurrences_expr, id), Termops.InHyp) eqs ); - Tacexpr.concl_occs = Rawterm.no_occurrences_expr + Tacexpr.concl_occs = Glob_term.no_occurrences_expr } let rec rewrite_eqs_in_eqs eqs = @@ -1416,7 +1423,7 @@ let rec rewrite_eqs_in_eqs eqs = (fun id gl -> observe_tac (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) - (tclTRY (Equality.general_rewrite_in true all_occurrences (* dep proofs also: *) true id (mkVar eq) false)) + (tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* dep proofs also: *) true id (mkVar eq) false)) gl ) eqs @@ -1438,7 +1445,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = (fun g -> if is_mes then - unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g + unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g else tclIDTAC g ); observe_tac "rew_and_finish" @@ -1449,9 +1456,8 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = ( tclCOMPLETE( Eauto.eauto_with_bases - false (true,5) - [Lazy.force refl_equal] + [Evd.empty,Lazy.force refl_equal] [Auto.Hint_db.empty empty_transparent_state false] ) ) diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index b756492b..04fcc8d4 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,7 +1,6 @@ open Printer open Util open Term -open Termops open Namegen open Names open Declarations @@ -114,9 +113,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let pre_princ = it_mkProd_or_LetIn - ~init: (it_mkProd_or_LetIn - ~init:(Option.fold_right + (Option.fold_right mkProd_or_LetIn princ_type_info.indarg princ_type_info.concl @@ -140,16 +138,10 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let dummy_var = mkVar (id_of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in + let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in (* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) res in - let rec has_dummy_var t = - fold_constr - (fun b t -> b || (eq_constr t dummy_var) || (has_dummy_var t)) - false - t - in let rec compute_new_princ_type remove env pre_princ : types*(constr list) = let (new_princ_type,_) as res = match kind_of_term pre_princ with @@ -199,58 +191,58 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in - let new_x : name = get_name (ids_of_context env) x in + let new_x : name = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (x,None,t) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b + then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b else ( bind_fun(new_x,new_t,new_b), list_union_eq eq_constr binders_to_remove_from_t - (List.map pop binders_to_remove_from_b) + (List.map Termops.pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b + new_b, List.map Termops.pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) + new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) end and compute_new_princ_type_for_letin remove env x v t b = begin try let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in - let new_x : name = get_name (ids_of_context env) x in + let new_x : name = get_name (Termops.ids_of_context env) x in let new_env = Environ.push_rel (x,Some v,t) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b + then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b else ( mkLetIn(new_x,new_v,new_t,new_b), list_union_eq eq_constr (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) - (List.map pop binders_to_remove_from_b) + (List.map Termops.pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map pop binders_to_remove_from_b + new_b, List.map Termops.pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) + new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) end and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = let new_e,to_remove_from_e = compute_new_princ_type remove env e @@ -267,10 +259,10 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (lift (List.length ptes_vars) pre_res) in it_mkProd_or_LetIn - ~init:(it_mkProd_or_LetIn - ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) - new_predicates) - ) + (it_mkProd_or_LetIn + pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) + new_predicates) + ) princ_type_info.params @@ -283,7 +275,7 @@ let change_property_sort toSort princ princName = compose_prod args (mkSort toSort) ) in - let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in + let princName_as_constr = Constrintern.global_reference princName in let init = let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in mkApp(princName_as_constr, @@ -291,8 +283,7 @@ let change_property_sort toSort princ princName = (fun i -> mkRel (nargs - i ))) in it_mkLambda_or_LetIn - ~init: - (it_mkLambda_or_LetIn ~init + (it_mkLambda_or_LetIn init (List.map change_sort_in_predicate princ_info.predicates) ) princ_info.params @@ -311,11 +302,8 @@ let defined () = "defined" ((try str "On goal : " ++ fnl () ++ pr_open_subgoals () ++ fnl () - with _ -> mt () + with e when Errors.noncritical e -> mt () ) ++msg) - | e -> raise e - - let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) @@ -384,10 +372,9 @@ let generate_functional_principle (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) let ce = { const_entry_body = value; + const_entry_secctx = None; const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() - } + const_entry_opaque = false } in ignore( Declare.declare_constant @@ -411,7 +398,7 @@ let generate_functional_principle Don't forget to close the goal if an error is raised !!!! *) save false new_princ_name entry g_kind hook - with e -> + with e when Errors.noncritical e -> begin begin try @@ -423,7 +410,7 @@ let generate_functional_principle then Pfedit.delete_current_proof () else () else () - with _ -> () + with e when Errors.noncritical e -> () end; raise (Defining_principle e) end @@ -450,7 +437,7 @@ let get_funs_constant mp dp = in function const -> let find_constant_body const = - match (Global.lookup_constant const ).const_body with + match body_of_constant (Global.lookup_constant const) with | Some b -> let body = force b in let body = Tacred.cbv_norm_flags @@ -475,7 +462,7 @@ let get_funs_constant mp dp = let first_params = List.hd l_params in List.iter (fun params -> - if not ((=) first_params params) + if not (list_equal (fun (n1, c1) (n2, c2) -> n1 = n2 && eq_constr c1 c2) first_params params) then error "Not a mutal recursive block" ) l_params @@ -493,7 +480,10 @@ let get_funs_constant mp dp = in let first_infos = extract_info true (List.hd l_bodies) in let check body = (* Hope this is correct *) - if not (first_infos = (extract_info false body)) + let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = + ia1 = ia2 && na1 = na2 && array_equal eq_constr ta1 ta2 && array_equal eq_constr ca1 ca2 + in + if not (eq_infos first_infos (extract_info false body)) then error "Not a mutal recursive block" in List.iter check l_bodies @@ -504,7 +494,7 @@ let get_funs_constant mp dp = exception No_graph_found exception Found_type of int -let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = +let make_scheme (fas : (constant*Glob_term.glob_sort) list) : Entries.definition_entry list = let env = Global.env () and sigma = Evd.empty in let funs = List.map fst fas in @@ -561,7 +551,7 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent 0 (prove_princ_for_struct false 0 (Array.of_list funs)) (fun _ _ _ -> ()) - with e -> + with e when Errors.noncritical e -> begin begin try @@ -573,7 +563,7 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent then Pfedit.delete_current_proof () else () else () - with _ -> () + with e when Errors.noncritical e -> () end; raise (Defining_principle e) end @@ -584,7 +574,7 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent let finfos = find_Function_infos this_block_funs.(0) in try let equation = Option.get finfos.equation_lemma in - (Global.lookup_constant equation).Declarations.const_opaque + Declarations.is_opaque (Global.lookup_constant equation) with Option.IsNone -> (* non recursive definition *) false in @@ -639,7 +629,7 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent const with Found_type i -> let princ_body = - Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt + Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt in {const with Entries.const_entry_body = princ_body; @@ -688,7 +678,7 @@ let build_case_scheme fa = let env = Global.env () and sigma = Evd.empty in (* let id_to_constr id = *) -(* Tacinterp.constr_of_id env id *) +(* Constrintern.global_reference id *) (* in *) let funs = (fun (_,f,_) -> try Libnames.constr_of_global (Nametab.global f) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index fb04c6ec..1c02c16e 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -27,8 +27,8 @@ val compute_new_princ_type_from_rel : constr array -> sorts array -> exception No_graph_found -val make_scheme : (constant*Rawterm.rawsort) list -> Entries.definition_entry list +val make_scheme : (constant*Glob_term.glob_sort) list -> Entries.definition_entry list -val build_scheme : (identifier*Libnames.reference*Rawterm.rawsort) list -> unit -val build_case_scheme : (identifier*Libnames.reference*Rawterm.rawsort) -> unit +val build_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) list -> unit +val build_case_scheme : (identifier*Libnames.reference*Glob_term.glob_sort) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 41fafdf1..6b6e4838 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,19 +16,20 @@ open Indfun open Genarg open Pcoq open Tacticals +open Constr let pr_binding prc = function - | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) - | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + | loc, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c) + | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) let pr_bindings prc prlc = function - | Rawterm.ImplicitBindings l -> + | Glob_term.ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc prc l - | Rawterm.ExplicitBindings l -> + | Glob_term.ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | Rawterm.NoBindings -> mt () + | Glob_term.NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) @@ -55,7 +56,6 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = ARGUMENT EXTEND fun_ind_using - TYPED AS constr_with_bindings_opt PRINTED BY pr_fun_ind_using_typed RAW_TYPED AS constr_with_bindings_opt RAW_PRINTED BY pr_fun_ind_using @@ -129,85 +129,36 @@ ARGUMENT EXTEND auto_using' | [ ] -> [ [] ] END -let pr_rec_annotation2_aux s r id l = - str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ - Util.pr_opt Nameops.pr_id id ++ - Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}" - -let pr_rec_annotation2 = function - | Struct id -> str "{struct" ++ Nameops.pr_id id ++ str "}" - | Wf(r,id,l) -> pr_rec_annotation2_aux "wf" r id l - | Mes(r,id,l) -> pr_rec_annotation2_aux "measure" r id l - -VERNAC ARGUMENT EXTEND rec_annotation2 -PRINTED BY pr_rec_annotation2 - [ "{" "struct" ident(id) "}"] -> [ Struct id ] -| [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ] -| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] -END - -let pr_binder2 (idl,c) = - str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ - str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")" +module Gram = Pcoq.Gram +module Vernac = Pcoq.Vernac_ +module Tactic = Pcoq.Tactic -VERNAC ARGUMENT EXTEND binder2 -PRINTED BY pr_binder2 - [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> [ (idl,c) ] -END +module FunctionGram = +struct + let gec s = Gram.entry_create ("Function."^s) + (* types *) + let function_rec_definition_loc : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located Gram.entry = gec "function_rec_definition_loc" +end +open FunctionGram -let make_binder2 (idl,c) = - LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) - -let pr_rec_definition2 (id,bl,annot,type_,def) = - Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ - Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++ - Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ - Ppconstr.pr_lconstr_expr def - -VERNAC ARGUMENT EXTEND rec_definition2 -PRINTED BY pr_rec_definition2 - [ ident(id) binder2_list(bl) - rec_annotation2_opt(annot) ":" lconstr(type_) - ":=" lconstr(def)] -> - [ (id,bl,annot,type_,def) ] -END +GEXTEND Gram + GLOBAL: function_rec_definition_loc ; -let make_rec_definitions2 (id,bl,annot,type_,def) = - let bl = List.map make_binder2 bl in - let names = List.map snd (Topconstr.names_of_local_assums bl) in - let check_one_name () = - if List.length names > 1 then - Util.user_err_loc - (Util.dummy_loc,"Function", - Pp.str "the recursive argument needs to be specified"); - in - let check_exists_args an = - try - let id = match an with - | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id - | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" - in - (try ignore(Util.list_index0 (Name id) names); annot - with Not_found -> Util.user_err_loc - (Util.dummy_loc,"Function", - Pp.str "No argument named " ++ Nameops.pr_id id) - ) - with Failure "check_exists_args" -> check_one_name ();annot - in - let ni = - match annot with - | None -> - annot - | Some an -> - check_exists_args an - in - ((Util.dummy_loc,id), ni, bl, type_, def) + function_rec_definition_loc: + [ [ g = Vernac.rec_definition -> loc, g ]] + ; + END +type 'a function_rec_definition_loc_argtype = ((Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located, 'a) Genarg.abstract_argument_type +let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype), + (globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype), + (rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) = + Genarg.create_arg None "function_rec_definition_loc" VERNAC COMMAND EXTEND Function - ["Function" ne_rec_definition2_list_sep(recsl,"with")] -> + ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] -> [ - do_generate_principle false (List.map make_rec_definitions2 recsl); + do_generate_principle false (List.map snd recsl); ] END @@ -215,7 +166,7 @@ END let pr_fun_scheme_arg (princ_name,fun_name,s) = Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ - Ppconstr.pr_rawsort s + Ppconstr.pr_glob_sort s VERNAC ARGUMENT EXTEND fun_scheme_arg PRINTED BY pr_fun_scheme_arg @@ -224,17 +175,18 @@ END let warning_error names e = + let e = Cerrors.process_vernac_interp_error e in match e with | Building_graph e -> Pp.msg_warning (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ - if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) + if do_observe () then (spc () ++ Errors.print e) else mt ()) | Defining_principle e -> Pp.msg_warning (str "Cannot define principle(s) for "++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ - if do_observe () then Cerrors.explain_exn e else mt ()) + if do_observe () then Errors.print e else mt ()) | _ -> raise e @@ -256,14 +208,14 @@ VERNAC COMMAND EXTEND NewFunctionalScheme try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> Util.error ("Cannot generate induction principle(s)") - | e -> + | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end | _ -> assert false (* we can only have non empty list *) end - | e -> + | e when Errors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end @@ -480,7 +432,7 @@ TACTIC EXTEND fauto [ "fauto" tactic(tac)] -> [ let heuristic = chose_heuristic None in - finduction None heuristic (snd tac) + finduction None heuristic (Tacinterp.eval_tactic tac) ] | [ "fauto" ] -> diff --git a/plugins/funind/rawterm_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index b74422a3..b9e0e62a 100644 --- a/plugins/funind/rawterm_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -2,11 +2,11 @@ open Printer open Pp open Names open Term -open Rawterm +open Glob_term open Libnames open Indfun_common open Util -open Rawtermops +open Glob_termops let observe strm = if do_observe () @@ -23,31 +23,31 @@ type binder_type = | Prod of name | LetIn of name -type raw_context = (binder_type*rawconstr) list +type glob_context = (binder_type*glob_constr) list (* - compose_raw_context [(bt_1,n_1,t_1);......] rt returns + compose_glob_context [(bt_1,n_1,t_1);......] rt returns b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the binders corresponding to the bt_i's *) -let compose_raw_context = +let compose_glob_context = let compose_binder (bt,t) acc = match bt with - | Lambda n -> mkRLambda(n,t,acc) - | Prod n -> mkRProd(n,t,acc) - | LetIn n -> mkRLetIn(n,t,acc) + | Lambda n -> mkGLambda(n,t,acc) + | Prod n -> mkGProd(n,t,acc) + | LetIn n -> mkGLetIn(n,t,acc) in List.fold_right compose_binder (* - The main part deals with building a list of raw constructor expressions + The main part deals with building a list of globalized constructor expressions from the rhs of a fixpoint equation. *) type 'a build_entry_pre_return = { - context : raw_context; (* the binding context of the result *) + context : glob_context; (* the binding context of the result *) value : 'a; (* The value *) } @@ -159,8 +159,8 @@ let apply_args ctxt body args = | _,[] -> (* No more args *) (ctxt,body) | [],_ -> (* no more fun *) - let f,args' = raw_decompose_app body in - (ctxt,mkRApp(f,args'@args)) + let f,args' = glob_decompose_app body in + (ctxt,mkGApp(f,args'@args)) | (Lambda Anonymous,t)::ctxt',arg::args' -> do_apply avoid ctxt' body args' | (Lambda (Name id),t)::ctxt',arg::args' -> @@ -215,8 +215,8 @@ let combine_app f args = let combine_lam n t b = { context = []; - value = mkRLambda(n, compose_raw_context t.context t.value, - compose_raw_context b.context b.value ) + value = mkGLambda(n, compose_glob_context t.context t.value, + compose_glob_context b.context b.value ) } @@ -269,8 +269,8 @@ let make_discr_match_brl i = list_map_i (fun j (_,idl,patl,_) -> if j=i - then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref)) - else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref)) + then (dummy_loc,idl,patl, mkGRef (Lazy.force coq_True_ref)) + else (dummy_loc,idl,patl, mkGRef (Lazy.force coq_False_ref)) ) 0 (* @@ -281,7 +281,7 @@ let make_discr_match_brl i = *) let make_discr_match brl = fun el i -> - mkRCases(None, + mkGCases(None, make_discr_match_el el, make_discr_match_brl i brl) @@ -308,26 +308,27 @@ let build_constructors_of_type ind' argl = (Global.env ()) construct in - let argl = - if argl = [] - then + let argl = match argl with + | None -> Array.to_list - (Array.init (cst_narg - npar) (fun _ -> mkRHole ()) + (Array.init cst_narg (fun _ -> mkGHole ()) ) - else argl + | Some l -> + Array.to_list + (Array.init npar (fun _ -> mkGHole ()))@l in let pat_as_term = - mkRApp(mkRRef (ConstructRef(ind',i+1)),argl) + mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) in - cases_pattern_of_rawconstr Anonymous pat_as_term + cases_pattern_of_glob_constr Anonymous pat_as_term ) ind.Declarations.mind_consnames (* [find_type_of] very naive attempts to discover the type of an if or a letin *) let rec find_type_of nb b = - let f,_ = raw_decompose_app b in + let f,_ = glob_decompose_app b in match f with - | RRef(_,ref) -> + | GRef(_,ref) -> begin let ind_type = match ref with @@ -350,8 +351,8 @@ let rec find_type_of nb b = then raise (Invalid_argument "find_type_of : not a valid inductive"); ind_type end - | RCast(_,b,_) -> find_type_of nb b - | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *) + | GCast(_,b,_) -> find_type_of nb b + | GApp _ -> assert false (* we have decomposed any application via glob_decompose_app *) | _ -> raise (Invalid_argument "not a ref") @@ -419,7 +420,7 @@ let add_pat_variables pat typ env : Environ.env = let rec pattern_to_term_and_type env typ = function | PatVar(loc,Anonymous) -> assert false | PatVar(loc,Name id) -> - mkRVar id + mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = Inductiveops.mis_constructor_nargs_env @@ -445,7 +446,7 @@ let rec pattern_to_term_and_type env typ = function let patl_as_term = List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl in - mkRApp(mkRRef(ConstructRef constr), + mkGApp(mkGRef(ConstructRef constr), implicit_args@patl_as_term ) @@ -472,7 +473,7 @@ let rec pattern_to_term_and_type env typ = function and concatenate them (informally, each branch of a match produces a new constructor) \end{itemize} - WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. + WARNING: The terms constructed here are only USING the glob_constr syntax but are highly bad formed. We must wait to have complete all the current calculi to set the recursive calls. At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. @@ -481,15 +482,15 @@ let rec pattern_to_term_and_type env typ = function *) -let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = - observe (str " Entering : " ++ Printer.pr_rawconstr rt); +let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = + observe (str " Entering : " ++ Printer.pr_glob_constr rt); match rt with - | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid - | RApp(_,_,_) -> - let f,args = raw_decompose_app rt in - let args_res : (rawconstr list) build_entry_return = + | GApp(_,_,_) -> + let f,args = glob_decompose_app rt in + let args_res : (glob_constr list) build_entry_return = List.fold_right (* create the arguments lists of constructors and combine them *) (fun arg ctxt_argsl -> let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in @@ -500,19 +501,19 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = in begin match f with - | RLambda _ -> + | GLambda _ -> let rec aux t l = match l with | [] -> t | u::l -> match t with - | RLambda(loc,na,_,nat,b) -> - RLetIn(dummy_loc,na,u,aux b l) + | GLambda(loc,na,_,nat,b) -> + GLetIn(dummy_loc,na,u,aux b l) | _ -> - RApp(dummy_loc,t,l) + GApp(dummy_loc,t,l) in build_entry_lc env funnames avoid (aux f args) - | RVar(_,id) when Idset.mem id funnames -> + | GVar(_,id) when Idset.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] then we create a fresh variable [res], add [res] and its "value" (i.e. [res v1 ... vn]) to each @@ -525,20 +526,20 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in let res = fresh_id args_res.to_avoid "res" in let new_avoid = res::args_res.to_avoid in - let res_rt = mkRVar res in + let res_rt = mkGVar res in let new_result = List.map (fun arg_res -> let new_hyps = [Prod (Name res),res_raw_type; - Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)] + Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)] in {context = arg_res.context@new_hyps; value = res_rt } ) args_res.result in { result = new_result; to_avoid = new_avoid } - | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> + | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ -> (* if have [g t1 ... tn] with [g] not appearing in [funnames] then foreach [ctxt,v1 ... vn] in [args_res] we return @@ -549,11 +550,11 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = result = List.map (fun args_res -> - {args_res with value = mkRApp(f,args_res.value)}) + {args_res with value = mkGApp(f,args_res.value)}) args_res.result } - | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *) - | RLetIn(_,n,t,b) -> + | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) + | GLetIn(_,n,t,b) -> (* if we have [(let x := v in b) t1 ... tn] , we discard our work and compute the list of constructor for [let x = v in (b t1 ... tn)] up to alpha conversion @@ -567,7 +568,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = let new_b = replace_var_by_term id - (RVar(dummy_loc,id)) + (GVar(dummy_loc,id)) b in (Name new_id,new_b,new_avoid) @@ -577,27 +578,26 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = env funnames avoid - (mkRLetIn(new_n,t,mkRApp(new_b,args))) - | RCases _ | RIf _ | RLetTuple _ -> + (mkGLetIn(new_n,t,mkGApp(new_b,args))) + | GCases _ | GIf _ | GLetTuple _ -> (* we have [(match e1, ...., en with ..... end) t1 tn] we first compute the result from the case and then combine each of them with each of args one *) let f_res = build_entry_lc env funnames args_res.to_avoid f in combine_results combine_app f_res args_res - | RDynamic _ ->error "Not handled RDynamic" - | RCast(_,b,_) -> + | GCast(_,b,_) -> (* for an applied cast we just trash the cast part and restart the work. WARNING: We need to restart since [b] itself should be an application term *) - build_entry_lc env funnames avoid (mkRApp(b,args)) - | RRec _ -> error "Not handled RRec" - | RProd _ -> error "Cannot apply a type" + build_entry_lc env funnames avoid (mkGApp(b,args)) + | GRec _ -> error "Not handled GRec" + | GProd _ -> error "Cannot apply a type" end (* end of the application treatement *) - | RLambda(_,n,_,t,b) -> + | GLambda(_,n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type @@ -612,7 +612,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = let new_env = raw_push_named (new_n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_lam new_n) t_res b_res - | RProd(_,n,_,t,b) -> + | GProd(_,n,_,t,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the type @@ -622,7 +622,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = let new_env = raw_push_named (n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_prod n) t_res b_res - | RLetIn(_,n,v,b) -> + | GLetIn(_,n,v,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the value [t] @@ -638,23 +638,23 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res - | RCases(_,_,_,el,brl) -> + | GCases(_,_,_,el,brl) -> (* we create the discrimination function and treat the case itself *) let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid - | RIf(_,b,(na,e_option),lhs,rhs) -> + | GIf(_,b,(na,e_option),lhs,rhs) -> let b_as_constr = Pretyping.Default.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in let (ind,_) = try Inductiveops.find_inductive env Evd.empty b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ - Printer.pr_rawconstr b ++ str " in " ++ - Printer.pr_rawconstr rt ++ str ". try again with a cast") + Printer.pr_glob_constr b ++ str " in " ++ + Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind [] in + let case_pats = build_constructors_of_type ind None in assert (Array.length case_pats = 2); let brl = list_map_i @@ -663,19 +663,19 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = [lhs;rhs] in let match_expr = - mkRCases(None,[(b,(Anonymous,None))],brl) + mkGCases(None,[(b,(Anonymous,None))],brl) in - (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) + (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) build_entry_lc env funnames avoid match_expr - | RLetTuple(_,nal,_,b,e) -> + | GLetTuple(_,nal,_,b,e) -> begin - let nal_as_rawconstr = - List.map + let nal_as_glob_constr = + Some (List.map (function - Name id -> mkRVar id - | Anonymous -> mkRHole () + Name id -> mkGVar id + | Anonymous -> mkGHole () ) - nal + nal) in let b_as_constr = Pretyping.Default.understand Evd.empty env b in let b_typ = Typing.type_of env Evd.empty b_as_constr in @@ -683,26 +683,25 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = try Inductiveops.find_inductive env Evd.empty b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ - Printer.pr_rawconstr b ++ str " in " ++ - Printer.pr_rawconstr rt ++ str ". try again with a cast") + Printer.pr_glob_constr b ++ str " in " ++ + Printer.pr_glob_constr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind nal_as_rawconstr in + let case_pats = build_constructors_of_type ind nal_as_glob_constr in assert (Array.length case_pats = 1); let br = (dummy_loc,[],[case_pats.(0)],e) in - let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in + let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in build_entry_lc env funnames avoid match_expr end - | RRec _ -> error "Not handled RRec" - | RCast(_,b,_) -> + | GRec _ -> error "Not handled GRec" + | GCast(_,b,_) -> build_entry_lc env funnames avoid b - | RDynamic _ -> error "Not handled RDynamic" and build_entry_lc_from_case env funname make_discr (el:tomatch_tuples) - (brl:Rawterm.cases_clauses) avoid : - rawconstr build_entry_return = + (brl:Glob_term.cases_clauses) avoid : + glob_constr build_entry_return = match el with | [] -> assert false (* this case correspond to match <nothing> with .... !*) | el -> @@ -762,7 +761,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (will be used in the following recursive calls) *) let new_env = List.fold_right2 add_pat_variables patl types env in - let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = + let not_those_patterns : (identifier list -> glob_constr -> glob_constr) list = List.map2 (fun pat typ -> fun avoid pat'_as_term -> @@ -778,9 +777,9 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id in - mkRProd (Name id,raw_typ_of_id,acc)) + mkGProd (Name id,raw_typ_of_id,acc)) pat_ids - (raw_make_neq pat'_as_term (pattern_to_term renamed_pat)) + (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) ) patl types @@ -835,7 +834,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve else acc ) idl - [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)] + [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] ) patl matched_expr.value @@ -879,16 +878,16 @@ let is_res id = let same_raw_term rt1 rt2 = match rt1,rt2 with - | RRef(_,r1), RRef (_,r2) -> r1=r2 - | RHole _, RHole _ -> true + | GRef(_,r1), GRef (_,r2) -> r1=r2 + | GHole _, GHole _ -> true | _ -> false let decompose_raw_eq lhs rhs = let rec decompose_raw_eq lhs rhs acc = - observe (str "decomposing eq for " ++ pr_rawconstr lhs ++ str " " ++ pr_rawconstr rhs); - let (rhd,lrhs) = raw_decompose_app rhs in - let (lhd,llhs) = raw_decompose_app lhs in - observe (str "lhd := " ++ pr_rawconstr lhd); - observe (str "rhd := " ++ pr_rawconstr rhd); + observe (str "decomposing eq for " ++ pr_glob_constr lhs ++ str " " ++ pr_glob_constr rhs); + let (rhd,lrhs) = glob_decompose_app rhs in + let (lhd,llhs) = glob_decompose_app lhs in + observe (str "lhd := " ++ pr_glob_constr lhd); + observe (str "rhd := " ++ pr_glob_constr rhd); observe (str "llhs := " ++ int (List.length llhs)); observe (str "lrhs := " ++ int (List.length lrhs)); let sllhs = List.length llhs in @@ -905,29 +904,29 @@ let decompose_raw_eq lhs rhs = exception Continue (* The second phase which reconstruct the real type of the constructor. - rebuild the raw constructors expression. + rebuild the globalized constructors expression. eliminates some meaningless equalities, applies some rewrites...... *) let rec rebuild_cons env nb_args relname args crossed_types depth rt = - observe (str "rebuilding : " ++ pr_rawconstr rt); + observe (str "rebuilding : " ++ pr_glob_constr rt); match rt with - | RProd(_,n,k,t,b) -> + | GProd(_,n,k,t,b) -> let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t::crossed_types in begin match t with - | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id -> + | GApp(_,(GVar(_,res_id) as res_rt),args') when is_res res_id -> begin match args' with - | (RVar(_,this_relname))::args' -> + | (GVar(_,this_relname))::args' -> (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious i*) let new_t = - mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) + mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in let t' = Pretyping.Default.understand Evd.empty env new_t in let new_env = Environ.push_rel (n,None,t') env in @@ -937,19 +936,20 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = args new_crossed_types (depth + 1) b in - mkRProd(n,new_t,new_b), + mkGProd(n,new_t,new_b), Idset.filter not_free_in_t id_to_exclude | _ -> (* the first args is the name of the function! *) assert false end - | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt]) + | GApp(loc1,GRef(loc2,eq_as_ref),[ty;GVar(loc3,id);rt]) when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous -> begin try - observe (str "computing new type for eq : " ++ pr_rawconstr rt); + observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = - try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue + try Pretyping.Default.understand Evd.empty env t + with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in let _keep_eq = @@ -968,7 +968,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = new_args new_crossed_types (depth + 1) subst_b in - mkRProd(n,t,new_b),id_to_exclude + mkGProd(n,t,new_b),id_to_exclude with Continue -> let jmeq = Libnames.IndRef (destInd (jmeq ())) in let ty' = Pretyping.Default.understand Evd.empty env ty in @@ -979,20 +979,20 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = ((Util.list_chop nparam args')) in let rt_typ = - RApp(Util.dummy_loc, - RRef (Util.dummy_loc,Libnames.IndRef ind), + GApp(Util.dummy_loc, + GRef (Util.dummy_loc,Libnames.IndRef ind), (List.map (fun p -> Detyping.detype false [] (Termops.names_of_rel_context env) p) params)@(Array.to_list (Array.make (List.length args' - nparam) - (mkRHole ())))) + (mkGHole ())))) in let eq' = - RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt]) + GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt]) in - observe (str "computing new type for jmeq : " ++ pr_rawconstr eq'); + observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in observe (str " computing new type for jmeq : done") ; let new_args = @@ -1051,14 +1051,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = new_args new_crossed_types (depth + 1) subst_b in - mkRProd(n,eq',new_b),id_to_exclude + mkGProd(n,eq',new_b),id_to_exclude end (* J.F:. keep this comment it explain how to remove some meaningless equalities if keep_eq then - mkRProd(n,t,new_b),id_to_exclude + mkGProd(n,t,new_b),id_to_exclude else new_b, Idset.add id id_to_exclude *) - | RApp(loc1,RRef(loc2,eq_as_ref),[ty;rt1;rt2]) + | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2]) when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous -> begin @@ -1069,8 +1069,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_rt = List.fold_left (fun acc (lhs,rhs) -> - mkRProd(Anonymous, - mkRApp(mkRRef(eq_as_ref),[mkRHole ();lhs;rhs]),acc) + mkGProd(Anonymous, + mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc) ) b l @@ -1078,7 +1078,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = rebuild_cons env nb_args relname args crossed_types depth new_rt else raise Continue with Continue -> - observe (str "computing new type for prod : " ++ pr_rawconstr rt); + observe (str "computing new type for prod : " ++ pr_glob_constr rt); let t' = Pretyping.Default.understand Evd.empty env t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = @@ -1091,10 +1091,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) - | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude end | _ -> - observe (str "computing new type for prod : " ++ pr_rawconstr rt); + observe (str "computing new type for prod : " ++ pr_glob_constr rt); let t' = Pretyping.Default.understand Evd.empty env t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = @@ -1107,13 +1107,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) - | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude end - | RLambda(_,n,k,t,b) -> + | GLambda(_,n,k,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in - observe (str "computing new type for lambda : " ++ pr_rawconstr rt); + observe (str "computing new type for lambda : " ++ pr_glob_constr rt); let t' = Pretyping.Default.understand Evd.empty env t in match n with | Name id -> @@ -1121,19 +1121,19 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_b,id_to_exclude = rebuild_cons new_env nb_args relname - (args@[mkRVar id])new_crossed_types + (args@[mkGVar id])new_crossed_types (depth + 1 ) b in if Idset.mem id id_to_exclude && depth >= nb_args then new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) else - RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude + GProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude | _ -> anomaly "Should not have an anonymous function here" (* We have renamed all the anonymous functions during alpha_renaming phase *) end - | RLetIn(_,n,t,b) -> + | GLetIn(_,n,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in let t' = Pretyping.Default.understand Evd.empty env t in @@ -1147,10 +1147,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = match n with | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) - | _ -> RLetIn(dummy_loc,n,t,new_b), + | _ -> GLetIn(dummy_loc,n,t,new_b), Idset.filter not_free_in_t id_to_exclude end - | RLetTuple(_,nal,(na,rto),t,b) -> + | GLetTuple(_,nal,(na,rto),t,b) -> assert (rto=None); begin let not_free_in_t id = not (is_free_in id t) in @@ -1173,22 +1173,22 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* | Name id when Idset.mem id id_to_exclude -> *) (* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *) (* | _ -> *) - RLetTuple(dummy_loc,nal,(na,None),t,new_b), + GLetTuple(dummy_loc,nal,(na,None),t,new_b), Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude') end - | _ -> mkRApp(mkRVar relname,args@[rt]),Idset.empty + | _ -> mkGApp(mkGVar relname,args@[rt]),Idset.empty (* debuging wrapper *) let rebuild_cons env nb_args relname args crossed_types rt = - observe (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ - str "nb_args := " ++ str (string_of_int nb_args)); +(* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *) +(* str "nb_args := " ++ str (string_of_int nb_args)); *) let res = rebuild_cons env nb_args relname args crossed_types 0 rt in - observe (str " leads to "++ pr_rawconstr (fst res)); +(* observe (str " leads to "++ pr_glob_constr (fst res)); *) res @@ -1200,30 +1200,30 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) let rec compute_cst_params relnames params = function - | RRef _ | RVar _ | REvar _ | RPatVar _ -> params - | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames -> + | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params + | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames -> compute_cst_params_from_app [] (params,rtl) - | RApp(_,f,args) -> + | GApp(_,f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) - | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> + | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetIn(_,_,t,b) | GLetTuple(_,_,_,t,b) -> let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b - | RCases _ -> + | GCases _ -> params (* If there is still cases at this point they can only be discriminitation ones *) - | RSort _ -> params - | RHole _ -> params - | RIf _ | RRec _ | RCast _ | RDynamic _ -> + | GSort _ -> params + | GHole _ -> params + | GIf _ | GRec _ | GCast _ -> raise (UserError("compute_cst_params", str "Not handled case")) and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' + | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl' when id_ord id id' == 0 && not is_defined -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc -let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts = +let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * bool) list array) csts = let rels_params = Array.mapi (fun i args -> @@ -1242,13 +1242,13 @@ let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) if array_for_all (fun l -> let (n',nt',is_defined') = List.nth l i in - n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined') + n = n' && Topconstr.eq_glob_constr nt nt' && is_defined = is_defined') rels_params then l := param::!l ) rels_params.(0) - with _ -> + with e when Errors.noncritical e -> () in List.rev !l @@ -1261,15 +1261,15 @@ let rec rebuild_return_type rt = Topconstr.CArrow(loc,t,rebuild_return_type t') | Topconstr.CLetIn(loc,na,t,t') -> Topconstr.CLetIn(loc,na,t,rebuild_return_type t') - | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None)) + | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,GType None)) let do_build_inductive - funnames (funsargs: (Names.name * rawconstr * bool) list list) + funnames (funsargs: (Names.name * glob_constr * bool) list list) returned_types - (rtl:rawconstr list) = + (rtl:glob_constr list) = let _time1 = System.get_time () in -(* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *) +(* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *) let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in let funnames = Array.of_list funnames in let funsargs = Array.of_list funsargs in @@ -1286,7 +1286,7 @@ let do_build_inductive let env = Array.fold_right (fun id env -> - Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env + Environ.push_named (id,None,Typing.type_of env Evd.empty (Constrintern.global_reference id)) env ) funnames (Global.env ()) @@ -1294,19 +1294,19 @@ let do_build_inductive let resa = Array.map (build_entry_lc env funnames_as_set []) rta in let env_with_graphs = let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = + let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list = funargs in List.fold_right (fun (n,t,is_defined) acc -> if is_defined then - Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, + Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t, acc) else Topconstr.CProdN (dummy_loc, - [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t], + [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], acc ) ) @@ -1325,9 +1325,9 @@ let do_build_inductive let constr i res = List.map (function result (* (args',concl') *) -> - let rt = compose_raw_context result.context result.value in + let rt = compose_glob_context result.context result.value in let nb_args = List.length funsargs.(i) in - (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *) + (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *) fst ( rebuild_cons env_with_graphs nb_args relnames.(i) [] @@ -1346,7 +1346,7 @@ let do_build_inductive i*) id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) in - let rel_constructors i rt : (identifier*rawconstr) list = + let rel_constructors i rt : (identifier*glob_constr) list = next_constructor_id := (-1); List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) in @@ -1360,19 +1360,19 @@ let do_build_inductive rel_constructors in let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = + let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list = (snd (list_chop nrel_params funargs)) in List.fold_right (fun (n,t,is_defined) acc -> if is_defined then - Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, + Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t, acc) else Topconstr.CProdN (dummy_loc, - [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t], + [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], acc ) ) @@ -1389,10 +1389,10 @@ let do_build_inductive (fun (n,t,is_defined) -> if is_defined then - Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t) + Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_glob_constr Idset.empty t) else Topconstr.LocalRawAssum - ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t) + ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t) ) rels_params in @@ -1402,7 +1402,7 @@ let do_build_inductive false,((dummy_loc,id), Flags.with_option Flags.raw_print - (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t) + (Constrextern.extern_glob_type Idset.empty) ((* zeta_normalize *) t) ) )) (rel_constructors) @@ -1454,7 +1454,7 @@ let do_build_inductive in observe (msg); raise e - | e -> + | reraise -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) let repacked_rel_inds = @@ -1465,16 +1465,16 @@ let do_build_inductive str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ - Cerrors.explain_exn e + Errors.print reraise in observe msg; - raise e + raise reraise let build_inductive funnames funsargs returned_types rtl = try do_build_inductive funnames funsargs returned_types rtl - with e -> raise (Building_graph e) + with e when Errors.noncritical e -> raise (Building_graph e) diff --git a/plugins/funind/rawterm_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index a314050f..5c91292b 100644 --- a/plugins/funind/rawterm_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -9,8 +9,8 @@ val build_inductive : Names.identifier list -> (* The list of function name *) - (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *) + (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *) Topconstr.constr_expr list -> (* The list of function returned type *) - Rawterm.rawconstr list -> (* the list of body *) + Glob_term.glob_constr list -> (* the list of body *) unit diff --git a/plugins/funind/rawtermops.ml b/plugins/funind/glob_termops.ml index e31f1452..6cc932b1 100644 --- a/plugins/funind/rawtermops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,89 +1,89 @@ open Pp -open Rawterm +open Glob_term open Util open Names (* Ocaml 3.06 Map.S does not handle is_empty *) let idmap_is_empty m = m = Idmap.empty (* - Some basic functions to rebuild rawconstr + Some basic functions to rebuild glob_constr In each of them the location is Util.dummy_loc *) -let mkRRef ref = RRef(dummy_loc,ref) -let mkRVar id = RVar(dummy_loc,id) -let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl) -let mkRLambda(n,t,b) = RLambda(dummy_loc,n,Explicit,t,b) -let mkRProd(n,t,b) = RProd(dummy_loc,n,Explicit,t,b) -let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b) -let mkRCases(rto,l,brl) = RCases(dummy_loc,Term.RegularStyle,rto,l,brl) -let mkRSort s = RSort(dummy_loc,s) -let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous) -let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) +let mkGRef ref = GRef(dummy_loc,ref) +let mkGVar id = GVar(dummy_loc,id) +let mkGApp(rt,rtl) = GApp(dummy_loc,rt,rtl) +let mkGLambda(n,t,b) = GLambda(dummy_loc,n,Explicit,t,b) +let mkGProd(n,t,b) = GProd(dummy_loc,n,Explicit,t,b) +let mkGLetIn(n,t,b) = GLetIn(dummy_loc,n,t,b) +let mkGCases(rto,l,brl) = GCases(dummy_loc,Term.RegularStyle,rto,l,brl) +let mkGSort s = GSort(dummy_loc,s) +let mkGHole () = GHole(dummy_loc,Evd.BinderType Anonymous) +let mkGCast(b,t) = GCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) (* - Some basic functions to decompose rawconstrs + Some basic functions to decompose glob_constrs These are analogous to the ones constrs *) -let raw_decompose_prod = - let rec raw_decompose_prod args = function - | RProd(_,n,k,t,b) -> - raw_decompose_prod ((n,t)::args) b +let glob_decompose_prod = + let rec glob_decompose_prod args = function + | GProd(_,n,k,t,b) -> + glob_decompose_prod ((n,t)::args) b | rt -> args,rt in - raw_decompose_prod [] - -let raw_decompose_prod_or_letin = - let rec raw_decompose_prod args = function - | RProd(_,n,k,t,b) -> - raw_decompose_prod ((n,None,Some t)::args) b - | RLetIn(_,n,t,b) -> - raw_decompose_prod ((n,Some t,None)::args) b + glob_decompose_prod [] + +let glob_decompose_prod_or_letin = + let rec glob_decompose_prod args = function + | GProd(_,n,k,t,b) -> + glob_decompose_prod ((n,None,Some t)::args) b + | GLetIn(_,n,t,b) -> + glob_decompose_prod ((n,Some t,None)::args) b | rt -> args,rt in - raw_decompose_prod [] + glob_decompose_prod [] -let raw_compose_prod = - List.fold_left (fun b (n,t) -> mkRProd(n,t,b)) +let glob_compose_prod = + List.fold_left (fun b (n,t) -> mkGProd(n,t,b)) -let raw_compose_prod_or_letin = +let glob_compose_prod_or_letin = List.fold_left ( fun concl decl -> match decl with - | (n,None,Some t) -> mkRProd(n,t,concl) - | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl) + | (n,None,Some t) -> mkGProd(n,t,concl) + | (n,Some bdy,None) -> mkGLetIn(n,bdy,concl) | _ -> assert false) -let raw_decompose_prod_n n = - let rec raw_decompose_prod i args c = +let glob_decompose_prod_n n = + let rec glob_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 + | GProd(_,n,_,t,b) -> + glob_decompose_prod (i-1) ((n,t)::args) b | rt -> args,rt in - raw_decompose_prod n [] + glob_decompose_prod n [] -let raw_decompose_prod_or_letin_n n = - let rec raw_decompose_prod i args c = +let glob_decompose_prod_or_letin_n n = + let rec glob_decompose_prod i args c = if i<=0 then args,c else match c with - | RProd(_,n,_,t,b) -> - raw_decompose_prod (i-1) ((n,None,Some t)::args) b - | RLetIn(_,n,t,b) -> - raw_decompose_prod (i-1) ((n,Some t,None)::args) b + | GProd(_,n,_,t,b) -> + glob_decompose_prod (i-1) ((n,None,Some t)::args) b + | GLetIn(_,n,t,b) -> + glob_decompose_prod (i-1) ((n,Some t,None)::args) b | rt -> args,rt in - raw_decompose_prod n [] + glob_decompose_prod n [] -let raw_decompose_app = +let glob_decompose_app = let rec decompose_rapp acc rt = -(* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *) +(* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) match rt with - | RApp(_,rt,rtl) -> + | GApp(_,rt,rtl) -> decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt | rt -> rt,List.rev acc in @@ -92,24 +92,24 @@ let raw_decompose_app = -(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) -let raw_make_eq ?(typ= mkRHole ()) t1 t2 = - mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) +(* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) +let glob_make_eq ?(typ= mkGHole ()) t1 t2 = + mkGApp(mkGRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) -(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) -let raw_make_neq t1 t2 = - mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2]) +(* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) +let glob_make_neq t1 t2 = + mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2]) -(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) -let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) +(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) +let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) -(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding +(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding to [P1 \/ ( .... \/ Pn)] *) -let rec raw_make_or_list = function +let rec glob_make_or_list = function | [] -> raise (Invalid_argument "mk_or") | [e] -> e - | e::l -> raw_make_or e (raw_make_or_list l) + | e::l -> glob_make_or e (glob_make_or_list l) let remove_name_from_mapping mapping na = @@ -120,70 +120,69 @@ let remove_name_from_mapping mapping na = let change_vars = let rec change_vars mapping rt = match rt with - | RRef _ -> rt - | RVar(loc,id) -> + | GRef _ -> rt + | GVar(loc,id) -> let new_id = try Idmap.find id mapping with Not_found -> id in - RVar(loc,new_id) - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> - RApp(loc, + GVar(loc,new_id) + | GEvar _ -> rt + | GPatVar _ -> rt + | GApp(loc,rt',rtl) -> + GApp(loc, change_vars mapping rt', List.map (change_vars mapping) rtl ) - | RLambda(loc,name,k,t,b) -> - RLambda(loc, + | GLambda(loc,name,k,t,b) -> + GLambda(loc, name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | RProd(loc,name,k,t,b) -> - RProd(loc, + | GProd(loc,name,k,t,b) -> + GProd(loc, name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | RLetIn(loc,name,def,b) -> - RLetIn(loc, + | GLetIn(loc,name,def,b) -> + GLetIn(loc, name, change_vars mapping def, change_vars (remove_name_from_mapping mapping name) b ) - | RLetTuple(loc,nal,(na,rto),b,e) -> + | GLetTuple(loc,nal,(na,rto),b,e) -> let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - RLetTuple(loc, + GLetTuple(loc, nal, (na, Option.map (change_vars mapping) rto), change_vars mapping b, change_vars new_mapping e ) - | RCases(loc,sty,infos,el,brl) -> - RCases(loc,sty, + | GCases(loc,sty,infos,el,brl) -> + GCases(loc,sty, infos, List.map (fun (e,x) -> (change_vars mapping e,x)) el, List.map (change_vars_br mapping) brl ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> - RIf(loc, + | GIf(loc,b,(na,e_option),lhs,rhs) -> + GIf(loc, change_vars mapping b, (na,Option.map (change_vars mapping) e_option), change_vars mapping lhs, change_vars mapping rhs ) - | RRec _ -> error "Local (co)fixes are not supported" - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv (k,t)) -> - RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) - | RCast(loc,b,CastCoerce) -> - RCast(loc,change_vars mapping b,CastCoerce) - | RDynamic _ -> error "Not handled RDynamic" + | GRec _ -> error "Local (co)fixes are not supported" + | GSort _ -> rt + | GHole _ -> rt + | GCast(loc,b,CastConv (k,t)) -> + GCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) + | GCast(loc,b,CastCoerce) -> + GCast(loc,change_vars mapping b,CastCoerce) and change_vars_br mapping ((loc,idl,patl,res) as br) = let new_mapping = List.fold_right Idmap.remove idl mapping in if idmap_is_empty new_mapping @@ -262,22 +261,22 @@ let get_pattern_id pat = raw_get_pattern_id pat [] let rec alpha_rt excluded rt = let new_rt = match rt with - | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt - | RLambda(loc,Anonymous,k,t,b) -> + | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt + | GLambda(loc,Anonymous,k,t,b) -> let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in let new_excluded = new_id :: excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - RLambda(loc,Name new_id,k,new_t,new_b) - | RProd(loc,Anonymous,k,t,b) -> + GLambda(loc,Name new_id,k,new_t,new_b) + | GProd(loc,Anonymous,k,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in - RProd(loc,Anonymous,k,new_t,new_b) - | RLetIn(loc,Anonymous,t,b) -> + GProd(loc,Anonymous,k,new_t,new_b) + | GLetIn(loc,Anonymous,t,b) -> let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in - RLetIn(loc,Anonymous,new_t,new_b) - | RLambda(loc,Name id,k,t,b) -> + GLetIn(loc,Anonymous,new_t,new_b) + | GLambda(loc,Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = if new_id = id @@ -289,8 +288,8 @@ let rec alpha_rt excluded rt = let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - RLambda(loc,Name new_id,k,new_t,new_b) - | RProd(loc,Name id,k,t,b) -> + GLambda(loc,Name new_id,k,new_t,new_b) + | GProd(loc,Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let new_excluded = new_id::excluded in let t,b = @@ -302,8 +301,8 @@ let rec alpha_rt excluded rt = in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - RProd(loc,Name new_id,k,new_t,new_b) - | RLetIn(loc,Name id,t,b) -> + GProd(loc,Name new_id,k,new_t,new_b) + | GLetIn(loc,Name id,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = if new_id = id @@ -315,10 +314,10 @@ let rec alpha_rt excluded rt = let new_excluded = new_id::excluded in let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - RLetIn(loc,Name new_id,new_t,new_b) + GLetIn(loc,Name new_id,new_t,new_b) - | RLetTuple(loc,nal,(na,rto),t,b) -> + | GLetTuple(loc,nal,(na,rto),t,b) -> let rev_new_nal,new_excluded,mapping = List.fold_left (fun (nal,excluded,mapping) na -> @@ -345,28 +344,27 @@ let rec alpha_rt excluded rt = let new_t = alpha_rt new_excluded new_t in let new_b = alpha_rt new_excluded new_b in let new_rto = Option.map (alpha_rt new_excluded) new_rto in - RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) - | RCases(loc,sty,infos,el,brl) -> + GLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) + | GCases(loc,sty,infos,el,brl) -> let new_el = List.map (function (rt,i) -> alpha_rt excluded rt, i) el in - RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) - | RIf(loc,b,(na,e_o),lhs,rhs) -> - RIf(loc,alpha_rt excluded b, + GCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) + | GIf(loc,b,(na,e_o),lhs,rhs) -> + GIf(loc,alpha_rt excluded b, (na,Option.map (alpha_rt excluded) e_o), alpha_rt excluded lhs, alpha_rt excluded rhs ) - | RRec _ -> error "Not handled RRec" - | RSort _ -> rt - | RHole _ -> rt - | RCast (loc,b,CastConv (k,t)) -> - RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) - | RCast (loc,b,CastCoerce) -> - RCast(loc,alpha_rt excluded b,CastCoerce) - | RDynamic _ -> error "Not handled RDynamic" - | RApp(loc,f,args) -> - RApp(loc, + | GRec _ -> error "Not handled GRec" + | GSort _ -> rt + | GHole _ -> rt + | GCast (loc,b,CastConv (k,t)) -> + GCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) + | GCast (loc,b,CastCoerce) -> + GCast(loc,alpha_rt excluded b,CastCoerce) + | GApp(loc,f,args) -> + GApp(loc, alpha_rt excluded f, List.map (alpha_rt excluded) args ) @@ -386,35 +384,34 @@ and alpha_br excluded (loc,ids,patl,res) = *) let is_free_in id = let rec is_free_in = function - | RRef _ -> false - | RVar(_,id') -> id_ord id' id == 0 - | REvar _ -> false - | RPatVar _ -> false - | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) - | RLambda(_,n,_,t,b) | RProd(_,n,_,t,b) | RLetIn(_,n,t,b) -> + | GRef _ -> false + | GVar(_,id') -> id_ord id' id == 0 + | GEvar _ -> false + | GPatVar _ -> false + | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) + | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) -> let check_in_b = match n with | Name id' -> id_ord id' id <> 0 | _ -> true in is_free_in t || (check_in_b && is_free_in b) - | RCases(_,_,_,el,brl) -> + | GCases(_,_,_,el,brl) -> (List.exists (fun (e,_) -> is_free_in e) el) || List.exists is_free_in_br brl - | RLetTuple(_,nal,_,b,t) -> + | GLetTuple(_,nal,_,b,t) -> let check_in_nal = not (List.exists (function Name id' -> id'= id | _ -> false) nal) in is_free_in t || (check_in_nal && is_free_in b) - | RIf(_,cond,_,br1,br2) -> + | GIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 - | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> false - | RHole _ -> false - | RCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t - | RCast (_,b,CastCoerce) -> is_free_in b - | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) + | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GSort _ -> false + | GHole _ -> false + | GCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t + | GCast (_,b,CastCoerce) -> is_free_in b and is_free_in_br (_,ids,_,rt) = (not (List.mem id ids)) && is_free_in rt in @@ -425,7 +422,7 @@ let is_free_in id = let rec pattern_to_term = function | PatVar(loc,Anonymous) -> assert false | PatVar(loc,Name id) -> - mkRVar id + mkGVar id | PatCstr(loc,constr,patternl,_) -> let cst_narg = Inductiveops.mis_constructor_nargs_env @@ -436,13 +433,13 @@ let rec pattern_to_term = function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun _ -> mkRHole ()) + (fun _ -> mkGHole ()) ) in let patl_as_term = List.map pattern_to_term patternl in - mkRApp(mkRRef(Libnames.ConstructRef constr), + mkGApp(mkGRef(Libnames.ConstructRef constr), implicit_args@patl_as_term ) @@ -451,69 +448,68 @@ let rec pattern_to_term = function let replace_var_by_term x_id term = let rec replace_var_by_pattern rt = match rt with - | RRef _ -> rt - | RVar(_,id) when id_ord id x_id == 0 -> term - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> - RApp(loc, + | GRef _ -> rt + | GVar(_,id) when id_ord id x_id == 0 -> term + | GVar _ -> rt + | GEvar _ -> rt + | GPatVar _ -> rt + | GApp(loc,rt',rtl) -> + GApp(loc, replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) - | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt - | RLambda(loc,name,k,t,b) -> - RLambda(loc, + | GLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | GLambda(loc,name,k,t,b) -> + GLambda(loc, name, k, replace_var_by_pattern t, replace_var_by_pattern b ) - | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt - | RProd(loc,name,k,t,b) -> - RProd(loc, + | GProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt + | GProd(loc,name,k,t,b) -> + GProd(loc, name, k, replace_var_by_pattern t, replace_var_by_pattern b ) - | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt - | RLetIn(loc,name,def,b) -> - RLetIn(loc, + | GLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt + | GLetIn(loc,name,def,b) -> + GLetIn(loc, name, replace_var_by_pattern def, replace_var_by_pattern b ) - | RLetTuple(_,nal,_,_,_) + | GLetTuple(_,nal,_,_,_) when List.exists (function Name id -> id = x_id | _ -> false) nal -> rt - | RLetTuple(loc,nal,(na,rto),def,b) -> - RLetTuple(loc, + | GLetTuple(loc,nal,(na,rto),def,b) -> + GLetTuple(loc, nal, (na,Option.map replace_var_by_pattern rto), replace_var_by_pattern def, replace_var_by_pattern b ) - | RCases(loc,sty,infos,el,brl) -> - RCases(loc,sty, + | GCases(loc,sty,infos,el,brl) -> + GCases(loc,sty, infos, List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, List.map replace_var_by_pattern_br brl ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> - RIf(loc, replace_var_by_pattern b, + | GIf(loc,b,(na,e_option),lhs,rhs) -> + GIf(loc, replace_var_by_pattern b, (na,Option.map replace_var_by_pattern e_option), replace_var_by_pattern lhs, replace_var_by_pattern rhs ) - | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv(k,t)) -> - RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) - | RCast(loc,b,CastCoerce) -> - RCast(loc,replace_var_by_pattern b,CastCoerce) - | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) + | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GSort _ -> rt + | GHole _ -> rt + | GCast(loc,b,CastConv(k,t)) -> + GCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) + | GCast(loc,b,CastCoerce) -> + GCast(loc,replace_var_by_pattern b,CastCoerce) and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = if List.exists (fun id -> id_ord id x_id == 0) idl then br @@ -538,7 +534,8 @@ let rec are_unifiable_aux = function else let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "are_unifiable_aux" + with e when Errors.noncritical e -> + anomaly "are_unifiable_aux" in are_unifiable_aux eqs' @@ -560,7 +557,8 @@ let rec eq_cases_pattern_aux = function else let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "eq_cases_pattern_aux" + with e when Errors.noncritical e -> + anomaly "eq_cases_pattern_aux" in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable @@ -586,28 +584,28 @@ let id_of_name = function | Names.Name x -> x (* TODO: finish Rec caes *) -let ids_of_rawterm c = - let rec ids_of_rawterm acc c = +let ids_of_glob_constr c = + let rec ids_of_glob_constr acc c = let idof = id_of_name in match c with - | RVar (_,id) -> id::acc - | RApp (loc,g,args) -> - ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc - | RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc - | RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc - | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc - | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc - | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc - | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc - | RLetTuple (_,nal,(na,po),b,c) -> - List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc - | RCases (loc,sty,rtntypopt,tml,brchl) -> - List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl) - | RRec _ -> failwith "Fix inside a constructor branch" - | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> [] + | GVar (_,id) -> id::acc + | GApp (loc,g,args) -> + ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc + | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc + | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc + | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc + | GCast (loc,c,CastConv(k,t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc + | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc + | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc + | GLetTuple (_,nal,(na,po),b,c) -> + List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc + | GCases (loc,sty,rtntypopt,tml,brchl) -> + List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_glob_constr [] c) brchl) + | GRec _ -> failwith "Fix inside a constructor branch" + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> [] in (* build the set *) - List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c) + List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_glob_constr [] c) @@ -616,59 +614,58 @@ let ids_of_rawterm c = let zeta_normalize = let rec zeta_normalize_term rt = match rt with - | RRef _ -> rt - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> - RApp(loc, + | GRef _ -> rt + | GVar _ -> rt + | GEvar _ -> rt + | GPatVar _ -> rt + | GApp(loc,rt',rtl) -> + GApp(loc, zeta_normalize_term rt', List.map zeta_normalize_term rtl ) - | RLambda(loc,name,k,t,b) -> - RLambda(loc, + | GLambda(loc,name,k,t,b) -> + GLambda(loc, name, k, zeta_normalize_term t, zeta_normalize_term b ) - | RProd(loc,name,k,t,b) -> - RProd(loc, + | GProd(loc,name,k,t,b) -> + GProd(loc, name, k, zeta_normalize_term t, zeta_normalize_term b ) - | RLetIn(_,Name id,def,b) -> + | GLetIn(_,Name id,def,b) -> zeta_normalize_term (replace_var_by_term id def b) - | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b - | RLetTuple(loc,nal,(na,rto),def,b) -> - RLetTuple(loc, + | GLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b + | GLetTuple(loc,nal,(na,rto),def,b) -> + GLetTuple(loc, nal, (na,Option.map zeta_normalize_term rto), zeta_normalize_term def, zeta_normalize_term b ) - | RCases(loc,sty,infos,el,brl) -> - RCases(loc,sty, + | GCases(loc,sty,infos,el,brl) -> + GCases(loc,sty, infos, List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, List.map zeta_normalize_br brl ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> - RIf(loc, zeta_normalize_term b, + | GIf(loc,b,(na,e_option),lhs,rhs) -> + GIf(loc, zeta_normalize_term b, (na,Option.map zeta_normalize_term e_option), zeta_normalize_term lhs, zeta_normalize_term rhs ) - | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv(k,t)) -> - RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) - | RCast(loc,b,CastCoerce) -> - RCast(loc,zeta_normalize_term b,CastCoerce) - | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) + | GRec _ -> raise (UserError("",str "Not handled GRec")) + | GSort _ -> rt + | GHole _ -> rt + | GCast(loc,b,CastConv(k,t)) -> + GCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) + | GCast(loc,b,CastCoerce) -> + GCast(loc,zeta_normalize_term b,CastCoerce) and zeta_normalize_br (loc,idl,patl,res) = (loc,idl,patl,zeta_normalize_term res) in @@ -688,29 +685,28 @@ let expand_as = in let rec expand_as map rt = match rt with - | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt - | RVar(_,id) -> + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> rt + | GVar(_,id) -> begin try Idmap.find id map with Not_found -> rt end - | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args) - | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b) - | RProd(loc,na,k,t,b) -> RProd(loc,na,k,expand_as map t, expand_as map b) - | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b) - | RLetTuple(loc,nal,(na,po),v,b) -> - RLetTuple(loc,nal,(na,Option.map (expand_as map) po), + | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args) + | GLambda(loc,na,k,t,b) -> GLambda(loc,na,k,expand_as map t, expand_as map b) + | GProd(loc,na,k,t,b) -> GProd(loc,na,k,expand_as map t, expand_as map b) + | GLetIn(loc,na,v,b) -> GLetIn(loc,na, expand_as map v,expand_as map b) + | GLetTuple(loc,nal,(na,po),v,b) -> + GLetTuple(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), + | GIf(loc,e,(na,po),br1,br2) -> + GIf(loc,expand_as map e,(na,Option.map (expand_as map) po), expand_as map br1, expand_as map br2) - | RRec _ -> error "Not handled RRec" - | RDynamic _ -> error "Not handled RDynamic" - | RCast(loc,b,CastConv(kind,t)) -> RCast(loc,expand_as map b,CastConv(kind,expand_as map t)) - | RCast(loc,b,CastCoerce) -> RCast(loc,expand_as map b,CastCoerce) - | RCases(loc,sty,po,el,brl) -> - RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, + | GRec _ -> error "Not handled GRec" + | GCast(loc,b,CastConv(kind,t)) -> GCast(loc,expand_as map b,CastConv(kind,expand_as map t)) + | GCast(loc,b,CastCoerce) -> GCast(loc,expand_as map b,CastCoerce) + | GCases(loc,sty,po,el,brl) -> + GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) and expand_as_br map (loc,idl,cpl,rt) = (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli new file mode 100644 index 00000000..bfd15357 --- /dev/null +++ b/plugins/funind/glob_termops.mli @@ -0,0 +1,126 @@ +open Glob_term + +(* Ocaml 3.06 Map.S does not handle is_empty *) +val idmap_is_empty : 'a Names.Idmap.t -> bool + + +(* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) +val get_pattern_id : cases_pattern -> Names.identifier list + +(* [pattern_to_term pat] returns a glob_constr corresponding to [pat]. + [pat] must not contain occurences of anonymous pattern +*) +val pattern_to_term : cases_pattern -> glob_constr + +(* + Some basic functions to rebuild glob_constr + In each of them the location is Util.dummy_loc +*) +val mkGRef : Libnames.global_reference -> glob_constr +val mkGVar : Names.identifier -> glob_constr +val mkGApp : glob_constr*(glob_constr list) -> glob_constr +val mkGLambda : Names.name * glob_constr * glob_constr -> glob_constr +val mkGProd : Names.name * glob_constr * glob_constr -> glob_constr +val mkGLetIn : Names.name * glob_constr * glob_constr -> glob_constr +val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr +val mkGSort : glob_sort -> glob_constr +val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) +val mkGCast : glob_constr* glob_constr -> glob_constr +(* + Some basic functions to decompose glob_constrs + These are analogous to the ones constrs +*) +val glob_decompose_prod : glob_constr -> (Names.name*glob_constr) list * glob_constr +val glob_decompose_prod_or_letin : + glob_constr -> (Names.name*glob_constr option*glob_constr option) list * glob_constr +val glob_decompose_prod_n : int -> glob_constr -> (Names.name*glob_constr) list * glob_constr +val glob_decompose_prod_or_letin_n : int -> glob_constr -> + (Names.name*glob_constr option*glob_constr option) list * glob_constr +val glob_compose_prod : glob_constr -> (Names.name*glob_constr) list -> glob_constr +val glob_compose_prod_or_letin: glob_constr -> + (Names.name*glob_constr option*glob_constr option) list -> glob_constr +val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list) + + +(* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) +val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr +(* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) +val glob_make_neq : glob_constr -> glob_constr -> glob_constr +(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *) +val glob_make_or : glob_constr -> glob_constr -> glob_constr + +(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding + to [P1 \/ ( .... \/ Pn)] +*) +val glob_make_or_list : glob_constr list -> glob_constr + + +(* alpha_conversion functions *) + + + +(* Replace the var mapped in the glob_constr/context *) +val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr + + + +(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. + the result does not share variables with [avoid]. This function create + a fresh variable for each occurence of the anonymous pattern. + + Also returns a mapping from old variables to new ones and the concatenation of + [avoid] with the variables appearing in the result. +*) + val alpha_pat : + Names.Idmap.key list -> + Glob_term.cases_pattern -> + Glob_term.cases_pattern * Names.Idmap.key list * + Names.identifier Names.Idmap.t + +(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt + conventions and does not share bound variables with avoid +*) +val alpha_rt : Names.identifier list -> glob_constr -> glob_constr + +(* same as alpha_rt but for case branches *) +val alpha_br : Names.identifier list -> + Util.loc * Names.identifier list * Glob_term.cases_pattern list * + Glob_term.glob_constr -> + Util.loc * Names.identifier list * Glob_term.cases_pattern list * + Glob_term.glob_constr + + +(* Reduction function *) +val replace_var_by_term : + Names.identifier -> + Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr + + + +(* + [is_free_in id rt] checks if [id] is a free variable in [rt] +*) +val is_free_in : Names.identifier -> glob_constr -> bool + + +val are_unifiable : cases_pattern -> cases_pattern -> bool +val eq_cases_pattern : cases_pattern -> cases_pattern -> bool + + + +(* + ids_of_pat : cases_pattern -> Idset.t + returns the set of variables appearing in a pattern +*) +val ids_of_pat : cases_pattern -> Names.Idset.t + +(* TODO: finish this function (Fix not treated) *) +val ids_of_glob_constr: glob_constr -> Names.Idset.t + +(* + removing let_in construction in a glob_constr +*) +val zeta_normalize : Glob_term.glob_constr -> Glob_term.glob_constr + + +val expand_as : glob_constr -> glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a61671f8..d2c065a0 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -4,7 +4,7 @@ open Term open Pp open Indfun_common open Libnames -open Rawterm +open Glob_term open Declarations let is_rec_info scheme_info = @@ -19,13 +19,11 @@ let is_rec_info scheme_info = in Util.list_fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) - let choose_dest_or_ind scheme_info = if is_rec_info scheme_info then Tactics.new_induct false else Tactics.new_destruct false - let functional_induction with_clean c princl pat = Dumpglob.pause (); let res = let f,args = decompose_app c in @@ -65,9 +63,8 @@ let functional_induction with_clean c princl pat = errorlabstrm "" (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in - (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ) + (princ,Glob_term.NoBindings, Tacmach.pf_type_of g princ) | _ -> raise (UserError("",str "functional induction must be used with a function" )) - end | Some ((princ,binding)) -> princ,binding,Tacmach.pf_type_of g princ @@ -78,14 +75,14 @@ let functional_induction with_clean c princl pat = if princ_infos.Tactics.farg_in_concl then [c] else [] in - List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) + List.map (fun c -> Tacexpr.ElimOnConstr (Evd.empty,(c,NoBindings))) (args@c_list) in let princ' = Some (princ,bindings) in let princ_vars = List.fold_right (fun a acc -> try Idset.add (destVar a) acc - with _ -> acc + with e when Errors.noncritical e -> acc ) args Idset.empty @@ -104,9 +101,9 @@ let functional_induction with_clean c princl pat = (Tacmach.pf_ids_of_hyps g) in let flag = - Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; + Glob_term.Cbv + {Glob_term.all_flags + with Glob_term.rDelta = false; } in Tacticals.tclTHEN @@ -114,7 +111,6 @@ let functional_induction with_clean c princl pat = (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl) g else Tacticals.tclIDTAC g - in Tacticals.tclTHEN (choose_dest_or_ind @@ -129,94 +125,78 @@ let functional_induction with_clean c princl pat = Dumpglob.continue (); res - - - -type annot = - Struct of identifier - | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list - | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list - - -type newfixpoint_expr = - identifier * annot * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr - -let rec abstract_rawconstr c = function +let rec abstract_glob_constr c = function | [] -> c - | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr c bl) + | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_glob_constr c bl) | Topconstr.LocalRawAssum (idl,k,t)::bl -> List.fold_right (fun x b -> Topconstr.mkLambdaC([x],k,t,b)) idl - (abstract_rawconstr c bl) + (abstract_glob_constr c bl) let interp_casted_constr_with_implicits sigma env impls c = -(* Constrintern.interp_rawconstr_with_implicits sigma env [] impls c *) Constrintern.intern_gen false sigma env ~impls ~allow_patvar:false ~ltacvars:([],[]) c - (* - Construct a fixpoint as a Rawterm + Construct a fixpoint as a Glob_term and not as a constr *) + let build_newrecursive -(lnameargsardef) = + lnameargsardef = let env0 = Global.env() and sigma = Evd.empty in let (rec_sign,rec_impls) = List.fold_left - (fun (env,impls) ((_,recname),_,bl,arityc,_) -> + (fun (env,impls) ((_,recname),bl,arityc,_) -> let arityc = Topconstr.prod_constr_expr arityc bl in let arity = Constrintern.interp_type sigma env0 arityc in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity [] in - (Environ.push_named (recname,None,arity) env, (recname, impl) :: impls)) - (env0,[]) lnameargsardef in + (Environ.push_named (recname,None,arity) env, Idmap.add recname impl impls)) + (env0,Constrintern.empty_internalization_env) lnameargsardef in let recdef = (* Declare local notations *) let fs = States.freeze() in let def = try List.map - (fun (_,_,bl,_,def) -> - let def = abstract_rawconstr def bl in + (fun (_,bl,_,def) -> + let def = abstract_glob_constr def bl in interp_casted_constr_with_implicits sigma rec_sign rec_impls def ) lnameargsardef - with e -> - States.unfreeze fs; raise e in + with reraise -> + States.unfreeze fs; raise reraise in States.unfreeze fs; def in recdef,rec_impls - -let compute_annot (name,annot,args,types,body) = - let names = List.map snd (Topconstr.names_of_local_assums args) in - match annot with - | None -> - if List.length names > 1 then - user_err_loc - (dummy_loc,"Function", - Pp.str "the recursive argument needs to be specified"); - let new_annot = (id_of_name (List.hd names)) in - (name,Struct new_annot,args,types,body) - | Some r -> (name,r,args,types,body) - +let build_newrecursive l = + let l' = List.map + (fun ((fixna,_,bll,ar,body_opt),lnot) -> + match body_opt with + | Some body -> + (fixna,bll,ar,body) + | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") + ) l + in + build_newrecursive l' (* Checks whether or not the mutual bloc is recursive *) let rec is_rec names = let names = List.fold_right Idset.add names Idset.empty in let check_id id names = Idset.mem id names in let rec lookup names = function - | RVar(_,id) -> check_id id names - | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false - | RCast(_,b,_) -> lookup names b - | RRec _ -> error "RRec not handled" - | RIf(_,b,_,lhs,rhs) -> + | GVar(_,id) -> check_id id names + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> false + | GCast(_,b,_) -> lookup names b + | GRec _ -> error "GRec not handled" + | GIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) - | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b) -> + | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b) -> lookup names t || lookup (Nameops.name_fold Idset.remove na names) b - | RLetTuple(_,nal,_,t,b) -> lookup names t || + | GLetTuple(_,nal,_,t,b) -> lookup names t || lookup (List.fold_left (fun acc na -> Nameops.name_fold Idset.remove na acc) @@ -224,8 +204,8 @@ let rec is_rec names = nal ) b - | RApp(_,f,args) -> List.exists (lookup names) (f::args) - | RCases(_,_,_,el,brl) -> + | GApp(_,f,args) -> List.exists (lookup names) (f::args) + | GCases(_,_,_,el,brl) -> List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl and lookup_br names (_,idl,_,rt) = @@ -240,9 +220,9 @@ let rec local_binders_length = function | Topconstr.LocalRawDef _::bl -> 1 + local_binders_length bl | Topconstr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl -let prepare_body (name,annot,args,types,body) rt = +let prepare_body ((name,_,args,types,_),_) rt = let n = local_binders_length args in -(* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *) +(* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') @@ -251,7 +231,7 @@ 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 + List.map (fun id -> destConst (Constrintern.global_reference id)) fix_names in (* Then we check that the graphs have been defined @@ -268,20 +248,22 @@ let derive_inversion fix_names = Ensures by : register_built i*) (List.map - (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) + (fun id -> destInd (Constrintern.global_reference (mk_rel_id id))) fix_names ) - with e -> + with e when Errors.noncritical e -> + let e' = Cerrors.process_vernac_interp_error e in msg_warning - (str "Cannot built inversion information" ++ - if do_observe () then Cerrors.explain_exn e else mt ()) - with _ -> () + (str "Cannot build inversion information" ++ + if do_observe () then (fnl() ++ Errors.print e') else mt ()) + with e when Errors.noncritical e -> () let warning_error names e = + let e = Cerrors.process_vernac_interp_error e in let e_explain e = match e with - | ToShow e -> spc () ++ Cerrors.explain_exn e - | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt () + | ToShow e -> spc () ++ Errors.print e + | _ -> if do_observe () then (spc () ++ Errors.print e) else mt () in match e with | Building_graph e -> @@ -297,10 +279,11 @@ let warning_error names e = | _ -> raise e let error_error names e = + let e = Cerrors.process_vernac_interp_error e in let e_explain e = match e with - | ToShow e -> spc () ++ Cerrors.explain_exn e - | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt () + | ToShow e -> spc () ++ Errors.print e + | _ -> if do_observe () then (spc () ++ Errors.print e) else mt () in match e with | Building_graph e -> @@ -311,16 +294,16 @@ let error_error names e = | _ -> raise e let generate_principle on_error - is_general do_built fix_rec_l recdefs interactive_proof + is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) 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 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 + let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in try (* We then register the Inductive graphs of the functions *) - Rawterm_to_relation.build_inductive names funs_args funs_types recdefs; + Glob_term_to_relation.build_inductive names funs_args funs_types recdefs; if do_built then begin @@ -334,7 +317,7 @@ let generate_principle on_error locate_ind f_R_mut) in - let fname_kn (fname,_,_,_,_) = + let fname_kn ((fname,_,_,_,_),_) = let f_ref = Ident fname in locate_with_msg (pr_reference f_ref++str ": Not an inductive type!") @@ -363,24 +346,21 @@ let generate_principle on_error Array.iter (add_Function is_general) funs_kn; () end - with e -> + with e when Errors.noncritical e -> on_error names e -let register_struct is_rec fixpoint_exprl = +let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> + let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in let ce,imps = - Command.interp_definition - (Flags.boxed_definitions ()) bl None body (Some ret_type) + Command.interp_definition bl None body (Some ret_type) in Command.declare_definition fname (Decl_kinds.Global,Decl_kinds.Definition) ce imps (fun _ _ -> ()) | _ -> - let fixpoint_exprl = - List.map (fun ((name,annot,bl,types,body),ntn) -> - ((name,annot,bl,types,Some body),ntn)) fixpoint_exprl in - Command.do_fixpoint fixpoint_exprl (Flags.boxed_definitions()) + Command.do_fixpoint fixpoint_exprl let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation @@ -402,8 +382,8 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas in match wf_arg with | None -> - if List.length names = 1 then 1 - else error "Recursive argument must be specified" + if List.length names = 1 then 1 + else error "Recursive argument must be specified" | Some wf_arg -> list_index (Name wf_arg) names in @@ -433,7 +413,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); derive_inversion [fname] - with e -> + with e when Errors.noncritical e -> (* No proof done *) () in @@ -447,7 +427,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas using_lemmas -let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = +let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = let wf_arg_type,wf_arg = match wf_arg with | None -> @@ -473,28 +453,186 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b | _ -> assert false with Not_found -> assert false in - let ltof = - let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in - Libnames.Qualid (dummy_loc,Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof"))) - in - let fun_from_mes = - let applied_mes = - Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in - Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) - in - let wf_rel_from_mes = - Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) - in - register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) + let wf_rel_from_mes,is_mes = + match wf_rel_expr_opt with + | None -> + let ltof = + let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in + Libnames.Qualid (dummy_loc,Libnames.qualid_of_path + (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof"))) + in + let fun_from_mes = + let applied_mes = + Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in + Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) + in + let wf_rel_from_mes = + Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) + in + wf_rel_from_mes,true + | Some wf_rel_expr -> + let wf_rel_with_mes = + let a = Names.id_of_string "___a" in + let b = Names.id_of_string "___b" in + Topconstr.mkLambdaC( + [dummy_loc,Name a;dummy_loc,Name b], + Topconstr.Default Lib.Explicit, + wf_arg_type, + Topconstr.mkAppC(wf_rel_expr, + [ + Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC a]); + Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC b]) + ]) + ) + in + wf_rel_with_mes,false + in + register_wf ~is_mes:is_mes fname rec_impls wf_rel_from_mes (Some wf_arg) using_lemmas args ret_type body +let map_option f = function + | None -> None + | Some v -> Some (f v) + +let decompose_lambda_n_assum_constr_expr = + let rec decompose_lambda_n_assum_constr_expr acc n e = + if n = 0 then (List.rev acc,e) + else + match e with + | Topconstr.CLambdaN(_, [],e') -> decompose_lambda_n_assum_constr_expr acc n e' + | Topconstr.CLambdaN(lambda_loc,(nal,bk,nal_type)::bl,e') -> + let nal_length = List.length nal in + if nal_length <= n + then + decompose_lambda_n_assum_constr_expr + (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) + (n - nal_length) + (Topconstr.CLambdaN(lambda_loc,bl,e')) + else + let nal_keep,nal_expr = list_chop n nal in + (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc), + Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e') + ) + | Topconstr.CLetIn(_, na,nav,e') -> + decompose_lambda_n_assum_constr_expr + (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e' + | _ -> error "Not enough product or assumption" + in + decompose_lambda_n_assum_constr_expr [] + +let decompose_prod_n_assum_constr_expr = + let rec decompose_prod_n_assum_constr_expr acc n e = + (* Pp.msgnl (str "n := " ++ int n ++ fnl ()++ *) + (* str "e := " ++ Ppconstr.pr_lconstr_expr e); *) + if n = 0 then + (* let _ = Pp.msgnl (str "return_type := " ++ Ppconstr.pr_lconstr_expr e) in *) + (List.rev acc,e) + else + match e with + | Topconstr.CProdN(_, [],e') -> decompose_prod_n_assum_constr_expr acc n e' + | Topconstr.CProdN(lambda_loc,(nal,bk,nal_type)::bl,e') -> + let nal_length = List.length nal in + if nal_length <= n + then + (* let _ = Pp.msgnl (str "first case") in *) + decompose_prod_n_assum_constr_expr + (Topconstr.LocalRawAssum(nal,bk,nal_type)::acc) + (n - nal_length) + (if bl = [] then e' else (Topconstr.CLambdaN(lambda_loc,bl,e'))) + else + (* let _ = Pp.msgnl (str "second case") in *) + let nal_keep,nal_expr = list_chop n nal in + (List.rev (Topconstr.LocalRawAssum(nal_keep,bk,nal_type)::acc), + Topconstr.CLambdaN(lambda_loc,(nal_expr,bk,nal_type)::bl,e') + ) + | Topconstr.CArrow(_,premisse,concl) -> + (* let _ = Pp.msgnl (str "arrow case") in *) + decompose_prod_n_assum_constr_expr + (Topconstr.LocalRawAssum([dummy_loc,Names.Anonymous], + Topconstr.Default Lib.Explicit,premisse) + ::acc) + (pred n) + concl + | Topconstr.CLetIn(_, na,nav,e') -> + decompose_prod_n_assum_constr_expr + (Topconstr.LocalRawDef(na,nav)::acc) (pred n) e' + | _ -> error "Not enough product or assumption" + in + decompose_prod_n_assum_constr_expr [] -let do_generate_principle on_error register_built interactive_proof fixpoint_exprl = - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in +open Topconstr + +let id_of_name = function + | Name id -> id + | _ -> assert false + + let rec rebuild_bl (aux,assoc) bl typ = + match bl,typ with + | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc) + | (Topconstr.LocalRawAssum(nal,bk,_))::bl',typ -> + rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ + | (Topconstr.LocalRawDef(na,_))::bl',CLetIn(_,_,nat,typ') -> + rebuild_bl ((Topconstr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc) + bl' typ' + | _ -> assert false + and rebuild_nal (aux,assoc) bk bl' nal lnal typ = + match nal,typ with + | [], _ -> rebuild_bl (aux,assoc) bl' typ + | na::nal,CArrow(_,nat,typ') -> + rebuild_nal + ((LocalRawAssum([na],bk,replace_vars_constr_expr assoc nat))::aux,assoc) + bk bl' nal (pred lnal) typ' + | _,CProdN(_,[],typ) -> rebuild_nal (aux,assoc) bk bl' nal lnal typ + | _,CProdN(_,(nal',bk',nal't)::rest,typ') -> + let lnal' = List.length nal' in + if lnal' >= lnal + then + let old_nal',new_nal' = list_chop lnal nal' in + rebuild_bl ((LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't)::aux),(List.rev_append (List.combine (List.map id_of_name (List.map snd old_nal')) (List.map id_of_name (List.map snd nal))) assoc)) bl' + (if new_nal' = [] && rest = [] + then typ' + else if new_nal' = [] + then CProdN(dummy_loc,rest,typ') + else CProdN(dummy_loc,((new_nal',bk',nal't)::rest),typ')) + else + let captured_nal,non_captured_nal = list_chop lnal' nal in + rebuild_nal ((LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't)::aux), (List.rev_append (List.combine (List.map id_of_name (List.map snd captured_nal)) ((List.map id_of_name (List.map snd nal)))) assoc)) + bk bl' non_captured_nal (lnal - lnal') (CProdN(dummy_loc,rest,typ')) + | _ -> assert false + +let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ + +let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = + let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in + let ((_,_,typel),_) = Command.interp_fixpoint fixl ntns in + let constr_expr_typel = + with_full_print (List.map (Constrextern.extern_constr false (Global.env ()))) typel in + let fixpoint_exprl_with_new_bl = + List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> + + let new_bl',new_ret_type,_ = rebuild_bl ([],[]) bl fix_typ in + (((lna,(rec_arg_opt,rec_order),new_bl',new_ret_type,opt_body),notation_list):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + ) + fixpoint_exprl constr_expr_typel + in + fixpoint_exprl_with_new_bl + + +let do_generate_principle on_error register_built interactive_proof + (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) :unit = + List.iter (fun (_,l) -> if l <> [] then error "Function does not support notations for now") fixpoint_exprl; let _is_struct = match fixpoint_exprl with - | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> + | [((_,(wf_x,Topconstr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> + let ((((_,name),_,args,types,body)),_) as fixpoint_expr = + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in let pre_hook = generate_principle on_error @@ -505,9 +643,18 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp true in if register_built - then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook; + then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook; false - | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> + |[((_,(wf_x,Topconstr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> + let ((((_,name),_,args,types,body)),_) as fixpoint_expr = + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in + let body = match body with | Some body -> body | None -> user_err_loc (dummy_loc,"Function",str "Body of Function must be given") in let pre_hook = generate_principle on_error @@ -518,56 +665,35 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp true in if register_built - then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook; + then register_mes name rec_impls wf_mes wf_rel_opt (map_option snd wf_x) using_lemmas args types body pre_hook; true | _ -> - let fix_names = - List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl - in - let is_one_rec = is_rec fix_names in - let old_fixpoint_exprl = - List.map - (function - | (name,Some (Struct id),args,types,body),_ -> - let annot = - try Some (dummy_loc, id), Topconstr.CStructRec - with Not_found -> - raise (UserError("",str "Cannot find argument " ++ - Ppconstr.pr_id id)) - in - (name,annot,args,types,body),([]:Vernacexpr.decl_notation list) - | (name,None,args,types,body),recdef -> - let names = (Topconstr.names_of_local_assums args) in - if is_one_rec recdef && List.length names > 1 then - user_err_loc - (dummy_loc,"Function", - Pp.str "the recursive argument needs to be specified in Function") - else - let loc, na = List.hd names in - (name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body), - ([]:Vernacexpr.decl_notation list) - | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> - error - ("Cannot use mutual definition with well-founded recursion or measure") - ) - (List.combine fixpoint_exprl recdefs) - in + List.iter (function ((_na,(_,ord),_args,_body,_type),_not) -> + match ord with + | Topconstr.CMeasureRec _ | Topconstr.CWfRec _ -> + error + ("Cannot use mutual definition with well-founded recursion or measure") + | _ -> () + ) + fixpoint_exprl; + let fixpoint_exprl = recompute_binder_list fixpoint_exprl in + let fix_names = + List.map (function (((_,name),_,_,_,_),_) -> name) fixpoint_exprl + in (* ok all the expressions are structural *) - let fix_names = - List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl - in - let is_rec = List.exists (is_rec fix_names) recdefs in - if register_built then register_struct is_rec old_fixpoint_exprl; - generate_principle - on_error - false - register_built - fixpoint_exprl - recdefs - interactive_proof - (Functional_principles_proofs.prove_princ_for_struct interactive_proof); - if register_built then derive_inversion fix_names; - true; + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let is_rec = List.exists (is_rec fix_names) recdefs in + if register_built then register_struct is_rec fixpoint_exprl; + generate_principle + on_error + false + register_built + fixpoint_exprl + recdefs + interactive_proof + (Functional_principles_proofs.prove_princ_for_struct interactive_proof); + if register_built then derive_inversion fix_names; + true; in () @@ -638,7 +764,6 @@ let rec add_args id new_args b = | CGeneralization _ -> anomaly "add_args : CGeneralization" | CPrim _ -> b | CDelimiters _ -> anomaly "add_args : CDelimiters" - | CDynamic _ -> anomaly "add_args : CDynamic" exception Stop of Topconstr.constr_expr @@ -701,75 +826,71 @@ let rec get_args b t : Topconstr.local_binder list * let make_graph (f_ref:global_reference) = - let c,c_body = - match f_ref with - | ConstRef c -> - begin try c,Global.lookup_constant c - with Not_found -> - raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) - end - | _ -> raise (UserError ("", str "Not a function reference") ) - + let c,c_body = + match f_ref with + | ConstRef c -> + begin try c,Global.lookup_constant c + with Not_found -> + raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) + end + | _ -> raise (UserError ("", str "Not a function reference") ) in - Dumpglob.pause (); - (match c_body.const_body with - | None -> error "Cannot build a graph over an axiom !" - | Some b -> - let env = Global.env () in - let body = (force b) in - let extern_body,extern_type = - with_full_print - (fun () -> - (Constrextern.extern_constr false env body, - Constrextern.extern_type false env - (Typeops.type_of_constant_type env c_body.const_type) - ) - ) - () - in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b with - | Topconstr.CFix(loc,l_id,fixexprl) -> - let l = - List.map - (fun (id,(n,recexp),bl,t,b) -> - let loc, rec_id = Option.get n in - let new_args = - List.flatten - (List.map - (function - | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_,_) -> - List.map - (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n))) - nal - ) - nal_tas - ) - in - let b' = add_args (snd id) new_args b in - (id, Some (Struct rec_id),nal_tas@bl,t,b') - ) - fixexprl - in - l - | _ -> - let id = id_of_label (con_label c) in - [((dummy_loc,id),None,nal_tas,t,b)] - in - do_generate_principle error_error false false expr_list; - (* We register the infos *) - let mp,dp,_ = repr_con c in - List.iter - (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) - expr_list); + Dumpglob.pause (); + (match body_of_constant c_body with + | None -> error "Cannot build a graph over an axiom !" + | Some b -> + let env = Global.env () in + let body = (force b) in + let extern_body,extern_type = + with_full_print + (fun () -> + (Constrextern.extern_constr false env body, + Constrextern.extern_type false env + (Typeops.type_of_constant_type env c_body.const_type) + ) + ) + () + in + let (nal_tas,b,t) = get_args extern_body extern_type in + let expr_list = + match b with + | Topconstr.CFix(loc,l_id,fixexprl) -> + let l = + List.map + (fun (id,(n,recexp),bl,t,b) -> + let loc, rec_id = Option.get n in + let new_args = + List.flatten + (List.map + (function + | Topconstr.LocalRawDef (na,_)-> [] + | Topconstr.LocalRawAssum (nal,_,_) -> + List.map + (fun (loc,n) -> + CRef(Libnames.Ident(loc, Nameops.out_name n))) + nal + ) + nal_tas + ) + in + let b' = add_args (snd id) new_args b in + (((id, ( Some (dummy_loc,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + ) + fixexprl + in + l + | _ -> + let id = id_of_label (con_label c) in + [((dummy_loc,id),(None,Topconstr.CStructRec),nal_tas,t,Some b),[]] + in + do_generate_principle error_error false false expr_list; + (* We register the infos *) + let mp,dp,_ = repr_con c in + List.iter + (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (label_of_id id))) + expr_list); Dumpglob.continue () - -(* let make_graph _ = assert false *) - let do_generate_principle = do_generate_principle warning_error true diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli new file mode 100644 index 00000000..e65b5808 --- /dev/null +++ b/plugins/funind/indfun.mli @@ -0,0 +1,24 @@ +open Util +open Names +open Term +open Pp +open Indfun_common +open Libnames +open Glob_term +open Declarations + +val do_generate_principle : + bool -> + (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list -> + unit + + +val functional_induction : + bool -> + Term.constr -> + (Term.constr * Term.constr Glob_term.bindings) option -> + Genarg.intro_pattern_expr Util.located option -> + Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma + + +val make_graph : Libnames.global_reference -> unit diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 0f048f59..827191b1 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -55,7 +55,6 @@ let locate_with_msg msg f x = f x with | Not_found -> raise (Util.UserError("", msg)) - | e -> raise e let filter_map filter f = @@ -76,8 +75,8 @@ let chop_rlambda_n = then List.rev acc,rt else match rt with - | Rawterm.RLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b - | Rawterm.RLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b + | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b + | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b | _ -> raise (Util.UserError("chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) @@ -90,7 +89,7 @@ let chop_rprod_n = then List.rev acc,rt else match rt with - | Rawterm.RProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b + | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b | _ -> raise (Util.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -120,10 +119,10 @@ let const_of_id id = let def_of_const t = match (Term.kind_of_term t) with Term.Const sp -> - (try (match (Global.lookup_constant sp) with - {Declarations.const_body=Some c} -> Declarations.force c - |_ -> assert false) - with _ -> assert false) + (try (match Declarations.body_of_constant (Global.lookup_constant sp) with + | Some c -> Declarations.force c + | _ -> assert false) + with e when Errors.noncritical e -> assert false) |_ -> assert false let coq_constant s = @@ -158,6 +157,7 @@ let definition_message id = let save with_clean id const (locality,kind) hook = let {const_entry_body = pft; + const_entry_secctx = _; const_entry_type = tpo; const_entry_opaque = opacity } = const in let l,r = match locality with @@ -180,48 +180,9 @@ let save with_clean id const (locality,kind) hook = - -let extract_pftreestate pts = - let pfterm,subgoals = Refiner.extract_open_pftreestate pts in - let tpfsigma = Refiner.evc_of_pftreestate pts in - let exl = Evarutil.non_instantiated tpfsigma in - if subgoals <> [] or exl <> [] then - Util.errorlabstrm "extract_proof" - (if subgoals <> [] then - str "Attempt to save an incomplete proof" - else - str "Attempt to save a proof with existential variables still non-instantiated"); - let env = Global.env_of_context (Refiner.proof_of_pftreestate pts).Proof_type.goal.Evd.evar_hyps in - env,tpfsigma,pfterm - - -let nf_betaiotazeta = - let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiotazeta - -let nf_betaiota = - let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiota - -let cook_proof do_reduce = - let pfs = Pfedit.get_pftreestate () -(* and ident = Pfedit.get_current_proof_name () *) - and (ident,strength,concl,hook) = Pfedit.current_proof_statement () in - let env,sigma,pfterm = extract_pftreestate pfs in - let pfterm = - if do_reduce - then nf_betaiota env sigma pfterm - else pfterm - in - (ident, - ({ const_entry_body = pfterm; - const_entry_type = Some concl; - const_entry_opaque = false; - const_entry_boxed = false}, - strength, hook)) - +let cook_proof _ = + let (id,(entry,_,strength,hook)) = Pfedit.cook_proof (fun _ -> ()) in + (id,(entry,strength,hook)) let new_save_named opacity = let id,(const,persistence,hook) = cook_proof true in @@ -253,13 +214,13 @@ let with_full_print f a = Dumpglob.continue (); res with - | e -> + | reraise -> Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Dumpglob.continue (); - raise e + raise reraise @@ -388,7 +349,8 @@ open Term let pr_info f_info = str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ str "function_constant_type := " ++ - (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++ + (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) + with e when Errors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++ @@ -401,7 +363,7 @@ 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 = +let in_Function : function_info -> Libobject.obj = Libobject.declare_object {(Libobject.default_object "FUNCTIONS_DB") with Libobject.cache_function = cache_Function; @@ -490,6 +452,7 @@ open Goptions let functional_induction_rewrite_dependent_proofs_sig = { optsync = false; + optdepr = false; optname = "Functional Induction Rewrite Dependent"; optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; optread = (fun () -> !functional_induction_rewrite_dependent_proofs); @@ -502,6 +465,7 @@ let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = t let function_debug_sig = { optsync = false; + optdepr = false; optname = "Function debug"; optkey = ["Function_debug"]; optread = (fun () -> !function_debug); @@ -521,6 +485,7 @@ let is_strict_tcc () = !strict_tcc let strict_tcc_sig = { optsync = false; + optdepr = false; optname = "Raw Function Tcc"; optkey = ["Function_raw_tcc"]; optread = (fun () -> !strict_tcc); @@ -537,22 +502,22 @@ exception ToShow of exn let init_constant dir s = try Coqlib.gen_constant "Function" dir s - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) let jmeq () = try (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq") - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) let jmeq_rec () = try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_rec" - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_refl" - with e -> raise (ToShow e) + with e when Errors.noncritical e -> raise (ToShow e) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 6f6607fc..e0076735 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -35,11 +35,11 @@ val list_union_eq : val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list -val chop_rlambda_n : int -> Rawterm.rawconstr -> - (name*Rawterm.rawconstr*bool) list * Rawterm.rawconstr +val chop_rlambda_n : int -> Glob_term.glob_constr -> + (name*Glob_term.glob_constr*bool) list * Glob_term.glob_constr -val chop_rprod_n : int -> Rawterm.rawconstr -> - (name*Rawterm.rawconstr) list * Rawterm.rawconstr +val chop_rprod_n : int -> Glob_term.glob_constr -> + (name*Glob_term.glob_constr) list * Glob_term.glob_constr val def_of_const : Term.constr -> Term.constr val eq : Term.constr Lazy.t @@ -50,15 +50,8 @@ val jmeq_refl : unit -> Term.constr (* [save_named] is a copy of [Command.save_named] but uses [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] - - - - DON'T USE IT if you cannot ensure that there is no VMcast in the proof - *) -(* val nf_betaiotazeta : Reductionops.reduction_function *) - val new_save_named : bool -> unit val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index aa42f6cd..7b5dd763 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,7 +16,6 @@ open Tacticals open Tactics open Indfun_common open Tacmach -open Termops open Sign open Hiddentac @@ -24,17 +23,17 @@ open Hiddentac let pr_binding prc = function - | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) - | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) + | loc, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) + | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) let pr_bindings prc prlc = function - | Rawterm.ImplicitBindings l -> + | Glob_term.ImplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc prc l - | Rawterm.ExplicitBindings l -> + | Glob_term.ExplicitBindings l -> brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l - | Rawterm.NoBindings -> mt () + | Glob_term.NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = @@ -60,13 +59,17 @@ let observennl strm = let do_observe_tac s tac g = - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + let goal = + try Printer.pr_goal g + with e when Errors.noncritical e -> assert false + in try let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v - with e -> + with reraise -> + let e' = Cerrors.process_vernac_interp_error reraise in msgnl (str "observation "++ s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); - raise e;; + Errors.print e' ++ str " on goal " ++ goal ); + raise reraise;; let observe_tac s tac g = @@ -84,7 +87,7 @@ let nf_zeta = (* [id_to_constr id] finds the term associated to [id] in the global environment *) let id_to_constr id = try - Tacinterp.constr_of_id (Global.env ()) id + Constrintern.global_reference id with Not_found -> raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) @@ -248,7 +251,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem | [] | [_] | [_;_] -> anomaly "bad context" | hres::res::(x,_,t)::ctxt -> Termops.it_mkLambda_or_LetIn - ~init:(Termops.it_mkProd_or_LetIn ~init:concl [hres;res]) + (Termops.it_mkProd_or_LetIn concl [hres;res]) ((x,None,t)::ctxt) ) lemmas_types_infos @@ -313,7 +316,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem | None -> (id::pre_args,pre_tac) | Some b -> (pre_args, - tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac + tclTHEN (h_reduce (Glob_term.Unfold([Glob_term.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac ) else (pre_args,pre_tac) @@ -395,10 +398,10 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem observe_tac "unfolding" pre_tac; (* $zeta$ normalizing of the conclusion *) h_reduce - (Rawterm.Cbv - { Rawterm.all_flags with - Rawterm.rDelta = false ; - Rawterm.rConst = [] + (Glob_term.Cbv + { Glob_term.all_flags with + Glob_term.rDelta = false ; + Glob_term.rConst = [] } ) onConcl; @@ -424,7 +427,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Namegen.next_ident_away (Nameops.out_name x) avoid in - (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid + (dummy_loc,Glob_term.NamedHyp id,p)::bindings,id::avoid ) ([],pf_ids_of_hyps g) princ_infos.params @@ -434,12 +437,12 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem List.rev (fst (List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> let id = Namegen.next_ident_away (Nameops.out_name x) avoid in - (dummy_loc,Rawterm.NamedHyp id,(nf_zeta p))::bindings,id::avoid) + (dummy_loc,Glob_term.NamedHyp id,(nf_zeta p))::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) in - Rawterm.ExplicitBindings (params_bindings@lemmas_bindings) + Glob_term.ExplicitBindings (params_bindings@lemmas_bindings) in tclTHENSEQ [ observe_tac "intro args_names" (tclMAP h_intro args_names); @@ -526,15 +529,15 @@ and intros_with_rewrite_aux : tactic = Tauto.tauto g | Case(_,_,v,_) -> tclTHENSEQ[ - h_case false (v,Rawterm.NoBindings); + h_case false (v,Glob_term.NoBindings); intros_with_rewrite ] g | LetIn _ -> tclTHENSEQ[ h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; + (Glob_term.Cbv + {Glob_term.all_flags + with Glob_term.rDelta = false; }) onConcl ; @@ -547,9 +550,9 @@ and intros_with_rewrite_aux : tactic = | LetIn _ -> tclTHENSEQ[ h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; + (Glob_term.Cbv + {Glob_term.all_flags + with Glob_term.rDelta = false; }) onConcl ; @@ -563,12 +566,12 @@ let rec reflexivity_with_destruct_cases g = match kind_of_term (snd (destApp (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ - h_case false (v,Rawterm.NoBindings); + h_case false (v,Glob_term.NoBindings); intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] | _ -> reflexivity - with _ -> reflexivity + with e when Errors.noncritical e -> reflexivity in let eq_ind = Coqlib.build_coq_eq () in let discr_inject = @@ -588,15 +591,15 @@ let rec reflexivity_with_destruct_cases g = ) in (tclFIRST - [ reflexivity; - tclTHEN (tclPROGRESS discr_inject) (destruct_case ()); + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity; + observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); (* We reach this point ONLY if the same value is matched (at least) two times along binding path. In this case, either we have a discriminable hypothesis and we are done, either at least an injectable one and we do the injection before continuing *) - tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases + observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) ]) g @@ -636,7 +639,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) + (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) @@ -686,16 +689,16 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = Equality.rewriteLR (mkConst eq_lemma); (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) h_reduce - (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; + (Glob_term.Cbv + {Glob_term.all_flags + with Glob_term.rDelta = false; }) onConcl ; h_generalize (List.map mkVar ids); thin ids ] - else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))] + else unfold_in_concl [(Termops.all_occurrences, Names.EvalConstRef (destConst f))] in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -733,7 +736,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); h_intro graph_principle_id; observe_tac "" (tclTHEN_i - (observe_tac "elim" ((elim false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings))))) + (observe_tac "elim" ((elim false (mkVar hres,Glob_term.NoBindings) (Some (mkVar graph_principle_id,Glob_term.NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g @@ -752,6 +755,7 @@ let do_save () = Lemmas.save_named false *) let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = + let previous_state = States.freeze () in let funs = Array.of_list funs and graphs = Array.of_list graphs in let funs_constr = Array.map mkConst funs in try @@ -763,7 +767,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type false const_of_f graph i in - let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info @@ -784,7 +788,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g (fun entry -> (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type ) ) - (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs)) + (make_scheme (array_map_to_list (fun const -> const,Glob_term.GType None) funs)) ) in let proving_tac = @@ -793,22 +797,21 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g Array.iteri (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in - Lemmas.start_proof - (*i The next call to mk_correct_id is valid since we are constructing the lemma + (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious - i*) - (mk_correct_id f_id) + i*) + let lem_id = mk_correct_id f_id in + Lemmas.start_proof lem_id (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); - Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i)); + Pfedit.by + (observe_tac ("prove correctness ("^(string_of_id f_id)^")") + (proving_tac i)); do_save (); let finfo = find_Function_infos f_as_constant in - update_Function - {finfo with - correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id))) - } - + let lem_cst = destConst (Constrintern.global_reference lem_id) in + update_Function {finfo with correctness_lemma = Some lem_cst} ) funs; let lemmas_types_infos = @@ -818,7 +821,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type true const_of_f graph i in - let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info @@ -845,35 +848,28 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g Array.iteri (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in - Lemmas.start_proof - (*i The next call to mk_complete_id is valid since we are constructing the lemma + (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious - i*) - (mk_complete_id f_id) + i*) + let lem_id = mk_complete_id f_id in + Lemmas.start_proof lem_id (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); - Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i)); + Pfedit.by + (observe_tac ("prove completeness ("^(string_of_id f_id)^")") + (proving_tac i)); do_save (); let finfo = find_Function_infos f_as_constant in - update_Function - {finfo with - completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id))) - } + let lem_cst = destConst (Constrintern.global_reference lem_id) in + update_Function {finfo with completeness_lemma = Some lem_cst} ) funs; - with e -> + with reraise -> (* In case of problem, we reset all the lemmas *) - (*i The next call to mk_correct_id is valid since we are erasing the lemmas - Ensures by: obvious - i*) - let first_lemma_id = - let f_id = id_of_label (con_label funs.(0)) in - - mk_correct_id f_id - in - ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ()); - raise e + Pfedit.delete_all_proofs (); + States.unfreeze previous_state; + raise reraise @@ -955,7 +951,7 @@ let functional_inversion kn hid fconst f_correct : tactic = h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; thin [hid]; h_intro hid; - Inv.inv FullInversion None (Rawterm.NamedHyp hid); + Inv.inv FullInversion None (Glob_term.NamedHyp hid); (fun g -> let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 40ee116d..bd1a1710 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,6 @@ (* Merging of induction principles. *) -(*i $Id: i*) open Libnames open Tactics open Indfun_common @@ -21,12 +20,12 @@ open Term open Termops open Declarations open Environ -open Rawterm -open Rawtermops +open Glob_term +open Glob_termops (** {1 Utilities} *) -(** {2 Useful operations on constr and rawconstr} *) +(** {2 Useful operations on constr and glob_constr} *) let rec popn i c = if i<=0 then c else pop (popn (i-1) c) @@ -61,7 +60,7 @@ 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 + | GVar (_,x) -> Pervasives.compare x f = 0 | _ -> false (** [ident_global_exist id] returns true if identifier [id] is linked @@ -71,7 +70,7 @@ let ident_global_exist id = let ans = CRef (Libnames.Ident (dummy_loc,id)) in let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in true - with _ -> false + with e when Errors.noncritical e -> false (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) @@ -98,7 +97,7 @@ let prNamedConstr s c = let prNamedRConstr s c = begin msg(str ""); - msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} "); + msg(str(s^" {§ ") ++ Printer.pr_glob_constr c ++ str " §} "); msg(str ""); end let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc @@ -130,7 +129,7 @@ let prNamedRLDecl s lc = end let showind (id:identifier) = - let cstrid = Tacinterp.constr_of_id (Global.env()) id in + let cstrid = Constrintern.global_reference 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) -> @@ -378,15 +377,15 @@ let verify_inds mib1 mib2 = let build_raw_params prms_decl avoid = let dummy_constr = compose_prod (List.map (fun (x,_,z) -> x,z) prms_decl) (mkRel 1) in let _ = prNamedConstr "DUMMY" dummy_constr in - let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in - let _ = prNamedRConstr "RAWDUMMY" dummy_rawconstr in - let res,_ = raw_decompose_prod dummy_rawconstr in + let dummy_glob_constr = Detyping.detype false avoid [] dummy_constr in + let _ = prNamedRConstr "RAWDUMMY" dummy_glob_constr in + let res,_ = glob_decompose_prod dummy_glob_constr in let comblist = List.combine prms_decl res in - comblist, res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr))) + comblist, res , (avoid @ (Idset.elements (ids_of_glob_constr dummy_glob_constr))) *) let ids_of_rawlist avoid rawl = - List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl) + List.fold_left Idset.union avoid (List.map ids_of_glob_constr rawl) @@ -464,7 +463,7 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array ([],[],[],[]) arity_ctxt in (* let arity_ctxt2 = build_raw_params oib2.mind_arity_ctxt - (Idset.elements (ids_of_rawterm oib1.mind_arity_ctxt)) in*) + (Idset.elements (ids_of_glob_constr oib1.mind_arity_ctxt)) in*) let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in let _ = prstr "\n\n\n" in let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in @@ -512,37 +511,37 @@ exception NoMerge let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with - | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> + | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> let _ = prstr "\nICI1!\n";Pp.flush_all() in let args = filter_shift_stable lnk (arr1 @ arr2) in - RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args) - | RApp(_,f1, arr1), RApp(_,f2,arr2) -> raise NoMerge - | RLetIn(_,nme,bdy,trm) , _ -> + GApp (dummy_loc,GVar (dummy_loc,shift.ident) , args) + | GApp(_,f1, arr1), GApp(_,f2,arr2) -> raise NoMerge + | GLetIn(_,nme,bdy,trm) , _ -> let _ = prstr "\nICI2!\n";Pp.flush_all() in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - RLetIn(dummy_loc,nme,bdy,newtrm) - | _, RLetIn(_,nme,bdy,trm) -> + GLetIn(dummy_loc,nme,bdy,newtrm) + | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3!\n";Pp.flush_all() in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - RLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(dummy_loc,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in raise NoMerge let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with - | RApp(_,f1, arr1), RApp(_,f2,arr2) -> + | GApp(_,f1, arr1), GApp(_,f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in - RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args) + GApp (dummy_loc,GVar(dummy_loc,shift.ident) , args) (* FIXME: what if the function appears in the body of the let? *) - | RLetIn(_,nme,bdy,trm) , _ -> + | GLetIn(_,nme,bdy,trm) , _ -> let _ = prstr "\nICI2 '!\n";Pp.flush_all() in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - RLetIn(dummy_loc,nme,bdy,newtrm) - | _, RLetIn(_,nme,bdy,trm) -> + GLetIn(dummy_loc,nme,bdy,newtrm) + | _, GLetIn(_,nme,bdy,trm) -> let _ = prstr "\nICI3 '!\n";Pp.flush_all() in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - RLetIn(dummy_loc,nme,bdy,newtrm) + GLetIn(dummy_loc,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge @@ -551,24 +550,24 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = calls of branch 1 with all rec calls of branch 2. *) (* TODO: reecrire cette heuristique (jusqu'a merge_types) *) let rec merge_rec_hyps shift accrec - (ltyp:(Names.name * rawconstr option * rawconstr option) list) - filter_shift_stable : (Names.name * rawconstr option * rawconstr option) list = + (ltyp:(Names.name * glob_constr option * glob_constr option) list) + filter_shift_stable : (Names.name * glob_constr option * glob_constr option) list = let mergeonehyp t reldecl = match reldecl with - | (nme,x,Some (RApp(_,i,args) as ind)) + | (nme,x,Some (GApp(_,i,args) as ind)) -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) | (nme,Some _,None) -> error "letins with recursive calls not treated yet" | (nme,None,Some _) -> assert false | (nme,None,None) | (nme,Some _,Some _) -> assert false in match ltyp with | [] -> [] - | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> + | (nme,None,Some (GApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> let rechyps = List.map (mergeonehyp t) accrec in rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable -let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = +let rec build_suppl_reccall (accrec:(name * glob_constr) list) concl2 shift = List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec @@ -578,7 +577,7 @@ let find_app (nme:identifier) ltyp = (List.map (fun x -> match x with - | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0) + | _,None,Some (GApp(_,f,_)) when isVarf nme f -> raise (Found 0) | _ -> ()) ltyp); false @@ -592,9 +591,9 @@ let prnt_prod_or_letin nm letbdy typ = let rec merge_types shift accrec1 - (ltyp1:(name * rawconstr option * rawconstr option) list) - (concl1:rawconstr) (ltyp2:(name * rawconstr option * rawconstr option) list) concl2 - : (name * rawconstr option * rawconstr option) list * rawconstr = + (ltyp1:(name * glob_constr option * glob_constr option) list) + (concl1:glob_constr) (ltyp2:(name * glob_constr option * glob_constr option) list) concl2 + : (name * glob_constr option * glob_constr option) list * glob_constr = let _ = prstr "MERGE_TYPES\n" in let _ = prstr "ltyp 1 : " in let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in @@ -638,7 +637,7 @@ let rec merge_types shift accrec1 rechyps , concl | (nme,None, Some t1)as e ::lt1 -> (match t1 with - | RApp(_,f,carr) when isVarf ind1name f -> + | GApp(_,f,carr) when isVarf ind1name f -> merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 | _ -> let recres, recconcl2 = @@ -705,8 +704,8 @@ let build_link_map allargs1 allargs2 lnk = 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 = +let merge_one_constructor (shift:merge_infos) (typcstr1:glob_constr) + (typcstr2:glob_constr) : glob_constr = (* 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 *) @@ -714,17 +713,17 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in let nargs2 = shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in - let allargs1,rest1 = raw_decompose_prod_or_letin_n nargs1 typcstr1 in - let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in + let allargs1,rest1 = glob_decompose_prod_or_letin_n nargs1 typcstr1 in + let allargs2,rest2 = glob_decompose_prod_or_letin_n nargs2 typcstr2 in (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in let rest2 = change_vars linked_map rest2 in - let hyps1,concl1 = raw_decompose_prod_or_letin rest1 in - let hyps2,concl2' = raw_decompose_prod_or_letin rest2 in + let hyps1,concl1 = glob_decompose_prod_or_letin rest1 in + let hyps2,concl2' = glob_decompose_prod_or_letin rest2 in let ltyp,concl2 = merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in let _ = prNamedRLDecl "ltyp result:" ltyp in - let typ = raw_compose_prod_or_letin concl2 (List.rev ltyp) in + let typ = glob_compose_prod_or_letin concl2 (List.rev ltyp) in let revargs1 = list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in let _ = prNamedRLDecl "ltyp allargs1" allargs1 in @@ -734,7 +733,7 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) let _ = prNamedRLDecl "ltyp allargs2" allargs2 in let _ = prNamedRLDecl "ltyp revargs2" revargs2 in let typwithprms = - raw_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in + glob_compose_prod_or_letin typ (List.rev revargs2 @ List.rev revargs1) in typwithprms @@ -757,11 +756,11 @@ let merge_constructor_id id1 id2 shift:identifier = (** [merge_constructors lnk shift avoid] merges the two list of - constructor [(name*type)]. These are translated to rawterms + constructor [(name*type)]. These are translated to glob_constr first, each of them having distinct var names. *) let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) - (typcstr1:(identifier * rawconstr) list) - (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list = + (typcstr1:(identifier * glob_constr) list) + (typcstr2:(identifier * glob_constr) list) : (identifier * glob_constr) list = List.flatten (List.map (fun (id1,rawtyp1) -> @@ -779,12 +778,12 @@ let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) info in [shift], avoiding identifiers in [avoid]. *) let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) (oib2:one_inductive_body) = - (* building rawconstr type of constructors *) + (* building glob_constr type of constructors *) let mkrawcor nme avoid typ = (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in Detyping.detype false (Idset.elements avoid) [] substindtyp in - let lcstr1: rawconstr list = + let lcstr1: glob_constr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in (* add to avoid all indentifiers of lcstr1 *) let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in @@ -793,11 +792,11 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in let params1 = - try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) - with _ -> [] in + try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) + with e when Errors.noncritical e -> [] in let params2 = - try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) - with _ -> [] in + try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) + with e when Errors.noncritical e -> [] 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 @@ -817,8 +816,8 @@ let rec merge_mutual_inductive_body merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) -let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *) - Flags.with_option Flags.raw_print (Constrextern.extern_rawtype Idset.empty) x +let glob_constr_to_constr_expr x = (* build a constr_expr from a glob_constr *) + Flags.with_option Flags.raw_print (Constrextern.extern_glob_type Idset.empty) x let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let params = prms2 @ prms1 in @@ -828,7 +827,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let _ = prstr "param :" in let _ = prNamedRConstr (string_of_name nme) tp in let _ = prstr " ; " in - let typ = rawterm_to_constr_expr tp in + let typ = glob_constr_to_constr_expr tp in LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc) [] params in let concl = Constrextern.extern_constr false (Global.env()) concl in @@ -845,38 +844,38 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = -(** [rawterm_list_to_inductive_expr ident rawlist] returns the +(** [glob_constr_list_to_inductive_expr ident rawlist] returns the induct_expr corresponding to the the list of constructor types [rawlist], named ident. FIXME: params et cstr_expr (arity) *) -let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift - (rawlist:(identifier * rawconstr) list) = +let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift + (rawlist:(identifier * glob_constr) list) = let lident = dummy_loc, shift.ident in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in let lcstor_expr : (bool * (lident * constr_expr)) list = List.map (* zeta_normalize t ? *) - (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t)) + (fun (id,t) -> false, ((dummy_loc,id),glob_constr_to_constr_expr t)) rawlist in lident , bindlist , Some cstr_expr , lcstor_expr -let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = +let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) = match rdecl with | (nme,None,t) -> let traw = Detyping.detype false [] [] t in - RProd (dummy_loc,nme,Explicit,traw,t2) + GProd (dummy_loc,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false -let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = +let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) = match rdecl with | (nme,None,t) -> let traw = Detyping.detype false [] [] t in - RProd (dummy_loc,nme,Explicit,traw,t2) + GProd (dummy_loc,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false @@ -902,7 +901,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive) recprms1=prms1; recprms1=prms1; } in *) - let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in + let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in let mie,impls = Command.interp_mutual_inductive indl [] true (* means: not coinductive *) in @@ -1024,9 +1023,3 @@ let relprinctype_to_funprinctype relprinctype nfuns = url = "citeseer.ist.psu.edu/bundy93rippling.html" } *) -(* -*** Local Variables: *** -*** compile-command: "make -C ../.. plugins/funind/merge.cmo" *** -*** indent-tabs-mode: nil *** -*** End: *** -*) diff --git a/plugins/funind/rawtermops.mli b/plugins/funind/rawtermops.mli deleted file mode 100644 index 455e7c89..00000000 --- a/plugins/funind/rawtermops.mli +++ /dev/null @@ -1,126 +0,0 @@ -open Rawterm - -(* Ocaml 3.06 Map.S does not handle is_empty *) -val idmap_is_empty : 'a Names.Idmap.t -> bool - - -(* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) -val get_pattern_id : cases_pattern -> Names.identifier list - -(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. - [pat] must not contain occurences of anonymous pattern -*) -val pattern_to_term : cases_pattern -> rawconstr - -(* - Some basic functions to rebuild rawconstr - In each of them the location is Util.dummy_loc -*) -val mkRRef : Libnames.global_reference -> rawconstr -val mkRVar : Names.identifier -> rawconstr -val mkRApp : rawconstr*(rawconstr list) -> rawconstr -val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr -val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr -val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr -val mkRCases : rawconstr option * tomatch_tuples * cases_clauses -> rawconstr -val mkRSort : rawsort -> rawconstr -val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *) -val mkRCast : rawconstr* rawconstr -> rawconstr -(* - Some basic functions to decompose rawconstrs - These are analogous to the ones constrs -*) -val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr -val raw_decompose_prod_or_letin : - rawconstr -> (Names.name*rawconstr option*rawconstr option) list * rawconstr -val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr -val raw_decompose_prod_or_letin_n : int -> rawconstr -> - (Names.name*rawconstr option*rawconstr option) list * rawconstr -val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list -> rawconstr -val raw_compose_prod_or_letin: rawconstr -> - (Names.name*rawconstr option*rawconstr option) list -> rawconstr -val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list) - - -(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) -val raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr -(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) -val raw_make_neq : rawconstr -> rawconstr -> rawconstr -(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) -val raw_make_or : rawconstr -> rawconstr -> rawconstr - -(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -val raw_make_or_list : rawconstr list -> rawconstr - - -(* alpha_conversion functions *) - - - -(* Replace the var mapped in the rawconstr/context *) -val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr - - - -(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. - the result does not share variables with [avoid]. This function create - a fresh variable for each occurence of the anonymous pattern. - - Also returns a mapping from old variables to new ones and the concatenation of - [avoid] with the variables appearing in the result. -*) - val alpha_pat : - Names.Idmap.key list -> - Rawterm.cases_pattern -> - Rawterm.cases_pattern * Names.Idmap.key list * - Names.identifier Names.Idmap.t - -(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt - conventions and does not share bound variables with avoid -*) -val alpha_rt : Names.identifier list -> rawconstr -> rawconstr - -(* same as alpha_rt but for case branches *) -val alpha_br : Names.identifier list -> - Util.loc * Names.identifier list * Rawterm.cases_pattern list * - Rawterm.rawconstr -> - Util.loc * Names.identifier list * Rawterm.cases_pattern list * - Rawterm.rawconstr - - -(* Reduction function *) -val replace_var_by_term : - Names.identifier -> - Rawterm.rawconstr -> Rawterm.rawconstr -> Rawterm.rawconstr - - - -(* - [is_free_in id rt] checks if [id] is a free variable in [rt] -*) -val is_free_in : Names.identifier -> rawconstr -> bool - - -val are_unifiable : cases_pattern -> cases_pattern -> bool -val eq_cases_pattern : cases_pattern -> cases_pattern -> bool - - - -(* - ids_of_pat : cases_pattern -> Idset.t - returns the set of variables appearing in a pattern -*) -val ids_of_pat : cases_pattern -> Names.Idset.t - -(* TODO: finish this function (Fix not treated) *) -val ids_of_rawterm: rawconstr -> Names.Idset.t - -(* - removing let_in construction in a rawterm -*) -val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr - - -val expand_as : rawconstr -> rawconstr diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 934bf683..9853fd73 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,10 +8,7 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: recdef.ml 15069 2012-03-20 14:06:07Z herbelin $ *) - open Term -open Termops open Namegen open Environ open Declarations @@ -36,7 +33,7 @@ open Proof_type open Vernacinterp open Pfedit open Topconstr -open Rawterm +open Glob_term open Pretyping open Pretyping.Default open Safe_typing @@ -70,44 +67,38 @@ let pf_get_new_id id g = let h_intros l = tclMAP h_intro l -let debug_queue = Queue.create () +let debug_queue = Stack.create () -let rec print_debug_queue e = - let lmsg,goal = Queue.pop debug_queue in - if Queue.is_empty debug_queue - then - msgnl (lmsg ++ (str " raised exception " ++ Cerrors.explain_exn e) ++ str " on goal " ++ goal) - else +let rec print_debug_queue b e = + if not (Stack.is_empty debug_queue) + then begin - print_debug_queue e; - msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal); + let lmsg,goal = Stack.pop debug_queue in + if b then + msgnl (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal) + else + begin + msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal); + end; + print_debug_queue false e; end + let do_observe_tac s tac g = - let goal = Printer.pr_goal (sig_it g) in - let lmsg = (str "recdef ") ++ (str s) in - Queue.add (lmsg,goal) debug_queue; + let goal = Printer.pr_goal g in + let lmsg = (str "recdef : ") ++ (str s) in + Stack.push (lmsg,goal) debug_queue; try let v = tac g in - ignore(Queue.pop debug_queue); + ignore(Stack.pop debug_queue); v - with e -> - if not (Queue.is_empty debug_queue) + with reraise -> + if not (Stack.is_empty debug_queue) then - print_debug_queue e; - raise e - -(*let do_observe_tac s tac g = - let goal = begin (Printer.pr_goal (sig_it g)) end in - try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++ - (str s)++(str " ")++(str "finished")); v - with e -> - msgnl (str "observation "++str s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); - raise e;; -*) + print_debug_queue true reraise; + raise reraise let observe_tac s tac g = if Tacinterp.get_debug () <> Tactic_debug.DebugOff @@ -146,10 +137,10 @@ let message s = if Flags.is_verbose () then msgnl(str s);; let def_of_const t = match (kind_of_term t) with Const sp -> - (try (match (Global.lookup_constant sp) with - {const_body=Some c} -> Declarations.force c - |_ -> assert false) - with _ -> + (try (match body_of_constant (Global.lookup_constant sp) with + | Some c -> Declarations.force c + | _ -> assert false) + with e when Errors.noncritical e -> anomaly ("Cannot find definition of constant "^ (string_of_id (id_of_label (con_label sp)))) ) @@ -181,11 +172,23 @@ let rank_for_arg_list h = | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in rank_aux 0;; -let rec (find_call_occs : int -> constr -> constr -> +let rec check_not_nested f t = + match kind_of_term t with + | App(g, _) when eq_constr f g -> + errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function") + | Var(_) when eq_constr t f -> errorlabstrm "recdef" (str "Nested recursive function are not allowed with Function") + | _ -> iter_constr (check_not_nested f) t + + + + +let rec (find_call_occs : int -> int -> constr -> constr -> (constr list -> constr) * constr list list) = - fun nb_lam f expr -> + fun nb_arg nb_lam f expr -> match (kind_of_term expr) with - App (g, args) when g = f -> + App (g, args) when eq_constr g f -> + if Array.length args <> nb_arg then errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function"); + Array.iter (check_not_nested f) args; (fun l -> List.hd l), [Array.to_list args] | App (g, args) -> let (largs: constr list) = Array.to_list args in @@ -194,7 +197,7 @@ let rec (find_call_occs : int -> constr -> constr -> | a::upper_tl -> (match find_aux upper_tl with (cf, ((arg1::args) as args_for_upper_tl)) -> - (match find_call_occs nb_lam f a with + (match find_call_occs nb_arg nb_lam f a with cf2, (_ :: _ as other_args) -> let rec avoid_duplicates args = match args with @@ -218,7 +221,7 @@ let rec (find_call_occs : int -> constr -> constr -> other_args'@args_for_upper_tl | _, [] -> (fun x -> a::cf x), args_for_upper_tl) | _, [] -> - (match find_call_occs nb_lam f a with + (match find_call_occs nb_arg nb_lam f a with cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args) | _, [] -> (fun x -> a::upper_tl), [])) in begin @@ -228,40 +231,42 @@ let rec (find_call_occs : int -> constr -> constr -> (fun l -> mkApp (g, Array.of_list (cf l))), args end | Rel(v) -> if v > nb_lam then error "find_call_occs : Rel" else ((fun l -> expr),[]) + | Var(_) when eq_constr expr f -> errorlabstrm "recdef" (str "Partial application of function " ++ Printer.pr_lconstr expr ++ str " in its body is not allowed while using Function") | Var(id) -> (fun l -> expr), [] - | Meta(_) -> error "find_call_occs : Meta" - | Evar(_) -> error "find_call_occs : Evar" + | Meta(_) -> error "Found a metavariable. Can not treat such a term" + | Evar(_) -> error "Found an evar. Can not treat such a term" | Sort(_) -> (fun l -> expr), [] - | Cast(b,_,_) -> find_call_occs nb_lam f b - | Prod(_,_,_) -> error "find_call_occs : Prod" + | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b + | Prod(na,t,b) -> + error "Found a product. Can not treat such a term" | Lambda(na,t,b) -> begin - match find_call_occs (succ nb_lam) f b with + match find_call_occs nb_arg (succ nb_lam) f b with | _, [] -> (* Lambda are authorized as long as they do not contain recursives calls *) (fun l -> expr),[] - | _ -> error "find_call_occs : Lambda" + | _ -> error "Found a lambda which body contains a recursive call. Such terms are not allowed" end | LetIn(na,v,t,b) -> begin - match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with + match find_call_occs nb_arg nb_lam f v, find_call_occs nb_arg (succ nb_lam) f b with | (_,[]),(_,[]) -> ((fun l -> expr), []) | (_,[]),(cf,(_::_ as l)) -> ((fun l -> mkLetIn(na,v,t,cf l)),l) | (cf,(_::_ as l)),(_,[]) -> ((fun l -> mkLetIn(na,cf l,t,b)), l) - | _ -> error "find_call_occs : LetIn" + | _ -> error "Found a letin with recursive calls in both variable value and body. Such terms are not allowed." end | Const(_) -> (fun l -> expr), [] | Ind(_) -> (fun l -> expr), [] | Construct (_, _) -> (fun l -> expr), [] | Case(i,t,a,r) -> - (match find_call_occs nb_lam f a with + (match find_call_occs nb_arg nb_lam f a with cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args) | _ -> (fun l -> expr),[]) - | Fix(_) -> error "find_call_occs : Fix" - | CoFix(_) -> error "find_call_occs : CoFix";; + | Fix(_) -> error "Found a local fixpoint. Can not treat such a term" + | CoFix(_) -> error "Found a local cofixpoint : CoFix";; let coq_constant s = Coqlib.gen_constant_in_modules "RecursiveDefinition" @@ -370,15 +375,19 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool) h_intros thin_intros; tclMAP - (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences (* deps proofs also: *) true teq eq false)) + (fun eq -> tclTRY (Equality.general_rewrite_in true Termops.all_occurrences true (* deps proofs also: *) true teq eq false)) (List.rev eqs); (fun g1 -> let ty_teq = pf_type_of g1 (mkVar teq) in let teq_lhs,teq_rhs = - let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in + let _,args = + try destApp ty_teq + with e when Errors.noncritical e -> + Pp.msgnl (Printer.pr_goal g1 ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false + in args.(1),args.(2) in - cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1 + cont_function (mkVar teq::eqs) (Termops.replace_term teq_lhs teq_rhs expr) g1 ) ] @@ -431,7 +440,7 @@ let tclUSER tac is_mes l g = clear_tac; if is_mes then tclTHEN - (unfold_in_concl [(all_occurrences, evaluable_of_global_reference + (unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) tac else tac @@ -530,8 +539,8 @@ let rec list_cond_rewrite k def pmax cond_eqs le_proofs = Nameops.out_name k_na,Nameops.out_name def_na in tclTHENS - (general_rewrite_bindings false all_occurrences - (* dep proofs also: *) true + (general_rewrite_bindings false Termops.all_occurrences + (* dep proofs also: *) true true (mkVar eq, ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k; dummy_loc, NamedHyp def_id, mkVar def]) false) @@ -573,7 +582,7 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs observe_tac "refl equal" (apply (delayed_force refl_equal))] g | spec1::specs -> fun g -> - let ids = ids_of_named_context (pf_hyps g) in + let ids = Termops.ids_of_named_context (pf_hyps g) in let p = next_ident_away_in_goal p_id ids in let ids = p::ids in let pmax = next_ident_away_in_goal pmax_id ids in @@ -619,7 +628,7 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn (List.rev values) (List.rev specs) (delayed_force coq_O) [] [])] | arg::args -> (fun g -> - let ids = ids_of_named_context (pf_hyps g) in + let ids = Termops.ids_of_named_context (pf_hyps g) in let rec_res = next_ident_away_in_goal rec_res_id ids in let ids = rec_res::ids in let hspec = next_ident_away_in_goal hspec_id ids in @@ -658,13 +667,13 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn ) -let rec_leaf_terminate f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr = - match find_call_occs 0 f_constr expr with +let rec_leaf_terminate nb_arg f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr = + match find_call_occs nb_arg 0 f_constr expr with | context_fn, args -> observe_tac "introduce_all_values" (introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] []) -let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier) +let proveterminate nb_arg rec_arg_id is_mes acc_inv (hrec:identifier) (f_constr:constr) (func:global_reference) base_leaf rec_leaf = let rec proveterminate (eqs:constr list) (expr:constr) = try @@ -672,7 +681,7 @@ let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier) let v = match (kind_of_term expr) with Case (ci, t, a, l) -> - (match find_call_occs 0 f_constr a with + (match find_call_occs nb_arg 0 f_constr a with _,[] -> (fun g -> let destruct_tac, rev_to_thin_intro = @@ -684,24 +693,29 @@ let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier) true proveterminate eqs - ci.ci_cstr_nargs.(i)) + ci.ci_cstr_ndecls.(i)) 0 (Array.to_list l)) g) | _, _::_ -> - (match find_call_occs 0 f_constr expr with + (match find_call_occs nb_arg 0 f_constr expr with _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr) | _, _:: _ -> observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr))) | _ -> - (match find_call_occs 0 f_constr expr with + (match find_call_occs nb_arg 0 f_constr expr with _,[] -> (try observe_tac "base_leaf" (base_leaf func eqs expr) - with e -> (msgerrnl (str "failure in base case");raise e )) + with reraise -> + (msgerrnl (str "failure in base case");raise reraise )) | _, _::_ -> observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr)) in v - with e -> begin msgerrnl(str "failure in proveterminate"); raise e end + with reraise -> + begin + msgerrnl(str "failure in proveterminate"); + raise reraise + end in proveterminate @@ -832,7 +846,7 @@ let rec instantiate_lambda t l = let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = begin fun g -> - let ids = ids_of_named_context (pf_hyps g) in + let ids = Termops.ids_of_named_context (pf_hyps g) in let func_body = (def_of_const (constr_of_global func)) in let (f_name, _, body1) = destLambda func_body in let f_id = @@ -865,6 +879,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a rec_arg_id (fun rec_arg_id hrec acc_inv g -> (proveterminate + nb_args [rec_arg_id] is_mes acc_inv @@ -872,7 +887,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a (mkVar f_id) func base_leaf_terminate - (rec_leaf_terminate (mkVar f_id) concl_tac) + (rec_leaf_terminate nb_args (mkVar f_id) concl_tac) [] expr ) @@ -883,15 +898,29 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a end let get_current_subgoals_types () = - let pts = get_pftreestate () in - let _,subs = extract_open_pftreestate pts in - List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs ) + let p = Proof_global.give_me_the_proof () in + let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in + List.map (Goal.V82.abstract_type sigma) sgs let build_and_l l = let and_constr = Coqlib.build_coq_and () in let conj_constr = coq_conj () in let mk_and p1 p2 = Term.mkApp(and_constr,[|p1;p2|]) in + let rec is_well_founded t = + match kind_of_term t with + | Prod(_,_,t') -> is_well_founded t' + | App(_,_) -> + let (f,_) = decompose_app t in + eq_constr f (well_founded ()) + | _ -> assert false + in + let compare t1 t2 = + let b1,b2= is_well_founded t1,is_well_founded t2 in + if (b1&&b2) || not (b1 || b2) then 0 + else if b1 && not b2 then 1 else -1 + in + let l = List.sort compare l in let rec f = function | [] -> failwith "empty list of subgoals!" | [p] -> p,tclIDTAC,1 @@ -911,7 +940,7 @@ let is_rec_res id = let id_name = string_of_id id in try String.sub id_name 0 (String.length rec_res_name) = rec_res_name - with _ -> false + with e when Errors.noncritical e -> false let clear_goals = let rec clear_goal t = @@ -919,7 +948,7 @@ let clear_goals = | Prod(Name id as na,t',b) -> let b' = clear_goal b in if noccurn 1 b' && (is_rec_res id) - then pop b' + then Termops.pop b' else if b' == b then t else mkProd(na,t',b') | _ -> map_constr clear_goal t @@ -935,6 +964,13 @@ let build_new_goal_type () = let res = build_and_l sub_gls_types in res +let is_opaque_constant c = + let cb = Global.lookup_constant c in + match cb.Declarations.const_body with + | Declarations.OpaqueDef _ -> true + | Declarations.Undef _ -> true + | Declarations.Def _ -> false + let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) let current_proof_name = get_current_proof_name () in @@ -942,22 +978,19 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ | Some s -> s | None -> try (add_suffix current_proof_name "_subproof") - with _ -> anomaly "open_new_goal with an unamed theorem" + with e when Errors.noncritical e -> + anomaly "open_new_goal with an unamed theorem" in - let sign = Global.named_context () in - let sign = clear_proofs sign in + let sign = initialize_named_context_for_proof () in let na = next_global_ident_away name [] in - if occur_existential gls_type then + if Termops.occur_existential gls_type then Util.error "\"abstract\" cannot handle existentials"; let hook _ _ = let opacity = let na_ref = Libnames.Ident (dummy_loc,na) in let na_global = Nametab.global na_ref in match na_global with - ConstRef c -> - let cb = Global.lookup_constant c in - if cb.Declarations.const_opaque then true - else begin match cb.const_body with None -> true | _ -> false end + ConstRef c -> is_opaque_constant c | _ -> anomaly "equation_lemma: not a constant" in let lemma = mkConst (Lib.make_con na) in @@ -999,9 +1032,8 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) e_assumption; Eauto.eauto_with_bases - false (true,5) - [delayed_force refl_equal] + [Evd.empty,delayed_force refl_equal] [Auto.Hint_db.empty empty_transparent_state false] ] ) @@ -1102,38 +1134,31 @@ let (value_f:constr list -> global_reference -> constr) = al ) in - let fun_body = - RCases + let context = List.map + (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al)) + in + let env = Environ.push_rel_context context (Global.env ()) in + let glob_body = + GCases (d0,RegularStyle,None, - [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l), + [GApp(d0, GRef(d0,fterm), List.rev_map (fun x_id -> GVar(d0, x_id)) rev_x_id_l), (Anonymous,None)], [d0, [v_id], [PatCstr(d0,(ind_of_ref (delayed_force coq_sig_ref),1), [PatVar(d0, Name v_id); PatVar(d0, Anonymous)], Anonymous)], - RVar(d0,v_id)]) + GVar(d0,v_id)]) in - let value = - List.fold_left2 - (fun acc x_id a -> - RLambda - (d0, Name x_id, Explicit, RDynamic(d0, constr_in a), - acc - ) - ) - fun_body - rev_x_id_l - (List.rev al) - in - understand Evd.empty (Global.env()) value;; + let body = understand Evd.empty env glob_body in + it_mkLambda_or_LetIn body context let (declare_fun : identifier -> logical_kind -> constr -> global_reference) = fun f_id kind value -> let ce = {const_entry_body = value; + const_entry_secctx = None; const_entry_type = None; - const_entry_opaque = false; - const_entry_boxed = true} in + const_entry_opaque = false } in ConstRef(declare_constant f_id (DefinitionEntry ce, kind));; let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) = @@ -1153,7 +1178,7 @@ let start_equation (f:global_reference) (term_f:global_reference) let x = n_x_id ids nargs in tclTHENLIST [ h_intros x; - unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)]; + unfold_in_concl [(Termops.all_occurrences, evaluable_of_global_reference f)]; observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x)))); @@ -1195,7 +1220,7 @@ let rec introduce_all_values_eq cont_tac functional termine simpl_iter (onHyp heq2); unfold_in_hyp [((true,[1]), evaluable_of_global_reference (global_of_constr functional))] - (heq2, InHyp); + (heq2, Termops.InHyp); tclTHENS (fun gls -> let t_eq = compute_renamed_type gls (mkVar heq2) in @@ -1203,8 +1228,8 @@ let rec introduce_all_values_eq cont_tac functional termine let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in Nameops.out_name def_na in - observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences - (* dep proofs also: *) true (mkVar heq2, + observe_tac "rewrite heq" (general_rewrite_bindings false Termops.all_occurrences + true (* dep proofs also: *) true (mkVar heq2, ExplicitBindings[dummy_loc,NamedHyp def_id, f]) false) gls) [tclTHENLIST @@ -1259,7 +1284,7 @@ let rec introduce_all_values_eq cont_tac functional termine f_S(mkVar pmax'); dummy_loc, NamedHyp def_id, f]) in - observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false all_occurrences (* dep proofs also: *) true + observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false Termops.all_occurrences true (* dep proofs also: *) true c_b false)) g ) @@ -1294,12 +1319,12 @@ let rec_leaf_eq termine f ids functional eqs expr fn args = functional termine f p heq1 p [] [] eqs ids args); observe_tac "failing here" (apply (delayed_force refl_equal))] -let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) +let rec prove_eq nb_arg (termine:constr) (f:constr)(functional:global_reference) (eqs:constr list) (expr:constr) = (* tclTRY *) observe_tac "prove_eq" (match kind_of_term expr with Case(ci,t,a,l) -> - (match find_call_occs 0 f a with + (match find_call_occs nb_arg 0 f a with _,[] -> (fun g -> let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in @@ -1308,38 +1333,35 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) (list_map_i (fun i -> mk_intros_and_continue (List.rev rev_to_thin_intro) true - (prove_eq termine f functional) - eqs ci.ci_cstr_nargs.(i)) + (prove_eq nb_arg termine f functional) + eqs ci.ci_cstr_ndecls.(i)) 0 (Array.to_list l)) g) | _,_::_ -> - (match find_call_occs 0 f expr with + (match find_call_occs nb_arg 0 f expr with _,[] -> observe_tac "base_leaf_eq(1)" (base_leaf_eq functional eqs f) | fn,args -> fun g -> - let ids = ids_of_named_context (pf_hyps g) in + let ids = Termops.ids_of_named_context (pf_hyps g) in observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids (constr_of_global functional) eqs expr fn args) g)) | _ -> - (match find_call_occs 0 f expr with + (match find_call_occs nb_arg 0 f expr with _,[] -> observe_tac "base_leaf_eq(2)" ( base_leaf_eq functional eqs f) | fn,args -> fun g -> - let ids = ids_of_named_context (pf_hyps g) in + let ids = Termops.ids_of_named_context (pf_hyps g) in observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids (constr_of_global functional) eqs expr fn args) g));; -let (com_eqn : identifier -> +let (com_eqn : int -> identifier -> global_reference -> global_reference -> global_reference -> constr -> unit) = - fun eq_name functional_ref f_ref terminate_ref equation_lemma_type -> + fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> let opacity = match terminate_ref with - | ConstRef c -> - let cb = Global.lookup_constant c in - if cb.Declarations.const_opaque then true - else begin match cb.const_body with None -> true | _ -> false end + | ConstRef c -> is_opaque_constant c | _ -> anomaly "terminate_lemma: not a constant" in let (evmap, env) = Lemmas.get_current_context() in @@ -1350,7 +1372,7 @@ let (com_eqn : identifier -> by (start_equation f_ref terminate_ref (fun x -> - prove_eq + prove_eq nb_arg (constr_of_global terminate_ref) f_constr functional_ref @@ -1381,14 +1403,15 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = + let previous_label = Lib.current_command_label () in let function_type = interp_constr Evd.empty (Global.env()) type_of_f in let env = push_named (function_name,None,function_type) (Global.env()) in -(* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) + (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let equation_lemma_type = nf_betaiotazeta (interp_gen (OfType None) Evd.empty env ~impls:rec_impls eq) in -(* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) + (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in let eq' = nf_zeta env_eq' eq' in @@ -1407,7 +1430,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in - let functional_ref = declare_fun functional_id (IsDefinition Definition) res in + let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) res in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in let relation = interp_constr @@ -1421,17 +1444,17 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in + let _ = Table.extraction_inline true [Ident (dummy_loc,term_id)] in (* message "start second proof"; *) let stop = ref false in begin - try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) - with e -> + try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) + with e when Errors.noncritical e -> begin if Tacinterp.get_debug () <> Tactic_debug.DebugOff - then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e) + then pperrnl (str "Cannot create equation Lemma " ++ Errors.print e) else anomaly "Cannot create equation Lemma" ; -(* ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); *) stop := true; end end; @@ -1461,12 +1484,10 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num using_lemmas (List.length res_vars) hook - with e -> + with reraise -> begin - ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); -(* anomaly "Cannot create termination Lemma" *) - raise e + (try ignore (Backtrack.backto previous_label) + with e when Errors.noncritical e -> ()); + (* anomaly "Cannot create termination Lemma" *) + raise reraise end - - - diff --git a/plugins/funind/recdef_plugin.mllib b/plugins/funind/recdef_plugin.mllib index 31818c39..ec1f5436 100644 --- a/plugins/funind/recdef_plugin.mllib +++ b/plugins/funind/recdef_plugin.mllib @@ -1,7 +1,7 @@ Indfun_common -Rawtermops +Glob_termops Recdef -Rawterm_to_relation +Glob_term_to_relation Functional_principles_proofs Functional_principles_types Invfun diff --git a/plugins/micromega/CheckerMaker.v b/plugins/micromega/CheckerMaker.v index 8f0f86c5..fa780671 100644 --- a/plugins/micromega/CheckerMaker.v +++ b/plugins/micromega/CheckerMaker.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,6 +12,8 @@ (* *) (************************************************************************) +(* FK: scheduled for deletion *) +(* Require Import Setoid. Require Import Decidable. Require Import List. @@ -127,3 +129,4 @@ apply <- negate_correct. intro; now elim H3. exact (H1 H2). Qed. End CheckerMaker. +*)
\ No newline at end of file diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v index 5aa30fed..caec7800 100644 --- a/plugins/micromega/Env.v +++ b/plugins/micromega/Env.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,16 +12,9 @@ (* *) (************************************************************************) -Require Import ZArith. -Require Import Coq.Arith.Max. -Require Import List. +Require Import BinInt List. Set Implicit Arguments. - -(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) - -- this is harmless and spares a lot of Empty. - This means smaller proof-terms. - BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up. -*) +Local Open Scope positive_scope. Section S. @@ -29,154 +22,78 @@ Section S. Definition Env := positive -> D. - Definition jump (j:positive) (e:Env) := fun x => e (Pplus x j). + Definition jump (j:positive) (e:Env) := fun x => e (x+j). - Definition nth (n:positive) (e : Env ) := e n. + Definition nth (n:positive) (e:Env) := e n. - Definition hd (x:D) (e: Env) := nth xH e. + Definition hd (e:Env) := nth 1 e. - Definition tail (e: Env) := jump xH e. + Definition tail (e:Env) := jump 1 e. - Lemma psucc : forall p, (match p with - | xI y' => xO (Psucc y') - | xO y' => xI y' - | 1%positive => 2%positive - end) = (p+1)%positive. + Lemma jump_add i j l x : jump (i + j) l x = jump i (jump j l) x. Proof. - destruct p. - auto with zarith. - rewrite xI_succ_xO. - auto with zarith. - reflexivity. + unfold jump. f_equal. apply Pos.add_assoc. Qed. - Lemma jump_Pplus : forall i j l, - forall x, jump (i + j) l x = jump i (jump j l) x. - Proof. - unfold jump. - intros. - rewrite Pplus_assoc. - reflexivity. - Qed. - - Lemma jump_simpl : forall p l, - forall x, jump p l x = + Lemma jump_simpl p l x : + jump p l x = match p with | xH => tail l x | xO p => jump p (jump p l) x | xI p => jump p (jump p (tail l)) x end. Proof. - destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus. - (* xI p = p + p + 1 *) - rewrite xI_succ_xO. - rewrite Pplus_diag. - rewrite <- Pplus_one_succ_r. - reflexivity. - (* xO p = p + p *) - rewrite Pplus_diag. - reflexivity. - reflexivity. - Qed. - - Ltac jump_s := - repeat - match goal with - | |- context [jump xH ?e] => rewrite (jump_simpl xH) - | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) - | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) - end. - - Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x. - Proof. - unfold tail. - intros. - repeat rewrite <- jump_Pplus. - rewrite Pplus_comm. - reflexivity. + destruct p; unfold tail; rewrite <- ?jump_add; f_equal; + now rewrite Pos.add_diag. Qed. - Lemma jump_Psucc : forall j l, - forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x). + Lemma jump_tl j l x : tail (jump j l) x = jump j (tail l) x. Proof. - intros. - rewrite <- jump_Pplus. - rewrite Pplus_one_succ_r. - rewrite Pplus_comm. - reflexivity. + unfold tail. rewrite <- !jump_add. f_equal. apply Pos.add_comm. Qed. - Lemma jump_Pdouble_minus_one : forall i l, - forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x. + Lemma jump_succ j l x : jump (Pos.succ j) l x = jump 1 (jump j l) x. Proof. - unfold tail. - intros. - repeat rewrite <- jump_Pplus. - rewrite <- Pplus_one_succ_r. - rewrite Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_diag. - reflexivity. + rewrite <- jump_add. f_equal. symmetry. apply Pos.add_1_l. Qed. - Lemma jump_x0_tail : forall p l, forall x, jump (xO p) (tail l) x = jump (xI p) l x. + Lemma jump_pred_double i l x : + jump (Pos.pred_double i) (tail l) x = jump i (jump i l) x. Proof. - intros. - unfold jump. - unfold tail. - unfold jump. - rewrite <- Pplus_assoc. - simpl. - reflexivity. + unfold tail. rewrite <- !jump_add. f_equal. + now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. Qed. - Lemma nth_spec : forall p l x, + Lemma nth_spec p l : nth p l = match p with - | xH => hd x l + | xH => hd l | xO p => nth p (jump p l) | xI p => nth p (jump p (tail l)) end. Proof. - unfold nth. - destruct p. - intros. - unfold jump, tail. - unfold jump. - rewrite Pplus_diag. - rewrite xI_succ_xO. - simpl. - reflexivity. - unfold jump. - rewrite Pplus_diag. - reflexivity. - unfold hd. - unfold nth. - reflexivity. + unfold hd, nth, tail, jump. + destruct p; f_equal; now rewrite Pos.add_diag. Qed. - - Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l). + Lemma nth_jump p l : nth p (tail l) = hd (jump p l). Proof. - unfold tail. - unfold hd. - unfold jump. - unfold nth. - intros. - rewrite Pplus_comm. - reflexivity. + unfold hd, nth, tail, jump. f_equal. apply Pos.add_comm. Qed. - Lemma nth_Pdouble_minus_one : - forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). + Lemma nth_pred_double p l : + nth (Pos.pred_double p) (tail l) = nth p (jump p l). Proof. - intros. - unfold tail. - unfold nth, jump. - rewrite Pplus_diag. - rewrite <- Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_one_succ_r. - reflexivity. + unfold nth, tail, jump. f_equal. + now rewrite Pos.add_1_r, Pos.succ_pred_double, Pos.add_diag. Qed. End S. +Ltac jump_simpl := + repeat + match goal with + | |- appcontext [jump xH] => rewrite (jump_simpl xH) + | |- appcontext [jump (xO ?p)] => rewrite (jump_simpl (xO p)) + | |- appcontext [jump (xI ?p)] => rewrite (jump_simpl (xI p)) + end. diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 8968a014..786c3393 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -11,15 +11,10 @@ Set Implicit Arguments. -Require Import Setoid. -Require Import BinList. -Require Import Env. -Require Import BinPos. -Require Import BinNat. -Require Import BinInt. +Require Import Setoid Morphisms Env BinPos BinNat BinInt. Require Export Ring_theory. -Open Local Scope positive_scope. +Local Open Scope positive_scope. Import RingSyntax. Section MakeRingPol. @@ -30,7 +25,7 @@ Section MakeRingPol. Variable req : R -> R -> Prop. (* Ring properties *) - Variable Rsth : Setoid_Theory R req. + Variable Rsth : Equivalence req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. @@ -42,35 +37,55 @@ Section MakeRingPol. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. - (* Power coefficients *) - Variable Cpow : Set. + (* Power coefficients *) + Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. - (* R notations *) Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). + Infix "+" := radd. Infix "*" := rmul. + Infix "-" := rsub. Notation "- x" := (ropp x). + Infix "==" := req. + Infix "^" := (pow_pos rmul). (* C notations *) - Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). - Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). - Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - - (* Usefull tactics *) - Add Setoid R req Rsth as R_set1. - Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Infix "+!" := cadd. Infix "*!" := cmul. + Infix "-! " := csub. Notation "-! x" := (copp x). + Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). + + (* Useful tactics *) + Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. + Ltac add_permut_rec t := + match t with + | ?x + ?y => add_permut_rec y || add_permut_rec x + | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] + end. + + Ltac add_permut := + repeat (reflexivity || + match goal with |- ?t == _ => add_permut_rec t end). + + Ltac mul_permut_rec t := + match t with + | ?x * ?y => mul_permut_rec y || mul_permut_rec x + | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] + end. + + Ltac mul_permut := + repeat (reflexivity || + match goal with |- ?t == _ => mul_permut_rec t end). + + (* Definition of multivariable polynomials with coefficients in C : Type [Pol] represents [X1 ... Xn]. The representation is Horner's where a [n] variable polynomial @@ -105,31 +120,31 @@ Section MakeRingPol. match P, P' with | Pc c, Pc c' => c ?=! c' | Pinj j Q, Pinj j' Q' => - match Pcompare j j' Eq with + match j ?= j' with | Eq => Peq Q Q' | _ => false end | PX P i Q, PX P' i' Q' => - match Pcompare i i' Eq with + match i ?= i' with | Eq => if Peq P P' then Peq Q Q' else false | _ => false end | _, _ => false end. - Notation " P ?== P' " := (Peq P P'). + Infix "?==" := Peq. Definition mkPinj j P := match P with | Pc _ => P - | Pinj j' Q => Pinj ((j + j'):positive) Q + | Pinj j' Q => Pinj (j + j') Q | _ => Pinj j P end. Definition mkPinj_pred j P:= match j with | xH => P - | xO j => Pinj (Pdouble_minus_one j) P + | xO j => Pinj (Pos.pred_double j) P | xI j => Pinj (xO j) P end. @@ -157,14 +172,14 @@ Section MakeRingPol. (** Addition et subtraction *) - Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol := + Fixpoint PaddC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 +! c) | Pinj j Q => Pinj j (PaddC Q c) | PX P i Q => PX P i (PaddC Q c) end. - Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol := + Fixpoint PsubC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 -! c) | Pinj j Q => Pinj j (PsubC Q c) @@ -176,11 +191,11 @@ Section MakeRingPol. Variable Pop : Pol -> Pol -> Pol. Variable Q : Pol. - Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol := + Fixpoint PaddI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC Q c) | Pinj j' Q' => - match ZPminus j' j with + match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PaddI k Q') @@ -188,16 +203,16 @@ Section MakeRingPol. | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PaddI (Pdouble_minus_one j) Q') + | xO j => PX P i (PaddI (Pos.pred_double j) Q') | xI j => PX P i (PaddI (xO j) Q') end end. - Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := + Fixpoint PsubI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC (--Q) c) | Pinj j' Q' => - match ZPminus j' j with + match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PsubI k Q') @@ -205,41 +220,41 @@ Section MakeRingPol. | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PsubI (Pdouble_minus_one j) Q') + | xO j => PX P i (PsubI (Pos.pred_double j) Q') | xI j => PX P i (PsubI (xO j) Q') end end. Variable P' : Pol. - Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol := + Fixpoint PaddX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX P' i' P | Pinj j Q' => match j with | xH => PX P' i' Q' - | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q') + | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') | xI j => PX P' i' (Pinj (xO j) Q') end | PX P i Q' => - match ZPminus i i' with + match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PaddX k P) i Q' end end. - Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol := + Fixpoint PsubX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX (--P') i' P | Pinj j Q' => match j with | xH => PX (--P') i' Q' - | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q') + | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') | xI j => PX (--P') i' (Pinj (xO j) Q') end | PX P i Q' => - match ZPminus i i' with + match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PsubX k P) i Q' @@ -259,18 +274,18 @@ Section MakeRingPol. | Pinj j Q => match j with | xH => PX P' i' (Padd Q Q') - | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q') + | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') end | PX P i Q => - match ZPminus i i' with + match Z.pos_sub i i' with | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') | Z0 => mkPX (Padd P P') i (Padd Q Q') | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') end end end. - Notation "P ++ P'" := (Padd P P'). + Infix "++" := Padd. Fixpoint Psub (P P': Pol) {struct P'} : Pol := match P' with @@ -282,22 +297,22 @@ Section MakeRingPol. | Pinj j Q => match j with | xH => PX (--P') i' (Psub Q Q') - | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q') + | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') end | PX P i Q => - match ZPminus i i' with + match Z.pos_sub i i' with | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') | Z0 => mkPX (Psub P P') i (Psub Q Q') | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') end end end. - Notation "P -- P'" := (Psub P P'). + Infix "--" := Psub. (** Multiplication *) - Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := + Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := match P with | Pc c' => Pc (c' *! c) | Pinj j Q => mkPinj j (PmulC_aux Q c) @@ -311,11 +326,11 @@ Section MakeRingPol. Section PmulI. Variable Pmul : Pol -> Pol -> Pol. Variable Q : Pol. - Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol := + Fixpoint PmulI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PmulC Q c) | Pinj j' Q' => - match ZPminus j' j with + match Z.pos_sub j' j with | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) | Z0 => mkPinj j (Pmul Q' Q) | Zneg k => mkPinj j' (PmulI k Q') @@ -323,13 +338,12 @@ Section MakeRingPol. | PX P' i' Q' => match j with | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) - | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q') + | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') end end. End PmulI. -(* A symmetric version of the multiplication *) Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := match P'' with @@ -342,7 +356,7 @@ Section MakeRingPol. let QQ' := match j with | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' + | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' | xI j => Pmul (Pinj (xO j) Q) Q' end in mkPX (Pmul P P') i' QQ' @@ -355,25 +369,7 @@ Section MakeRingPol. end end. -(* Non symmetric *) -(* - Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol := - match P' with - | Pc c' => PmulC P c' - | Pinj j' Q' => PmulI Pmul_aux Q' j' P - | PX P' i' Q' => - (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) - end. - - Definition Pmul P P' := - match P with - | Pc c => PmulC P' c - | Pinj j Q => PmulI Pmul_aux Q j P' - | PX P i Q => - (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') - end. -*) - Notation "P ** P'" := (Pmul P P'). + Infix "**" := Pmul. Fixpoint Psquare (P:Pol) : Pol := match P with @@ -388,26 +384,26 @@ Section MakeRingPol. (** Monomial **) + (** A monomial is X1^k1...Xi^ki. Its representation + is a simplified version of the polynomial representation: + + - [mon0] correspond to the polynom [P1]. + - [(zmon j M)] corresponds to [(Pinj j ...)], + i.e. skip j variable indices. + - [(vmon i M)] is X^i*M with X the current variable, + its corresponds to (PX P1 i ...)] + *) + Inductive Mon: Set := - mon0: Mon + | mon0: Mon | zmon: positive -> Mon -> Mon | vmon: positive -> Mon -> Mon. - Fixpoint Mphi(l:Env R) (M: Mon) {struct M} : R := - match M with - mon0 => rI - | zmon j M1 => Mphi (jump j l) M1 - | vmon i M1 => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Mphi (tail l) M1) * xi - end. - Definition mkZmon j M := match M with mon0 => mon0 | _ => zmon j M end. Definition zmon_pred j M := - match j with xH => M | _ => mkZmon (Ppred j) M end. + match j with xH => M | _ => mkZmon (Pos.pred j) M end. Definition mkVmon i M := match M with @@ -416,12 +412,12 @@ Section MakeRingPol. | vmon i' m => vmon (i+i') m end. - Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol := + Fixpoint MFactor (P: Pol) (M: Mon) : 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 + match (j1 ?= j2) 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 @@ -435,7 +431,7 @@ Section MakeRingPol. 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 + match (i ?= j) 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 @@ -453,7 +449,7 @@ Section MakeRingPol. | _ => Some (Padd Q1 (Pmul P2 R1)) end. - Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol := + Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) : Pol := match POneSubst P1 M1 P2 with Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end | _ => P1 @@ -465,14 +461,13 @@ Section MakeRingPol. | _ => None end. - Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: - Pol := + Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : 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 := + Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) : option Pol := match LM1 with cons (M1,P2) LM2 => match PNSubst P1 M1 P2 n with @@ -482,7 +477,7 @@ Section MakeRingPol. | _ => None end. - Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol := + Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) : Pol := match PSubstL P1 LM1 n with Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end | _ => P1 @@ -490,726 +485,446 @@ Section MakeRingPol. (** Evaluation of a polynomial towards R *) - Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R := + Fixpoint Pphi(l:Env R) (P:Pol) : R := match P with | Pc c => [c] | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Pphi l P) * xi + (Pphi (tail l) Q) + | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q end. Reserved Notation "P @ l " (at level 10, no associativity). Notation "P @ l " := (Pphi l P). + + (** Evaluation of a monomial towards R *) + + Fixpoint Mphi(l:Env R) (M: Mon) : R := + match M with + | mon0 => rI + | zmon j M1 => Mphi (jump j l) M1 + | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i + end. + + Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). + (** Proofs *) - Lemma ZPminus_spec : forall x y, - match ZPminus x y with - | Z0 => x = y - | Zpos k => x = (y + k)%positive - | Zneg k => y = (x + k)%positive + + Ltac destr_pos_sub := + match goal with |- context [Z.pos_sub ?x ?y] => + generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) end. + + Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l. Proof. - induction x;destruct y. - replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - simpl;trivial. - replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial. - replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - simpl;trivial. + revert P';induction P;destruct P';simpl; intros H l; try easy. + - now apply (morph_eq CRmorph). + - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. + now rewrite IHP. + - specialize (IHP1 P'1); specialize (IHP2 P'2). + destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. + destruct (P2 ?== P'1); [|easy]. + rewrite H in *. + now rewrite IHP1, IHP2. Qed. - Lemma Peq_ok : forall P P', - (P ?== P') = true -> forall l, P@l == P'@ l. + Lemma Peq_spec P P' : + BoolSpec (forall l, P@l == P'@l) True (P ?== P'). Proof. - induction P;destruct P';simpl;intros;try discriminate;trivial. - apply (morph_eq CRmorph);trivial. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite (IHP P' H); rewrite H1;trivial;rrefl. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite H1;trivial. clear H1. - assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); - destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H] - |discriminate H]. - rewrite (H1 H);rewrite (H2 H);rrefl. + generalize (Peq_ok P P'). destruct (P ?== P'); auto. Qed. - Lemma Pphi0 : forall l, P0@l == 0. + Lemma Pphi0 l : P0@l == 0. Proof. - intros;simpl;apply (morph0 CRmorph). + simpl;apply (morph0 CRmorph). Qed. -Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> - p @ e1 = p @ e2. + Lemma Pphi1 l : P1@l == 1. + Proof. + simpl;apply (morph1 CRmorph). + Qed. + +Lemma env_morph p e1 e2 : + (forall x, e1 x = e2 x) -> p @ e1 = p @ e2. Proof. - induction p ; simpl. - reflexivity. - intros. - apply IHp. - intros. - unfold jump. - apply H. - intros. - rewrite (IHp1 e1 e2) ; auto. - rewrite (IHp2 (tail e1) (tail e2)) ; auto. - unfold hd. unfold nth. rewrite H. reflexivity. - unfold tail. unfold jump. intros ; apply H. + revert e1 e2. induction p ; simpl. + - reflexivity. + - intros e1 e2 EQ. apply IHp. intros. apply EQ. + - intros e1 e2 EQ. f_equal; [f_equal|]. + + now apply IHp1. + + f_equal. apply EQ. + + apply IHp2. intros; apply EQ. Qed. -Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)). +Lemma Pjump_add P i j l : + P @ (jump (i + j) l) = P @ (jump j (jump i l)). Proof. - intros. apply env_morph. intros. rewrite <- jump_Pplus. - rewrite Pplus_comm. - reflexivity. + apply env_morph. intros. rewrite <- jump_add. f_equal. + apply Pos.add_comm. Qed. -Lemma Pjump_xO_tail : forall P p l, +Lemma Pjump_xO_tail P p l : P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). Proof. - intros. - apply env_morph. - intros. - rewrite (@jump_simpl R (xI p)). - rewrite (@jump_simpl R (xO p)). - reflexivity. + apply env_morph. intros. now jump_simpl. Qed. -Lemma Pjump_Pdouble_minus_one : forall P p l, - P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l). +Lemma Pjump_pred_double P p l : + P @ (jump (Pos.pred_double p) (tail l)) = P @ (jump (xO p) l). Proof. - intros. - apply env_morph. - intros. - rewrite jump_Pdouble_minus_one. - rewrite (@jump_simpl R (xO p)). - reflexivity. + apply env_morph. intros. + rewrite jump_pred_double. now jump_simpl. Qed. - - - Lemma Pphi1 : forall l, P1@l == 1. + Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). Proof. - intros;simpl;apply (morph1 CRmorph). + destruct P;simpl;rsimpl. + now rewrite Pjump_add. Qed. - Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l). + Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. Proof. - intros j l p;destruct p;simpl;rsimpl. - rewrite Pjump_Pplus. - reflexivity. + rewrite Pos.add_comm. + apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). Qed. - Let pow_pos_Pplus := - pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc). - - Lemma mkPX_ok : forall l P i Q, - (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l). + Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). Proof. - intros l P i Q;unfold mkPX. - destruct P;try (simpl;rrefl). - assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl. - rewrite (H (refl_equal true));rewrite (morph0 CRmorph). - rewrite mkPinj_ok;rsimpl;simpl;rrefl. - assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl. - rewrite (H (refl_equal true));trivial. - rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl. + generalize (morph_eq CRmorph c c'). + destruct (c ?=! c'); auto. Qed. - - Ltac Esimpl := - repeat (progress ( - match goal with - | |- context [P0@?l] => rewrite (Pphi0 l) - | |- context [P1@?l] => rewrite (Pphi1 l) - | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P) - | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q) - | |- context [[cO]] => rewrite (morph0 CRmorph) - | |- context [[cI]] => rewrite (morph1 CRmorph) - | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y) - | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y) - | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y) - | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x) - end)); - rsimpl; simpl. - - Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. + Lemma mkPX_ok l P i Q : + (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP2;rsimpl. + unfold mkPX. destruct P. + - case ceqb_spec; intros H; simpl; try reflexivity. + rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. + - reflexivity. + - case Peq_spec; intros H; simpl; try reflexivity. + rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. Qed. - Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c]. + Hint Rewrite + Pphi0 + Pphi1 + mkPinj_ok + mkPX_ok + (morph0 CRmorph) + (morph1 CRmorph) + (morph0 CRmorph) + (morph_add CRmorph) + (morph_mul CRmorph) + (morph_sub CRmorph) + (morph_opp CRmorph) + : Esimpl. + + (* Quicker than autorewrite with Esimpl :-) *) + Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. + + Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. Proof. - induction P;simpl;intros. - Esimpl. - rewrite IHP;rsimpl. + revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP2;rsimpl. Qed. - Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. + Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP1;rewrite IHP2;rsimpl. - mul_push ([c]);rrefl. + revert l;induction P;simpl;intros. + - Esimpl. + - rewrite IHP;rsimpl. + - rewrite IHP2;rsimpl. Qed. - Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. + Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. Proof. - intros c P l; unfold PmulC. - assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO). - rewrite (H (refl_equal true));Esimpl. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - apply PmulC_aux_ok. + revert l;induction P;simpl;intros;Esimpl;trivial. + rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. Qed. - Lemma Popp_ok : forall P l, (--P)@l == - P@l. + Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. Proof. - induction P;simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1;rewrite IHP2;rsimpl. + unfold PmulC. + case ceqb_spec; intros H. + - rewrite H; Esimpl. + - case ceqb_spec; intros H'. + + rewrite H'; Esimpl. + + apply PmulC_aux_ok. Qed. - Ltac Esimpl2 := - Esimpl; - repeat (progress ( - match goal with - | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l) - | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l) - | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) - | |- context [(--?P)@?l] => rewrite (Popp_ok P l) - end)); Esimpl. - - - - - Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l. + Lemma Popp_ok P l : (--P)@l == - P@l. Proof. - induction P';simpl;intros;Esimpl2. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rrefl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite Pjump_Pplus. rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite Pjump_Pplus. rrefl. - destruct p0;simpl. - rewrite IHP2;simpl. rsimpl. - rewrite Pjump_xO_tail. Esimpl. - rewrite IHP2;simpl. - rewrite Pjump_Pdouble_minus_one. - rsimpl. - rewrite IHP'. - rsimpl. - destruct P;simpl. - Esimpl2;add_push [c];rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl. - rewrite Pjump_xO_tail. - rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;simpl. - rewrite Pjump_Pdouble_minus_one. rsimpl. - add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl. - unfold tail. - add_push (P @ (jump 1 l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1;rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros;try apply (ARadd_comm ARth). - destruct p2; simpl; try apply (ARadd_comm ARth). - rewrite Pjump_xO_tail. - apply (ARadd_comm ARth). - rewrite Pjump_Pdouble_minus_one. - apply (ARadd_comm ARth). - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. - rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. - rewrite IHP'1;simpl;Esimpl. - rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. + revert l;induction P;simpl;intros. + - Esimpl. + - apply IHP. + - rewrite IHP1, IHP2;rsimpl. Qed. - Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. + Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. + + Lemma PaddX_ok P' P k l : + (forall P l, (P++P')@l == P@l + P'@l) -> + (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. Proof. - induction P';simpl;intros;Esimpl2;trivial. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rsimpl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl. - destruct p0;simpl. - rewrite IHP2;simpl; try rewrite Pjump_xO_tail ; rsimpl. - rewrite IHP2;simpl. - rewrite Pjump_Pdouble_minus_one;rsimpl. - unfold tail ; rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. - repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. - rewrite Pjump_xO_tail. - add_push (P @ ((jump (xI p0) l)));rrefl. - rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl. - add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. - unfold tail. - rewrite IHP'2;rsimpl;add_push (P @ (jump 1 l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1; rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros. - rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. - destruct p2;simpl; rewrite Popp_ok;rsimpl. - rewrite Pjump_xO_tail. - apply (ARadd_comm ARth);trivial. - rewrite Pjump_Pdouble_minus_one. - apply (ARadd_comm ARth);trivial. - apply (ARadd_comm ARth);trivial. - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. - rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl. - rewrite IHP'1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. + intros IHP'. + revert k l. induction P;simpl;intros. + - add_permut. + - destruct p; simpl; + rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. + - destr_pos_sub; intros ->;Esimpl. + + rewrite IHP';rsimpl. add_permut. + + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. -(* Proof for the symmetric version *) - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : Env R), (Pmul P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : Env R), - (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). + Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pjump_Pplus;simpl;rrefl. - rewrite H1. - rewrite Pjump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;rsimpl. - rewrite Pjump_xO_tail. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite Pjump_Pdouble_minus_one. - rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. + revert P l; induction P';simpl;intros;Esimpl. + - revert p l; induction P;simpl;intros. + + Esimpl; add_permut. + + destr_pos_sub; intros ->;Esimpl. + * now rewrite IHP'. + * rewrite IHP';Esimpl. now rewrite Pjump_add. + * rewrite IHP. now rewrite Pjump_add. + + destruct p0;simpl. + * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. + * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. + * rewrite IHP'. rsimpl. + - destruct P;simpl. + + Esimpl. add_permut. + + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. + * rewrite Pjump_xO_tail. rsimpl. add_permut. + * rewrite Pjump_pred_double. rsimpl. add_permut. + * rsimpl. unfold tail. add_permut. + + destr_pos_sub; intros ->; Esimpl. + * rewrite IHP'1, IHP'2;rsimpl. add_permut. + * rewrite IHP'1, IHP'2;simpl;Esimpl. + rewrite pow_pos_add;rsimpl. add_permut. + * rewrite PaddX_ok by trivial; rsimpl. + rewrite IHP'2, pow_pos_add; rsimpl. add_permut. Qed. -(* - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : list R), - (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l). + Lemma PsubX_ok P' P k l : + (forall P l, (P--P')@l == P@l - P'@l) -> + (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k. Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pplus_comm. - rewrite jump_Pplus;simpl;rrefl. - rewrite H1;rewrite Pplus_comm. - rewrite jump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. + intros IHP'. + revert k l. induction P;simpl;intros. + - rewrite Popp_ok;rsimpl; add_permut. + - destruct p; simpl; + rewrite Popp_ok;rsimpl; + rewrite ?Pjump_xO_tail, ?Pjump_pred_double; add_permut. + - destr_pos_sub; intros ->; Esimpl. + + rewrite IHP';rsimpl. add_permut. + + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. - Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l. + Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. Proof. - induction P';simpl;intros. - Esimpl2;trivial. - apply PmulI_ok;trivial. - rewrite Padd_ok;Esimpl2. - rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl. + revert P l; induction P';simpl;intros;Esimpl. + - revert p l; induction P;simpl;intros. + + Esimpl; add_permut. + + destr_pos_sub; intros ->;Esimpl. + * rewrite IHP';rsimpl. + * rewrite IHP';Esimpl. now rewrite Pjump_add. + * rewrite IHP. now rewrite Pjump_add. + + destruct p0;simpl. + * rewrite IHP2;simpl. rsimpl. rewrite Pjump_xO_tail. Esimpl. + * rewrite IHP2;simpl. rewrite Pjump_pred_double. rsimpl. + * rewrite IHP'. rsimpl. + - destruct P;simpl. + + Esimpl; add_permut. + + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. + * rewrite Pjump_xO_tail. rsimpl. add_permut. + * rewrite Pjump_pred_double. rsimpl. add_permut. + * rsimpl. unfold tail. add_permut. + + destr_pos_sub; intros ->; Esimpl. + * rewrite IHP'1, IHP'2;rsimpl. add_permut. + * rewrite IHP'1, IHP'2;simpl;Esimpl. + rewrite pow_pos_add;rsimpl. add_permut. + * rewrite PsubX_ok by trivial;rsimpl. + rewrite IHP'2, pow_pos_add;rsimpl. add_permut. Qed. -*) -(* Proof for the symmetric version *) - Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Lemma PmulI_ok P' : + (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> + forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). Proof. - intros P P';generalize P;clear P;induction P';simpl;intros. - apply PmulC_ok. apply PmulI_ok;trivial. - destruct P. - rewrite (ARmul_comm ARth);Esimpl2;Esimpl2. - Esimpl2. rewrite IHP'1;Esimpl2. - assert (match p0 with - | xI j => Pinj (xO j) P ** P'2 - | xO j => Pinj (Pdouble_minus_one j) P ** P'2 - | 1 => P ** P'2 - end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). - destruct p0;rewrite IHP'2;Esimpl. - rewrite Pjump_xO_tail. reflexivity. - rewrite Pjump_Pdouble_minus_one;Esimpl. - rewrite H;Esimpl. - rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2. - repeat (rewrite IHP'1 || rewrite IHP'2);simpl. - rewrite PmulI_ok;trivial. - unfold tail. - mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 l)). Esimpl. + intros IHP'. + induction P;simpl;intros. + - Esimpl; mul_permut. + - destr_pos_sub; intros ->;Esimpl. + + now rewrite IHP'. + + now rewrite IHP', Pjump_add. + + now rewrite IHP, Pjump_add. + - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. + + rewrite Pjump_xO_tail. f_equiv. mul_permut. + + rewrite Pjump_pred_double. f_equiv. mul_permut. + + rewrite IHP'. f_equiv. mul_permut. Qed. -(* -Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. Proof. - destruct P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - rewrite (PmulI_ok P (Pmul_aux_ok P)). - apply (ARmul_comm ARth). - rewrite Padd_ok; Esimpl2. - rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. - rewrite Pmul_aux_ok;mul_push (P' @ l). - rewrite (ARmul_comm ARth (P' @ l));rrefl. + revert P l;induction P';simpl;intros. + - apply PmulC_ok. + - apply PmulI_ok;trivial. + - destruct P. + + rewrite (ARmul_comm ARth). Esimpl. + + Esimpl. rewrite IHP'1;Esimpl. f_equiv. + destruct p0;rewrite IHP'2;Esimpl. + * now rewrite Pjump_xO_tail. + * rewrite Pjump_pred_double; Esimpl. + + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, + !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. + unfold tail. + add_permut; f_equiv; mul_permut. Qed. -*) - Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. + Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l. Proof. - induction P;simpl;intros;Esimpl2. - apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2. - rewrite IHP1;rewrite IHP2. - mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l). - rrefl. + revert l;induction P;simpl;intros;Esimpl. + - apply IHP. + - rewrite Padd_ok, Pmul_ok;Esimpl. + rewrite IHP1, IHP2. + mul_push ((hd l)^p). now mul_push (P2@l). Qed. - Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) -> - Mphi env P = Mphi env' P. + Lemma Mphi_morph M e1 e2 : + (forall x, e1 x = e2 x) -> M @@ e1 = M @@ e2. Proof. - induction P ; simpl. - reflexivity. - intros. - apply IHP. - intros. - unfold jump. - apply H. - (**) - intros. - replace (Mphi (tail env) P) with (Mphi (tail env') P). - unfold hd. unfold nth. - rewrite H. - reflexivity. - apply IHP. - unfold tail,jump. - intros. symmetry. apply H. + revert e1 e2; induction M; simpl; intros e1 e2 EQ; trivial. + - apply IHM. intros; apply EQ. + - f_equal. + * apply IHM. intros; apply EQ. + * f_equal. apply EQ. Qed. -Lemma Mjump_xO_tail : forall M p l, - Mphi (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M. +Lemma Mjump_xO_tail M p l : + M @@ (jump (xO p) (tail l)) = M @@ (jump (xI p) l). Proof. - intros. - apply Mphi_morph. - intros. - rewrite (@jump_simpl R (xI p)). - rewrite (@jump_simpl R (xO p)). - reflexivity. + apply Mphi_morph. intros. now jump_simpl. Qed. -Lemma Mjump_Pdouble_minus_one : forall M p l, - Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M. +Lemma Mjump_pred_double M p l : + M @@ (jump (Pos.pred_double p) (tail l)) = M @@ (jump (xO p) l). Proof. - intros. - apply Mphi_morph. - intros. - rewrite jump_Pdouble_minus_one. - rewrite (@jump_simpl R (xO p)). - reflexivity. + apply Mphi_morph. intros. + rewrite jump_pred_double. now jump_simpl. Qed. -Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M. +Lemma Mjump_add M i j l : + M @@ (jump (i + j) l) = M @@ (jump j (jump i l)). Proof. - intros. apply Mphi_morph. intros. rewrite <- jump_Pplus. - rewrite Pplus_comm. - reflexivity. + apply Mphi_morph. intros. now rewrite <- jump_add, Pos.add_comm. 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. + Lemma mkZmon_ok M j l : + (mkZmon j M) @@ l == (zmon j M) @@ l. + Proof. + destruct M; simpl; rsimpl. Qed. - Lemma zmon_pred_ok : forall M j l, - Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). + Lemma zmon_pred_ok M j l : + (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. Proof. - destruct j; simpl;intros l; rsimpl. - rewrite mkZmon_ok;rsimpl. - simpl. - rewrite Mjump_xO_tail. - reflexivity. - rewrite mkZmon_ok;simpl. - rewrite Mjump_Pdouble_minus_one; rsimpl. + destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. + - now rewrite Mjump_xO_tail. + - rewrite Mjump_pred_double; rsimpl. Qed. - Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i. + Lemma mkVmon_ok M i l : + (mkVmon i M)@@l == M@@l * (hd l)^i. Proof. destruct M;simpl;intros;rsimpl. - rewrite zmon_pred_ok;simpl;rsimpl. - rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. + - rewrite zmon_pred_ok;simpl;rsimpl. + - rewrite pow_pos_add;rsimpl. Qed. + Ltac destr_mfactor R S := match goal with + | H : context [MFactor ?P _] |- context [MFactor ?P ?M] => + specialize (H M); destruct MFactor as (R,S) + end. - Lemma Mphi_ok: forall P M l, - let (Q,R) := MFactor P M in - P@l == Q@l + (Mphi l M) * (R@l). + Lemma Mphi_ok P M l : + let (Q,R) := MFactor P M in + P@l == Q@l + M@@l * R@l. Proof. - intros P; elim P; simpl; auto; clear P. - intros c M l; case M; simpl; auto; try intro p; try intro m; - try rewrite (morph0 CRmorph); rsimpl. - - intros i P Hrec M l; case M; simpl; clear M. - rewrite (morph0 CRmorph); rsimpl. - intros j M. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec M (jump j l)); case (MFactor P M); - simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - generalize (Hrec (zmon (j -i) M) (jump i l)); - case (MFactor P (zmon (j -i) M)); simpl. - intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). - rewrite Mjump_Pplus; auto. - rewrite (morph0 CRmorph); rsimpl. - intros P2 m; rewrite (morph0 CRmorph); rsimpl. - - intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto. - rewrite (morph0 CRmorph); rsimpl. - intros j M1. - generalize (Hrec1 (zmon j M1) l); - case (MFactor P2 (zmon j M1)). - intros R1 S1 H1. - generalize (Hrec2 (zmon_pred j M1) (tail l)); - case (MFactor Q2 (zmon_pred j M1)); simpl. - intros R2 S2 H2; rewrite H1; rewrite H2. - repeat rewrite mkPX_ok; simpl. - rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - rewrite zmon_pred_ok;rsimpl. - intros j M1. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite mkZmon_ok. - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - generalize (Hrec1 (vmon (j - i) M1) l); - case (MFactor P2 (vmon (j - i) M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. - generalize (Hrec1 (mkZmon 1 M1) l); - case (MFactor P2 (mkZmon 1 M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite mkZmon_ok. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - rewrite mkPX_ok; simpl; rsimpl. - rewrite (morph0 CRmorph); rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite (ARmul_comm ARth (Q3@l)); rsimpl. - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ He); rsimpl. + revert M l; induction P; destruct M; intros l; simpl; auto; Esimpl. + - case Pos.compare_spec; intros He; simpl. + * destr_mfactor R1 S1. now rewrite IHP, He, !mkPinj_ok. + * destr_mfactor R1 S1. rewrite IHP; simpl. + now rewrite !mkPinj_ok, <- Mjump_add, Pos.add_comm, Pos.sub_add. + * Esimpl. + - destr_mfactor R1 S1. destr_mfactor R2 S2. + rewrite IHP1, IHP2, !mkPX_ok, zmon_pred_ok; simpl; rsimpl. + add_permut. + - case Pos.compare_spec; intros He; simpl; destr_mfactor R1 S1; + rewrite ?He, IHP1, mkPX_ok, ?mkZmon_ok; simpl; rsimpl; + unfold tail; add_permut; mul_permut. + * rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. + * rewrite mkPX_ok. simpl. Esimpl. mul_permut. + rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. Qed. -(* Proof for the symmetric version *) - - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. + Lemma POneSubst_ok P1 M1 P2 P3 l : + POneSubst P1 M1 P2 = Some P3 -> M1@@l == P2@l -> + P1@l == P3@l. Proof. - intros P2 M1 P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - (* new version *) - rewrite Padd_ok; rewrite PmulC_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - assert (P4 = Q1 ++ P3 ** PX i P5 P6). - injection H2; intros; subst;trivial. - rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl. -Qed. -(* - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. -Proof. - intros P2 M1 P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - injection H2; intros; subst; rsimpl. - rewrite Padd_ok. - rewrite Pmul_ok; rsimpl. + unfold POneSubst. + assert (H := Mphi_ok P1). destr_mfactor R1 S1. rewrite H; clear H. + intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). + - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. + - revert EQ. destruct S1; try now injection 1. + case ceqb_spec; now inversion 2. Qed. -*) - Lemma PNSubst1_ok: forall n P1 M1 P2 l, - Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. + + Lemma PNSubst1_ok n P1 M1 P2 l : + M1@@l == 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. + revert P1. induction n; simpl; intros P1; + generalize (POneSubst_ok P1 M1 P2); destruct POneSubst; + intros; rewrite <- ?IHn; auto; reflexivity. 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. + Lemma PNSubst_ok n P1 M1 P2 l P3 : + PNSubst P1 M1 P2 n = Some P3 -> M1@@l == 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. + unfold PNSubst. + assert (H := POneSubst_ok P1 M1 P2); destruct POneSubst; try discriminate. + destruct n; inversion_clear 1. + intros. rewrite <- PNSubst1_ok; auto. Qed. - Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop := - match LM1 with - cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l) - | _ => True - end. + Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) : Prop := + match LM1 with + | cons (M1,P2) LM2 => (M1@@l == 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. + Lemma PSubstL1_ok 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. + revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. + - reflexivity. + - rewrite <- IH by intuition. now apply PNSubst1_ok. Qed. - Lemma PSubstL_ok: forall n LM1 P1 P2 l, - PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. + Lemma PSubstL_ok 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. + revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. + - discriminate. + - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. + * injection H; intros <-. rewrite <- PSubstL1_ok; intuition. + * now apply IH. Qed. - Lemma PNSubstL_ok: forall m n LM1 P1 l, - MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. + Lemma PNSubstL_ok 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. + revert LM1 P1. induction m; simpl; intros; + assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; + auto; try reflexivity. + rewrite <- IHm; auto. Qed. (** Definition of polynomial expressions *) @@ -1228,7 +943,7 @@ Proof. (** evaluation of polynomial expressions towards R *) - Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R := + Fixpoint PEeval (l:Env R) (pe:PExpr) : R := match pe with | PEc c => phi c | PEX j => nth j l @@ -1241,60 +956,23 @@ Proof. (** Correctness proofs *) - Lemma mkX_ok : forall p l, nth p l == (mk_X p) @ l. + Lemma mkX_ok p l : nth p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. rewrite nth_spec ; auto. unfold hd. - rewrite <- nth_Pdouble_minus_one. - rewrite (nth_jump (Pdouble_minus_one p) l 1). - reflexivity. + now rewrite <- nth_pred_double, nth_jump. Qed. - Ltac Esimpl3 := - repeat match goal with - | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) - | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) - end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). - -(* Power using the chinise algorithm *) -(*Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => P - | xO p => subst_l (Psquare (Ppow_pos P p)) - | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p))) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P p - end. - - Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l. - Proof. - intros l subst_l_ok P. - induction p;simpl;intros;try rrefl;try rewrite subst_l_ok. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - Qed. - - Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed. - - End POWER. *) + Hint Rewrite Padd_ok Psub_ok : Esimpl. Section POWER. Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := + Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := match p with - | xH => subst_l (Pmul res P) + | xH => subst_l (res ** P) | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P) + | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) end. Definition Ppow_N P n := @@ -1303,17 +981,23 @@ Section POWER. | Npos p => Ppow_pos P1 P p end. - Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. + Lemma Ppow_pos_ok l : + (forall P, subst_l P@l == P@l) -> + forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. Proof. - intros l subst_l_ok res P p. generalize res;clear res. - induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp. - rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl. + intros subst_l_ok res P p. revert res. + induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; + mul_permut. Qed. - Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl. auto. Qed. + Lemma Ppow_N_ok l : + (forall P, subst_l P@l == P@l) -> + forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. + Proof. + destruct n;simpl. + - reflexivity. + - rewrite Ppow_pos_ok by trivial. Esimpl. + Qed. End POWER. @@ -1342,62 +1026,57 @@ Section POWER. Definition norm_subst pe := subst_l (norm_aux pe). - (* - Fixpoint norm_subst (pe:PExpr) : Pol := + (** Internally, [norm_aux] is expanded in a large number of cases. + To speed-up proofs, we use an alternative definition. *) + + Definition get_PEopp pe := match pe with - | PEc c => Pc c - | PEX j => subst_l (mk_X j) - | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_subst pe1) (norm_subst pe2) - | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2) - | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2) - | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) - | PEopp pe1 => Popp (norm_subst pe1) - | PEpow pe1 n => Ppow_subst (norm_subst pe1) n + | PEopp pe' => Some pe' + | _ => None end. - Lemma norm_subst_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. + Lemma norm_aux_PEadd pe1 pe2 : + norm_aux (PEadd pe1 pe2) = + match get_PEopp pe1, get_PEopp pe2 with + | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') + | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') + | None, None => (norm_aux pe1) ++ (norm_aux pe2) + end. Proof. - intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). - unfold subst_l;intros. - rewrite <- PNSubstL_ok;trivial. rrefl. - assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l). - intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl. - induction pe;simpl;Esimpl3. - rewrite subst_l_ok;apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe;rrefl. - unfold Ppow_subst. rewrite Ppow_N_ok. trivial. - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. + simpl (norm_aux (PEadd _ _)). + destruct pe1; [ | | | | | reflexivity | ]; + destruct pe2; simpl get_PEopp; reflexivity. Qed. -*) - Lemma norm_aux_spec : - forall l pe, (*MPcond lmp l ->*) - PEeval l pe == (norm_aux pe)@l. + + Lemma norm_aux_PEopp pe : + match get_PEopp pe with + | Some pe' => norm_aux pe = -- (norm_aux pe') + | None => True + end. Proof. - intros. - induction pe;simpl;Esimpl3. - apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. - rewrite IHpe;rrefl. - rewrite Ppow_N_ok by reflexivity. - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. + now destruct pe. Qed. + Lemma norm_aux_spec l pe : + PEeval l pe == (norm_aux pe)@l. + Proof. + intros. + induction pe. + - reflexivity. + - apply mkX_ok. + - simpl PEeval. rewrite IHpe1, IHpe2. + assert (H1 := norm_aux_PEopp pe1). + assert (H2 := norm_aux_PEopp pe2). + rewrite norm_aux_PEadd. + do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. + - simpl. rewrite IHpe1, IHpe2. Esimpl. + - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. + - simpl. rewrite IHpe. Esimpl. + - simpl. rewrite Ppow_N_ok by reflexivity. + rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. + induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. + Qed. End NORM_SUBST_REC. - End MakeRingPol. - diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 5afe7e37..64181cde 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -23,7 +23,7 @@ Require Import NArith. Require Import QArith. Extract Inductive prod => "( * )" [ "(,)" ]. -Extract Inductive List.list => list [ "[]" "(::)" ]. +Extract Inductive list => list [ "[]" "(::)" ]. Extract Inductive bool => bool [ true false ]. Extract Inductive sumbool => bool [ true false ]. Extract Inductive option => option [ Some None ]. @@ -38,10 +38,23 @@ Extract Inductive sumor => option [ Some None ]. Let's rather use the ocaml && *) Extract Inlined Constant andb => "(&&)". +Require Import Reals. + +Extract Constant R => "int". +Extract Constant R0 => "0". +Extract Constant R1 => "1". +Extract Constant Rplus => "( + )". +Extract Constant Rmult => "( * )". +Extract Constant Ropp => "fun x -> - x". +Extract Constant Rinv => "fun x -> 1 / x". + Extraction "micromega.ml" List.map simpl_cone (*map_cone indexes*) denorm Qpower - n_of_Z Nnat.N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. + n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. + + + (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index e4f91fb6..b260feab 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v index fde0f29a..bcf84c6b 100644 --- a/plugins/micromega/Psatz.v +++ b/plugins/micromega/Psatz.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,7 +18,7 @@ Require Import RMicromega. Require Import QArith. Require Export Ring_normalize. Require Import ZArith. -Require Import Raxioms. +Require Import Rdefinitions. Require Export RingMicromega. Require Import VarMap. Require Tauto. @@ -66,6 +66,7 @@ Ltac psatzl dom := change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity) | R => + unfold Rdiv in * ; psatzl_R ; (* If csdp is not installed, the previous step might not produce any progress: the rest of the tactical will then fail. Hence the 'try'. *) @@ -75,12 +76,25 @@ Ltac psatzl dom := | _ => fail "Unsupported domain" end in tac. + +Ltac lra := + first [ psatzl R | psatzl Q ]. + Ltac lia := - xlia ; + zify ; unfold Z.succ in * ; + (*cbv delta - [Z.add Z.sub Z.opp Z.mul Z.pow Z.gt Z.ge Z.le Z.lt iff not] ;*) xlia ; intros __wit __varmap __ff ; change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. +Ltac nia := + zify ; unfold Z.succ in * ; + xnlia ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. + + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index 5ff6a1a7..792e2c3c 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -60,7 +60,7 @@ Proof. Qed. -(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*) +(*Definition Zeval_expr := eval_pexpr 0 Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => Z.of_N x) (Z.pow).*) Require Import EnvRing. Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := @@ -71,7 +71,7 @@ Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) + | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) end. Lemma Qeval_expr_simpl : forall env e, @@ -83,7 +83,7 @@ Lemma Qeval_expr_simpl : forall env e, | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) | PEopp pe1 => - (Qeval_expr env pe1) - | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n) + | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z.of_N n) end. Proof. destruct e ; reflexivity. @@ -91,7 +91,7 @@ Qed. Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult). -Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n. +Lemma QNpower : forall r n, r ^ Z.of_N n = pow_N 1 Qmult r n. Proof. destruct n ; reflexivity. Qed. @@ -173,8 +173,15 @@ Require Import Tauto. Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. +Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. + +Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool. + + + Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := @tauto_checker (Formula Q) (NFormula Q) + qunsat qdeduce Qnormalise Qnegate QWitness QWeakChecker f w. @@ -186,6 +193,11 @@ Proof. unfold QTautoChecker. apply (tauto_checker_sound Qeval_formula Qeval_nformula). apply Qeval_nformula_dec. + intros until env. + unfold eval_nformula. unfold RingMicromega.eval_nformula. + destruct t. + apply (check_inconsistent_sound Qsor QSORaddon) ; auto. + unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon). intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor QSORaddon). intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon). intros t w0. diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 305d553c..d6f67485 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,6 +16,10 @@ Require Import OrderedRing. Require Import RingMicromega. Require Import Refl. Require Import Raxioms RIneq Rpow_def DiscrR. +Require Import QArith. +Require Import Qfield. + + Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -60,32 +64,405 @@ Proof. apply (Rmult_lt_compat_r) ; auto. Qed. -Require ZMicromega. -(* R with coeffs in Z *) +Definition IQR := fun x : Q => (IZR (Qnum x) * / IZR (' Qden x))%R. + + +Lemma Rinv_elim : forall x y z, + y <> 0 -> (z * y = x <-> x * / y = z). +Proof. + intros. + split ; intros. + subst. + rewrite Rmult_assoc. + rewrite Rinv_r; auto. + ring. + subst. + rewrite Rmult_assoc. + rewrite (Rmult_comm (/ y)). + rewrite Rinv_r ; auto. + ring. +Qed. + +Ltac INR_nat_of_P := + match goal with + | H : context[INR (Pos.to_nat ?X)] |- _ => + revert H ; + let HH := fresh in + assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) + | |- context[INR (Pos.to_nat ?X)] => + let HH := fresh in + assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) + end. + +Ltac add_eq expr val := set (temp := expr) ; + generalize (eq_refl temp) ; + unfold temp at 1 ; generalize temp ; intro val ; clear temp. + +Ltac Rinv_elim := + match goal with + | |- context[?x * / ?y] => + let z := fresh "v" in + add_eq (x * / y) z ; + let H := fresh in intro H ; rewrite <- Rinv_elim in H + end. + +Lemma Rlt_neq : forall r , 0 < r -> r <> 0. +Proof. + red. intros. + subst. + apply (Rlt_irrefl 0 H). +Qed. + + +Lemma Rinv_1 : forall x, x * / 1 = x. +Proof. + intro. + Rinv_elim. + subst ; ring. + apply R1_neq_R0. +Qed. + +Lemma Qeq_true : forall x y, + Qeq_bool x y = true -> + IQR x = IQR y. +Proof. + unfold IQR. + simpl. + intros. + apply Qeq_bool_eq in H. + unfold Qeq in H. + assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z. + rewrite H. reflexivity. + repeat rewrite mult_IZR in H0. + simpl in H0. + revert H0. + repeat INR_nat_of_P. + intros. + apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto]. + rewrite <- H2. + field. + split ; apply Rlt_neq ; auto. +Qed. + +Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. +Proof. + intros. + apply Qeq_bool_neq in H. + intro. apply H. clear H. + unfold Qeq,IQR in *. + simpl in *. + revert H0. + repeat Rinv_elim. + intros. + subst. + assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z). + repeat rewrite mult_IZR. + simpl. + rewrite <- H0. rewrite <- H. + ring. + apply eq_IZR ; auto. + INR_nat_of_P; intros; apply Rlt_neq ; auto. + INR_nat_of_P; intros ; apply Rlt_neq ; auto. +Qed. + + + +Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. +Proof. + intros. + apply Qle_bool_imp_le in H. + unfold Qle in H. + unfold IQR. + simpl in *. + apply IZR_le in H. + repeat rewrite mult_IZR in H. + simpl in H. + repeat INR_nat_of_P; intros. + assert (Hr := Rlt_neq r H). + assert (Hr0 := Rlt_neq r0 H0). + replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)). + replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)). + apply Rmult_le_compat_r ; auto. + apply Rmult_le_pos. + unfold Rle. left. apply Rinv_0_lt_compat ; auto. + unfold Rle. left. apply Rinv_0_lt_compat ; auto. + field ; intuition. + field ; intuition. +Qed. + + + +Lemma IQR_0 : IQR 0 = 0. +Proof. + compute. apply Rinv_1. +Qed. + +Lemma IQR_1 : IQR 1 = 1. +Proof. + compute. apply Rinv_1. +Qed. + +Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y. +Proof. + intros. + unfold IQR. + simpl in *. + rewrite plus_IZR in *. + rewrite mult_IZR in *. + simpl. + rewrite Pos2Nat.inj_mul. + rewrite mult_INR. + rewrite mult_IZR. + simpl. + repeat INR_nat_of_P. + intros. field. + split ; apply Rlt_neq ; auto. +Qed. + +Lemma IQR_opp : forall x, IQR (- x) = - IQR x. +Proof. + intros. + unfold IQR. + simpl. + rewrite opp_IZR. + ring. +Qed. + +Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y. +Proof. + intros. + unfold Qminus. + rewrite IQR_plus. + rewrite IQR_opp. + ring. +Qed. + + +Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y. +Proof. + unfold IQR ; intros. + simpl. + repeat rewrite mult_IZR. + simpl. + rewrite Pos2Nat.inj_mul. + rewrite mult_INR. + repeat INR_nat_of_P. + intros. field ; split ; apply Rlt_neq ; auto. +Qed. + +Lemma IQR_inv_lt : forall x, (0 < x)%Q -> + IQR (/ x) = / IQR x. +Proof. + unfold IQR ; simpl. + intros. + unfold Qlt in H. + revert H. + simpl. + intros. + unfold Qinv. + destruct x ; simpl in *. + destruct Qnum ; simpl. + exfalso. auto with zarith. + clear H. + repeat INR_nat_of_P. + intros. + assert (HH := Rlt_neq _ H). + assert (HH0 := Rlt_neq _ H0). + rewrite Rinv_mult_distr ; auto. + rewrite Rinv_involutive ; auto. + ring. + apply Rinv_0_lt_compat in H0. + apply Rlt_neq ; auto. + simpl in H. + exfalso. + rewrite Pos.mul_comm in H. + compute in H. + discriminate. +Qed. + +Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q. +Proof. + destruct x ; destruct Qnum ; reflexivity. +Qed. + +Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q. +Proof. + intros. + destruct x. + unfold Qopp. + simpl. + rewrite Z.opp_involutive. + reflexivity. +Qed. + +Lemma Ropp_0 : forall r , - r = 0 -> r = 0. +Proof. + intros. + rewrite <- (Ropp_involutive r). + apply Ropp_eq_0_compat ; auto. +Qed. + +Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q. +Proof. + destruct x ; simpl. + unfold IQR. + simpl. + INR_nat_of_P. + intros. + apply Rmult_integral in H0. + destruct H0. + apply eq_IZR_R0 in H0. + subst. + reflexivity. + exfalso. + apply Rinv_0_lt_compat in H. + rewrite <- H0 in H. + apply Rlt_irrefl in H. auto. +Qed. + + +Lemma IQR_inv_gt : forall x, (0 > x)%Q -> + IQR (/ x) = / IQR x. +Proof. + intros. + rewrite <- (Qopp_involutive_strong x). + rewrite <- Qinv_opp. + rewrite IQR_opp. + rewrite IQR_inv_lt. + repeat rewrite IQR_opp. + rewrite Ropp_inv_permute. + auto. + intro. + apply Ropp_0 in H0. + apply IQR_x_0 in H0. + rewrite H0 in H. + compute in H. discriminate. + unfold Qlt in *. + destruct x ; simpl in *. + auto with zarith. +Qed. + +Lemma IQR_inv : forall x, ~ x == 0 -> + IQR (/ x) = / IQR x. +Proof. + intros. + assert ( 0 > x \/ 0 < x)%Q. + destruct x ; unfold Qlt, Qeq in * ; simpl in *. + rewrite Z.mul_1_r in *. + destruct Qnum ; simpl in * ; intuition auto. + right. reflexivity. + left ; reflexivity. + destruct H0. + apply IQR_inv_gt ; auto. + apply IQR_inv_lt ; auto. +Qed. -Lemma RZSORaddon : - SORaddon R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) - 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *) - Zeq_bool Zle_bool - IZR Nnat.nat_of_N pow. +Lemma IQR_inv_ext : forall x, + IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). +Proof. + intros. + case_eq (Qeq_bool x 0). + intros. + apply Qeq_bool_eq in H. + destruct x ; simpl. + unfold Qeq in H. + simpl in H. + replace Qnum with 0%Z. + compute. rewrite Rinv_1. + reflexivity. + rewrite <- H. ring. + intros. + apply IQR_inv. + intro. + rewrite <- Qeq_bool_iff in H0. + congruence. +Qed. + + +Notation to_nat := N.to_nat. + +Lemma QSORaddon : + @SORaddon R + R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle (* ring elements *) + Q 0%Q 1%Q Qplus Qmult Qminus Qopp (* coefficients *) + Qeq_bool Qle_bool + IQR nat to_nat pow. Proof. constructor. constructor ; intros ; try reflexivity. - apply plus_IZR. - symmetry. apply Z_R_minus. - apply mult_IZR. - apply Ropp_Ropp_IZR. - apply IZR_eq. - apply Zeq_bool_eq ; auto. + apply IQR_0. + apply IQR_1. + apply IQR_plus. + apply IQR_minus. + apply IQR_mult. + apply IQR_opp. + apply Qeq_true ; auto. apply R_power_theory. - intros x y. - intro. - apply IZR_neq. - apply Zeq_bool_neq ; auto. - intros. apply IZR_le. apply Zle_bool_imp_le. auto. + apply Qeq_false. + apply Qle_true. Qed. +(* Syntactic ring coefficients. + For computing, we use Q. *) +Inductive Rcst := +| C0 +| C1 +| CQ (r : Q) +| CZ (r : Z) +| CPlus (r1 r2 : Rcst) +| CMinus (r1 r2 : Rcst) +| CMult (r1 r2 : Rcst) +| CInv (r : Rcst) +| COpp (r : Rcst). + + +Fixpoint Q_of_Rcst (r : Rcst) : Q := + match r with + | C0 => 0 # 1 + | C1 => 1 # 1 + | CZ z => z # 1 + | CQ q => q + | CPlus r1 r2 => Qplus (Q_of_Rcst r1) (Q_of_Rcst r2) + | CMinus r1 r2 => Qminus (Q_of_Rcst r1) (Q_of_Rcst r2) + | CMult r1 r2 => Qmult (Q_of_Rcst r1) (Q_of_Rcst r2) + | CInv r => Qinv (Q_of_Rcst r) + | COpp r => Qopp (Q_of_Rcst r) + end. + + +Fixpoint R_of_Rcst (r : Rcst) : R := + match r with + | C0 => R0 + | C1 => R1 + | CZ z => IZR z + | CQ q => IQR q + | CPlus r1 r2 => (R_of_Rcst r1) + (R_of_Rcst r2) + | CMinus r1 r2 => (R_of_Rcst r1) - (R_of_Rcst r2) + | CMult r1 r2 => (R_of_Rcst r1) * (R_of_Rcst r2) + | CInv r => + if Qeq_bool (Q_of_Rcst r) (0 # 1) + then R0 + else Rinv (R_of_Rcst r) + | COpp r => - (R_of_Rcst r) + end. + +Lemma Q_of_RcstR : forall c, IQR (Q_of_Rcst c) = R_of_Rcst c. +Proof. + induction c ; simpl ; try (rewrite <- IHc1 ; rewrite <- IHc2). + apply IQR_0. + apply IQR_1. + reflexivity. + unfold IQR. simpl. rewrite Rinv_1. reflexivity. + apply IQR_plus. + apply IQR_minus. + apply IQR_mult. + rewrite <- IHc. + apply IQR_inv_ext. + rewrite <- IHc. + apply IQR_opp. + Qed. + Require Import EnvRing. Definition INZ (n:N) : R := @@ -94,7 +471,7 @@ Definition INZ (n:N) : R := | Npos p => IZR (Zpos p) end. -Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow. +Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp R_of_Rcst N.to_nat pow. Definition Reval_op2 (o:Op2) : R -> R -> Prop := @@ -108,11 +485,15 @@ Definition Reval_op2 (o:Op2) : R -> R -> Prop := end. -Definition Reval_formula (e: PolEnv R) (ff : Formula Z) := +Definition Reval_formula (e: PolEnv R) (ff : Formula Rcst) := let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs). + Definition Reval_formula' := - eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow. + eval_sformula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt N.to_nat pow R_of_Rcst. + +Definition QReval_formula := + eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR N.to_nat pow . Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f. Proof. @@ -126,57 +507,74 @@ Proof. apply Rle_ge. Qed. -Definition Reval_nformula := - eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt IZR. +Definition Qeval_nformula := + eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt IQR. -Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d). +Lemma Reval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d). Proof. - exact (fun env d =>eval_nformula_dec Rsor IZR env d). + exact (fun env d =>eval_nformula_dec Rsor IQR env d). Qed. -Definition RWitness := Psatz Z. +Definition RWitness := Psatz Q. -Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zeq_bool Zle_bool. +Definition RWeakChecker := check_normalised_formulas 0%Q 1%Q Qplus Qmult Qeq_bool Qle_bool. Require Import List. -Lemma RWeakChecker_sound : forall (l : list (NFormula Z)) (cm : RWitness), +Lemma RWeakChecker_sound : forall (l : list (NFormula Q)) (cm : RWitness), RWeakChecker l cm = true -> - forall env, make_impl (Reval_nformula env) l False. + forall env, make_impl (Qeval_nformula env) l False. Proof. intros l cm H. intro. - unfold Reval_nformula. - apply (checker_nf_sound Rsor RZSORaddon l cm). + unfold Qeval_nformula. + apply (checker_nf_sound Rsor QSORaddon l cm). unfold RWeakChecker in H. exact H. Qed. Require Import Tauto. -Definition Rnormalise := @cnf_normalise Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. -Definition Rnegate := @cnf_negate Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. +Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. +Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. + +Definition runsat := check_inconsistent 0%Q Qeq_bool Qle_bool. -Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool := - @tauto_checker (Formula Z) (NFormula Z) +Definition rdeduce := nformula_plus_nformula 0%Q Qplus Qeq_bool. + +Definition RTautoChecker (f : BFormula (Formula Rcst)) (w: list RWitness) : bool := + @tauto_checker (Formula Q) (NFormula Q) + runsat rdeduce Rnormalise Rnegate - RWitness RWeakChecker f w. + RWitness RWeakChecker (map_bformula (map_Formula Q_of_Rcst) f) w. Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f (Reval_formula env) f. Proof. intros f w. unfold RTautoChecker. - apply (tauto_checker_sound Reval_formula Reval_nformula). + intros TC env. + apply (tauto_checker_sound QReval_formula Qeval_nformula) with (env := env) in TC. + rewrite eval_f_map in TC. + rewrite eval_f_morph with (ev':= Reval_formula env) in TC ; auto. + intro. + unfold QReval_formula. + rewrite <- eval_formulaSC with (phiS := R_of_Rcst). + rewrite Reval_formula_compat. + tauto. + intro. rewrite Q_of_RcstR. reflexivity. apply Reval_nformula_dec. - intros. rewrite Reval_formula_compat. - unfold Reval_formula'. now apply (cnf_normalise_correct Rsor RZSORaddon). - intros. rewrite Reval_formula_compat. unfold Reval_formula. now apply (cnf_negate_correct Rsor RZSORaddon). + destruct t. + apply (check_inconsistent_sound Rsor QSORaddon) ; auto. + unfold rdeduce. apply (nformula_plus_nformula_correct Rsor QSORaddon). + now apply (cnf_normalise_correct Rsor QSORaddon). + intros. now apply (cnf_negate_correct Rsor QSORaddon). intros t w0. apply RWeakChecker_sound. Qed. + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v index 53413b4a..43bfb4d7 100644 --- a/plugins/micromega/Refl.v +++ b/plugins/micromega/Refl.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index b10cf784..fccacc74 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -142,7 +142,7 @@ Qed. Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *) Definition PolEnv := Env R. (* For interpreting PolC *) Definition eval_pol (env : PolEnv) (p:PolC) : R := - Pphi 0 rplus rtimes phi env p. + Pphi rplus rtimes phi env p. Inductive Op1 : Set := (* relations with 0 *) | Equal (* == 0 *) @@ -308,7 +308,7 @@ Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B : | Some x => f x end. -Implicit Arguments map_option [A B]. +Arguments map_option [A B] f o. Definition map_option2 (A B C : Type) (f : A -> B -> option C) (o: option A) (o': option B) : option C := @@ -318,9 +318,9 @@ Definition map_option2 (A B C : Type) (f : A -> B -> option C) | Some x , Some x' => f x x' end. -Implicit Arguments map_option2 [A B C]. +Arguments map_option2 [A B C] f o o'. -Definition Rops_wd := mk_reqe rplus rtimes ropp req +Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*) sor.(SORplus_wd) sor.(SORtimes_wd) sor.(SORopp_wd). @@ -355,6 +355,7 @@ Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula | PsatzZ => Some (Pc cO, Equal) (* Just to make life easier *) end. + Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula), eval_nformula env f -> pexpr_times_nformula e f = Some f' -> eval_nformula env f'. @@ -468,17 +469,11 @@ Fixpoint ge_bool (n m : nat) : bool := end end. -Lemma ge_bool_cases : forall n m, (if ge_bool n m then n >= m else n < m)%nat. +Lemma ge_bool_cases : forall n m, + (if ge_bool n m then n >= m else n < m)%nat. Proof. - induction n ; simpl. - destruct m ; simpl. - constructor. - omega. - destruct m. - constructor. - omega. - generalize (IHn m). - destruct (ge_bool n m) ; omega. + induction n; destruct m ; simpl; auto with arith. + specialize (IHn m). destruct (ge_bool); auto with arith. Qed. @@ -490,6 +485,99 @@ Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := | PsatzIn n => if ge_bool n base then (n::acc) else acc end. +Fixpoint nhyps_of_psatz (prf : Psatz) : list nat := + match prf with + | PsatzC _ | PsatzZ | PsatzSquare _ => nil + | PsatzMulC _ prf => nhyps_of_psatz prf + | PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz e1 ++ nhyps_of_psatz e2 + | PsatzIn n => n :: nil + end. + + +Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula := + match ln with + | nil => nil + | n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln + end. + +Lemma extract_hyps_app : forall l ln1 ln2, + extract_hyps l (ln1 ++ ln2) = (extract_hyps l ln1) ++ (extract_hyps l ln2). +Proof. + induction ln1. + reflexivity. + simpl. + intros. + rewrite IHln1. reflexivity. +Qed. + +Ltac inv H := inversion H ; try subst ; clear H. + +Lemma nhyps_of_psatz_correct : forall (env : PolEnv) (e:Psatz) (l : list NFormula) (f: NFormula), + eval_Psatz l e = Some f -> + ((forall f', In f' (extract_hyps l (nhyps_of_psatz e)) -> eval_nformula env f') -> eval_nformula env f). +Proof. + induction e ; intros. + (*PsatzIn*) + simpl in *. + apply H0. intuition congruence. + (* PsatzSquare *) + simpl in *. + inv H. + simpl. + unfold eval_pol. + rewrite (Psquare_ok sor.(SORsetoid) Rops_wd + (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); + now apply (Rtimes_square_nonneg sor). + (* PsatzMulC *) + simpl in *. + case_eq (eval_Psatz l e). + intros. rewrite H1 in H. simpl in H. + apply pexpr_times_nformula_correct with (2:= H). + apply IHe with (1:= H1); auto. + intros. rewrite H1 in H. simpl in H ; discriminate. + (* PsatzMulE *) + simpl in *. + revert H. + case_eq (eval_Psatz l e1). + case_eq (eval_Psatz l e2) ; simpl ; intros. + apply nformula_times_nformula_correct with (3:= H2). + apply IHe1 with (1:= H1) ; auto. + intros. apply H0. rewrite extract_hyps_app. + apply in_or_app. tauto. + apply IHe2 with (1:= H) ; auto. + intros. apply H0. rewrite extract_hyps_app. + apply in_or_app. tauto. + discriminate. simpl. discriminate. + (* PsatzAdd *) + simpl in *. + revert H. + case_eq (eval_Psatz l e1). + case_eq (eval_Psatz l e2) ; simpl ; intros. + apply nformula_plus_nformula_correct with (3:= H2). + apply IHe1 with (1:= H1) ; auto. + intros. apply H0. rewrite extract_hyps_app. + apply in_or_app. tauto. + apply IHe2 with (1:= H) ; auto. + intros. apply H0. rewrite extract_hyps_app. + apply in_or_app. tauto. + discriminate. simpl. discriminate. + (* PsatzC *) + simpl in H. + case_eq (cO [<] c). + intros. rewrite H1 in H. inv H. + unfold eval_nformula. simpl. + rewrite <- addon.(SORrm).(morph0). now apply cltb_sound. + intros. rewrite H1 in H. discriminate. + (* PsatzZ *) + simpl in *. inv H. + unfold eval_nformula. simpl. + apply addon.(SORrm).(morph0). +Qed. + + + + + (* roughly speaking, normalise_pexpr_correct is a proof of forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) @@ -499,7 +587,7 @@ Definition paddC := PaddC cplus. Definition psubC := PsubC cminus. Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := - let Rops_wd := mk_reqe rplus rtimes ropp req + let Rops_wd := mk_reqe (*rplus rtimes ropp req*) sor.(SORplus_wd) sor.(SORtimes_wd) sor.(SORopp_wd) in @@ -507,7 +595,7 @@ Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env addon.(SORrm). Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] := - let Rops_wd := mk_reqe rplus rtimes ropp req + let Rops_wd := mk_reqe (*rplus rtimes ropp req*) sor.(SORplus_wd) sor.(SORtimes_wd) sor.(SORopp_wd) in @@ -546,6 +634,7 @@ apply cleb_sound in H1. now apply -> (Rle_ngt sor). apply cltb_sound in H1. now apply -> (Rlt_nge sor). Qed. + Definition check_normalised_formulas : list NFormula -> Psatz -> bool := fun l cm => match eval_Psatz l cm with @@ -592,16 +681,17 @@ end. Definition eval_pexpr (l : PolEnv) (pe : PExpr C) : R := PEeval rplus rtimes rminus ropp phi pow_phi rpow l pe. -Record Formula : Type := { - Flhs : PExpr C; +Record Formula (T:Type) : Type := { + Flhs : PExpr T; Fop : Op2; - Frhs : PExpr C + Frhs : PExpr T }. -Definition eval_formula (env : PolEnv) (f : Formula) : Prop := +Definition eval_formula (env : PolEnv) (f : Formula C) : Prop := let (lhs, op, rhs) := f in (eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs). + (* We normalize Formulas by moving terms to one side *) Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb. @@ -610,7 +700,7 @@ Definition psub := Psub cO cplus cminus copp ceqb. Definition padd := Padd cO cplus ceqb. -Definition normalise (f : Formula) : NFormula := +Definition normalise (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in let rhs := norm rhs in @@ -623,7 +713,7 @@ let (lhs, op, rhs) := f in | OpLt => (psub rhs lhs, Strict) end. -Definition negate (f : Formula) : NFormula := +Definition negate (f : Formula C) : NFormula := let (lhs, op, rhs) := f in let lhs := norm lhs in let rhs := norm rhs in @@ -659,7 +749,7 @@ Qed. Theorem normalise_sound : - forall (env : PolEnv) (f : Formula), + forall (env : PolEnv) (f : Formula C), eval_formula env f -> eval_nformula env (normalise f). Proof. intros env f H; destruct f as [lhs op rhs]; simpl in *. @@ -673,7 +763,7 @@ now apply -> (Rlt_lt_minus sor). Qed. Theorem negate_correct : - forall (env : PolEnv) (f : Formula), + forall (env : PolEnv) (f : Formula C), eval_formula env f <-> ~ (eval_nformula env (negate f)). Proof. intros env f; destruct f as [lhs op rhs]; simpl. @@ -687,9 +777,9 @@ rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). rewrite <- (Rle_le_minus sor). now rewrite <- (Rlt_nge sor). Qed. -(** Another normalistion - this is used for cnf conversion **) +(** Another normalisation - this is used for cnf conversion **) -Definition xnormalise (t:Formula) : list (NFormula) := +Definition xnormalise (t:Formula C) : list (NFormula) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in @@ -705,16 +795,16 @@ Definition xnormalise (t:Formula) : list (NFormula) := Require Import Tauto. -Definition cnf_normalise (t:Formula) : cnf (NFormula) := +Definition cnf_normalise (t:Formula C) : cnf (NFormula) := List.map (fun x => x::nil) (xnormalise t). Add Ring SORRing : sor.(SORrt). -Lemma cnf_normalise_correct : forall env t, eval_cnf (eval_nformula env) (cnf_normalise t) -> eval_formula env t. +Lemma cnf_normalise_correct : forall env t, eval_cnf eval_nformula env (cnf_normalise t) -> eval_formula env t. Proof. unfold cnf_normalise, xnormalise ; simpl ; intros env t. - unfold eval_cnf. + unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o ; simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); @@ -730,7 +820,7 @@ Proof. rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto. Qed. -Definition xnegate (t:Formula) : list (NFormula) := +Definition xnegate (t:Formula C) : list (NFormula) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in @@ -743,13 +833,13 @@ Definition xnegate (t:Formula) : list (NFormula) := | OpLe => (psub rhs lhs,NonStrict) :: nil end. -Definition cnf_negate (t:Formula) : cnf (NFormula) := +Definition cnf_negate (t:Formula C) : cnf (NFormula) := List.map (fun x => x::nil) (xnegate t). -Lemma cnf_negate_correct : forall env t, eval_cnf (eval_nformula env) (cnf_negate t) -> ~ eval_formula env t. +Lemma cnf_negate_correct : forall env t, eval_cnf eval_nformula env (cnf_negate t) -> ~ eval_formula env t. Proof. unfold cnf_negate, xnegate ; simpl ; intros env t. - unfold eval_cnf. + unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o ; simpl; repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); @@ -786,13 +876,14 @@ Qed. Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := match p with | Pc c => PEc c - | Pinj j p => xdenorm (Pplus j jmp ) p + | Pinj j p => xdenorm (Pos.add j jmp ) p | PX p j q => PEadd (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j))) - (xdenorm (Psucc jmp) q) + (xdenorm (Pos.succ jmp) q) end. -Lemma xdenorm_correct : forall p i env, eval_pol (jump i env) p == eval_pexpr env (xdenorm (Psucc i) p). +Lemma xdenorm_correct : forall p i env, + eval_pol (jump i env) p == eval_pexpr env (xdenorm (Pos.succ i) p). Proof. unfold eval_pol. induction p. @@ -800,22 +891,21 @@ Proof. (* Pinj *) simpl. intros. - rewrite Pplus_succ_permute_r. + rewrite Pos.add_succ_r. rewrite <- IHp. symmetry. - rewrite Pplus_comm. - rewrite Pjump_Pplus. reflexivity. + rewrite Pos.add_comm. + rewrite Pjump_add. reflexivity. (* PX *) simpl. intros. - rewrite <- IHp1. - rewrite <- IHp2. + rewrite <- IHp1, <- IHp2. unfold Env.tail , Env.hd. - rewrite <- Pjump_Pplus. - rewrite <- Pplus_one_succ_r. + rewrite <- Pjump_add. + rewrite Pos.add_1_r. unfold Env.nth. unfold jump at 2. - rewrite Pplus_one_succ_l. + rewrite <- Pos.add_1_l. rewrite addon.(SORpower).(rpow_pow_N). unfold pow_N. ring. Qed. @@ -828,19 +918,76 @@ Proof. induction p. reflexivity. simpl. - rewrite <- Pplus_one_succ_r. + rewrite Pos.add_1_r. apply xdenorm_correct. simpl. intros. rewrite IHp1. unfold Env.tail. rewrite xdenorm_correct. - change (Psucc xH) with 2%positive. + change (Pos.succ xH) with 2%positive. rewrite addon.(SORpower).(rpow_pow_N). simpl. reflexivity. Qed. +(** Sometimes it is convenient to make a distinction between "syntactic" coefficients and "real" +coefficients that are used to actually compute *) + + + +Variable S : Type. + +Variable C_of_S : S -> C. + +Variable phiS : S -> R. + +Variable phi_C_of_S : forall c, phiS c = phi (C_of_S c). + +Fixpoint map_PExpr (e : PExpr S) : PExpr C := + match e with + | PEc c => PEc (C_of_S c) + | PEX p => PEX _ p + | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2) + | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2) + | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2) + | PEopp e => PEopp (map_PExpr e) + | PEpow e n => PEpow (map_PExpr e) n + end. + +Definition map_Formula (f : Formula S) : Formula C := + let (l,o,r) := f in + Build_Formula (map_PExpr l) o (map_PExpr r). + + +Definition eval_sexpr (env : PolEnv) (e : PExpr S) : R := + PEeval rplus rtimes rminus ropp phiS pow_phi rpow env e. + +Definition eval_sformula (env : PolEnv) (f : Formula S) : Prop := + let (lhs, op, rhs) := f in + (eval_op2 op) (eval_sexpr env lhs) (eval_sexpr env rhs). + +Lemma eval_pexprSC : forall env s, eval_sexpr env s = eval_pexpr env (map_PExpr s). +Proof. + unfold eval_pexpr, eval_sexpr. + induction s ; simpl ; try (rewrite IHs1 ; rewrite IHs2) ; try reflexivity. + apply phi_C_of_S. + rewrite IHs. reflexivity. + rewrite IHs. reflexivity. +Qed. + +(** equality migth be (too) strong *) +Lemma eval_formulaSC : forall env f, eval_sformula env f = eval_formula env (map_Formula f). +Proof. + destruct f. + simpl. + repeat rewrite eval_pexprSC. + reflexivity. +Qed. + + + + (** Some syntactic simplifications of expressions *) @@ -881,4 +1028,4 @@ End Micromega. (* Local Variables: *) (* coding: utf-8 *) -(* End: *)
\ No newline at end of file +(* End: *) diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 0706611c..440070a1 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* Frédéric Besson (Irisa/Inria) 2006-20011 *) (* *) (************************************************************************) @@ -41,6 +41,37 @@ Set Implicit Arguments. | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2) end. + Lemma eval_f_morph : forall A (ev ev' : A -> Prop) (f : BFormula A), + (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f). + Proof. + induction f ; simpl ; try tauto. + intros. + assert (H' := H a). + auto. + Qed. + + + + Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U := + match f with + | TT => TT _ + | FF => FF _ + | X p => X _ p + | A a => A (fct a) + | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2) + | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2) + | N f => N (map_bformula fct f) + | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2) + end. + + Lemma eval_f_map : forall T U (fct: T-> U) env f , + eval_f env (map_bformula fct f) = eval_f (fun x => env (fct x)) f. + Proof. + induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto. + rewrite <- IHf. auto. + Qed. + + Lemma map_simpl : forall A B f l, @map A B f l = match l with | nil => nil @@ -52,6 +83,7 @@ Set Implicit Arguments. + Section S. Variable Env : Type. @@ -64,6 +96,15 @@ Set Implicit Arguments. Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d). + Variable unsat : Term' -> bool. + + Variable unsat_prop : forall t, unsat t = true -> + forall env, eval' env t -> False. + + Variable deduce : Term' -> Term' -> option Term'. + + Variable deduce_prop : forall env t t' u, + eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u. Definition clause := list Term'. Definition cnf := list clause. @@ -76,8 +117,48 @@ Set Implicit Arguments. Definition ff : cnf := cons (@nil Term') nil. + Fixpoint add_term (t: Term') (cl : clause) : option clause := + match cl with + | nil => + match deduce t t with + | None => Some (t ::nil) + | Some u => if unsat u then None else Some (t::nil) + end + | t'::cl => + match deduce t t' with + | None => + match add_term t cl with + | None => None + | Some cl' => Some (t' :: cl') + end + | Some u => + if unsat u then None else + match add_term t cl with + | None => None + | Some cl' => Some (t' :: cl') + end + end + end. + + Fixpoint or_clause (cl1 cl2 : clause) : option clause := + match cl1 with + | nil => Some cl2 + | t::cl => match add_term t cl2 with + | None => None + | Some cl' => or_clause cl cl' + end + end. + +(* Definition or_clause_cnf (t:clause) (f:cnf) : cnf := + List.map (fun x => (t++x)) f. *) + Definition or_clause_cnf (t:clause) (f:cnf) : cnf := - List.map (fun x => (t++x)) f. + List.fold_right (fun e acc => + match or_clause t e with + | None => acc + | Some cl => cl :: acc + end) nil f. + Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := match f with @@ -102,46 +183,154 @@ Set Implicit Arguments. | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) end. - Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj (fun cl => ~ make_conj env cl) f. + Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval' env) cl. + + Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f. + + + Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y. + Proof. + unfold eval_cnf. + intros. + rewrite make_conj_app in H ; auto. + Qed. + + + Definition eval_opt_clause (env : Env) (cl: option clause) := + match cl with + | None => True + | Some cl => eval_clause env cl + end. - Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y. + Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl). + Proof. + induction cl. + (* BC *) + simpl. + case_eq (deduce t t) ; auto. + intros until 0. + case_eq (unsat t0) ; auto. + unfold eval_clause. + rewrite make_conj_cons. + intros. intro. + apply unsat_prop with (1:= H) (env := env). + apply deduce_prop with (3:= H0) ; tauto. + (* IC *) + simpl. + case_eq (deduce t a). + intro u. + case_eq (unsat u). + simpl. intros. + unfold eval_clause. + intro. + apply unsat_prop with (1:= H) (env:= env). + repeat rewrite make_conj_cons in H2. + apply deduce_prop with (3:= H0); tauto. + intro. + case_eq (add_term t cl) ; intros. + simpl in H2. + rewrite H0 in IHcl. + simpl in IHcl. + unfold eval_clause in *. + intros. + repeat rewrite make_conj_cons in *. + tauto. + rewrite H0 in IHcl ; simpl in *. + unfold eval_clause in *. + intros. + repeat rewrite make_conj_cons in *. + tauto. + case_eq (add_term t cl) ; intros. + simpl in H1. + unfold eval_clause in *. + repeat rewrite make_conj_cons in *. + rewrite H in IHcl. + simpl in IHcl. + tauto. + simpl in *. + rewrite H in IHcl. + simpl in IHcl. + unfold eval_clause in *. + repeat rewrite make_conj_cons in *. + tauto. + Qed. + + + Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'. Proof. - unfold eval_cnf. + induction cl. + simpl. tauto. + intros until 0. + simpl. + assert (HH := add_term_correct env a cl'). + case_eq (add_term a cl'). + simpl in *. + intros. + apply IHcl in H0. + rewrite H in HH. + simpl in HH. + unfold eval_clause in *. + destruct H0. + repeat rewrite make_conj_cons in *. + tauto. + apply HH in H0. + apply not_make_conj_cons in H0 ; auto. + repeat rewrite make_conj_cons in *. + tauto. + simpl. intros. - rewrite make_conj_app in H ; auto. + rewrite H in HH. + simpl in HH. + unfold eval_clause in *. + assert (HH' := HH Coq.Init.Logic.I). + apply not_make_conj_cons in HH'; auto. + repeat rewrite make_conj_cons in *. + tauto. Qed. + - - Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj (eval' env) t) \/ (eval_cnf (eval' env) f). + Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f). Proof. unfold eval_cnf. unfold or_clause_cnf. + intros until t. + set (F := (fun (e : clause) (acc : list clause) => + match or_clause t e with + | Some cl => cl :: acc + | None => acc + end)). induction f. - simpl. - intros ; right;auto. + auto. (**) - rewrite map_simpl. + simpl. intros. - rewrite make_conj_cons in H. - destruct H as [HH1 HH2]. - generalize (IHf HH2) ; clear IHf ; intro. - destruct H. - left ; auto. - rewrite make_conj_cons. - destruct (not_make_conj_app _ _ _ (no_middle_eval' env) HH1). - tauto. + destruct f. + simpl in H. + simpl in IHf. + unfold F in H. + revert H. + intros. + apply or_clause_correct. + destruct (or_clause t a) ; simpl in * ; auto. + unfold F in H at 1. + revert H. + assert (HH := or_clause_correct t a env). + destruct (or_clause t a); simpl in HH ; + rewrite make_conj_cons in * ; intuition. + rewrite make_conj_cons in *. tauto. Qed. - Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf (eval' env) f -> eval_cnf (eval' env) (a::f). + + Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f). Proof. intros. unfold eval_cnf in *. rewrite make_conj_cons ; eauto. Qed. - Lemma or_cnf_correct : forall env f f', eval_cnf (eval' env) (or_cnf f f') -> (eval_cnf (eval' env) f) \/ (eval_cnf (eval' env) f'). + Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env f) \/ (eval_cnf env f'). Proof. induction f. unfold eval_cnf. @@ -153,19 +342,19 @@ Set Implicit Arguments. destruct (eval_cnf_app _ _ _ H). clear H. destruct (IHf _ H0). - destruct (or_clause_correct _ _ _ H1). + destruct (or_clause_cnf_correct _ _ _ H1). left. apply eval_cnf_cons ; auto. right ; auto. right ; auto. Qed. - Variable normalise_correct : forall env t, eval_cnf (eval' env) (normalise t) -> eval env t. + Variable normalise_correct : forall env t, eval_cnf env (normalise t) -> eval env t. - Variable negate_correct : forall env t, eval_cnf (eval' env) (negate t) -> ~ eval env t. + Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t. - Lemma xcnf_correct : forall f pol env, eval_cnf (eval' env) (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). + Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f). Proof. induction f. (* TT *) @@ -175,15 +364,19 @@ Set Implicit Arguments. (* FF *) unfold eval_cnf. destruct pol; simpl ; auto. + unfold eval_clause ; simpl. + tauto. (* P *) simpl. destruct pol ; intros ;simpl. unfold eval_cnf in H. (* Here I have to drop the proposition *) simpl in H. + unfold eval_clause in H ; simpl in H. tauto. (* Here, I could store P in the clause *) unfold eval_cnf in H;simpl in H. + unfold eval_clause in H ; simpl in H. tauto. (* A *) simpl. @@ -282,7 +475,7 @@ Set Implicit Arguments. end end. - Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf (eval' env) t. + Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t. Proof. unfold eval_cnf. induction t. @@ -319,7 +512,6 @@ Set Implicit Arguments. - End S. (* Local Variables: *) diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 7d25524a..9ff8044e 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,11 +18,12 @@ Require Import Coq.Arith.Max. Require Import List. Set Implicit Arguments. -(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) - -- this is harmless and spares a lot of Empty. - This means smaller proof-terms. - BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up. -*) +(* + * This adds a Leaf constructor to the varmap data structure (plugins/quote/Quote.v) + * --- it is harmless and spares a lot of Empty. + * It also means smaller proof-terms. + * As a side note, by dropping the polymorphism, one gets small, yet noticeable, speed-up. + *) Section MakeVarMap. Variable A : Type. @@ -33,7 +34,7 @@ Section MakeVarMap. | Leaf : A -> t | Node : t -> A -> t -> t . - Fixpoint find (vm : t ) (p:positive) {struct vm} : A := + Fixpoint find (vm : t) (p:positive) {struct vm} : A := match vm with | Empty => default | Leaf i => i @@ -44,216 +45,6 @@ Section MakeVarMap. end end. - (* an off_map (a map with offset) offers the same functionalites as /plugins/setoid_ring/BinList.v - it is used in EnvRing.v *) -(* - Definition off_map := (option positive *t )%type. - - - - Definition jump (j:positive) (l:off_map ) := - let (o,m) := l in - match o with - | None => (Some j,m) - | Some j0 => (Some (j+j0)%positive,m) - end. - - Definition nth (n:positive) (l: off_map ) := - let (o,m) := l in - let idx := match o with - | None => n - | Some i => i + n - end%positive in - find idx m. - - - Definition hd (l:off_map) := nth xH l. - - - Definition tail (l:off_map ) := jump xH l. - - - Lemma psucc : forall p, (match p with - | xI y' => xO (Psucc y') - | xO y' => xI y' - | 1%positive => 2%positive - end) = (p+1)%positive. - Proof. - destruct p. - auto with zarith. - rewrite xI_succ_xO. - auto with zarith. - reflexivity. - Qed. - - Lemma jump_Pplus : forall i j l, - (jump (i + j) l) = (jump i (jump j l)). - Proof. - unfold jump. - destruct l. - destruct o. - rewrite Pplus_assoc. - reflexivity. - reflexivity. - Qed. - - Lemma jump_simpl : forall p l, - jump p l = - match p with - | xH => tail l - | xO p => jump p (jump p l) - | xI p => jump p (jump p (tail l)) - end. - Proof. - destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus. - (* xI p = p + p + 1 *) - rewrite xI_succ_xO. - rewrite Pplus_diag. - rewrite <- Pplus_one_succ_r. - reflexivity. - (* xO p = p + p *) - rewrite Pplus_diag. - reflexivity. - reflexivity. - Qed. - - Ltac jump_s := - repeat - match goal with - | |- context [jump xH ?e] => rewrite (jump_simpl xH) - | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) - | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) - end. - - Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). - Proof. - unfold tail. - intros. - repeat rewrite <- jump_Pplus. - rewrite Pplus_comm. - reflexivity. - Qed. - - Lemma jump_Psucc : forall j l, - (jump (Psucc j) l) = (jump 1 (jump j l)). - Proof. - intros. - rewrite <- jump_Pplus. - rewrite Pplus_one_succ_r. - rewrite Pplus_comm. - reflexivity. - Qed. - - Lemma jump_Pdouble_minus_one : forall i l, - (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)). - Proof. - unfold tail. - intros. - repeat rewrite <- jump_Pplus. - rewrite <- Pplus_one_succ_r. - rewrite Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_diag. - reflexivity. - Qed. - - Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l. - Proof. - intros. - jump_s. - repeat rewrite <- jump_Pplus. - reflexivity. - Qed. - - - Lemma nth_spec : forall p l, - nth p l = - match p with - | xH => hd l - | xO p => nth p (jump p l) - | xI p => nth p (jump p (tail l)) - end. - Proof. - unfold nth. - destruct l. - destruct o. - simpl. - rewrite psucc. - destruct p. - replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive. - reflexivity. - rewrite xI_succ_xO. - rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag. - rewrite Pplus_comm. - symmetry. - rewrite (Pplus_comm p0). - rewrite <- Pplus_assoc. - rewrite (Pplus_comm 1)%positive. - rewrite <- Pplus_assoc. - reflexivity. - (**) - replace ((p0 + xO p))%positive with (p + p0 + p)%positive. - reflexivity. - rewrite <- Pplus_diag. - rewrite <- Pplus_assoc. - rewrite Pplus_comm. - rewrite Pplus_assoc. - reflexivity. - reflexivity. - simpl. - destruct p. - rewrite xI_succ_xO. - rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag. - symmetry. - rewrite Pplus_comm. - rewrite Pplus_assoc. - reflexivity. - rewrite Pplus_diag. - reflexivity. - reflexivity. - Qed. - - - Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l). - Proof. - destruct l. - unfold tail. - unfold hd. - unfold jump. - unfold nth. - destruct o. - symmetry. - rewrite Pplus_comm. - rewrite <- Pplus_assoc. - rewrite (Pplus_comm p0). - reflexivity. - rewrite Pplus_comm. - reflexivity. - Qed. - - Lemma nth_Pdouble_minus_one : - forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). - Proof. - destruct l. - unfold tail. - unfold nth, jump. - destruct o. - rewrite ((Pplus_comm p)). - rewrite <- (Pplus_assoc p0). - rewrite Pplus_diag. - rewrite <- Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_one_succ_r. - rewrite (Pplus_comm (Pdouble_minus_one p)). - rewrite Pplus_assoc. - rewrite (Pplus_comm p0). - reflexivity. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO. - rewrite Pplus_diag. - reflexivity. - Qed. - -*) End MakeVarMap. diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v index cf2bca49..e30295e6 100644 --- a/plugins/micromega/ZCoeff.v +++ b/plugins/micromega/ZCoeff.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -109,7 +109,7 @@ Qed. Lemma Zring_morph : ring_morph 0 1 rplus rtimes rminus ropp req - 0%Z 1%Z Zplus Zmult Zminus Zopp + 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool gen_order_phi_Z. Proof. exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)). @@ -122,7 +122,7 @@ try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_ try apply (Rlt_0_1 sor); assumption. Qed. -Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x. +Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Pos.succ x) == 1 + phi_pos1 x. Proof. exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))). @@ -130,7 +130,7 @@ Qed. Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y. Proof. -intros x y H. pattern y; apply Plt_ind with x. +intros x y H. pattern y; apply Pos.lt_ind with x. rewrite phi_pos1_succ; apply (Rlt_succ_r sor). clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor). assumption. @@ -138,7 +138,7 @@ Qed. Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y]. Proof. -unfold Zlt; intros x y H; +intros x y H. do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt)); destruct x; destruct y; simpl in *; try discriminate. apply phi_pos1_pos. @@ -146,13 +146,13 @@ now apply clt_pos_morph. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. apply (Rlt_trans sor) with 0. apply <- (Ropp_neg_pos sor); apply phi_pos1_pos. apply phi_pos1_pos. -rewrite Pcompare_antisym in H; simpl in H. apply -> (Ropp_lt_mono sor). -now apply clt_pos_morph. +apply -> (Ropp_lt_mono sor); apply clt_pos_morph. +red. now rewrite Pos.compare_antisym. Qed. -Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y]. +Lemma Zcleb_morph : forall x y : Z, Z.leb x y = true -> [x] <= [y]. Proof. -unfold Zle_bool; intros x y H. +unfold Z.leb; intros x y H. case_eq (x ?= y)%Z; intro H1; rewrite H1 in H. le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1. le_less. now apply clt_morph. @@ -162,9 +162,9 @@ Qed. Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y]. Proof. intros x y H. unfold Zeq_bool in H. -case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H). +case_eq (Z.compare x y); intro H1; rewrite H1 in *; (discriminate || clear H). apply (Rlt_neq sor). now apply clt_morph. -fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1. +fold (x > y)%Z in H1. rewrite Z.gt_lt_iff in H1. apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph. Qed. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index d6245681..bdc4671d 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,7 +8,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* Frédéric Besson (Irisa/Inria) 2006-2011 *) (* *) (************************************************************************) @@ -34,20 +34,20 @@ Require Import EnvRing. Open Scope Z_scope. -Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt. +Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt. Proof. constructor ; intros ; subst ; try (intuition (auto with zarith)). apply Zsth. apply Zth. - destruct (Ztrichotomy n m) ; intuition (auto with zarith). - apply Zmult_lt_0_compat ; auto. + destruct (Z.lt_trichotomy n m) ; intuition. + apply Z.mul_pos_pos ; auto. Qed. Lemma ZSORaddon : - SORaddon 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle (* ring elements *) - 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *) - Zeq_bool Zle_bool - (fun x => x) (fun x => x) (pow_N 1 Zmult). + SORaddon 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le (* ring elements *) + 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (* coefficients *) + Zeq_bool Z.leb + (fun x => x) (fun x => x) (pow_N 1 Z.mul). Proof. constructor. constructor ; intros ; try reflexivity. @@ -65,20 +65,20 @@ Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := | PEX x => env x | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2 | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2 - | PEpow e1 n => Zpower (Zeval_expr env e1) (Z_of_N n) + | PEpow e1 n => Z.pow (Zeval_expr env e1) (Z.of_N n) | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2) - | PEopp e => Zopp (Zeval_expr env e) + | PEopp e => Z.opp (Zeval_expr env e) end. -Definition eval_expr := eval_pexpr Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult). +Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x => x) (pow_N 1 Z.mul). -Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n. +Lemma ZNpower : forall r n, r ^ Z.of_N n = pow_N 1 Z.mul r n. Proof. destruct n. reflexivity. simpl. - unfold Zpower_pos. - replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring. + unfold Z.pow_pos. + replace (pow_pos Z.mul r p) with (1 * (pow_pos Z.mul r p)) by ring. generalize 1. induction p; simpl ; intros ; repeat rewrite IHp ; ring. Qed. @@ -94,10 +94,10 @@ Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop := match o with | OpEq => @eq Z | OpNEq => fun x y => ~ x = y -| OpLe => Zle -| OpGe => Zge -| OpLt => Zlt -| OpGt => Zgt +| OpLe => Z.le +| OpGe => Z.ge +| OpLt => Z.lt +| OpGt => Z.gt end. Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= @@ -105,23 +105,23 @@ Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs). Definition Zeval_formula' := - eval_formula Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult). + eval_formula Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt (fun x => x) (fun x => x) (pow_N 1 Z.mul). Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f. Proof. destruct f ; simpl. rewrite Zeval_expr_compat. rewrite Zeval_expr_compat. unfold eval_expr. - generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Zmult) env Flhs). - generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : N => x) (pow_N 1 Zmult) env Frhs)). + generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env Flhs). + generalize ((eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env Frhs)). destruct Fop ; simpl; intros ; intuition (auto with zarith). Qed. Definition eval_nformula := - eval_nformula 0 Zplus Zmult (@eq Z) Zle Zlt (fun x => x) . + eval_nformula 0 Z.add Z.mul (@eq Z) Z.le Z.lt (fun x => x) . Definition Zeval_op1 (o : Op1) : Z -> Prop := match o with @@ -140,7 +140,7 @@ Qed. Definition ZWitness := Psatz Z. -Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zeq_bool Zle_bool. +Definition ZWeakChecker := check_normalised_formulas 0 1 Z.add Z.mul Zeq_bool Z.leb. Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness), ZWeakChecker l cm = true -> @@ -154,13 +154,13 @@ Proof. exact H. Qed. -Definition psub := psub Z0 Zplus Zminus Zopp Zeq_bool. +Definition psub := psub Z0 Z.add Z.sub Z.opp Zeq_bool. -Definition padd := padd Z0 Zplus Zeq_bool. +Definition padd := padd Z0 Z.add Zeq_bool. -Definition norm := norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool. +Definition norm := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. -Definition eval_pol := eval_pol 0 Zplus Zmult (fun x => x). +Definition eval_pol := eval_pol Z.add Z.mul (fun x => x). Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) = eval_pol env lhs - eval_pol env rhs. Proof. @@ -194,27 +194,27 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z) := | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil end. -Require Import Tauto. +Require Import Tauto BinNums. Definition normalise (t:Formula Z) : cnf (NFormula Z) := List.map (fun x => x::nil) (xnormalise t). -Lemma normalise_correct : forall env t, eval_cnf (eval_nformula env) (normalise t) <-> Zeval_formula env t. +Lemma normalise_correct : forall env t, eval_cnf eval_nformula env (normalise t) <-> Zeval_formula env t. Proof. Opaque padd. unfold normalise, xnormalise ; simpl; intros env t. rewrite Zeval_formula_compat. - unfold eval_cnf. + unfold eval_cnf, eval_clause. destruct t as [lhs o rhs]; case_eq o; simpl; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; unfold eval_expr; - generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs); - generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst; + generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env lhs); + generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; intuition (auto with zarith). Transparent padd. Qed. @@ -235,31 +235,34 @@ Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := Definition negate (t:RingMicromega.Formula Z) : cnf (NFormula Z) := List.map (fun x => x::nil) (xnegate t). -Lemma negate_correct : forall env t, eval_cnf (eval_nformula env) (negate t) <-> ~ Zeval_formula env t. +Lemma negate_correct : forall env t, eval_cnf eval_nformula env (negate t) <-> ~ Zeval_formula env t. Proof. Proof. Opaque padd. intros env t. rewrite Zeval_formula_compat. unfold negate, xnegate ; simpl. - unfold eval_cnf. + unfold eval_cnf,eval_clause. destruct t as [lhs o rhs]; case_eq o; simpl; repeat rewrite eval_pol_sub; repeat rewrite eval_pol_add; repeat rewrite <- eval_pol_norm ; simpl in *; unfold eval_expr; - generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs); - generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) - (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst; + generalize ( eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env lhs); + generalize (eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) + (fun x : N => x) (pow_N 1 Z.mul) env rhs) ; intros z1 z2 ; intros ; subst; intuition (auto with zarith). Transparent padd. Qed. +Definition Zunsat := check_inconsistent 0 Zeq_bool Z.leb. + +Definition Zdeduce := nformula_plus_nformula 0 Z.add Zeq_bool. Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool := - @tauto_checker (Formula Z) (NFormula Z) normalise negate ZWitness ZWeakChecker f w. + @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZWitness ZWeakChecker f w. (* To get a complete checker, the proof format has to be enriched *) @@ -267,36 +270,47 @@ Require Import Zdiv. Open Scope Z_scope. Definition ceiling (a b:Z) : Z := - let (q,r) := Zdiv_eucl a b in + let (q,r) := Z.div_eucl a b in match r with | Z0 => q | _ => q + 1 end. -Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x >= b -> x >= ceiling b a. + +Require Import Znumtheory. + +Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Z.div a b. Proof. unfold ceiling. intros. - generalize (Z_div_mod b a H). - destruct (Zdiv_eucl b a). + apply Zdivide_mod in H. + case_eq (Z.div_eucl a b). intros. - destruct H1. - destruct H2. - subst. - destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate. - assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith). - destruct HH ;auto. - generalize (Zmult_lt_compat_l _ _ _ H3 H1). - auto with zarith. - clear H2. - assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)). - destruct HH ;auto. - assert (0 < a) by auto with zarith. - generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1). - intros. - rewrite Zmult_comm in H4. - rewrite (Zmult_comm z) in H4. - auto with zarith. + change z with (fst (z,z0)). + rewrite <- H0. + change (fst (Z.div_eucl a b)) with (Z.div a b). + change z0 with (snd (z,z0)). + rewrite <- H0. + change (snd (Z.div_eucl a b)) with (Z.modulo a b). + rewrite H. + reflexivity. +Qed. + +Lemma narrow_interval_lower_bound a b x : + a > 0 -> a * x >= b -> x >= ceiling b a. +Proof. + rewrite !Z.ge_le_iff. + unfold ceiling. + intros Ha H. + generalize (Z_div_mod b a Ha). + destruct (Z.div_eucl b a) as (q,r). intros (->,(H1,H2)). + destruct r as [|r|r]. + - rewrite Z.add_0_r in H. + apply Z.mul_le_mono_pos_l in H; auto with zarith. + - assert (0 < Z.pos r) by easy. + rewrite Z.add_1_r, Z.le_succ_l. + apply Z.mul_lt_mono_pos_l with a; auto with zarith. + - now elim H1. Qed. (** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *) @@ -307,40 +321,13 @@ Inductive ZArithProof : Type := | DoneProof | RatProof : ZWitness -> ZArithProof -> ZArithProof | CutProof : ZWitness -> ZArithProof -> ZArithProof -| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof. - -(* n/d <= x -> d*x - n >= 0 *) -(* -Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z := - let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc n),NonStrict). - -(* x <= n/d -> d * x <= d *) -Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z := - let (n,d) := q in - (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict). +| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof +(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof*). -Definition qceiling (q:Q) : Z := - let (n,d) := q in ceiling n (Zpos d). -Definition qfloor (q:Q) : Z := - let (n,d) := q in Zdiv n (Zpos d). -Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z := - (PEsub v (PEc (qceiling q)), NonStrict). - -Definition neg_nformula (f : NFormula Z) := - let (e,o) := f in - (PEopp (PEadd e (PEc 1%Z)), o). +(* n/d <= x -> d*x - n >= 0 *) -Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f). -Proof. - unfold neg_nformula. - destruct f. - simpl. - intros ; subst ; simpl in *. - split; auto with zarith. -Qed. -*) (* In order to compute the 'cut', we need to express a polynomial P as a * Q + b. - b is the constant @@ -364,7 +351,7 @@ Proof. destruct x ; simpl ; intuition congruence. Qed. -Definition ZgcdM (x y : Z) := Zmax (Zgcd x y) 1. +Definition ZgcdM (x y : Z) := Z.max (Z.gcd x y) 1. Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) := @@ -382,7 +369,7 @@ Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) := Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z := match p with - | Pc c => Pc (Zdiv c x) + | Pc c => Pc (Z.div c x) | Pinj j p => Pinj j (Zdiv_pol p x) | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x) end. @@ -425,10 +412,10 @@ Proof. intros. simpl. unfold ZgcdM. - generalize (Zgcd_is_pos z1 z2). - generalize (Zmax_spec (Zgcd z1 z2) 1). - generalize (Zgcd_is_pos (Zmax (Zgcd z1 z2) 1) z). - generalize (Zmax_spec (Zgcd (Zmax (Zgcd z1 z2) 1) z) 1). + generalize (Z.gcd_nonneg z1 z2). + generalize (Zmax_spec (Z.gcd z1 z2) 1). + generalize (Z.gcd_nonneg (Z.max (Z.gcd z1 z2) 1) z). + generalize (Zmax_spec (Z.gcd (Z.max (Z.gcd z1 z2) 1) z) 1). auto with zarith. Qed. @@ -437,7 +424,7 @@ Proof. intros. induction H. constructor. - apply Zdivide_trans with (1:= H0) ; assumption. + apply Z.divide_trans with (1:= H0) ; assumption. constructor. auto. constructor ; auto. Qed. @@ -448,20 +435,20 @@ Proof. exists c. ring. Qed. -Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Zgcd a b | c). +Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Z.gcd a b | c). Proof. intros a b c (q,Hq). destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _]. - set (g:=Zgcd a b) in *; clearbody g. + set (g:=Z.gcd a b) in *; clearbody g. exists (q * a' + b'). - symmetry in Hq. rewrite <- Zeq_plus_swap in Hq. + symmetry in Hq. rewrite <- Z.add_move_r in Hq. rewrite <- Hq, Hb, Ha. ring. Qed. Lemma Zdivide_pol_sub : forall p a b, - 0 < Zgcd a b -> - Zdivide_pol a (PsubC Zminus p b) -> - Zdivide_pol (Zgcd a b) p. + 0 < Z.gcd a b -> + Zdivide_pol a (PsubC Z.sub p b) -> + Zdivide_pol (Z.gcd a b) p. Proof. induction p. simpl. @@ -481,7 +468,7 @@ Proof. Qed. Lemma Zdivide_pol_sub_0 : forall p a, - Zdivide_pol a (PsubC Zminus p 0) -> + Zdivide_pol a (PsubC Z.sub p 0) -> Zdivide_pol a p. Proof. induction p. @@ -500,7 +487,7 @@ Qed. Lemma Zgcd_pol_div : forall p g c, - Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Zminus p c). + Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Z.sub p c). Proof. induction p ; simpl. (* Pc *) @@ -515,12 +502,12 @@ Proof. case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros. inv H1. unfold ZgcdM at 1. - destruct (Zmax_spec (Zgcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1]; + destruct (Zmax_spec (Z.gcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1]; destruct HH1 as [HH1 HH1'] ; rewrite HH1'. constructor. apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2). unfold ZgcdM. - destruct (Zmax_spec (Zgcd z1 z2) 1) as [HH2 | HH2]. + destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. destruct HH2. rewrite H2. apply Zdivide_pol_sub ; auto. @@ -528,9 +515,9 @@ Proof. destruct HH2. rewrite H2. apply Zdivide_pol_one. unfold ZgcdM in HH1. unfold ZgcdM. - destruct (Zmax_spec (Zgcd z1 z2) 1) as [HH2 | HH2]. + destruct (Zmax_spec (Z.gcd z1 z2) 1) as [HH2 | HH2]. destruct HH2. rewrite H2 in *. - destruct (Zgcd_is_gcd (Zgcd z1 z2) z); auto. + destruct (Zgcd_is_gcd (Z.gcd z1 z2) z); auto. destruct HH2. rewrite H2. destruct (Zgcd_is_gcd 1 z); auto. apply Zdivide_pol_Zdivide with (x:= z). @@ -543,7 +530,7 @@ Qed. -Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) + c. +Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) + c. Proof. intros. rewrite <- Zdiv_pol_correct ; auto. @@ -557,8 +544,8 @@ Qed. Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := let (g,c) := Zgcd_pol p in - if Zgt_bool g Z0 - then (Zdiv_pol (PsubC Zminus p c) g , Zopp (ceiling (Zopp c) g)) + if Z.gtb g Z0 + then (Zdiv_pol (PsubC Z.sub p c) g , Z.opp (ceiling (Z.opp c) g)) else (p,Z0). @@ -566,11 +553,13 @@ Definition genCuttingPlane (f : NFormula Z) : option (PolC Z * Z * Op1) := let (e,op) := f in match op with | Equal => let (g,c) := Zgcd_pol e in - if andb (Zgt_bool g Z0) (andb (Zgt_bool c Z0) (negb (Zeq_bool (Zgcd g c) g))) + if andb (Z.gtb g Z0) (andb (negb (Zeq_bool c Z0)) (negb (Zeq_bool (Z.gcd g c) g))) then None (* inconsistent *) - else Some (e, Z0,op) (* It could still be inconsistent -- but not a cut *) + else (* Could be optimised Zgcd_pol is recomputed *) + let (p,c) := makeCuttingPlane e in + Some (p,c,Equal) | NonEqual => Some (e,Z0,op) - | Strict => let (p,c) := makeCuttingPlane (PsubC Zminus e 1) in + | Strict => let (p,c) := makeCuttingPlane (PsubC Z.sub e 1) in Some (p,c,NonStrict) | NonStrict => let (p,c) := makeCuttingPlane e in Some (p,c,NonStrict) @@ -596,16 +585,16 @@ Proof. Qed. - - - Definition eval_Psatz : list (NFormula Z) -> ZWitness -> option (NFormula Z) := - eval_Psatz 0 1 Zplus Zmult Zeq_bool Zle_bool. - - -Definition check_inconsistent := check_inconsistent 0 Zeq_bool Zle_bool. + eval_Psatz 0 1 Z.add Z.mul Zeq_bool Z.leb. +Definition valid_cut_sign (op:Op1) := + match op with + | Equal => true + | NonStrict => true + | _ => false + end. Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with @@ -614,7 +603,7 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool : match eval_Psatz l w with | None => false | Some f => - if check_inconsistent f then true + if Zunsat f then true else ZChecker (f::l) pf end | CutProof w pf => @@ -627,29 +616,24 @@ Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool : end end | EnumProof w1 w2 pf => - match eval_Psatz l w1 , eval_Psatz l w2 with - | Some f1 , Some f2 => - match genCuttingPlane f1 , genCuttingPlane f2 with - |Some (e1,z1,op1) , Some (e2,z2,op2) => - match op1 , op2 with - | NonStrict , NonStrict => - if is_pol_Z0 (padd e1 e2) - then - (fix label (pfs:list ZArithProof) := - fun lb ub => - match pfs with - | nil => if Zgt_bool lb ub then true else false - | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) - end) - pf (Zopp z1) z2 - else false - | _ , _ => false - end - | _ , _ => false - end - | _ , _ => false - end - end. + match eval_Psatz l w1 , eval_Psatz l w2 with + | Some f1 , Some f2 => + match genCuttingPlane f1 , genCuttingPlane f2 with + |Some (e1,z1,op1) , Some (e2,z2,op2) => + if (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd e1 e2)) + then + (fix label (pfs:list ZArithProof) := + fun lb ub => + match pfs with + | nil => if Z.gtb lb ub then true else false + | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Z.add lb 1%Z) ub) + end) pf (Z.opp z1) z2 + else false + | _ , _ => true + end + | _ , _ => false + end +end. @@ -702,7 +686,7 @@ Proof. apply make_conj_in ; auto. Qed. -Lemma makeCuttingPlane_sound : forall env e e' c, +Lemma makeCuttingPlane_ns_sound : forall env e e' c, eval_nformula env (e, NonStrict) -> makeCuttingPlane e = (e',c) -> eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)). @@ -717,19 +701,18 @@ Proof. unfold makeCuttingPlane in H0. revert H0. case_eq (Zgcd_pol e) ; intros g c0. - generalize (Zgt_cases g 0) ; destruct (Zgt_bool g 0). + generalize (Zgt_cases g 0) ; destruct (Z.gtb g 0). intros. inv H2. - change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in *. + change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *. apply Zgcd_pol_correct_lt with (env:=env) in H1. - generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Zminus e c0) g)) H0). + generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0). auto with zarith. auto with zarith. (* g <= 0 *) intros. inv H2. auto with zarith. Qed. - Lemma cutting_plane_sound : forall env f p, eval_nformula env f -> genCuttingPlane f = Some p -> @@ -741,13 +724,50 @@ Proof. (* Equal *) destruct p as [[e' z] op]. case_eq (Zgcd_pol e) ; intros g c. - destruct (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))) ; [discriminate|]. - intros. inv H1. unfold nformula_of_cutting_plane. - unfold eval_nformula in *. - unfold RingMicromega.eval_nformula in *. - unfold eval_op1 in *. - rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). - simpl. rewrite H0. reflexivity. + case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))) ; [discriminate|]. + case_eq (makeCuttingPlane e). + intros. + inv H3. + unfold makeCuttingPlane in H. + rewrite H1 in H. + revert H. + change (eval_pol env e = 0) in H2. + case_eq (Z.gtb g 0). + intros. + rewrite <- Zgt_is_gt_bool in H. + rewrite Zgcd_pol_correct_lt with (1:= H1) in H2; auto with zarith. + unfold nformula_of_cutting_plane. + change (eval_pol env (padd e' (Pc z)) = 0). + inv H3. + rewrite eval_pol_add. + set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub e c) g)) in *; clearbody x. + simpl. + rewrite andb_false_iff in H0. + destruct H0. + rewrite Zgt_is_gt_bool in H ; congruence. + rewrite andb_false_iff in H0. + destruct H0. + rewrite negb_false_iff in H0. + apply Zeq_bool_eq in H0. + subst. simpl. + rewrite Z.add_0_r, Z.mul_eq_0 in H2. + intuition auto with zarith. + rewrite negb_false_iff in H0. + apply Zeq_bool_eq in H0. + assert (HH := Zgcd_is_gcd g c). + rewrite H0 in HH. + inv HH. + apply Zdivide_opp_r in H4. + rewrite Zdivide_ceiling ; auto. + apply Z.sub_move_0_r. + apply Z.div_unique_exact ; auto with zarith. + intros. + unfold nformula_of_cutting_plane. + inv H3. + change (eval_pol env (padd e' (Pc 0)) = 0). + rewrite eval_pol_add. + simpl. + auto with zarith. (* NonEqual *) intros. inv H0. @@ -759,10 +779,10 @@ Proof. simpl. auto with zarith. (* Strict *) destruct p as [[e' z] op]. - case_eq (makeCuttingPlane (PsubC Zminus e 1)). + case_eq (makeCuttingPlane (PsubC Z.sub e 1)). intros. inv H1. - apply makeCuttingPlane_sound with (env:=env) (2:= H). + apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). simpl in *. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). auto with zarith. @@ -771,7 +791,7 @@ Proof. case_eq (makeCuttingPlane e). intros. inv H1. - apply makeCuttingPlane_sound with (env:=env) (2:= H). + apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). assumption. Qed. @@ -783,25 +803,26 @@ Proof. destruct f. destruct o. case_eq (Zgcd_pol p) ; intros g c. - case_eq (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))). + case_eq (Z.gtb g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Z.gcd g c) g))). intros. flatten_bool. rewrite negb_true_iff in H5. apply Zeq_bool_neq in H5. - contradict H5. rewrite <- Zgt_is_gt_bool in H3. - rewrite <- Zgt_is_gt_bool in H. - apply Zis_gcd_gcd; auto with zarith. - constructor; auto with zarith. + rewrite negb_true_iff in H. + apply Zeq_bool_neq in H. change (eval_pol env p = 0) in H2. rewrite Zgcd_pol_correct_lt with (1:= H0) in H2; auto with zarith. - set (x:=eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) in *; clearbody x. + set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) in *; clearbody x. + contradict H5. + apply Zis_gcd_gcd; auto with zarith. + constructor; auto with zarith. exists (-x). - rewrite <- Zopp_mult_distr_l, Zmult_comm; auto with zarith. + rewrite Z.mul_opp_l, Z.mul_comm; auto with zarith. (**) + destruct (makeCuttingPlane p); discriminate. discriminate. - discriminate. - destruct (makeCuttingPlane (PsubC Zminus p 1)) ; discriminate. + destruct (makeCuttingPlane (PsubC Z.sub p 1)) ; discriminate. destruct (makeCuttingPlane p) ; discriminate. Qed. @@ -816,11 +837,11 @@ Proof. simpl. intro l. case_eq (eval_Psatz l w) ; [| discriminate]. intros f Hf. - case_eq (check_inconsistent f). + case_eq (Zunsat f). intros. apply (checker_nf_sound Zsor ZSORaddon l w). unfold check_normalised_formulas. unfold eval_Psatz in Hf. rewrite Hf. - unfold check_inconsistent in H0. assumption. + unfold Zunsat in H0. assumption. intros. assert (make_impl (eval_nformula env) (f::l) False). apply H with (2:= H1). @@ -868,60 +889,59 @@ Proof. case_eq (eval_Psatz l w1) ; [ | discriminate]. case_eq (eval_Psatz l w2) ; [ | discriminate]. intros f1 Hf1 f2 Hf2. - case_eq (genCuttingPlane f2) ; [ | discriminate]. + case_eq (genCuttingPlane f2). destruct p as [ [p1 z1] op1]. - case_eq (genCuttingPlane f1) ; [ | discriminate]. + case_eq (genCuttingPlane f1). destruct p as [ [p2 z2] op2]. - case_eq op1 ; case_eq op2 ; try discriminate. - case_eq (is_pol_Z0 (padd p1 p2)) ; try discriminate. - intros. + case_eq (valid_cut_sign op1 && valid_cut_sign op2 && is_pol_Z0 (padd p1 p2)). + intros Hcond. + flatten_bool. + rename H1 into HZ0. + rename H2 into Hop1. + rename H3 into Hop2. + intros HCutL HCutR Hfix env. (* get the bounds of the enum *) rewrite <- make_conj_impl. intro. assert (-z1 <= eval_pol env p1 <= z2). split. apply eval_Psatz_sound with (env:=env) in Hf2 ; auto. - apply cutting_plane_sound with (1:= Hf2) in H4. - unfold nformula_of_cutting_plane in H4. - unfold eval_nformula in H4. - unfold RingMicromega.eval_nformula in H4. - change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H4. - unfold eval_op1 in H4. - rewrite eval_pol_add in H4. simpl in H4. - auto with zarith. + apply cutting_plane_sound with (1:= Hf2) in HCutR. + unfold nformula_of_cutting_plane in HCutR. + unfold eval_nformula in HCutR. + unfold RingMicromega.eval_nformula in HCutR. + change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutR. + unfold eval_op1 in HCutR. + destruct op1 ; simpl in Hop1 ; try discriminate; + rewrite eval_pol_add in HCutR; simpl in HCutR; auto with zarith. (**) - apply is_pol_Z0_eval_pol with (env := env) in H0. - rewrite eval_pol_add in H0. + apply is_pol_Z0_eval_pol with (env := env) in HZ0. + rewrite eval_pol_add in HZ0. replace (eval_pol env p1) with (- eval_pol env p2) by omega. apply eval_Psatz_sound with (env:=env) in Hf1 ; auto. - apply cutting_plane_sound with (1:= Hf1) in H3. - unfold nformula_of_cutting_plane in H3. - unfold eval_nformula in H3. - unfold RingMicromega.eval_nformula in H3. - change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H3. - unfold eval_op1 in H3. - rewrite eval_pol_add in H3. simpl in H3. - omega. - revert H5. - set (FF := (fix label (pfs : list ZArithProof) (lb ub : Z) {struct pfs} : bool := - match pfs with - | nil => if Z_gt_dec lb ub then true else false - | pf :: rsr => - (ZChecker ((PsubC Zminus p1 lb, Equal) :: l) pf && - label rsr (lb + 1)%Z ub)%bool - end)). + apply cutting_plane_sound with (1:= Hf1) in HCutL. + unfold nformula_of_cutting_plane in HCutL. + unfold eval_nformula in HCutL. + unfold RingMicromega.eval_nformula in HCutL. + change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutL. + unfold eval_op1 in HCutL. + rewrite eval_pol_add in HCutL. simpl in HCutL. + destruct op2 ; simpl in Hop2 ; try discriminate ; omega. + revert Hfix. + match goal with + | |- context[?F pf (-z1) z2 = true] => set (FF := F) + end. intros. assert (HH :forall x, -z1 <= x <= z2 -> exists pr, (In pr pf /\ - ZChecker ((PsubC Zminus p1 x,Equal) :: l) pr = true)%Z). - clear H. - clear H0 H1 H2 H3 H4 H7. - revert H5. + ZChecker ((PsubC Z.sub p1 x,Equal) :: l) pr = true)%Z). + clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1. + revert Hfix. generalize (-z1). clear z1. intro z1. revert z1 z2. induction pf;simpl ;intros. generalize (Zgt_cases z1 z2). - destruct (Zgt_bool z1 z2). + destruct (Z.gtb z1 z2). intros. apply False_ind ; omega. discriminate. @@ -931,16 +951,22 @@ Proof. subst. exists a ; auto. assert (z1 + 1 <= x <= z2)%Z by omega. - destruct (IHpf _ _ H1 _ H3). + elim IHpf with (2:=H2) (3:= H4). destruct H4. - exists x0 ; split;auto. + intros. + exists x0 ; split;tauto. + intros until 1. + apply H ; auto. + unfold ltof in *. + simpl in *. + zify. omega. (*/asser *) - destruct (HH _ H7) as [pr [Hin Hcheker]]. - assert (make_impl (eval_nformula env) ((PsubC Zminus p1 (eval_pol env p1),Equal) :: l) False). + destruct (HH _ H1) as [pr [Hin Hcheker]]. + assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False). apply (H pr);auto. apply in_bdepth ; auto. - rewrite <- make_conj_impl in H8. - apply H8. + rewrite <- make_conj_impl in H2. + apply H2. rewrite make_conj_cons. split ;auto. unfold eval_nformula. @@ -948,10 +974,23 @@ Proof. simpl. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). unfold eval_pol. ring. + discriminate. + (* No cutting plane *) + intros. + rewrite <- make_conj_impl. + intros. + apply eval_Psatz_sound with (2:= Hf1) in H3. + apply genCuttingPlaneNone with (2:= H3) ; auto. + (* No Cutting plane (bis) *) + intros. + rewrite <- make_conj_impl. + intros. + apply eval_Psatz_sound with (2:= Hf2) in H2. + apply genCuttingPlaneNone with (2:= H2) ; auto. Qed. Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool := - @tauto_checker (Formula Z) (NFormula Z) normalise negate ZArithProof ZChecker f w. + @tauto_checker (Formula Z) (NFormula Z) Zunsat Zdeduce normalise negate ZArithProof ZChecker f w. Lemma ZTautoChecker_sound : forall f w, ZTautoChecker f w = true -> forall env, eval_f (Zeval_formula env) f. Proof. @@ -959,6 +998,11 @@ Proof. unfold ZTautoChecker. apply (tauto_checker_sound Zeval_formula eval_nformula). apply Zeval_nformula_dec. + intros until env. + unfold eval_nformula. unfold RingMicromega.eval_nformula. + destruct t. + apply (check_inconsistent_sound Zsor ZSORaddon) ; auto. + unfold Zdeduce. apply (nformula_plus_nformula_correct Zsor ZSORaddon). intros env t. rewrite normalise_correct ; auto. intros env t. @@ -1009,12 +1053,7 @@ Definition eval := eval_formula. Definition prod_pos_nat := prod positive nat. -Definition n_of_Z (z:Z) : BinNat.N := - match z with - | Z0 => N0 - | Zpos p => Npos p - | Zneg p => N0 - end. +Notation n_of_Z := Z.to_N (only parsing). (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index bcab73ec..a5b0da9c 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,153 +15,18 @@ (* We take as input a list of polynomials [p1...pn] and return an unfeasibility certificate polynomial. *) -(*open Micromega.Polynomial*) +type var = int + + + open Big_int open Num -open Sos_lib +open Polynomial module Mc = Micromega module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml -let (<+>) = add_num -let (<->) = minus_num -let (<*>) = mult_num - -type var = Mc.positive - -module Monomial : -sig - type t - val const : t - val var : var -> t - val find : var -> t -> int - val mult : var -> t -> t - val prod : t -> t -> t - val compare : t -> t -> int - val pp : out_channel -> t -> unit - val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a -end - = -struct - (* A monomial is represented by a multiset of variables *) - module Map = Map.Make(struct type t = var let compare = Pervasives.compare end) - open Map - - type t = int Map.t - - (* The monomial that corresponds to a constant *) - let const = Map.empty - - (* The monomial 'x' *) - let var x = Map.add x 1 Map.empty - - (* Get the degre of a variable in a monomial *) - let find x m = try find x m with Not_found -> 0 - - (* Multiply a monomial by a variable *) - let mult x m = add x ( (find x m) + 1) m - - (* Product of monomials *) - let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 - - (* Total ordering of monomials *) - let compare m1 m2 = Map.compare Pervasives.compare m1 m2 - - let pp o m = Map.iter (fun k v -> - if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k) - else Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m - - let fold = fold - -end - - -module Poly : - (* A polynomial is a map of monomials *) - (* - This is probably a naive implementation - (expected to be fast enough - Coq is probably the bottleneck) - *The new ring contribution is using a sparse Horner representation. - *) -sig - type t - val get : Monomial.t -> t -> num - val variable : var -> t - val add : Monomial.t -> num -> t -> t - val constant : num -> t - val mult : Monomial.t -> num -> t -> t - val product : t -> t -> t - val addition : t -> t -> t - val uminus : t -> t - val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a - val pp : out_channel -> t -> unit - val compare : t -> t -> int - val is_null : t -> bool -end = -struct - (*normalisation bug : 0*x ... *) - module P = Map.Make(Monomial) - open P - - type t = num P.t - - let pp o p = P.iter (fun k v -> - if compare_num v (Int 0) <> 0 - then - if Monomial.compare Monomial.const k = 0 - then Printf.fprintf o "%s " (string_of_num v) - else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p - - (* Get the coefficient of monomial mn *) - let get : Monomial.t -> t -> num = - fun mn p -> try find mn p with Not_found -> (Int 0) - - - (* The polynomial 1.x *) - let variable : var -> t = - fun x -> add (Monomial.var x) (Int 1) empty - - (*The constant polynomial *) - let constant : num -> t = - fun c -> add (Monomial.const) c empty - - (* The addition of a monomial *) - - let add : Monomial.t -> num -> t -> t = - fun mn v p -> - let vl = (get mn p) <+> v in - add mn vl p - - - (** Design choice: empty is not a polynomial - I do not remember why .... - **) - - (* The product by a monomial *) - let mult : Monomial.t -> num -> t -> t = - fun mn v p -> - fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty - - - let addition : t -> t -> t = - fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 - - - let product : t -> t -> t = - fun p1 p2 -> - fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty - - - let uminus : t -> t = - fun p -> map (fun v -> minus_num v) p - - let fold = P.fold - - let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p true - - let compare = compare compare_num -end open Mutils type 'a number_spec = { @@ -178,10 +43,10 @@ let z_spec = { number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); zero = Mc.Z0; unit = Mc.Zpos Mc.XH; - mult = Mc.zmult; + mult = Mc.Z.mul; eqb = Mc.zeq_bool } - + let q_spec = { bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); @@ -195,56 +60,58 @@ let q_spec = { let r_spec = z_spec - - let dev_form n_spec p = - let rec dev_form p = + let rec dev_form p = match p with | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) - | Mc.PEX v -> Poly.variable v - | Mc.PEmul(p1,p2) -> + | Mc.PEX v -> Poly.variable (C2Ml.positive v) + | Mc.PEmul(p1,p2) -> let p1 = dev_form p1 in let p2 = dev_form p2 in - Poly.product p1 p2 + Poly.product p1 p2 | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) | Mc.PEopp p -> Poly.uminus (dev_form p) | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) - | Mc.PEpow(p,n) -> + | Mc.PEpow(p,n) -> let p = dev_form p in let n = C2Ml.n n in - let rec pow n = - if n = 0 + let rec pow n = + if n = 0 then Poly.constant (n_spec.number_to_num n_spec.unit) else Poly.product p (pow (n-1)) in pow n in dev_form p -let monomial_to_polynomial mn = - Monomial.fold - (fun v i acc -> - let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in - if acc = Mc.PEc (Mc.Zpos Mc.XH) - then mn - else Mc.PEmul(mn,acc)) - mn - (Mc.PEc (Mc.Zpos Mc.XH)) +let monomial_to_polynomial mn = + Monomial.fold + (fun v i acc -> + let v = Ml2C.positive v in + let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in + if acc = Mc.PEc (Mc.Zpos Mc.XH) + then mn + else Mc.PEmul(mn,acc)) + mn + (Mc.PEc (Mc.Zpos Mc.XH)) + -let list_to_polynomial vars l = + +let list_to_polynomial vars l = assert (List.for_all (fun x -> ceiling_num x =/ x) l); let var x = monomial_to_polynomial (List.nth vars x) in + let rec xtopoly p i = function | [] -> p - | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l + | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l else let c = Mc.PEc (Ml2C.bigint (numerator c)) in - let mn = + let mn = if c = Mc.PEc (Mc.Zpos Mc.XH) then var i else Mc.PEmul (c,var i) in let p' = if p = Mc.PEc Mc.Z0 then mn else Mc.PEadd (mn, p) in xtopoly p' (i+1) l in - + xtopoly (Mc.PEc Mc.Z0) 0 l let rec fixpoint f x = @@ -252,61 +119,54 @@ let rec fixpoint f x = if y' = x then y' else fixpoint f y' - - - - - - - -let rec_simpl_cone n_spec e = - let simpl_cone = +let rec_simpl_cone n_spec e = + let simpl_cone = Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in let rec rec_simpl_cone = function - | Mc.PsatzMulE(t1, t2) -> + | Mc.PsatzMulE(t1, t2) -> simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) - | Mc.PsatzAdd(t1,t2) -> + | Mc.PsatzAdd(t1,t2) -> simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) | x -> simpl_cone x in rec_simpl_cone e - - + + let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c - -type cone_prod = - Const of cone - | Ideal of cone *cone - | Mult of cone * cone + +type cone_prod = + Const of cone + | Ideal of cone *cone + | Mult of cone * cone | Other of cone and cone = Mc.zWitness let factorise_linear_cone c = - - let rec cone_list c l = + + let rec cone_list c l = match c with | Mc.PsatzAdd (x,r) -> cone_list r (x::l) | _ -> c :: l in - + let factorise c1 c2 = match c1 , c2 with - | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> + | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None - | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> + | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None | _ -> None in - + let rec rebuild_cone l pending = match l with | [] -> (match pending with | None -> Mc.PsatzZ | Some p -> p ) - | e::l -> + | e::l -> (match pending with - | None -> rebuild_cone l (Some e) + | None -> rebuild_cone l (Some e) | Some p -> (match factorise p e with | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e)) | Some f -> rebuild_cone l (Some f) ) @@ -316,15 +176,15 @@ let factorise_linear_cone c = -(* The binding with Fourier might be a bit obsolete +(* The binding with Fourier might be a bit obsolete -- how does it handle equalities ? *) (* Certificates are elements of the cone such that P = 0 *) (* To begin with, we search for certificates of the form: - a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 + a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 where pi >= 0 qi > 0 - ai >= 0 + ai >= 0 bi >= 0 Sum bi + c >= 1 This is a linear problem: each monomial is considered as a variable. @@ -334,216 +194,210 @@ let factorise_linear_cone c = *) open Mfourier - (*module Fourier = Fourier(Vector.VList)(SysSet(Vector.VList))*) - (*module Fourier = Fourier(Vector.VSparse)(SysSetAlt(Vector.VSparse))*) -(*module Fourier = Mfourier.Fourier(Vector.VSparse)(*(SysSetAlt(Vector.VMap))*)*) - -(*module Vect = Fourier.Vect*) -(*open Fourier.Cstr*) (* fold_left followed by a rev ! *) -let constrain_monomial mn l = +let constrain_monomial mn l = let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in if mn = Monomial.const - then - { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; - op = Eq ; + then + { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; + op = Eq ; cst = Big_int zero_big_int } else - { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; - op = Eq ; + { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; + op = Eq ; cst = Big_int zero_big_int } - -let positivity l = - let rec xpositivity i l = + +let positivity l = + let rec xpositivity i l = match l with | [] -> [] | (_,Mc.Equal)::l -> xpositivity (i+1) l - | (_,_)::l -> - {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; - op = Ge ; + | (_,_)::l -> + {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; + op = Ge ; cst = Int 0 } :: (xpositivity (i+1) l) in xpositivity 0 l let string_of_op = function - | Mc.Strict -> "> 0" - | Mc.NonStrict -> ">= 0" + | Mc.Strict -> "> 0" + | Mc.NonStrict -> ">= 0" | Mc.Equal -> "= 0" | Mc.NonEqual -> "<> 0" -(* If the certificate includes at least one strict inequality, +(* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) let build_linear_system l = - (* Gather the monomials: HINT add up of the polynomials *) + (* Gather the monomials: HINT add up of the polynomials ==> This does not work anymore *) let l' = List.map fst l in - let monomials = - List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' + + let module MonSet = Set.Make(Monomial) in + + let monomials = + List.fold_left (fun acc p -> + Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) + (MonSet.singleton Monomial.const) l' in (* For each monomial, compute a constraint *) - let s0 = - Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in + let s0 = + MonSet.fold (fun mn res -> (constrain_monomial mn l')::res) monomials [] in (* I need at least something strictly positive *) let strict = { coeffs = Vect.from_list ((Big_int unit_big_int):: - (List.map (fun (x,y) -> - match y with Mc.Strict -> - Big_int unit_big_int + (List.map (fun (x,y) -> + match y with Mc.Strict -> + Big_int unit_big_int | _ -> Big_int zero_big_int) l)); op = Ge ; cst = Big_int unit_big_int } in (* Add the positivity constraint *) - {coeffs = Vect.from_list ([Big_int unit_big_int]) ; - op = Ge ; + {coeffs = Vect.from_list ([Big_int unit_big_int]) ; + op = Ge ; cst = Big_int zero_big_int}::(strict::(positivity l)@s0) let big_int_to_z = Ml2C.bigint - -(* For Q, this is a pity that the certificate has been scaled + +(* For Q, this is a pity that the certificate has been scaled -- at a lower layer, certificates are using nums... *) -let make_certificate n_spec (cert,li) = +let make_certificate n_spec (cert,li) = let bint_to_cst = n_spec.bigint_to_number in match cert with | [] -> failwith "empty_certificate" - | e::cert' -> - let cst = match compare_big_int e zero_big_int with + | e::cert' -> +(* let cst = match compare_big_int e zero_big_int with | 0 -> Mc.PsatzZ - | 1 -> Mc.PsatzC (bint_to_cst e) - | _ -> failwith "positivity error" - in + | 1 -> Mc.PsatzC (bint_to_cst e) + | _ -> failwith "positivity error" + in *) let rec scalar_product cert l = match cert with | [] -> Mc.PsatzZ - | c::cert -> match l with - | [] -> failwith "make_certificate(1)" - | i::l -> - let r = scalar_product cert l in - match compare_big_int c zero_big_int with - | -1 -> Mc.PsatzAdd ( - Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), - r) - | 0 -> r - | _ -> Mc.PsatzAdd ( - Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), - r) in - - ((factorise_linear_cone - (simplify_cone n_spec (Mc.PsatzAdd (cst, scalar_product cert' li))))) + | c::cert -> + match l with + | [] -> failwith "make_certificate(1)" + | i::l -> + let r = scalar_product cert l in + match compare_big_int c zero_big_int with + | -1 -> Mc.PsatzAdd ( + Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), + r) + | 0 -> r + | _ -> Mc.PsatzAdd ( + Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), + r) in + (factorise_linear_cone + (simplify_cone n_spec (scalar_product cert' li))) exception Found of Monomial.t exception Strict -let primal l = +let primal l = let vr = ref 0 in let module Mmn = Map.Make(Monomial) in let vect_of_poly map p = - Poly.fold (fun mn vl (map,vect) -> - if mn = Monomial.const + Poly.fold (fun mn vl (map,vect) -> + if mn = Monomial.const then (map,vect) - else + else let (mn,m) = try (Mmn.find mn map,map) with Not_found -> let res = (!vr, Mmn.add mn !vr map) in incr vr ; res in (m,if sign_num vl = 0 then vect else (mn,vl)::vect)) p (map,[]) in - + let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in let cmp x y = Pervasives.compare (fst x) (fst y) in snd (List.fold_right (fun (p,op) (map,l) -> - let (mp,vect) = vect_of_poly map p in + let (mp,vect) = vect_of_poly map p in let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in (mp,cstr::l)) l (Mmn.empty,[])) -let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = +let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = (* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *) - - + let sys = build_linear_system l in - try + try match Fourier.find_point sys with | Inr _ -> None - | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) + | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) (* should not use rats_to_ints *) - with x -> - if debug - then (Printf.printf "raw certificate %s" (Printexc.to_string x); + with x when Errors.noncritical x -> + if debug + then (Printf.printf "raw certificate %s" (Printexc.to_string x); flush stdout) ; None -let raw_certificate l = - try +let raw_certificate l = + try let p = primal l in match Fourier.find_point p with - | Inr prf -> - if debug then Printf.printf "AProof : %a\n" pp_proof prf ; + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" pp_proof prf ; let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in - if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; + if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; Some (rats_to_ints (Vect.to_list cert)) | Inl _ -> None - with Strict -> + with Strict -> (* Fourier elimination should handle > *) - dual_raw_certificate l + dual_raw_certificate l -let simple_linear_prover (*to_constant*) l = +let simple_linear_prover l = let (lc,li) = List.split l in match raw_certificate lc with | None -> None (* No certificate *) - | Some cert -> (* make_certificate to_constant*)Some (cert,li) + | Some cert -> Some (cert,li) + -let linear_prover n_spec l = - let li = List.combine l (interval 0 (List.length l -1)) in - let (l1,l') = List.partition - (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in - let l' = List.map - (fun ((x,y),i) -> match y with - Mc.NonEqual -> failwith "cannot happen" - | y -> ((dev_form n_spec x, y),i)) l' in - simple_linear_prover (*n_spec*) l' +let linear_prover n_spec l = + let build_system n_spec l = + let li = List.combine l (interval 0 (List.length l -1)) in + let (l1,l') = List.partition + (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in + List.map + (fun ((x,y),i) -> match y with + Mc.NonEqual -> failwith "cannot happen" + | y -> ((dev_form n_spec x, y),i)) l' in + let l' = build_system n_spec l in + simple_linear_prover (*n_spec*) l' let linear_prover n_spec l = - try linear_prover n_spec l with - x -> (print_string (Printexc.to_string x); None) + try linear_prover n_spec l + with x when x <> Sys.Break -> + (print_string (Printexc.to_string x); None) -let linear_prover_with_cert spec l = +let linear_prover_with_cert spec l = match linear_prover spec l with | None -> None | Some cert -> Some (make_certificate spec cert) -(* zprover.... *) - -(* I need to gather the set of variables ---> - Then go for fold - Once I have an interval, I need a certificate : 2 other fourier elims. - (I could probably get the certificate directly - as it is done in the fourier contrib.) -*) let make_linear_system l = let l' = List.map fst l in - let monomials = List.fold_left (fun acc p -> Poly.addition p acc) + let monomials = List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' in - let monomials = Poly.fold + let monomials = Poly.fold (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in - (List.map (fun (c,op) -> - {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; - op = op ; + (List.map (fun (c,op) -> + {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; + op = op ; cst = minus_num ( (Poly.get Monomial.const c))}) l ,monomials) @@ -552,130 +406,66 @@ let pplus x y = Mc.PEadd(x,y) let pmult x y = Mc.PEmul(x,y) let pconst x = Mc.PEc x let popp x = Mc.PEopp x - + let debug = false - + (* keep track of enumerated vectors *) -let rec mem p x l = +let rec mem p x l = match l with [] -> false | e::l -> if p x e then true else mem p x l -let rec remove_assoc p x l = +let rec remove_assoc p x l = match l with [] -> [] | e::l -> if p x (fst e) then - remove_assoc p x l else e::(remove_assoc p x l) + remove_assoc p x l else e::(remove_assoc p x l) let eq x y = Vect.compare x y = 0 let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l -(* The prover is (probably) incomplete -- +(* The prover is (probably) incomplete -- only searching for naive cutting planes *) -let candidates sys = - let ll = List.fold_right ( - fun (e,k) r -> - match k with - | Mc.NonStrict -> (dev_form z_spec e , Ge)::r - | Mc.Equal -> (dev_form z_spec e , Eq)::r - (* we already know the bound -- don't compute it again *) - | _ -> failwith "Cannot happen candidates") sys [] in - - let (sys,var_mn) = make_linear_system ll in - let vars = mapi (fun _ i -> Vect.set i (Int 1) Vect.null) var_mn in - (List.fold_left (fun l cstr -> - let gcd = Big_int (Vect.gcd cstr.coeffs) in - if gcd =/ (Int 1) && cstr.op = Eq - then l - else (Vect.mul (Int 1 // gcd) cstr.coeffs)::l) [] sys) @ vars - - - - -let rec xzlinear_prover planes sys = - match linear_prover z_spec sys with - | Some prf -> Some (Mc.RatProof (make_certificate z_spec prf,Mc.DoneProof)) - | None -> (* find the candidate with the smallest range *) - (* Grrr - linear_prover is also calling 'make_linear_system' *) - let ll = List.fold_right (fun (e,k) r -> match k with - Mc.NonEqual -> r - | k -> (dev_form z_spec e , - match k with - Mc.NonStrict -> Ge - | Mc.Equal -> Eq - | Mc.Strict | Mc.NonEqual -> failwith "Cannot happen") :: r) sys [] in - let (ll,var) = make_linear_system ll in - let candidates = List.fold_left (fun acc vect -> - match Fourier.optimise vect ll with - | None -> acc - | Some i -> -(* Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *) - flush stdout ; - (vect,i) ::acc) [] planes in - - let smallest_interval = - match List.fold_left (fun (x1,i1) (x2,i2) -> - if Itv.smaller_itv i1 i2 - then (x1,i1) else (x2,i2)) (Vect.null,(None,None)) candidates - with - | (x,(Some i, Some j)) -> Some(i,x,j) - | x -> None (* This might be a cutting plane *) - in - match smallest_interval with - | Some (lb,e,ub) -> - let (lbn,lbd) = - (Ml2C.bigint (sub_big_int (numerator lb) unit_big_int), - Ml2C.bigint (denominator lb)) in - let (ubn,ubd) = - (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) , - Ml2C.bigint (denominator ub)) in - let expr = list_to_polynomial var (Vect.to_list e) in - (match - (*x <= ub -> x > ub *) - linear_prover z_spec - ((pplus (pmult (pconst ubd) expr) (popp (pconst ubn)), - Mc.NonStrict) :: sys), - (* lb <= x -> lb > x *) - linear_prover z_spec - ((pplus (popp (pmult (pconst lbd) expr)) (pconst lbn), - Mc.NonStrict)::sys) - with - | Some cub , Some clb -> - (match zlinear_enum (remove e planes) expr - (ceiling_num lb) (floor_num ub) sys - with - | None -> None - | Some prf -> - let bound_proof (c,l) = make_certificate z_spec (List.tl c , List.tl (List.map (fun x -> x -1) l)) in - - Some (Mc.EnumProof((*Ml2C.q lb,expr,Ml2C.q ub,*) bound_proof clb, bound_proof cub,prf))) - | _ -> None - ) - | _ -> None -and zlinear_enum planes expr clb cub l = - if clb >/ cub - then Some [] - else - let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in - let sys' = (pexpr, Mc.Equal)::l in - (*let enum = *) - match xzlinear_prover planes sys' with - | None -> if debug then print_string "zlp?"; None - | Some prf -> if debug then print_string "zlp!"; - match zlinear_enum planes expr (clb +/ (Int 1)) cub l with - | None -> None - | Some prfl -> Some (prf :: prfl) +let develop_constraint z_spec (e,k) = + match k with + | Mc.NonStrict -> (dev_form z_spec e , Ge) + | Mc.Equal -> (dev_form z_spec e , Eq) + | _ -> assert false + + +let op_of_op_compat = function + | Ge -> Mc.NonStrict + | Eq -> Mc.Equal + + +let integer_vector coeffs = + let vars , coeffs = List.split coeffs in + List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs)) + +let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } = + let vars , coeffs = List.split coeffs in + match rats_to_ints (cst::coeffs) with + | cst :: coeffs -> + { + coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ; + op = op ; cst = Big_int cst} + | _ -> assert false + + +let pexpr_of_cstr_compat var cstr = + let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in + try + let expr = list_to_polynomial var (Vect.to_list coeffs) in + let d = Ml2C.bigint (denominator cst) in + let n = Ml2C.bigint (numerator cst) in + (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op) + with Failure _ -> failwith "pexpr_of_cstr_compat" + + -let zlinear_prover sys = - let candidates = candidates sys in - (* Printf.printf "candidates %d" (List.length candidates) ; *) - (*let t0 = Sys.time () in*) - let res = xzlinear_prover candidates sys in - (*Printf.printf "Time prover : %f" (Sys.time () -. t0) ;*) res open Sos_types -open Mutils -let rec scale_term t = +let rec scale_term t = match t with | Zero -> unit_big_int , Zero | Const n -> (denominator n) , Const (Big_int (numerator n)) @@ -708,7 +498,7 @@ let get_index_of_ith_match f i l = match l with | [] -> failwith "bad index" | e::l -> if f e - then + then (if j = i then res else get (j+1) (res+1) l ) else get j (res+1) l in get 0 0 l @@ -722,19 +512,19 @@ let rec scale_certificate pos = match pos with | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) - | Square t -> let s,t' = scale_term t in + | Square t -> let s,t' = scale_term t in mult_big_int s s , Square t' | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in mult_big_int s1 s2 , Eqmul (y1,y2) - | Sum (y, z) -> let s1,y1 = scale_certificate y + | Sum (y, z) -> let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in let g = gcd_big_int s1 s2 in let s1' = div_big_int s1 g in let s2' = div_big_int s2 g in - mult_big_int g (mult_big_int s1' s2'), + mult_big_int g (mult_big_int s1' s2'), Sum (Product(Rational_le (Big_int s2'), y1), Product (Rational_le (Big_int s1'), y2)) - | Product (y, z) -> + | Product (y, z) -> let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in mult_big_int s1 s2 , Product (y1,y2) @@ -743,7 +533,7 @@ open Micromega let rec term_to_q_expr = function | Const n -> PEc (Ml2C.q n) | Zero -> PEc ( Ml2C.q (Int 0)) - | Var s -> PEX (Ml2C.index + | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) @@ -755,20 +545,20 @@ open Micromega let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) - let rec product l = + let rec product l = match l with | [] -> Mc.PsatzZ | [i] -> Mc.PsatzIn (Ml2C.nat i) | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) -let q_cert_of_pos pos = +let q_cert_of_pos pos = let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l - | Rational_eq n | Rational_le n | Rational_lt n -> + | Rational_eq n | Rational_le n | Rational_lt n -> if compare_num n (Int 0) = 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.q n) | Square t -> Mc.PsatzSquare (term_to_q_pol t) @@ -781,7 +571,7 @@ let q_cert_of_pos pos = let rec term_to_z_expr = function | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) | Zero -> PEc ( Z0) - | Var s -> PEX (Ml2C.index + | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) @@ -790,24 +580,649 @@ let q_cert_of_pos pos = | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) | _ -> failwith "term_to_z_expr: not implemented" - let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.zplus Mc.zmult Mc.zminus Mc.zopp Mc.zeq_bool (term_to_z_expr e) + let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e) -let z_cert_of_pos pos = +let z_cert_of_pos pos = let s,pos = (scale_certificate pos) in let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l - | Rational_eq n | Rational_le n | Rational_lt n -> + | Rational_eq n | Rational_le n | Rational_lt n -> if compare_num n (Int 0) = 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) | Square t -> Mc.PsatzSquare (term_to_z_pol t) - | Eqmul (t, y) -> Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) + | Eqmul (t, y) -> + let is_unit = + match t with + | Const n -> n =/ Int 1 + | _ -> false in + if is_unit + then _cert_of_pos y + else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in simplify_cone z_spec (_cert_of_pos pos) +(** All constraints (initial or derived) have an index and have a justification i.e., proof. + Given a constraint, all the coefficients are always integers. +*) +open Mutils +open Mfourier +open Num +open Big_int +open Polynomial + +(*module Mc = Micromega*) +(*module Ml2C = Mutils.CamlToCoq +module C2Ml = Mutils.CoqToCaml +*) +let debug = false + + + +module Env = +struct + + type t = int list + + let id_of_hyp hyp l = + let rec xid_of_hyp i l = + match l with + | [] -> failwith "id_of_hyp" + | hyp'::l -> if hyp = hyp' then i else xid_of_hyp (i+1) l in + xid_of_hyp 0 l + +end + + +let coq_poly_of_linpol (p,c) = + + let pol_of_mon m = + Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in + + List.fold_left (fun acc (x,v) -> + let mn = LinPoly.MonT.retrieve x in + Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p + + + + +let rec cmpl_prf_rule env = function + | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env)) + | Cst i -> Mc.PsatzC (Ml2C.bigint i) + | Zero -> Mc.PsatzZ + | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2) + | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2) + | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in + Mc.PsatzMulC(lp,cmpl_prf_rule env p) + | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp)) + | _ -> failwith "Cuts should already be compiled" + + +let rec cmpl_proof env = function + | Done -> Mc.DoneProof + | Step(i,p,prf) -> + begin + match p with + | CutPrf p' -> + Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf) + | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf) + end + | Enum(i,p1,_,p2,l) -> + Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l) + + +let compile_proof env prf = + let id = 1 + proof_max_id prf in + let _,prf = normalise_proof id prf in + if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf; + cmpl_proof env prf + +type prf_sys = (cstr_compat * prf_rule) list + + +let xlinear_prover sys = + match Fourier.find_point sys with + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" pp_proof prf ; + let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in + if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; + Some (rats_to_ints (Vect.to_list cert)) + | Inl _ -> None + + +let output_num o n = output_string o (string_of_num n) +let output_bigint o n = output_string o (string_of_big_int n) + +let proof_of_farkas prf cert = +(* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *) + let rec mk_farkas acc prf cert = + match prf, cert with + | _ , [] -> acc + | [] , _ -> failwith "proof_of_farkas : not enough hyps" + | p::prf,c::cert -> + mk_farkas (add_proof (mul_proof c p) acc) prf cert in + let res = mk_farkas Zero prf cert in + (*Printf.printf "==> %a" output_prf_rule res ; *) + res + + +let linear_prover sys = + let (sysi,prfi) = List.split sys in + match xlinear_prover sysi with + | None -> None + | Some cert -> Some (proof_of_farkas prfi cert) + +let linear_prover = + if debug + then + fun sys -> + Printf.printf "<linear_prover"; flush stdout ; + let res = linear_prover sys in + Printf.printf ">"; flush stdout ; + res + else linear_prover + + + + +(** A single constraint can be unsat for the following reasons: + - 0 >= c for c a negative constant + - 0 = c for c a non-zero constant + - e = c when the coeffs of e are all integers and c is rational +*) + +type checksat = + | Tauto (* Tautology *) + | Unsat of prf_rule (* Unsatisfiable *) + | Cut of cstr_compat * prf_rule (* Cutting plane *) + | Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *) + + +(** [check_sat] + - detects constraints that are not satisfiable; + - normalises constraints and generate cuts. +*) + +let check_sat (cstr,prf) = + let {coeffs=coeffs ; op=op ; cst=cst} = cstr in + match coeffs with + | [] -> + if eval_op op (Int 0) cst then Tauto else Unsat prf + | _ -> + let gcdi = (gcd_list (List.map snd coeffs)) in + let gcd = Big_int gcdi in + if eq_num gcd (Int 1) + then Normalise(cstr,prf) + else + if sign_num (mod_num cst gcd) = 0 + then (* We can really normalise *) + begin + assert (sign_num gcd >=1 ) ; + let cstr = { + coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; + op = op ; cst = cst // gcd + } in + Normalise(cstr,Gcd(gcdi,prf)) + (* Normalise(cstr,CutPrf prf)*) + end + else + match op with + | Eq -> Unsat (CutPrf prf) + | Ge -> + let cstr = { + coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; + op = op ; cst = ceiling_num (cst // gcd) + } in Cut(cstr,CutPrf prf) + + +(** Proof generating pivoting over variable v *) +let pivot v (c1,p1) (c2,p2) = + let {coeffs = v1 ; op = op1 ; cst = n1} = c1 + and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in + + + + (* Could factorise gcd... *) + let xpivot cv1 cv2 = + ( + {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; + op = Proof.add_op op1 op2 ; + cst = n1 */ cv1 +/ n2 */ cv2 }, + + AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in + + match Vect.get v v1 , Vect.get v v2 with + | None , _ | _ , None -> None + | Some a , Some b -> + if (sign_num a) * (sign_num b) = -1 + then + let cv1 = abs_num b + and cv2 = abs_num a in + Some (xpivot cv1 cv2) + else + if op1 = Eq + then + let cv1 = minus_num (b */ (Int (sign_num a))) + and cv2 = abs_num a in + Some (xpivot cv1 cv2) + else if op2 = Eq + then + let cv1 = abs_num b + and cv2 = minus_num (a */ (Int (sign_num b))) in + Some (xpivot cv1 cv2) + else None (* op2 could be Eq ... this might happen *) + +exception FoundProof of prf_rule + +let rec simpl_sys sys = + List.fold_left (fun acc (c,p) -> + match check_sat (c,p) with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut(c,p) -> (c,p)::acc + | Normalise (c,p) -> (c,p)::acc) [] sys + + +(** [ext_gcd a b] is the extended Euclid algorithm. + [ext_gcd a b = (x,y,g)] iff [ax+by=g] + Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm +*) +let rec ext_gcd a b = + if sign_big_int b = 0 + then (unit_big_int,zero_big_int) + else + let (q,r) = quomod_big_int a b in + let (s,t) = ext_gcd b r in + (t, sub_big_int s (mult_big_int q t)) + + +let pp_ext_gcd a b = + let a' = big_int_of_int a in + let b' = big_int_of_int b in + + let (x,y) = ext_gcd a' b' in + Printf.fprintf stdout "%s * %s + %s * %s = %s\n" + (string_of_big_int x) (string_of_big_int a') + (string_of_big_int y) (string_of_big_int b') + (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b'))) + +exception Result of (int * (proof * cstr_compat)) + +let split_equations psys = + List.partition (fun (c,p) -> c.op = Eq) + + +let extract_coprime (c1,p1) (c2,p2) = + let rec exist2 vect1 vect2 = + match vect1 , vect2 with + | _ , [] | [], _ -> None + | (v1,n1)::vect1' , (v2, n2) :: vect2' -> + if v1 = v2 + then + if compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int = 0 + then Some (v1,n1,n2) + else + exist2 vect1' vect2' + else + if v1 < v2 + then exist2 vect1' vect2 + else exist2 vect1 vect2' in + + if c1.op = Eq && c2.op = Eq + then exist2 c1.coeffs c2.coeffs + else None + +let extract2 pred l = + let rec xextract2 rl l = + match l with + | [] -> (None,rl) (* Did not find *) + | e::l -> + match extract (pred e) l with + | None,_ -> xextract2 (e::rl) l + | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in + + xextract2 [] l + + +let extract_coprime_equation psys = + extract2 extract_coprime psys + + +let apply_and_normalise f psys = + List.fold_left (fun acc pc' -> + match f pc' with + | None -> pc'::acc + | Some pc' -> + match check_sat pc' with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut(c,p) -> (c,p)::acc + | Normalise (c,p) -> (c,p)::acc + ) [] psys + + + + +let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys + + +let reduce_coprime psys = + let oeq,sys = extract_coprime_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> + let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in + let l1' = Big_int l1 and l2' = Big_int l2 in + let cstr = + {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs); + op = Eq ; + cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) + } in + let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in + + Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) + +(** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) +let reduce_unary psys = + let is_unary_equation (cstr,prf) = + if cstr.op = Eq + then + try + Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs)) + with Not_found -> None + else None in + + let (oeq,sys) = extract is_unary_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some(v,pc) -> + Some(pivot_sys v pc sys) + +let reduce_non_lin_unary psys = + + let is_unary_equation (cstr,prf) = + if cstr.op = Eq + then + try + let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in + let x' = LinPoly.MonT.retrieve x in + if List.for_all (fun (y,_) -> y = x || snd (Monomial.div (LinPoly.MonT.retrieve y) x') = 0) cstr.coeffs + then Some x + else None + with Not_found -> None + else None in + + + let (oeq,sys) = extract is_unary_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some(v,pc) -> + Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys) + +let reduce_var_change psys = + + let rec rel_prime vect = + match vect with + | [] -> None + | (x,v)::vect -> + let v = numerator v in + try + let (x',v') = List.find (fun (_,v') -> + let v' = numerator v' in + eq_big_int (gcd_big_int v v') unit_big_int) vect in + Some ((x,v),(x',numerator v')) + with Not_found -> rel_prime vect in + + let rel_prime (cstr,prf) = if cstr.op = Eq then rel_prime cstr.coeffs else None in + + let (oeq,sys) = extract rel_prime psys in + + match oeq with + | None -> None + | Some(((x,v),(x',v')),(c,p)) -> + let (l1,l2) = ext_gcd v v' in + let l1,l2 = Big_int l1 , Big_int l2 in + + let get v vect = + match Vect.get v vect with + | None -> Int 0 + | Some n -> n in + + let pivot_eq (c',p') = + let {coeffs = coeffs ; op = op ; cst = cst} = c' in + let vx = get x coeffs in + let vx' = get x' coeffs in + let m = minus_num (vx */ l1 +/ vx' */ l2) in + Some ({coeffs = + Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} , + AddPrf(MulC(([], m),p),p')) in + + Some (apply_and_normalise pivot_eq sys) + + + + + let reduce_pivot psys = + let is_equation (cstr,prf) = + if cstr.op = Eq + then + try + Some (fst (List.hd cstr.coeffs)) + with Not_found -> None + else None in + let (oeq,sys) = extract is_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some(v,pc) -> + if debug then + Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst); + Some(pivot_sys v pc sys) + + + + + + let iterate_until_stable f x = + let rec iter x = + match f x with + | None -> x + | Some x' -> iter x' in + iter x + + let rec app_funs l x = + match l with + | [] -> None + | f::fl -> + match f x with + | None -> app_funs fl x + | Some x' -> Some x' + + let reduction_equations psys = + iterate_until_stable (app_funs + [reduce_unary ; reduce_coprime ; + reduce_var_change (*; reduce_pivot*)]) psys + + let reduction_non_lin_equations psys = + iterate_until_stable (app_funs + [reduce_non_lin_unary (*; reduce_coprime ; + reduce_var_change ; reduce_pivot *)]) psys + + + + + (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) + let get_bound sys = + let is_small (v,i) = + match Itv.range i with + | None -> false + | Some i -> i <=/ (Int 1) in + + let select_best (x1,i1) (x2,i2) = + if Itv.smaller_itv i1 i2 + then (x1,i1) else (x2,i2) in + + (* For lia, there are no equations => these precautions are not needed *) + (* For nlia, there are equations => do not enumerate over equations! *) + let all_planes sys = + let (eq,ineq) = List.partition (fun c -> c.op = Eq) sys in + match eq with + | [] -> List.rev_map (fun c -> c.coeffs) ineq + | _ -> + List.fold_left (fun acc c -> + if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq + then acc else c.coeffs ::acc) [] ineq in + + let smallest_interval = + List.fold_left + (fun acc vect -> + if is_small acc + then acc + else + match Fourier.optimise vect sys with + | None -> acc + | Some i -> + if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ; + select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in + let smallest_interval = + match smallest_interval + with + | (x,(Some i, Some j)) -> Some(i,x,j) + | x -> None (* This should not be possible *) + in + match smallest_interval with + | Some (lb,e,ub) -> + let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in + let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in + (match + (* x <= ub -> x > ub *) + xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), + (* lb <= x -> lb > x *) + xlinear_prover + ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys) + with + | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub) + | _ -> failwith "Interval without proof" + ) + | None -> None + + + let check_sys sys = + List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys + + + let xlia reduction_equations sys = + + let rec enum_proof (id:int) (sys:prf_sys) : proof option = + if debug then (Printf.printf "enum_proof\n" ; flush stdout) ; + assert (check_sys sys) ; + + let nsys,prf = List.split sys in + match get_bound nsys with + | None -> None (* Is the systeme really unbounded ? *) + | Some(prf1,(lb,e,ub),prf2) -> + if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ; + (match start_enum id e (ceiling_num lb) (floor_num ub) sys + with + | Some prfl -> + Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl)) + | None -> None + ) + + and start_enum id e clb cub sys = + if clb >/ cub + then Some [] + else + let eq = {coeffs = e ; op = Eq ; cst = clb} in + match aux_lia (id+1) ((eq, Def id) :: sys) with + | None -> None + | Some prf -> + match start_enum id e (clb +/ (Int 1)) cub sys with + | None -> None + | Some l -> Some (prf::l) + + and aux_lia (id:int) (sys:prf_sys) : proof option = + assert (check_sys sys) ; + if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; + try + let sys = reduction_equations sys in + if debug then + Printf.printf "after reduction: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; + match linear_prover sys with + | Some prf -> Some (Step(id,prf,Done)) + | None -> enum_proof id sys + with FoundProof prf -> + (* [reduction_equations] can find a proof *) + Some(Step(id,prf,Done)) in + + (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*) + let id = List.length sys in + let orpf = + try + let sys = simpl_sys sys in + aux_lia id sys + with FoundProof pr -> Some(Step(id,pr,Done)) in + match orpf with + | None -> None + | Some prf -> + (*Printf.printf "direct proof %a\n" output_proof prf ; *) + let env = mapi (fun _ i -> i) sys in + let prf = compile_proof env prf in + (*try + if Mc.zChecker sys' prf then Some prf else + raise Certificate.BadCertificate + with Failure s -> (Printf.printf "%s" s ; Some prf) + *) Some prf + + + let cstr_compat_of_poly (p,o) = + let (v,c) = LinPoly.linpol_of_pol p in + {coeffs = v ; op = o ; cst = minus_num c } + + + let lia sys = + LinPoly.MonT.clear (); + let sys = List.map (develop_constraint z_spec) sys in + let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in + let sys = mapi (fun c i -> (c,Hyp i)) sys in + xlia reduction_equations sys + + + let nlia sys = + LinPoly.MonT.clear (); + let sys = List.map (develop_constraint z_spec) sys in + let sys = mapi (fun c i -> (c,Hyp i)) sys in + + let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in + + let module MonMap = Map.Make(Monomial) in + + let collect_square = + List.fold_left (fun acc ((p,_),_) -> Poly.fold + (fun m _ acc -> + match Monomial.sqrt m with + | None -> acc + | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in + let sys = MonMap.fold (fun s m acc -> + let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in + let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in + ((m, Ge), (Square s))::acc) collect_square sys in + +(* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*) + + let sys = + if is_linear then sys + else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') -> + ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in + + let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in + assert (check_sys sys) ; + xlia (if is_linear then reduction_equations else reduction_non_lin_equations) sys + + + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 4eb26afd..ff08aeb3 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -12,7 +12,7 @@ (* *) (* - Modules ISet, M, Mc, Env, Cache, CacheZ *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-2009 *) +(* Frédéric Besson (Irisa/Inria) 2006-20011 *) (* *) (************************************************************************) @@ -55,7 +55,7 @@ type 'cst atom = 'cst Micromega.formula * Micromega's encoding of formulas. * By order of appearance: boolean constants, variables, atoms, conjunctions, * disjunctions, negation, implication. - *) +*) type 'cst formula = | TT @@ -86,6 +86,18 @@ let rec pp_formula o f = | None -> "") pp_formula f2 | N(f) -> Printf.fprintf o "N(%a)" pp_formula f + +let rec map_atoms fct f = + match f with + | TT -> TT + | FF -> FF + | X x -> X x + | A (at,tg,cstr) -> A(fct at,tg,cstr) + | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2) + | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2) + | N f -> N(map_atoms fct f) + | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) + (** * Collect the identifiers of a (string of) implications. Implication labels * are inherited from Coq/CoC's higher order dependent type constructor (Pi). @@ -125,7 +137,9 @@ let ff : 'cst cnf = [ [] ] * and the freeform formulas ('cst formula) that is retrieved from Coq. *) -type 'cst mc_cnf = ('cst Micromega.nFormula) list list +module Mc = Micromega + +type 'cst mc_cnf = ('cst Mc.nFormula) list list (** * From a freeform formula, build a cnf. @@ -134,7 +148,12 @@ type 'cst mc_cnf = ('cst Micromega.nFormula) list list * and RingMicromega.v). *) -let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) = +type 'a tagged_option = T of tag list | S of 'a + +let cnf + (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) + (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) = + let negate a t = List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in @@ -143,26 +162,79 @@ let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) let and_cnf x y = x @ y in - let or_clause_cnf t f = List.map (fun x -> t@x) f in +let rec add_term t0 = function + | [] -> + (match deduce (fst t0) (fst t0) with + | Some u -> if unsat u then T [snd t0] else S (t0::[]) + | None -> S (t0::[])) + | t'::cl0 -> + (match deduce (fst t0) (fst t') with + | Some u -> + if unsat u + then T [snd t0 ; snd t'] + else (match add_term t0 cl0 with + | S cl' -> S (t'::cl') + | T l -> T l) + | None -> + (match add_term t0 cl0 with + | S cl' -> S (t'::cl') + | T l -> T l)) in + + + let rec or_clause cl1 cl2 = + match cl1 with + | [] -> S cl2 + | t0::cl -> + (match add_term t0 cl2 with + | S cl' -> or_clause cl cl' + | T l -> T l) in + + + + let or_clause_cnf t f = + List.fold_right (fun e (acc,tg) -> + match or_clause t e with + | S cl -> (cl :: acc,tg) + | T l -> (acc,tg@l)) f ([],[]) in + let rec or_cnf f f' = match f with - | [] -> tt - | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in + | [] -> tt,[] + | e :: rst -> + let (rst_f',t) = or_cnf rst f' in + let (e_f', t') = or_clause_cnf e f' in + (rst_f' @ e_f', t @ t') in + let rec xcnf (polarity : bool) f = match f with - | TT -> if polarity then tt else ff - | FF -> if polarity then ff else tt - | X p -> if polarity then ff else ff - | A(x,t,_) -> if polarity then normalise x t else negate x t + | TT -> if polarity then (tt,[]) else (ff,[]) + | FF -> if polarity then (ff,[]) else (tt,[]) + | X p -> if polarity then (ff,[]) else (ff,[]) + | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[]) | N(e) -> xcnf (not polarity) e - | C(e1,e2) -> - (if polarity then and_cnf else or_cnf) (xcnf polarity e1) (xcnf polarity e2) + | C(e1,e2) -> + let e1,t1 = xcnf polarity e1 in + let e2,t2 = xcnf polarity e2 in + if polarity + then and_cnf e1 e2, t1 @ t2 + else let f',t' = or_cnf e1 e2 in + (f', t1 @ t2 @ t') | D(e1,e2) -> - (if polarity then or_cnf else and_cnf) (xcnf polarity e1) (xcnf polarity e2) + let e1,t1 = xcnf polarity e1 in + let e2,t2 = xcnf polarity e2 in + if polarity + then let f',t' = or_cnf e1 e2 in + (f', t1 @ t2 @ t') + else and_cnf e1 e2, t1 @ t2 | I(e1,_,e2) -> - (if polarity then or_cnf else and_cnf) (xcnf (not polarity) e1) (xcnf polarity e2) in + let e1 , t1 = (xcnf (not polarity) e1) in + let e2 , t2 = (xcnf polarity e2) in + if polarity + then let f',t' = or_cnf e1 e2 in + (f', t1 @ t2 @ t') + else and_cnf e1 e2, t1 @ t2 in xcnf true f @@ -212,6 +284,7 @@ struct ["RingMicromega"]; ["EnvRing"]; ["Coq"; "micromega"; "ZMicromega"]; + ["Coq"; "micromega"; "RMicromega"]; ["Coq" ; "micromega" ; "Tauto"]; ["Coq" ; "micromega" ; "RingMicromega"]; ["Coq" ; "micromega" ; "EnvRing"]; @@ -220,6 +293,15 @@ struct ["Coq";"Reals" ; "Rpow_def"]; ["LRing_normalise"]] + let bin_module = [["Coq";"Numbers";"BinNums"]] + + let r_modules = + [["Coq";"Reals" ; "Rdefinitions"]; + ["Coq";"Reals" ; "Rpow_def"] ; +] + + let z_modules = [["Coq";"ZArith";"BinInt"]] + (** * Initialization : a large amount of Caml symbols are derived from * ZMicromega.v @@ -227,6 +309,9 @@ struct let init_constant = gen_constant_in_modules "ZMicromega" init_modules let constant = gen_constant_in_modules "ZMicromega" coq_modules + let bin_constant = gen_constant_in_modules "ZMicromega" bin_module + let r_constant = gen_constant_in_modules "ZMicromega" r_modules + let z_constant = gen_constant_in_modules "ZMicromega" z_modules (* let constant = gen_constant_in_modules "Omicron" coq_modules *) let coq_and = lazy (init_constant "and") @@ -244,34 +329,42 @@ struct let coq_S = lazy (init_constant "S") let coq_nat = lazy (init_constant "nat") - let coq_NO = lazy - (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]] "N0") - let coq_Npos = lazy - (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]] "Npos") - (* let coq_n = lazy (constant "N")*) + let coq_N0 = lazy (bin_constant "N0") + let coq_Npos = lazy (bin_constant "Npos") - let coq_pair = lazy (constant "pair") - let coq_None = lazy (constant "None") - let coq_option = lazy (constant "option") - let coq_positive = lazy (constant "positive") - let coq_xH = lazy (constant "xH") - let coq_xO = lazy (constant "xO") - let coq_xI = lazy (constant "xI") + let coq_pair = lazy (init_constant "pair") + let coq_None = lazy (init_constant "None") + let coq_option = lazy (init_constant "option") - let coq_N0 = lazy (constant "N0") - let coq_N0 = lazy (constant "Npos") + let coq_positive = lazy (bin_constant "positive") + let coq_xH = lazy (bin_constant "xH") + let coq_xO = lazy (bin_constant "xO") + let coq_xI = lazy (bin_constant "xI") + + let coq_Z = lazy (bin_constant "Z") + let coq_ZERO = lazy (bin_constant "Z0") + let coq_POS = lazy (bin_constant "Zpos") + let coq_NEG = lazy (bin_constant "Zneg") - let coq_Z = lazy (constant "Z") let coq_Q = lazy (constant "Q") let coq_R = lazy (constant "R") - let coq_ZERO = lazy (constant "Z0") - let coq_POS = lazy (constant "Zpos") - let coq_NEG = lazy (constant "Zneg") - let coq_Build_Witness = lazy (constant "Build_Witness") let coq_Qmake = lazy (constant "Qmake") + + let coq_Rcst = lazy (constant "Rcst") + let coq_C0 = lazy (constant "C0") + let coq_C1 = lazy (constant "C1") + let coq_CQ = lazy (constant "CQ") + let coq_CZ = lazy (constant "CZ") + let coq_CPlus = lazy (constant "CPlus") + let coq_CMinus = lazy (constant "CMinus") + let coq_CMult = lazy (constant "CMult") + let coq_CInv = lazy (constant "CInv") + let coq_COpp = lazy (constant "COpp") + + let coq_R0 = lazy (constant "R0") let coq_R1 = lazy (constant "R1") @@ -281,17 +374,17 @@ struct let coq_cutProof = lazy (constant "CutProof") let coq_enumProof = lazy (constant "EnumProof") - let coq_Zgt = lazy (constant "Zgt") - let coq_Zge = lazy (constant "Zge") - let coq_Zle = lazy (constant "Zle") - let coq_Zlt = lazy (constant "Zlt") + let coq_Zgt = lazy (z_constant "Z.gt") + let coq_Zge = lazy (z_constant "Z.ge") + let coq_Zle = lazy (z_constant "Z.le") + let coq_Zlt = lazy (z_constant "Z.lt") let coq_Eq = lazy (init_constant "eq") - let coq_Zplus = lazy (constant "Zplus") - let coq_Zminus = lazy (constant "Zminus") - let coq_Zopp = lazy (constant "Zopp") - let coq_Zmult = lazy (constant "Zmult") - let coq_Zpower = lazy (constant "Zpower") + let coq_Zplus = lazy (z_constant "Z.add") + let coq_Zminus = lazy (z_constant "Z.sub") + let coq_Zopp = lazy (z_constant "Z.opp") + let coq_Zmult = lazy (z_constant "Z.mul") + let coq_Zpower = lazy (z_constant "Z.pow") let coq_Qgt = lazy (constant "Qgt") let coq_Qge = lazy (constant "Qge") @@ -305,16 +398,20 @@ struct let coq_Qmult = lazy (constant "Qmult") let coq_Qpower = lazy (constant "Qpower") - let coq_Rgt = lazy (constant "Rgt") - let coq_Rge = lazy (constant "Rge") - let coq_Rle = lazy (constant "Rle") - let coq_Rlt = lazy (constant "Rlt") - - let coq_Rplus = lazy (constant "Rplus") - let coq_Rminus = lazy (constant "Rminus") - let coq_Ropp = lazy (constant "Ropp") - let coq_Rmult = lazy (constant "Rmult") - let coq_Rpower = lazy (constant "pow") + let coq_Rgt = lazy (r_constant "Rgt") + let coq_Rge = lazy (r_constant "Rge") + let coq_Rle = lazy (r_constant "Rle") + let coq_Rlt = lazy (r_constant "Rlt") + + let coq_Rplus = lazy (r_constant "Rplus") + let coq_Rminus = lazy (r_constant "Rminus") + let coq_Ropp = lazy (r_constant "Ropp") + let coq_Rmult = lazy (r_constant "Rmult") + let coq_Rdiv = lazy (r_constant "Rdiv") + let coq_Rinv = lazy (r_constant "Rinv") + let coq_Rpower = lazy (r_constant "pow") + let coq_IQR = lazy (constant "IQR") + let coq_IZR = lazy (constant "IZR") let coq_PEX = lazy (constant "PEX" ) let coq_PEc = lazy (constant"PEc") @@ -444,8 +541,6 @@ struct (* Access the Micromega module *) - module Mc = Micromega - (* parse/dump/print from numbers up to expressions and formulas *) let rec parse_nat term = @@ -491,11 +586,6 @@ struct let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) - let rec dump_n x = - match x with - | Mc.N0 -> Lazy.force coq_NO - | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |]) - let rec pp_n o x = output_string o (string_of_int (CoqToCaml.n x)) let dump_pair t1 t2 dump_t1 dump_t2 (x,y) = @@ -515,7 +605,7 @@ struct | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) - let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x) + let pp_z o x = Printf.fprintf o "%s" (Big_int.string_of_big_int (CoqToCaml.z_big_int x)) let dump_num bd1 = Term.mkApp(Lazy.force coq_Qmake, @@ -533,6 +623,48 @@ struct else raise ParseError | _ -> raise ParseError + + let rec pp_Rcst o cst = + match cst with + | Mc.C0 -> output_string o "C0" + | Mc.C1 -> output_string o "C1" + | Mc.CQ q -> output_string o "CQ _" + | Mc.CZ z -> pp_z o z + | Mc.CPlus(x,y) -> Printf.fprintf o "(%a + %a)" pp_Rcst x pp_Rcst y + | Mc.CMinus(x,y) -> Printf.fprintf o "(%a - %a)" pp_Rcst x pp_Rcst y + | Mc.CMult(x,y) -> Printf.fprintf o "(%a * %a)" pp_Rcst x pp_Rcst y + | Mc.CInv t -> Printf.fprintf o "(/ %a)" pp_Rcst t + | Mc.COpp t -> Printf.fprintf o "(- %a)" pp_Rcst t + + + let rec dump_Rcst cst = + match cst with + | Mc.C0 -> Lazy.force coq_C0 + | Mc.C1 -> Lazy.force coq_C1 + | Mc.CQ q -> Term.mkApp(Lazy.force coq_CQ, [| dump_q q |]) + | Mc.CZ z -> Term.mkApp(Lazy.force coq_CZ, [| dump_z z |]) + | Mc.CPlus(x,y) -> Term.mkApp(Lazy.force coq_CPlus, [| dump_Rcst x ; dump_Rcst y |]) + | Mc.CMinus(x,y) -> Term.mkApp(Lazy.force coq_CMinus, [| dump_Rcst x ; dump_Rcst y |]) + | Mc.CMult(x,y) -> Term.mkApp(Lazy.force coq_CMult, [| dump_Rcst x ; dump_Rcst y |]) + | Mc.CInv t -> Term.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) + | Mc.COpp t -> Term.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) + + let rec parse_Rcst term = + let (i,c) = get_left_construct term in + match i with + | 1 -> Mc.C0 + | 2 -> Mc.C1 + | 3 -> Mc.CQ (parse_q c.(0)) + | 4 -> Mc.CPlus(parse_Rcst c.(0), parse_Rcst c.(1)) + | 5 -> Mc.CMinus(parse_Rcst c.(0), parse_Rcst c.(1)) + | 6 -> Mc.CMult(parse_Rcst c.(0), parse_Rcst c.(1)) + | 7 -> Mc.CInv(parse_Rcst c.(0)) + | 8 -> Mc.COpp(parse_Rcst c.(0)) + | _ -> raise ParseError + + + + let rec parse_list parse_elt term = let (i,c) = get_left_construct term in match i with @@ -766,14 +898,21 @@ struct let parse_expr parse_constant parse_exp ops_spec env term = if debug then (Pp.pp (Pp.str "parse_expr: "); - Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ()); + Pp.pp (Printer.prterm term); + Pp.pp (Pp.str "\n"); + Pp.pp_flush ()); +(* let constant_or_variable env term = try ( Mc.PEc (parse_constant term) , env) with ParseError -> let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in +*) + let parse_variable env term = + let (env,n) = Env.compute_rank_add env term in + (Mc.PEX n , env) in let rec parse_expr env term = let combine env op (t1,t2) = @@ -781,32 +920,35 @@ struct let (expr2,env) = parse_expr env t2 in (op expr1 expr2,env) in - match kind_of_term term with - | App(t,args) -> - ( - match kind_of_term t with - | Const c -> - ( match assoc_ops t ops_spec with - | Binop f -> combine env f (args.(0),args.(1)) - | Opp -> let (expr,env) = parse_expr env args.(0) in - (Mc.PEopp expr, env) - | Power -> - begin - try - let (expr,env) = parse_expr env args.(0) in - let power = (parse_exp expr args.(1)) in - (power , env) - with _ -> (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) - end - | Ukn s -> - if debug - then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + try (Mc.PEc (parse_constant term) , env) + with ParseError -> + match kind_of_term term with + | App(t,args) -> + ( + match kind_of_term t with + | Const c -> + ( match assoc_ops t ops_spec with + | Binop f -> combine env f (args.(0),args.(1)) + | Opp -> let (expr,env) = parse_expr env args.(0) in + (Mc.PEopp expr, env) + | Power -> + begin + try + let (expr,env) = parse_expr env args.(0) in + let power = (parse_exp expr args.(1)) in + (power , env) + with e when e <> Sys.Break -> + (* if the exponent is a variable *) + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + end + | Ukn s -> + if debug + then (Printf.printf "unknown op: %s\n" s; flush stdout;); + let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) ) - | _ -> constant_or_variable env term - ) - | _ -> constant_or_variable env term in + | _ -> parse_variable env term + ) + | _ -> parse_variable env term in parse_expr env term let zop_spec = @@ -836,27 +978,63 @@ struct let zconstant = parse_z let qconstant = parse_q - let rconstant term = - if debug - then (Pp.pp_flush (); - Pp.pp (Pp.str "rconstant: "); - Pp.pp (Printer.prterm term); Pp.pp_flush ()); + + let rconst_assoc = + [ + coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ; + coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ; + coq_Rmult , (fun x y -> Mc.CMult(x,y)) ; + coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ; + ] + + let rec rconstant term = match Term.kind_of_term term with | Const x -> if term = Lazy.force coq_R0 - then Mc.Z0 + then Mc.C0 else if term = Lazy.force coq_R1 - then Mc.Zpos Mc.XH + then Mc.C1 else raise ParseError + | App(op,args) -> + begin + try + (* the evaluation order is important in the following *) + let f = assoc_const op rconst_assoc in + let a = rconstant args.(0) in + let b = rconstant args.(1) in + f a b + with + ParseError -> + match op with + | op when op = Lazy.force coq_Rinv -> Mc.CInv(rconstant args.(0)) + | op when op = Lazy.force coq_IQR -> Mc.CQ (parse_q args.(0)) +(* | op when op = Lazy.force coq_IZR -> Mc.CZ (parse_z args.(0))*) + | _ -> raise ParseError + end + | _ -> raise ParseError + + let rconstant term = + if debug + then (Pp.pp_flush (); + Pp.pp (Pp.str "rconstant: "); + Pp.pp (Printer.prterm term); + Pp.pp (Pp.str "\n"); + Pp.pp_flush ()); + let res = rconstant term in + if debug then + (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; + res + + let parse_zexpr = parse_expr zconstant (fun expr x -> let exp = (parse_z x) in match exp with | Mc.Zneg _ -> Mc.PEc Mc.Z0 - | _ -> Mc.PEpow(expr, Mc.n_of_Z exp)) + | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec let parse_qexpr = parse_expr @@ -870,14 +1048,14 @@ struct | Mc.PEc q -> Mc.PEc (Mc.qpower q exp) | _ -> print_string "parse_qexpr parse error" ; flush stdout ; raise ParseError end - | _ -> let exp = Mc.n_of_Z exp in + | _ -> let exp = Mc.Z.to_N exp in Mc.PEpow(expr,exp)) qop_spec let parse_rexpr = parse_expr rconstant (fun expr x -> - let exp = Mc.n_of_nat (parse_nat x) in + let exp = Mc.N.of_nat (parse_nat x) in Mc.PEpow(expr,exp)) rop_spec @@ -886,6 +1064,7 @@ struct then (Pp.pp_flush (); Pp.pp (Pp.str "parse_arith: "); Pp.pp (Printer.prterm cstr); + Pp.pp (Pp.str "\n"); Pp.pp_flush ()); match kind_of_term cstr with | App(op,args) -> @@ -932,26 +1111,30 @@ struct * This is the big generic function for formula parsers. *) - let parse_formula parse_atom env term = + let parse_formula parse_atom env tg term = - let parse_atom env tg t = try let (at,env) = parse_atom env t in - (A(at,tg,t), env,Tag.next tg) with _ -> (X(t),env,tg) in + let parse_atom env tg t = + try + let (at,env) = parse_atom env t in + (A(at,tg,t), env,Tag.next tg) + with e when e <> Sys.Break -> (X(t),env,tg) + in let rec xparse_formula env tg term = match kind_of_term term with | App(l,rst) -> (match rst with - | [|a;b|] when l = Lazy.force coq_and -> + | [|a;b|] when eq_constr l (Lazy.force coq_and) -> let f,env,tg = xparse_formula env tg a in let g,env, tg = xparse_formula env tg b in mkformula_binary mkC term f g,env,tg - | [|a;b|] when l = Lazy.force coq_or -> + | [|a;b|] when eq_constr l (Lazy.force coq_or) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkD term f g,env,tg - | [|a|] when l = Lazy.force coq_not -> + | [|a|] when eq_constr l (Lazy.force coq_not) -> let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) - | [|a;b|] when l = Lazy.force coq_iff -> + | [|a;b|] when eq_constr l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg @@ -960,10 +1143,10 @@ struct let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg - | _ when term = Lazy.force coq_True -> (TT,env,tg) - | _ when term = Lazy.force coq_False -> (FF,env,tg) + | _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg) + | _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg) | _ -> X(term),env,tg in - xparse_formula env term + xparse_formula env tg ((*Reductionops.whd_zeta*) term) let dump_formula typ dump_atom f = let rec xdump f = @@ -1011,7 +1194,8 @@ let same_proof sg cl1 cl2 = let rec xsame_proof sg = match sg with | [] -> true - | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) + | n::sg -> + (try List.nth cl1 n = List.nth cl2 n with e when e <> Sys.Break -> false) && (xsame_proof sg ) in xsame_proof sg @@ -1024,9 +1208,9 @@ let tags_of_clause tgs wit clause = | _ -> tgs in xtags tgs wit -let tags_of_cnf wits cnf = +(*let tags_of_cnf wits cnf = List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) - Names.Idset.empty wits cnf + Names.Idset.empty wits cnf *) let find_witness prover polys1 = try_any prover polys1 @@ -1075,7 +1259,7 @@ let btree_of_array typ a = let btree_of_array typ a = try btree_of_array typ a - with x -> + with x when x <> Sys.Break -> failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) let dump_varmap typ env = @@ -1103,6 +1287,27 @@ let rec dump_proof_term = function [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) + +let rec size_of_psatz = function + | Micromega.PsatzIn _ -> 1 + | Micromega.PsatzSquare _ -> 1 + | Micromega.PsatzMulC(_,p) -> 1 + (size_of_psatz p) + | Micromega.PsatzMulE(p1,p2) | Micromega.PsatzAdd(p1,p2) -> size_of_psatz p1 + size_of_psatz p2 + | Micromega.PsatzC _ -> 1 + | Micromega.PsatzZ -> 1 + +let rec size_of_pf = function + | Micromega.DoneProof -> 1 + | Micromega.RatProof(p,a) -> (size_of_pf a) + (size_of_psatz p) + | Micromega.CutProof(p,a) -> (size_of_pf a) + (size_of_psatz p) + | Micromega.EnumProof(p1,p2,l) -> (size_of_psatz p1) + (size_of_psatz p2) + (List.fold_left (fun acc p -> size_of_pf p + acc) 0 l) + +let dump_proof_term t = + if debug then Printf.printf "dump_proof_term %i\n" (size_of_pf t) ; + dump_proof_term t + + + let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden @@ -1123,7 +1328,7 @@ let rec parse_hyps parse_arith env tg hyps = try let (c,env,tg) = parse_formula parse_arith env tg t in ((i,c)::lhyps, env,tg) - with _ -> (lhyps,env,tg) + with e when e <> Sys.Break -> (lhyps,env,tg) (*(if debug then Printf.printf "parse_arith : %s\n" x);*) @@ -1139,13 +1344,12 @@ let parse_goal parse_arith env hyps term = (** * The datastructures that aggregate theory-dependent proof values. *) - -type ('d, 'prf) domain_spec = { - typ : Term.constr; (* Z, Q , R *) - coeff : Term.constr ; (* Z, Q *) - dump_coeff : 'd -> Term.constr ; - proof_typ : Term.constr ; - dump_proof : 'prf -> Term.constr +type ('synt_c, 'prf) domain_spec = { + typ : Term.constr; (* is the type of the interpretation domain - Z, Q, R*) + coeff : Term.constr ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) + dump_coeff : 'synt_c -> Term.constr ; + proof_typ : Term.constr ; + dump_proof : 'prf -> Term.constr } let zz_domain_spec = lazy { @@ -1164,12 +1368,12 @@ let qq_domain_spec = lazy { dump_proof = dump_psatz coq_Q dump_q } -let rz_domain_spec = lazy { +let rcst_domain_spec = lazy { typ = Lazy.force coq_R; - coeff = Lazy.force coq_Z; - dump_coeff = dump_z; - proof_typ = Lazy.force coq_ZWitness ; - dump_proof = dump_psatz coq_Z dump_z + coeff = Lazy.force coq_Rcst; + dump_coeff = dump_Rcst; + proof_typ = Lazy.force coq_QWitness ; + dump_proof = dump_psatz coq_Q dump_q } (** @@ -1260,15 +1464,15 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = let remap i = let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in List.assoc formula new_cl in - if debug then +(* if debug then begin Printf.printf "\ncompact_proof : %a %a %a" (pp_ml_list prover.pp_f) (List.map fst old_cl) prover.pp_prf prf (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout - end ; - let res = try prover.compact prf remap with x -> + end ; *) + let res = try prover.compact prf remap with x when x <> Sys.Break -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) match prover.prover (List.map fst new_cl) with @@ -1327,6 +1531,20 @@ let abstract_formula hyps f = | TT -> TT in xabs f + +(* [abstract_wrt_formula] is used in contexts whre f1 is already an abstraction of f2 *) +let rec abstract_wrt_formula f1 f2 = + match f1 , f2 with + | X c , _ -> X c + | A _ , A _ -> f2 + | C(a,b) , C(a',b') -> C(abstract_wrt_formula a a', abstract_wrt_formula b b') + | D(a,b) , D(a',b') -> D(abstract_wrt_formula a a', abstract_wrt_formula b b') + | I(a,_,b) , I(a',x,b') -> I(abstract_wrt_formula a a',x, abstract_wrt_formula b b') + | FF , FF -> FF + | TT , TT -> TT + | N x , N y -> N(abstract_wrt_formula x y) + | _ -> failwith "abstract_wrt_formula" + (** * This exception is raised by really_call_csdpcert if Coq's configure didn't * find a CSDP executable. @@ -1339,20 +1557,22 @@ exception CsdpNotFound * prune unused fomulas, and finally modify the proof state. *) -let micromega_tauto negate normalise spec prover env polys1 polys2 gl = - let spec = Lazy.force spec in - - (* Express the goal as one big implication *) - let (ff,ids) = +let formula_hyps_concl hyps concl = List.fold_right (fun (id,f) (cc,ids) -> match f with X _ -> (cc,ids) | _ -> (I(f,Some id,cc), id::ids)) - polys1 (polys2,[]) in + hyps (concl,[]) + + +let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 gl = + + (* Express the goal as one big implication *) + let (ff,ids) = formula_hyps_concl polys1 polys2 in (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *) - let cnf_ff = cnf negate normalise ff in + let cnf_ff,cnf_ff_tags = cnf negate normalise unsat deduce ff in if debug then begin @@ -1365,19 +1585,19 @@ let micromega_tauto negate normalise spec prover env polys1 polys2 gl = end; match witness_list_tags prover cnf_ff with - | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl + | None -> None | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) let hyps = List.fold_left (fun s (cl,(prf,p)) -> let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in - TagSet.union s tags) TagSet.empty (List.combine cnf_ff res) in + TagSet.union s tags) (List.fold_left (fun s i -> TagSet.add i s) TagSet.empty cnf_ff_tags) (List.combine cnf_ff res) in if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; let ff' = abstract_formula hyps ff in - let cnf_ff' = cnf negate normalise ff' in + let cnf_ff',_ = cnf negate normalise unsat deduce ff' in if debug then begin @@ -1400,41 +1620,124 @@ let micromega_tauto negate normalise spec prover env polys1 polys2 gl = end ; *) let res' = compact_proofs cnf_ff res cnf_ff' in - let (ff',res',ids) = (ff',res',List.map Term.mkVar (ids_of_formula ff')) in + let (ff',res',ids) = (ff',res', ids_of_formula ff') in let res' = dump_list (spec.proof_typ) spec.dump_proof res' in - (Tacticals.tclTHENSEQ - [ - Tactics.generalize ids ; - micromega_order_change spec res' - (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff' - ]) gl + Some (ids,ff',res') + + (** * Parse the proof environment, and call micromega_tauto *) let micromega_gen - parse_arith + parse_arith (negate:'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) + unsat deduce spec prover gl = let concl = Tacmach.pf_concl gl in let hyps = Tacmach.pf_hyps_types gl in try let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in let env = Env.elements env in - micromega_tauto negate normalise spec prover env hyps concl gl + let spec = Lazy.force spec in + + match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl with + | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl + | Some (ids,ff',res') -> + (Tacticals.tclTHENSEQ + [ + Tactics.generalize (List.map Term.mkVar ids) ; + micromega_order_change spec res' + (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff' + ]) gl with - | Failure x -> flush stdout ; Pp.pp_flush () ; - Tacticals.tclFAIL 0 (Pp.str x) gl +(* | Failure x -> flush stdout ; Pp.pp_flush () ; + Tacticals.tclFAIL 0 (Pp.str x) gl *) | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl | CsdpNotFound -> flush stdout ; Pp.pp_flush () ; Tacticals.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately this instance of Coq isn't aware of the presence of any \"csdp\" executable. \n\n" - ^ "This executable should be in PATH")) gl + ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" + ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl + + + +let micromega_order_changer cert env ff gl = + let coeff = Lazy.force coq_Rcst in + let dump_coeff = dump_Rcst in + let typ = Lazy.force coq_R in + let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in + + let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in + let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in + let vm = dump_varmap (typ) env in + Tactics.change_in_concl None + (set + [ + ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); + ("__varmap", vm, Term.mkApp + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); + ("__wit", cert, cert_typ) + ] + (Tacmach.pf_concl gl) + ) + gl + + +let micromega_genr prover gl = + let parse_arith = parse_rarith in + let negate = Mc.rnegate in + let normalise = Mc.rnormalise in + let unsat = Mc.runsat in + let deduce = Mc.rdeduce in + let spec = lazy { + typ = Lazy.force coq_R; + coeff = Lazy.force coq_Rcst; + dump_coeff = dump_q; + proof_typ = Lazy.force coq_QWitness ; + dump_proof = dump_psatz coq_Q dump_q + } in + + let concl = Tacmach.pf_concl gl in + let hyps = Tacmach.pf_hyps_types gl in + try + let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in + let env = Env.elements env in + let spec = Lazy.force spec in + + let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in + let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in + + match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with + | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl + | Some (ids,ff',res') -> + let (ff,ids') = formula_hyps_concl + (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in + + (Tacticals.tclTHENSEQ + [ + Tactics.generalize (List.map Term.mkVar ids) ; + micromega_order_changer res' env (abstract_wrt_formula ff' ff) + ]) gl + with +(* | Failure x -> flush stdout ; Pp.pp_flush () ; + Tacticals.tclFAIL 0 (Pp.str x) gl *) + | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl + | CsdpNotFound -> flush stdout ; Pp.pp_flush () ; + Tacticals.tclFAIL 0 (Pp.str + (" Skipping what remains of this tactic: the complexity of the goal requires " + ^ "the use of a specialized external tool called csdp. \n\n" + ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" + ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl + + + + let lift_ratproof prover l = match prover l with @@ -1462,13 +1765,13 @@ let csdp_cache = "csdp.cache" (** * Build the command to call csdpcert, and launch it. This in turn will call * the sos driver to the csdp executable. - * Throw CsdpNotFound if a Coq isn't aware of any csdp executable. + * Throw CsdpNotFound if Coq isn't aware of any csdp executable. *) let require_csdp = - match System.search_exe_in_path "csdp" with - | Some _ -> lazy () - | _ -> lazy (raise CsdpNotFound) + if System.is_in_system_path "csdp" + then lazy () + else lazy (raise CsdpNotFound) let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = fun provername poly -> @@ -1607,15 +1910,17 @@ let linear_prover_Q = { pp_f = fun o x -> pp_pol pp_q o (fst x) } + let linear_prover_R = { name = "linear prover"; - prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec) ; + prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; hyps = hyps_of_cone ; compact = compact_cone ; - pp_prf = pp_psatz pp_z ; - pp_f = fun o x -> pp_pol pp_z o (fst x) + pp_prf = pp_psatz pp_q ; + pp_f = fun o x -> pp_pol pp_q o (fst x) } + let non_linear_prover_Q str o = { name = "real nonlinear prover"; prover = call_csdpcert_q (str, o); @@ -1627,11 +1932,11 @@ let non_linear_prover_Q str o = { let non_linear_prover_R str o = { name = "real nonlinear prover"; - prover = call_csdpcert_z (str, o); + prover = call_csdpcert_q (str, o); hyps = hyps_of_cone; compact = compact_cone; - pp_prf = pp_psatz pp_z; - pp_f = fun o x -> pp_pol pp_z o (fst x) + pp_prf = pp_psatz pp_q; + pp_f = fun o x -> pp_pol pp_q o (fst x) } let non_linear_prover_Z str o = { @@ -1649,7 +1954,13 @@ module CacheZ = PHashtable(struct let hash = Hashtbl.hash end) -let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover) +let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.lia) +let memo_nlia = CacheZ.memo "nlia.cache" (lift_pexpr_prover Certificate.nlia) + +(*let memo_zlinear_prover = (lift_pexpr_prover Lia.lia)*) +(*let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)*) + + let linear_Z = { name = "lia"; @@ -1660,50 +1971,81 @@ let linear_Z = { pp_f = fun o x -> pp_pol pp_z o (fst x) } +let nlinear_Z = { + name = "nlia"; + prover = memo_nlia ; + hyps = hyps_of_pt; + compact = compact_pt; + pp_prf = pp_proof_term; + pp_f = fun o x -> pp_pol pp_z o (fst x) +} + + + +let tauto_lia ff = + let prover = linear_Z in + let cnf_ff,_ = cnf Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce ff in + match witness_list_tags [prover] cnf_ff with + | None -> None + | Some l -> Some (List.map fst l) + + (** * Functions instantiating micromega_gen with the appropriate theories and * solvers *) let psatzl_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ linear_prover_Z ] gl let psatzl_Q gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec [ linear_prover_Q ] gl let psatz_Q i gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl + let psatzl_R gl = - micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec - [ linear_prover_R ] gl + micromega_genr [ linear_prover_R ] gl + let psatz_R i gl = - micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec - [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl + micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl + let psatz_Z i gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec - [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec + [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl let sos_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec [ non_linear_prover_Z "pure_sos" None ] gl let sos_Q gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec [ non_linear_prover_Q "pure_sos" None ] gl + let sos_R gl = - micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec - [ non_linear_prover_R "pure_sos" None ] gl + micromega_genr [ non_linear_prover_R "pure_sos" None ] gl + let xlia gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec - [ linear_Z ] gl + try + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec + [ linear_Z ] gl + with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise + +let xnlia gl = + try + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec + [ nlinear_Z ] gl + with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise + + (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index 3b47007c..0f26575c 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -28,7 +28,7 @@ type csdp_certificate = S of Sos_types.positivstellensatz option | F of string type provername = string * int option -let debug = true +let debug = false let flags = [Open_append;Open_binary;Open_creat] let chan = open_out_gen flags 0o666 "trace" @@ -150,7 +150,7 @@ let real_nonlinear_prover d l = S (Some proof) with | Sos_lib.TooDeep -> S None - | x -> F (Printexc.to_string x) + | x when x <> Sys.Break -> F (Printexc.to_string x) (* This is somewhat buggy, over Z, strict inequality vanish... *) let pure_sos l = @@ -174,7 +174,7 @@ let pure_sos l = S (Some proof) with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) - | x -> (* May be that could be refined *) S None + | x when x <> Sys.Break -> (* May be that could be refined *) S None @@ -203,7 +203,7 @@ let main () = Marshal.to_channel chan (cert:csdp_certificate) [] ; flush chan ; exit 0 - with x -> (Printf.fprintf chan "error %s" (Printexc.to_string x) ; exit 1) + with any -> (Printf.fprintf chan "error %s" (Printexc.to_string any) ; exit 1) ;; diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 9b6842bd..0d888f85 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,18 +8,18 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) +(* * Mappings from Coq tactics to Caml function calls *) +(* *) (* Frédéric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_micromega.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Quote open Ring open Mutils -open Rawterm +open Glob_term open Util let out_arg = function @@ -35,6 +35,11 @@ TACTIC EXTEND ZOmicron [ "xlia" ] -> [ Coq_micromega.xlia] END +TACTIC EXTEND Nlia +[ "xnlia" ] -> [ Coq_micromega.xnlia] +END + + TACTIC EXTEND Sos_Z | [ "sos_Z" ] -> [ Coq_micromega.sos_Z] @@ -57,8 +62,6 @@ TACTIC EXTEND QOmicron [ "psatzl_Q" ] -> [ Coq_micromega.psatzl_Q] END - - TACTIC EXTEND ROmicron [ "psatzl_R" ] -> [ Coq_micromega.psatzl_R] END @@ -68,7 +71,6 @@ TACTIC EXTEND RMicromega | [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ] END - TACTIC EXTEND QMicromega | [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ] | [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ] diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 6250e324..6effa4c4 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -1,5 +1,8 @@ open Num module Utils = Mutils +open Polynomial +open Vect + let map_option = Utils.map_option let from_option = Utils.from_option @@ -7,132 +10,6 @@ let from_option = Utils.from_option let debug = false type ('a,'b) lr = Inl of 'a | Inr of 'b - -module Vect = - struct - (** [t] is the type of vectors. - A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - - variables indexes are ordered (x1 < ... < xn - - values are all non-zero - *) - type var = int - type t = (var * num) list - -(** [equal v1 v2 = true] if the vectors are syntactically equal. - ([num] is not handled by [Pervasives.equal] *) - - let rec equal v1 v2 = - match v1 , v2 with - | [] , [] -> true - | [] , _ -> false - | _::_ , [] -> false - | (i1,n1)::v1 , (i2,n2)::v2 -> - (i1 = i2) && n1 =/ n2 && equal v1 v2 - - let hash v = - let rec hash i = function - | [] -> i - | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in - Hashtbl.hash (hash 0 v ) - - - let null = [] - - let pp_vect o vect = - List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect - - let from_list (l: num list) = - let rec xfrom_list i l = - match l with - | [] -> [] - | e::l -> - if e <>/ Int 0 - then (i,e)::(xfrom_list (i+1) l) - else xfrom_list (i+1) l in - - xfrom_list 0 l - - let zero_num = Int 0 - let unit_num = Int 1 - - - let to_list m = - let rec xto_list i l = - match l with - | [] -> [] - | (x,v)::l' -> - if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in - xto_list 0 m - - - let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst - - let rec update i f t = - match t with - | [] -> cons i (f zero_num) [] - | (k,v)::l -> - match Pervasives.compare i k with - | 0 -> cons k (f v) l - | -1 -> cons i (f zero_num) t - | 1 -> (k,v) ::(update i f l) - | _ -> failwith "compare_num" - - let rec set i n t = - match t with - | [] -> cons i n [] - | (k,v)::l -> - match Pervasives.compare i k with - | 0 -> cons k n l - | -1 -> cons i n t - | 1 -> (k,v) :: (set i n l) - | _ -> failwith "compare_num" - - let gcd m = - let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in - if Big_int.compare_big_int res Big_int.zero_big_int = 0 - then Big_int.unit_big_int else res - - let rec mul z t = - match z with - | Int 0 -> [] - | Int 1 -> t - | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t - - let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical - [ - (fun () -> Pervasives.compare (fst x) (fst y)); - (fun () -> compare_num (snd x) (snd y))]) - - (** [tail v vect] returns - - [None] if [v] is not a variable of the vector [vect] - - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] - and [rst] is the remaining of the vector - We exploit that vectors are ordered lists - *) - let rec tail (v:var) (vect:t) = - match vect with - | [] -> None - | (v',vl)::vect' -> - match Pervasives.compare v' v with - | 0 -> Some (vl,vect) (* Ok, found *) - | -1 -> tail v vect' (* Might be in the tail *) - | _ -> None (* Hopeless *) - - let get v vect = - match tail v vect with - | None -> None - | Some(vl,_) -> Some vl - - - let rec fresh v = - match v with - | [] -> 1 - | [v,_] -> v + 1 - | _::v -> fresh v - - end -open Vect - (** Implementation of intervals *) module Itv = struct @@ -203,11 +80,11 @@ let in_bound bnd v = | Some a , None -> a <=/ v | Some a , Some b -> a <=/ v && v <=/ b + end open Itv type vector = Vect.t -type cstr = { coeffs : vector ; bound : interval } (** 'cstr' is the type of constraints. {coeffs = v ; bound = (l,r) } models the constraints l <= v <= r **) @@ -275,10 +152,6 @@ let pp_bound o = function let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r -let rec pp_list f o l = - match l with - | [] -> () - | e::l -> f o e ; output_string o ";" ; pp_list f o l let pp_iset o s = output_string o "{" ; @@ -366,12 +239,7 @@ let normalise_cstr vect cinfo = then{cinfo with bound = (map_option divn l , map_option divn r) } else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)}) -(** For compatibility, there an external representation of constraints *) - -type cstr_compat = {coeffs : vector ; op : op ; cst : num} -and op = |Eq | Ge - -let string_of_op = function Eq -> "=" | Ge -> ">=" +(** For compatibility, there is an external representation of constraints *) let eval_op = function @@ -653,7 +521,7 @@ let solve_sys black_v choose_eq choose_variable sys sys_l = let vars = choose_variable sys in try let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in - if debug then (Printf.printf "\nV : %i esimate %f\n" v est ; flush stdout) ; + if debug then (Printf.printf "\nV : %i estimate %f\n" v est ; flush stdout) ; let sys' = project v sys in solve_sys sys' ((v,sys)::sys_l) with Not_found -> (* we are done *) Inl (sys,sys_l) in @@ -666,7 +534,7 @@ let solve black_v choose_eq choose_variable cstrs = try let sys = load_system cstrs in -(* Printf.printf "solve :\n %a" pp_system sys.sys ; *) + if debug then Printf.printf "solve :\n %a" pp_system sys.sys ; solve_sys black_v choose_eq choose_variable sys [] with SystemContradiction prf -> Inr prf @@ -752,20 +620,33 @@ struct else if i < v then unroll_until v rl else (false,l) + let rec choose_simple_equation eqs = + match eqs with + | [] -> None + | (vect,a,prf,ln)::eqs -> + match vect with + | [i,_] -> Some (i,vect,a,prf,ln) + | _ -> choose_simple_equation eqs + + + let choose_primal_equation eqs sys_l = + (* Counts the number of equations refering to variable [v] -- + It looks like nb_cst is dead... + *) let is_primal_equation_var v = - List.fold_left (fun (nb_eq,nb_cst) (vect,info) -> + List.fold_left (fun nb_eq (vect,info) -> if fst (unroll_until v vect) - then if itv_point info.bound then (nb_eq + 1,nb_cst) else (nb_eq,nb_cst) - else (nb_eq,nb_cst)) (0,0) sys_l in + then if itv_point info.bound then nb_eq + 1 else nb_eq + else nb_eq) 0 sys_l in let rec find_var vect = match vect with | [] -> None | (i,_)::vect -> - let (nb_eq,nb_cst) = is_primal_equation_var i in - if nb_eq = 2 && nb_cst = 0 + let nb_eq = is_primal_equation_var i in + if nb_eq = 2 then Some i else find_var vect in let rec find_eq_var eqs = @@ -776,10 +657,9 @@ struct | None -> find_eq_var l | Some r -> Some (r,vect,a,prf,ln) in - - - find_eq_var eqs - + match choose_simple_equation eqs with + | None -> find_eq_var eqs + | Some res -> Some res @@ -848,7 +728,8 @@ struct try Some (bound_of_variable IMap.empty fresh s.sys) with - x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None + x when x <> Sys.Break -> + Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None let find_point cstrs = @@ -913,7 +794,8 @@ struct | None , _ | _ , None -> None | Some a , Some b -> if (sign_num a) * (sign_num b) = -1 - then Some (add (p1,abs_num a) (p2,abs_num b) , + then + Some (add (p1,abs_num a) (p2,abs_num b) , {coeffs = add (v1,abs_num a) (v2,abs_num b) ; op = add_op op1 op2 ; cst = n1 // (abs_num a) +/ n2 // (abs_num b) }) diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index c350ed0f..564126d2 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1,447 +1,2786 @@ +type __ = Obj.t +let __ = let rec f _ = Obj.repr f in Obj.repr f + (** val negb : bool -> bool **) let negb = function - | true -> false - | false -> true +| true -> false +| false -> true type nat = - | O - | S of nat +| O +| S of nat + +(** val fst : ('a1 * 'a2) -> 'a1 **) + +let fst = function +| x,y -> x + +(** val snd : ('a1 * 'a2) -> 'a2 **) + +let snd = function +| x,y -> y + +(** val app : 'a1 list -> 'a1 list -> 'a1 list **) + +let rec app l m = + match l with + | [] -> m + | a::l1 -> a::(app l1 m) type comparison = - | Eq - | Lt - | Gt +| Eq +| Lt +| Gt (** val compOpp : comparison -> comparison **) let compOpp = function - | Eq -> Eq - | Lt -> Gt - | Gt -> Lt +| Eq -> Eq +| Lt -> Gt +| Gt -> Lt -(** val plus : nat -> nat -> nat **) +type compareSpecT = +| CompEqT +| CompLtT +| CompGtT -let rec plus n0 m = - match n0 with - | O -> m - | S p -> S (plus p m) +(** val compareSpec2Type : comparison -> compareSpecT **) -(** val app : 'a1 list -> 'a1 list -> 'a1 list **) +let compareSpec2Type = function +| Eq -> CompEqT +| Lt -> CompLtT +| Gt -> CompGtT -let rec app l m = - match l with - | [] -> m - | a :: l1 -> a :: (app l1 m) +type 'a compSpecT = compareSpecT -(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) +(** val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT **) -let rec nth n0 l default = +let compSpec2Type x y c = + compareSpec2Type c + +type 'a sig0 = + 'a + (* singleton inductive, whose constructor was exist *) + +(** val plus : nat -> nat -> nat **) + +let rec plus n0 m = match n0 with - | O -> (match l with - | [] -> default - | x :: l' -> x) - | S m -> (match l with - | [] -> default - | x :: t0 -> nth m t0 default) + | O -> m + | S p -> S (plus p m) -(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) +(** val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) -let rec map f = function - | [] -> [] - | a :: t0 -> (f a) :: (map f t0) +let rec nat_iter n0 f x = + match n0 with + | O -> x + | S n' -> f (nat_iter n' f x) type positive = - | XI of positive - | XO of positive - | XH +| XI of positive +| XO of positive +| XH -(** val psucc : positive -> positive **) +type n = +| N0 +| Npos of positive -let rec psucc = function - | XI p -> XO (psucc p) +type z = +| Z0 +| Zpos of positive +| Zneg of positive + +module type TotalOrder' = + sig + type t + end + +module MakeOrderTac = + functor (O:TotalOrder') -> + struct + + end + +module MaxLogicalProperties = + functor (O:TotalOrder') -> + functor (M:sig + val max : O.t -> O.t -> O.t + end) -> + struct + module T = MakeOrderTac(O) + end + +module Pos = + struct + type t = positive + + (** val succ : positive -> positive **) + + let rec succ = function + | XI p -> XO (succ p) | XO p -> XI p | XH -> XO XH - -(** val pplus : positive -> positive -> positive **) - -let rec pplus x y = - match x with + + (** val add : positive -> positive -> positive **) + + let rec add x y = + match x with | XI p -> - (match y with - | XI q0 -> XO (pplus_carry p q0) - | XO q0 -> XI (pplus p q0) - | XH -> XO (psucc p)) + (match y with + | XI q0 -> XO (add_carry p q0) + | XO q0 -> XI (add p q0) + | XH -> XO (succ p)) | XO p -> - (match y with - | XI q0 -> XI (pplus p q0) - | XO q0 -> XO (pplus p q0) - | XH -> XI p) + (match y with + | XI q0 -> XI (add p q0) + | XO q0 -> XO (add p q0) + | XH -> XI p) | XH -> - (match y with - | XI q0 -> XO (psucc q0) - | XO q0 -> XI q0 - | XH -> XO XH) - -(** val pplus_carry : positive -> positive -> positive **) - -and pplus_carry x y = - match x with + (match y with + | XI q0 -> XO (succ q0) + | XO q0 -> XI q0 + | XH -> XO XH) + + (** val add_carry : positive -> positive -> positive **) + + and add_carry x y = + match x with | XI p -> - (match y with - | XI q0 -> XI (pplus_carry p q0) - | XO q0 -> XO (pplus_carry p q0) - | XH -> XI (psucc p)) + (match y with + | XI q0 -> XI (add_carry p q0) + | XO q0 -> XO (add_carry p q0) + | XH -> XI (succ p)) | XO p -> - (match y with - | XI q0 -> XO (pplus_carry p q0) - | XO q0 -> XI (pplus p q0) - | XH -> XO (psucc p)) + (match y with + | XI q0 -> XO (add_carry p q0) + | XO q0 -> XI (add p q0) + | XH -> XO (succ p)) | XH -> - (match y with - | XI q0 -> XI (psucc q0) - | XO q0 -> XO (psucc q0) - | XH -> XI XH) - -(** val p_of_succ_nat : nat -> positive **) - -let rec p_of_succ_nat = function - | O -> XH - | S x -> psucc (p_of_succ_nat x) - -(** val pdouble_minus_one : positive -> positive **) - -let rec pdouble_minus_one = function + (match y with + | XI q0 -> XI (succ q0) + | XO q0 -> XO (succ q0) + | XH -> XI XH) + + (** val pred_double : positive -> positive **) + + let rec pred_double = function | XI p -> XI (XO p) - | XO p -> XI (pdouble_minus_one p) + | XO p -> XI (pred_double p) | XH -> XH - -type positive_mask = + + (** val pred : positive -> positive **) + + let pred = function + | XI p -> XO p + | XO p -> pred_double p + | XH -> XH + + (** val pred_N : positive -> n **) + + let pred_N = function + | XI p -> Npos (XO p) + | XO p -> Npos (pred_double p) + | XH -> N0 + + type mask = | IsNul | IsPos of positive | IsNeg - -(** val pdouble_plus_one_mask : positive_mask -> positive_mask **) - -let pdouble_plus_one_mask = function + + (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) + + let mask_rect f f0 f1 = function + | IsNul -> f + | IsPos x -> f0 x + | IsNeg -> f1 + + (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) + + let mask_rec f f0 f1 = function + | IsNul -> f + | IsPos x -> f0 x + | IsNeg -> f1 + + (** val succ_double_mask : mask -> mask **) + + let succ_double_mask = function | IsNul -> IsPos XH | IsPos p -> IsPos (XI p) | IsNeg -> IsNeg - -(** val pdouble_mask : positive_mask -> positive_mask **) - -let pdouble_mask = function - | IsNul -> IsNul + + (** val double_mask : mask -> mask **) + + let double_mask = function | IsPos p -> IsPos (XO p) - | IsNeg -> IsNeg - -(** val pdouble_minus_two : positive -> positive_mask **) - -let pdouble_minus_two = function + | x0 -> x0 + + (** val double_pred_mask : positive -> mask **) + + let double_pred_mask = function | XI p -> IsPos (XO (XO p)) - | XO p -> IsPos (XO (pdouble_minus_one p)) + | XO p -> IsPos (XO (pred_double p)) | XH -> IsNul - -(** val pminus_mask : positive -> positive -> positive_mask **) - -let rec pminus_mask x y = - match x with + + (** val pred_mask : mask -> mask **) + + let pred_mask = function + | IsPos q0 -> + (match q0 with + | XH -> IsNul + | _ -> IsPos (pred q0)) + | _ -> IsNeg + + (** val sub_mask : positive -> positive -> mask **) + + let rec sub_mask x y = + match x with | XI p -> - (match y with - | XI q0 -> pdouble_mask (pminus_mask p q0) - | XO q0 -> pdouble_plus_one_mask (pminus_mask p q0) - | XH -> IsPos (XO p)) + (match y with + | XI q0 -> double_mask (sub_mask p q0) + | XO q0 -> succ_double_mask (sub_mask p q0) + | XH -> IsPos (XO p)) | XO p -> - (match y with - | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) - | XO q0 -> pdouble_mask (pminus_mask p q0) - | XH -> IsPos (pdouble_minus_one p)) - | XH -> (match y with - | XH -> IsNul - | _ -> IsNeg) - -(** val pminus_mask_carry : positive -> positive -> positive_mask **) - -and pminus_mask_carry x y = - match x with + (match y with + | XI q0 -> succ_double_mask (sub_mask_carry p q0) + | XO q0 -> double_mask (sub_mask p q0) + | XH -> IsPos (pred_double p)) + | XH -> + (match y with + | XH -> IsNul + | _ -> IsNeg) + + (** val sub_mask_carry : positive -> positive -> mask **) + + and sub_mask_carry x y = + match x with | XI p -> - (match y with - | XI q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) - | XO q0 -> pdouble_mask (pminus_mask p q0) - | XH -> IsPos (pdouble_minus_one p)) + (match y with + | XI q0 -> succ_double_mask (sub_mask_carry p q0) + | XO q0 -> double_mask (sub_mask p q0) + | XH -> IsPos (pred_double p)) | XO p -> - (match y with - | XI q0 -> pdouble_mask (pminus_mask_carry p q0) - | XO q0 -> pdouble_plus_one_mask (pminus_mask_carry p q0) - | XH -> pdouble_minus_two p) + (match y with + | XI q0 -> double_mask (sub_mask_carry p q0) + | XO q0 -> succ_double_mask (sub_mask_carry p q0) + | XH -> double_pred_mask p) | XH -> IsNeg - -(** val pminus : positive -> positive -> positive **) - -let pminus x y = - match pminus_mask x y with + + (** val sub : positive -> positive -> positive **) + + let sub x y = + match sub_mask x y with | IsPos z0 -> z0 | _ -> XH - -(** val pmult : positive -> positive -> positive **) - -let rec pmult x y = - match x with - | XI p -> pplus y (XO (pmult p y)) - | XO p -> XO (pmult p y) + + (** val mul : positive -> positive -> positive **) + + let rec mul x y = + match x with + | XI p -> add y (XO (mul p y)) + | XO p -> XO (mul p y) | XH -> y - -(** val pcompare : positive -> positive -> comparison -> comparison **) - -let rec pcompare x y r = - match x with + + (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) + + let rec iter n0 f x = + match n0 with + | XI n' -> f (iter n' f (iter n' f x)) + | XO n' -> iter n' f (iter n' f x) + | XH -> f x + + (** val pow : positive -> positive -> positive **) + + let pow x y = + iter y (mul x) XH + + (** val div2 : positive -> positive **) + + let div2 = function + | XI p2 -> p2 + | XO p2 -> p2 + | XH -> XH + + (** val div2_up : positive -> positive **) + + let div2_up = function + | XI p2 -> succ p2 + | XO p2 -> p2 + | XH -> XH + + (** val size_nat : positive -> nat **) + + let rec size_nat = function + | XI p2 -> S (size_nat p2) + | XO p2 -> S (size_nat p2) + | XH -> S O + + (** val size : positive -> positive **) + + let rec size = function + | XI p2 -> succ (size p2) + | XO p2 -> succ (size p2) + | XH -> XH + + (** val compare_cont : positive -> positive -> comparison -> comparison **) + + let rec compare_cont x y r = + match x with + | XI p -> + (match y with + | XI q0 -> compare_cont p q0 r + | XO q0 -> compare_cont p q0 Gt + | XH -> Gt) + | XO p -> + (match y with + | XI q0 -> compare_cont p q0 Lt + | XO q0 -> compare_cont p q0 r + | XH -> Gt) + | XH -> + (match y with + | XH -> r + | _ -> Lt) + + (** val compare : positive -> positive -> comparison **) + + let compare x y = + compare_cont x y Eq + + (** val min : positive -> positive -> positive **) + + let min p p' = + match compare p p' with + | Gt -> p' + | _ -> p + + (** val max : positive -> positive -> positive **) + + let max p p' = + match compare p p' with + | Gt -> p + | _ -> p' + + (** val eqb : positive -> positive -> bool **) + + let rec eqb p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> eqb p2 q1 + | _ -> false) + | XO p2 -> + (match q0 with + | XO q1 -> eqb p2 q1 + | _ -> false) + | XH -> + (match q0 with + | XH -> true + | _ -> false) + + (** val leb : positive -> positive -> bool **) + + let leb x y = + match compare x y with + | Gt -> false + | _ -> true + + (** val ltb : positive -> positive -> bool **) + + let ltb x y = + match compare x y with + | Lt -> true + | _ -> false + + (** val sqrtrem_step : + (positive -> positive) -> (positive -> positive) -> (positive * mask) + -> positive * mask **) + + let sqrtrem_step f g = function + | s,y -> + (match y with + | IsPos r -> + let s' = XI (XO s) in + let r' = g (f r) in + if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') + | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) + + (** val sqrtrem : positive -> positive * mask **) + + let rec sqrtrem = function + | XI p2 -> + (match p2 with + | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) + | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) + | XH -> XH,(IsPos (XO XH))) + | XO p2 -> + (match p2 with + | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) + | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) + | XH -> XH,(IsPos XH)) + | XH -> XH,IsNul + + (** val sqrt : positive -> positive **) + + let sqrt p = + fst (sqrtrem p) + + (** val gcdn : nat -> positive -> positive -> positive **) + + let rec gcdn n0 a b = + match n0 with + | O -> XH + | S n1 -> + (match a with + | XI a' -> + (match b with + | XI b' -> + (match compare a' b' with + | Eq -> a + | Lt -> gcdn n1 (sub b' a') a + | Gt -> gcdn n1 (sub a' b') b) + | XO b0 -> gcdn n1 a b0 + | XH -> XH) + | XO a0 -> + (match b with + | XI p -> gcdn n1 a0 b + | XO b0 -> XO (gcdn n1 a0 b0) + | XH -> XH) + | XH -> XH) + + (** val gcd : positive -> positive -> positive **) + + let gcd a b = + gcdn (plus (size_nat a) (size_nat b)) a b + + (** val ggcdn : + nat -> positive -> positive -> positive * (positive * positive) **) + + let rec ggcdn n0 a b = + match n0 with + | O -> XH,(a,b) + | S n1 -> + (match a with + | XI a' -> + (match b with + | XI b' -> + (match compare a' b' with + | Eq -> a,(XH,XH) + | Lt -> + let g,p = ggcdn n1 (sub b' a') a in + let ba,aa = p in g,(aa,(add aa (XO ba))) + | Gt -> + let g,p = ggcdn n1 (sub a' b') b in + let ab,bb = p in g,((add bb (XO ab)),bb)) + | XO b0 -> + let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) + | XH -> XH,(a,XH)) + | XO a0 -> + (match b with + | XI p -> + let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) + | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p + | XH -> XH,(a,XH)) + | XH -> XH,(XH,b)) + + (** val ggcd : positive -> positive -> positive * (positive * positive) **) + + let ggcd a b = + ggcdn (plus (size_nat a) (size_nat b)) a b + + (** val coq_Nsucc_double : n -> n **) + + let coq_Nsucc_double = function + | N0 -> Npos XH + | Npos p -> Npos (XI p) + + (** val coq_Ndouble : n -> n **) + + let coq_Ndouble = function + | N0 -> N0 + | Npos p -> Npos (XO p) + + (** val coq_lor : positive -> positive -> positive **) + + let rec coq_lor p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> XI (coq_lor p2 q1) + | XO q1 -> XI (coq_lor p2 q1) + | XH -> p) + | XO p2 -> + (match q0 with + | XI q1 -> XI (coq_lor p2 q1) + | XO q1 -> XO (coq_lor p2 q1) + | XH -> XI p2) + | XH -> + (match q0 with + | XO q1 -> XI q1 + | _ -> q0) + + (** val coq_land : positive -> positive -> n **) + + let rec coq_land p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> coq_Nsucc_double (coq_land p2 q1) + | XO q1 -> coq_Ndouble (coq_land p2 q1) + | XH -> Npos XH) + | XO p2 -> + (match q0 with + | XI q1 -> coq_Ndouble (coq_land p2 q1) + | XO q1 -> coq_Ndouble (coq_land p2 q1) + | XH -> N0) + | XH -> + (match q0 with + | XO q1 -> N0 + | _ -> Npos XH) + + (** val ldiff : positive -> positive -> n **) + + let rec ldiff p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> coq_Ndouble (ldiff p2 q1) + | XO q1 -> coq_Nsucc_double (ldiff p2 q1) + | XH -> Npos (XO p2)) + | XO p2 -> + (match q0 with + | XI q1 -> coq_Ndouble (ldiff p2 q1) + | XO q1 -> coq_Ndouble (ldiff p2 q1) + | XH -> Npos p) + | XH -> + (match q0 with + | XO q1 -> Npos XH + | _ -> N0) + + (** val coq_lxor : positive -> positive -> n **) + + let rec coq_lxor p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> coq_Ndouble (coq_lxor p2 q1) + | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1) + | XH -> Npos (XO p2)) + | XO p2 -> + (match q0 with + | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1) + | XO q1 -> coq_Ndouble (coq_lxor p2 q1) + | XH -> Npos (XI p2)) + | XH -> + (match q0 with + | XI q1 -> Npos (XO q1) + | XO q1 -> Npos (XI q1) + | XH -> N0) + + (** val shiftl_nat : positive -> nat -> positive **) + + let shiftl_nat p n0 = + nat_iter n0 (fun x -> XO x) p + + (** val shiftr_nat : positive -> nat -> positive **) + + let shiftr_nat p n0 = + nat_iter n0 div2 p + + (** val shiftl : positive -> n -> positive **) + + let shiftl p = function + | N0 -> p + | Npos n1 -> iter n1 (fun x -> XO x) p + + (** val shiftr : positive -> n -> positive **) + + let shiftr p = function + | N0 -> p + | Npos n1 -> iter n1 div2 p + + (** val testbit_nat : positive -> nat -> bool **) + + let rec testbit_nat p n0 = + match p with + | XI p2 -> + (match n0 with + | O -> true + | S n' -> testbit_nat p2 n') + | XO p2 -> + (match n0 with + | O -> false + | S n' -> testbit_nat p2 n') + | XH -> + (match n0 with + | O -> true + | S n1 -> false) + + (** val testbit : positive -> n -> bool **) + + let rec testbit p n0 = + match p with + | XI p2 -> + (match n0 with + | N0 -> true + | Npos n1 -> testbit p2 (pred_N n1)) + | XO p2 -> + (match n0 with + | N0 -> false + | Npos n1 -> testbit p2 (pred_N n1)) + | XH -> + (match n0 with + | N0 -> true + | Npos p2 -> false) + + (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) + + let rec iter_op op p a = + match p with + | XI p2 -> op a (iter_op op p2 (op a a)) + | XO p2 -> iter_op op p2 (op a a) + | XH -> a + + (** val to_nat : positive -> nat **) + + let to_nat x = + iter_op plus x (S O) + + (** val of_nat : nat -> positive **) + + let rec of_nat = function + | O -> XH + | S x -> + (match x with + | O -> XH + | S n1 -> succ (of_nat x)) + + (** val of_succ_nat : nat -> positive **) + + let rec of_succ_nat = function + | O -> XH + | S x -> succ (of_succ_nat x) + end + +module Coq_Pos = + struct + module Coq__1 = struct + type t = positive + end + type t = Coq__1.t + + (** val succ : positive -> positive **) + + let rec succ = function + | XI p -> XO (succ p) + | XO p -> XI p + | XH -> XO XH + + (** val add : positive -> positive -> positive **) + + let rec add x y = + match x with + | XI p -> + (match y with + | XI q0 -> XO (add_carry p q0) + | XO q0 -> XI (add p q0) + | XH -> XO (succ p)) + | XO p -> + (match y with + | XI q0 -> XI (add p q0) + | XO q0 -> XO (add p q0) + | XH -> XI p) + | XH -> + (match y with + | XI q0 -> XO (succ q0) + | XO q0 -> XI q0 + | XH -> XO XH) + + (** val add_carry : positive -> positive -> positive **) + + and add_carry x y = + match x with + | XI p -> + (match y with + | XI q0 -> XI (add_carry p q0) + | XO q0 -> XO (add_carry p q0) + | XH -> XI (succ p)) + | XO p -> + (match y with + | XI q0 -> XO (add_carry p q0) + | XO q0 -> XI (add p q0) + | XH -> XO (succ p)) + | XH -> + (match y with + | XI q0 -> XI (succ q0) + | XO q0 -> XO (succ q0) + | XH -> XI XH) + + (** val pred_double : positive -> positive **) + + let rec pred_double = function + | XI p -> XI (XO p) + | XO p -> XI (pred_double p) + | XH -> XH + + (** val pred : positive -> positive **) + + let pred = function + | XI p -> XO p + | XO p -> pred_double p + | XH -> XH + + (** val pred_N : positive -> n **) + + let pred_N = function + | XI p -> Npos (XO p) + | XO p -> Npos (pred_double p) + | XH -> N0 + + type mask = Pos.mask = + | IsNul + | IsPos of positive + | IsNeg + + (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) + + let mask_rect f f0 f1 = function + | IsNul -> f + | IsPos x -> f0 x + | IsNeg -> f1 + + (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) + + let mask_rec f f0 f1 = function + | IsNul -> f + | IsPos x -> f0 x + | IsNeg -> f1 + + (** val succ_double_mask : mask -> mask **) + + let succ_double_mask = function + | IsNul -> IsPos XH + | IsPos p -> IsPos (XI p) + | IsNeg -> IsNeg + + (** val double_mask : mask -> mask **) + + let double_mask = function + | IsPos p -> IsPos (XO p) + | x0 -> x0 + + (** val double_pred_mask : positive -> mask **) + + let double_pred_mask = function + | XI p -> IsPos (XO (XO p)) + | XO p -> IsPos (XO (pred_double p)) + | XH -> IsNul + + (** val pred_mask : mask -> mask **) + + let pred_mask = function + | IsPos q0 -> + (match q0 with + | XH -> IsNul + | _ -> IsPos (pred q0)) + | _ -> IsNeg + + (** val sub_mask : positive -> positive -> mask **) + + let rec sub_mask x y = + match x with + | XI p -> + (match y with + | XI q0 -> double_mask (sub_mask p q0) + | XO q0 -> succ_double_mask (sub_mask p q0) + | XH -> IsPos (XO p)) + | XO p -> + (match y with + | XI q0 -> succ_double_mask (sub_mask_carry p q0) + | XO q0 -> double_mask (sub_mask p q0) + | XH -> IsPos (pred_double p)) + | XH -> + (match y with + | XH -> IsNul + | _ -> IsNeg) + + (** val sub_mask_carry : positive -> positive -> mask **) + + and sub_mask_carry x y = + match x with | XI p -> - (match y with - | XI q0 -> pcompare p q0 r - | XO q0 -> pcompare p q0 Gt - | XH -> Gt) + (match y with + | XI q0 -> succ_double_mask (sub_mask_carry p q0) + | XO q0 -> double_mask (sub_mask p q0) + | XH -> IsPos (pred_double p)) | XO p -> - (match y with - | XI q0 -> pcompare p q0 Lt - | XO q0 -> pcompare p q0 r - | XH -> Gt) - | XH -> (match y with - | XH -> r - | _ -> Lt) - -(** val psize : positive -> nat **) - -let rec psize = function - | XI p2 -> S (psize p2) - | XO p2 -> S (psize p2) + (match y with + | XI q0 -> double_mask (sub_mask_carry p q0) + | XO q0 -> succ_double_mask (sub_mask_carry p q0) + | XH -> double_pred_mask p) + | XH -> IsNeg + + (** val sub : positive -> positive -> positive **) + + let sub x y = + match sub_mask x y with + | IsPos z0 -> z0 + | _ -> XH + + (** val mul : positive -> positive -> positive **) + + let rec mul x y = + match x with + | XI p -> add y (XO (mul p y)) + | XO p -> XO (mul p y) + | XH -> y + + (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) + + let rec iter n0 f x = + match n0 with + | XI n' -> f (iter n' f (iter n' f x)) + | XO n' -> iter n' f (iter n' f x) + | XH -> f x + + (** val pow : positive -> positive -> positive **) + + let pow x y = + iter y (mul x) XH + + (** val div2 : positive -> positive **) + + let div2 = function + | XI p2 -> p2 + | XO p2 -> p2 + | XH -> XH + + (** val div2_up : positive -> positive **) + + let div2_up = function + | XI p2 -> succ p2 + | XO p2 -> p2 + | XH -> XH + + (** val size_nat : positive -> nat **) + + let rec size_nat = function + | XI p2 -> S (size_nat p2) + | XO p2 -> S (size_nat p2) | XH -> S O - -type n = - | N0 - | Npos of positive + + (** val size : positive -> positive **) + + let rec size = function + | XI p2 -> succ (size p2) + | XO p2 -> succ (size p2) + | XH -> XH + + (** val compare_cont : positive -> positive -> comparison -> comparison **) + + let rec compare_cont x y r = + match x with + | XI p -> + (match y with + | XI q0 -> compare_cont p q0 r + | XO q0 -> compare_cont p q0 Gt + | XH -> Gt) + | XO p -> + (match y with + | XI q0 -> compare_cont p q0 Lt + | XO q0 -> compare_cont p q0 r + | XH -> Gt) + | XH -> + (match y with + | XH -> r + | _ -> Lt) + + (** val compare : positive -> positive -> comparison **) + + let compare x y = + compare_cont x y Eq + + (** val min : positive -> positive -> positive **) + + let min p p' = + match compare p p' with + | Gt -> p' + | _ -> p + + (** val max : positive -> positive -> positive **) + + let max p p' = + match compare p p' with + | Gt -> p + | _ -> p' + + (** val eqb : positive -> positive -> bool **) + + let rec eqb p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> eqb p2 q1 + | _ -> false) + | XO p2 -> + (match q0 with + | XO q1 -> eqb p2 q1 + | _ -> false) + | XH -> + (match q0 with + | XH -> true + | _ -> false) + + (** val leb : positive -> positive -> bool **) + + let leb x y = + match compare x y with + | Gt -> false + | _ -> true + + (** val ltb : positive -> positive -> bool **) + + let ltb x y = + match compare x y with + | Lt -> true + | _ -> false + + (** val sqrtrem_step : + (positive -> positive) -> (positive -> positive) -> (positive * mask) + -> positive * mask **) + + let sqrtrem_step f g = function + | s,y -> + (match y with + | IsPos r -> + let s' = XI (XO s) in + let r' = g (f r) in + if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') + | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) + + (** val sqrtrem : positive -> positive * mask **) + + let rec sqrtrem = function + | XI p2 -> + (match p2 with + | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) + | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) + | XH -> XH,(IsPos (XO XH))) + | XO p2 -> + (match p2 with + | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) + | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) + | XH -> XH,(IsPos XH)) + | XH -> XH,IsNul + + (** val sqrt : positive -> positive **) + + let sqrt p = + fst (sqrtrem p) + + (** val gcdn : nat -> positive -> positive -> positive **) + + let rec gcdn n0 a b = + match n0 with + | O -> XH + | S n1 -> + (match a with + | XI a' -> + (match b with + | XI b' -> + (match compare a' b' with + | Eq -> a + | Lt -> gcdn n1 (sub b' a') a + | Gt -> gcdn n1 (sub a' b') b) + | XO b0 -> gcdn n1 a b0 + | XH -> XH) + | XO a0 -> + (match b with + | XI p -> gcdn n1 a0 b + | XO b0 -> XO (gcdn n1 a0 b0) + | XH -> XH) + | XH -> XH) + + (** val gcd : positive -> positive -> positive **) + + let gcd a b = + gcdn (plus (size_nat a) (size_nat b)) a b + + (** val ggcdn : + nat -> positive -> positive -> positive * (positive * positive) **) + + let rec ggcdn n0 a b = + match n0 with + | O -> XH,(a,b) + | S n1 -> + (match a with + | XI a' -> + (match b with + | XI b' -> + (match compare a' b' with + | Eq -> a,(XH,XH) + | Lt -> + let g,p = ggcdn n1 (sub b' a') a in + let ba,aa = p in g,(aa,(add aa (XO ba))) + | Gt -> + let g,p = ggcdn n1 (sub a' b') b in + let ab,bb = p in g,((add bb (XO ab)),bb)) + | XO b0 -> + let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) + | XH -> XH,(a,XH)) + | XO a0 -> + (match b with + | XI p -> + let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) + | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p + | XH -> XH,(a,XH)) + | XH -> XH,(XH,b)) + + (** val ggcd : positive -> positive -> positive * (positive * positive) **) + + let ggcd a b = + ggcdn (plus (size_nat a) (size_nat b)) a b + + (** val coq_Nsucc_double : n -> n **) + + let coq_Nsucc_double = function + | N0 -> Npos XH + | Npos p -> Npos (XI p) + + (** val coq_Ndouble : n -> n **) + + let coq_Ndouble = function + | N0 -> N0 + | Npos p -> Npos (XO p) + + (** val coq_lor : positive -> positive -> positive **) + + let rec coq_lor p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> XI (coq_lor p2 q1) + | XO q1 -> XI (coq_lor p2 q1) + | XH -> p) + | XO p2 -> + (match q0 with + | XI q1 -> XI (coq_lor p2 q1) + | XO q1 -> XO (coq_lor p2 q1) + | XH -> XI p2) + | XH -> + (match q0 with + | XO q1 -> XI q1 + | _ -> q0) + + (** val coq_land : positive -> positive -> n **) + + let rec coq_land p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> coq_Nsucc_double (coq_land p2 q1) + | XO q1 -> coq_Ndouble (coq_land p2 q1) + | XH -> Npos XH) + | XO p2 -> + (match q0 with + | XI q1 -> coq_Ndouble (coq_land p2 q1) + | XO q1 -> coq_Ndouble (coq_land p2 q1) + | XH -> N0) + | XH -> + (match q0 with + | XO q1 -> N0 + | _ -> Npos XH) + + (** val ldiff : positive -> positive -> n **) + + let rec ldiff p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> coq_Ndouble (ldiff p2 q1) + | XO q1 -> coq_Nsucc_double (ldiff p2 q1) + | XH -> Npos (XO p2)) + | XO p2 -> + (match q0 with + | XI q1 -> coq_Ndouble (ldiff p2 q1) + | XO q1 -> coq_Ndouble (ldiff p2 q1) + | XH -> Npos p) + | XH -> + (match q0 with + | XO q1 -> Npos XH + | _ -> N0) + + (** val coq_lxor : positive -> positive -> n **) + + let rec coq_lxor p q0 = + match p with + | XI p2 -> + (match q0 with + | XI q1 -> coq_Ndouble (coq_lxor p2 q1) + | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1) + | XH -> Npos (XO p2)) + | XO p2 -> + (match q0 with + | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1) + | XO q1 -> coq_Ndouble (coq_lxor p2 q1) + | XH -> Npos (XI p2)) + | XH -> + (match q0 with + | XI q1 -> Npos (XO q1) + | XO q1 -> Npos (XI q1) + | XH -> N0) + + (** val shiftl_nat : positive -> nat -> positive **) + + let shiftl_nat p n0 = + nat_iter n0 (fun x -> XO x) p + + (** val shiftr_nat : positive -> nat -> positive **) + + let shiftr_nat p n0 = + nat_iter n0 div2 p + + (** val shiftl : positive -> n -> positive **) + + let shiftl p = function + | N0 -> p + | Npos n1 -> iter n1 (fun x -> XO x) p + + (** val shiftr : positive -> n -> positive **) + + let shiftr p = function + | N0 -> p + | Npos n1 -> iter n1 div2 p + + (** val testbit_nat : positive -> nat -> bool **) + + let rec testbit_nat p n0 = + match p with + | XI p2 -> + (match n0 with + | O -> true + | S n' -> testbit_nat p2 n') + | XO p2 -> + (match n0 with + | O -> false + | S n' -> testbit_nat p2 n') + | XH -> + (match n0 with + | O -> true + | S n1 -> false) + + (** val testbit : positive -> n -> bool **) + + let rec testbit p n0 = + match p with + | XI p2 -> + (match n0 with + | N0 -> true + | Npos n1 -> testbit p2 (pred_N n1)) + | XO p2 -> + (match n0 with + | N0 -> false + | Npos n1 -> testbit p2 (pred_N n1)) + | XH -> + (match n0 with + | N0 -> true + | Npos p2 -> false) + + (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) + + let rec iter_op op p a = + match p with + | XI p2 -> op a (iter_op op p2 (op a a)) + | XO p2 -> iter_op op p2 (op a a) + | XH -> a + + (** val to_nat : positive -> nat **) + + let to_nat x = + iter_op plus x (S O) + + (** val of_nat : nat -> positive **) + + let rec of_nat = function + | O -> XH + | S x -> + (match x with + | O -> XH + | S n1 -> succ (of_nat x)) + + (** val of_succ_nat : nat -> positive **) + + let rec of_succ_nat = function + | O -> XH + | S x -> succ (of_succ_nat x) + + (** val eq_dec : positive -> positive -> bool **) + + let rec eq_dec p y0 = + match p with + | XI p2 -> + (match y0 with + | XI p3 -> eq_dec p2 p3 + | _ -> false) + | XO p2 -> + (match y0 with + | XO p3 -> eq_dec p2 p3 + | _ -> false) + | XH -> + (match y0 with + | XH -> true + | _ -> false) + + (** val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) + + let rec peano_rect a f p = + let f2 = peano_rect (f XH a) (fun p2 x -> f (succ (XO p2)) (f (XO p2) x)) + in + (match p with + | XI q0 -> f (XO q0) (f2 q0) + | XO q0 -> f2 q0 + | XH -> a) + + (** val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) + + let peano_rec = + peano_rect + + type coq_PeanoView = + | PeanoOne + | PeanoSucc of positive * coq_PeanoView + + (** val coq_PeanoView_rect : + 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> + coq_PeanoView -> 'a1 **) + + let rec coq_PeanoView_rect f f0 p = function + | PeanoOne -> f + | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rect f f0 p3 p4) + + (** val coq_PeanoView_rec : + 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> + coq_PeanoView -> 'a1 **) + + let rec coq_PeanoView_rec f f0 p = function + | PeanoOne -> f + | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rec f f0 p3 p4) + + (** val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView **) + + let rec peanoView_xO p = function + | PeanoOne -> PeanoSucc (XH, PeanoOne) + | PeanoSucc (p2, q1) -> + PeanoSucc ((succ (XO p2)), (PeanoSucc ((XO p2), (peanoView_xO p2 q1)))) + + (** val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView **) + + let rec peanoView_xI p = function + | PeanoOne -> PeanoSucc ((succ XH), (PeanoSucc (XH, PeanoOne))) + | PeanoSucc (p2, q1) -> + PeanoSucc ((succ (XI p2)), (PeanoSucc ((XI p2), (peanoView_xI p2 q1)))) + + (** val peanoView : positive -> coq_PeanoView **) + + let rec peanoView = function + | XI p2 -> peanoView_xI p2 (peanoView p2) + | XO p2 -> peanoView_xO p2 (peanoView p2) + | XH -> PeanoOne + + (** val coq_PeanoView_iter : + 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **) + + let rec coq_PeanoView_iter a f p = function + | PeanoOne -> a + | PeanoSucc (p2, q1) -> f p2 (coq_PeanoView_iter a f p2 q1) + + (** val switch_Eq : comparison -> comparison -> comparison **) + + let switch_Eq c = function + | Eq -> c + | x -> x + + (** val mask2cmp : mask -> comparison **) + + let mask2cmp = function + | IsNul -> Eq + | IsPos p2 -> Gt + | IsNeg -> Lt + + module T = + struct + + end + + module ORev = + struct + type t = Coq__1.t + end + + module MRev = + struct + (** val max : t -> t -> t **) + + let max x y = + min y x + end + + module MPRev = MaxLogicalProperties(ORev)(MRev) + + module P = + struct + (** val max_case_strong : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let max_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat n0 (max n0 m) __ (hl __) + | _ -> compat m (max n0 m) __ (hr __)) + + (** val max_case : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 x1 = + max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val max_dec : t -> t -> bool **) + + let max_dec n0 m = + max_case n0 m (fun x y _ h0 -> h0) true false + + (** val min_case_strong : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let min_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat m (min n0 m) __ (hr __) + | _ -> compat n0 (min n0 m) __ (hl __)) + + (** val min_case : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 x1 = + min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val min_dec : t -> t -> bool **) + + let min_dec n0 m = + min_case n0 m (fun x y _ h0 -> h0) true false + end + + (** val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let max_case_strong n0 m x x0 = + P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 = + max_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val max_dec : t -> t -> bool **) + + let max_dec = + P.max_dec + + (** val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let min_case_strong n0 m x x0 = + P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 = + min_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val min_dec : t -> t -> bool **) + + let min_dec = + P.min_dec + end + +module N = + struct + type t = n + + (** val zero : n **) + + let zero = + N0 + + (** val one : n **) + + let one = + Npos XH + + (** val two : n **) + + let two = + Npos (XO XH) + + (** val succ_double : n -> n **) + + let succ_double = function + | N0 -> Npos XH + | Npos p -> Npos (XI p) + + (** val double : n -> n **) + + let double = function + | N0 -> N0 + | Npos p -> Npos (XO p) + + (** val succ : n -> n **) + + let succ = function + | N0 -> Npos XH + | Npos p -> Npos (Coq_Pos.succ p) + + (** val pred : n -> n **) + + let pred = function + | N0 -> N0 + | Npos p -> Coq_Pos.pred_N p + + (** val succ_pos : n -> positive **) + + let succ_pos = function + | N0 -> XH + | Npos p -> Coq_Pos.succ p + + (** val add : n -> n -> n **) + + let add n0 m = + match n0 with + | N0 -> m + | Npos p -> + (match m with + | N0 -> n0 + | Npos q0 -> Npos (Coq_Pos.add p q0)) + + (** val sub : n -> n -> n **) + + let sub n0 m = + match n0 with + | N0 -> N0 + | Npos n' -> + (match m with + | N0 -> n0 + | Npos m' -> + (match Coq_Pos.sub_mask n' m' with + | Coq_Pos.IsPos p -> Npos p + | _ -> N0)) + + (** val mul : n -> n -> n **) + + let mul n0 m = + match n0 with + | N0 -> N0 + | Npos p -> + (match m with + | N0 -> N0 + | Npos q0 -> Npos (Coq_Pos.mul p q0)) + + (** val compare : n -> n -> comparison **) + + let compare n0 m = + match n0 with + | N0 -> + (match m with + | N0 -> Eq + | Npos m' -> Lt) + | Npos n' -> + (match m with + | N0 -> Gt + | Npos m' -> Coq_Pos.compare n' m') + + (** val eqb : n -> n -> bool **) + + let rec eqb n0 m = + match n0 with + | N0 -> + (match m with + | N0 -> true + | Npos p -> false) + | Npos p -> + (match m with + | N0 -> false + | Npos q0 -> Coq_Pos.eqb p q0) + + (** val leb : n -> n -> bool **) + + let leb x y = + match compare x y with + | Gt -> false + | _ -> true + + (** val ltb : n -> n -> bool **) + + let ltb x y = + match compare x y with + | Lt -> true + | _ -> false + + (** val min : n -> n -> n **) + + let min n0 n' = + match compare n0 n' with + | Gt -> n' + | _ -> n0 + + (** val max : n -> n -> n **) + + let max n0 n' = + match compare n0 n' with + | Gt -> n0 + | _ -> n' + + (** val div2 : n -> n **) + + let div2 = function + | N0 -> N0 + | Npos p2 -> + (match p2 with + | XI p -> Npos p + | XO p -> Npos p + | XH -> N0) + + (** val even : n -> bool **) + + let even = function + | N0 -> true + | Npos p -> + (match p with + | XO p2 -> true + | _ -> false) + + (** val odd : n -> bool **) + + let odd n0 = + negb (even n0) + + (** val pow : n -> n -> n **) + + let pow n0 = function + | N0 -> Npos XH + | Npos p2 -> + (match n0 with + | N0 -> N0 + | Npos q0 -> Npos (Coq_Pos.pow q0 p2)) + + (** val log2 : n -> n **) + + let log2 = function + | N0 -> N0 + | Npos p2 -> + (match p2 with + | XI p -> Npos (Coq_Pos.size p) + | XO p -> Npos (Coq_Pos.size p) + | XH -> N0) + + (** val size : n -> n **) + + let size = function + | N0 -> N0 + | Npos p -> Npos (Coq_Pos.size p) + + (** val size_nat : n -> nat **) + + let size_nat = function + | N0 -> O + | Npos p -> Coq_Pos.size_nat p + + (** val pos_div_eucl : positive -> n -> n * n **) + + let rec pos_div_eucl a b = + match a with + | XI a' -> + let q0,r = pos_div_eucl a' b in + let r' = succ_double r in + if leb b r' then (succ_double q0),(sub r' b) else (double q0),r' + | XO a' -> + let q0,r = pos_div_eucl a' b in + let r' = double r in + if leb b r' then (succ_double q0),(sub r' b) else (double q0),r' + | XH -> + (match b with + | N0 -> N0,(Npos XH) + | Npos p -> + (match p with + | XH -> (Npos XH),N0 + | _ -> N0,(Npos XH))) + + (** val div_eucl : n -> n -> n * n **) + + let div_eucl a b = + match a with + | N0 -> N0,N0 + | Npos na -> + (match b with + | N0 -> N0,a + | Npos p -> pos_div_eucl na b) + + (** val div : n -> n -> n **) + + let div a b = + fst (div_eucl a b) + + (** val modulo : n -> n -> n **) + + let modulo a b = + snd (div_eucl a b) + + (** val gcd : n -> n -> n **) + + let gcd a b = + match a with + | N0 -> b + | Npos p -> + (match b with + | N0 -> a + | Npos q0 -> Npos (Coq_Pos.gcd p q0)) + + (** val ggcd : n -> n -> n * (n * n) **) + + let ggcd a b = + match a with + | N0 -> b,(N0,(Npos XH)) + | Npos p -> + (match b with + | N0 -> a,((Npos XH),N0) + | Npos q0 -> + let g,p2 = Coq_Pos.ggcd p q0 in + let aa,bb = p2 in (Npos g),((Npos aa),(Npos bb))) + + (** val sqrtrem : n -> n * n **) + + let sqrtrem = function + | N0 -> N0,N0 + | Npos p -> + let s,m = Coq_Pos.sqrtrem p in + (match m with + | Coq_Pos.IsPos r -> (Npos s),(Npos r) + | _ -> (Npos s),N0) + + (** val sqrt : n -> n **) + + let sqrt = function + | N0 -> N0 + | Npos p -> Npos (Coq_Pos.sqrt p) + + (** val coq_lor : n -> n -> n **) + + let coq_lor n0 m = + match n0 with + | N0 -> m + | Npos p -> + (match m with + | N0 -> n0 + | Npos q0 -> Npos (Coq_Pos.coq_lor p q0)) + + (** val coq_land : n -> n -> n **) + + let coq_land n0 m = + match n0 with + | N0 -> N0 + | Npos p -> + (match m with + | N0 -> N0 + | Npos q0 -> Coq_Pos.coq_land p q0) + + (** val ldiff : n -> n -> n **) + + let rec ldiff n0 m = + match n0 with + | N0 -> N0 + | Npos p -> + (match m with + | N0 -> n0 + | Npos q0 -> Coq_Pos.ldiff p q0) + + (** val coq_lxor : n -> n -> n **) + + let coq_lxor n0 m = + match n0 with + | N0 -> m + | Npos p -> + (match m with + | N0 -> n0 + | Npos q0 -> Coq_Pos.coq_lxor p q0) + + (** val shiftl_nat : n -> nat -> n **) + + let shiftl_nat a n0 = + nat_iter n0 double a + + (** val shiftr_nat : n -> nat -> n **) + + let shiftr_nat a n0 = + nat_iter n0 div2 a + + (** val shiftl : n -> n -> n **) + + let shiftl a n0 = + match a with + | N0 -> N0 + | Npos a0 -> Npos (Coq_Pos.shiftl a0 n0) + + (** val shiftr : n -> n -> n **) + + let shiftr a = function + | N0 -> a + | Npos p -> Coq_Pos.iter p div2 a + + (** val testbit_nat : n -> nat -> bool **) + + let testbit_nat = function + | N0 -> (fun x -> false) + | Npos p -> Coq_Pos.testbit_nat p + + (** val testbit : n -> n -> bool **) + + let testbit a n0 = + match a with + | N0 -> false + | Npos p -> Coq_Pos.testbit p n0 + + (** val to_nat : n -> nat **) + + let to_nat = function + | N0 -> O + | Npos p -> Coq_Pos.to_nat p + + (** val of_nat : nat -> n **) + + let of_nat = function + | O -> N0 + | S n' -> Npos (Coq_Pos.of_succ_nat n') + + (** val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) + + let iter n0 f x = + match n0 with + | N0 -> x + | Npos p -> Coq_Pos.iter p f x + + (** val eq_dec : n -> n -> bool **) + + let eq_dec n0 m = + match n0 with + | N0 -> + (match m with + | N0 -> true + | Npos p -> false) + | Npos x -> + (match m with + | N0 -> false + | Npos p2 -> Coq_Pos.eq_dec x p2) + + (** val discr : n -> positive option **) + + let discr = function + | N0 -> None + | Npos p -> Some p + + (** val binary_rect : + 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let binary_rect f0 f2 fS2 n0 = + let f2' = fun p -> f2 (Npos p) in + let fS2' = fun p -> fS2 (Npos p) in + (match n0 with + | N0 -> f0 + | Npos p -> + let rec f = function + | XI p3 -> fS2' p3 (f p3) + | XO p3 -> f2' p3 (f p3) + | XH -> fS2 N0 f0 + in f p) + + (** val binary_rec : + 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let binary_rec = + binary_rect + + (** val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let peano_rect f0 f n0 = + let f' = fun p -> f (Npos p) in + (match n0 with + | N0 -> f0 + | Npos p -> Coq_Pos.peano_rect (f N0 f0) f' p) + + (** val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let peano_rec = + peano_rect + + module BootStrap = + struct + + end + + (** val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) + + let recursion x = + peano_rect x + + module OrderElts = + struct + type t = n + end + + module OrderTac = MakeOrderTac(OrderElts) + + module NZPowP = + struct + + end + + module NZSqrtP = + struct + + end + + (** val sqrt_up : n -> n **) + + let sqrt_up a = + match compare N0 a with + | Lt -> succ (sqrt (pred a)) + | _ -> N0 + + (** val log2_up : n -> n **) + + let log2_up a = + match compare (Npos XH) a with + | Lt -> succ (log2 (pred a)) + | _ -> N0 + + module NZDivP = + struct + + end + + (** val lcm : n -> n -> n **) + + let lcm a b = + mul a (div b (gcd a b)) + + (** val b2n : bool -> n **) + + let b2n = function + | true -> Npos XH + | false -> N0 + + (** val setbit : n -> n -> n **) + + let setbit a n0 = + coq_lor a (shiftl (Npos XH) n0) + + (** val clearbit : n -> n -> n **) + + let clearbit a n0 = + ldiff a (shiftl (Npos XH) n0) + + (** val ones : n -> n **) + + let ones n0 = + pred (shiftl (Npos XH) n0) + + (** val lnot : n -> n -> n **) + + let lnot a n0 = + coq_lxor a (ones n0) + + module T = + struct + + end + + module ORev = + struct + type t = n + end + + module MRev = + struct + (** val max : n -> n -> n **) + + let max x y = + min y x + end + + module MPRev = MaxLogicalProperties(ORev)(MRev) + + module P = + struct + (** val max_case_strong : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let max_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat n0 (max n0 m) __ (hl __) + | _ -> compat m (max n0 m) __ (hr __)) + + (** val max_case : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 x1 = + max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val max_dec : n -> n -> bool **) + + let max_dec n0 m = + max_case n0 m (fun x y _ h0 -> h0) true false + + (** val min_case_strong : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let min_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat m (min n0 m) __ (hr __) + | _ -> compat n0 (min n0 m) __ (hl __)) + + (** val min_case : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 x1 = + min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val min_dec : n -> n -> bool **) + + let min_dec n0 m = + min_case n0 m (fun x y _ h0 -> h0) true false + end + + (** val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let max_case_strong n0 m x x0 = + P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 = + max_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val max_dec : n -> n -> bool **) + + let max_dec = + P.max_dec + + (** val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let min_case_strong n0 m x x0 = + P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 = + min_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val min_dec : n -> n -> bool **) + + let min_dec = + P.min_dec + end (** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) let rec pow_pos rmul x = function - | XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p) - | XO i0 -> let p = pow_pos rmul x i0 in rmul p p - | XH -> x +| XI i0 -> let p = pow_pos rmul x i0 in rmul x (rmul p p) +| XO i0 -> let p = pow_pos rmul x i0 in rmul p p +| XH -> x -type z = - | Z0 - | Zpos of positive - | Zneg of positive - -(** val zdouble_plus_one : z -> z **) - -let zdouble_plus_one = function - | Z0 -> Zpos XH - | Zpos p -> Zpos (XI p) - | Zneg p -> Zneg (pdouble_minus_one p) - -(** val zdouble_minus_one : z -> z **) +(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **) -let zdouble_minus_one = function - | Z0 -> Zneg XH - | Zpos p -> Zpos (pdouble_minus_one p) - | Zneg p -> Zneg (XI p) +let rec nth n0 l default = + match n0 with + | O -> + (match l with + | [] -> default + | x::l' -> x) + | S m -> + (match l with + | [] -> default + | x::t1 -> nth m t1 default) -(** val zdouble : z -> z **) +(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) -let zdouble = function +let rec map f = function +| [] -> [] +| a::t1 -> (f a)::(map f t1) + +(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) + +let rec fold_right f a0 = function +| [] -> a0 +| b::t1 -> f b (fold_right f a0 t1) + +module Z = + struct + type t = z + + (** val zero : z **) + + let zero = + Z0 + + (** val one : z **) + + let one = + Zpos XH + + (** val two : z **) + + let two = + Zpos (XO XH) + + (** val double : z -> z **) + + let double = function | Z0 -> Z0 | Zpos p -> Zpos (XO p) | Zneg p -> Zneg (XO p) - -(** val zPminus : positive -> positive -> z **) - -let rec zPminus x y = - match x with + + (** val succ_double : z -> z **) + + let succ_double = function + | Z0 -> Zpos XH + | Zpos p -> Zpos (XI p) + | Zneg p -> Zneg (Coq_Pos.pred_double p) + + (** val pred_double : z -> z **) + + let pred_double = function + | Z0 -> Zneg XH + | Zpos p -> Zpos (Coq_Pos.pred_double p) + | Zneg p -> Zneg (XI p) + + (** val pos_sub : positive -> positive -> z **) + + let rec pos_sub x y = + match x with | XI p -> - (match y with - | XI q0 -> zdouble (zPminus p q0) - | XO q0 -> zdouble_plus_one (zPminus p q0) - | XH -> Zpos (XO p)) + (match y with + | XI q0 -> double (pos_sub p q0) + | XO q0 -> succ_double (pos_sub p q0) + | XH -> Zpos (XO p)) | XO p -> - (match y with - | XI q0 -> zdouble_minus_one (zPminus p q0) - | XO q0 -> zdouble (zPminus p q0) - | XH -> Zpos (pdouble_minus_one p)) + (match y with + | XI q0 -> pred_double (pos_sub p q0) + | XO q0 -> double (pos_sub p q0) + | XH -> Zpos (Coq_Pos.pred_double p)) | XH -> - (match y with - | XI q0 -> Zneg (XO q0) - | XO q0 -> Zneg (pdouble_minus_one q0) - | XH -> Z0) - -(** val zplus : z -> z -> z **) - -let zplus x y = - match x with + (match y with + | XI q0 -> Zneg (XO q0) + | XO q0 -> Zneg (Coq_Pos.pred_double q0) + | XH -> Z0) + + (** val add : z -> z -> z **) + + let add x y = + match x with | Z0 -> y | Zpos x' -> - (match y with - | Z0 -> Zpos x' - | Zpos y' -> Zpos (pplus x' y') - | Zneg y' -> - (match pcompare x' y' Eq with - | Eq -> Z0 - | Lt -> Zneg (pminus y' x') - | Gt -> Zpos (pminus x' y'))) + (match y with + | Z0 -> x + | Zpos y' -> Zpos (Coq_Pos.add x' y') + | Zneg y' -> pos_sub x' y') | Zneg x' -> - (match y with - | Z0 -> Zneg x' - | Zpos y' -> - (match pcompare x' y' Eq with - | Eq -> Z0 - | Lt -> Zpos (pminus y' x') - | Gt -> Zneg (pminus x' y')) - | Zneg y' -> Zneg (pplus x' y')) - -(** val zopp : z -> z **) - -let zopp = function + (match y with + | Z0 -> x + | Zpos y' -> pos_sub y' x' + | Zneg y' -> Zneg (Coq_Pos.add x' y')) + + (** val opp : z -> z **) + + let opp = function | Z0 -> Z0 | Zpos x0 -> Zneg x0 | Zneg x0 -> Zpos x0 - -(** val zminus : z -> z -> z **) - -let zminus m n0 = - zplus m (zopp n0) - -(** val zmult : z -> z -> z **) - -let zmult x y = - match x with + + (** val succ : z -> z **) + + let succ x = + add x (Zpos XH) + + (** val pred : z -> z **) + + let pred x = + add x (Zneg XH) + + (** val sub : z -> z -> z **) + + let sub m n0 = + add m (opp n0) + + (** val mul : z -> z -> z **) + + let mul x y = + match x with | Z0 -> Z0 | Zpos x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zpos (pmult x' y') - | Zneg y' -> Zneg (pmult x' y')) + (match y with + | Z0 -> Z0 + | Zpos y' -> Zpos (Coq_Pos.mul x' y') + | Zneg y' -> Zneg (Coq_Pos.mul x' y')) | Zneg x' -> - (match y with - | Z0 -> Z0 - | Zpos y' -> Zneg (pmult x' y') - | Zneg y' -> Zpos (pmult x' y')) - -(** val zcompare : z -> z -> comparison **) - -let zcompare x y = - match x with - | Z0 -> (match y with - | Z0 -> Eq - | Zpos y' -> Lt - | Zneg y' -> Gt) - | Zpos x' -> (match y with - | Zpos y' -> pcompare x' y' Eq - | _ -> Gt) + (match y with + | Z0 -> Z0 + | Zpos y' -> Zneg (Coq_Pos.mul x' y') + | Zneg y' -> Zpos (Coq_Pos.mul x' y')) + + (** val pow_pos : z -> positive -> z **) + + let pow_pos z0 n0 = + Coq_Pos.iter n0 (mul z0) (Zpos XH) + + (** val pow : z -> z -> z **) + + let pow x = function + | Z0 -> Zpos XH + | Zpos p -> pow_pos x p + | Zneg p -> Z0 + + (** val compare : z -> z -> comparison **) + + let compare x y = + match x with + | Z0 -> + (match y with + | Z0 -> Eq + | Zpos y' -> Lt + | Zneg y' -> Gt) + | Zpos x' -> + (match y with + | Zpos y' -> Coq_Pos.compare x' y' + | _ -> Gt) | Zneg x' -> - (match y with - | Zneg y' -> compOpp (pcompare x' y' Eq) - | _ -> Lt) - -(** val zabs : z -> z **) - -let zabs = function + (match y with + | Zneg y' -> compOpp (Coq_Pos.compare x' y') + | _ -> Lt) + + (** val sgn : z -> z **) + + let sgn = function | Z0 -> Z0 - | Zpos p -> Zpos p - | Zneg p -> Zpos p - -(** val zmax : z -> z -> z **) - -let zmax m n0 = - match zcompare m n0 with - | Lt -> n0 - | _ -> m - -(** val zle_bool : z -> z -> bool **) - -let zle_bool x y = - match zcompare x y with + | Zpos p -> Zpos XH + | Zneg p -> Zneg XH + + (** val leb : z -> z -> bool **) + + let leb x y = + match compare x y with | Gt -> false | _ -> true - -(** val zge_bool : z -> z -> bool **) - -let zge_bool x y = - match zcompare x y with + + (** val geb : z -> z -> bool **) + + let geb x y = + match compare x y with | Lt -> false | _ -> true - -(** val zgt_bool : z -> z -> bool **) - -let zgt_bool x y = - match zcompare x y with - | Gt -> true + + (** val ltb : z -> z -> bool **) + + let ltb x y = + match compare x y with + | Lt -> true | _ -> false - -(** val zeq_bool : z -> z -> bool **) - -let zeq_bool x y = - match zcompare x y with - | Eq -> true + + (** val gtb : z -> z -> bool **) + + let gtb x y = + match compare x y with + | Gt -> true | _ -> false - -(** val n_of_nat : nat -> n **) - -let n_of_nat = function - | O -> N0 - | S n' -> Npos (p_of_succ_nat n') - -(** val zdiv_eucl_POS : positive -> z -> z * z **) - -let rec zdiv_eucl_POS a b = - match a with + + (** val eqb : z -> z -> bool **) + + let rec eqb x y = + match x with + | Z0 -> + (match y with + | Z0 -> true + | _ -> false) + | Zpos p -> + (match y with + | Zpos q0 -> Coq_Pos.eqb p q0 + | _ -> false) + | Zneg p -> + (match y with + | Zneg q0 -> Coq_Pos.eqb p q0 + | _ -> false) + + (** val max : z -> z -> z **) + + let max n0 m = + match compare n0 m with + | Lt -> m + | _ -> n0 + + (** val min : z -> z -> z **) + + let min n0 m = + match compare n0 m with + | Gt -> m + | _ -> n0 + + (** val abs : z -> z **) + + let abs = function + | Zneg p -> Zpos p + | x -> x + + (** val abs_nat : z -> nat **) + + let abs_nat = function + | Z0 -> O + | Zpos p -> Coq_Pos.to_nat p + | Zneg p -> Coq_Pos.to_nat p + + (** val abs_N : z -> n **) + + let abs_N = function + | Z0 -> N0 + | Zpos p -> Npos p + | Zneg p -> Npos p + + (** val to_nat : z -> nat **) + + let to_nat = function + | Zpos p -> Coq_Pos.to_nat p + | _ -> O + + (** val to_N : z -> n **) + + let to_N = function + | Zpos p -> Npos p + | _ -> N0 + + (** val of_nat : nat -> z **) + + let of_nat = function + | O -> Z0 + | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) + + (** val of_N : n -> z **) + + let of_N = function + | N0 -> Z0 + | Npos p -> Zpos p + + (** val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) + + let iter n0 f x = + match n0 with + | Zpos p -> Coq_Pos.iter p f x + | _ -> x + + (** val pos_div_eucl : positive -> z -> z * z **) + + let rec pos_div_eucl a b = + match a with | XI a' -> - let q0 , r = zdiv_eucl_POS a' b in - let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in - if zgt_bool b r' - then (zmult (Zpos (XO XH)) q0) , r' - else (zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)) , (zminus r' b) + let q0,r = pos_div_eucl a' b in + let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in + if gtb b r' + then (mul (Zpos (XO XH)) q0),r' + else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) | XO a' -> - let q0 , r = zdiv_eucl_POS a' b in - let r' = zmult (Zpos (XO XH)) r in - if zgt_bool b r' - then (zmult (Zpos (XO XH)) q0) , r' - else (zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)) , (zminus r' b) - | XH -> - if zge_bool b (Zpos (XO XH)) then Z0 , (Zpos XH) else (Zpos XH) , Z0 - -(** val zdiv_eucl : z -> z -> z * z **) - -let zdiv_eucl a b = - match a with - | Z0 -> Z0 , Z0 + let q0,r = pos_div_eucl a' b in + let r' = mul (Zpos (XO XH)) r in + if gtb b r' + then (mul (Zpos (XO XH)) q0),r' + else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) + | XH -> if geb b (Zpos (XO XH)) then Z0,(Zpos XH) else (Zpos XH),Z0 + + (** val div_eucl : z -> z -> z * z **) + + let div_eucl a b = + match a with + | Z0 -> Z0,Z0 | Zpos a' -> - (match b with - | Z0 -> Z0 , Z0 - | Zpos p -> zdiv_eucl_POS a' b - | Zneg b' -> - let q0 , r = zdiv_eucl_POS a' (Zpos b') in - (match r with - | Z0 -> (zopp q0) , Z0 - | _ -> (zopp (zplus q0 (Zpos XH))) , (zplus b r))) + (match b with + | Z0 -> Z0,Z0 + | Zpos p -> pos_div_eucl a' b + | Zneg b' -> + let q0,r = pos_div_eucl a' (Zpos b') in + (match r with + | Z0 -> (opp q0),Z0 + | _ -> (opp (add q0 (Zpos XH))),(add b r))) | Zneg a' -> - (match b with - | Z0 -> Z0 , Z0 - | Zpos p -> - let q0 , r = zdiv_eucl_POS a' b in - (match r with - | Z0 -> (zopp q0) , Z0 - | _ -> (zopp (zplus q0 (Zpos XH))) , (zminus b r)) - | Zneg b' -> - let q0 , r = zdiv_eucl_POS a' (Zpos b') in q0 , (zopp r)) + (match b with + | Z0 -> Z0,Z0 + | Zpos p -> + let q0,r = pos_div_eucl a' b in + (match r with + | Z0 -> (opp q0),Z0 + | _ -> (opp (add q0 (Zpos XH))),(sub b r)) + | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r)) + + (** val div : z -> z -> z **) + + let div a b = + let q0,x = div_eucl a b in q0 + + (** val modulo : z -> z -> z **) + + let modulo a b = + let x,r = div_eucl a b in r + + (** val quotrem : z -> z -> z * z **) + + let quotrem a b = + match a with + | Z0 -> Z0,Z0 + | Zpos a0 -> + (match b with + | Z0 -> Z0,a + | Zpos b0 -> + let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(of_N r) + | Zneg b0 -> + let q0,r = N.pos_div_eucl a0 (Npos b0) in (opp (of_N q0)),(of_N r)) + | Zneg a0 -> + (match b with + | Z0 -> Z0,a + | Zpos b0 -> + let q0,r = N.pos_div_eucl a0 (Npos b0) in + (opp (of_N q0)),(opp (of_N r)) + | Zneg b0 -> + let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(opp (of_N r))) + + (** val quot : z -> z -> z **) + + let quot a b = + fst (quotrem a b) + + (** val rem : z -> z -> z **) + + let rem a b = + snd (quotrem a b) + + (** val even : z -> bool **) + + let even = function + | Z0 -> true + | Zpos p -> + (match p with + | XO p2 -> true + | _ -> false) + | Zneg p -> + (match p with + | XO p2 -> true + | _ -> false) + + (** val odd : z -> bool **) + + let odd = function + | Z0 -> false + | Zpos p -> + (match p with + | XO p2 -> false + | _ -> true) + | Zneg p -> + (match p with + | XO p2 -> false + | _ -> true) + + (** val div2 : z -> z **) + + let div2 = function + | Z0 -> Z0 + | Zpos p -> + (match p with + | XH -> Z0 + | _ -> Zpos (Coq_Pos.div2 p)) + | Zneg p -> Zneg (Coq_Pos.div2_up p) + + (** val quot2 : z -> z **) + + let quot2 = function + | Z0 -> Z0 + | Zpos p -> + (match p with + | XH -> Z0 + | _ -> Zpos (Coq_Pos.div2 p)) + | Zneg p -> + (match p with + | XH -> Z0 + | _ -> Zneg (Coq_Pos.div2 p)) + + (** val log2 : z -> z **) + + let log2 = function + | Zpos p2 -> + (match p2 with + | XI p -> Zpos (Coq_Pos.size p) + | XO p -> Zpos (Coq_Pos.size p) + | XH -> Z0) + | _ -> Z0 + + (** val sqrtrem : z -> z * z **) + + let sqrtrem = function + | Zpos p -> + let s,m = Coq_Pos.sqrtrem p in + (match m with + | Coq_Pos.IsPos r -> (Zpos s),(Zpos r) + | _ -> (Zpos s),Z0) + | _ -> Z0,Z0 + + (** val sqrt : z -> z **) + + let sqrt = function + | Zpos p -> Zpos (Coq_Pos.sqrt p) + | _ -> Z0 + + (** val gcd : z -> z -> z **) + + let gcd a b = + match a with + | Z0 -> abs b + | Zpos a0 -> + (match b with + | Z0 -> abs a + | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) + | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) + | Zneg a0 -> + (match b with + | Z0 -> abs a + | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) + | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) + + (** val ggcd : z -> z -> z * (z * z) **) + + let ggcd a b = + match a with + | Z0 -> (abs b),(Z0,(sgn b)) + | Zpos a0 -> + (match b with + | Z0 -> (abs a),((sgn a),Z0) + | Zpos b0 -> + let g,p = Coq_Pos.ggcd a0 b0 in + let aa,bb = p in (Zpos g),((Zpos aa),(Zpos bb)) + | Zneg b0 -> + let g,p = Coq_Pos.ggcd a0 b0 in + let aa,bb = p in (Zpos g),((Zpos aa),(Zneg bb))) + | Zneg a0 -> + (match b with + | Z0 -> (abs a),((sgn a),Z0) + | Zpos b0 -> + let g,p = Coq_Pos.ggcd a0 b0 in + let aa,bb = p in (Zpos g),((Zneg aa),(Zpos bb)) + | Zneg b0 -> + let g,p = Coq_Pos.ggcd a0 b0 in + let aa,bb = p in (Zpos g),((Zneg aa),(Zneg bb))) + + (** val testbit : z -> z -> bool **) + + let testbit a = function + | Z0 -> odd a + | Zpos p -> + (match a with + | Z0 -> false + | Zpos a0 -> Coq_Pos.testbit a0 (Npos p) + | Zneg a0 -> negb (N.testbit (Coq_Pos.pred_N a0) (Npos p))) + | Zneg p -> false + + (** val shiftl : z -> z -> z **) + + let shiftl a = function + | Z0 -> a + | Zpos p -> Coq_Pos.iter p (mul (Zpos (XO XH))) a + | Zneg p -> Coq_Pos.iter p div2 a + + (** val shiftr : z -> z -> z **) + + let shiftr a n0 = + shiftl a (opp n0) + + (** val coq_lor : z -> z -> z **) + + let coq_lor a b = + match a with + | Z0 -> b + | Zpos a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> Zpos (Coq_Pos.coq_lor a0 b0) + | Zneg b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N b0) (Npos a0)))) + | Zneg a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N a0) (Npos b0))) + | Zneg b0 -> + Zneg + (N.succ_pos (N.coq_land (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) + + (** val coq_land : z -> z -> z **) + + let coq_land a b = + match a with + | Z0 -> Z0 + | Zpos a0 -> + (match b with + | Z0 -> Z0 + | Zpos b0 -> of_N (Coq_Pos.coq_land a0 b0) + | Zneg b0 -> of_N (N.ldiff (Npos a0) (Coq_Pos.pred_N b0))) + | Zneg a0 -> + (match b with + | Z0 -> Z0 + | Zpos b0 -> of_N (N.ldiff (Npos b0) (Coq_Pos.pred_N a0)) + | Zneg b0 -> + Zneg + (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) + + (** val ldiff : z -> z -> z **) + + let ldiff a b = + match a with + | Z0 -> Z0 + | Zpos a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> of_N (Coq_Pos.ldiff a0 b0) + | Zneg b0 -> of_N (N.coq_land (Npos a0) (Coq_Pos.pred_N b0))) + | Zneg a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> + Zneg (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Npos b0))) + | Zneg b0 -> of_N (N.ldiff (Coq_Pos.pred_N b0) (Coq_Pos.pred_N a0))) + + (** val coq_lxor : z -> z -> z **) + + let coq_lxor a b = + match a with + | Z0 -> b + | Zpos a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> of_N (Coq_Pos.coq_lxor a0 b0) + | Zneg b0 -> + Zneg (N.succ_pos (N.coq_lxor (Npos a0) (Coq_Pos.pred_N b0)))) + | Zneg a0 -> + (match b with + | Z0 -> a + | Zpos b0 -> + Zneg (N.succ_pos (N.coq_lxor (Coq_Pos.pred_N a0) (Npos b0))) + | Zneg b0 -> of_N (N.coq_lxor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))) + + (** val eq_dec : z -> z -> bool **) + + let eq_dec x y = + match x with + | Z0 -> + (match y with + | Z0 -> true + | _ -> false) + | Zpos x0 -> + (match y with + | Zpos p2 -> Coq_Pos.eq_dec x0 p2 + | _ -> false) + | Zneg x0 -> + (match y with + | Zneg p2 -> Coq_Pos.eq_dec x0 p2 + | _ -> false) + + module BootStrap = + struct + + end + + module OrderElts = + struct + type t = z + end + + module OrderTac = MakeOrderTac(OrderElts) + + (** val sqrt_up : z -> z **) + + let sqrt_up a = + match compare Z0 a with + | Lt -> succ (sqrt (pred a)) + | _ -> Z0 + + (** val log2_up : z -> z **) + + let log2_up a = + match compare (Zpos XH) a with + | Lt -> succ (log2 (pred a)) + | _ -> Z0 + + module NZDivP = + struct + + end + + module Quot2Div = + struct + (** val div : z -> z -> z **) + + let div = + quot + + (** val modulo : z -> z -> z **) + + let modulo = + rem + end + + module NZQuot = + struct + + end + + (** val lcm : z -> z -> z **) + + let lcm a b = + abs (mul a (div b (gcd a b))) + + (** val b2z : bool -> z **) + + let b2z = function + | true -> Zpos XH + | false -> Z0 + + (** val setbit : z -> z -> z **) + + let setbit a n0 = + coq_lor a (shiftl (Zpos XH) n0) + + (** val clearbit : z -> z -> z **) + + let clearbit a n0 = + ldiff a (shiftl (Zpos XH) n0) + + (** val lnot : z -> z **) + + let lnot a = + pred (opp a) + + (** val ones : z -> z **) + + let ones n0 = + pred (shiftl (Zpos XH) n0) + + module T = + struct + + end + + module ORev = + struct + type t = z + end + + module MRev = + struct + (** val max : z -> z -> z **) + + let max x y = + min y x + end + + module MPRev = MaxLogicalProperties(ORev)(MRev) + + module P = + struct + (** val max_case_strong : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let max_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat n0 (max n0 m) __ (hl __) + | _ -> compat m (max n0 m) __ (hr __)) + + (** val max_case : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 x1 = + max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val max_dec : z -> z -> bool **) + + let max_dec n0 m = + max_case n0 m (fun x y _ h0 -> h0) true false + + (** val min_case_strong : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) + -> 'a1 **) + + let min_case_strong n0 m compat hl hr = + let c = compSpec2Type n0 m (compare n0 m) in + (match c with + | CompGtT -> compat m (min n0 m) __ (hr __) + | _ -> compat n0 (min n0 m) __ (hl __)) + + (** val min_case : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 x1 = + min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) + + (** val min_dec : z -> z -> bool **) + + let min_dec n0 m = + min_case n0 m (fun x y _ h0 -> h0) true false + end + + (** val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let max_case_strong n0 m x x0 = + P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) + + let max_case n0 m x x0 = + max_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val max_dec : z -> z -> bool **) + + let max_dec = + P.max_dec + + (** val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) + + let min_case_strong n0 m x x0 = + P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 + + (** val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) + + let min_case n0 m x x0 = + min_case_strong n0 m (fun _ -> x) (fun _ -> x0) + + (** val min_dec : z -> z -> bool **) + + let min_dec = + P.min_dec + end -(** val zdiv : z -> z -> z **) +(** val zeq_bool : z -> z -> bool **) -let zdiv a b = - let q0 , x = zdiv_eucl a b in q0 +let zeq_bool x y = + match Z.compare x y with + | Eq -> true + | _ -> false type 'c pol = - | Pc of 'c - | Pinj of positive * 'c pol - | PX of 'c pol * positive * 'c pol +| Pc of 'c +| Pinj of positive * 'c pol +| PX of 'c pol * positive * 'c pol (** val p0 : 'a1 -> 'a1 pol **) @@ -457,49 +2796,51 @@ let p1 cI = let rec peq ceqb p p' = match p with - | Pc c -> (match p' with - | Pc c' -> ceqb c c' - | _ -> false) - | Pinj (j, q0) -> - (match p' with - | Pinj (j', q') -> - (match pcompare j j' Eq with - | Eq -> peq ceqb q0 q' - | _ -> false) - | _ -> false) - | PX (p2, i, q0) -> - (match p' with - | PX (p'0, i', q') -> - (match pcompare i i' Eq with - | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false - | _ -> false) - | _ -> false) + | Pc c -> + (match p' with + | Pc c' -> ceqb c c' + | _ -> false) + | Pinj (j, q0) -> + (match p' with + | Pinj (j', q') -> + (match Coq_Pos.compare j j' with + | Eq -> peq ceqb q0 q' + | _ -> false) + | _ -> false) + | PX (p2, i, q0) -> + (match p' with + | PX (p'0, i', q') -> + (match Coq_Pos.compare i i' with + | Eq -> if peq ceqb p2 p'0 then peq ceqb q0 q' else false + | _ -> false) + | _ -> false) + +(** val mkPinj : positive -> 'a1 pol -> 'a1 pol **) + +let mkPinj j p = match p with +| Pc c -> p +| Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0) +| PX (p2, p3, p4) -> Pinj (j, p) (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) let mkPinj_pred j p = match j with - | XI j0 -> Pinj ((XO j0), p) - | XO j0 -> Pinj ((pdouble_minus_one j0), p) - | XH -> p + | XI j0 -> Pinj ((XO j0), p) + | XO j0 -> Pinj ((Coq_Pos.pred_double j0), p) + | XH -> p (** val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let mkPX cO ceqb p i q0 = match p with - | Pc c -> - if ceqb c cO - then (match q0 with - | Pc c0 -> q0 - | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) - | PX (p2, p3, p4) -> Pinj (XH, q0)) - else PX (p, i, q0) - | Pinj (p2, p3) -> PX (p, i, q0) - | PX (p', i', q') -> - if peq ceqb q' (p0 cO) - then PX (p', (pplus i' i), q0) - else PX (p, i, q0) + | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0) + | Pinj (p2, p3) -> PX (p, i, q0) + | PX (p', i', q') -> + if peq ceqb q' (p0 cO) + then PX (p', (Coq_Pos.add i' i), q0) + else PX (p, i, q0) (** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **) @@ -514,202 +2855,155 @@ let mkX cO cI = (** val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol **) let rec popp copp = function - | Pc c -> Pc (copp c) - | Pinj (j, q0) -> Pinj (j, (popp copp q0)) - | PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) +| Pc c -> Pc (copp c) +| Pinj (j, q0) -> Pinj (j, (popp copp q0)) +| PX (p2, i, q0) -> PX ((popp copp p2), i, (popp copp q0)) (** val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) let rec paddC cadd p c = match p with - | Pc c1 -> Pc (cadd c1 c) - | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) + | Pc c1 -> Pc (cadd c1 c) + | Pinj (j, q0) -> Pinj (j, (paddC cadd q0 c)) + | PX (p2, i, q0) -> PX (p2, i, (paddC cadd q0 c)) (** val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol **) let rec psubC csub p c = match p with - | Pc c1 -> Pc (csub c1 c) - | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) - | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) + | Pc c1 -> Pc (csub c1 c) + | Pinj (j, q0) -> Pinj (j, (psubC csub q0 c)) + | PX (p2, i, q0) -> PX (p2, i, (psubC csub q0 c)) (** val paddI : ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec paddI cadd pop q0 j = function - | Pc c -> - let p2 = paddC cadd q0 c in - (match p2 with - | Pc c0 -> p2 - | Pinj (j', q1) -> Pinj ((pplus j j'), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Pinj (j', q') -> - (match zPminus j' j with - | Z0 -> - let p2 = pop q' q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zpos k -> - let p2 = pop (Pinj (k, q')) q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zneg k -> - let p2 = paddI cadd pop q0 k q' in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) - | PX (p3, p4, p5) -> Pinj (j', p2))) - | PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) - | XO j0 -> PX (p2, i, (paddI cadd pop q0 (pdouble_minus_one j0) q')) - | XH -> PX (p2, i, (pop q' q0))) +| Pc c -> mkPinj j (paddC cadd q0 c) +| Pinj (j', q') -> + (match Z.pos_sub j' j with + | Z0 -> mkPinj j (pop q' q0) + | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) + | Zneg k -> mkPinj j' (paddI cadd pop q0 k q')) +| PX (p2, i, q') -> + (match j with + | XI j0 -> PX (p2, i, (paddI cadd pop q0 (XO j0) q')) + | XO j0 -> PX (p2, i, (paddI cadd pop q0 (Coq_Pos.pred_double j0) q')) + | XH -> PX (p2, i, (pop q' q0))) (** val psubI : ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec psubI cadd copp pop q0 j = function - | Pc c -> - let p2 = paddC cadd (popp copp q0) c in - (match p2 with - | Pc c0 -> p2 - | Pinj (j', q1) -> Pinj ((pplus j j'), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Pinj (j', q') -> - (match zPminus j' j with - | Z0 -> - let p2 = pop q' q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zpos k -> - let p2 = pop (Pinj (k, q')) q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zneg k -> - let p2 = psubI cadd copp pop q0 k q' in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) - | PX (p3, p4, p5) -> Pinj (j', p2))) - | PX (p2, i, q') -> - (match j with - | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) - | XO j0 -> PX (p2, i, - (psubI cadd copp pop q0 (pdouble_minus_one j0) q')) - | XH -> PX (p2, i, (pop q' q0))) +| Pc c -> mkPinj j (paddC cadd (popp copp q0) c) +| Pinj (j', q') -> + (match Z.pos_sub j' j with + | Z0 -> mkPinj j (pop q' q0) + | Zpos k -> mkPinj j (pop (Pinj (k, q')) q0) + | Zneg k -> mkPinj j' (psubI cadd copp pop q0 k q')) +| PX (p2, i, q') -> + (match j with + | XI j0 -> PX (p2, i, (psubI cadd copp pop q0 (XO j0) q')) + | XO j0 -> + PX (p2, i, (psubI cadd copp pop q0 (Coq_Pos.pred_double j0) q')) + | XH -> PX (p2, i, (pop q' q0))) (** val paddX : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec paddX cO ceqb pop p' i' p = match p with - | Pc c -> PX (p', i', p) - | Pinj (j, q') -> - (match j with - | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) - | XO j0 -> PX (p', i', (Pinj ((pdouble_minus_one j0), q'))) - | XH -> PX (p', i', q')) - | PX (p2, i, q') -> - (match zPminus i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') +| Pc c -> PX (p', i', p) +| Pinj (j, q') -> + (match j with + | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) + | XO j0 -> PX (p', i', (Pinj ((Coq_Pos.pred_double j0), q'))) + | XH -> PX (p', i', q')) +| PX (p2, i, q') -> + (match Z.pos_sub i i' with + | Z0 -> mkPX cO ceqb (pop p2 p') i q' + | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' + | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') (** val psubX : 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec psubX cO copp ceqb pop p' i' p = match p with - | Pc c -> PX ((popp copp p'), i', p) - | Pinj (j, q') -> - (match j with - | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) - | XO j0 -> PX ((popp copp p'), i', (Pinj ( - (pdouble_minus_one j0), q'))) - | XH -> PX ((popp copp p'), i', q')) - | PX (p2, i, q') -> - (match zPminus i i' with - | Z0 -> mkPX cO ceqb (pop p2 p') i q' - | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' - | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') +| Pc c -> PX ((popp copp p'), i', p) +| Pinj (j, q') -> + (match j with + | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) + | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) + | XH -> PX ((popp copp p'), i', q')) +| PX (p2, i, q') -> + (match Z.pos_sub i i' with + | Z0 -> mkPX cO ceqb (pop p2 p') i q' + | Zpos k -> mkPX cO ceqb (pop (PX (p2, k, (p0 cO))) p') i' q' + | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') (** val padd : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let rec padd cO cadd ceqb p = function - | Pc c' -> paddC cadd p c' - | Pinj (j', q') -> paddI cadd (fun x x0 -> padd cO cadd ceqb x x0) q' j' p - | PX (p'0, i', q') -> - (match p with - | Pc c -> PX (p'0, i', (paddC cadd q' c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> PX (p'0, i', - (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> PX (p'0, i', - (padd cO cadd ceqb (Pinj ((pdouble_minus_one j0), q0)) - q')) - | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) - | PX (p2, i, q0) -> - (match zPminus i i' with - | Z0 -> - mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i - (padd cO cadd ceqb q0 q') - | Zpos k -> - mkPX cO ceqb - (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' - (padd cO cadd ceqb q0 q') - | Zneg k -> - mkPX cO ceqb - (paddX cO ceqb (fun x x0 -> padd cO cadd ceqb x x0) p'0 - k p2) i (padd cO cadd ceqb q0 q'))) +| Pc c' -> paddC cadd p c' +| Pinj (j', q') -> paddI cadd (padd cO cadd ceqb) q' j' p +| PX (p'0, i', q') -> + (match p with + | Pc c -> PX (p'0, i', (paddC cadd q' c)) + | Pinj (j, q0) -> + (match j with + | XI j0 -> PX (p'0, i', (padd cO cadd ceqb (Pinj ((XO j0), q0)) q')) + | XO j0 -> + PX (p'0, i', + (padd cO cadd ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q')) + | XH -> PX (p'0, i', (padd cO cadd ceqb q0 q'))) + | PX (p2, i, q0) -> + (match Z.pos_sub i i' with + | Z0 -> + mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q') + | Zpos k -> + mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' + (padd cO cadd ceqb q0 q') + | Zneg k -> + mkPX cO ceqb (paddX cO ceqb (padd cO cadd ceqb) p'0 k p2) i + (padd cO cadd ceqb q0 q'))) (** val psub : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let rec psub cO cadd csub copp ceqb p = function - | Pc c' -> psubC csub p c' - | Pinj (j', q') -> - psubI cadd copp (fun x x0 -> psub cO cadd csub copp ceqb x x0) q' j' p - | PX (p'0, i', q') -> - (match p with - | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) - | Pinj (j, q0) -> - (match j with - | XI j0 -> PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) - | XO j0 -> PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj - ((pdouble_minus_one j0), q0)) q')) - | XH -> PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb q0 q'))) - | PX (p2, i, q0) -> - (match zPminus i i' with - | Z0 -> - mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i - (psub cO cadd csub copp ceqb q0 q') - | Zpos k -> - mkPX cO ceqb - (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) - i' (psub cO cadd csub copp ceqb q0 q') - | Zneg k -> - mkPX cO ceqb - (psubX cO copp ceqb (fun x x0 -> - psub cO cadd csub copp ceqb x x0) p'0 k p2) i - (psub cO cadd csub copp ceqb q0 q'))) +| Pc c' -> psubC csub p c' +| Pinj (j', q') -> psubI cadd copp (psub cO cadd csub copp ceqb) q' j' p +| PX (p'0, i', q') -> + (match p with + | Pc c -> PX ((popp copp p'0), i', (paddC cadd (popp copp q') c)) + | Pinj (j, q0) -> + (match j with + | XI j0 -> + PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) + | XO j0 -> + PX ((popp copp p'0), i', + (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) + q')) + | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) + | PX (p2, i, q0) -> + (match Z.pos_sub i i' with + | Z0 -> + mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i + (psub cO cadd csub copp ceqb q0 q') + | Zpos k -> + mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) + i' (psub cO cadd csub copp ceqb q0 q') + | Zneg k -> + mkPX cO ceqb + (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i + (psub cO cadd csub copp ceqb q0 q'))) (** val pmulC_aux : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> @@ -717,16 +3011,11 @@ let rec psub cO cadd csub copp ceqb p = function let rec pmulC_aux cO cmul ceqb p c = match p with - | Pc c' -> Pc (cmul c' c) - | Pinj (j, q0) -> - let p2 = pmulC_aux cO cmul ceqb q0 c in - (match p2 with - | Pc c0 -> p2 - | Pinj (j', q1) -> Pinj ((pplus j j'), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | PX (p2, i, q0) -> - mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i - (pmulC_aux cO cmul ceqb q0 c) + | Pc c' -> Pc (cmul c' c) + | Pinj (j, q0) -> mkPinj j (pmulC_aux cO cmul ceqb q0 c) + | PX (p2, i, q0) -> + mkPX cO ceqb (pmulC_aux cO cmul ceqb p2 c) i + (pmulC_aux cO cmul ceqb q0 c) (** val pmulC : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> @@ -742,108 +3031,75 @@ let pmulC cO cI cmul ceqb p c = 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) let rec pmulI cO cI cmul ceqb pmul0 q0 j = function - | Pc c -> - let p2 = pmulC cO cI cmul ceqb q0 c in - (match p2 with - | Pc c0 -> p2 - | Pinj (j', q1) -> Pinj ((pplus j j'), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Pinj (j', q') -> - (match zPminus j' j with - | Z0 -> - let p2 = pmul0 q' q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zpos k -> - let p2 = pmul0 (Pinj (k, q')) q0 in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j j'0), q1) - | PX (p3, p4, p5) -> Pinj (j, p2)) - | Zneg k -> - let p2 = pmulI cO cI cmul ceqb pmul0 q0 k q' in - (match p2 with - | Pc c -> p2 - | Pinj (j'0, q1) -> Pinj ((pplus j' j'0), q1) - | PX (p3, p4, p5) -> Pinj (j', p2))) - | PX (p', i', q') -> - (match j with - | XI j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') - | XO j' -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' - (pmulI cO cI cmul ceqb pmul0 q0 (pdouble_minus_one j') q') - | XH -> - mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' - (pmul0 q' q0)) +| Pc c -> mkPinj j (pmulC cO cI cmul ceqb q0 c) +| Pinj (j', q') -> + (match Z.pos_sub j' j with + | Z0 -> mkPinj j (pmul0 q' q0) + | Zpos k -> mkPinj j (pmul0 (Pinj (k, q')) q0) + | Zneg k -> mkPinj j' (pmulI cO cI cmul ceqb pmul0 q0 k q')) +| PX (p', i', q') -> + (match j with + | XI j' -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' + (pmulI cO cI cmul ceqb pmul0 q0 (XO j') q') + | XO j' -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 j p') i' + (pmulI cO cI cmul ceqb pmul0 q0 (Coq_Pos.pred_double j') q') + | XH -> + mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0)) (** val pmul : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with - | Pc c -> pmulC cO cI cmul ceqb p c - | Pinj (j', q') -> - pmulI cO cI cmul ceqb (fun x x0 -> pmul cO cI cadd cmul ceqb x x0) q' - j' p - | PX (p', i', q') -> - (match p with - | Pc c -> pmulC cO cI cmul ceqb p'' c - | Pinj (j, q0) -> - mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' - (match j with - | XI j0 -> - pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' - | XO j0 -> - pmul cO cI cadd cmul ceqb (Pinj - ((pdouble_minus_one j0), q0)) q' - | XH -> pmul cO cI cadd cmul ceqb q0 q') - | PX (p2, i, q0) -> - padd cO cadd ceqb - (mkPX cO ceqb - (padd cO cadd ceqb - (mkPX cO ceqb (pmul cO cI cadd cmul ceqb p2 p') i (p0 cO)) - (pmul cO cI cadd cmul ceqb - (match q0 with - | Pc c -> q0 - | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) - | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' - (p0 cO)) - (mkPX cO ceqb - (pmulI cO cI cmul ceqb (fun x x0 -> - pmul cO cI cadd cmul ceqb x x0) q' XH p2) i - (pmul cO cI cadd cmul ceqb q0 q'))) +| Pc c -> pmulC cO cI cmul ceqb p c +| Pinj (j', q') -> pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p +| PX (p', i', q') -> + (match p with + | Pc c -> pmulC cO cI cmul ceqb p'' c + | Pinj (j, q0) -> + let qQ' = + match j with + | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' + | XO j0 -> + pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q' + | XH -> pmul cO cI cadd cmul ceqb q0 q' + in + mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' + | PX (p2, i, q0) -> + let qQ' = pmul cO cI cadd cmul ceqb q0 q' in + let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in + let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in + let pP' = pmul cO cI cadd cmul ceqb p2 p' in + padd cO cadd ceqb + (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i' + (p0 cO)) (mkPX cO ceqb pQ' i qQ')) (** val psquare : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol **) let rec psquare cO cI cadd cmul ceqb = function - | Pc c -> Pc (cmul c c) - | Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0)) - | PX (p2, i, q0) -> - mkPX cO ceqb - (padd cO cadd ceqb - (mkPX cO ceqb (psquare cO cI cadd cmul ceqb p2) i (p0 cO)) - (pmul cO cI cadd cmul ceqb p2 - (let p3 = pmulC cO cI cmul ceqb q0 (cadd cI cI) in - match p3 with - | Pc c -> p3 - | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) - | PX (p4, p5, p6) -> Pinj (XH, p3)))) i - (psquare cO cI cadd cmul ceqb q0) +| Pc c -> Pc (cmul c c) +| Pinj (j, q0) -> Pinj (j, (psquare cO cI cadd cmul ceqb q0)) +| PX (p2, i, q0) -> + let twoPQ = + pmul cO cI cadd cmul ceqb p2 + (mkPinj XH (pmulC cO cI cmul ceqb q0 (cadd cI cI))) + in + let q2 = psquare cO cI cadd cmul ceqb q0 in + let p3 = psquare cO cI cadd cmul ceqb p2 in + mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2 type 'c pExpr = - | PEc of 'c - | PEX of positive - | PEadd of 'c pExpr * 'c pExpr - | PEsub of 'c pExpr * 'c pExpr - | PEmul of 'c pExpr * 'c pExpr - | PEopp of 'c pExpr - | PEpow of 'c pExpr * n +| PEc of 'c +| PEX of positive +| PEadd of 'c pExpr * 'c pExpr +| PEsub of 'c pExpr * 'c pExpr +| PEmul of 'c pExpr * 'c pExpr +| PEopp of 'c pExpr +| PEpow of 'c pExpr * n (** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) @@ -856,68 +3112,78 @@ let mk_X cO cI j = pol **) let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function - | XI p3 -> - subst_l - (pmul cO cI cadd cmul ceqb - (ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p) - | XO p3 -> - ppow_pos cO cI cadd cmul ceqb subst_l - (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 - | XH -> subst_l (pmul cO cI cadd cmul ceqb res p) +| XI p3 -> + subst_l + (pmul cO cI cadd cmul ceqb + (ppow_pos cO cI cadd cmul ceqb subst_l + (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3) p) +| XO p3 -> + ppow_pos cO cI cadd cmul ceqb subst_l + (ppow_pos cO cI cadd cmul ceqb subst_l res p p3) p p3 +| XH -> subst_l (pmul cO cI cadd cmul ceqb res p) (** val ppow_N : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol **) let ppow_N cO cI cadd cmul ceqb subst_l p = function - | N0 -> p1 cI - | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 +| N0 -> p1 cI +| Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 (** val norm_aux : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) let rec norm_aux cO cI cadd cmul csub copp ceqb = function - | PEc c -> Pc c - | PEX j -> mk_X cO cI j - | PEadd (pe1, pe2) -> - (match pe1 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - (match pe2 with - | PEopp pe3 -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe3) - | _ -> - padd cO cadd ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2))) - | PEsub (pe1, pe2) -> - psub cO cadd csub copp ceqb - (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - | PEmul (pe1, pe2) -> - pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) - (norm_aux cO cI cadd cmul csub copp ceqb pe2) - | PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) - | PEpow (pe1, n0) -> - ppow_N cO cI cadd cmul ceqb (fun p -> p) - (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 +| PEc c -> Pc c +| PEX j -> mk_X cO cI j +| PEadd (pe1, pe2) -> + (match pe1 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe2) + (norm_aux cO cI cadd cmul csub copp ceqb pe3) + | _ -> + (match pe2 with + | PEopp pe3 -> + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe3) + | _ -> + padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2))) +| PEsub (pe1, pe2) -> + psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2) +| PEmul (pe1, pe2) -> + pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) + (norm_aux cO cI cadd cmul csub copp ceqb pe2) +| PEopp pe1 -> popp copp (norm_aux cO cI cadd cmul csub copp ceqb pe1) +| PEpow (pe1, n0) -> + ppow_N cO cI cadd cmul ceqb (fun p -> p) + (norm_aux cO cI cadd cmul csub copp ceqb pe1) n0 type 'a bFormula = - | TT - | FF - | X - | A of 'a - | Cj of 'a bFormula * 'a bFormula - | D of 'a bFormula * 'a bFormula - | N of 'a bFormula - | I of 'a bFormula * 'a bFormula +| TT +| FF +| X +| A of 'a +| Cj of 'a bFormula * 'a bFormula +| D of 'a bFormula * 'a bFormula +| N of 'a bFormula +| I of 'a bFormula * 'a bFormula + +(** val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula **) + +let rec map_bformula fct = function +| TT -> TT +| FF -> FF +| X -> X +| A a -> A (fct a) +| Cj (f1, f2) -> Cj ((map_bformula fct f1), (map_bformula fct f2)) +| D (f1, f2) -> D ((map_bformula fct f1), (map_bformula fct f2)) +| N f0 -> N (map_bformula fct f0) +| I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2)) type 'term' clause = 'term' list @@ -931,19 +3197,61 @@ let tt = (** val ff : 'a1 cnf **) let ff = - [] :: [] + []::[] + +(** val add_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 + clause option **) + +let rec add_term unsat deduce t1 = function +| [] -> + (match deduce t1 t1 with + | Some u -> if unsat u then None else Some (t1::[]) + | None -> Some (t1::[])) +| t'::cl0 -> + (match deduce t1 t' with + | Some u -> + if unsat u + then None + else (match add_term unsat deduce t1 cl0 with + | Some cl' -> Some (t'::cl') + | None -> None) + | None -> + (match add_term unsat deduce t1 cl0 with + | Some cl' -> Some (t'::cl') + | None -> None)) + +(** val or_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause + -> 'a1 clause option **) + +let rec or_clause unsat deduce cl1 cl2 = + match cl1 with + | [] -> Some cl2 + | t1::cl -> + (match add_term unsat deduce t1 cl2 with + | Some cl' -> or_clause unsat deduce cl cl' + | None -> None) -(** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **) +(** val or_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> + 'a1 cnf **) -let or_clause_cnf t0 f = - map (fun x -> app t0 x) f +let or_clause_cnf unsat deduce t1 f = + fold_right (fun e acc -> + match or_clause unsat deduce t1 e with + | Some cl -> cl::acc + | None -> acc) [] f -(** val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) +(** val or_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 + cnf **) -let rec or_cnf f f' = +let rec or_cnf unsat deduce f f' = match f with - | [] -> tt - | e :: rst -> app (or_cnf rst f') (or_clause_cnf e f') + | [] -> tt + | e::rst -> + app (or_cnf unsat deduce rst f') (or_clause_cnf unsat deduce e f') (** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **) @@ -951,133 +3259,168 @@ let and_cnf f1 f2 = app f1 f2 (** val xcnf : - ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) - -let rec xcnf normalise0 negate0 pol0 = function - | TT -> if pol0 then tt else ff - | FF -> if pol0 then ff else tt - | X -> ff - | A x -> if pol0 then normalise0 x else negate0 x - | Cj (e1, e2) -> - if pol0 - then and_cnf (xcnf normalise0 negate0 pol0 e1) - (xcnf normalise0 negate0 pol0 e2) - else or_cnf (xcnf normalise0 negate0 pol0 e1) - (xcnf normalise0 negate0 pol0 e2) - | D (e1, e2) -> - if pol0 - then or_cnf (xcnf normalise0 negate0 pol0 e1) - (xcnf normalise0 negate0 pol0 e2) - else and_cnf (xcnf normalise0 negate0 pol0 e1) - (xcnf normalise0 negate0 pol0 e2) - | N e -> xcnf normalise0 negate0 (negb pol0) e - | I (e1, e2) -> - if pol0 - then or_cnf (xcnf normalise0 negate0 (negb pol0) e1) - (xcnf normalise0 negate0 pol0 e2) - else and_cnf (xcnf normalise0 negate0 (negb pol0) e1) - (xcnf normalise0 negate0 pol0 e2) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 + -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) + +let rec xcnf unsat deduce normalise0 negate0 pol0 = function +| TT -> if pol0 then tt else ff +| FF -> if pol0 then ff else tt +| X -> ff +| A x -> if pol0 then normalise0 x else negate0 x +| Cj (e1, e2) -> + if pol0 + then and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) + else or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) +| D (e1, e2) -> + if pol0 + then or_cnf unsat deduce (xcnf unsat deduce normalise0 negate0 pol0 e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) + else and_cnf (xcnf unsat deduce normalise0 negate0 pol0 e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) +| N e -> xcnf unsat deduce normalise0 negate0 (negb pol0) e +| I (e1, e2) -> + if pol0 + then or_cnf unsat deduce + (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) + else and_cnf (xcnf unsat deduce normalise0 negate0 (negb pol0) e1) + (xcnf unsat deduce normalise0 negate0 pol0 e2) (** val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool **) let rec cnf_checker checker f l = match f with - | [] -> true - | e :: f0 -> - (match l with - | [] -> false - | c :: l0 -> - if checker e c then cnf_checker checker f0 l0 else false) + | [] -> true + | e::f0 -> + (match l with + | [] -> false + | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) (** val tauto_checker : - ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 - bFormula -> 'a3 list -> bool **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 + -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> + bool **) + +let tauto_checker unsat deduce normalise0 negate0 checker f w = + cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w + +(** val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) + +let cneqb ceqb x y = + negb (ceqb x y) -let tauto_checker normalise0 negate0 checker f w = - cnf_checker checker (xcnf normalise0 negate0 true f) w +(** val cltb : + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool **) + +let cltb ceqb cleb x y = + (&&) (cleb x y) (cneqb ceqb x y) type 'c polC = 'c pol type op1 = - | Equal - | NonEqual - | Strict - | NonStrict +| Equal +| NonEqual +| Strict +| NonStrict + +type 'c nFormula = 'c polC * op1 -type 'c nFormula = 'c polC * op1 +(** val opMult : op1 -> op1 -> op1 option **) + +let opMult o o' = + match o with + | Equal -> Some Equal + | NonEqual -> + (match o' with + | Strict -> None + | NonStrict -> None + | x -> Some x) + | Strict -> + (match o' with + | NonEqual -> None + | _ -> Some o') + | NonStrict -> + (match o' with + | NonEqual -> None + | Strict -> Some NonStrict + | x -> Some x) (** val opAdd : op1 -> op1 -> op1 option **) let opAdd o o' = match o with - | Equal -> Some o' - | NonEqual -> (match o' with - | Equal -> Some NonEqual - | _ -> None) - | Strict -> (match o' with - | NonEqual -> None - | _ -> Some Strict) - | NonStrict -> - (match o' with - | NonEqual -> None - | Strict -> Some Strict - | _ -> Some NonStrict) + | Equal -> Some o' + | NonEqual -> + (match o' with + | Equal -> Some NonEqual + | _ -> None) + | Strict -> + (match o' with + | NonEqual -> None + | _ -> Some Strict) + | NonStrict -> + (match o' with + | Equal -> Some NonStrict + | NonEqual -> None + | x -> Some x) type 'c psatz = - | PsatzIn of nat - | PsatzSquare of 'c polC - | PsatzMulC of 'c polC * 'c psatz - | PsatzMulE of 'c psatz * 'c psatz - | PsatzAdd of 'c psatz * 'c psatz - | PsatzC of 'c - | PsatzZ +| PsatzIn of nat +| PsatzSquare of 'c polC +| PsatzMulC of 'c polC * 'c psatz +| PsatzMulE of 'c psatz * 'c psatz +| PsatzAdd of 'c psatz * 'c psatz +| PsatzC of 'c +| PsatzZ + +(** val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option **) + +let map_option f = function +| Some x -> f x +| None -> None + +(** val map_option2 : + ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option **) + +let map_option2 f o o' = + match o with + | Some x -> + (match o' with + | Some x' -> f x x' + | None -> None) + | None -> None (** val pexpr_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **) let pexpr_times_nformula cO cI cplus ctimes ceqb e = function - | ef , o -> - (match o with - | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef) , Equal) - | _ -> None) +| ef,o -> + (match o with + | Equal -> Some ((pmul cO cI cplus ctimes ceqb e ef),Equal) + | _ -> None) (** val nformula_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = - let e1 , o1 = f1 in - let e2 , o2 = f2 in - (match o1 with - | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal) - | NonEqual -> - (match o2 with - | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal) - | NonEqual -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , - NonEqual) - | _ -> None) - | Strict -> - (match o2 with - | NonEqual -> None - | _ -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , o2)) - | NonStrict -> - (match o2 with - | Equal -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , Equal) - | NonEqual -> None - | _ -> Some ((pmul cO cI cplus ctimes ceqb e1 e2) , NonStrict))) + let e1,o1 = f1 in + let e2,o2 = f2 in + map_option (fun x -> Some ((pmul cO cI cplus ctimes ceqb e1 e2),x)) + (opMult o1 o2) (** val nformula_plus_nformula : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **) let nformula_plus_nformula cO cplus ceqb f1 f2 = - let e1 , o1 = f1 in - let e2 , o2 = f2 in - (match opAdd o1 o2 with - | Some x -> Some ((padd cO cplus ceqb e1 e2) , x) - | None -> None) + let e1,o1 = f1 in + let e2,o2 = f2 in + map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2) (** val eval_Psatz : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 @@ -1085,47 +3428,36 @@ let nformula_plus_nformula cO cplus ceqb f1 f2 = nFormula option **) let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function - | PsatzIn n0 -> Some (nth n0 l ((Pc cO) , Equal)) - | PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0) , NonStrict) - | PsatzMulC (re, e0) -> - (match eval_Psatz cO cI cplus ctimes ceqb cleb l e0 with - | Some x -> pexpr_times_nformula cO cI cplus ctimes ceqb re x - | None -> None) - | PsatzMulE (f1, f2) -> - (match eval_Psatz cO cI cplus ctimes ceqb cleb l f1 with - | Some x -> - (match eval_Psatz cO cI cplus ctimes ceqb cleb l f2 with - | Some x' -> - nformula_times_nformula cO cI cplus ctimes ceqb x x' - | None -> None) - | None -> None) - | PsatzAdd (f1, f2) -> - (match eval_Psatz cO cI cplus ctimes ceqb cleb l f1 with - | Some x -> - (match eval_Psatz cO cI cplus ctimes ceqb cleb l f2 with - | Some x' -> nformula_plus_nformula cO cplus ceqb x x' - | None -> None) - | None -> None) - | PsatzC c -> - if (&&) (cleb cO c) (negb (ceqb cO c)) - then Some ((Pc c) , Strict) - else None - | PsatzZ -> Some ((Pc cO) , Equal) +| PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal)) +| PsatzSquare e0 -> Some ((psquare cO cI cplus ctimes ceqb e0),NonStrict) +| PsatzMulC (re, e0) -> + map_option (pexpr_times_nformula cO cI cplus ctimes ceqb re) + (eval_Psatz cO cI cplus ctimes ceqb cleb l e0) +| PsatzMulE (f1, f2) -> + map_option2 (nformula_times_nformula cO cI cplus ctimes ceqb) + (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) + (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) +| PsatzAdd (f1, f2) -> + map_option2 (nformula_plus_nformula cO cplus ceqb) + (eval_Psatz cO cI cplus ctimes ceqb cleb l f1) + (eval_Psatz cO cI cplus ctimes ceqb cleb l f2) +| PsatzC c -> if cltb ceqb cleb cO c then Some ((Pc c),Strict) else None +| PsatzZ -> Some ((Pc cO),Equal) (** val check_inconsistent : 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool **) let check_inconsistent cO ceqb cleb = function - | e , op -> - (match e with - | Pc c -> - (match op with - | Equal -> negb (ceqb c cO) - | NonEqual -> ceqb c cO - | Strict -> cleb c cO - | NonStrict -> (&&) (cleb c cO) (negb (ceqb c cO))) - | _ -> false) +| e,op -> + (match e with + | Pc c -> + (match op with + | Equal -> cneqb ceqb c cO + | NonEqual -> ceqb c cO + | Strict -> cleb c cO + | NonStrict -> cltb ceqb cleb c cO) + | _ -> false) (** val check_normalised_formulas : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 @@ -1134,18 +3466,18 @@ let check_inconsistent cO ceqb cleb = function let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm = match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with - | Some f -> check_inconsistent cO ceqb cleb f - | None -> false + | Some f -> check_inconsistent cO ceqb cleb f + | None -> false type op2 = - | OpEq - | OpNEq - | OpLe - | OpGe - | OpLt - | OpGt +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt -type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr } +type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } (** val flhs : 'a1 formula -> 'a1 pExpr **) @@ -1163,157 +3495,170 @@ let frhs x = x.frhs 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **) -let norm cO cI cplus ctimes cminus copp ceqb pe = - norm_aux cO cI cplus ctimes cminus copp ceqb pe +let norm cO cI cplus ctimes cminus copp ceqb = + norm_aux cO cI cplus ctimes cminus copp ceqb (** val psub0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) -let psub0 cO cplus cminus copp ceqb p p' = - psub cO cplus cminus copp ceqb p p' +let psub0 cO cplus cminus copp ceqb = + psub cO cplus cminus copp ceqb (** val padd0 : 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **) -let padd0 cO cplus ceqb p p' = - padd cO cplus ceqb p p' +let padd0 cO cplus ceqb = + padd cO cplus ceqb (** val xnormalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list **) -let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in +let xnormalise cO cI cplus ctimes cminus copp ceqb t1 = + let { flhs = lhs; fop = o; frhs = rhs } = t1 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with - | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: - (((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: []) - | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Equal) :: [] - | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: [] - | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: [] - | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , NonStrict) :: - [] - | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , NonStrict) :: - []) + | OpEq -> + ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus + cminus copp + ceqb rhs0 + lhs0),Strict)::[]) + | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] + | OpLe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[] + | OpGe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] + | OpLt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] + | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[]) (** val cnf_normalise : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf **) -let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x :: []) (xnormalise cO cI cplus ctimes cminus copp ceqb t0) +let cnf_normalise cO cI cplus ctimes cminus copp ceqb t1 = + map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t1) (** val xnegate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula list **) -let xnegate cO cI cplus ctimes cminus copp ceqb t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in +let xnegate cO cI cplus ctimes cminus copp ceqb t1 = + let { flhs = lhs; fop = o; frhs = rhs } = t1 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with - | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Equal) :: [] - | OpNEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: - (((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: []) - | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , NonStrict) :: - [] - | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , NonStrict) :: - [] - | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0) , Strict) :: [] - | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0) , Strict) :: []) + | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] + | OpNEq -> + ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus + cminus copp + ceqb rhs0 + lhs0),Strict)::[]) + | OpLe -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[] + | OpGe -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),NonStrict)::[] + | OpLt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),Strict)::[] + | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[]) (** val cnf_negate : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula cnf **) -let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 = - map (fun x -> x :: []) (xnegate cO cI cplus ctimes cminus copp ceqb t0) +let cnf_negate cO cI cplus ctimes cminus copp ceqb t1 = + map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t1) (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) let rec xdenorm jmp = function - | Pc c -> PEc c - | Pinj (j, p2) -> xdenorm (pplus j jmp) p2 - | PX (p2, j, q0) -> PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), - (Npos j))))), (xdenorm (psucc jmp) q0)) +| Pc c -> PEc c +| Pinj (j, p2) -> xdenorm (Coq_Pos.add j jmp) p2 +| PX (p2, j, q0) -> + PEadd ((PEmul ((xdenorm jmp p2), (PEpow ((PEX jmp), (Npos j))))), + (xdenorm (Coq_Pos.succ jmp) q0)) (** val denorm : 'a1 pol -> 'a1 pExpr **) let denorm p = xdenorm XH p +(** val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr **) + +let rec map_PExpr c_of_S = function +| PEc c -> PEc (c_of_S c) +| PEX p -> PEX p +| PEadd (e1, e2) -> PEadd ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) +| PEsub (e1, e2) -> PEsub ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) +| PEmul (e1, e2) -> PEmul ((map_PExpr c_of_S e1), (map_PExpr c_of_S e2)) +| PEopp e0 -> PEopp (map_PExpr c_of_S e0) +| PEpow (e0, n0) -> PEpow ((map_PExpr c_of_S e0), n0) + +(** val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula **) + +let map_Formula c_of_S f = + let { flhs = l; fop = o; frhs = r } = f in + { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) } + (** val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz **) let simpl_cone cO cI ctimes ceqb e = match e with - | PsatzSquare t0 -> - (match t0 with - | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) - | _ -> PsatzSquare t0) - | PsatzMulE (t1, t2) -> - (match t1 with - | PsatzMulE (x, x0) -> - (match x with - | PsatzC p2 -> - (match t2 with - | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0) - | PsatzZ -> PsatzZ - | _ -> e) - | _ -> - (match x0 with - | PsatzC p2 -> - (match t2 with - | PsatzC c -> PsatzMulE ((PsatzC - (ctimes c p2)), x) - | PsatzZ -> PsatzZ - | _ -> e) - | _ -> - (match t2 with - | PsatzC c -> - if ceqb cI c - then t1 - else PsatzMulE (t1, t2) - | PsatzZ -> PsatzZ - | _ -> e))) - | PsatzC c -> - (match t2 with - | PsatzMulE (x, x0) -> - (match x with - | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0) - | _ -> - (match x0 with - | PsatzC p2 -> PsatzMulE ((PsatzC - (ctimes c p2)), x) - | _ -> - if ceqb cI c - then t2 - else PsatzMulE (t1, t2))) - | PsatzAdd (y, z0) -> PsatzAdd ((PsatzMulE ((PsatzC c), y)), - (PsatzMulE ((PsatzC c), z0))) - | PsatzC c0 -> PsatzC (ctimes c c0) - | PsatzZ -> PsatzZ - | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) +| PsatzSquare t1 -> + (match t1 with + | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) + | _ -> PsatzSquare t1) +| PsatzMulE (t1, t2) -> + (match t1 with + | PsatzMulE (x, x0) -> + (match x with + | PsatzC p2 -> + (match t2 with + | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x0) | PsatzZ -> PsatzZ + | _ -> e) + | _ -> + (match x0 with + | PsatzC p2 -> + (match t2 with + | PsatzC c -> PsatzMulE ((PsatzC (ctimes c p2)), x) + | PsatzZ -> PsatzZ + | _ -> e) + | _ -> + (match t2 with + | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) + | PsatzZ -> PsatzZ + | _ -> e))) + | PsatzC c -> + (match t2 with + | PsatzMulE (x, x0) -> + (match x with + | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x0) | _ -> - (match t2 with - | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) - | PsatzZ -> PsatzZ - | _ -> e)) - | PsatzAdd (t1, t2) -> - (match t1 with - | PsatzZ -> t2 - | _ -> (match t2 with - | PsatzZ -> t1 - | _ -> PsatzAdd (t1, t2))) - | _ -> e + (match x0 with + | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x) + | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))) + | PsatzAdd (y, z0) -> + PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0))) + | PsatzC c0 -> PsatzC (ctimes c c0) + | PsatzZ -> PsatzZ + | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) + | PsatzZ -> PsatzZ + | _ -> + (match t2 with + | PsatzC c -> if ceqb cI c then t1 else PsatzMulE (t1, t2) + | PsatzZ -> PsatzZ + | _ -> e)) +| PsatzAdd (t1, t2) -> + (match t1 with + | PsatzZ -> t2 + | _ -> + (match t2 with + | PsatzZ -> t1 + | _ -> PsatzAdd (t1, t2))) +| _ -> e type q = { qnum : z; qden : positive } @@ -1328,28 +3673,28 @@ let qden x = x.qden (** val qeq_bool : q -> q -> bool **) let qeq_bool x y = - zeq_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)) + zeq_bool (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) (** val qle_bool : q -> q -> bool **) let qle_bool x y = - zle_bool (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden)) + Z.leb (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)) (** val qplus : q -> q -> q **) let qplus x y = - { qnum = (zplus (zmult x.qnum (Zpos y.qden)) (zmult y.qnum (Zpos x.qden))); - qden = (pmult x.qden y.qden) } + { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); + qden = (Coq_Pos.mul x.qden y.qden) } (** val qmult : q -> q -> q **) let qmult x y = - { qnum = (zmult x.qnum y.qnum); qden = (pmult x.qden y.qden) } + { qnum = (Z.mul x.qnum y.qnum); qden = (Coq_Pos.mul x.qden y.qden) } (** val qopp : q -> q **) let qopp x = - { qnum = (zopp x.qnum); qden = x.qden } + { qnum = (Z.opp x.qnum); qden = x.qden } (** val qminus : q -> q -> q **) @@ -1360,9 +3705,9 @@ let qminus x y = let qinv x = match x.qnum with - | Z0 -> { qnum = Z0; qden = XH } - | Zpos p -> { qnum = (Zpos x.qden); qden = p } - | Zneg p -> { qnum = (Zneg x.qden); qden = p } + | Z0 -> { qnum = Z0; qden = XH } + | Zpos p -> { qnum = (Zpos x.qden); qden = p } + | Zneg p -> { qnum = (Zneg x.qden); qden = p } (** val qpower_positive : q -> positive -> q **) @@ -1372,332 +3717,330 @@ let qpower_positive q0 p = (** val qpower : q -> z -> q **) let qpower q0 = function - | Z0 -> { qnum = (Zpos XH); qden = XH } - | Zpos p -> qpower_positive q0 p - | Zneg p -> qinv (qpower_positive q0 p) +| Z0 -> { qnum = (Zpos XH); qden = XH } +| Zpos p -> qpower_positive q0 p +| Zneg p -> qinv (qpower_positive q0 p) -(** val pgcdn : nat -> positive -> positive -> positive **) +type 'a t0 = +| Empty +| Leaf of 'a +| Node of 'a t0 * 'a * 'a t0 -let rec pgcdn n0 a b = - match n0 with - | O -> XH - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match pcompare a' b' Eq with - | Eq -> a - | Lt -> pgcdn n1 (pminus b' a') a - | Gt -> pgcdn n1 (pminus a' b') b) - | XO b0 -> pgcdn n1 a b0 - | XH -> XH) - | XO a0 -> - (match b with - | XI p -> pgcdn n1 a0 b - | XO b0 -> XO (pgcdn n1 a0 b0) - | XH -> XH) - | XH -> XH) - -(** val pgcd : positive -> positive -> positive **) - -let pgcd a b = - pgcdn (plus (psize a) (psize b)) a b - -(** val zgcd : z -> z -> z **) - -let zgcd a b = - match a with - | Z0 -> zabs b - | Zpos a0 -> - (match b with - | Z0 -> zabs a - | Zpos b0 -> Zpos (pgcd a0 b0) - | Zneg b0 -> Zpos (pgcd a0 b0)) - | Zneg a0 -> - (match b with - | Z0 -> zabs a - | Zpos b0 -> Zpos (pgcd a0 b0) - | Zneg b0 -> Zpos (pgcd a0 b0)) - -type 'a t = - | Empty - | Leaf of 'a - | Node of 'a t * 'a * 'a t - -(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) +(** val find : 'a1 -> 'a1 t0 -> positive -> 'a1 **) let rec find default vm p = match vm with - | Empty -> default - | Leaf i -> i - | Node (l, e, r) -> - (match p with - | XI p2 -> find default r p2 - | XO p2 -> find default l p2 - | XH -> e) + | Empty -> default + | Leaf i -> i + | Node (l, e, r) -> + (match p with + | XI p2 -> find default r p2 + | XO p2 -> find default l p2 + | XH -> e) type zWitness = z psatz (** val zWeakChecker : z nFormula list -> z psatz -> bool **) -let zWeakChecker x x0 = - check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0 +let zWeakChecker = + check_normalised_formulas Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb (** val psub1 : z pol -> z pol -> z pol **) -let psub1 p p' = - psub0 Z0 zplus zminus zopp zeq_bool p p' +let psub1 = + psub0 Z0 Z.add Z.sub Z.opp zeq_bool (** val padd1 : z pol -> z pol -> z pol **) -let padd1 p p' = - padd0 Z0 zplus zeq_bool p p' +let padd1 = + padd0 Z0 Z.add zeq_bool (** val norm0 : z pExpr -> z pol **) -let norm0 pe = - norm Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool pe +let norm0 = + norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool (** val xnormalise0 : z formula -> z nFormula list **) -let xnormalise0 t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in +let xnormalise0 t1 = + let { flhs = lhs; fop = o; frhs = rhs } = t1 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with - | OpEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: - (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: []) - | OpNEq -> ((psub1 lhs0 rhs0) , Equal) :: [] - | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: [] - | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: [] - | OpLt -> ((psub1 lhs0 rhs0) , NonStrict) :: [] - | OpGt -> ((psub1 rhs0 lhs0) , NonStrict) :: []) + | OpEq -> + ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 + (padd1 lhs0 + (Pc (Zpos + XH)))),NonStrict)::[]) + | OpNEq -> ((psub1 lhs0 rhs0),Equal)::[] + | OpLe -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[] + | OpGe -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] + | OpLt -> ((psub1 lhs0 rhs0),NonStrict)::[] + | OpGt -> ((psub1 rhs0 lhs0),NonStrict)::[]) (** val normalise : z formula -> z nFormula cnf **) -let normalise t0 = - map (fun x -> x :: []) (xnormalise0 t0) +let normalise t1 = + map (fun x -> x::[]) (xnormalise0 t1) (** val xnegate0 : z formula -> z nFormula list **) -let xnegate0 t0 = - let { flhs = lhs; fop = o; frhs = rhs } = t0 in +let xnegate0 t1 = + let { flhs = lhs; fop = o; frhs = rhs } = t1 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with - | OpEq -> ((psub1 lhs0 rhs0) , Equal) :: [] - | OpNEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: - (((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: []) - | OpLe -> ((psub1 rhs0 lhs0) , NonStrict) :: [] - | OpGe -> ((psub1 lhs0 rhs0) , NonStrict) :: [] - | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))) , NonStrict) :: [] - | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))) , NonStrict) :: []) + | OpEq -> ((psub1 lhs0 rhs0),Equal)::[] + | OpNEq -> + ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 + (padd1 lhs0 + (Pc (Zpos + XH)))),NonStrict)::[]) + | OpLe -> ((psub1 rhs0 lhs0),NonStrict)::[] + | OpGe -> ((psub1 lhs0 rhs0),NonStrict)::[] + | OpLt -> ((psub1 rhs0 (padd1 lhs0 (Pc (Zpos XH)))),NonStrict)::[] + | OpGt -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::[]) (** val negate : z formula -> z nFormula cnf **) -let negate t0 = - map (fun x -> x :: []) (xnegate0 t0) +let negate t1 = + map (fun x -> x::[]) (xnegate0 t1) + +(** val zunsat : z nFormula -> bool **) + +let zunsat = + check_inconsistent Z0 zeq_bool Z.leb + +(** val zdeduce : z nFormula -> z nFormula -> z nFormula option **) + +let zdeduce = + nformula_plus_nformula Z0 Z.add zeq_bool (** val ceiling : z -> z -> z **) let ceiling a b = - let q0 , r = zdiv_eucl a b in + let q0,r = Z.div_eucl a b in (match r with - | Z0 -> q0 - | _ -> zplus q0 (Zpos XH)) + | Z0 -> q0 + | _ -> Z.add q0 (Zpos XH)) type zArithProof = - | DoneProof - | RatProof of zWitness * zArithProof - | CutProof of zWitness * zArithProof - | EnumProof of zWitness * zWitness * zArithProof list +| DoneProof +| RatProof of zWitness * zArithProof +| CutProof of zWitness * zArithProof +| EnumProof of zWitness * zWitness * zArithProof list (** val zgcdM : z -> z -> z **) let zgcdM x y = - zmax (zgcd x y) (Zpos XH) + Z.max (Z.gcd x y) (Zpos XH) -(** val zgcd_pol : z polC -> z * z **) +(** val zgcd_pol : z polC -> z * z **) let rec zgcd_pol = function - | Pc c -> Z0 , c - | Pinj (p2, p3) -> zgcd_pol p3 - | PX (p2, p3, q0) -> - let g1 , c1 = zgcd_pol p2 in - let g2 , c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2) , c2 +| Pc c -> Z0,c +| Pinj (p2, p3) -> zgcd_pol p3 +| PX (p2, p3, q0) -> + let g1,c1 = zgcd_pol p2 in + let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2 (** val zdiv_pol : z polC -> z -> z polC **) let rec zdiv_pol p x = match p with - | Pc c -> Pc (zdiv c x) - | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x)) - | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x)) + | Pc c -> Pc (Z.div c x) + | Pinj (j, p2) -> Pinj (j, (zdiv_pol p2 x)) + | PX (p2, j, q0) -> PX ((zdiv_pol p2 x), j, (zdiv_pol q0 x)) -(** val makeCuttingPlane : z polC -> z polC * z **) +(** val makeCuttingPlane : z polC -> z polC * z **) let makeCuttingPlane p = - let g , c = zgcd_pol p in - if zgt_bool g Z0 - then (zdiv_pol (psubC zminus p c) g) , (zopp (ceiling (zopp c) g)) - else p , Z0 + let g,c = zgcd_pol p in + if Z.gtb g Z0 + then (zdiv_pol (psubC Z.sub p c) g),(Z.opp (ceiling (Z.opp c) g)) + else p,Z0 -(** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **) +(** val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option **) let genCuttingPlane = function - | e , op -> - (match op with - | Equal -> - let g , c = zgcd_pol e in - if (&&) (zgt_bool g Z0) - ((&&) (zgt_bool c Z0) (negb (zeq_bool (zgcd g c) g))) - then None - else Some ((e , Z0) , op) - | NonEqual -> Some ((e , Z0) , op) - | Strict -> - let p , c = makeCuttingPlane (psubC zminus e (Zpos XH)) in - Some ((p , c) , NonStrict) - | NonStrict -> - let p , c = makeCuttingPlane e in Some ((p , c) , NonStrict)) - -(** val nformula_of_cutting_plane : - ((z polC * z) * op1) -> z nFormula **) +| e,op -> + (match op with + | Equal -> + let g,c = zgcd_pol e in + if (&&) (Z.gtb g Z0) + ((&&) (negb (zeq_bool c Z0)) (negb (zeq_bool (Z.gcd g c) g))) + then None + else Some ((makeCuttingPlane e),Equal) + | NonEqual -> Some ((e,Z0),op) + | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) + | NonStrict -> Some ((makeCuttingPlane e),NonStrict)) + +(** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **) let nformula_of_cutting_plane = function - | e_z , o -> let e , z0 = e_z in (padd1 e (Pc z0)) , o +| e_z,o -> let e,z0 = e_z in (padd1 e (Pc z0)),o (** val is_pol_Z0 : z polC -> bool **) let is_pol_Z0 = function - | Pc z0 -> (match z0 with - | Z0 -> true - | _ -> false) - | _ -> false +| Pc z0 -> + (match z0 with + | Z0 -> true + | _ -> false) +| _ -> false (** val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option **) -let eval_Psatz0 x x0 = - eval_Psatz Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0 +let eval_Psatz0 = + eval_Psatz Z0 (Zpos XH) Z.add Z.mul zeq_bool Z.leb -(** val check_inconsistent0 : z nFormula -> bool **) +(** val valid_cut_sign : op1 -> bool **) -let check_inconsistent0 f = - check_inconsistent Z0 zeq_bool zle_bool f +let valid_cut_sign = function +| Equal -> true +| NonStrict -> true +| _ -> false (** val zChecker : z nFormula list -> zArithProof -> bool **) let rec zChecker l = function - | DoneProof -> false - | RatProof (w, pf0) -> - (match eval_Psatz0 l w with - | Some f -> - if check_inconsistent0 f then true else zChecker (f :: l) pf0 - | None -> false) - | CutProof (w, pf0) -> - (match eval_Psatz0 l w with - | Some f -> - (match genCuttingPlane f with - | Some cp -> - zChecker ((nformula_of_cutting_plane cp) :: l) pf0 - | None -> true) - | None -> false) - | EnumProof (w1, w2, pf0) -> - (match eval_Psatz0 l w1 with - | Some f1 -> - (match eval_Psatz0 l w2 with - | Some f2 -> - (match genCuttingPlane f1 with - | Some p -> - let p2 , op3 = p in - let e1 , z1 = p2 in - (match genCuttingPlane f2 with - | Some p3 -> - let p4 , op4 = p3 in - let e2 , z2 = p4 in - (match op3 with - | NonStrict -> - (match op4 with - | NonStrict -> - if is_pol_Z0 (padd1 e1 e2) - then - let rec label pfs lb ub = - - match pfs with - | - [] -> zgt_bool lb ub - | - pf1 :: rsr -> - (&&) - (zChecker - (((psub1 e1 (Pc lb)) , - Equal) :: l) pf1) - (label rsr - (zplus lb (Zpos XH)) ub) - in label pf0 (zopp z1) z2 - else false - | _ -> false) - | _ -> false) - | None -> false) - | None -> false) - | None -> false) - | None -> false) +| DoneProof -> false +| RatProof (w, pf0) -> + (match eval_Psatz0 l w with + | Some f -> if zunsat f then true else zChecker (f::l) pf0 + | None -> false) +| CutProof (w, pf0) -> + (match eval_Psatz0 l w with + | Some f -> + (match genCuttingPlane f with + | Some cp -> zChecker ((nformula_of_cutting_plane cp)::l) pf0 + | None -> true) + | None -> false) +| EnumProof (w1, w2, pf0) -> + (match eval_Psatz0 l w1 with + | Some f1 -> + (match eval_Psatz0 l w2 with + | Some f2 -> + (match genCuttingPlane f1 with + | Some p -> + let p2,op3 = p in + let e1,z1 = p2 in + (match genCuttingPlane f2 with + | Some p3 -> + let p4,op4 = p3 in + let e2,z2 = p4 in + if (&&) ((&&) (valid_cut_sign op3) (valid_cut_sign op4)) + (is_pol_Z0 (padd1 e1 e2)) + then let rec label pfs lb ub = + match pfs with + | [] -> Z.gtb lb ub + | pf1::rsr -> + (&&) (zChecker (((psub1 e1 (Pc lb)),Equal)::l) pf1) + (label rsr (Z.add lb (Zpos XH)) ub) + in label pf0 (Z.opp z1) z2 + else false + | None -> true) + | None -> true) + | None -> false) + | None -> false) (** val zTautoChecker : z formula bFormula -> zArithProof list -> bool **) let zTautoChecker f w = - tauto_checker normalise negate zChecker f w - -(** val n_of_Z : z -> n **) - -let n_of_Z = function - | Zpos p -> Npos p - | _ -> N0 + tauto_checker zunsat zdeduce normalise negate zChecker f w type qWitness = q psatz (** val qWeakChecker : q nFormula list -> q psatz -> bool **) -let qWeakChecker x x0 = +let qWeakChecker = check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); - qden = XH } qplus qmult qeq_bool qle_bool x x0 + qden = XH } qplus qmult qeq_bool qle_bool (** val qnormalise : q formula -> q nFormula cnf **) -let qnormalise t0 = +let qnormalise = cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } - qplus qmult qminus qopp qeq_bool t0 + qplus qmult qminus qopp qeq_bool (** val qnegate : q formula -> q nFormula cnf **) -let qnegate t0 = +let qnegate = cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool t0 + qmult qminus qopp qeq_bool + +(** val qunsat : q nFormula -> bool **) + +let qunsat = + check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool + +(** val qdeduce : q nFormula -> q nFormula -> q nFormula option **) + +let qdeduce = + nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) let qTautoChecker f w = - tauto_checker qnormalise qnegate qWeakChecker f w + tauto_checker qunsat qdeduce qnormalise qnegate qWeakChecker f w + +type rcst = +| C0 +| C1 +| CQ of q +| CZ of z +| CPlus of rcst * rcst +| CMinus of rcst * rcst +| CMult of rcst * rcst +| CInv of rcst +| COpp of rcst + +(** val q_of_Rcst : rcst -> q **) + +let rec q_of_Rcst = function +| C0 -> { qnum = Z0; qden = XH } +| C1 -> { qnum = (Zpos XH); qden = XH } +| CQ q0 -> q0 +| CZ z0 -> { qnum = z0; qden = XH } +| CPlus (r1, r2) -> qplus (q_of_Rcst r1) (q_of_Rcst r2) +| CMinus (r1, r2) -> qminus (q_of_Rcst r1) (q_of_Rcst r2) +| CMult (r1, r2) -> qmult (q_of_Rcst r1) (q_of_Rcst r2) +| CInv r0 -> qinv (q_of_Rcst r0) +| COpp r0 -> qopp (q_of_Rcst r0) + +type rWitness = q psatz + +(** val rWeakChecker : q nFormula list -> q psatz -> bool **) + +let rWeakChecker = + check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH); + qden = XH } qplus qmult qeq_bool qle_bool + +(** val rnormalise : q formula -> q nFormula cnf **) -type rWitness = z psatz +let rnormalise = + cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } + qplus qmult qminus qopp qeq_bool -(** val rWeakChecker : z nFormula list -> z psatz -> bool **) +(** val rnegate : q formula -> q nFormula cnf **) -let rWeakChecker x x0 = - check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0 +let rnegate = + cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus + qmult qminus qopp qeq_bool -(** val rnormalise : z formula -> z nFormula cnf **) +(** val runsat : q nFormula -> bool **) -let rnormalise t0 = - cnf_normalise Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0 +let runsat = + check_inconsistent { qnum = Z0; qden = XH } qeq_bool qle_bool -(** val rnegate : z formula -> z nFormula cnf **) +(** val rdeduce : q nFormula -> q nFormula -> q nFormula option **) -let rnegate t0 = - cnf_negate Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0 +let rdeduce = + nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool -(** val rTautoChecker : z formula bFormula -> rWitness list -> bool **) +(** val rTautoChecker : rcst formula bFormula -> rWitness list -> bool **) let rTautoChecker f w = - tauto_checker rnormalise rnegate rWeakChecker f w + tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker + (map_bformula (map_Formula q_of_Rcst) f) w diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 3e3ae2c3..bcd61f39 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,115 +1,848 @@ +type __ = Obj.t + val negb : bool -> bool type nat = - | O - | S of nat +| O +| S of nat -type comparison = - | Eq - | Lt - | Gt +val fst : ('a1 * 'a2) -> 'a1 -val compOpp : comparison -> comparison - -val plus : nat -> nat -> nat +val snd : ('a1 * 'a2) -> 'a2 val app : 'a1 list -> 'a1 list -> 'a1 list -val nth : nat -> 'a1 list -> 'a1 -> 'a1 - -val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list - -type positive = - | XI of positive - | XO of positive - | XH - -val psucc : positive -> positive - -val pplus : positive -> positive -> positive - -val pplus_carry : positive -> positive -> positive - -val p_of_succ_nat : nat -> positive - -val pdouble_minus_one : positive -> positive - -type positive_mask = - | IsNul - | IsPos of positive - | IsNeg +type comparison = +| Eq +| Lt +| Gt -val pdouble_plus_one_mask : positive_mask -> positive_mask +val compOpp : comparison -> comparison -val pdouble_mask : positive_mask -> positive_mask +type compareSpecT = +| CompEqT +| CompLtT +| CompGtT -val pdouble_minus_two : positive -> positive_mask +val compareSpec2Type : comparison -> compareSpecT -val pminus_mask : positive -> positive -> positive_mask +type 'a compSpecT = compareSpecT -val pminus_mask_carry : positive -> positive -> positive_mask +val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT -val pminus : positive -> positive -> positive +type 'a sig0 = + 'a + (* singleton inductive, whose constructor was exist *) -val pmult : positive -> positive -> positive +val plus : nat -> nat -> nat -val pcompare : positive -> positive -> comparison -> comparison +val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 -val psize : positive -> nat +type positive = +| XI of positive +| XO of positive +| XH type n = - | N0 - | Npos of positive - -val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 +| N0 +| Npos of positive type z = - | Z0 - | Zpos of positive - | Zneg of positive - -val zdouble_plus_one : z -> z - -val zdouble_minus_one : z -> z - -val zdouble : z -> z - -val zPminus : positive -> positive -> z - -val zplus : z -> z -> z - -val zopp : z -> z - -val zminus : z -> z -> z - -val zmult : z -> z -> z - -val zcompare : z -> z -> comparison - -val zabs : z -> z +| Z0 +| Zpos of positive +| Zneg of positive + +module type TotalOrder' = + sig + type t + end + +module MakeOrderTac : + functor (O:TotalOrder') -> + sig + + end + +module MaxLogicalProperties : + functor (O:TotalOrder') -> + functor (M:sig + val max : O.t -> O.t -> O.t + end) -> + sig + module T : + sig + + end + end + +module Pos : + sig + type t = positive + + val succ : positive -> positive + + val add : positive -> positive -> positive + + val add_carry : positive -> positive -> positive + + val pred_double : positive -> positive + + val pred : positive -> positive + + val pred_N : positive -> n + + type mask = + | IsNul + | IsPos of positive + | IsNeg + + val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 + + val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 + + val succ_double_mask : mask -> mask + + val double_mask : mask -> mask + + val double_pred_mask : positive -> mask + + val pred_mask : mask -> mask + + val sub_mask : positive -> positive -> mask + + val sub_mask_carry : positive -> positive -> mask + + val sub : positive -> positive -> positive + + val mul : positive -> positive -> positive + + val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 + + val pow : positive -> positive -> positive + + val div2 : positive -> positive + + val div2_up : positive -> positive + + val size_nat : positive -> nat + + val size : positive -> positive + + val compare_cont : positive -> positive -> comparison -> comparison + + val compare : positive -> positive -> comparison + + val min : positive -> positive -> positive + + val max : positive -> positive -> positive + + val eqb : positive -> positive -> bool + + val leb : positive -> positive -> bool + + val ltb : positive -> positive -> bool + + val sqrtrem_step : + (positive -> positive) -> (positive -> positive) -> (positive * mask) -> + positive * mask + + val sqrtrem : positive -> positive * mask + + val sqrt : positive -> positive + + val gcdn : nat -> positive -> positive -> positive + + val gcd : positive -> positive -> positive + + val ggcdn : nat -> positive -> positive -> positive * (positive * positive) + + val ggcd : positive -> positive -> positive * (positive * positive) + + val coq_Nsucc_double : n -> n + + val coq_Ndouble : n -> n + + val coq_lor : positive -> positive -> positive + + val coq_land : positive -> positive -> n + + val ldiff : positive -> positive -> n + + val coq_lxor : positive -> positive -> n + + val shiftl_nat : positive -> nat -> positive + + val shiftr_nat : positive -> nat -> positive + + val shiftl : positive -> n -> positive + + val shiftr : positive -> n -> positive + + val testbit_nat : positive -> nat -> bool + + val testbit : positive -> n -> bool + + val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 + + val to_nat : positive -> nat + + val of_nat : nat -> positive + + val of_succ_nat : nat -> positive + end + +module Coq_Pos : + sig + module Coq__1 : sig + type t = positive + end + type t = Coq__1.t + + val succ : positive -> positive + + val add : positive -> positive -> positive + + val add_carry : positive -> positive -> positive + + val pred_double : positive -> positive + + val pred : positive -> positive + + val pred_N : positive -> n + + type mask = Pos.mask = + | IsNul + | IsPos of positive + | IsNeg + + val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 + + val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 + + val succ_double_mask : mask -> mask + + val double_mask : mask -> mask + + val double_pred_mask : positive -> mask + + val pred_mask : mask -> mask + + val sub_mask : positive -> positive -> mask + + val sub_mask_carry : positive -> positive -> mask + + val sub : positive -> positive -> positive + + val mul : positive -> positive -> positive + + val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 + + val pow : positive -> positive -> positive + + val div2 : positive -> positive + + val div2_up : positive -> positive + + val size_nat : positive -> nat + + val size : positive -> positive + + val compare_cont : positive -> positive -> comparison -> comparison + + val compare : positive -> positive -> comparison + + val min : positive -> positive -> positive + + val max : positive -> positive -> positive + + val eqb : positive -> positive -> bool + + val leb : positive -> positive -> bool + + val ltb : positive -> positive -> bool + + val sqrtrem_step : + (positive -> positive) -> (positive -> positive) -> (positive * mask) -> + positive * mask + + val sqrtrem : positive -> positive * mask + + val sqrt : positive -> positive + + val gcdn : nat -> positive -> positive -> positive + + val gcd : positive -> positive -> positive + + val ggcdn : nat -> positive -> positive -> positive * (positive * positive) + + val ggcd : positive -> positive -> positive * (positive * positive) + + val coq_Nsucc_double : n -> n + + val coq_Ndouble : n -> n + + val coq_lor : positive -> positive -> positive + + val coq_land : positive -> positive -> n + + val ldiff : positive -> positive -> n + + val coq_lxor : positive -> positive -> n + + val shiftl_nat : positive -> nat -> positive + + val shiftr_nat : positive -> nat -> positive + + val shiftl : positive -> n -> positive + + val shiftr : positive -> n -> positive + + val testbit_nat : positive -> nat -> bool + + val testbit : positive -> n -> bool + + val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 + + val to_nat : positive -> nat + + val of_nat : nat -> positive + + val of_succ_nat : nat -> positive + + val eq_dec : positive -> positive -> bool + + val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 + + val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 + + type coq_PeanoView = + | PeanoOne + | PeanoSucc of positive * coq_PeanoView + + val coq_PeanoView_rect : + 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> + coq_PeanoView -> 'a1 + + val coq_PeanoView_rec : + 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> + coq_PeanoView -> 'a1 + + val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView + + val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView + + val peanoView : positive -> coq_PeanoView + + val coq_PeanoView_iter : + 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 + + val switch_Eq : comparison -> comparison -> comparison + + val mask2cmp : mask -> comparison + + module T : + sig + + end + + module ORev : + sig + type t = Coq__1.t + end + + module MRev : + sig + val max : t -> t -> t + end + + module MPRev : + sig + module T : + sig + + end + end + + module P : + sig + val max_case_strong : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val max_case : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val max_dec : t -> t -> bool + + val min_case_strong : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val min_case : + t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val min_dec : t -> t -> bool + end + + val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 + + val max_dec : t -> t -> bool + + val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 + + val min_dec : t -> t -> bool + end + +module N : + sig + type t = n + + val zero : n + + val one : n + + val two : n + + val succ_double : n -> n + + val double : n -> n + + val succ : n -> n + + val pred : n -> n + + val succ_pos : n -> positive + + val add : n -> n -> n + + val sub : n -> n -> n + + val mul : n -> n -> n + + val compare : n -> n -> comparison + + val eqb : n -> n -> bool + + val leb : n -> n -> bool + + val ltb : n -> n -> bool + + val min : n -> n -> n + + val max : n -> n -> n + + val div2 : n -> n + + val even : n -> bool + + val odd : n -> bool + + val pow : n -> n -> n + + val log2 : n -> n + + val size : n -> n + + val size_nat : n -> nat + + val pos_div_eucl : positive -> n -> n * n + + val div_eucl : n -> n -> n * n + + val div : n -> n -> n + + val modulo : n -> n -> n + + val gcd : n -> n -> n + + val ggcd : n -> n -> n * (n * n) + + val sqrtrem : n -> n * n + + val sqrt : n -> n + + val coq_lor : n -> n -> n + + val coq_land : n -> n -> n + + val ldiff : n -> n -> n + + val coq_lxor : n -> n -> n + + val shiftl_nat : n -> nat -> n + + val shiftr_nat : n -> nat -> n + + val shiftl : n -> n -> n + + val shiftr : n -> n -> n + + val testbit_nat : n -> nat -> bool + + val testbit : n -> n -> bool + + val to_nat : n -> nat + + val of_nat : nat -> n + + val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 + + val eq_dec : n -> n -> bool + + val discr : n -> positive option + + val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + module BootStrap : + sig + + end + + val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 + + module OrderElts : + sig + type t = n + end + + module OrderTac : + sig + + end + + module NZPowP : + sig + + end + + module NZSqrtP : + sig + + end + + val sqrt_up : n -> n + + val log2_up : n -> n + + module NZDivP : + sig + + end + + val lcm : n -> n -> n + + val b2n : bool -> n + + val setbit : n -> n -> n + + val clearbit : n -> n -> n + + val ones : n -> n + + val lnot : n -> n -> n + + module T : + sig + + end + + module ORev : + sig + type t = n + end + + module MRev : + sig + val max : n -> n -> n + end + + module MPRev : + sig + module T : + sig + + end + end + + module P : + sig + val max_case_strong : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val max_case : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val max_dec : n -> n -> bool + + val min_case_strong : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val min_case : + n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val min_dec : n -> n -> bool + end + + val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 + + val max_dec : n -> n -> bool + + val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 + + val min_dec : n -> n -> bool + end -val zmax : z -> z -> z +val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 -val zle_bool : z -> z -> bool +val nth : nat -> 'a1 list -> 'a1 -> 'a1 -val zge_bool : z -> z -> bool +val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list -val zgt_bool : z -> z -> bool +val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 + +module Z : + sig + type t = z + + val zero : z + + val one : z + + val two : z + + val double : z -> z + + val succ_double : z -> z + + val pred_double : z -> z + + val pos_sub : positive -> positive -> z + + val add : z -> z -> z + + val opp : z -> z + + val succ : z -> z + + val pred : z -> z + + val sub : z -> z -> z + + val mul : z -> z -> z + + val pow_pos : z -> positive -> z + + val pow : z -> z -> z + + val compare : z -> z -> comparison + + val sgn : z -> z + + val leb : z -> z -> bool + + val geb : z -> z -> bool + + val ltb : z -> z -> bool + + val gtb : z -> z -> bool + + val eqb : z -> z -> bool + + val max : z -> z -> z + + val min : z -> z -> z + + val abs : z -> z + + val abs_nat : z -> nat + + val abs_N : z -> n + + val to_nat : z -> nat + + val to_N : z -> n + + val of_nat : nat -> z + + val of_N : n -> z + + val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 + + val pos_div_eucl : positive -> z -> z * z + + val div_eucl : z -> z -> z * z + + val div : z -> z -> z + + val modulo : z -> z -> z + + val quotrem : z -> z -> z * z + + val quot : z -> z -> z + + val rem : z -> z -> z + + val even : z -> bool + + val odd : z -> bool + + val div2 : z -> z + + val quot2 : z -> z + + val log2 : z -> z + + val sqrtrem : z -> z * z + + val sqrt : z -> z + + val gcd : z -> z -> z + + val ggcd : z -> z -> z * (z * z) + + val testbit : z -> z -> bool + + val shiftl : z -> z -> z + + val shiftr : z -> z -> z + + val coq_lor : z -> z -> z + + val coq_land : z -> z -> z + + val ldiff : z -> z -> z + + val coq_lxor : z -> z -> z + + val eq_dec : z -> z -> bool + + module BootStrap : + sig + + end + + module OrderElts : + sig + type t = z + end + + module OrderTac : + sig + + end + + val sqrt_up : z -> z + + val log2_up : z -> z + + module NZDivP : + sig + + end + + module Quot2Div : + sig + val div : z -> z -> z + + val modulo : z -> z -> z + end + + module NZQuot : + sig + + end + + val lcm : z -> z -> z + + val b2z : bool -> z + + val setbit : z -> z -> z + + val clearbit : z -> z -> z + + val lnot : z -> z + + val ones : z -> z + + module T : + sig + + end + + module ORev : + sig + type t = z + end + + module MRev : + sig + val max : z -> z -> z + end + + module MPRev : + sig + module T : + sig + + end + end + + module P : + sig + val max_case_strong : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val max_case : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val max_dec : z -> z -> bool + + val min_case_strong : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> + 'a1 + + val min_case : + z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 + + val min_dec : z -> z -> bool + end + + val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 + + val max_dec : z -> z -> bool + + val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 + + val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 + + val min_dec : z -> z -> bool + end val zeq_bool : z -> z -> bool -val n_of_nat : nat -> n - -val zdiv_eucl_POS : positive -> z -> z * z - -val zdiv_eucl : z -> z -> z * z - -val zdiv : z -> z -> z - type 'c pol = - | Pc of 'c - | Pinj of positive * 'c pol - | PX of 'c pol * positive * 'c pol +| Pc of 'c +| Pinj of positive * 'c pol +| PX of 'c pol * positive * 'c pol val p0 : 'a1 -> 'a1 pol @@ -117,6 +850,8 @@ val p1 : 'a1 -> 'a1 pol val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool +val mkPinj : positive -> 'a1 pol -> 'a1 pol + val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol val mkPX : @@ -177,13 +912,13 @@ val psquare : bool) -> 'a1 pol -> 'a1 pol type 'c pExpr = - | PEc of 'c - | PEX of positive - | PEadd of 'c pExpr * 'c pExpr - | PEsub of 'c pExpr * 'c pExpr - | PEmul of 'c pExpr * 'c pExpr - | PEopp of 'c pExpr - | PEpow of 'c pExpr * n +| PEc of 'c +| PEX of positive +| PEadd of 'c pExpr * 'c pExpr +| PEsub of 'c pExpr * 'c pExpr +| PEmul of 'c pExpr * 'c pExpr +| PEopp of 'c pExpr +| PEpow of 'c pExpr * n val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol @@ -200,14 +935,16 @@ val norm_aux : 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type 'a bFormula = - | TT - | FF - | X - | A of 'a - | Cj of 'a bFormula * 'a bFormula - | D of 'a bFormula * 'a bFormula - | N of 'a bFormula - | I of 'a bFormula * 'a bFormula +| TT +| FF +| X +| A of 'a +| Cj of 'a bFormula * 'a bFormula +| D of 'a bFormula * 'a bFormula +| N of 'a bFormula +| I of 'a bFormula * 'a bFormula + +val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula type 'term' clause = 'term' list @@ -217,41 +954,65 @@ val tt : 'a1 cnf val ff : 'a1 cnf -val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf +val add_term : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 + clause option -val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf +val or_clause : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> + 'a1 clause option + +val or_clause_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 + cnf + +val or_cnf : + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 + cnf val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf val xcnf : - ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> + 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool val tauto_checker : - ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 - bFormula -> 'a3 list -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> + 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool + +val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool + +val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool type 'c polC = 'c pol type op1 = - | Equal - | NonEqual - | Strict - | NonStrict +| Equal +| NonEqual +| Strict +| NonStrict + +type 'c nFormula = 'c polC * op1 -type 'c nFormula = 'c polC * op1 +val opMult : op1 -> op1 -> op1 option val opAdd : op1 -> op1 -> op1 option type 'c psatz = - | PsatzIn of nat - | PsatzSquare of 'c polC - | PsatzMulC of 'c polC * 'c psatz - | PsatzMulE of 'c psatz * 'c psatz - | PsatzAdd of 'c psatz * 'c psatz - | PsatzC of 'c - | PsatzZ +| PsatzIn of nat +| PsatzSquare of 'c polC +| PsatzMulC of 'c polC * 'c psatz +| PsatzMulE of 'c psatz * 'c psatz +| PsatzAdd of 'c psatz * 'c psatz +| PsatzC of 'c +| PsatzZ + +val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option + +val map_option2 : + ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option val pexpr_times_nformula : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> @@ -278,14 +1039,14 @@ val check_normalised_formulas : bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool type op2 = - | OpEq - | OpNEq - | OpLe - | OpGe - | OpLt - | OpGt +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt -type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr } +type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } val flhs : 'a1 formula -> 'a1 pExpr @@ -329,6 +1090,10 @@ val xdenorm : positive -> 'a1 pol -> 'a1 pExpr val denorm : 'a1 pol -> 'a1 pExpr +val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr + +val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula + val simpl_cone : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> 'a1 psatz @@ -357,18 +1122,12 @@ val qpower_positive : q -> positive -> q val qpower : q -> z -> q -val pgcdn : nat -> positive -> positive -> positive - -val pgcd : positive -> positive -> positive - -val zgcd : z -> z -> z - -type 'a t = - | Empty - | Leaf of 'a - | Node of 'a t * 'a * 'a t +type 'a t0 = +| Empty +| Leaf of 'a +| Node of 'a t0 * 'a * 'a t0 -val find : 'a1 -> 'a1 t -> positive -> 'a1 +val find : 'a1 -> 'a1 t0 -> positive -> 'a1 type zWitness = z psatz @@ -388,38 +1147,40 @@ val xnegate0 : z formula -> z nFormula list val negate : z formula -> z nFormula cnf +val zunsat : z nFormula -> bool + +val zdeduce : z nFormula -> z nFormula -> z nFormula option + val ceiling : z -> z -> z type zArithProof = - | DoneProof - | RatProof of zWitness * zArithProof - | CutProof of zWitness * zArithProof - | EnumProof of zWitness * zWitness * zArithProof list +| DoneProof +| RatProof of zWitness * zArithProof +| CutProof of zWitness * zArithProof +| EnumProof of zWitness * zWitness * zArithProof list val zgcdM : z -> z -> z -val zgcd_pol : z polC -> z * z +val zgcd_pol : z polC -> z * z val zdiv_pol : z polC -> z -> z polC -val makeCuttingPlane : z polC -> z polC * z +val makeCuttingPlane : z polC -> z polC * z -val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option +val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option -val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula +val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula val is_pol_Z0 : z polC -> bool val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option -val check_inconsistent0 : z nFormula -> bool +val valid_cut_sign : op1 -> bool val zChecker : z nFormula list -> zArithProof -> bool val zTautoChecker : z formula bFormula -> zArithProof list -> bool -val n_of_Z : z -> n - type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool @@ -428,15 +1189,36 @@ val qnormalise : q formula -> q nFormula cnf val qnegate : q formula -> q nFormula cnf +val qunsat : q nFormula -> bool + +val qdeduce : q nFormula -> q nFormula -> q nFormula option + val qTautoChecker : q formula bFormula -> qWitness list -> bool -type rWitness = z psatz +type rcst = +| C0 +| C1 +| CQ of q +| CZ of z +| CPlus of rcst * rcst +| CMinus of rcst * rcst +| CMult of rcst * rcst +| CInv of rcst +| COpp of rcst + +val q_of_Rcst : rcst -> q + +type rWitness = q psatz + +val rWeakChecker : q nFormula list -> q psatz -> bool + +val rnormalise : q formula -> q nFormula cnf -val rWeakChecker : z nFormula list -> z psatz -> bool +val rnegate : q formula -> q nFormula cnf -val rnormalise : z formula -> z nFormula cnf +val runsat : q nFormula -> bool -val rnegate : z formula -> z nFormula cnf +val rdeduce : q nFormula -> q nFormula -> q nFormula option -val rTautoChecker : z formula bFormula -> rWitness list -> bool +val rTautoChecker : rcst formula bFormula -> rWitness list -> bool diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mllib index debc296e..f53a9e37 100644 --- a/plugins/micromega/micromega_plugin.mllib +++ b/plugins/micromega/micromega_plugin.mllib @@ -1,6 +1,7 @@ Sos_types Mutils Micromega +Polynomial Mfourier Certificate Persistent_cache diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index ef23b912..3129e54d 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,20 +8,31 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) +(* ** Utility functions ** *) +(* *) +(* - Modules CoqToCaml, CamlToCoq *) +(* - Modules Cmp, Tag, TagSet *) +(* *) (* Frédéric Besson (Irisa/Inria) 2006-2008 *) (* *) (************************************************************************) let debug = false +let rec pp_list f o l = + match l with + | [] -> () + | e::l -> f o e ; output_string o ";" ; pp_list f o l + + let finally f rst = try let res = f () in rst () ; res - with x -> + with reraise -> (try rst () - with _ -> raise x - ); raise x + with any -> raise reraise + ); raise reraise let map_option f x = match x with @@ -46,12 +57,16 @@ let iteri f l = | e::l -> f i e ; xiter (i+1) l in xiter 0 l -let mapi f l = - let rec xmap i l = - match l with - | [] -> [] - | e::l -> (f i e)::xmap (i+1) l in - xmap 0 l +let all_sym_pairs f l = + let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in + + let rec xpairs acc l = + match l with + | [] -> acc + | e::l -> xpairs (pair_with acc e l) l in + xpairs [] l + + let rec map3 f l1 l2 l3 = match l1 , l2 ,l3 with @@ -59,8 +74,6 @@ let rec map3 f l1 l2 l3 = | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3) | _ -> raise (Invalid_argument "map3") - - let rec is_sublist l1 l2 = match l1 ,l2 with | [] ,_ -> true @@ -69,8 +82,6 @@ let rec is_sublist l1 l2 = if e = e' then is_sublist l1' l2' else is_sublist l1 l2' - - let list_try_find f = let rec try_find_f = function | [] -> failwith "try_find" @@ -91,6 +102,18 @@ let interval n m = in interval_n ([],m) +let extract pred l = + List.fold_left (fun (fd,sys) e -> + match fd with + | None -> + begin + match pred e with + | None -> fd, e::sys + | Some v -> Some(v,e) , sys + end + | _ -> (fd, e::sys) + ) (None,[]) l + open Num open Big_int @@ -100,7 +123,6 @@ let ppcm x y = let y' = div_big_int y g in mult_big_int g (mult_big_int x' y') - let denominator = function | Int _ | Big_int _ -> unit_big_int | Ratio r -> Ratio.denominator_ratio r @@ -125,8 +147,6 @@ let rec gcd_list l = if compare_big_int res zero_big_int = 0 then unit_big_int else res - - let rats_to_ints l = let c = ppcm_list unit_big_int l in List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) @@ -140,7 +160,6 @@ let mapi f l = | e::l -> (f e i)::(xmapi (i+1) l) in xmapi 0 l - let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) (* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) @@ -178,6 +197,9 @@ let select_pos lpos l = else xselect (i+1) lpos l in xselect 0 lpos l +(** + * MODULE: Coq to Caml data-structure mappings + *) module CoqToCaml = struct @@ -194,20 +216,17 @@ struct | XI p -> 1+ 2*(positive p) | XO p -> 2*(positive p) - let n nt = match nt with | N0 -> 0 | Npos p -> positive p - let rec index i = (* Swap left-right ? *) match i with | XH -> 1 | XI i -> 1+(2*(index i)) | XO i -> 2*(index i) - let z x = match x with | Z0 -> 0 @@ -222,14 +241,12 @@ struct | XI p -> add_int_big_int 1 (mult_int_big_int 2 (positive_big_int p)) | XO p -> (mult_int_big_int 2 (positive_big_int p)) - let z_big_int x = match x with | Z0 -> zero_big_int | Zpos p -> (positive_big_int p) | Zneg p -> minus_big_int (positive_big_int p) - let num x = Num.Big_int (z_big_int x) let q_to_num {qnum = x ; qden = y} = @@ -238,6 +255,10 @@ struct end +(** + * MODULE: Caml to Coq data-structure mappings + *) + module CamlToCoq = struct open Micromega @@ -252,7 +273,7 @@ struct else if n land 1 = 1 then XI (positive (n lsr 1)) else XO (positive (n lsr 1)) - let n nt = + let n nt = if nt < 0 then assert false else if nt = 0 then N0 @@ -266,8 +287,7 @@ struct let idx n = (*a.k.a path_of_int *) - (* returns the list of digits of n in reverse order with - initial 1 removed *) + (* returns the list of digits of n in reverse order with initial 1 removed *) let rec digits_of_int n = if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1)) @@ -309,6 +329,11 @@ struct end +(** + * MODULE: Comparisons on lists: by evaluating the elements in a single list, + * between two lists given an ordering, and using a hash computation + *) + module Cmp = struct @@ -317,7 +342,7 @@ struct | [] -> 0 (* Equal *) | f::l -> let cmp = f () in - if cmp = 0 then compare_lexical l else cmp + if cmp = 0 then compare_lexical l else cmp let rec compare_list cmp l1 l2 = match l1 , l2 with @@ -328,36 +353,59 @@ struct let c = cmp e1 e2 in if c = 0 then compare_list cmp l1 l2 else c +(** + * hash_list takes a hash function and a list, and computes an integer which + * is the hash value of the list. + *) let hash_list hash l = let rec _hash_list l h = match l with | [] -> h lxor (Hashtbl.hash []) - | e::l -> _hash_list l ((hash e) lxor h) in + | e::l -> _hash_list l ((hash e) lxor h) + in _hash_list l 0 - _hash_list l 0 end +(** + * MODULE: Labels for atoms in propositional formulas. + * Tags are used to identify unused atoms in CNFs, and propagate them back to + * the original formula. The translation back to Coq then ignores these + * superfluous items, which speeds the translation up a bit. + *) + module type Tag = sig + type t val from : int -> t val next : t -> t val pp : out_channel -> t -> unit val compare : t -> t -> int + end module Tag : Tag = struct + type t = int + let from i = i let next i = i + 1 let pp o i = output_string o (string_of_int i) let compare : int -> int -> int = Pervasives.compare + end +(** + * MODULE: Ordered sets of tags. + *) + module TagSet = Set.Make(Tag) +(** + * Forking routine, plumbing the appropriate pipes where needed. + *) let command exe_path args vl = (* creating pipes for stdin, stdout, stderr *) @@ -365,7 +413,6 @@ let command exe_path args vl = and (stdout_read,stdout_write) = Unix.pipe () and (stderr_read,stderr_write) = Unix.pipe () in - (* Create the process *) let pid = Unix.create_process exe_path args stdin_read stdout_write stderr_write in @@ -378,24 +425,22 @@ let command exe_path args vl = let _pid,status = Unix.waitpid [] pid in finally + (* Recover the result *) (fun () -> - (* Recover the result *) match status with | Unix.WEXITED 0 -> - let inch = Unix.in_channel_of_descr stdout_read in - begin try Marshal.from_channel inch with x -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) end - | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) + let inch = Unix.in_channel_of_descr stdout_read in + begin try Marshal.from_channel inch + with x when x <> Sys.Break -> + failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) + end + | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) - | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) + | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) + (* Cleanup *) (fun () -> - (* Cleanup *) - List.iter (fun x -> try Unix.close x with _ -> ()) [stdin_read; stdin_write; stdout_read ; stdout_write ; stderr_read; stderr_write] - ) - - - - - + List.iter (fun x -> try Unix.close x with e when e <> Sys.Break -> ()) + [stdin_read; stdin_write; stdout_read; stdout_write; stderr_read; stderr_write]) (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index b48fa36b..6d1a2927 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -1,14 +1,14 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (* *) -(* A persistent hashtable *) +(* A persistent hashtable *) (* *) -(* Frédéric Besson (Inria Rennes) 2009 *) +(* Frédéric Besson (Inria Rennes) 2009-2011 *) (* *) (************************************************************************) @@ -20,8 +20,7 @@ module type PHashtable = val create : int -> string -> 'a t (** [create i f] creates an empty persistent table - with initial size i - associated with file [f] *) + with initial size i associated with file [f] *) val open_in : string -> 'a t @@ -40,7 +39,7 @@ module type PHashtable = val close : 'a t -> unit (** [close tbl] is closing the table. Once closed, a table cannot be used. - i.e, copy, find,add will raise UnboundTable *) + i.e, find,add will raise UnboundTable *) val memo : string -> (key -> 'a) -> (key -> 'a) (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. @@ -52,20 +51,17 @@ open Hashtbl module PHashtable(Key:HashedType) : PHashtable with type key = Key.t = struct + open Unix type key = Key.t module Table = Hashtbl.Make(Key) - - exception InvalidTableFormat exception UnboundTable - type mode = Closed | Open - type 'a t = { outch : out_channel ; @@ -75,8 +71,9 @@ struct let create i f = + let flags = [O_WRONLY; O_TRUNC;O_CREAT] in { - outch = open_out_bin f ; + outch = out_channel_of_descr (openfile f flags 0o666); status = Open ; htbl = Table.create i } @@ -85,10 +82,10 @@ let finally f rst = try let res = f () in rst () ; res - with x -> + with reraise -> (try rst () - with _ -> raise x - ); raise x + with any -> raise reraise + ); raise reraise let read_key_elem inch = @@ -96,12 +93,32 @@ let read_key_elem inch = Some (Marshal.from_channel inch) with | End_of_file -> None - | _ -> raise InvalidTableFormat + | e when e <> Sys.Break -> raise InvalidTableFormat + +(** In win32, it seems that we should unlock the exact zone + that has been locked, and not the whole file *) + +let locked_start = ref 0 + +let lock fd = + locked_start := lseek fd 0 SEEK_CUR; + lockf fd F_LOCK 0 + +let rlock fd = + locked_start := lseek fd 0 SEEK_CUR; + lockf fd F_RLOCK 0 + +let unlock fd = + let pos = lseek fd 0 SEEK_CUR in + ignore (lseek fd !locked_start SEEK_SET); + lockf fd F_ULOCK 0; + ignore (lseek fd pos SEEK_SET) let open_in f = - let flags = [Open_rdonly;Open_binary;Open_creat] in - let inch = open_in_gen flags 0o666 f in - let htbl = Table.create 10 in + let flags = [O_RDONLY ; O_CREAT] in + let finch = openfile f flags 0o666 in + let inch = in_channel_of_descr finch in + let htbl = Table.create 100 in let rec xload () = match read_key_elem inch with @@ -109,27 +126,38 @@ let open_in f = | Some (key,elem) -> Table.add htbl key elem ; xload () in - try - finally (fun () -> xload () ) (fun () -> close_in inch) ; + (* Locking of the (whole) file while reading *) + rlock finch; + finally + (fun () -> xload () ) + (fun () -> + unlock finch ; + close_in_noerr inch ; + ) ; { - outch = begin - let flags = [Open_append;Open_binary;Open_creat] in - open_out_gen flags 0o666 f - end ; + outch = out_channel_of_descr (openfile f [O_WRONLY;O_APPEND;O_CREAT] 0o666) ; status = Open ; htbl = htbl } with InvalidTableFormat -> (* Try to keep as many entries as possible *) begin - let flags = [Open_wronly; Open_trunc;Open_binary;Open_creat] in - let outch = open_out_gen flags 0o666 f in - Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; - { outch = outch ; - status = Open ; - htbl = htbl - } + let flags = [O_WRONLY; O_TRUNC;O_CREAT] in + let out = (openfile f flags 0o666) in + let outch = out_channel_of_descr out in + lock out; + (try + Table.iter + (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; + flush outch ; + with e when e <> Sys.Break -> () ) + ; + unlock out ; + { outch = outch ; + status = Open ; + htbl = htbl + } end @@ -147,9 +175,14 @@ let add t k e = if status = Closed then raise UnboundTable else + let fd = descr_of_out_channel outch in begin Table.add tbl k e ; - Marshal.to_channel outch (k,e) [Marshal.No_sharing] + lock fd; + ignore (lseek fd 0 SEEK_END); + Marshal.to_channel outch (k,e) [Marshal.No_sharing] ; + flush outch ; + unlock fd end let find t k = diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml new file mode 100644 index 00000000..36b05a72 --- /dev/null +++ b/plugins/micromega/polynomial.ml @@ -0,0 +1,739 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-20011 *) +(* *) +(************************************************************************) + +open Num +module Utils = Mutils +open Utils + +type var = int + + +let (<+>) = add_num +let (<->) = minus_num +let (<*>) = mult_num + + +module Monomial : +sig + type t + val const : t + val is_const : t -> bool + val var : var -> t + val is_var : t -> bool + val find : var -> t -> int + val mult : var -> t -> t + val prod : t -> t -> t + val exp : t -> int -> t + val div : t -> t -> t * int + val compare : t -> t -> int + val pp : out_channel -> t -> unit + val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a + val sqrt : t -> t option +end + = +struct + (* A monomial is represented by a multiset of variables *) + module Map = Map.Make(struct type t = var let compare = Pervasives.compare end) + open Map + + type t = int Map.t + + let pp o m = Map.iter + (fun k v -> + if v = 1 then Printf.fprintf o "x%i." k + else Printf.fprintf o "x%i^%i." k v) m + + + (* The monomial that corresponds to a constant *) + let const = Map.empty + + let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 + + (* Total ordering of monomials *) + let compare: t -> t -> int = + fun m1 m2 -> + let s1 = sum_degree m1 + and s2 = sum_degree m2 in + if s1 = s2 then Map.compare Pervasives.compare m1 m2 + else Pervasives.compare s1 s2 + + let is_const m = (m = Map.empty) + + (* The monomial 'x' *) + let var x = Map.add x 1 Map.empty + + let is_var m = + try + not (Map.fold (fun _ i fk -> + if fk = true (* first key *) + then + if i = 1 then false + else raise Not_found + else raise Not_found) m true) + with Not_found -> false + + let sqrt m = + if is_const m then None + else + try + Some (Map.fold (fun v i acc -> + let i' = i / 2 in + if i mod 2 = 0 + then add v i' m + else raise Not_found) m const) + with Not_found -> None + + (* Get the degre of a variable in a monomial *) + let find x m = try find x m with Not_found -> 0 + + (* Multiply a monomial by a variable *) + let mult x m = add x ( (find x m) + 1) m + + (* Product of monomials *) + let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 + + + let exp m n = + let rec exp acc n = + if n = 0 then acc + else exp (prod acc m) (n - 1) in + + exp const n + + + (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) + let div m1 m2 = + let n = fold (fun x i n -> let i' = find x m1 in + let nx = i' / i in + min n nx) m2 max_int in + + let mr = fold (fun x i' m -> + let i = find x m2 in + let ir = i' - i * n in + if ir = 0 then m + else add x ir m) m1 empty in + (mr,n) + + + let fold = fold + +end + +module Poly : + (* A polynomial is a map of monomials *) + (* + This is probably a naive implementation + (expected to be fast enough - Coq is probably the bottleneck) + *The new ring contribution is using a sparse Horner representation. + *) +sig + type t + val get : Monomial.t -> t -> num + val variable : var -> t + val add : Monomial.t -> num -> t -> t + val constant : num -> t + val mult : Monomial.t -> num -> t -> t + val product : t -> t -> t + val addition : t -> t -> t + val uminus : t -> t + val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a + val pp : out_channel -> t -> unit + val compare : t -> t -> int + val is_null : t -> bool + val is_linear : t -> bool +end = +struct + (*normalisation bug : 0*x ... *) + module P = Map.Make(Monomial) + open P + + type t = num P.t + + let pp o p = P.iter + (fun k v -> + if Monomial.compare Monomial.const k = 0 + then Printf.fprintf o "%s " (string_of_num v) + else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p + + (* Get the coefficient of monomial mn *) + let get : Monomial.t -> t -> num = + fun mn p -> try find mn p with Not_found -> (Int 0) + + + (* The polynomial 1.x *) + let variable : var -> t = + fun x -> add (Monomial.var x) (Int 1) empty + + (*The constant polynomial *) + let constant : num -> t = + fun c -> add (Monomial.const) c empty + + (* The addition of a monomial *) + + let add : Monomial.t -> num -> t -> t = + fun mn v p -> + if sign_num v = 0 then p + else + let vl = (get mn p) <+> v in + if sign_num vl = 0 then + remove mn p + else add mn vl p + + + (** Design choice: empty is not a polynomial + I do not remember why .... + **) + + (* The product by a monomial *) + let mult : Monomial.t -> num -> t -> t = + fun mn v p -> + if sign_num v = 0 + then constant (Int 0) + else + fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty + + + let addition : t -> t -> t = + fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 + + + let product : t -> t -> t = + fun p1 p2 -> + fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty + + + let uminus : t -> t = + fun p -> map (fun v -> minus_num v) p + + let fold = P.fold + + let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p true + + let compare = compare compare_num + + let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true + +(* let is_linear p = + let res = is_linear p in + Printf.printf "is_linear %a = %b\n" pp p res ; res +*) +end + + +module Vect = + struct + (** [t] is the type of vectors. + A vector [(x1,v1) ; ... ; (xn,vn)] is such that: + - variables indexes are ordered (x1 <c ... < xn + - values are all non-zero + *) + type var = int + type t = (var * num) list + +(** [equal v1 v2 = true] if the vectors are syntactically equal. + ([num] is not handled by [Pervasives.equal] *) + + let rec equal v1 v2 = + match v1 , v2 with + | [] , [] -> true + | [] , _ -> false + | _::_ , [] -> false + | (i1,n1)::v1 , (i2,n2)::v2 -> + (i1 = i2) && n1 =/ n2 && equal v1 v2 + + let hash v = + let rec hash i = function + | [] -> i + | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in + Hashtbl.hash (hash 0 v ) + + + let null = [] + + let pp_vect o vect = + List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect + + let from_list (l: num list) = + let rec xfrom_list i l = + match l with + | [] -> [] + | e::l -> + if e <>/ Int 0 + then (i,e)::(xfrom_list (i+1) l) + else xfrom_list (i+1) l in + + xfrom_list 0 l + + let zero_num = Int 0 + let unit_num = Int 1 + + + let to_list m = + let rec xto_list i l = + match l with + | [] -> [] + | (x,v)::l' -> + if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in + xto_list 0 m + + + let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst + + let rec update i f t = + match t with + | [] -> cons i (f zero_num) [] + | (k,v)::l -> + match Pervasives.compare i k with + | 0 -> cons k (f v) l + | -1 -> cons i (f zero_num) t + | 1 -> (k,v) ::(update i f l) + | _ -> failwith "compare_num" + + let rec set i n t = + match t with + | [] -> cons i n [] + | (k,v)::l -> + match Pervasives.compare i k with + | 0 -> cons k n l + | -1 -> cons i n t + | 1 -> (k,v) :: (set i n l) + | _ -> failwith "compare_num" + + let gcd m = + let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in + if Big_int.compare_big_int res Big_int.zero_big_int = 0 + then Big_int.unit_big_int else res + + let rec mul z t = + match z with + | Int 0 -> [] + | Int 1 -> t + | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t + + + let rec add v1 v2 = + match v1 , v2 with + | (x1,n1)::v1' , (x2,n2)::v2' -> + if x1 = x2 + then + let n' = n1 +/ n2 in + if n' =/ Int 0 then add v1' v2' + else + let res = add v1' v2' in + (x1,n') ::res + else if x1 < x2 + then let res = add v1' v2 in + (x1, n1)::res + else let res = add v1 v2' in + (x2, n2)::res + | [] , [] -> [] + | [] , _ -> v2 + | _ , [] -> v1 + + + + + let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical + [ + (fun () -> Pervasives.compare (fst x) (fst y)); + (fun () -> compare_num (snd x) (snd y))]) + + (** [tail v vect] returns + - [None] if [v] is not a variable of the vector [vect] + - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] + and [rst] is the remaining of the vector + We exploit that vectors are ordered lists + *) + let rec tail (v:var) (vect:t) = + match vect with + | [] -> None + | (v',vl)::vect' -> + match Pervasives.compare v' v with + | 0 -> Some (vl,vect) (* Ok, found *) + | -1 -> tail v vect' (* Might be in the tail *) + | _ -> None (* Hopeless *) + + let get v vect = + match tail v vect with + | None -> None + | Some(vl,_) -> Some vl + + + let rec fresh v = + match v with + | [] -> 1 + | [v,_] -> v + 1 + | _::v -> fresh v + + end + +type vector = Vect.t + +type cstr_compat = {coeffs : vector ; op : op ; cst : num} +and op = |Eq | Ge + +let string_of_op = function Eq -> "=" | Ge -> ">=" + +let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = + Printf.fprintf o "%a %s %s" Vect.pp_vect coeffs (string_of_op op) (string_of_num cst) + +let opMult o1 o2 = + match o1, o2 with + | Eq , Eq -> Eq + | Eq , Ge | Ge , Eq -> Ge + | Ge , Ge -> Ge + +let opAdd o1 o2 = + match o1 , o2 with + | Eq , _ | _ , Eq -> Eq + | Ge , Ge -> Ge + + + + +open Big_int + +type index = int + +type prf_rule = + | Hyp of int + | Def of int + | Cst of big_int + | Zero + | Square of (Vect.t * num) + | MulC of (Vect.t * num) * prf_rule + | Gcd of big_int * prf_rule + | MulPrf of prf_rule * prf_rule + | AddPrf of prf_rule * prf_rule + | CutPrf of prf_rule + +type proof = + | Done + | Step of int * prf_rule * proof + | Enum of int * prf_rule * Vect.t * prf_rule * proof list + + +let rec output_prf_rule o = function + | Hyp i -> Printf.fprintf o "Hyp %i" i + | Def i -> Printf.fprintf o "Def %i" i + | Cst c -> Printf.fprintf o "Cst %s" (string_of_big_int c) + | Zero -> Printf.fprintf o "Zero" + | Square _ -> Printf.fprintf o "( )^2" + | MulC(p,pr) -> Printf.fprintf o "P * %a" output_prf_rule pr + | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2 + | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2 + | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p + | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c) + +let rec output_proof o = function + | Done -> Printf.fprintf o "." + | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i + output_prf_rule p1 Vect.pp_vect v output_prf_rule p2 + (pp_list output_proof) pl + +let rec pr_rule_max_id = function + | Hyp i | Def i -> i + | Cst _ | Zero | Square _ -> -1 + | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p + | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) + +let rec proof_max_id = function + | Done -> -1 + | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) + | Enum(i,p1,_,p2,l) -> + let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in + List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l + +let rec pr_rule_def_cut id = function + | MulC(p,prf) -> + let (bds,id',prf') = pr_rule_def_cut id prf in + (bds, id', MulC(p,prf')) + | MulPrf(p1,p2) -> + let (bds1,id,p1) = pr_rule_def_cut id p1 in + let (bds2,id,p2) = pr_rule_def_cut id p2 in + (bds2@bds1,id,MulPrf(p1,p2)) + | AddPrf(p1,p2) -> + let (bds1,id,p1) = pr_rule_def_cut id p1 in + let (bds2,id,p2) = pr_rule_def_cut id p2 in + (bds2@bds1,id,AddPrf(p1,p2)) + | CutPrf p -> + let (bds,id,p) = pr_rule_def_cut id p in + ((id,p)::bds,id+1,Def id) + | Gcd(c,p) -> + let (bds,id,p) = pr_rule_def_cut id p in + ((id,p)::bds,id+1,Def id) + | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) + + +(* Do not define top-level cuts *) +let pr_rule_def_cut id = function + | CutPrf p -> + let (bds,ids,p') = pr_rule_def_cut id p in + bds,ids, CutPrf p' + | p -> pr_rule_def_cut id p + + +let rec implicit_cut p = + match p with + | CutPrf p -> implicit_cut p + | _ -> p + + +let rec normalise_proof id prf = + match prf with + | Done -> (id,Done) + | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) + | Step(i,p,prf) -> + let bds,id,p' = pr_rule_def_cut id p in + let (id,prf) = normalise_proof id prf in + let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) + (Step(i,p',prf)) bds in + + (id,prf) + | Enum(i,p1,v,p2,pl) -> + (* Why do I have top-level cuts ? *) +(* let p1 = implicit_cut p1 in + let p2 = implicit_cut p2 in + let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in + (List.fold_left max 0 ids , + Enum(i,p1,v,p2,prfs)) +*) + + let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in + let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in + let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in + (List.fold_left max 0 ids , + List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) + (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) + + +let normalise_proof id prf = + let res = normalise_proof id prf in + if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; + res + + + +let add_proof x y = + match x, y with + | Zero , p | p , Zero -> p + | _ -> AddPrf(x,y) + + +let mul_proof c p = + match sign_big_int c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> MulC(([],Big_int c),p) (* [p] should represent an equality *) + | 1 -> + if eq_big_int c unit_big_int + then p + else MulPrf(Cst c,p) + | _ -> assert false + + +let mul_proof_ext (p,c) prf = + match p with + | [] -> mul_proof (numerator c) prf + | _ -> MulC((p,c),prf) + + + +(* + let rec scale_prf_rule = function + | Hyp i -> (unit_big_int, Hyp i) + | Def i -> (unit_big_int, Def i) + | Cst c -> (unit_big_int, Cst i) + | Zero -> (unit_big_int, Zero) + | Square p -> (unit_big_int,Square p) + | Div(c,pr) -> + let (bi,pr') = scale_prf_rule pr in + (mult_big_int c bi , pr') + | MulC(p,pr) -> + let bi,pr' = scale_prf_rule pr in + (bi,MulC p,pr') + | MulPrf(p1,p2) -> + let b1,p1 = scale_prf_rule p1 in + let b2,p2 = scale_prf_rule p2 in + + + | AddPrf(p1,p2) -> + let b1,p1 = scale_prf_rule p1 in + let b2,p2 = scale_prf_rule p2 in + let g = gcd_big_int +*) + + + + + +module LinPoly = +struct + type t = Vect.t * num + + module MonT = + struct + module MonoMap = Map.Make(Monomial) + module IntMap = Map.Make(struct type t = int let compare = Pervasives.compare end) + + (** A hash table might be preferable but requires a hash function. *) + let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty) + let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty) + let fresh = ref 0 + + let clear () = + index_of_monomial := MonoMap.empty; + monomial_of_index := IntMap.empty ; + fresh := 0 + + + let register m = + try + MonoMap.find m !index_of_monomial + with Not_found -> + begin + let res = !fresh in + index_of_monomial := MonoMap.add m res !index_of_monomial ; + monomial_of_index := IntMap.add res m !monomial_of_index ; + incr fresh ; res + end + + let retrieve i = IntMap.find i !monomial_of_index + + + end + + let normalise (v,c) = + (List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) v , c) + + + let output_mon o (x,v) = + Printf.fprintf o "%s.%a +" (string_of_num v) Monomial.pp (MonT.retrieve x) + + + + let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = + Printf.fprintf o "%a %s %s" (pp_list output_mon) coeffs (string_of_op op) (string_of_num cst) + + + + let linpol_of_pol p = + let (v,c) = + Poly.fold + (fun mon num (vct,cst) -> + if Monomial.is_const mon then (vct,num) + else + let vr = MonT.register mon in + ((vr,num)::vct,cst)) p ([], Int 0) in + normalise (v,c) + + let mult v m (vect,c) = + if Monomial.is_const m + then + (Vect.mul v vect, v <*> c) + else + if sign_num v <> 0 + then + let hd = + if sign_num c <> 0 + then [MonT.register m,v <*> c] + else [] in + + let vect = hd @ (List.map (fun (x,n) -> + let x = MonT.retrieve x in + let x_m = MonT.register (Monomial.prod m x) in + (x_m, v <*> n)) vect ) in + normalise (vect , Int 0) + else ([],Int 0) + + let mult v m (vect,c) = + let (vect',c') = mult v m (vect,c) in + if debug then + Printf.printf "mult %s %a (%a,%s) -> (%a,%s)\n" (string_of_num v) Monomial.pp m + (pp_list output_mon) vect (string_of_num c) + (pp_list output_mon) vect' (string_of_num c') ; + (vect',c') + + + + let make_lin_pol v mon = + if Monomial.is_const mon + then [] , v + else [MonT.register mon, v],Int 0 + + + + + + + let xpivot_eq (c,prf) x v (c',prf') = + if debug then Printf.printf "xpivot_eq {%a} %a %s {%a}\n" + output_cstr c + Monomial.pp (MonT.retrieve x) + (string_of_num v) output_cstr c' ; + + + let {coeffs = coeffs ; op = op ; cst = cst} = c' in + let m = MonT.retrieve x in + + let apply_pivot (vqn,q,n) (c',prf') = + (* Morally, we have (Vect.get (q*x^n) c'.coeffs) = vmn with n >=0 *) + + let cc' = abs_num v in + let cc_num = Int (- (sign_num v)) <*> vqn in + let cc_mon = Monomial.prod q (Monomial.exp m (n-1)) in + + let (c_coeff,c_cst) = mult cc_num cc_mon (c.coeffs, minus_num c.cst) in + + let c' = {coeffs = Vect.add (Vect.mul cc' c'.coeffs) c_coeff ; op = op ; cst = (minus_num c_cst) <+> (cc' <*> c'.cst)} in + let prf' = add_proof + (mul_proof_ext (make_lin_pol cc_num cc_mon) prf) + (mul_proof (numerator cc') prf') in + + if debug then Printf.printf "apply_pivot -> {%a}\n" output_cstr c' ; + (c',prf') in + + + let cmp (q,n) (q',n') = + if n < n' then -1 + else if n = n' then Monomial.compare q q' + else 1 in + + + let find_pivot (c',prf') = + let (v,q,n) = List.fold_left + (fun (v,q,n) (x,v') -> + let x = MonT.retrieve x in + let (q',n') = Monomial.div x m in + if cmp (q,n) (q',n') = -1 then (v',q',n') else (v,q,n)) (Int 0, Monomial.const,0) c'.coeffs in + if n > 0 then Some (v,q,n) else None in + + let rec pivot (q,n) (c',prf') = + match find_pivot (c',prf') with + | None -> (c',prf') + | Some(v,q',n') -> + if cmp (q',n') (q,n) = -1 + then pivot (q',n') (apply_pivot (v,q',n') (c',prf')) + else (c',prf') in + + pivot (Monomial.const,max_int) (c',prf') + + + let pivot_eq x (c,prf) = + match Vect.get x c.coeffs with + | None -> (fun x -> None) + | Some v -> fun cp' -> Some (xpivot_eq (c,prf) x v cp') + + +end diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index 3029496b..6ddc48e7 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -526,17 +526,17 @@ let sdpa_run_succeeded = (* ------------------------------------------------------------------------- *) let sdpa_default_parameters = -"100 unsigned int maxIteration; -1.0E-7 double 0.0 < epsilonStar; -1.0E2 double 0.0 < lambdaStar; -2.0 double 1.0 < omegaStar; --1.0E5 double lowerBound; -1.0E5 double upperBound; -0.1 double 0.0 <= betaStar < 1.0; -0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar; -0.9 double 0.0 < gammaStar < 1.0; -1.0E-7 double 0.0 < epsilonDash; -";; +"100 unsigned int maxIteration;\ +\n1.0E-7 double 0.0 < epsilonStar;\ +\n1.0E2 double 0.0 < lambdaStar;\ +\n2.0 double 1.0 < omegaStar;\ +\n-1.0E5 double lowerBound;\ +\n1.0E5 double upperBound;\ +\n0.1 double 0.0 <= betaStar < 1.0;\ +\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\ +\n0.9 double 0.0 < gammaStar < 1.0;\ +\n1.0E-7 double 0.0 < epsilonDash;\ +\n";; (* ------------------------------------------------------------------------- *) (* These were suggested by Makoto Yamashita for problems where we are *) @@ -544,17 +544,17 @@ let sdpa_default_parameters = (* ------------------------------------------------------------------------- *) let sdpa_alt_parameters = -"1000 unsigned int maxIteration; -1.0E-7 double 0.0 < epsilonStar; -1.0E4 double 0.0 < lambdaStar; -2.0 double 1.0 < omegaStar; --1.0E5 double lowerBound; -1.0E5 double upperBound; -0.1 double 0.0 <= betaStar < 1.0; -0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar; -0.9 double 0.0 < gammaStar < 1.0; -1.0E-7 double 0.0 < epsilonDash; -";; +"1000 unsigned int maxIteration;\ +\n1.0E-7 double 0.0 < epsilonStar;\ +\n1.0E4 double 0.0 < lambdaStar;\ +\n2.0 double 1.0 < omegaStar;\ +\n-1.0E5 double lowerBound;\ +\n1.0E5 double upperBound;\ +\n0.1 double 0.0 <= betaStar < 1.0;\ +\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\ +\n0.9 double 0.0 < gammaStar < 1.0;\ +\n1.0E-7 double 0.0 < epsilonDash;\ +\n";; let sdpa_params = sdpa_alt_parameters;; @@ -563,21 +563,21 @@ let sdpa_params = sdpa_alt_parameters;; (* ------------------------------------------------------------------------- *) let csdp_default_parameters = -"axtol=1.0e-8 -atytol=1.0e-8 -objtol=1.0e-8 -pinftol=1.0e8 -dinftol=1.0e8 -maxiter=100 -minstepfrac=0.9 -maxstepfrac=0.97 -minstepp=1.0e-8 -minstepd=1.0e-8 -usexzgap=1 -tweakgap=0 -affine=0 -printlevel=1 -";; +"axtol=1.0e-8\ +\natytol=1.0e-8\ +\nobjtol=1.0e-8\ +\npinftol=1.0e8\ +\ndinftol=1.0e8\ +\nmaxiter=100\ +\nminstepfrac=0.9\ +\nmaxstepfrac=0.97\ +\nminstepp=1.0e-8\ +\nminstepd=1.0e-8\ +\nusexzgap=1\ +\ntweakgap=0\ +\naffine=0\ +\nprintlevel=1\ +\n";; let csdp_params = csdp_default_parameters;; diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli index 23219be2..bc08d3c9 100644 --- a/plugins/micromega/sos.mli +++ b/plugins/micromega/sos.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml index 6bd463ef..f9d2fb0b 100644 --- a/plugins/micromega/sos_types.ml +++ b/plugins/micromega/sos_types.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v index ac321ba2..4f4f2039 100644 --- a/plugins/nsatz/Nsatz.v +++ b/plugins/nsatz/Nsatz.v @@ -1,20 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (* - Tactic nsatz: proofs of polynomials equalities in a domain (ring without zero divisor). - Reification is done by type classes, following a technique shown by Mathieu -Sozeau. Verification of certificate is done by a code written by Benjamin -Gregoire, following an idea of Laurent Théry. - + Tactic nsatz: proofs of polynomials equalities in an integral domain +(commutative ring without zero divisor). + Examples: see test-suite/success/Nsatz.v -Loïc Pottier, july 2010 +Reification is done using type classes, defined in Ncring_tac.v + *) Require Import List. @@ -22,74 +21,27 @@ Require Import Setoid. Require Import BinPos. Require Import BinList. Require Import Znumtheory. -Require Import Ring_polynom Ring_tac InitialRing. Require Export Morphisms Setoid Bool. +Require Export Algebra_syntax. +Require Export Ncring. +Require Export Ncring_initial. +Require Export Ncring_tac. +Require Export Integral_domain. +Require Import DiscrR. Declare ML Module "nsatz_plugin". -Class Zero (A : Type) := {zero : A}. -Notation "0" := zero. -Class One (A : Type) := {one : A}. -Notation "1" := one. -Class Addition (A : Type) := {addition : A -> A -> A}. -Notation "x + y" := (addition x y). -Class Multiplication (A : Type) := {multiplication : A -> A -> A}. -Notation "x * y" := (multiplication x y). -Class Subtraction (A : Type) := {subtraction : A -> A -> A}. -Notation "x - y" := (subtraction x y). -Class Opposite (A : Type) := {opposite : A -> A}. -Notation "- x" := (opposite x). - -Class Ring (R:Type) := { - ring0: R; ring1: R; - ring_plus: R->R->R; ring_mult: R->R->R; - ring_sub: R->R->R; ring_opp: R->R; - ring_eq : R -> R -> Prop; - ring_ring: - ring_theory ring0 ring1 ring_plus ring_mult ring_sub - ring_opp ring_eq; - ring_setoid: Equivalence ring_eq; - ring_plus_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_plus; - ring_mult_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_mult; - ring_sub_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_sub; - ring_opp_comp: Proper (ring_eq==>ring_eq) ring_opp -}. - -Class Domain (R : Type) := { - domain_ring:> Ring R; - domain_axiom_product: - forall x y, ring_eq (ring_mult x y) ring0 -> (ring_eq x ring0) \/ (ring_eq y ring0); - domain_axiom_one_zero: not (ring_eq ring1 ring0)}. - -Section domain. - -Variable R: Type. -Variable Rd: Domain R. - -Existing Instance ring_setoid. -Existing Instance ring_plus_comp. -Existing Instance ring_mult_comp. -Existing Instance ring_sub_comp. -Existing Instance ring_opp_comp. - -Add Ring Rr: (@ring_ring R (@domain_ring R Rd)). - -Instance zero_ring : Zero R := {zero := ring0}. -Instance one_ring : One R := {one := ring1}. -Instance addition_ring : Addition R := {addition x y := ring_plus x y}. -Instance multiplication_ring : Multiplication R := {multiplication x y := ring_mult x y}. -Instance subtraction_ring : Subtraction R := {subtraction x y := ring_sub x y}. -Instance opposite_ring : Opposite R := {opposite x := ring_opp x}. - -Infix "==" := ring_eq (at level 70, no associativity). +Section nsatz1. + +Context {R:Type}`{Rid:Integral_domain R}. Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y. intros x y H; setoid_replace x with ((x - y) + y); simpl; - [setoid_rewrite H | idtac]; simpl; ring. + [setoid_rewrite H | idtac]; simpl. cring. cring. Qed. Lemma psos_r1: forall x y, x == y -> x - y == 0. -intros x y H; simpl; setoid_rewrite H; simpl; ring. +intros x y H; simpl; setoid_rewrite H; simpl; cring. Qed. Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). @@ -97,28 +49,30 @@ intros. intro; apply H. simpl; setoid_replace x with ((x - y) + y). simpl. setoid_rewrite H0. -simpl; ring. -simpl. simpl; ring. +simpl; cring. +simpl. simpl; cring. Qed. (* adpatation du code de Benjamin aux setoides *) Require Import ZArith. +Require Export Ring_polynom. +Require Export InitialRing. Definition PolZ := Pol Z. Definition PEZ := PExpr Z. -Definition P0Z : PolZ := @P0 Z 0%Z. +Definition P0Z : PolZ := P0 (C:=Z) 0%Z. Definition PolZadd : PolZ -> PolZ -> PolZ := - @Padd Z 0%Z Zplus Zeq_bool. + @Padd Z 0%Z Z.add Zeq_bool. Definition PolZmul : PolZ -> PolZ -> PolZ := - @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool. + @Pmul Z 0%Z 1%Z Z.add Z.mul Zeq_bool. Definition PolZeq := @Peq Z Zeq_bool. Definition norm := - @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. + @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool. Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := match la, lp with @@ -140,53 +94,65 @@ Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := (* Correction *) Definition PhiR : list R -> PolZ -> R := - (Pphi 0 ring_plus ring_mult (gen_phiZ 0 1 ring_plus ring_mult ring_opp)). - -Definition pow (r : R) (n : nat) := pow_N 1 ring_mult r (Nnat.N_of_nat n). + (Pphi ring0 add mul + (InitialRing.gen_phiZ ring0 ring1 add mul opp)). Definition PEevalR : list R -> PEZ -> R := - PEeval 0 ring_plus ring_mult ring_sub ring_opp - (gen_phiZ 0 1 ring_plus ring_mult ring_opp) - Nnat.nat_of_N pow. + PEeval ring0 add mul sub opp + (gen_phiZ ring0 ring1 add mul opp) + N.to_nat pow. Lemma P0Z_correct : forall l, PhiR l P0Z = 0. Proof. trivial. Qed. -Lemma Rext: ring_eq_ext ring_plus ring_mult ring_opp ring_eq. -apply mk_reqe. intros. setoid_rewrite H; rewrite H0; ring. - intros. setoid_rewrite H; setoid_rewrite H0; ring. -intros. setoid_rewrite H; ring. Qed. - -Lemma Rset : Setoid_Theory R ring_eq. +Lemma Rext: ring_eq_ext add mul opp _==_. +Proof. +constructor; solve_proper. +Qed. + +Lemma Rset : Setoid_Theory R _==_. apply ring_setoid. Qed. +Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_. +apply mk_rt. +apply ring_add_0_l. +apply ring_add_comm. +apply ring_add_assoc. +apply ring_mul_1_l. +apply cring_mul_comm. +apply ring_mul_assoc. +apply ring_distr_l. +apply ring_sub_def. +apply ring_opp_def. +Defined. + Lemma PolZadd_correct : forall P' P l, PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). Proof. -simpl. - refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd))) - (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))). +unfold PolZadd, PhiR. intros. simpl. + refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) _ _ _). Qed. Lemma PolZmul_correct : forall P P' l, PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). Proof. - refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd))) - (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))). +unfold PolZmul, PhiR. intros. + refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) _ _ _). Qed. Lemma R_power_theory - : power_theory 1 ring_mult ring_eq Nnat.nat_of_N pow. -apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. ring. Qed. + : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow. +apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id. +reflexivity. Qed. Lemma norm_correct : forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). Proof. - intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd))) - (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))) R_power_theory) - with (lmp:= List.nil). - compute;trivial. + intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) R_power_theory). Qed. Lemma PolZeq_correct : forall P P' l, @@ -194,7 +160,7 @@ Lemma PolZeq_correct : forall P P' l, PhiR l P == PhiR l P'. Proof. intros;apply - (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))));trivial. + (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial. Qed. Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := @@ -207,12 +173,12 @@ Lemma mult_l_correct : forall l la lp, Cond0 PolZ (PhiR l) lp -> PhiR l (mult_l la lp) == 0. Proof. - induction la;simpl;intros. ring. - destruct lp;trivial. simpl. ring. + induction la;simpl;intros. cring. + destruct lp;trivial. simpl. cring. simpl in H;destruct H. - setoid_rewrite PolZadd_correct. - simpl. setoid_rewrite PolZmul_correct. simpl. setoid_rewrite H. - setoid_rewrite IHla. unfold zero. simpl. ring. trivial. + rewrite PolZadd_correct. + simpl. rewrite PolZmul_correct. simpl. rewrite H. + rewrite IHla. cring. trivial. Qed. Lemma compute_list_correct : forall l lla lp, @@ -242,86 +208,63 @@ Qed. (* fin *) -Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0. -induction n. unfold pow; simpl. intros. absurd (1 == 0). -simpl. apply domain_axiom_one_zero. - trivial. setoid_replace (pow p (S n)) with (p * (pow p n)). intros. -case (@domain_axiom_product _ _ _ _ H). trivial. trivial. -unfold pow; simpl. -clear IHn. induction n; simpl; try ring. - rewrite pow_pos_Psucc. ring. exact Rset. - intros. setoid_rewrite H; setoid_rewrite H0; ring. - intros. simpl; ring. intros. simpl; ring. Qed. - -Lemma Rdomain_pow: forall c p r, ~c == ring0 -> ring_mult c (pow p r) == ring0 -> p == ring0. -intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c == ring0); auto. -intros. apply pow_not_zero with r. trivial. Qed. - -Definition R2:= ring_plus ring1 ring1. +Definition R2:= 1 + 1. Fixpoint IPR p {struct p}: R := match p with xH => ring1 - | xO xH => ring_plus ring1 ring1 - | xO p1 => ring_mult R2 (IPR p1) - | xI xH => ring_plus ring1 (ring_plus ring1 ring1) - | xI p1 => ring_plus ring1 (ring_mult R2 (IPR p1)) + | xO xH => 1+1 + | xO p1 => R2*(IPR p1) + | xI xH => 1+(1+1) + | xI p1 => 1+(R2*(IPR p1)) end. Definition IZR1 z := - match z with Z0 => ring0 + match z with Z0 => 0 | Zpos p => IPR p - | Zneg p => ring_opp(IPR p) + | Zneg p => -(IPR p) end. Fixpoint interpret3 t fv {struct t}: R := match t with | (PEadd t1 t2) => let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (ring_plus v1 v2) + let v2 := interpret3 t2 fv in (v1 + v2) | (PEmul t1 t2) => let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (ring_mult v1 v2) + let v2 := interpret3 t2 fv in (v1 * v2) | (PEsub t1 t2) => let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (ring_sub v1 v2) + let v2 := interpret3 t2 fv in (v1 - v2) | (PEopp t1) => - let v1 := interpret3 t1 fv in (ring_opp v1) + let v1 := interpret3 t1 fv in (-v1) | (PEpow t1 t2) => - let v1 := interpret3 t1 fv in pow v1 (Nnat.nat_of_N t2) + let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) | (PEc t1) => (IZR1 t1) - | (PEX n) => List.nth (pred (nat_of_P n)) fv 0 + | (PEX n) => List.nth (pred (Pos.to_nat n)) fv 0 end. -End domain. +End nsatz1. + +Ltac equality_to_goal H x y:= + let h := fresh "nH" in + (* eliminate trivial hypotheses, but it takes time!: + (assert (h:equality x y); + [solve [cring] | clear H; clear h]) + || *) (try generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H) +. Ltac equalities_to_goal := lazymatch goal with - | H: (@ring_eq _ _ ?x ?y) |- _ => - try generalize (@psos_r1 _ _ _ _ H); clear H + | H: (_ ?x ?y) |- _ => equality_to_goal H x y + | H: (_ _ ?x ?y) |- _ => equality_to_goal H x y + | H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y + | H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y +(* extension possible :-) *) + | H: (?x == ?y) |- _ => equality_to_goal H x y end. -Ltac nsatz_domain_begin tacsimpl := - intros; - try apply (@psos_r1b _ _); - repeat equalities_to_goal; - tacsimpl. - -Ltac generalise_eq_hyps:= - repeat - (match goal with - |h : (@ring_eq _ _ ?p ?q)|- _ => revert h - end). - -Ltac lpol_goal t := - match t with - | ?a = ring0 -> ?b => - let r:= lpol_goal b in - constr:(a::r) - | ?a = ring0 => constr:(a::nil) - end. - (* lp est incluse dans fv. La met en tete. *) Ltac parametres_en_tete fv lp := @@ -344,13 +287,12 @@ Ltac rev l := | (cons ?x ?l) => let l' := rev l in append1 x l' end. - - Ltac nsatz_call_n info nparam p rr lp kont := - (*idtac "Trying power: " rr;*) +(* idtac "Trying power: " rr;*) let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in +(* idtac "calcul...";*) nsatz_compute ll; - (*idtac "done";*) +(* idtac "done";*) match goal with | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => intros _; @@ -364,58 +306,20 @@ Ltac nsatz_call radicalmax info nparam p lp kont := lazymatch n with | 0%N => fail | _ => - (let r := eval compute in (Nminus radicalmax (Npred n)) in + (let r := eval compute in (N.sub radicalmax (N.pred n)) in nsatz_call_n info nparam p r lp kont) || - let n' := eval compute in (Npred n) in try_n n' + let n' := eval compute in (N.pred n) in try_n n' end in try_n radicalmax. -Set Implicit Arguments. -Class Cclosed_seq T (l:list T) := {}. -Instance Iclosed_nil T : Cclosed_seq (T:=T) nil. -Instance Iclosed_cons T t l `{Cclosed_seq (T:=T) l} : Cclosed_seq (T:=T) (t::l). - -Class Cfind_at (R:Type) (b:R) (l:list R) (i:nat) := {}. -Instance Ifind0 (R:Type) (b:R) l: Cfind_at b (b::l) 0. -Instance IfindS (R:Type) (b2 b1:R) l i `{Cfind_at R b1 l i} : Cfind_at b1 (b2::l) (S i) | 1. -Definition Ifind0' := Ifind0. -Definition IfindS' := IfindS. - -Definition li_find_at (R:Type) (b:R) l i `{Cfind_at R b l i} {H:Cclosed_seq (T:=R) l} := (l,i). - -Class Creify (R:Type) (e:PExpr Z) (l:list R) (b:R) := {}. -Instance Ireify_zero (R:Type) (Rd:Domain R) l : Creify (PEc 0%Z) l ring0. -Instance Ireify_one (R:Type) (Rd:Domain R) l : Creify (PEc 1%Z) l ring1. -Instance Ireify_plus (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} - : Creify (PEadd e1 e2) l (ring_plus b1 b2). -Instance Ireify_mult (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} - : Creify (PEmul e1 e2) l (ring_mult b1 b2). -Instance Ireify_sub (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2} - : Creify (PEsub e1 e2) l (ring_sub b1 b2). -Instance Ireify_opp (R:Type) (Rd:Domain R) e1 l b1 `{Creify R e1 l b1} - : Creify (PEopp e1) l (ring_opp b1). -Instance Ireify_var (R:Type) b l i `{Cfind_at R b l i} - : Creify (PEX _ (P_of_succ_nat i)) l b | 100. - - -Class Creifylist (R:Type) (le:list (PExpr Z)) (l:list R) (lb:list R) := {}. -Instance Creify_nil (R:Type) l : Creifylist nil l (@nil R). -Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2} - : Creifylist (e1::le2) l (b1::lb2). - -Definition li_reifyl (R:Type) le l lb `{Creifylist R le l lb} - {H:Cclosed_seq (T:=R) l} := (l,le). - -Unset Implicit Arguments. - Ltac lterm_goal g := match g with - ring_eq ?b1 ?b2 => constr:(b1::b2::nil) - | ring_eq ?b1 ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) + ?b1 == ?b2 => constr:(b1::b2::nil) + | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) end. -Ltac reify_goal l le lb Rd:= +Ltac reify_goal l le lb:= match le with nil => idtac | ?e::?le1 => @@ -423,241 +327,182 @@ Ltac reify_goal l le lb Rd:= ?b::?lb1 => (* idtac "b="; idtac b;*) let x := fresh "B" in set (x:= b) at 1; - change x with (@interpret3 _ Rd e l); + change x with (interpret3 e l); clear x; - reify_goal l le1 lb1 Rd + reify_goal l le1 lb1 end end. Ltac get_lpol g := match g with - ring_eq (interpret3 _ _ ?p _) _ => constr:(p::nil) - | ring_eq (interpret3 _ _ ?p _) _ -> ?g => + (interpret3 ?p _) == _ => constr:(p::nil) + | (interpret3 ?p _) == _ -> ?g => let l := get_lpol g in constr:(p::l) end. -Ltac nsatz_domain_generic radicalmax info lparam lvar tacsimpl Rd := - match goal with - |- ?g => let lb := lterm_goal g in - (*idtac "lb"; idtac lb;*) - match eval red in (li_reifyl (lb:=lb)) with - | (?fv, ?le) => - let fv := match lvar with - (@nil _) => fv - | _ => lvar - end in - (* idtac "variables:";idtac fv;*) - let nparam := eval compute in (Z_of_nat (List.length lparam)) in - let fv := parametres_en_tete fv lparam in - (*idtac "variables:"; idtac fv; - idtac "nparam:"; idtac nparam; *) - match eval red in (li_reifyl (l:=fv) (lb:=lb)) with - | (?fv, ?le) => - (*idtac "variables:";idtac fv; idtac le; idtac lb;*) - reify_goal fv le lb Rd; - match goal with +Ltac nsatz_generic radicalmax info lparam lvar := + let nparam := eval compute in (Z.of_nat (List.length lparam)) in + match goal with + |- ?g => let lb := lterm_goal g in + match (match lvar with + |(@nil _) => + match lparam with + |(@nil _) => + let r := eval red in (list_reifyl (lterm:=lb)) in r + |_ => + match eval red in (list_reifyl (lterm:=lb)) with + |(?fv, ?le) => + let fv := parametres_en_tete fv lparam in + (* we reify a second time, with the good order + for variables *) + let r := eval red in + (list_reifyl (lterm:=lb) (lvar:=fv)) in r + end + end + |_ => + let fv := parametres_en_tete lvar lparam in + let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r + end) with + |(?fv, ?le) => + reify_goal fv le lb ; + match goal with |- ?g => let lp := get_lpol g in let lpol := eval compute in (List.rev lp) in - (*idtac "polynomes:"; idtac lpol;*) - tacsimpl; intros; - + intros; + let SplitPolyList kont := match lpol with | ?p2::?lp2 => kont p2 lp2 | _ => idtac "polynomial not in the ideal" end in - tacsimpl; + SplitPolyList ltac:(fun p lp => set (p21:=p) ; set (lp21:=lp); - (*idtac "lp:"; idtac lp; *) +(* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => set (q := PEmul c (PEpow p21 r)); let Hg := fresh "Hg" in assert (Hg:check lp21 q (lci,lq) = true); [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" | let Hg2 := fresh "Hg" in - assert (Hg2: ring_eq (interpret3 _ Rd q fv) ring0); - [ tacsimpl; - apply (@check_correct _ Rd fv lp21 q (lci,lq) Hg); - tacsimpl; + assert (Hg2: (interpret3 q fv) == 0); + [ (*simpl*) idtac; + generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg); + let cc := fresh "H" in + (*simpl*) idtac; intro cc; apply cc; clear cc; + (*simpl*) idtac; repeat (split;[assumption|idtac]); exact I - | simpl in Hg2; tacsimpl; - apply Rdomain_pow with (interpret3 _ Rd c fv) (Nnat.nat_of_N r); auto with domain; - tacsimpl; apply domain_axiom_one_zero - || (simpl) || idtac "could not prove discrimination result" + | (*simpl in Hg2;*) (*simpl*) idtac; + apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r); + (*simpl*) idtac; + try apply integral_domain_one_zero; + try apply integral_domain_minus_one_zero; + try trivial; + try exact integral_domain_one_zero; + try exact integral_domain_minus_one_zero + || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, + one, one_notation, multiplication, mul_notation, zero, zero_notation; + discrR || omega]) + || ((*simpl*) idtac) || idtac "could not prove discrimination result" ] ] ) ) -end end end end . +end end end . -Ltac nsatz_domainpv pretac radicalmax info lparam lvar tacsimpl rd := - pretac; - nsatz_domain_begin tacsimpl; auto with domain; - nsatz_domain_generic radicalmax info lparam lvar tacsimpl rd. +Ltac nsatz_default:= + intros; + try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); + match goal with |- (@equality ?r _ _ _) => + repeat equalities_to_goal; + nsatz_generic 6%N 1%Z (@nil r) (@nil r) + end. + +Tactic Notation "nsatz" := nsatz_default. -Ltac nsatz_domain:= +Tactic Notation "nsatz" "with" + "radicalmax" ":=" constr(radicalmax) + "strategy" ":=" constr(info) + "parameters" ":=" constr(lparam) + "variables" ":=" constr(lvar):= intros; - match goal with - |- (@ring_eq _ (@domain_ring ?r ?rd) _ _ ) => - nsatz_domainpv ltac:idtac 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd + try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); + match goal with |- (@equality ?r _ _ _) => + repeat equalities_to_goal; + nsatz_generic radicalmax info lparam lvar end. -(* Dans R *) +(* Real numbers *) Require Import Reals. Require Import RealField. -Instance Rri : Ring R := { - ring0 := 0%R; - ring1 := 1%R; - ring_plus := Rplus; - ring_mult := Rmult; - ring_sub := Rminus; - ring_opp := Ropp; - ring_eq := @eq R; - ring_ring := RTheory}. - -Lemma Raxiom_one_zero: 1%R <> 0%R. -discrR. +Lemma Rsth : Setoid_Theory R (@eq R). +constructor;red;intros;subst;trivial. Qed. -Instance Rdi : Domain R := { - domain_ring := Rri; - domain_axiom_product := Rmult_integral; - domain_axiom_one_zero := Raxiom_one_zero}. - -Hint Resolve ring_setoid ring_plus_comp ring_mult_comp ring_sub_comp ring_opp_comp: domain. - -Ltac replaceR:= -replace 0%R with (@ring0 _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; -replace 1%R with (@ring1 _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; -replace Rplus with (@ring_plus _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; -replace Rmult with (@ring_mult _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; -replace Rminus with (@ring_sub _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; -replace Ropp with (@ring_opp _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]; -replace (@eq R) with (@ring_eq _ (@domain_ring _ Rdi)) in *;[idtac|reflexivity]. - -Ltac simplR:= - simpl; replaceR. - -Ltac pretacR:= - replaceR; - replace Rri with (@domain_ring _ Rdi) in *; [idtac | reflexivity]. +Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). -Ltac nsatz_domainR:= - nsatz_domainpv ltac:pretacR 6%N 1%Z (@Datatypes.nil R) (@Datatypes.nil R) - ltac:simplR Rdi; - discrR. +Instance Rri : (Ring (Ro:=Rops)). +constructor; +try (try apply Rsth; + try (unfold respectful, Proper; unfold equality; unfold eq_notation in *; + intros; try rewrite H; try rewrite H0; reflexivity)). + exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. + exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. + exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. +exact Rplus_opp_r. +Defined. - -Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R. -nsatz_domainR. -Qed. - - -(* Dans Z *) -Instance Zri : Ring Z := { - ring0 := 0%Z; - ring1 := 1%Z; - ring_plus := Zplus; - ring_mult := Zmult; - ring_sub := Zminus; - ring_opp := Zopp; - ring_eq := (@eq Z); - ring_ring := Zth}. - -Lemma Zaxiom_one_zero: 1%Z <> 0%Z. -discriminate. +Lemma R_one_zero: 1%R <> 0%R. +discrR. Qed. -Instance Zdi : Domain Z := { - domain_ring := Zri; - domain_axiom_product := Zmult_integral; - domain_axiom_one_zero := Zaxiom_one_zero}. - -Ltac replaceZ := -replace 0%Z with (@ring0 _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; -replace 1%Z with (@ring1 _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; -replace Zplus with (@ring_plus _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; -replace Zmult with (@ring_mult _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; -replace Zminus with (@ring_sub _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; -replace Zopp with (@ring_opp _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]; -replace (@eq Z) with (@ring_eq _ (@domain_ring _ Zdi)) in *;[idtac|reflexivity]. - -Ltac simplZ:= - simpl; replaceZ. +Instance Rcri: (Cring (Rr:=Rri)). +red. exact Rmult_comm. Defined. -Ltac pretacZ := -replaceZ; -replace Zri with (@domain_ring _ Zdi) in *; [idtac | reflexivity]. +Instance Rdi : (Integral_domain (Rcr:=Rcri)). +constructor. +exact Rmult_integral. exact R_one_zero. Defined. -Ltac nsatz_domainZ:= -nsatz_domainpv ltac:pretacZ 6%N 1%Z (@Datatypes.nil Z) (@Datatypes.nil Z) ltac:simplZ Zdi. - - -(* Dans Q *) +(* Rational numbers *) Require Import QArith. -Instance Qri : Ring Q := { - ring0 := 0%Q; - ring1 := 1%Q; - ring_plus := Qplus; - ring_mult := Qmult; - ring_sub := Qminus; - ring_opp := Qopp; - ring_eq := Qeq; - ring_ring := Qsrt}. - -Lemma Qaxiom_one_zero: not (Qeq 1%Q 0%Q). -discriminate. +Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). + +Instance Qri : (Ring (Ro:=Qops)). +constructor. +try apply Q_Setoid. +apply Qplus_comp. +apply Qmult_comp. +apply Qminus_comp. +apply Qopp_comp. + exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. + exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. + apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. +reflexivity. exact Qplus_opp_r. +Defined. + +Lemma Q_one_zero: not (Qeq 1%Q 0%Q). +unfold Qeq. simpl. auto with *. Qed. + +Instance Qcri: (Cring (Rr:=Qri)). +red. exact Qmult_comm. Defined. + +Instance Qdi : (Integral_domain (Rcr:=Qcri)). +constructor. +exact Qmult_integral. exact Q_one_zero. Defined. + +(* Integers *) +Lemma Z_one_zero: 1%Z <> 0%Z. +omega. Qed. -Instance Qdi : Domain Q := { - domain_ring := Qri; - domain_axiom_product := Qmult_integral; - domain_axiom_one_zero := Qaxiom_one_zero}. - -Ltac replaceQ := -replace 0%Q with (@ring0 _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; -replace 1%Q with (@ring1 _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; -replace Qplus with (@ring_plus _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; -replace Qmult with (@ring_mult _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; -replace Qminus with (@ring_sub _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; -replace Qopp with (@ring_opp _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]; -replace Qeq with (@ring_eq _ (@domain_ring _ Qdi)) in *;[idtac|reflexivity]. - -Ltac simplQ:= - simpl; replaceQ. - -Ltac pretacQ := -replaceQ; -replace Qri with (@domain_ring _ Qdi) in *; [idtac | reflexivity]. - -Ltac nsatz_domainQ:= -nsatz_domainpv ltac:pretacQ 6%N 1%Z (@Datatypes.nil Q) (@Datatypes.nil Q) ltac:simplQ Qdi. - -(* tactique générique *) - -Ltac nsatz := - intros; - match goal with - | |- (@eq R _ _) => nsatz_domainR - | |- (@eq Z _ _) => nsatz_domainZ - | |- (@Qeq _ _) => nsatz_domainQ - | |- _ => nsatz_domain - end. -(* -Goal forall x y:Q, Qeq x y -> Qeq (x*x-x+1)%Q ((y*y-y)+1+0)%Q. -nsatz. -Qed. +Instance Zcri: (Cring (Rr:=Zr)). +red. exact Z.mul_comm. Defined. -Goal forall x y:Z, x = y -> (x*x-x+1)%Z = ((y*y-y)+1+0)%Z. -nsatz. -Qed. +Instance Zdi : (Integral_domain (Rcr:=Zcri)). +constructor. +exact Zmult_integral. exact Z_one_zero. Defined. -Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R. -nsatz. -Qed. -*) diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 5fde2cfc..68fb2626 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -237,7 +237,8 @@ open Format let getvar lv i = try (nth lv i) - with _ -> (fold_left (fun r x -> r^" "^x) "lv= " lv) + with e when Errors.noncritical e -> + (fold_left (fun r x -> r^" "^x) "lv= " lv) ^" i="^(string_of_int i) let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef @@ -363,7 +364,7 @@ let stringPcut p = nsP2:=10; let res = if (length p)> !nsP2 - then (stringP [hd p])^" + "^(string_of_int (length p))^" termes" + then (stringP [hd p])^" + "^(string_of_int (length p))^" terms" else stringP p in (*Polynomesrec.nsP1:= max_int;*) nsP2:= max_int; @@ -590,7 +591,7 @@ let coefpoldep = Hashtbl.create 51 (* coef of q in p = sum_i c_i*q_i *) let coefpoldep_find p q = try (Hashtbl.find coefpoldep (p.num,q.num)) - with _ -> [] + with Not_found -> [] let coefpoldep_remove p q = Hashtbl.remove coefpoldep (p.num,q.num) @@ -992,7 +993,7 @@ let pbuchf pq p lp0= coefpoldep_remove a q; coefpoldep_set a q c) lca !poldep; let a0 = a in - info ("\nnew polynomials: "^(stringPcut (ppol a0))^"\n"); + info ("\nnew polynomial: "^(stringPcut (ppol a0))^"\n"); let ct = coef1 (* contentP a0 *) in (*info ("content: "^(string_of_coef ct)^"\n");*) poldep:=addS a0 lp; diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4 index da0ee898..14c7609d 100644 --- a/plugins/nsatz/nsatz.ml4 +++ b/plugins/nsatz/nsatz.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -16,7 +16,7 @@ open Closure open Environ open Libnames open Tactics -open Rawterm +open Glob_term open Tacticals open Tacexpr open Pcoq @@ -180,21 +180,24 @@ let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow") -let tlist = lazy (gen_constant "CC" ["Lists";"List"] "list") -let lnil = lazy (gen_constant "CC" ["Lists";"List"] "nil") -let lcons = lazy (gen_constant "CC" ["Lists";"List"] "cons") +let datatypes = ["Init";"Datatypes"] +let binnums = ["Numbers";"BinNums"] -let tz = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z") -let z0 = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z0") -let zpos = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Zpos") -let zneg = lazy(gen_constant "CC" ["ZArith";"BinInt"] "Zneg") +let tlist = lazy (gen_constant "CC" datatypes "list") +let lnil = lazy (gen_constant "CC" datatypes "nil") +let lcons = lazy (gen_constant "CC" datatypes "cons") -let pxI = lazy(gen_constant "CC" ["NArith";"BinPos"] "xI") -let pxO = lazy(gen_constant "CC" ["NArith";"BinPos"] "xO") -let pxH = lazy(gen_constant "CC" ["NArith";"BinPos"] "xH") +let tz = lazy (gen_constant "CC" binnums "Z") +let z0 = lazy (gen_constant "CC" binnums "Z0") +let zpos = lazy (gen_constant "CC" binnums "Zpos") +let zneg = lazy(gen_constant "CC" binnums "Zneg") -let nN0 = lazy (gen_constant "CC" ["NArith";"BinNat"] "N0") -let nNpos = lazy(gen_constant "CC" ["NArith";"BinNat"] "Npos") +let pxI = lazy(gen_constant "CC" binnums "xI") +let pxO = lazy(gen_constant "CC" binnums "xO") +let pxH = lazy(gen_constant "CC" binnums "xH") + +let nN0 = lazy (gen_constant "CC" binnums "N0") +let nNpos = lazy(gen_constant "CC" binnums "Npos") let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) @@ -237,14 +240,14 @@ else let rec parse_pos p = match kind_of_term p with | App (a,[|p2|]) -> - if a = Lazy.force pxO then num_2 */ (parse_pos p2) + if eq_constr a (Lazy.force pxO) then num_2 */ (parse_pos p2) else num_1 +/ (num_2 */ (parse_pos p2)) | _ -> num_1 let parse_z z = match kind_of_term z with | App (a,[|p2|]) -> - if a = Lazy.force zpos then parse_pos p2 else (num_0 -/ (parse_pos p2)) + if eq_constr a (Lazy.force zpos) then parse_pos p2 else (num_0 -/ (parse_pos p2)) | _ -> num_0 let parse_n z = @@ -256,15 +259,15 @@ let parse_n z = let rec parse_term p = match kind_of_term p with | App (a,[|_;p2|]) -> - if a = Lazy.force ttvar then Var (string_of_num (parse_pos p2)) - else if a = Lazy.force ttconst then Const (parse_z p2) - else if a = Lazy.force ttopp then Opp (parse_term p2) + if eq_constr a (Lazy.force ttvar) then Var (string_of_num (parse_pos p2)) + else if eq_constr a (Lazy.force ttconst) then Const (parse_z p2) + else if eq_constr a (Lazy.force ttopp) then Opp (parse_term p2) else Zero | App (a,[|_;p2;p3|]) -> - if a = Lazy.force ttadd then Add (parse_term p2, parse_term p3) - else if a = Lazy.force ttsub then Sub (parse_term p2, parse_term p3) - else if a = Lazy.force ttmul then Mul (parse_term p2, parse_term p3) - else if a = Lazy.force ttpow then + if eq_constr a (Lazy.force ttadd) then Add (parse_term p2, parse_term p3) + else if eq_constr a (Lazy.force ttsub) then Sub (parse_term p2, parse_term p3) + else if eq_constr a (Lazy.force ttmul) then Mul (parse_term p2, parse_term p3) + else if eq_constr a (Lazy.force ttpow) then Pow (parse_term p2, int_of_num (parse_n p3)) else Zero | _ -> Zero @@ -323,6 +326,8 @@ open PIdeal let term_pol_sparse np t= let d = !nvars in let rec aux t = +(* info ("conversion de: "^(string_of_term t)^"\n");*) + let res = match t with | Zero -> zeroP | Const r -> @@ -339,9 +344,11 @@ let term_pol_sparse np t= | Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2)) | Mul (t1,t2) -> multP (aux t1) (aux t2) | Pow (t1,n) -> puisP (aux t1) n - in (*info ("conversion de: "^(string_of_term t)^"\n");*) + in +(* info ("donne: "^(stringP res)^"\n");*) + res + in let res= aux t in - (*info ("donne: "^(stringP res)^"\n");*) res (* sparse polynomial to term *) @@ -364,7 +371,7 @@ let polrec_to_term p = (* approximation of the Horner form used in the tactic ring *) let pol_sparse_to_term n2 p = - info "pol_sparse_to_term ->\n"; + (* info "pol_sparse_to_term ->\n";*) let p = PIdeal.repr p in let rec aux p = match p with @@ -408,7 +415,7 @@ let pol_sparse_to_term n2 p = then Var (string_of_int (i0)) else pow (Var (string_of_int (i0)),e0) in add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2)))) - in info "-> pol_sparse_to_term\n"; + in (*info "-> pol_sparse_to_term\n";*) aux p @@ -489,35 +496,35 @@ let theoremedeszeros_termes lp = match lp with | Const (Int sugarparam)::Const (Int nparam)::lp -> ((match sugarparam with - |0 -> info "calcul sans sugar\n"; + |0 -> info "computation without sugar\n"; lexico:=false; sugar_flag := false; divide_rem_with_critical_pair := false - |1 -> info "calcul avec sugar\n"; + |1 -> info "computation with sugar\n"; lexico:=false; sugar_flag := true; divide_rem_with_critical_pair := false - |2 -> info "ordre lexico calcul sans sugar\n"; + |2 -> info "ordre lexico computation without sugar\n"; lexico:=true; sugar_flag := false; divide_rem_with_critical_pair := false - |3 -> info "ordre lexico calcul avec sugar\n"; + |3 -> info "ordre lexico computation with sugar\n"; lexico:=true; sugar_flag := true; divide_rem_with_critical_pair := false - |4 -> info "calcul sans sugar, division par les paires\n"; + |4 -> info "computation without sugar, division by pairs\n"; lexico:=false; sugar_flag := false; divide_rem_with_critical_pair := true - |5 -> info "calcul avec sugar, division par les paires\n"; + |5 -> info "computation with sugar, division by pairs\n"; lexico:=false; sugar_flag := true; divide_rem_with_critical_pair := true - |6 -> info "ordre lexico calcul sans sugar, division par les paires\n"; + |6 -> info "ordre lexico computation without sugar, division by pairs\n"; lexico:=true; sugar_flag := false; divide_rem_with_critical_pair := true - |7 -> info "ordre lexico calcul avec sugar, division par les paires\n"; + |7 -> info "ordre lexico computation with sugar, division by pairs\n"; lexico:=true; sugar_flag := true; divide_rem_with_critical_pair := true @@ -534,6 +541,7 @@ let theoremedeszeros_termes lp = | p::lp1 -> let lpol = List.rev lp1 in let (cert,lp0,p,_lct) = theoremedeszeros lpol p in + info "cert ok\n"; let lc = cert.last_comb::List.rev cert.gb_comb in match remove_zeros (fun x -> x=zeroP) lc with | [] -> assert false @@ -545,8 +553,8 @@ let theoremedeszeros_termes lp = let lci = List.rev lci in let lci = List.map (List.map (pol_sparse_to_term m)) lci in let lq = List.map (pol_sparse_to_term m) lq in - info ("nombre de parametres: "^string_of_int nparam^"\n"); - info "terme calcule\n"; + info ("number of parametres: "^string_of_int nparam^"\n"); + info "term computed\n"; (c,r,lci,lq) ) |_ -> assert false @@ -565,7 +573,7 @@ let nsatz lpol = let certif = hash_certif certif in let certif = certif_term certif in let c = mkt_term c in - info "constr calcule\n"; + info "constr computed\n"; (c, certif) *) @@ -586,7 +594,7 @@ let nsatz lpol = mkt_app lcons [tlp ();ltterm;r]) res (mkt_app lnil [tlp ()]) in - info "terme calcule\n"; + info "term computed\n"; res let return_term t = diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml index ee7b9f33..fdc8e865 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -173,7 +173,7 @@ let rec equal p q = then failwith "raté") p1; true) - with _ -> false) + with e when Errors.noncritical e -> false) | (_,_) -> false (* normalize polynomial: remove head zeros, coefficients are normalized @@ -282,12 +282,11 @@ let rec multx n v p = p2.(i+n)<-p1.(i); done; Prec (x,p2) - |_ -> if p = (Pint coef0) then (Pint coef0) + |_ -> if equal p (Pint coef0) then (Pint coef0) else (let p2=Array.create (n+1) (Pint coef0) in p2.(n)<-p; Prec (v,p2)) - (* product *) let rec multP p q = match (p,q) with @@ -525,7 +524,7 @@ let div_pol_rat p q= q x in (* degueulasse, mais c 'est pour enlever un warning *) if s==s then true else true) - with _ -> false + with e when Errors.noncritical e -> false (*********************************************************************** 5. Pseudo-division and gcd with subresultants. diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli index 980a8306..0643327f 100644 --- a/plugins/nsatz/polynom.mli +++ b/plugins/nsatz/polynom.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index c16bd425..17c8654b 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -33,10 +33,11 @@ let set_of_list_eq eq l = let memos s memoire nf f x = try (let v = Hashtbl.find memoire (nf x) in pr s;v) - with _ -> (pr "#"; - let v = f x in - Hashtbl.add memoire (nf x) v; - v) + with e when Errors.noncritical e -> + (pr "#"; + let v = f x in + Hashtbl.add memoire (nf x) v; + v) (********************************************************************** @@ -64,7 +65,7 @@ let facteurs_liste div constant lp = if not (constant r) then l1:=r::(!l1) else p_dans_lmin:=true) - with _ -> ()) + with e when Errors.noncritical e -> ()) lmin; if !p_dans_lmin then factor lmin lp1 @@ -75,7 +76,8 @@ let facteurs_liste div constant lp = List.iter (fun q -> try (let r = div q p in if not (constant r) then l1:=r::(!l1)) - with _ -> lmin1:=q::(!lmin1)) + with e when Errors.noncritical e -> + lmin1:=q::(!lmin1)) lmin; factor (List.rev (p::(!lmin1))) !l1) (* au moins un q de lmin divise p non trivialement *) @@ -105,7 +107,7 @@ let factorise_tableau div zero c f l1 = li:=j::(!li); r:=rr; done) - with _ -> ()) + with e when Errors.noncritical e -> ()) l1; res.(i)<-(!r,!li)) f; diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v index c8a06265..ea5a8cb7 100644 --- a/plugins/omega/Omega.v +++ b/plugins/omega/Omega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,17 +13,15 @@ (* *) (**************************************************************************) -(* $Id: Omega.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (* We do not require [ZArith] anymore, but only what's necessary for Omega *) Require Export ZArith_base. Require Export OmegaLemmas. Require Export PreOmega. Declare ML Module "omega_plugin". -Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l - Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l - Zmult_plus_distr_r: zarith. +Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l + Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_r + Z.mul_add_distr_l: zarith. Require Export Zhints. diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v index ec9faedd..1872f576 100644 --- a/plugins/omega/OmegaLemmas.v +++ b/plugins/omega/OmegaLemmas.v @@ -6,234 +6,192 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id: OmegaLemmas.v 12337 2009-09-17 15:58:14Z glondu $ i*) - -Require Import ZArith_base. -Open Local Scope Z_scope. +Require Import BinInt Znat. +Local Open Scope Z_scope. (** Factorization lemmas *) -Theorem Zred_factor0 : forall n:Z, n = n * 1. - intro x; rewrite (Zmult_1_r x); reflexivity. +Theorem Zred_factor0 n : n = n * 1. +Proof. + now Z.nzsimpl. Qed. -Theorem Zred_factor1 : forall n:Z, n + n = n * 2. +Theorem Zred_factor1 n : n + n = n * 2. Proof. - exact Zplus_diag_eq_mult_2. + rewrite Z.mul_comm. apply Z.add_diag. Qed. -Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m). +Theorem Zred_factor2 n m : n + n * m = n * (1 + m). Proof. - intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; trivial with arith. + rewrite Z.mul_add_distr_l; now Z.nzsimpl. Qed. -Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m). +Theorem Zred_factor3 n m : n * m + n = n * (1 + m). Proof. - intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; - trivial with arith. + now Z.nzsimpl. Qed. -Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p). +Theorem Zred_factor4 n m p : n * m + n * p = n * (m + p). Proof. - intros x y z; symmetry in |- *; apply Zmult_plus_distr_r. + symmetry; apply Z.mul_add_distr_l. Qed. -Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m. +Theorem Zred_factor5 n m : n * 0 + m = m. Proof. - intros x y; rewrite <- Zmult_0_r_reverse; auto with arith. + now Z.nzsimpl. Qed. -Theorem Zred_factor6 : forall n:Z, n = n + 0. +Theorem Zred_factor6 n : n = n + 0. Proof. - intro; rewrite Zplus_0_r; trivial with arith. + now Z.nzsimpl. Qed. (** Other specific variants of theorems dedicated for the Omega tactic *) Lemma new_var : forall x : Z, exists y : Z, x = y. -intros x; exists x; trivial with arith. +Proof. +intros x; now exists x. Qed. -Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y. -intros x y H; rewrite H; auto with arith. +Lemma OMEGA1 x y : x = y -> 0 <= x -> 0 <= y. +Proof. +now intros ->. Qed. -Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y. -exact Zplus_le_0_compat. +Lemma OMEGA2 x y : 0 <= x -> 0 <= y -> 0 <= x + y. +Proof. +Z.order_pos. Qed. -Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0. - -intros x y k H1 H2 H3; apply (Zmult_integral_l k); - [ unfold not in |- *; intros H4; absurd (k > 0); - [ rewrite H4; unfold Zgt in |- *; simpl in |- *; discriminate - | assumption ] - | rewrite <- H2; assumption ]. +Lemma OMEGA3 x y k : k > 0 -> x = y * k -> x = 0 -> y = 0. +Proof. +intros LT -> EQ. apply Z.mul_eq_0 in EQ. destruct EQ; now subst. Qed. -Lemma OMEGA4 : forall x y z : Z, x > 0 -> y > x -> z * y + x <> 0. - -unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0); - [ intros H4; cut (0 <= z * y + x); - [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6; - absurd (z * y + x > 0); - [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate - | apply Zle_gt_trans with x; - [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x); - apply Zplus_le_compat_r; rewrite Zmult_comm; - generalize H4; unfold Zgt in |- *; case y; - [ simpl in |- *; intros H7; discriminate H7 - | intros p H7; rewrite <- (Zmult_0_r (Zpos p)); - unfold Zle in |- *; rewrite Zcompare_mult_compat; - exact H6 - | simpl in |- *; intros p H7; discriminate H7 ] - | assumption ] ] - | rewrite H3; unfold Zle in |- *; simpl in |- *; discriminate ] - | apply Zgt_trans with x; [ assumption | assumption ] ]. +Lemma OMEGA4 x y z : x > 0 -> y > x -> z * y + x <> 0. +Proof. +Z.swap_greater. intros Hx Hxy. +rewrite Z.add_move_0_l, <- Z.mul_opp_l. +destruct (Z.lt_trichotomy (-z) 1) as [LT|[->|GT]]. +- intro. revert LT. apply Z.le_ngt, (Z.le_succ_l 0). + apply Z.mul_pos_cancel_r with y; Z.order. +- Z.nzsimpl. Z.order. +- rewrite (Z.mul_lt_mono_pos_r y), Z.mul_1_l in GT; Z.order. Qed. -Lemma OMEGA5 : forall x y z : Z, x = 0 -> y = 0 -> x + y * z = 0. - -intros x y z H1 H2; rewrite H1; rewrite H2; simpl in |- *; trivial with arith. +Lemma OMEGA5 x y z : x = 0 -> y = 0 -> x + y * z = 0. +Proof. +now intros -> ->. Qed. -Lemma OMEGA6 : forall x y z : Z, 0 <= x -> y = 0 -> 0 <= x + y * z. - -intros x y z H1 H2; rewrite H2; simpl in |- *; rewrite Zplus_0_r; assumption. +Lemma OMEGA6 x y z : 0 <= x -> y = 0 -> 0 <= x + y * z. +Proof. +intros H ->. now Z.nzsimpl. Qed. -Lemma OMEGA7 : - forall x y z t : Z, z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t. - -intros x y z t H1 H2 H3 H4; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; - apply Zmult_gt_0_le_0_compat; assumption. +Lemma OMEGA7 x y z t : + z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t. +Proof. +intros. Z.swap_greater. Z.order_pos. Qed. -Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0. - -intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1); - [ intros H4; absurd (0 < x); - [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y; - rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; - assumption - | assumption ] - | intros H4; rewrite H4; trivial with arith ]. +Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0. +Proof. +intros H1 H2 H3. rewrite <- Z.opp_nonpos_nonneg in H2. Z.order. Qed. -Lemma OMEGA9 : forall x y z t : Z, y = 0 -> x = z -> y + (- x + z) * t = 0. - -intros x y z t H1 H2; rewrite H2; rewrite Zplus_opp_l; rewrite Zmult_0_l; - rewrite Zplus_0_r; assumption. +Lemma OMEGA9 x y z t : y = 0 -> x = z -> y + (- x + z) * t = 0. +Proof. +intros. subst. now rewrite Z.add_opp_diag_l. Qed. -Lemma OMEGA10 : - forall v c1 c2 l1 l2 k1 k2 : Z, +Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 : (v * c1 + l1) * k1 + (v * c2 + l2) * k2 = v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2). - -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - rewrite (Zplus_permute (l1 * k1) (v * c2 * k2)); trivial with arith. +Proof. +rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. +rewrite <- !Z.add_assoc. f_equal. apply Z.add_shuffle3. Qed. -Lemma OMEGA11 : - forall v1 c1 l1 l2 k1 : Z, +Lemma OMEGA11 v1 c1 l1 l2 k1 : (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). - -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - trivial with arith. +Proof. +rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. +now rewrite Z.add_assoc. Qed. -Lemma OMEGA12 : - forall v2 c2 l1 l2 k2 : Z, +Lemma OMEGA12 v2 c2 l1 l2 k2 : l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). - -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - rewrite Zplus_permute; trivial with arith. +Proof. +rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. +apply Z.add_shuffle3. Qed. -Lemma OMEGA13 : - forall (v l1 l2 : Z) (x : positive), +Lemma OMEGA13 (v l1 l2 : Z) (x : positive) : v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2. - -intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1); - rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r; - rewrite <- Zopp_neg; rewrite (Zplus_comm (- Zneg x) (Zneg x)); - rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r; - trivial with arith. +Proof. + rewrite Z.add_shuffle1. + rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. + now Z.nzsimpl. Qed. -Lemma OMEGA14 : - forall (v l1 l2 : Z) (x : positive), +Lemma OMEGA14 (v l1 l2 : Z) (x : positive) : v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2. - -intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1); - rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r; - rewrite <- Zopp_neg; rewrite Zplus_opp_r; rewrite Zmult_0_r; - rewrite Zplus_0_r; trivial with arith. +Proof. + rewrite Z.add_shuffle1. + rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r. + now Z.nzsimpl. Qed. -Lemma OMEGA15 : - forall v c1 c2 l1 l2 k2 : Z, - v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - rewrite (Zplus_permute l1 (v * c2 * k2)); trivial with arith. +Lemma OMEGA15 v c1 c2 l1 l2 k2 : + v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2). +Proof. + rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. + apply Z.add_shuffle1. Qed. -Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k. - -intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; - trivial with arith. +Lemma OMEGA16 v c l k : (v * c + l) * k = v * (c * k) + l * k. +Proof. + now rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc. Qed. -Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0. - -unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; - apply Zplus_reg_l with (y * z); rewrite Zplus_comm; - rewrite H3; rewrite H2; auto with arith. +Lemma OMEGA17 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. +Proof. + unfold Zne, not. intros NE EQ. subst. now Z.nzsimpl. Qed. -Lemma OMEGA18 : forall x y k : Z, x = y * k -> Zne x 0 -> Zne y 0. - -unfold Zne, not in |- *; intros x y k H1 H2 H3; apply H2; rewrite H1; - rewrite H3; auto with arith. +Lemma OMEGA18 x y k : x = y * k -> Zne x 0 -> Zne y 0. +Proof. + unfold Zne, not. intros. subst; auto. Qed. -Lemma OMEGA19 : forall x : Z, Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1. - -unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x); - [ intros H1; elim Zle_lt_or_eq with (1 := H1); - [ intros H2; left; change (0 <= Zpred x) in |- *; apply Zsucc_le_reg; - rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption - | intros H2; absurd (x = 0); auto with arith ] - | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm; - apply Zle_left; apply Zsucc_le_reg; simpl in |- *; - apply Zlt_le_succ; auto with arith ]. +Lemma OMEGA19 x : Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1. +Proof. + unfold Zne. intros Hx. apply Z.lt_gt_cases in Hx. + destruct Hx as [LT|GT]. + - right. change (-1) with (-(1)). + rewrite Z.mul_opp_r, <- Z.opp_add_distr. Z.nzsimpl. + rewrite Z.opp_nonneg_nonpos. now apply Z.le_succ_l. + - left. now apply Z.lt_le_pred. Qed. -Lemma OMEGA20 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0. - -unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; rewrite H2 in H3; - simpl in H3; rewrite Zplus_0_r in H3; trivial with arith. +Lemma OMEGA20 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0. +Proof. + unfold Zne, not. intros H1 H2 H3; apply H1; rewrite H2 in H3; + simpl in H3; rewrite Z.add_0_r in H3; trivial with arith. Qed. Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop) - (H : P (y + x)) := eq_ind_r P H (Zplus_comm x y). + (H : P (y + x)) := eq_ind_r P H (Z.add_comm x y). Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p). Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) - (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p). + (H : P (n + m + p)) := eq_ind_r P H (Z.add_assoc n m p). Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop) - (H : P (m + (n + p))) := eq_ind_r P H (Zplus_permute n m p). + (H : P (m + (n + p))) := eq_ind_r P H (Z.add_shuffle3 n m p). Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop) (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) := @@ -261,24 +219,24 @@ Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x). Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop) - (H : P (x * -1)) := eq_ind_r P H (Zopp_eq_mult_neg_1 x). + (H : P (x * -1)) := eq_ind_r P H (Z.opp_eq_mul_m1 x). Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop) - (H : P (y * x)) := eq_ind_r P H (Zmult_comm x y). + (H : P (y * x)) := eq_ind_r P H (Z.mul_comm x y). Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) - (H : P (- x + - y)) := eq_ind_r P H (Zopp_plus_distr x y). + (H : P (- x + - y)) := eq_ind_r P H (Z.opp_add_distr x y). Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) := - eq_ind_r P H (Zopp_involutive x). + eq_ind_r P H (Z.opp_involutive x). Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) - (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p). + (H : P (n * p + m * p)) := eq_ind_r P H (Z.mul_add_distr_r n m p). Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) - (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y). + (H : P (x * - y)) := eq_ind_r P H (Z.mul_opp_comm x y). Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). @@ -300,3 +258,10 @@ Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x). + +Theorem intro_Z : + forall n:nat, exists y : Z, Z.of_nat n = y /\ 0 <= y * 1 + 0. +Proof. + intros n; exists (Z.of_nat n); split; trivial. + rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. +Qed. diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v index 69a6ea72..433db414 100644 --- a/plugins/omega/OmegaPlugin.v +++ b/plugins/omega/OmegaPlugin.v @@ -1,11 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: OmegaPlugin.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Declare ML Module "omega_plugin". diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index a5a085a9..60e606a6 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -1,6 +1,14 @@ -Require Import Arith Max Min ZArith_base NArith Nnat. +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) -Open Local Scope Z_scope. +Require Import Arith Max Min BinInt BinNat Znat Nnat. + +Local Open Scope Z_scope. (** * zify: the Z-ification tactic *) @@ -15,20 +23,20 @@ Open Local Scope Z_scope. - { eq, le, lt, ge, gt } on { Z, positive, N, nat } Recognized operations: - - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < = - - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat - - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat - - on N: N0 Npos + * - Nsucc Nmin Nmax N_of_nat Zabs_N + - on Z: Z.min, Z.max, Z.abs, Z.sgn are translated in term of <= < = + - on nat: + * - S O pred min max Pos.to_nat N.to_nat Z.abs_nat + - on positive: Zneg Zpos xI xO xH + * - Pos.succ Pos.pred Pos.min Pos.max Pos.of_succ_nat + - on N: N0 Npos + * - N.succ N.min N.max N.of_nat Z.abs_N *) -(** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *) +(** I) translation of Z.max, Z.min, Z.abs, Z.sgn into recognized equations *) Ltac zify_unop_core t thm a := (* Let's introduce the specification theorem for t *) - let H:= fresh "H" in assert (H:=thm a); + pose proof (thm a); (* Then we replace (t a) everywhere with a fresh variable *) let z := fresh "z" in set (z:=t a) in *; clearbody z. @@ -48,7 +56,7 @@ Ltac zify_unop t thm a := end. Ltac zify_unop_nored t thm a := - (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *) + (* in this version, we don't try to reduce the unop (that can be (Z.add x)) *) let isz := isZcst a in match isz with | true => zify_unop_core t thm a @@ -72,14 +80,14 @@ Ltac zify_binop t thm a b:= Ltac zify_op_1 := match goal with - | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b - | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b - | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b - | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b - | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a - | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a - | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a - | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a + | |- context [ Z.max ?a ?b ] => zify_binop Z.max Z.max_spec a b + | H : context [ Z.max ?a ?b ] |- _ => zify_binop Z.max Z.max_spec a b + | |- context [ Z.min ?a ?b ] => zify_binop Z.min Z.min_spec a b + | H : context [ Z.min ?a ?b ] |- _ => zify_binop Z.min Z.min_spec a b + | |- context [ Z.sgn ?a ] => zify_unop Z.sgn Z.sgn_spec a + | H : context [ Z.sgn ?a ] |- _ => zify_unop Z.sgn Z.sgn_spec a + | |- context [ Z.abs ?a ] => zify_unop Z.abs Z.abs_spec a + | H : context [ Z.abs ?a ] |- _ => zify_unop Z.abs Z.abs_spec a end. Ltac zify_op := repeat zify_op_1. @@ -91,113 +99,95 @@ Ltac zify_op := repeat zify_op_1. (** II) Conversion from nat to Z *) -Definition Z_of_nat' := Z_of_nat. +Definition Z_of_nat' := Z.of_nat. Ltac hide_Z_of_nat t := - let z := fresh "z" in set (z:=Z_of_nat t) in *; - change Z_of_nat with Z_of_nat' in z; + let z := fresh "z" in set (z:=Z.of_nat t) in *; + change Z.of_nat with Z_of_nat' in z; unfold z in *; clear z. Ltac zify_nat_rel := match goal with (* I: equalities *) - | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H - | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b) - | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H - | |- context [ @eq nat ?a ?b ] => rewrite (inj_eq_iff a b) + | |- (@eq nat ?a ?b) => apply (Nat2Z.inj a b) (* shortcut *) + | H : context [ @eq nat ?a ?b ] |- _ => rewrite <- (Nat2Z.inj_iff a b) in H + | |- context [ @eq nat ?a ?b ] => rewrite <- (Nat2Z.inj_iff a b) (* II: less than *) - | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H - | |- (lt ?a ?b) => apply (inj_lt_rev a b) - | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H - | |- context [ lt ?a ?b ] => rewrite (inj_lt_iff a b) + | H : context [ lt ?a ?b ] |- _ => rewrite (Nat2Z.inj_lt a b) in H + | |- context [ lt ?a ?b ] => rewrite (Nat2Z.inj_lt a b) (* III: less or equal *) - | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H - | |- (le ?a ?b) => apply (inj_le_rev a b) - | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H - | |- context [ le ?a ?b ] => rewrite (inj_le_iff a b) + | H : context [ le ?a ?b ] |- _ => rewrite (Nat2Z.inj_le a b) in H + | |- context [ le ?a ?b ] => rewrite (Nat2Z.inj_le a b) (* IV: greater than *) - | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H - | |- (gt ?a ?b) => apply (inj_gt_rev a b) - | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H - | |- context [ gt ?a ?b ] => rewrite (inj_gt_iff a b) + | H : context [ gt ?a ?b ] |- _ => rewrite (Nat2Z.inj_gt a b) in H + | |- context [ gt ?a ?b ] => rewrite (Nat2Z.inj_gt a b) (* V: greater or equal *) - | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H - | |- (ge ?a ?b) => apply (inj_ge_rev a b) - | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H - | |- context [ ge ?a ?b ] => rewrite (inj_ge_iff a b) + | H : context [ ge ?a ?b ] |- _ => rewrite (Nat2Z.inj_ge a b) in H + | |- context [ ge ?a ?b ] => rewrite (Nat2Z.inj_ge a b) end. Ltac zify_nat_op := match goal with (* misc type conversions: positive/N/Z to nat *) - | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H - | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) - | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H - | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a) - | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H - | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a) - - (* plus -> Zplus *) - | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H - | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b) - - (* min -> Zmin *) - | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H - | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b) - - (* max -> Zmax *) - | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H - | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b) - - (* minus -> Zmax (Zminus ... ...) 0 *) - | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H - | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b) - - (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *) - | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H - | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a) - - (* mult -> Zmult and a positivity hypothesis *) - | H : context [ Z_of_nat (mult ?a ?b) ] |- _ => - let H:= fresh "H" in - assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * - | |- context [ Z_of_nat (mult ?a ?b) ] => - let H:= fresh "H" in - assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * + | H : context [ Z.of_nat (Pos.to_nat ?a) ] |- _ => rewrite (positive_nat_Z a) in H + | |- context [ Z.of_nat (Pos.to_nat ?a) ] => rewrite (positive_nat_Z a) + | H : context [ Z.of_nat (N.to_nat ?a) ] |- _ => rewrite (N_nat_Z a) in H + | |- context [ Z.of_nat (N.to_nat ?a) ] => rewrite (N_nat_Z a) + | H : context [ Z.of_nat (Z.abs_nat ?a) ] |- _ => rewrite (Zabs2Nat.id_abs a) in H + | |- context [ Z.of_nat (Z.abs_nat ?a) ] => rewrite (Zabs2Nat.id_abs a) + + (* plus -> Z.add *) + | H : context [ Z.of_nat (plus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_add a b) in H + | |- context [ Z.of_nat (plus ?a ?b) ] => rewrite (Nat2Z.inj_add a b) + + (* min -> Z.min *) + | H : context [ Z.of_nat (min ?a ?b) ] |- _ => rewrite (Nat2Z.inj_min a b) in H + | |- context [ Z.of_nat (min ?a ?b) ] => rewrite (Nat2Z.inj_min a b) + + (* max -> Z.max *) + | H : context [ Z.of_nat (max ?a ?b) ] |- _ => rewrite (Nat2Z.inj_max a b) in H + | |- context [ Z.of_nat (max ?a ?b) ] => rewrite (Nat2Z.inj_max a b) + + (* minus -> Z.max (Z.sub ... ...) 0 *) + | H : context [ Z.of_nat (minus ?a ?b) ] |- _ => rewrite (Nat2Z.inj_sub_max a b) in H + | |- context [ Z.of_nat (minus ?a ?b) ] => rewrite (Nat2Z.inj_sub_max a b) + + (* pred -> minus ... -1 -> Z.max (Z.sub ... -1) 0 *) + | H : context [ Z.of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H + | |- context [ Z.of_nat (pred ?a) ] => rewrite (pred_of_minus a) + + (* mult -> Z.mul and a positivity hypothesis *) + | H : context [ Z.of_nat (mult ?a ?b) ] |- _ => + pose proof (Nat2Z.is_nonneg (mult a b)); + rewrite (Nat2Z.inj_mul a b) in * + | |- context [ Z.of_nat (mult ?a ?b) ] => + pose proof (Nat2Z.is_nonneg (mult a b)); + rewrite (Nat2Z.inj_mul a b) in * (* O -> Z0 *) - | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H - | |- context [ Z_of_nat O ] => simpl (Z_of_nat O) + | H : context [ Z.of_nat O ] |- _ => simpl (Z.of_nat O) in H + | |- context [ Z.of_nat O ] => simpl (Z.of_nat O) - (* S -> number or Zsucc *) - | H : context [ Z_of_nat (S ?a) ] |- _ => + (* S -> number or Z.succ *) + | H : context [ Z.of_nat (S ?a) ] |- _ => let isnat := isnatcst a in match isnat with - | true => simpl (Z_of_nat (S a)) in H - | _ => rewrite (inj_S a) in H + | true => simpl (Z.of_nat (S a)) in H + | _ => rewrite (Nat2Z.inj_succ a) in H end - | |- context [ Z_of_nat (S ?a) ] => + | |- context [ Z.of_nat (S ?a) ] => let isnat := isnatcst a in match isnat with - | true => simpl (Z_of_nat (S a)) - | _ => rewrite (inj_S a) + | true => simpl (Z.of_nat (S a)) + | _ => rewrite (Nat2Z.inj_succ a) end (* atoms of type nat : we add a positivity condition (if not already there) *) - | H : context [ Z_of_nat ?a ] |- _ => - match goal with - | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a - | H' : 0 <= Z_of_nat' a |- _ => fail - | _ => let H:= fresh "H" in - assert (H:=Zle_0_nat a); hide_Z_of_nat a - end - | |- context [ Z_of_nat ?a ] => - match goal with - | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a - | H' : 0 <= Z_of_nat' a |- _ => fail - | _ => let H:= fresh "H" in - assert (H:=Zle_0_nat a); hide_Z_of_nat a - end + | _ : 0 <= Z.of_nat ?a |- _ => hide_Z_of_nat a + | _ : context [ Z.of_nat ?a ] |- _ => + pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a + | |- context [ Z.of_nat ?a ] => + pose proof (Nat2Z.is_nonneg a); hide_Z_of_nat a end. Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. @@ -218,22 +208,21 @@ Ltac hide_Zpos t := Ltac zify_positive_rel := match goal with (* I: equalities *) - | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H - | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b) - | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H - | |- context [ @eq positive ?a ?b ] => rewrite (Zpos_eq_iff a b) + | |- (@eq positive ?a ?b) => apply Pos2Z.inj + | H : context [ @eq positive ?a ?b ] |- _ => rewrite <- (Pos2Z.inj_iff a b) in H + | |- context [ @eq positive ?a ?b ] => rewrite <- (Pos2Z.inj_iff a b) (* II: less than *) - | H : context [ (?a<?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H - | |- context [ (?a<?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b) + | H : context [ (?a < ?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H + | |- context [ (?a < ?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b) (* III: less or equal *) - | H : context [ (?a<=?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H - | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) + | H : context [ (?a <= ?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H + | |- context [ (?a <= ?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b) (* IV: greater than *) - | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H - | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) + | H : context [ (?a > ?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H + | |- context [ (?a > ?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b) (* V: greater or equal *) - | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H - | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) + | H : context [ (?a >= ?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H + | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) end. Ltac zify_positive_op := @@ -253,66 +242,66 @@ Ltac zify_positive_op := end (* misc type conversions: nat to positive *) - | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H - | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) + | H : context [ Zpos (Pos.of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H + | |- context [ Zpos (Pos.of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a) - (* Pplus -> Zplus *) - | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H - | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) + (* Pos.add -> Z.add *) + | H : context [ Zpos (?a + ?b) ] |- _ => change (Zpos (a+b)) with (Zpos a + Zpos b) in H + | |- context [ Zpos (?a + ?b) ] => change (Zpos (a+b)) with (Zpos a + Zpos b) - (* Pmin -> Zmin *) - | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H - | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b) + (* Pos.min -> Z.min *) + | H : context [ Zpos (Pos.min ?a ?b) ] |- _ => rewrite (Pos2Z.inj_min a b) in H + | |- context [ Zpos (Pos.min ?a ?b) ] => rewrite (Pos2Z.inj_min a b) - (* Pmax -> Zmax *) - | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H - | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b) + (* Pos.max -> Z.max *) + | H : context [ Zpos (Pos.max ?a ?b) ] |- _ => rewrite (Pos2Z.inj_max a b) in H + | |- context [ Zpos (Pos.max ?a ?b) ] => rewrite (Pos2Z.inj_max a b) - (* Pminus -> Zmax 1 (Zminus ... ...) *) - | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H - | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b) + (* Pos.sub -> Z.max 1 (Z.sub ... ...) *) + | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub a b) in H + | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub a b) - (* Psucc -> Zsucc *) - | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H - | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a) + (* Pos.succ -> Z.succ *) + | H : context [ Zpos (Pos.succ ?a) ] |- _ => rewrite (Pos2Z.inj_succ a) in H + | |- context [ Zpos (Pos.succ ?a) ] => rewrite (Pos2Z.inj_succ a) - (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *) - | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H - | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a) + (* Pos.pred -> Pos.sub ... -1 -> Z.max 1 (Z.sub ... - 1) *) + | H : context [ Zpos (Pos.pred ?a) ] |- _ => rewrite <- (Pos.sub_1_r a) in H + | |- context [ Zpos (Pos.pred ?a) ] => rewrite <- (Pos.sub_1_r a) - (* Pmult -> Zmult and a positivity hypothesis *) - | H : context [ Zpos (Pmult ?a ?b) ] |- _ => - let H:= fresh "H" in - assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * - | |- context [ Zpos (Pmult ?a ?b) ] => - let H:= fresh "H" in - assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * + (* Pos.mul -> Z.mul and a positivity hypothesis *) + | H : context [ Zpos (?a * ?b) ] |- _ => + pose proof (Pos2Z.is_pos (Pos.mul a b)); + change (Zpos (a*b)) with (Zpos a * Zpos b) in * + | |- context [ Zpos (?a * ?b) ] => + pose proof (Pos2Z.is_pos (Pos.mul a b)); + change (Zpos (a*b)) with (Zpos a * Zpos b) in * (* xO *) | H : context [ Zpos (xO ?a) ] |- _ => let isp := isPcst a in match isp with | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H - | _ => rewrite (Zpos_xO a) in H + | _ => rewrite (Pos2Z.inj_xO a) in H end | |- context [ Zpos (xO ?a) ] => let isp := isPcst a in match isp with | true => change (Zpos (xO a)) with (Zpos' (xO a)) - | _ => rewrite (Zpos_xO a) + | _ => rewrite (Pos2Z.inj_xO a) end (* xI *) | H : context [ Zpos (xI ?a) ] |- _ => let isp := isPcst a in match isp with | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H - | _ => rewrite (Zpos_xI a) in H + | _ => rewrite (Pos2Z.inj_xI a) in H end | |- context [ Zpos (xI ?a) ] => let isp := isPcst a in match isp with | true => change (Zpos (xI a)) with (Zpos' (xI a)) - | _ => rewrite (Zpos_xI a) + | _ => rewrite (Pos2Z.inj_xI a) end (* xI : nothing to do, just prevent adding a useless positivity condition *) @@ -320,18 +309,9 @@ Ltac zify_positive_op := | |- context [ Zpos xH ] => hide_Zpos xH (* atoms of type positive : we add a positivity condition (if not already there) *) - | H : context [ Zpos ?a ] |- _ => - match goal with - | H' : Zpos a > 0 |- _ => hide_Zpos a - | H' : Zpos' a > 0 |- _ => fail - | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a - end - | |- context [ Zpos ?a ] => - match goal with - | H' : Zpos a > 0 |- _ => hide_Zpos a - | H' : Zpos' a > 0 |- _ => fail - | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a - end + | _ : 0 < Zpos ?a |- _ => hide_Zpos a + | _ : context [ Zpos ?a ] |- _ => pose proof (Pos2Z.is_pos a); hide_Zpos a + | |- context [ Zpos ?a ] => pose proof (Pos2Z.is_pos a); hide_Zpos a end. Ltac zify_positive := @@ -343,95 +323,75 @@ Ltac zify_positive := (* IV) conversion from N to Z *) -Definition Z_of_N' := Z_of_N. +Definition Z_of_N' := Z.of_N. Ltac hide_Z_of_N t := - let z := fresh "z" in set (z:=Z_of_N t) in *; - change Z_of_N with Z_of_N' in z; + let z := fresh "z" in set (z:=Z.of_N t) in *; + change Z.of_N with Z_of_N' in z; unfold z in *; clear z. Ltac zify_N_rel := match goal with (* I: equalities *) - | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H - | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b) - | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H - | |- context [ @eq N ?a ?b ] => rewrite (Z_of_N_eq_iff a b) + | |- (@eq N ?a ?b) => apply (N2Z.inj a b) (* shortcut *) + | H : context [ @eq N ?a ?b ] |- _ => rewrite <- (N2Z.inj_iff a b) in H + | |- context [ @eq N ?a ?b ] => rewrite <- (N2Z.inj_iff a b) (* II: less than *) - | H : (?a<?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H - | |- (?a<?b)%N => apply (Z_of_N_lt_rev a b) - | H : context [ (?a<?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H - | |- context [ (?a<?b)%N ] => rewrite (Z_of_N_lt_iff a b) + | H : context [ (?a < ?b)%N ] |- _ => rewrite (N2Z.inj_lt a b) in H + | |- context [ (?a < ?b)%N ] => rewrite (N2Z.inj_lt a b) (* III: less or equal *) - | H : (?a<=?b)%N |- _ => generalize (Z_of_N_le _ _ H); clear H; intro H - | |- (?a<=?b)%N => apply (Z_of_N_le_rev a b) - | H : context [ (?a<=?b)%N ] |- _ => rewrite (Z_of_N_le_iff a b) in H - | |- context [ (?a<=?b)%N ] => rewrite (Z_of_N_le_iff a b) + | H : context [ (?a <= ?b)%N ] |- _ => rewrite (N2Z.inj_le a b) in H + | |- context [ (?a <= ?b)%N ] => rewrite (N2Z.inj_le a b) (* IV: greater than *) - | H : (?a>?b)%N |- _ => generalize (Z_of_N_gt _ _ H); clear H; intro H - | |- (?a>?b)%N => apply (Z_of_N_gt_rev a b) - | H : context [ (?a>?b)%N ] |- _ => rewrite (Z_of_N_gt_iff a b) in H - | |- context [ (?a>?b)%N ] => rewrite (Z_of_N_gt_iff a b) + | H : context [ (?a > ?b)%N ] |- _ => rewrite (N2Z.inj_gt a b) in H + | |- context [ (?a > ?b)%N ] => rewrite (N2Z.inj_gt a b) (* V: greater or equal *) - | H : (?a>=?b)%N |- _ => generalize (Z_of_N_ge _ _ H); clear H; intro H - | |- (?a>=?b)%N => apply (Z_of_N_ge_rev a b) - | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H - | |- context [ (?a>=?b)%N ] => rewrite (Z_of_N_ge_iff a b) + | H : context [ (?a >= ?b)%N ] |- _ => rewrite (N2Z.inj_ge a b) in H + | |- context [ (?a >= ?b)%N ] => rewrite (N2Z.inj_ge a b) end. Ltac zify_N_op := match goal with (* misc type conversions: nat to positive *) - | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H - | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a) - | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H - | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a) - | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H - | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a) - | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H - | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0 - - (* Nplus -> Zplus *) - | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H - | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b) - - (* Nmin -> Zmin *) - | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H - | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b) - - (* Nmax -> Zmax *) - | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H - | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b) - - (* Nminus -> Zmax 0 (Zminus ... ...) *) - | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H - | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b) - - (* Nsucc -> Zsucc *) - | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H - | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a) - - (* Nmult -> Zmult and a positivity hypothesis *) - | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ => - let H:= fresh "H" in - assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * - | |- context [ Z_of_N (Nmult ?a ?b) ] => - let H:= fresh "H" in - assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * + | H : context [ Z.of_N (N.of_nat ?a) ] |- _ => rewrite (nat_N_Z a) in H + | |- context [ Z.of_N (N.of_nat ?a) ] => rewrite (nat_N_Z a) + | H : context [ Z.of_N (Z.abs_N ?a) ] |- _ => rewrite (N2Z.inj_abs_N a) in H + | |- context [ Z.of_N (Z.abs_N ?a) ] => rewrite (N2Z.inj_abs_N a) + | H : context [ Z.of_N (Npos ?a) ] |- _ => rewrite (N2Z.inj_pos a) in H + | |- context [ Z.of_N (Npos ?a) ] => rewrite (N2Z.inj_pos a) + | H : context [ Z.of_N N0 ] |- _ => change (Z.of_N N0) with Z0 in H + | |- context [ Z.of_N N0 ] => change (Z.of_N N0) with Z0 + + (* N.add -> Z.add *) + | H : context [ Z.of_N (N.add ?a ?b) ] |- _ => rewrite (N2Z.inj_add a b) in H + | |- context [ Z.of_N (N.add ?a ?b) ] => rewrite (N2Z.inj_add a b) + + (* N.min -> Z.min *) + | H : context [ Z.of_N (N.min ?a ?b) ] |- _ => rewrite (N2Z.inj_min a b) in H + | |- context [ Z.of_N (N.min ?a ?b) ] => rewrite (N2Z.inj_min a b) + + (* N.max -> Z.max *) + | H : context [ Z.of_N (N.max ?a ?b) ] |- _ => rewrite (N2Z.inj_max a b) in H + | |- context [ Z.of_N (N.max ?a ?b) ] => rewrite (N2Z.inj_max a b) + + (* N.sub -> Z.max 0 (Z.sub ... ...) *) + | H : context [ Z.of_N (N.sub ?a ?b) ] |- _ => rewrite (N2Z.inj_sub_max a b) in H + | |- context [ Z.of_N (N.sub ?a ?b) ] => rewrite (N2Z.inj_sub_max a b) + + (* N.succ -> Z.succ *) + | H : context [ Z.of_N (N.succ ?a) ] |- _ => rewrite (N2Z.inj_succ a) in H + | |- context [ Z.of_N (N.succ ?a) ] => rewrite (N2Z.inj_succ a) + + (* N.mul -> Z.mul and a positivity hypothesis *) + | H : context [ Z.of_N (N.mul ?a ?b) ] |- _ => + pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * + | |- context [ Z.of_N (N.mul ?a ?b) ] => + pose proof (N2Z.is_nonneg (N.mul a b)); rewrite (N2Z.inj_mul a b) in * (* atoms of type N : we add a positivity condition (if not already there) *) - | H : context [ Z_of_N ?a ] |- _ => - match goal with - | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a - | H' : 0 <= Z_of_N' a |- _ => fail - | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a - end - | |- context [ Z_of_N ?a ] => - match goal with - | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a - | H' : 0 <= Z_of_N' a |- _ => fail - | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a - end + | _ : 0 <= Z.of_N ?a |- _ => hide_Z_of_N a + | _ : context [ Z.of_N ?a ] |- _ => pose proof (N2Z.is_nonneg a); hide_Z_of_N a + | |- context [ Z.of_N ?a ] => pose proof (N2Z.is_nonneg a); hide_Z_of_N a end. Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 20565d06..ffa99fc7 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,8 +13,6 @@ (* *) (**************************************************************************) -(* $Id: coq_omega.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Util open Pp open Reduction @@ -22,7 +20,6 @@ open Proof_type open Names open Nameops open Term -open Termops open Declarations open Environ open Sign @@ -60,6 +57,7 @@ open Goptions let _ = declare_bool_option { optsync = false; + optdepr = false; optname = "Omega system time displaying flag"; optkey = ["Omega";"System"]; optread = read display_system_flag; @@ -68,6 +66,7 @@ let _ = let _ = declare_bool_option { optsync = false; + optdepr = false; optname = "Omega action display flag"; optkey = ["Omega";"Action"]; optread = read display_action_flag; @@ -76,6 +75,7 @@ let _ = let _ = declare_bool_option { optsync = false; + optdepr = false; optname = "Omega old style flag"; optkey = ["Omega";"OldStyle"]; optread = read old_style_flag; @@ -128,12 +128,12 @@ let intern_id,unintern_id = let mk_then = tclTHENLIST -let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c]) +let exists_tac c = constructor_tac false (Some 1) 1 (Glob_term.ImplicitBindings [c]) let generalize_tac t = generalize_time (generalize t) let elim t = elim_time (simplest_elim t) let exact t = exact_time (Tactics.refine t) -let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s] +let unfold s = Tactics.unfold_in_concl [Termops.all_occurrences, Lazy.force s] let rev_assoc k = let rec loop = function @@ -150,7 +150,7 @@ let tag_hypothesis,tag_of_hyp, hyp_of_tag = let hide_constr,find_constr,clear_tables,dump_tables = let l = ref ([]:(constr * (identifier * identifier * bool)) list) in (fun h id eg b -> l := (h,(id,eg,b)):: !l), - (fun h -> try List.assoc h !l with Not_found -> failwith "find_contr"), + (fun h -> try list_assoc_f eq_constr h !l with Not_found -> failwith "find_contr"), (fun () -> l := []), (fun () -> !l) @@ -169,6 +169,11 @@ let coq_modules = let init_constant = gen_constant_in_modules "Omega" init_modules let constant = gen_constant_in_modules "Omega" coq_modules +let z_constant = gen_constant_in_modules "Omega" [["Coq";"ZArith"]] +let zbase_constant = + gen_constant_in_modules "Omega" [["Coq";"ZArith";"BinInt"]] + + (* Zarith *) let coq_xH = lazy (constant "xH") let coq_xO = lazy (constant "xO") @@ -179,25 +184,26 @@ let coq_Zneg = lazy (constant "Zneg") let coq_Z = lazy (constant "Z") let coq_comparison = lazy (constant "comparison") let coq_Gt = lazy (constant "Gt") -let coq_Zplus = lazy (constant "Zplus") -let coq_Zmult = lazy (constant "Zmult") -let coq_Zopp = lazy (constant "Zopp") -let coq_Zminus = lazy (constant "Zminus") -let coq_Zsucc = lazy (constant "Zsucc") -let coq_Zgt = lazy (constant "Zgt") -let coq_Zle = lazy (constant "Zle") -let coq_Z_of_nat = lazy (constant "Z_of_nat") -let coq_inj_plus = lazy (constant "inj_plus") -let coq_inj_mult = lazy (constant "inj_mult") -let coq_inj_minus1 = lazy (constant "inj_minus1") +let coq_Zplus = lazy (zbase_constant "Z.add") +let coq_Zmult = lazy (zbase_constant "Z.mul") +let coq_Zopp = lazy (zbase_constant "Z.opp") +let coq_Zminus = lazy (zbase_constant "Z.sub") +let coq_Zsucc = lazy (zbase_constant "Z.succ") +let coq_Zpred = lazy (zbase_constant "Z.pred") +let coq_Zgt = lazy (zbase_constant "Z.gt") +let coq_Zle = lazy (zbase_constant "Z.le") +let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat") +let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add") +let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul") +let coq_inj_minus1 = lazy (z_constant "Nat2Z.inj_sub") let coq_inj_minus2 = lazy (constant "inj_minus2") -let coq_inj_S = lazy (constant "inj_S") -let coq_inj_le = lazy (constant "inj_le") -let coq_inj_lt = lazy (constant "inj_lt") -let coq_inj_ge = lazy (constant "inj_ge") -let coq_inj_gt = lazy (constant "inj_gt") -let coq_inj_neq = lazy (constant "inj_neq") -let coq_inj_eq = lazy (constant "inj_eq") +let coq_inj_S = lazy (z_constant "Nat2Z.inj_succ") +let coq_inj_le = lazy (z_constant "Znat.inj_le") +let coq_inj_lt = lazy (z_constant "Znat.inj_lt") +let coq_inj_ge = lazy (z_constant "Znat.inj_ge") +let coq_inj_gt = lazy (z_constant "Znat.inj_gt") +let coq_inj_neq = lazy (z_constant "inj_neq") +let coq_inj_eq = lazy (z_constant "inj_eq") let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse") let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc") let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse") @@ -247,24 +253,25 @@ let coq_Zle_left = lazy (constant "Zle_left") let coq_new_var = lazy (constant "new_var") let coq_intro_Z = lazy (constant "intro_Z") -let coq_dec_eq = lazy (constant "dec_eq") +let coq_dec_eq = lazy (zbase_constant "Z.eq_decidable") let coq_dec_Zne = lazy (constant "dec_Zne") -let coq_dec_Zle = lazy (constant "dec_Zle") -let coq_dec_Zlt = lazy (constant "dec_Zlt") +let coq_dec_Zle = lazy (zbase_constant "Z.le_decidable") +let coq_dec_Zlt = lazy (zbase_constant "Z.lt_decidable") let coq_dec_Zgt = lazy (constant "dec_Zgt") let coq_dec_Zge = lazy (constant "dec_Zge") let coq_not_Zeq = lazy (constant "not_Zeq") +let coq_not_Zne = lazy (constant "not_Zne") let coq_Znot_le_gt = lazy (constant "Znot_le_gt") let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge") let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt") let coq_Znot_gt_le = lazy (constant "Znot_gt_le") let coq_neq = lazy (constant "neq") let coq_Zne = lazy (constant "Zne") -let coq_Zle = lazy (constant "Zle") -let coq_Zgt = lazy (constant "Zgt") -let coq_Zge = lazy (constant "Zge") -let coq_Zlt = lazy (constant "Zlt") +let coq_Zle = lazy (zbase_constant "Z.le") +let coq_Zgt = lazy (zbase_constant "Z.gt") +let coq_Zge = lazy (zbase_constant "Z.ge") +let coq_Zlt = lazy (zbase_constant "Z.lt") (* Peano/Datatypes *) let coq_le = lazy (init_constant "le") @@ -322,12 +329,13 @@ let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with EvalConstRef kn | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant") -let sp_Zsucc = lazy (evaluable_ref_of_constr "Zsucc" coq_Zsucc) -let sp_Zminus = lazy (evaluable_ref_of_constr "Zminus" coq_Zminus) -let sp_Zle = lazy (evaluable_ref_of_constr "Zle" coq_Zle) -let sp_Zgt = lazy (evaluable_ref_of_constr "Zgt" coq_Zgt) -let sp_Zge = lazy (evaluable_ref_of_constr "Zge" coq_Zge) -let sp_Zlt = lazy (evaluable_ref_of_constr "Zlt" coq_Zlt) +let sp_Zsucc = lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc) +let sp_Zpred = lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred) +let sp_Zminus = lazy (evaluable_ref_of_constr "Z.sub" coq_Zminus) +let sp_Zle = lazy (evaluable_ref_of_constr "Z.le" coq_Zle) +let sp_Zgt = lazy (evaluable_ref_of_constr "Z.gt" coq_Zgt) +let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge) +let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt) let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ()))) let mk_var v = mkVar (id_of_string v) @@ -356,7 +364,7 @@ let mk_integer n = [| loop (abs n) |]) type omega_constant = - | Zplus | Zmult | Zminus | Zsucc | Zopp + | Zplus | Zmult | Zminus | Zsucc | Zopp | Zpred | Plus | Mult | Minus | Pred | S | O | Zpos | Zneg | Z0 | Z_of_nat | Eq | Neq @@ -376,32 +384,39 @@ type result = | Kimp of constr * constr | Kufo +(* Nota: Kimp correspond to a binder (Prod), but hopefully we won't + have to bother with term lifting: Kimp will correspond to anonymous + product, for which (Rel 1) doesn't occur in the right term. + Moreover, we'll work on fully introduced goals, hence no Rel's in + the term parts that we manipulate, but rather Var's. + Said otherwise: all constr manipulated here are closed *) + let destructurate_prop t = let c, args = decompose_app t in match kind_of_term c, args with - | _, [_;_;_] when c = build_coq_eq () -> Kapp (Eq,args) - | _, [_;_] when c = Lazy.force coq_neq -> Kapp (Neq,args) - | _, [_;_] when c = Lazy.force coq_Zne -> Kapp (Zne,args) - | _, [_;_] when c = Lazy.force coq_Zle -> Kapp (Zle,args) - | _, [_;_] when c = Lazy.force coq_Zlt -> Kapp (Zlt,args) - | _, [_;_] when c = Lazy.force coq_Zge -> Kapp (Zge,args) - | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args) - | _, [_;_] when c = build_coq_and () -> Kapp (And,args) - | _, [_;_] when c = build_coq_or () -> Kapp (Or,args) - | _, [_;_] when c = Lazy.force coq_iff -> Kapp (Iff, args) - | _, [_] when c = build_coq_not () -> Kapp (Not,args) - | _, [] when c = build_coq_False () -> Kapp (False,args) - | _, [] when c = build_coq_True () -> Kapp (True,args) - | _, [_;_] when c = Lazy.force coq_le -> Kapp (Le,args) - | _, [_;_] when c = Lazy.force coq_lt -> Kapp (Lt,args) - | _, [_;_] when c = Lazy.force coq_ge -> Kapp (Ge,args) - | _, [_;_] when c = Lazy.force coq_gt -> Kapp (Gt,args) + | _, [_;_;_] when eq_constr c (build_coq_eq ()) -> Kapp (Eq,args) + | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) + | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) + | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) + | _, [_;_] when eq_constr c (Lazy.force coq_Zlt) -> Kapp (Zlt,args) + | _, [_;_] when eq_constr c (Lazy.force coq_Zge) -> Kapp (Zge,args) + | _, [_;_] when eq_constr c (Lazy.force coq_Zgt) -> Kapp (Zgt,args) + | _, [_;_] when eq_constr c (build_coq_and ()) -> Kapp (And,args) + | _, [_;_] when eq_constr c (build_coq_or ()) -> Kapp (Or,args) + | _, [_;_] when eq_constr c (Lazy.force coq_iff) -> Kapp (Iff, args) + | _, [_] when eq_constr c (build_coq_not ()) -> Kapp (Not,args) + | _, [] when eq_constr c (build_coq_False ()) -> Kapp (False,args) + | _, [] when eq_constr c (build_coq_True ()) -> Kapp (True,args) + | _, [_;_] when eq_constr c (Lazy.force coq_le) -> Kapp (Le,args) + | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) + | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) + | _, [_;_] when eq_constr c (Lazy.force coq_gt) -> Kapp (Gt,args) | Const sp, args -> - Kapp (Other (string_of_id (basename_of_global (ConstRef sp))),args) + Kapp (Other (string_of_path (path_of_global (ConstRef sp))),args) | Construct csp , args -> - Kapp (Other (string_of_id (basename_of_global (ConstructRef csp))), args) + Kapp (Other (string_of_path (path_of_global (ConstructRef csp))), args) | Ind isp, args -> - Kapp (Other (string_of_id (basename_of_global (IndRef isp))),args) + Kapp (Other (string_of_path (path_of_global (IndRef isp))),args) | Var id,[] -> Kvar id | Prod (Anonymous,typ,body), [] -> Kimp(typ,body) | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" @@ -410,43 +425,44 @@ let destructurate_prop t = let destructurate_type t = let c, args = decompose_app t in match kind_of_term c, args with - | _, [] when c = Lazy.force coq_Z -> Kapp (Z,args) - | _, [] when c = Lazy.force coq_nat -> Kapp (Nat,args) + | _, [] when eq_constr c (Lazy.force coq_Z) -> Kapp (Z,args) + | _, [] when eq_constr c (Lazy.force coq_nat) -> Kapp (Nat,args) | _ -> Kufo let destructurate_term t = let c, args = decompose_app t in match kind_of_term c, args with - | _, [_;_] when c = Lazy.force coq_Zplus -> Kapp (Zplus,args) - | _, [_;_] when c = Lazy.force coq_Zmult -> Kapp (Zmult,args) - | _, [_;_] when c = Lazy.force coq_Zminus -> Kapp (Zminus,args) - | _, [_] when c = Lazy.force coq_Zsucc -> Kapp (Zsucc,args) - | _, [_] when c = Lazy.force coq_Zopp -> Kapp (Zopp,args) - | _, [_;_] when c = Lazy.force coq_plus -> Kapp (Plus,args) - | _, [_;_] when c = Lazy.force coq_mult -> Kapp (Mult,args) - | _, [_;_] when c = Lazy.force coq_minus -> Kapp (Minus,args) - | _, [_] when c = Lazy.force coq_pred -> Kapp (Pred,args) - | _, [_] when c = Lazy.force coq_S -> Kapp (S,args) - | _, [] when c = Lazy.force coq_O -> Kapp (O,args) - | _, [_] when c = Lazy.force coq_Zpos -> Kapp (Zneg,args) - | _, [_] when c = Lazy.force coq_Zneg -> Kapp (Zpos,args) - | _, [] when c = Lazy.force coq_Z0 -> Kapp (Z0,args) - | _, [_] when c = Lazy.force coq_Z_of_nat -> Kapp (Z_of_nat,args) + | _, [_;_] when eq_constr c (Lazy.force coq_Zplus) -> Kapp (Zplus,args) + | _, [_;_] when eq_constr c (Lazy.force coq_Zmult) -> Kapp (Zmult,args) + | _, [_;_] when eq_constr c (Lazy.force coq_Zminus) -> Kapp (Zminus,args) + | _, [_] when eq_constr c (Lazy.force coq_Zsucc) -> Kapp (Zsucc,args) + | _, [_] when eq_constr c (Lazy.force coq_Zpred) -> Kapp (Zpred,args) + | _, [_] when eq_constr c (Lazy.force coq_Zopp) -> Kapp (Zopp,args) + | _, [_;_] when eq_constr c (Lazy.force coq_plus) -> Kapp (Plus,args) + | _, [_;_] when eq_constr c (Lazy.force coq_mult) -> Kapp (Mult,args) + | _, [_;_] when eq_constr c (Lazy.force coq_minus) -> Kapp (Minus,args) + | _, [_] when eq_constr c (Lazy.force coq_pred) -> Kapp (Pred,args) + | _, [_] when eq_constr c (Lazy.force coq_S) -> Kapp (S,args) + | _, [] when eq_constr c (Lazy.force coq_O) -> Kapp (O,args) + | _, [_] when eq_constr c (Lazy.force coq_Zpos) -> Kapp (Zneg,args) + | _, [_] when eq_constr c (Lazy.force coq_Zneg) -> Kapp (Zpos,args) + | _, [] when eq_constr c (Lazy.force coq_Z0) -> Kapp (Z0,args) + | _, [_] when eq_constr c (Lazy.force coq_Z_of_nat) -> Kapp (Z_of_nat,args) | Var id,[] -> Kvar id | _ -> Kufo let recognize_number t = let rec loop t = match decompose_app t with - | f, [t] when f = Lazy.force coq_xI -> one + two * loop t - | f, [t] when f = Lazy.force coq_xO -> two * loop t - | f, [] when f = Lazy.force coq_xH -> one + | f, [t] when eq_constr f (Lazy.force coq_xI) -> one + two * loop t + | f, [t] when eq_constr f (Lazy.force coq_xO) -> two * loop t + | f, [] when eq_constr f (Lazy.force coq_xH) -> one | _ -> failwith "not a number" in match decompose_app t with - | f, [t] when f = Lazy.force coq_Zpos -> loop t - | f, [t] when f = Lazy.force coq_Zneg -> neg (loop t) - | f, [] when f = Lazy.force coq_Z0 -> zero + | f, [t] when eq_constr f (Lazy.force coq_Zpos) -> loop t + | f, [t] when eq_constr f (Lazy.force coq_Zneg) -> neg (loop t) + | f, [] when eq_constr f (Lazy.force coq_Z0) -> zero | _ -> failwith "not a number" type constr_path = @@ -869,7 +885,7 @@ let rec transform p t = try let v,th,_ = find_constr t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - with _ -> + with e when Errors.noncritical e -> let v = new_identifier_var () and th = new_identifier () in hide_constr t' v th isnat; @@ -891,6 +907,10 @@ let rec transform p t = let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer one |])) in unfold sp_Zsucc :: tac,t + | Kapp(Zpred,[t1]) -> + let tac,t = transform p (mkApp (Lazy.force coq_Zplus, + [| t1; mk_integer negone |])) in + unfold sp_Zpred :: tac,t | Kapp(Zmult,[t1;t2]) -> let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in @@ -904,7 +924,8 @@ let rec transform p t = | _ -> default false t end | Kapp((Zpos|Zneg|Z0),_) -> - (try ([],Oz(recognize_number t)) with _ -> default false t) + (try ([],Oz(recognize_number t)) + with e when Errors.noncritical e -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> let tac,t' = transform (P_APP 1 :: p) t in @@ -1548,6 +1569,38 @@ let nat_inject gl = in loop (List.rev (pf_hyps_types gl)) gl +let dec_binop = function + | Zne -> coq_dec_Zne + | Zle -> coq_dec_Zle + | Zlt -> coq_dec_Zlt + | Zge -> coq_dec_Zge + | Zgt -> coq_dec_Zgt + | Le -> coq_dec_le + | Lt -> coq_dec_lt + | Ge -> coq_dec_ge + | Gt -> coq_dec_gt + | _ -> raise Not_found + +let not_binop = function + | Zne -> coq_not_Zne + | Zle -> coq_Znot_le_gt + | Zlt -> coq_Znot_lt_ge + | Zge -> coq_Znot_ge_lt + | Zgt -> coq_Znot_gt_le + | Le -> coq_not_le + | Lt -> coq_not_lt + | Ge -> coq_not_ge + | Gt -> coq_not_gt + | _ -> raise Not_found + +(** A decidability check : for some [t], could we build a term + of type [decidable t] (i.e. [t\/~t]) ? Otherwise, we raise + [Undecidable]. Note that a successful check implies that + [t] has type Prop. +*) + +exception Undecidable + let rec decidability gl t = match destructurate_prop t with | Kapp(Or,[t1;t2]) -> @@ -1560,34 +1613,24 @@ let rec decidability gl t = mkApp (Lazy.force coq_dec_iff, [| t1; t2; decidability gl t1; decidability gl t2 |]) | Kimp(t1,t2) -> - mkApp (Lazy.force coq_dec_imp, [| t1; t2; - decidability gl t1; decidability gl t2 |]) - | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; - decidability gl t1 |]) + (* This is the only situation where it's not obvious that [t] + is in Prop. The recursive call on [t2] will ensure that. *) + mkApp (Lazy.force coq_dec_imp, + [| t1; t2; decidability gl t1; decidability gl t2 |]) + | Kapp(Not,[t1]) -> + mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) | Kapp(Eq,[typ;t1;t2]) -> begin match destructurate_type (pf_nf gl typ) with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) - | _ -> errorlabstrm "decidability" - (str "Omega: Can't solve a goal with equality on " ++ - Printer.pr_lconstr typ) + | _ -> raise Undecidable end - | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |]) - | Kapp(Zle,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zle, [| t1;t2 |]) - | Kapp(Zlt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zlt, [| t1;t2 |]) - | Kapp(Zge,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zge, [| t1;t2 |]) - | Kapp(Zgt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zgt, [| t1;t2 |]) - | Kapp(Le, [t1;t2]) -> mkApp (Lazy.force coq_dec_le, [| t1;t2 |]) - | Kapp(Lt, [t1;t2]) -> mkApp (Lazy.force coq_dec_lt, [| t1;t2 |]) - | Kapp(Ge, [t1;t2]) -> mkApp (Lazy.force coq_dec_ge, [| t1;t2 |]) - | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |]) + | Kapp(op,[t1;t2]) -> + (try mkApp (Lazy.force (dec_binop op), [| t1; t2 |]) + with Not_found -> raise Undecidable) | Kapp(False,[]) -> Lazy.force coq_dec_False | Kapp(True,[]) -> Lazy.force coq_dec_True - | Kapp(Other t,_::_) -> error - ("Omega: Unrecognized predicate or connective: "^t) - | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t) - | Kvar _ -> error "Omega: Can't solve a goal with proposition variables" - | _ -> error "Omega: Unrecognized proposition" + | _ -> raise Undecidable let onClearedName id tac = (* We cannot ensure that hyps can be cleared (because of dependencies), *) @@ -1598,6 +1641,14 @@ let onClearedName id tac = let id = fresh_id [] id gl in tclTHEN (introduction id) (tac id) gl) +let onClearedName2 id tac = + tclTHEN + (tclTRY (clear [id])) + (fun gl -> + let id1 = fresh_id [] (add_suffix id "_left") gl in + let id2 = fresh_id [] (add_suffix id "_right") gl in + tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] gl) + let destructure_hyps gl = let rec loop = function | [] -> (tclTHEN nat_inject coq_omega) @@ -1611,50 +1662,24 @@ let destructure_hyps gl = [ onClearedName i (fun i -> (loop ((i,None,t1)::lit))); onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> - tclTHENLIST [ - (elim_id i); - (tclTRY (clear [i])); - (fun gl -> - let i1 = fresh_id [] (add_suffix i "_left") gl in - let i2 = fresh_id [] (add_suffix i "_right") gl in - tclTHENLIST [ - (introduction i1); - (introduction i2); - (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl) - ] + tclTHEN + (elim_id i) + (onClearedName2 i (fun i1 i2 -> + loop ((i1,None,t1)::(i2,None,t2)::lit))) | Kapp(Iff,[t1;t2]) -> - tclTHENLIST [ - (elim_id i); - (tclTRY (clear [i])); - (fun gl -> - let i1 = fresh_id [] (add_suffix i "_left") gl in - let i2 = fresh_id [] (add_suffix i "_right") gl in - tclTHENLIST [ - introduction i1; - generalize_tac - [mkApp (Lazy.force coq_imp_simp, - [| t1; t2; decidability gl t1; mkVar i1|])]; - onClearedName i1 (fun i1 -> - tclTHENLIST [ - introduction i2; - generalize_tac - [mkApp (Lazy.force coq_imp_simp, - [| t2; t1; decidability gl t2; mkVar i2|])]; - onClearedName i2 (fun i2 -> - loop - ((i1,None,mk_or (mk_not t1) t2):: - (i2,None,mk_or (mk_not t2) t1)::lit)) - ])] gl) - ] + tclTHEN + (elim_id i) + (onClearedName2 i (fun i1 i2 -> + loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit))) | Kimp(t1,t2) -> - if - is_Prop (pf_type_of gl t1) & - is_Prop (pf_type_of gl t2) & - closed0 t2 + (* t1 and t2 might be in Type rather than Prop. + For t1, the decidability check will ensure being Prop. *) + if is_Prop (pf_type_of gl t2) then + let d1 = decidability gl t1 in tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_imp_simp, - [| t1; t2; decidability gl t1; mkVar i|])]); + [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> (loop ((i,None,mk_or (mk_not t1) t2)::lit)))) ] @@ -1670,86 +1695,53 @@ let destructure_hyps gl = (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit)))) ] | Kapp(And,[t1;t2]) -> + let d1 = decidability gl t1 in tclTHENLIST [ (generalize_tac - [mkApp (Lazy.force coq_not_and, [| t1; t2; - decidability gl t1; mkVar i|])]); + [mkApp (Lazy.force coq_not_and, + [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit)))) ] | Kapp(Iff,[t1;t2]) -> + let d1 = decidability gl t1 in + let d2 = decidability gl t2 in tclTHENLIST [ (generalize_tac - [mkApp (Lazy.force coq_not_iff, [| t1; t2; - decidability gl t1; decidability gl t2; mkVar i|])]); + [mkApp (Lazy.force coq_not_iff, + [| t1; t2; d1; d2; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None, mk_or (mk_and t1 (mk_not t2)) (mk_and (mk_not t1) t2))::lit)))) ] | Kimp(t1,t2) -> + (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. + For t1, being decidable implies being Prop. *) + let d1 = decidability gl t1 in tclTHENLIST [ (generalize_tac - [mkApp (Lazy.force coq_not_imp, [| t1; t2; - decidability gl t1;mkVar i |])]); + [mkApp (Lazy.force coq_not_imp, + [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) ] | Kapp(Not,[t]) -> + let d = decidability gl t in tclTHENLIST [ (generalize_tac - [mkApp (Lazy.force coq_not_not, [| t; - decidability gl t; mkVar i |])]); + [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,t)::lit)))) ] - | Kapp(Zle, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Znot_le_gt, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Zge, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Znot_ge_lt, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Zlt, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Znot_lt_ge, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Zgt, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_Znot_gt_le, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Le, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_le, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Ge, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_ge, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Lt, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_lt, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] - | Kapp(Gt, [t1;t2]) -> - tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_gt, [| t1;t2;mkVar i|])]); - (onClearedName i (fun _ -> loop lit)) - ] + | Kapp(op,[t1;t2]) -> + (try + let thm = not_binop op in + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); + (onClearedName i (fun _ -> loop lit)) + ] + with Not_found -> loop lit) | Kapp(Eq,[typ;t1;t2]) -> if !old_style_flag then begin match destructurate_type (pf_nf gl typ) with @@ -1787,7 +1779,9 @@ let destructure_hyps gl = | _ -> loop lit end | _ -> loop lit - with e when catchable_exception e -> loop lit + with + | Undecidable -> loop lit + | e when catchable_exception e -> loop lit end in loop (pf_hyps gl) gl @@ -1803,13 +1797,16 @@ let destructure_goal gl = | Kimp(a,b) -> (tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps | _ -> - (tclTHEN - (tclTHEN - (Tactics.refine - (mkApp (Lazy.force coq_dec_not_not, [| t; - decidability gl t; mkNewMeta () |]))) - intro) - (destructure_hyps)) + let goal_tac = + try + let dec = decidability gl t in + tclTHEN + (Tactics.refine + (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))) + intro + with Undecidable -> Tactics.elim_type (build_coq_False ()) + in + tclTHEN goal_tac destructure_hyps in (loop concl) gl diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index cd6472c3..1542b60c 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -15,8 +15,6 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_omega.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Coq_omega open Refiner diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index 8bb10194..98cad09e 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -214,7 +214,7 @@ let rec display_action print_var = function constant factors.\n" e1.id e2.id | NEGATE_CONTRADICT(e1,e2,b) -> Printf.printf - "Equations E%d and E%d state that their body is at the same time + "Equations E%d and E%d state that their body is at the same time \ equal and different\n" e1.id e2.id | CONSTANT_NOT_NUL (e,k) -> Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget index 1485c147..787995ed 100644 --- a/plugins/pluginsbyte.itarget +++ b/plugins/pluginsbyte.itarget @@ -1,13 +1,13 @@ field/field_plugin.cma setoid_ring/newring_plugin.cma extraction/extraction_plugin.cma +decl_mode/decl_mode_plugin.cma firstorder/ground_plugin.cma rtauto/rtauto_plugin.cma fourier/fourier_plugin.cma romega/romega_plugin.cma omega/omega_plugin.cma micromega/micromega_plugin.cma -dp/dp_plugin.cma xml/xml_plugin.cma subtac/subtac_plugin.cma ring/ring_plugin.cma diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget index 5d502411..bd3cec01 100644 --- a/plugins/pluginsdyn.itarget +++ b/plugins/pluginsdyn.itarget @@ -1,13 +1,13 @@ field/field_plugin.cmxs setoid_ring/newring_plugin.cmxs extraction/extraction_plugin.cmxs +decl_mode/decl_mode_plugin.cmxs firstorder/ground_plugin.cmxs rtauto/rtauto_plugin.cmxs fourier/fourier_plugin.cmxs romega/romega_plugin.cmxs omega/omega_plugin.cmxs micromega/micromega_plugin.cmxs -dp/dp_plugin.cmxs xml/xml_plugin.cmxs subtac/subtac_plugin.cmxs ring/ring_plugin.cmxs diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget index 2f72dab8..5264ba37 100644 --- a/plugins/pluginsopt.itarget +++ b/plugins/pluginsopt.itarget @@ -1,13 +1,13 @@ field/field_plugin.cmxa setoid_ring/newring_plugin.cmxa extraction/extraction_plugin.cmxa +decl_mode/decl_mode_plugin.cmxa firstorder/ground_plugin.cmxa rtauto/rtauto_plugin.cmxa fourier/fourier_plugin.cmxa romega/romega_plugin.cmxa omega/omega_plugin.cmxa micromega/micromega_plugin.cmxa -dp/dp_plugin.cmxa xml/xml_plugin.cmxa subtac/subtac_plugin.cmxa ring/ring_plugin.cmxa diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget index db56534c..bab15ad0 100644 --- a/plugins/pluginsvo.itarget +++ b/plugins/pluginsvo.itarget @@ -1,4 +1,3 @@ -dp/vo.otarget field/vo.otarget fourier/vo.otarget funind/vo.otarget @@ -10,4 +9,4 @@ ring/vo.otarget romega/vo.otarget rtauto/vo.otarget setoid_ring/vo.otarget -extraction/vo.otarget
\ No newline at end of file +extraction/vo.otarget diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v index 55bb8bae..2206aedf 100644 --- a/plugins/quote/Quote.v +++ b/plugins/quote/Quote.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Quote.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Declare ML Module "quote_plugin". (*********************************************************************** @@ -28,7 +26,6 @@ Declare ML Module "quote_plugin". ***********************************************************************) Set Implicit Arguments. -Unset Boxed Definitions. Section variables_map. @@ -70,7 +67,7 @@ Fixpoint index_lt (n m:index) {struct m} : bool := end. Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m. - simple induction n; simple induction m; simpl in |- *; intros. + simple induction n; simple induction m; simpl; intros. rewrite (H i0 H1); reflexivity. discriminate. discriminate. diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index 3c51223a..09b780fd 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,14 +8,12 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_quote.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Util open Tacexpr open Quote let make_cont k x = - let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> fst k)) in + let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> k)) in let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in let tac = <:tactic<let cont := $k in cont $x>> in Tacinterp.interp tac diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index baba7e1b..216a719d 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: quote.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - (* The `Quote' tactic *) (* The basic idea is to automatize the inversion of interpetation functions @@ -111,7 +109,6 @@ open Pattern open Matching open Tacmach open Tactics -open Proof_trees open Tacexpr (*i*) @@ -169,7 +166,7 @@ exchange ?1 and ?2 in the example above) module ConstrSet = Set.Make( struct type t = constr - let compare = (Pervasives.compare : t->t->int) + let compare = constr_ord end) type inversion_scheme = { @@ -211,7 +208,7 @@ let compute_lhs typ i nargsi = let compute_rhs bodyi index_of_f = let rec aux c = match kind_of_term c with - | App (j, args) when j = mkRel (index_of_f) (* recursive call *) -> + | App (j, args) when isRel j && destRel j = index_of_f (* recursive call *) -> let i = destRel (array_last args) in PMeta (Some (coerce_meta_in i)) | App (f,args) -> @@ -224,7 +221,10 @@ let compute_rhs bodyi index_of_f = (*s Now the function [compute_ivs] itself *) let compute_ivs gl f cs = - let cst = try destConst f with _ -> i_can't_do_that () in + let cst = + try destConst f + with e when Errors.noncritical e -> i_can't_do_that () + in let body = Environ.constant_value (Global.env()) cst in match decomp_term body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> @@ -243,7 +243,7 @@ let compute_ivs gl f cs = (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) (* REL 1 to REL nargsi are argsi (reverse order) *) (* First we test if the RHS is the RHS for constants *) - if bodyi = mkRel 1 then + if isRel bodyi && destRel bodyi = 1 then c_lhs := Some (compute_lhs (snd (List.hd args3)) i nargsi) (* Then we test if the RHS is the RHS for variables *) @@ -373,13 +373,19 @@ let rec subterm gl (t : constr) (t' : constr) = let rec sort_subterm gl l = let rec insert c = function | [] -> [c] - | (h::t as l) when c = h -> l (* Avoid doing the same work twice *) + | (h::t as l) when eq_constr c h -> l (* Avoid doing the same work twice *) | h::t -> if subterm gl c h then c::h::t else h::(insert c t) in match l with | [] -> [] | h::t -> insert h (sort_subterm gl t) +module Constrhash = Hashtbl.Make + (struct type t = constr + let equal = eq_constr + let hash = hash_constr + end) + (*s Now we are able to do the inversion itself. We destructurate the term and use an imperative hashtable to store leafs that are already encountered. @@ -387,10 +393,9 @@ let rec sort_subterm gl l = [ivs : inversion_scheme]\\ [lc: constr list]\\ [gl: goal sigma]\\ *) - let quote_terms ivs lc gl = Coqlib.check_required_library ["Coq";"quote";"Quote"]; - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = @@ -417,7 +422,7 @@ let quote_terms ivs lc gl = Termops.subst_meta [1, c] c_lhs | _ -> begin - try Hashtbl.find varhash c + try Constrhash.find varhash c with Not_found -> let newvar = Termops.subst_meta [1, (path_of_int !counter)] @@ -425,7 +430,7 @@ let quote_terms ivs lc gl = begin incr counter; varlist := c :: !varlist; - Hashtbl.add varhash c newvar; + Constrhash.add varhash c newvar; newvar end end @@ -473,7 +478,7 @@ Just testing ... #use "include.ml";; open Quote;; -let r = raw_constr_of_string;; +let r = glob_constr_of_string;; let ivs = { normal_lhs_rhs = diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v index 2de16bc1..089dec02 100644 --- a/plugins/ring/LegacyArithRing.v +++ b/plugins/ring/LegacyArithRing.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (* Instantiation of the Ring tactic for the naturals of Arith $*) Require Import Bool. @@ -15,9 +13,9 @@ Require Export LegacyRing. Require Export Arith. Require Import Eqdep_dec. -Open Local Scope nat_scope. +Local Open Scope nat_scope. -Unboxed Fixpoint nateq (n m:nat) {struct m} : bool := +Fixpoint nateq (n m:nat) {struct m} : bool := match n, m with | O, O => true | S n', S m' => nateq n' m' @@ -77,14 +75,14 @@ Ltac rewrite_S_to_plus := (**) (**) rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in - change (t1 = t2) in |- * + change (t1 = t2) | |- (?X1 = ?X2) => try let t1 := (**) (**) rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in - change (t1 = t2) in |- * + change (t1 = t2) end. Ltac ring_nat := rewrite_S_to_plus; ring. diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v index ae7e62e0..7f1597a1 100644 --- a/plugins/ring/LegacyNArithRing.v +++ b/plugins/ring/LegacyNArithRing.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyNArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (* Instantiation of the Ring tactic for the binary natural numbers *) Require Import Bool. @@ -16,7 +14,7 @@ Require Export ZArith_base. Require Import NArith. Require Import Eqdep_dec. -Unboxed Definition Neq (n m:N) := +Definition Neq (n m:N) := match (n ?= m)%N with | Datatypes.Eq => true | _ => false @@ -24,23 +22,22 @@ Unboxed Definition Neq (n m:N) := Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m. intros n m H; unfold Neq in H. - apply Ncompare_Eq_eq. + apply N.compare_eq. destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ]. Qed. -Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq. +Definition NTheory : Semi_Ring_Theory N.add N.mul 1%N 0%N Neq. split. - apply Nplus_comm. - apply Nplus_assoc. - apply Nmult_comm. - apply Nmult_assoc. - apply Nplus_0_l. - apply Nmult_1_l. - apply Nmult_0_l. - apply Nmult_plus_distr_r. -(* apply Nplus_reg_l.*) + apply N.add_comm. + apply N.add_assoc. + apply N.mul_comm. + apply N.mul_assoc. + apply N.add_0_l. + apply N.mul_1_l. + apply N.mul_0_l. + apply N.mul_add_distr_r. apply Neq_prop. Qed. Add Legacy Semi Ring - N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ]. + N N.add N.mul 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ]. diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v index e53e60d3..d4f40081 100644 --- a/plugins/ring/LegacyRing.v +++ b/plugins/ring/LegacyRing.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyRing.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export Bool. Require Export LegacyRing_theory. Require Export Quote. @@ -21,7 +19,7 @@ Declare ML Module "ring_plugin". Definition BoolTheory : Ring_Theory xorb andb true false (fun b:bool => b) eqb. -split; simpl in |- *. +split; simpl. destruct n; destruct m; reflexivity. destruct n; destruct m; destruct p; reflexivity. destruct n; destruct m; reflexivity. @@ -30,7 +28,7 @@ destruct n; reflexivity. destruct n; reflexivity. destruct n; reflexivity. destruct n; destruct m; destruct p; reflexivity. -destruct x; destruct y; reflexivity || simpl in |- *; tauto. +destruct x; destruct y; reflexivity || simpl; tauto. Defined. Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v index bf61aee1..09de1bb4 100644 --- a/plugins/ring/LegacyRing_theory.v +++ b/plugins/ring/LegacyRing_theory.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyRing_theory.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export Bool. Set Implicit Arguments. @@ -60,22 +58,22 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left (* Lemmas whose form is x=y are also provided in form y=x because Auto does not symmetry *) Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma SR_mult_one_left2 : forall n:A, n = 1 * n. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). intros. @@ -102,7 +100,7 @@ eauto. Qed. Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). -symmetry in |- *; apply SR_distr_right. Qed. +symmetry ; apply SR_distr_right. Qed. Lemma SR_mult_zero_right : forall n:A, n * 0 = 0. intro; rewrite mult_comm; eauto. @@ -178,22 +176,22 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left (* Lemmas whose form is x=y are also provided in form y=x because Auto does not symmetry *) Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p). -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma Th_mult_one_left2 : forall n:A, n = 1 * n. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma Th_opp_def2 : forall n:A, 0 = n + - n. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p). intros. @@ -216,7 +214,7 @@ Hint Resolve Th_plus_permute Th_mult_permute. Lemma aux1 : forall a:A, a + a = a -> a = 0. intros. generalize (opp_def a). -pattern a at 1 in |- *. +pattern a at 1. rewrite <- H. rewrite <- plus_assoc. rewrite opp_def. @@ -235,7 +233,7 @@ Qed. Hint Resolve Th_mult_zero_left. Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z. intros. @@ -257,7 +255,7 @@ Qed. Hint Resolve Th_opp_mult_left. Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y). -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma Th_mult_zero_right : forall n:A, n * 0 = 0. intro; elim mult_comm; eauto. @@ -308,14 +306,14 @@ Qed. Hint Resolve Th_opp_opp. Lemma Th_opp_opp2 : forall n:A, n = - - n. -symmetry in |- *; eauto. Qed. +symmetry ; eauto. Qed. Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y. intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto. Qed. Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y. -symmetry in |- *; apply Th_mult_opp_opp. Qed. +symmetry ; apply Th_mult_opp_opp. Qed. Lemma Th_opp_zero : - 0 = 0. rewrite <- (plus_zero_left (- 0)). @@ -344,7 +342,7 @@ eauto. Qed. Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p). -symmetry in |- *; apply Th_distr_right. +symmetry ; apply Th_distr_right. Qed. End Theory_of_rings. @@ -359,7 +357,7 @@ Definition Semi_Ring_Theory_of : Ring_Theory Aplus Amult Aone Azero Aopp Aeq -> Semi_Ring_Theory Aplus Amult Aone Azero Aeq. intros until 1; case H. -split; intros; simpl in |- *; eauto. +split; intros; simpl; eauto. Defined. (* Every ring can be viewed as a semi-ring : this property will be used diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v index d1412104..3f01a5c3 100644 --- a/plugins/ring/LegacyZArithRing.v +++ b/plugins/ring/LegacyZArithRing.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: LegacyZArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *) - (* Instantiation of the Ring tactic for the binary integers of ZArith *) Require Export LegacyArithRing. @@ -15,7 +13,7 @@ Require Export ZArith_base. Require Import Eqdep_dec. Require Import LegacyRing. -Unboxed Definition Zeq (x y:Z) := +Definition Zeq (x y:Z) := match (x ?= y)%Z with | Datatypes.Eq => true | _ => false @@ -23,15 +21,15 @@ Unboxed Definition Zeq (x y:Z) := Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y. intros x y H; unfold Zeq in H. - apply Zcompare_Eq_eq. + apply Z.compare_eq. destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ]. Qed. -Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq. +Definition ZTheory : Ring_Theory Z.add Z.mul 1%Z 0%Z Z.opp Zeq. split; intros; eauto with zarith. apply Zeq_prop; assumption. Qed. (* NatConstants and NatTheory are defined in Ring_theory.v *) -Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory +Add Legacy Ring Z Z.add Z.mul 1%Z 0%Z Z.opp Zeq ZTheory [ Zpos Zneg 0%Z xO xI 1%positive ]. diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v index e6e2dda9..a00b7bcd 100644 --- a/plugins/ring/Ring_abstract.v +++ b/plugins/ring/Ring_abstract.v @@ -1,19 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_abstract.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import LegacyRing_theory. Require Import Quote. Require Import Ring_normalize. -Unset Boxed Definitions. - Section abstract_semi_rings. Inductive aspolynomial : Type := @@ -141,14 +137,13 @@ Hint Resolve (SR_plus_zero_right2 T). Hint Resolve (SR_mult_one_right T). Hint Resolve (SR_mult_one_right2 T). (*Hint Resolve (SR_plus_reg_right T).*) -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. Remark iacs_aux_ok : forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s). Proof. - simple induction s; simpl in |- *; intros. + simple induction s; simpl; intros. trivial. reflexivity. Qed. @@ -163,8 +158,8 @@ Lemma abstract_varlist_insert_ok : simple induction s. trivial. - simpl in |- *; intros. - elim (varlist_lt l v); simpl in |- *. + simpl; intros. + elim (varlist_lt l v); simpl. eauto. rewrite iacs_aux_ok. rewrite H; auto. @@ -182,13 +177,13 @@ Proof. auto. - simpl in |- *; elim (varlist_lt v v0); simpl in |- *. + simpl; elim (varlist_lt v v0); simpl. repeat rewrite iacs_aux_ok. - rewrite H; simpl in |- *; auto. + rewrite H; simpl; auto. simpl in H0. repeat rewrite iacs_aux_ok. - rewrite H0. simpl in |- *; auto. + rewrite H0. simpl; auto. Qed. Lemma abstract_sum_scalar_ok : @@ -197,9 +192,9 @@ Lemma abstract_sum_scalar_ok : Amult (interp_vl Amult Aone Azero vm l) (interp_acs s). Proof. simple induction s. - simpl in |- *; eauto. + simpl; eauto. - simpl in |- *; intros. + simpl; intros. rewrite iacs_aux_ok. rewrite abstract_varlist_insert_ok. rewrite H. @@ -213,22 +208,22 @@ Lemma abstract_sum_prod_ok : Proof. simple induction x. - intros; simpl in |- *; eauto. + intros; simpl; eauto. destruct y as [| v0 a0]; intros. - simpl in |- *; rewrite H; eauto. + simpl; rewrite H; eauto. - unfold abstract_sum_prod in |- *; fold abstract_sum_prod in |- *. + unfold abstract_sum_prod; fold abstract_sum_prod. rewrite abstract_sum_merge_ok. rewrite abstract_sum_scalar_ok. - rewrite H; simpl in |- *; auto. + rewrite H; simpl; auto. Qed. Theorem aspolynomial_normalize_ok : forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x). Proof. - simple induction x; simpl in |- *; intros; trivial. + simple induction x; simpl; intros; trivial. rewrite abstract_sum_merge_ok. rewrite H; rewrite H0; eauto. rewrite abstract_sum_prod_ok. @@ -450,14 +445,13 @@ Hint Resolve (Th_plus_zero_right2 T). Hint Resolve (Th_mult_one_right T). Hint Resolve (Th_mult_one_right2 T). (*Hint Resolve (Th_plus_reg_right T).*) -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. Lemma isacs_aux_ok : forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s). Proof. - simple induction s; simpl in |- *; intros. + simple induction s; simpl; intros. trivial. reflexivity. reflexivity. @@ -466,15 +460,15 @@ Qed. Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core. Ltac solve1 v v0 H H0 := - simpl in |- *; elim (varlist_lt v v0); simpl in |- *; rewrite isacs_aux_ok; - [ rewrite H; simpl in |- *; auto | simpl in H0; rewrite H0; auto ]. + simpl; elim (varlist_lt v v0); simpl; rewrite isacs_aux_ok; + [ rewrite H; simpl; auto | simpl in H0; rewrite H0; auto ]. Lemma signed_sum_merge_ok : forall x y:signed_sum, interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y). simple induction x. - intro; simpl in |- *; auto. + intro; simpl; auto. simple induction y; intros. @@ -482,8 +476,8 @@ Lemma signed_sum_merge_ok : solve1 v v0 H H0. - simpl in |- *; generalize (varlist_eq_prop v v0). - elim (varlist_eq v v0); simpl in |- *. + simpl; generalize (varlist_eq_prop v v0). + elim (varlist_eq v v0); simpl. intro Heq; rewrite (Heq I). rewrite H. @@ -503,8 +497,8 @@ Lemma signed_sum_merge_ok : auto. - simpl in |- *; generalize (varlist_eq_prop v v0). - elim (varlist_eq v v0); simpl in |- *. + simpl; generalize (varlist_eq_prop v v0). + elim (varlist_eq v v0); simpl. intro Heq; rewrite (Heq I). rewrite H. @@ -522,7 +516,7 @@ Lemma signed_sum_merge_ok : Qed. Ltac solve2 l v H := - elim (varlist_lt l v); simpl in |- *; rewrite isacs_aux_ok; + elim (varlist_lt l v); simpl; rewrite isacs_aux_ok; [ auto | rewrite H; auto ]. Lemma plus_varlist_insert_ok : @@ -534,12 +528,12 @@ Proof. simple induction s. trivial. - simpl in |- *; intros. + simpl; intros. solve2 l v H. - simpl in |- *; intros. + simpl; intros. generalize (varlist_eq_prop l v). - elim (varlist_eq l v); simpl in |- *. + elim (varlist_eq l v); simpl. intro Heq; rewrite (Heq I). repeat rewrite isacs_aux_ok. @@ -561,9 +555,9 @@ Proof. simple induction s. trivial. - simpl in |- *; intros. + simpl; intros. generalize (varlist_eq_prop l v). - elim (varlist_eq l v); simpl in |- *. + elim (varlist_eq l v); simpl. intro Heq; rewrite (Heq I). repeat rewrite isacs_aux_ok. @@ -574,10 +568,10 @@ Proof. rewrite (Th_opp_def T). auto. - simpl in |- *; intros. + simpl; intros. solve2 l v H. - simpl in |- *; intros; solve2 l v H. + simpl; intros; solve2 l v H. Qed. @@ -585,9 +579,9 @@ Lemma signed_sum_opp_ok : forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s). Proof. - simple induction s; simpl in |- *; intros. + simple induction s; simpl; intros. - symmetry in |- *; apply (Th_opp_zero T). + symmetry ; apply (Th_opp_zero T). repeat rewrite isacs_aux_ok. rewrite H. @@ -611,14 +605,14 @@ Proof. simple induction s. trivial. - simpl in |- *; intros. + simpl; intros. rewrite plus_varlist_insert_ok. rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). repeat rewrite isacs_aux_ok. rewrite H. auto. - simpl in |- *; intros. + simpl; intros. rewrite minus_varlist_insert_ok. repeat rewrite isacs_aux_ok. rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). @@ -635,11 +629,11 @@ Lemma minus_sum_scalar_ok : Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)). Proof. - simple induction s; simpl in |- *; intros. + simple induction s; simpl; intros. - rewrite (Th_mult_zero_right T); symmetry in |- *; apply (Th_opp_zero T). + rewrite (Th_mult_zero_right T); symmetry ; apply (Th_opp_zero T). - simpl in |- *; intros. + simpl; intros. rewrite minus_varlist_insert_ok. rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). repeat rewrite isacs_aux_ok. @@ -648,7 +642,7 @@ Proof. rewrite (Th_plus_opp_opp T). reflexivity. - simpl in |- *; intros. + simpl; intros. rewrite plus_varlist_insert_ok. repeat rewrite isacs_aux_ok. rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T). @@ -668,16 +662,16 @@ Proof. simple induction x. - simpl in |- *; eauto 1. + simpl; eauto 1. - intros; simpl in |- *. + intros; simpl. rewrite signed_sum_merge_ok. rewrite plus_sum_scalar_ok. repeat rewrite isacs_aux_ok. rewrite H. auto. - intros; simpl in |- *. + intros; simpl. repeat rewrite isacs_aux_ok. rewrite signed_sum_merge_ok. rewrite minus_sum_scalar_ok. @@ -691,7 +685,7 @@ Qed. Theorem apolynomial_normalize_ok : forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p. Proof. - simple induction p; simpl in |- *; auto 1. + simple induction p; simpl; auto 1. intros. rewrite signed_sum_merge_ok. rewrite H; rewrite H0; reflexivity. diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v index dd4e7314..d286208a 100644 --- a/plugins/ring/Ring_normalize.v +++ b/plugins/ring/Ring_normalize.v @@ -1,25 +1,22 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Ring_normalize.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import LegacyRing_theory. Require Import Quote. Set Implicit Arguments. -Unset Boxed Definitions. Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m. Proof. intros. apply index_eq_prop. generalize H. - case (index_eq n m); simpl in |- *; trivial; intros. + case (index_eq n m); simpl; trivial; intros. contradiction. Qed. @@ -368,14 +365,13 @@ Hint Resolve (SR_plus_zero_right2 T). Hint Resolve (SR_mult_one_right T). Hint Resolve (SR_mult_one_right2 T). (*Hint Resolve (SR_plus_reg_right T).*) -Hint Resolve refl_equal sym_equal trans_equal. -(* Hints Resolve refl_eqT sym_eqT trans_eqT. *) +Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. Proof. simple induction x; simple induction y; contradiction || (try reflexivity). - simpl in |- *; intros. + simpl; intros. generalize (andb_prop2 _ _ H1); intros; elim H2; intros. rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. Qed. @@ -384,7 +380,7 @@ Remark ivl_aux_ok : forall (v:varlist) (i:index), ivl_aux i v = Amult (interp_var i) (interp_vl v). Proof. - simple induction v; simpl in |- *; intros. + simple induction v; simpl; intros. trivial. rewrite H; trivial. Qed. @@ -394,14 +390,14 @@ Lemma varlist_merge_ok : interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y). Proof. simple induction x. - simpl in |- *; trivial. + simpl; trivial. simple induction y. - simpl in |- *; trivial. - simpl in |- *; intros. - elim (index_lt i i0); simpl in |- *; intros. + simpl; trivial. + simpl; intros. + elim (index_lt i i0); simpl; intros. repeat rewrite ivl_aux_ok. - rewrite H. simpl in |- *. + rewrite H. simpl. rewrite ivl_aux_ok. eauto. @@ -414,7 +410,7 @@ Qed. Remark ics_aux_ok : forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s). Proof. - simple induction s; simpl in |- *; intros. + simple induction s; simpl; intros. trivial. reflexivity. reflexivity. @@ -424,7 +420,7 @@ Remark interp_m_ok : forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l). Proof. destruct l as [| i v]. - simpl in |- *; trivial. + simpl; trivial. reflexivity. Qed. @@ -432,10 +428,10 @@ Lemma canonical_sum_merge_ok : forall x y:canonical_sum, interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y). -simple induction x; simpl in |- *. +simple induction x; simpl. trivial. -simple induction y; simpl in |- *; intros. +simple induction y; simpl; intros. (* monom and nil *) eauto. @@ -443,25 +439,25 @@ eauto. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). -simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +simpl; repeat rewrite ics_aux_ok; rewrite H. repeat rewrite interp_m_ok. rewrite (SR_distr_left T). repeat rewrite <- (SR_plus_assoc T). apply f_equal with (f := Aplus (Amult a (interp_vl v0))). trivial. -elim (varlist_lt v v0); simpl in |- *. +elim (varlist_lt v v0); simpl. repeat rewrite ics_aux_ok. -rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. +rewrite H; simpl; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; eauto. (* monom and varlist *) generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). -simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +simpl; repeat rewrite ics_aux_ok; rewrite H. repeat rewrite interp_m_ok. rewrite (SR_distr_left T). repeat rewrite <- (SR_plus_assoc T). @@ -469,13 +465,13 @@ apply f_equal with (f := Aplus (Amult a (interp_vl v0))). rewrite (SR_mult_one_left T). trivial. -elim (varlist_lt v v0); simpl in |- *. +elim (varlist_lt v v0); simpl. repeat rewrite ics_aux_ok. -rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; +rewrite H; simpl; rewrite ics_aux_ok; eauto. +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; eauto. -simple induction y; simpl in |- *; intros. +simple induction y; simpl; intros. (* varlist and nil *) trivial. @@ -483,7 +479,7 @@ trivial. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). -simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +simpl; repeat rewrite ics_aux_ok; rewrite H. repeat rewrite interp_m_ok. rewrite (SR_distr_left T). repeat rewrite <- (SR_plus_assoc T). @@ -491,17 +487,17 @@ rewrite (SR_mult_one_left T). apply f_equal with (f := Aplus (interp_vl v0)). trivial. -elim (varlist_lt v v0); simpl in |- *. +elim (varlist_lt v v0); simpl. repeat rewrite ics_aux_ok. -rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; +rewrite H; simpl; rewrite ics_aux_ok; eauto. +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; eauto. (* varlist and varlist *) generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). -simpl in |- *; repeat rewrite ics_aux_ok; rewrite H. +simpl; repeat rewrite ics_aux_ok; rewrite H. repeat rewrite interp_m_ok. rewrite (SR_distr_left T). repeat rewrite <- (SR_plus_assoc T). @@ -509,10 +505,10 @@ rewrite (SR_mult_one_left T). apply f_equal with (f := Aplus (interp_vl v0)). trivial. -elim (varlist_lt v v0); simpl in |- *. +elim (varlist_lt v v0); simpl. repeat rewrite ics_aux_ok. -rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto. -rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *; +rewrite H; simpl; rewrite ics_aux_ok; eauto. +rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl; eauto. Qed. @@ -522,24 +518,24 @@ Lemma monom_insert_ok : Aplus (Amult a (interp_vl l)) (interp_cs s). intros; generalize s; simple induction s0. -simpl in |- *; rewrite interp_m_ok; trivial. +simpl; rewrite interp_m_ok; trivial. -simpl in |- *; intros. +simpl; intros. generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; +intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok; repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); eauto. -elim (varlist_lt l v); simpl in |- *; +elim (varlist_lt l v); simpl; [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; rewrite ics_aux_ok; eauto ]. -simpl in |- *; intros. +simpl; intros. generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; +intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok; repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); rewrite (SR_mult_one_left T); eauto. -elim (varlist_lt l v); simpl in |- *; +elim (varlist_lt l v); simpl; [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; rewrite ics_aux_ok; eauto ]. @@ -550,24 +546,24 @@ Lemma varlist_insert_ok : interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s). intros; generalize s; simple induction s0. -simpl in |- *; trivial. +simpl; trivial. -simpl in |- *; intros. +simpl; intros. generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; +intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok; repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T); rewrite (SR_mult_one_left T); eauto. -elim (varlist_lt l v); simpl in |- *; +elim (varlist_lt l v); simpl; [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; rewrite ics_aux_ok; eauto ]. -simpl in |- *; intros. +simpl; intros. generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok; +intro Hr; rewrite (Hr I); simpl; rewrite interp_m_ok; repeat rewrite ics_aux_ok; rewrite (SR_distr_left T); rewrite (SR_mult_one_left T); eauto. -elim (varlist_lt l v); simpl in |- *; +elim (varlist_lt l v); simpl; [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H; rewrite ics_aux_ok; eauto ]. @@ -577,9 +573,9 @@ Lemma canonical_sum_scalar_ok : forall (a:A) (s:canonical_sum), interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s). simple induction s. -simpl in |- *; eauto. +simpl; eauto. -simpl in |- *; intros. +simpl; intros. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. @@ -587,7 +583,7 @@ rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). reflexivity. -simpl in |- *; intros. +simpl; intros. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. @@ -600,9 +596,9 @@ Lemma canonical_sum_scalar2_ok : forall (l:varlist) (s:canonical_sum), interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s). simple induction s. -simpl in |- *; trivial. +simpl; trivial. -simpl in |- *; intros. +simpl; intros. rewrite monom_insert_ok. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. @@ -614,7 +610,7 @@ repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). reflexivity. -simpl in |- *; intros. +simpl; intros. rewrite varlist_insert_ok. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. @@ -631,9 +627,9 @@ Lemma canonical_sum_scalar3_ok : interp_cs (canonical_sum_scalar3 c l s) = Amult c (Amult (interp_vl l) (interp_cs s)). simple induction s. -simpl in |- *; repeat rewrite (SR_mult_zero_right T); reflexivity. +simpl; repeat rewrite (SR_mult_zero_right T); reflexivity. -simpl in |- *; intros. +simpl; intros. rewrite monom_insert_ok. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. @@ -645,7 +641,7 @@ repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). reflexivity. -simpl in |- *; intros. +simpl; intros. rewrite monom_insert_ok. repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. @@ -661,7 +657,7 @@ Qed. Lemma canonical_sum_prod_ok : forall x y:canonical_sum, interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y). -simple induction x; simpl in |- *; intros. +simple induction x; simpl; intros. trivial. rewrite canonical_sum_merge_ok. @@ -670,7 +666,7 @@ rewrite ics_aux_ok. rewrite interp_m_ok. rewrite H. rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)). -symmetry in |- *. +symmetry . eauto. rewrite canonical_sum_merge_ok. @@ -682,7 +678,7 @@ Qed. Theorem spolynomial_normalize_ok : forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p. -simple induction p; simpl in |- *; intros. +simple induction p; simpl; intros. reflexivity. reflexivity. @@ -703,7 +699,7 @@ simple induction s. reflexivity. (* cons_monom *) -simpl in |- *; intros. +simpl; intros. generalize (SR_eq_prop T a Azero). elim (Aeq a Azero). intro Heq; rewrite (Heq I). @@ -713,25 +709,25 @@ rewrite interp_m_ok. rewrite (SR_mult_zero_left T). trivial. -intros; simpl in |- *. +intros; simpl. generalize (SR_eq_prop T a Aone). elim (Aeq a Aone). intro Heq; rewrite (Heq I). -simpl in |- *. +simpl. repeat rewrite ics_aux_ok. rewrite interp_m_ok. rewrite H. rewrite (SR_mult_one_left T). reflexivity. -simpl in |- *. +simpl. repeat rewrite ics_aux_ok. rewrite interp_m_ok. rewrite H. reflexivity. (* cons_varlist *) -simpl in |- *; intros. +simpl; intros. repeat rewrite ics_aux_ok. rewrite H. reflexivity. @@ -741,7 +737,7 @@ Qed. Theorem spolynomial_simplify_ok : forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p. intro. -unfold spolynomial_simplify in |- *. +unfold spolynomial_simplify. rewrite canonical_sum_simplify_ok. apply spolynomial_normalize_ok. Qed. @@ -749,11 +745,11 @@ Qed. (* End properties. *) End semi_rings. -Implicit Arguments Cons_varlist. -Implicit Arguments Cons_monom. -Implicit Arguments SPconst. -Implicit Arguments SPplus. -Implicit Arguments SPmult. +Arguments Cons_varlist : default implicits. +Arguments Cons_monom : default implicits. +Arguments SPconst : default implicits. +Arguments SPplus : default implicits. +Arguments SPmult : default implicits. Section rings. @@ -797,8 +793,7 @@ Hint Resolve (Th_plus_zero_right2 T). Hint Resolve (Th_mult_one_right T). Hint Resolve (Th_mult_one_right2 T). (*Hint Resolve (Th_plus_reg_right T).*) -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. (*** Definitions *) @@ -855,7 +850,7 @@ Unset Implicit Arguments. Lemma spolynomial_of_ok : forall p:polynomial, interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p). -simple induction p; reflexivity || (simpl in |- *; intros). +simple induction p; reflexivity || (simpl; intros). rewrite H; rewrite H0; reflexivity. rewrite H; rewrite H0; reflexivity. rewrite H. @@ -868,23 +863,23 @@ Theorem polynomial_normalize_ok : forall p:polynomial, polynomial_normalize p = spolynomial_normalize Aplus Amult Aone (spolynomial_of p). -simple induction p; reflexivity || (simpl in |- *; intros). +simple induction p; reflexivity || (simpl; intros). rewrite H; rewrite H0; reflexivity. rewrite H; rewrite H0; reflexivity. -rewrite H; simpl in |- *. +rewrite H; simpl. elim (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0))); [ reflexivity - | simpl in |- *; intros; rewrite H0; reflexivity - | simpl in |- *; intros; rewrite H0; reflexivity ]. + | simpl; intros; rewrite H0; reflexivity + | simpl; intros; rewrite H0; reflexivity ]. Qed. Theorem polynomial_simplify_ok : forall p:polynomial, interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p. intro. -unfold polynomial_simplify in |- *. +unfold polynomial_simplify. rewrite spolynomial_of_ok. rewrite polynomial_normalize_ok. rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T). diff --git a/plugins/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v index da4e3756..4717edc9 100644 --- a/plugins/ring/Setoid_ring.v +++ b/plugins/ring/Setoid_ring.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Setoid_ring.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export Setoid_ring_theory. Require Export Quote. Require Export Setoid_ring_normalize. diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v index c4527cfb..b0d790e0 100644 --- a/plugins/ring/Setoid_ring_normalize.v +++ b/plugins/ring/Setoid_ring_normalize.v @@ -1,22 +1,19 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Setoid_ring_normalize.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Import Setoid_ring_theory. Require Import Quote. Set Implicit Arguments. -Unset Boxed Definitions. Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m. Proof. - simple induction n; simple induction m; simpl in |- *; + simple induction n; simple induction m; simpl; try reflexivity || contradiction. intros; rewrite (H i0); trivial. intros; rewrite (H i0); trivial. @@ -390,14 +387,13 @@ Hint Resolve (SSR_plus_zero_right2 S T). Hint Resolve (SSR_mult_one_right S T). Hint Resolve (SSR_mult_one_right2 S T). Hint Resolve (SSR_plus_reg_right S T). -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y. Proof. simple induction x; simple induction y; contradiction || (try reflexivity). - simpl in |- *; intros. + simpl; intros. generalize (andb_prop2 _ _ H1); intros; elim H2; intros. rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity. Qed. @@ -406,7 +402,7 @@ Remark ivl_aux_ok : forall (v:varlist) (i:index), Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)). Proof. - simple induction v; simpl in |- *; intros. + simple induction v; simpl; intros. trivial. rewrite (H i); trivial. Qed. @@ -416,17 +412,17 @@ Lemma varlist_merge_ok : Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)). Proof. simple induction x. - simpl in |- *; trivial. + simpl; trivial. simple induction y. - simpl in |- *; trivial. - simpl in |- *; intros. - elim (index_lt i i0); simpl in |- *; intros. + simpl; trivial. + simpl; intros. + elim (index_lt i i0); simpl; intros. rewrite (ivl_aux_ok v i). rewrite (ivl_aux_ok v0 i0). rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i). rewrite (H (Cons_var i0 v0)). - simpl in |- *. + simpl. rewrite (ivl_aux_ok v0 i0). eauto. @@ -451,7 +447,7 @@ Remark ics_aux_ok : forall (x:A) (s:canonical_sum), Aequiv (ics_aux x s) (Aplus x (interp_setcs s)). Proof. - simple induction s; simpl in |- *; intros; trivial. + simple induction s; simpl; intros; trivial. Qed. Remark interp_m_ok : @@ -471,16 +467,16 @@ Lemma canonical_sum_merge_ok : Aequiv (interp_setcs (canonical_sum_merge x y)) (Aplus (interp_setcs x) (interp_setcs y)). Proof. -simple induction x; simpl in |- *. +simple induction x; simpl. trivial. -simple induction y; simpl in |- *; intros. +simple induction y; simpl; intros. eauto. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). -simpl in |- *. +simpl. rewrite (ics_aux_ok (interp_m a v0) c). rewrite (ics_aux_ok (interp_m a0 v0) c0). rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)). @@ -507,14 +503,14 @@ setoid_replace [ idtac | trivial ]. auto. -elim (varlist_lt v v0); simpl in |- *. +elim (varlist_lt v v0); simpl. intro. rewrite (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0))) . rewrite (ics_aux_ok (interp_m a v) c). rewrite (ics_aux_ok (interp_m a0 v0) c0). -rewrite (H (Cons_monom a0 v0 c0)); simpl in |- *. +rewrite (H (Cons_monom a0 v0 c0)); simpl. rewrite (ics_aux_ok (interp_m a0 v0) c0); auto. intro. @@ -540,13 +536,13 @@ rewrite end) c0)). rewrite H0. rewrite (ics_aux_ok (interp_m a v) c); - rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; + rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl; auto. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). -simpl in |- *. +simpl. rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0)); rewrite (ics_aux_ok (interp_m a v0) c); rewrite (ics_aux_ok (interp_vl v0) c0). @@ -573,13 +569,13 @@ setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); [ idtac | trivial ]. auto. -elim (varlist_lt v v0); simpl in |- *. +elim (varlist_lt v v0); simpl. intro. rewrite (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0))) ; rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0). -rewrite (H (Cons_varlist v0 c0)); simpl in |- *. +rewrite (H (Cons_varlist v0 c0)); simpl. rewrite (ics_aux_ok (interp_vl v0) c0). auto. @@ -605,16 +601,16 @@ rewrite else Cons_varlist l2 (csm_aux t2) end) c0)); rewrite H0. rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0); - simpl in |- *. + simpl. auto. -simple induction y; simpl in |- *; intros. +simple induction y; simpl; intros. trivial. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0). intros; rewrite (H1 I). -simpl in |- *. +simpl. rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0)); rewrite (ics_aux_ok (interp_vl v0) c); rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0). @@ -638,12 +634,12 @@ setoid_replace [ idtac | trivial ]. auto. -elim (varlist_lt v v0); simpl in |- *; intros. +elim (varlist_lt v v0); simpl; intros. rewrite (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0))) ; rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0). -rewrite (H (Cons_monom a v0 c0)); simpl in |- *. +rewrite (H (Cons_monom a v0 c0)); simpl. rewrite (ics_aux_ok (interp_m a v0) c0); auto. rewrite @@ -667,11 +663,11 @@ rewrite else Cons_varlist l2 (csm_aux2 t2) end) c0)); rewrite H0. rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0); - simpl in |- *; auto. + simpl; auto. generalize (varlist_eq_prop v v0). elim (varlist_eq v v0); intros. -rewrite (H1 I); simpl in |- *. +rewrite (H1 I); simpl. rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0)) ; rewrite (ics_aux_ok (interp_vl v0) c); @@ -695,12 +691,12 @@ setoid_replace [ idtac | trivial ]. setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto. -elim (varlist_lt v v0); simpl in |- *. +elim (varlist_lt v v0); simpl. rewrite (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0))) ; rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0)); - simpl in |- *. + simpl. rewrite (ics_aux_ok (interp_vl v0) c0); auto. rewrite @@ -724,7 +720,7 @@ rewrite else Cons_varlist l2 (csm_aux2 t2) end) c0)); rewrite H0. rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0); - simpl in |- *; auto. + simpl; auto. Qed. Lemma monom_insert_ok : @@ -733,10 +729,10 @@ Lemma monom_insert_ok : (Aplus (Amult a (interp_vl l)) (interp_setcs s)). Proof. simple induction s; intros. -simpl in |- *; rewrite (interp_m_ok a l); trivial. +simpl; rewrite (interp_m_ok a l); trivial. -simpl in |- *; generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *. +simpl; generalize (varlist_eq_prop l v); elim (varlist_eq l v). +intro Hr; rewrite (Hr I); simpl. rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c); rewrite (ics_aux_ok (interp_m a0 v) c). rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v). @@ -745,7 +741,7 @@ setoid_replace (Amult (Aplus a a0) (interp_vl v)) with [ idtac | trivial ]. auto. -elim (varlist_lt l v); simpl in |- *; intros. +elim (varlist_lt l v); simpl; intros. rewrite (ics_aux_ok (interp_m a0 v) c). rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l). auto. @@ -754,9 +750,9 @@ rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c)); rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H. auto. -simpl in |- *. +simpl. generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *. +intro Hr; rewrite (Hr I); simpl. rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c); rewrite (ics_aux_ok (interp_vl v) c). rewrite (interp_m_ok (Aplus a Aone) v). @@ -767,7 +763,7 @@ setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); [ idtac | trivial ]. auto. -elim (varlist_lt l v); simpl in |- *; intros; auto. +elim (varlist_lt l v); simpl; intros; auto. rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H. rewrite (ics_aux_ok (interp_vl v) c); auto. Qed. @@ -777,11 +773,11 @@ Lemma varlist_insert_ok : Aequiv (interp_setcs (varlist_insert l s)) (Aplus (interp_vl l) (interp_setcs s)). Proof. -simple induction s; simpl in |- *; intros. +simple induction s; simpl; intros. trivial. generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *. +intro Hr; rewrite (Hr I); simpl. rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c); rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v). @@ -790,14 +786,14 @@ setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with [ idtac | trivial ]. setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. -elim (varlist_lt l v); simpl in |- *; intros; auto. +elim (varlist_lt l v); simpl; intros; auto. rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c)); rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok a v). rewrite H; auto. generalize (varlist_eq_prop l v); elim (varlist_eq l v). -intro Hr; rewrite (Hr I); simpl in |- *. +intro Hr; rewrite (Hr I); simpl. rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c); rewrite (ics_aux_ok (interp_vl v) c). rewrite (interp_m_ok (Aplus Aone Aone) v). @@ -806,7 +802,7 @@ setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with [ idtac | trivial ]. setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto. -elim (varlist_lt l v); simpl in |- *; intros; auto. +elim (varlist_lt l v); simpl; intros; auto. rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)). rewrite H. rewrite (ics_aux_ok (interp_vl v) c); auto. @@ -817,7 +813,7 @@ Lemma canonical_sum_scalar_ok : Aequiv (interp_setcs (canonical_sum_scalar a s)) (Amult a (interp_setcs s)). Proof. -simple induction s; simpl in |- *; intros. +simple induction s; simpl; intros. trivial. rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c)); @@ -840,7 +836,7 @@ Lemma canonical_sum_scalar2_ok : Aequiv (interp_setcs (canonical_sum_scalar2 l s)) (Amult (interp_vl l) (interp_setcs s)). Proof. -simple induction s; simpl in |- *; intros; auto. +simple induction s; simpl; intros; auto. rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)). rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok a v). @@ -865,7 +861,7 @@ Lemma canonical_sum_scalar3_ok : Aequiv (interp_setcs (canonical_sum_scalar3 c l s)) (Amult c (Amult (interp_vl l) (interp_setcs s))). Proof. -simple induction s; simpl in |- *; intros. +simple induction s; simpl; intros. rewrite (SSR_mult_zero_right S T (interp_vl l)). auto. @@ -914,7 +910,7 @@ Lemma canonical_sum_prod_ok : Aequiv (interp_setcs (canonical_sum_prod x y)) (Amult (interp_setcs x) (interp_setcs y)). Proof. -simple induction x; simpl in |- *; intros. +simple induction x; simpl; intros. trivial. rewrite @@ -948,7 +944,7 @@ Theorem setspolynomial_normalize_ok : forall p:setspolynomial, Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p). Proof. -simple induction p; simpl in |- *; intros; trivial. +simple induction p; simpl; intros; trivial. rewrite (canonical_sum_merge_ok (setspolynomial_normalize s) (setspolynomial_normalize s0)). @@ -964,12 +960,12 @@ Lemma canonical_sum_simplify_ok : forall s:canonical_sum, Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s). Proof. -simple induction s; simpl in |- *; intros. +simple induction s; simpl; intros. trivial. generalize (SSR_eq_prop T a Azero). elim (Aeq a Azero). -simpl in |- *. +simpl. intros. rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok a v). @@ -979,19 +975,19 @@ setoid_replace (Amult Azero (interp_vl v)) with Azero; rewrite H. trivial. -intros; simpl in |- *. +intros; simpl. generalize (SSR_eq_prop T a Aone). elim (Aeq a Aone). intros. rewrite (ics_aux_ok (interp_m a v) c). rewrite (interp_m_ok a v). rewrite (H1 I). -simpl in |- *. +simpl. rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)). rewrite H. auto. -simpl in |- *. +simpl. intros. rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)). rewrite (ics_aux_ok (interp_m a v) c). @@ -1007,18 +1003,18 @@ Theorem setspolynomial_simplify_ok : Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p). Proof. intro. -unfold setspolynomial_simplify in |- *. +unfold setspolynomial_simplify. rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)). exact (setspolynomial_normalize_ok p). Qed. End semi_setoid_rings. -Implicit Arguments Cons_varlist. -Implicit Arguments Cons_monom. -Implicit Arguments SetSPconst. -Implicit Arguments SetSPplus. -Implicit Arguments SetSPmult. +Arguments Cons_varlist : default implicits. +Arguments Cons_monom : default implicits. +Arguments SetSPconst : default implicits. +Arguments SetSPplus : default implicits. +Arguments SetSPmult : default implicits. @@ -1055,8 +1051,7 @@ Hint Resolve (STh_plus_zero_right2 S T). Hint Resolve (STh_mult_one_right S T). Hint Resolve (STh_mult_one_right2 S T). Hint Resolve (STh_plus_reg_right S plus_morph T). -Hint Resolve refl_equal sym_equal trans_equal. -(*Hints Resolve refl_eqT sym_eqT trans_eqT.*) +Hint Resolve eq_refl eq_sym eq_trans. Hint Immediate T. @@ -1113,7 +1108,7 @@ Unset Implicit Arguments. Lemma setspolynomial_of_ok : forall p:setpolynomial, Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)). -simple induction p; trivial; simpl in |- *; intros. +simple induction p; trivial; simpl; intros. rewrite H; rewrite H0; trivial. rewrite H; rewrite H0; trivial. rewrite H. @@ -1127,23 +1122,23 @@ Qed. Theorem setpolynomial_normalize_ok : forall p:setpolynomial, setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p). -simple induction p; trivial; simpl in |- *; intros. +simple induction p; trivial; simpl; intros. rewrite H; rewrite H0; reflexivity. rewrite H; rewrite H0; reflexivity. -rewrite H; simpl in |- *. +rewrite H; simpl. elim (canonical_sum_scalar3 (Aopp Aone) Nil_var (setspolynomial_normalize (setspolynomial_of s))); [ reflexivity - | simpl in |- *; intros; rewrite H0; reflexivity - | simpl in |- *; intros; rewrite H0; reflexivity ]. + | simpl; intros; rewrite H0; reflexivity + | simpl; intros; rewrite H0; reflexivity ]. Qed. Theorem setpolynomial_simplify_ok : forall p:setpolynomial, Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p). intro. -unfold setpolynomial_simplify in |- *. +unfold setpolynomial_simplify. rewrite (setspolynomial_of_ok p). rewrite setpolynomial_normalize_ok. rewrite diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v index f07cbaf6..52f5968b 100644 --- a/plugins/ring/Setoid_ring_theory.v +++ b/plugins/ring/Setoid_ring_theory.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Setoid_ring_theory.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export Bool. Require Export Setoid. @@ -408,7 +406,7 @@ Unset Implicit Arguments. Definition Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory. intros until 1; case H. -split; intros; simpl in |- *; eauto. +split; intros; simpl; eauto. Defined. Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >-> diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4 index c5a33f39..8953b88f 100644 --- a/plugins/ring/g_ring.ml4 +++ b/plugins/ring/g_ring.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: g_ring.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Quote open Ring open Tacticals diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index 6e67272c..7b0d96bb 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: ring.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - (* ML part of the Ring tactic *) open Pp @@ -21,7 +19,6 @@ open Reductionops open Tacticals open Tacexpr open Tacmach -open Proof_trees open Printer open Equality open Vernacinterp @@ -138,7 +135,7 @@ let mkLApp(fc,v) = mkApp(Lazy.force fc, v) module OperSet = Set.Make (struct type t = global_reference - let compare = (Pervasives.compare : t->t->int) + let compare = (RefOrdered.compare : t->t->int) end) type morph = @@ -169,7 +166,7 @@ type theory = (* Theories are stored in a table which is synchronised with the Reset mechanism. *) -module Cmap = Map.Make(struct type t = constr let compare = compare end) +module Cmap = Map.Make(struct type t = constr let compare = constr_ord end) let theories_map = ref Cmap.empty @@ -265,7 +262,7 @@ let subst_th (subst,(c,th as obj)) = (c',th') -let (theory_to_obj, obj_to_theory) = +let theory_to_obj : constr * theory -> obj = let cache_th (_,(c, th)) = theories_map_add (c,th) in declare_object {(default_object "tactic-ring-theory") with open_function = (fun i o -> if i=1 then cache_th o); @@ -295,7 +292,8 @@ let unbox = function (* Protects the convertibility test against undue exceptions when using it with untyped terms *) -let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false +let safe_pf_conv_x gl c1 c2 = + try pf_conv_x gl c1 c2 with e when Errors.noncritical e -> false (* Add a Ring or a Semi-Ring to the database after a type verification *) @@ -380,8 +378,14 @@ Builds *) +module Constrhash = Hashtbl.Make + (struct type t = constr + let equal = eq_constr + let hash = hash_constr + end) + let build_spolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) (* aux creates the spolynom p by a recursive destructuration of c @@ -395,14 +399,14 @@ let build_spolynom gl th lc = | _ when closed_under th.th_closed c -> mkLApp(coq_SPconst, [|th.th_a; c |]) | _ -> - try Hashtbl.find varhash c + try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in begin incr counter; varlist := c :: !varlist; - Hashtbl.add varhash c newvar; + Constrhash.add varhash c newvar; newvar end in @@ -437,7 +441,7 @@ Builds *) let build_polynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = @@ -446,7 +450,7 @@ let build_polynom gl th lc = mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |]) - (* The special case of Zminus *) + (* The special case of Z.sub *) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl c (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) -> @@ -458,14 +462,14 @@ let build_polynom gl th lc = | _ when closed_under th.th_closed c -> mkLApp(coq_Pconst, [|th.th_a; c |]) | _ -> - try Hashtbl.find varhash c + try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in begin incr counter; varlist := c :: !varlist; - Hashtbl.add varhash c newvar; + Constrhash.add varhash c newvar; newvar end in @@ -501,7 +505,7 @@ Builds *) let build_aspolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) (* aux creates the aspolynom p by a recursive destructuration of c @@ -515,13 +519,13 @@ let build_aspolynom gl th lc = | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0 | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1 | _ -> - try Hashtbl.find varhash c + try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in begin incr counter; varlist := c :: !varlist; - Hashtbl.add varhash c newvar; + Constrhash.add varhash c newvar; newvar end in @@ -555,7 +559,7 @@ Builds *) let build_apolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = @@ -564,7 +568,7 @@ let build_apolynom gl th lc = mkLApp(coq_APplus, [| aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_APmult, [| aux c1; aux c2 |]) - (* The special case of Zminus *) + (* The special case of Z.sub *) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl c (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) -> @@ -575,14 +579,14 @@ let build_apolynom gl th lc = | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0 | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1 | _ -> - try Hashtbl.find varhash c + try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_APvar, [| path_of_int !counter |]) in begin incr counter; varlist := c :: !varlist; - Hashtbl.add varhash c newvar; + Constrhash.add varhash c newvar; newvar end in @@ -616,7 +620,7 @@ Builds *) let build_setpolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = @@ -625,7 +629,7 @@ let build_setpolynom gl th lc = mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |]) - (* The special case of Zminus *) + (* The special case of Z.sub *) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl c (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) -> @@ -637,14 +641,14 @@ let build_setpolynom gl th lc = | _ when closed_under th.th_closed c -> mkLApp(coq_SetPconst, [| th.th_a; c |]) | _ -> - try Hashtbl.find varhash c + try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in begin incr counter; varlist := c :: !varlist; - Hashtbl.add varhash c newvar; + Constrhash.add varhash c newvar; newvar end in @@ -683,7 +687,7 @@ Builds *) let build_setspolynom gl th lc = - let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in + let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) let rec aux c = @@ -695,14 +699,14 @@ let build_setspolynom gl th lc = | _ when closed_under th.th_closed c -> mkLApp(coq_SetSPconst, [| th.th_a; c |]) | _ -> - try Hashtbl.find varhash c + try Constrhash.find varhash c with Not_found -> let newvar = mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in begin incr counter; varlist := c :: !varlist; - Hashtbl.add varhash c newvar; + Constrhash.add varhash c newvar; newvar end in @@ -823,9 +827,9 @@ let raw_polynom th op lc gl = (tclTHENS (tclORELSE (Equality.general_rewrite true - Termops.all_occurrences false c'i_eq_c''i) + Termops.all_occurrences true false c'i_eq_c''i) (Equality.general_rewrite false - Termops.all_occurrences false c'i_eq_c''i)) + Termops.all_occurrences true false c'i_eq_c''i)) [tac])) else (tclORELSE diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 04eac3a8..ab424c22 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -14,14 +14,14 @@ Delimit Scope Int_scope with I. Module Type Int. - Parameter int : Set. + Parameter t : Set. - Parameter zero : int. - Parameter one : int. - Parameter plus : int -> int -> int. - Parameter opp : int -> int. - Parameter minus : int -> int -> int. - Parameter mult : int -> int -> int. + Parameter zero : t. + Parameter one : t. + Parameter plus : t -> t -> t. + Parameter opp : t -> t. + Parameter minus : t -> t -> t. + Parameter mult : t -> t -> t. Notation "0" := zero : Int_scope. Notation "1" := one : Int_scope. @@ -33,14 +33,14 @@ Module Type Int. Open Scope Int_scope. (* First, int is a ring: *) - Axiom ring : @ring_theory int 0 1 plus mult minus opp (@eq int). + Axiom ring : @ring_theory t 0 1 plus mult minus opp (@eq t). (* int should also be ordered: *) - Parameter le : int -> int -> Prop. - Parameter lt : int -> int -> Prop. - Parameter ge : int -> int -> Prop. - Parameter gt : int -> int -> Prop. + Parameter le : t -> t -> Prop. + Parameter lt : t -> t -> Prop. + Parameter ge : t -> t -> Prop. + Parameter gt : t -> t -> Prop. Notation "x <= y" := (le x y): Int_scope. Notation "x < y" := (lt x y) : Int_scope. Notation "x >= y" := (ge x y) : Int_scope. @@ -61,7 +61,7 @@ Module Type Int. forall i j k, 0 < k -> i < j -> k*i<k*j. (* We should have a way to decide the equality and the order*) - Parameter compare : int -> int -> comparison. + Parameter compare : t -> t -> comparison. Infix "?=" := compare (at level 70, no associativity) : Int_scope. Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j. @@ -83,76 +83,53 @@ Module Z_as_Int <: Int. Open Scope Z_scope. - Definition int := Z. + Definition t := Z. Definition zero := 0. Definition one := 1. - Definition plus := Zplus. - Definition opp := Zopp. - Definition minus := Zminus. - Definition mult := Zmult. + Definition plus := Z.add. + Definition opp := Z.opp. + Definition minus := Z.sub. + Definition mult := Z.mul. - Lemma ring : @ring_theory int zero one plus mult minus opp (@eq int). + Lemma ring : @ring_theory t zero one plus mult minus opp (@eq t). Proof. constructor. - exact Zplus_0_l. - exact Zplus_comm. - exact Zplus_assoc. - exact Zmult_1_l. - exact Zmult_comm. - exact Zmult_assoc. - exact Zmult_plus_distr_l. - unfold minus, Zminus; auto. - exact Zplus_opp_r. + exact Z.add_0_l. + exact Z.add_comm. + exact Z.add_assoc. + exact Z.mul_1_l. + exact Z.mul_comm. + exact Z.mul_assoc. + exact Z.mul_add_distr_r. + unfold minus, Z.sub; auto. + exact Z.add_opp_diag_r. Qed. - Definition le := Zle. - Definition lt := Zlt. - Definition ge := Zge. - Definition gt := Zgt. - Lemma le_lt_iff : forall i j, (i<=j) <-> ~(j<i). - Proof. - split; intros. - apply Zle_not_lt; auto. - rewrite <- Zge_iff_le. - apply Znot_lt_ge; auto. - Qed. - Definition ge_le_iff := Zge_iff_le. - Definition gt_lt_iff := Zgt_iff_lt. + Definition le := Z.le. + Definition lt := Z.lt. + Definition ge := Z.ge. + Definition gt := Z.gt. + Definition le_lt_iff := Z.le_ngt. + Definition ge_le_iff := Z.ge_le_iff. + Definition gt_lt_iff := Z.gt_lt_iff. - Definition lt_trans := Zlt_trans. - Definition lt_not_eq := Zlt_not_eq. + Definition lt_trans := Z.lt_trans. + Definition lt_not_eq := Z.lt_neq. - Definition lt_0_1 := Zlt_0_1. - Definition plus_le_compat := Zplus_le_compat. + Definition lt_0_1 := Z.lt_0_1. + Definition plus_le_compat := Z.add_le_mono. Definition mult_lt_compat_l := Zmult_lt_compat_l. - Lemma opp_le_compat : forall i j, i<=j -> (-j)<=(-i). - Proof. - unfold Zle; intros; rewrite <- Zcompare_opp; auto. - Qed. + Lemma opp_le_compat i j : i<=j -> (-j)<=(-i). + Proof. apply -> Z.opp_le_mono. Qed. - Definition compare := Zcompare. - Definition compare_Eq := Zcompare_Eq_iff_eq. - Lemma compare_Lt : forall i j, compare i j = Lt <-> i<j. - Proof. intros; unfold compare, Zlt; intuition. Qed. - Lemma compare_Gt : forall i j, compare i j = Gt <-> i>j. - Proof. intros; unfold compare, Zgt; intuition. Qed. + Definition compare := Z.compare. + Definition compare_Eq := Z.compare_eq_iff. + Lemma compare_Lt i j : compare i j = Lt <-> i<j. + Proof. reflexivity. Qed. + Lemma compare_Gt i j : compare i j = Gt <-> i>j. + Proof. reflexivity. Qed. - Lemma le_lt_int : forall x y, x<y <-> x<=y+-(1). - Proof. - intros; split; intros. - generalize (Zlt_left _ _ H); simpl; intros. - apply Zle_left_rev; auto. - apply Zlt_0_minus_lt. - generalize (Zplus_le_lt_compat x (y+-1) (-x) (-x+1) H). - rewrite Zplus_opp_r. - rewrite <-Zplus_assoc. - rewrite (Zplus_permute (-1)). - simpl in *. - rewrite Zplus_0_r. - intro H'; apply H'. - replace (-x+1) with (Zsucc (-x)); auto. - apply Zlt_succ. - Qed. + Definition le_lt_int := Z.lt_le_pred. End Z_as_Int. @@ -161,6 +138,7 @@ End Z_as_Int. Module IntProperties (I:Int). Import I. + Local Notation int := I.t. (* Primo, some consequences of being a ring theory... *) @@ -363,7 +341,7 @@ Module IntProperties (I:Int). Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d. Proof. - intros; elim H; elim H0; simpl in |- *; auto. + intros; elim H; elim H0; simpl; auto. now rewrite mult_0_l, mult_0_l, plus_0_l. Qed. @@ -850,6 +828,7 @@ Module IntOmega (I:Int). Import I. Module IP:=IntProperties(I). Import IP. +Local Notation int := I.t. (* \subsubsection{Definition of reified integer expressions} Terms are either: @@ -868,11 +847,11 @@ Inductive term : Set := | Tvar : nat -> term. Delimit Scope romega_scope with term. -Arguments Scope Tint [Int_scope]. -Arguments Scope Tplus [romega_scope romega_scope]. -Arguments Scope Tmult [romega_scope romega_scope]. -Arguments Scope Tminus [romega_scope romega_scope]. -Arguments Scope Topp [romega_scope]. +Arguments Tint _%I. +Arguments Tplus (_ _)%term. +Arguments Tmult (_ _)%term. +Arguments Tminus (_ _)%term. +Arguments Topp _%term. Infix "+" := Tplus : romega_scope. Infix "*" := Tmult : romega_scope. @@ -1014,7 +993,7 @@ Inductive h_step : Set := (* This type allows to navigate in the logical constructors that form the predicats of the hypothesis in order to decompose them. This allows in particular to extract one hypothesis from a - conjonction with possibly the right level of negations. *) + conjunction with possibly the right level of negations. *) Inductive direction : Set := | D_left : direction @@ -1060,52 +1039,24 @@ Close Scope romega_scope. Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. Proof. - simple induction t1; intros until t2; case t2; simpl in *; - try (intros; discriminate; fail); - [ intros; elim beq_true with (1 := H); trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); - trivial - | intros t21 H3; elim H with (1 := H3); trivial - | intros; elim beq_nat_true with (1 := H); trivial ]. + induction t1; destruct t2; simpl in *; try discriminate; + (rewrite andb_true_iff; intros (H1,H2)) || intros H; f_equal; + auto using beq_true, beq_nat_true. Qed. -Ltac trivial_case := unfold not in |- *; intros; discriminate. +Theorem eq_term_refl : forall t0 : term, eq_term t0 t0 = true. +Proof. + induction t0; simpl in *; try (apply andb_true_iff; split); trivial. + - now apply beq_iff. + - now apply beq_nat_true_iff. +Qed. + +Ltac trivial_case := unfold not; intros; discriminate. Theorem eq_term_false : forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2. Proof. - simple induction t1; - [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; - intros; elim beq_false with (1 := H); simplify_eq H0; - auto - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; - intros t21 t22 H3; unfold not in |- *; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; - intros t21 t22 H3; unfold not in |- *; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; - intros t21 t22 H3; unfold not in |- *; intro H4; - elim andb_false_elim with (1 := H3); intros H5; - [ elim H1 with (1 := H5); simplify_eq H4; auto - | elim H2 with (1 := H5); simplify_eq H4; auto ] - | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3; - unfold not in |- *; intro H4; elim H1 with (1 := H3); - simplify_eq H4; auto - | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; - intros; elim beq_nat_false with (1 := H); simplify_eq H0; - auto ]. + intros t1 t2 H E. subst t2. now rewrite eq_term_refl in H. Qed. (* \subsubsection{Tactiques pour éliminer ces tests} @@ -1123,17 +1074,17 @@ Qed. avait utilisé le test précédent et fait une elimination dessus. *) Ltac elim_eq_term t1 t2 := - pattern (eq_term t1 t2) in |- *; apply bool_eq_ind; intro Aux; + pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux; [ generalize (eq_term_true t1 t2 Aux); clear Aux | generalize (eq_term_false t1 t2 Aux); clear Aux ]. Ltac elim_beq t1 t2 := - pattern (beq t1 t2) in |- *; apply bool_eq_ind; intro Aux; + pattern (beq t1 t2); apply bool_eq_ind; intro Aux; [ generalize (beq_true t1 t2 Aux); clear Aux | generalize (beq_false t1 t2 Aux); clear Aux ]. Ltac elim_bgt t1 t2 := - pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux; + pattern (bgt t1 t2); apply bool_eq_ind; intro Aux; [ generalize (bgt_true t1 t2 Aux); clear Aux | generalize (bgt_false t1 t2 Aux); clear Aux ]. @@ -1209,15 +1160,15 @@ Theorem goal_to_hyps : (interp_hyps envp env l -> False) -> interp_goal envp env l. Proof. simple induction l; - [ simpl in |- *; auto - | simpl in |- *; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. + [ simpl; auto + | simpl; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ]. Qed. Theorem hyps_to_goal : forall (envp : list Prop) (env : list int) (l : hyps), interp_goal envp env l -> interp_hyps envp env l -> False. Proof. - simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ]. + simple induction l; simpl; [ auto | intros; apply H; elim H1; auto ]. Qed. (* \subsection{Manipulations sur les hypothèses} *) @@ -1257,7 +1208,7 @@ Theorem valid_goal : forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps), valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l. Proof. - intros; simpl in |- *; apply goal_to_hyps; intro H1; + intros; simpl; apply goal_to_hyps; intro H1; apply (hyps_to_goal ep env (a l) H0); apply H; assumption. Qed. @@ -1282,7 +1233,7 @@ Theorem list_goal_to_hyps : forall (envp : list Prop) (env : list int) (l : lhyps), (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l. Proof. - simple induction l; simpl in |- *; + simple induction l; simpl; [ auto | intros h1 l1 H H1; split; [ apply goal_to_hyps; intro H2; apply H1; auto @@ -1293,7 +1244,7 @@ Theorem list_hyps_to_goal : forall (envp : list Prop) (env : list int) (l : lhyps), interp_list_goal envp env l -> interp_list_hyps envp env l -> False. Proof. - simple induction l; simpl in |- *; + simple induction l; simpl; [ auto | intros h1 l1 H (H1, H2) H3; elim H3; intro H4; [ apply hyps_to_goal with (1 := H1); assumption | auto ] ]. @@ -1310,7 +1261,7 @@ Definition valid_list_goal (f : hyps -> lhyps) := Theorem goal_valid : forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. Proof. - unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps; + unfold valid_list_goal; intros f H ep e lp H1; apply goal_to_hyps; intro H2; apply list_hyps_to_goal with (1 := H1); apply (H ep e lp); assumption. Qed. @@ -1321,8 +1272,8 @@ Theorem append_valid : interp_list_hyps ep e (l1 ++ l2). Proof. intros ep e; simple induction l1; - [ simpl in |- *; intros l2 [H| H]; [ contradiction | trivial ] - | simpl in |- *; intros h1 t1 HR l2 [[H| H]| H]; + [ simpl; intros l2 [H| H]; [ contradiction | trivial ] + | simpl; intros h1 t1 HR l2 [[H| H]| H]; [ auto | right; apply (HR l2); left; trivial | right; apply (HR l2); right; trivial ] ]. @@ -1338,11 +1289,11 @@ Theorem nth_valid : forall (ep : list Prop) (e : list int) (i : nat) (l : hyps), interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l). Proof. - unfold nth_hyps in |- *; simple induction i; - [ simple induction l; simpl in |- *; [ auto | intros; elim H0; auto ] + unfold nth_hyps; simple induction i; + [ simple induction l; simpl; [ auto | intros; elim H0; auto ] | intros n H; simple induction l; - [ simpl in |- *; trivial - | intros; simpl in |- *; apply H; elim H1; auto ] ]. + [ simpl; trivial + | intros; simpl; apply H; elim H1; auto ] ]. Qed. (* Appliquer une opération (valide) sur deux hypothèses extraites de @@ -1355,7 +1306,7 @@ Theorem apply_oper_2_valid : forall (i j : nat) (f : proposition -> proposition -> proposition), valid2 f -> valid_hyps (apply_oper_2 i j f). Proof. - intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *; + intros i j f Hf; unfold apply_oper_2, valid_hyps; simpl; intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ]. Qed. @@ -1376,14 +1327,14 @@ Theorem apply_oper_1_valid : forall (i : nat) (f : proposition -> proposition), valid1 f -> valid_hyps (apply_oper_1 i f). Proof. - unfold valid_hyps in |- *; intros i f Hf ep e; elim i; + unfold valid_hyps; intros i f Hf ep e; elim i; [ intro lp; case lp; - [ simpl in |- *; trivial - | simpl in |- *; intros p l' (H1, H2); split; + [ simpl; trivial + | simpl; intros p l' (H1, H2); split; [ apply Hf with (1 := H1) | assumption ] ] | intros n Hrec lp; case lp; - [ simpl in |- *; auto - | simpl in |- *; intros p l' (H1, H2); split; + [ simpl; auto + | simpl; intros p l' (H1, H2); split; [ assumption | apply Hrec; assumption ] ] ]. Qed. @@ -1421,14 +1372,14 @@ Definition apply_both (f g : term -> term) (t : term) := Theorem apply_left_stable : forall f : term -> term, term_stable f -> term_stable (apply_left f). Proof. - unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; + unfold term_stable; intros f H e t; case t; auto; simpl; intros; elim H; trivial. Qed. Theorem apply_right_stable : forall f : term -> term, term_stable f -> term_stable (apply_right f). Proof. - unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *; + unfold term_stable; intros f H e t; case t; auto; simpl; intros t0 t1; elim H; trivial. Qed. @@ -1436,7 +1387,7 @@ Theorem apply_both_stable : forall f g : term -> term, term_stable f -> term_stable g -> term_stable (apply_both f g). Proof. - unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *; + unfold term_stable; intros f g H1 H2 e t; case t; auto; simpl; intros t0 t1; elim H1; elim H2; trivial. Qed. @@ -1444,7 +1395,7 @@ Theorem compose_term_stable : forall f g : term -> term, term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)). Proof. - unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg. + unfold term_stable; intros f g Hf Hg e t; elim Hf; apply Hg. Qed. (* \subsection{Les règles de réécriture} *) @@ -1522,14 +1473,14 @@ Ltac loop t := | (if beq ?X1 ?X2 then _ else _) => let H := fresh "H" in elim_beq X1 X2; intro H; try (rewrite H in *; clear H); - simpl in |- *; auto; Simplify + simpl; auto; Simplify | (if bgt ?X1 ?X2 then _ else _) => let H := fresh "H" in - elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify + elim_bgt X1 X2; intro H; simpl; auto; Simplify | (if eq_term ?X1 ?X2 then _ else _) => let H := fresh "H" in elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); - simpl in |- *; auto; Simplify + simpl; auto; Simplify | (if _ && _ then _ else _) => rewrite andb_if; Simplify | (if negb _ then _ else _) => rewrite negb_if; Simplify | _ => fail @@ -1543,7 +1494,7 @@ with Simplify := match goal with Ltac prove_stable x th := match constr:x with | ?X1 => - unfold term_stable, X1 in |- *; intros; Simplify; simpl in |- *; + unfold term_stable, X1; intros; Simplify; simpl; apply th end. @@ -1663,7 +1614,7 @@ Definition T_OMEGA13 (t : term) := Theorem T_OMEGA13_stable : term_stable T_OMEGA13. Proof. - unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *; + unfold term_stable, T_OMEGA13; intros; Simplify; simpl; apply OMEGA13. Qed. @@ -1910,16 +1861,16 @@ Fixpoint reduce (t : term) : term := Theorem reduce_stable : term_stable reduce. Proof. - unfold term_stable in |- *; intros e t; elim t; auto; + unfold term_stable; intros e t; elim t; auto; try - (intros t0 H0 t1 H1; simpl in |- *; rewrite H0; rewrite H1; + (intros t0 H0 t1 H1; simpl; rewrite H0; rewrite H1; (case (reduce t0); [ intro z0; case (reduce t1); intros; auto | intros; auto | intros; auto | intros; auto | intros; auto - | intros; auto ])); intros t0 H0; simpl in |- *; + | intros; auto ])); intros t0 H0; simpl; rewrite H0; case (reduce t0); intros; auto. Qed. @@ -1942,14 +1893,14 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := end end. -Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t). +Theorem fusion_stable : forall trace : list t_fusion, term_stable (fusion trace). Proof. - simple induction t; simpl in |- *; + simple induction trace; simpl; [ exact reduce_stable | intros stp l H; case stp; [ apply compose_term_stable; [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ] - | unfold term_stable in |- *; intros e t1; rewrite T_OMEGA10_stable; + | unfold term_stable; intros e t1; rewrite T_OMEGA10_stable; rewrite Tred_factor5_stable; apply H | apply compose_term_stable; [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ] @@ -1982,7 +1933,7 @@ Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term := Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t). Proof. - unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace; + unfold term_stable, fusion_cancel; intros trace e; elim trace; [ exact (reduce_stable e) | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. Qed. @@ -1999,7 +1950,7 @@ Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term := Theorem scalar_norm_add_stable : forall t : nat, term_stable (scalar_norm_add t). Proof. - unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace; + unfold term_stable, scalar_norm_add; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA11_stable e t) | exact H ] ]. @@ -2014,7 +1965,7 @@ Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t). Proof. - unfold term_stable, scalar_norm in |- *; intros trace; elim trace; + unfold term_stable, scalar_norm; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA16_stable e t) | exact H ] ]. @@ -2029,7 +1980,7 @@ Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term := Theorem add_norm_stable : forall t : nat, term_stable (add_norm t). Proof. - unfold term_stable, add_norm in |- *; intros trace; elim trace; + unfold term_stable, add_norm; intros trace; elim trace; [ exact reduce_stable | intros n H e t; elim apply_right_stable; [ exact (Tplus_assoc_r_stable e t) | exact H ] ]. @@ -2038,12 +1989,12 @@ Qed. (* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *) -Fixpoint rewrite (s : step) : term -> term := +Fixpoint t_rewrite (s : step) : term -> term := match s with - | C_DO_BOTH s1 s2 => apply_both (rewrite s1) (rewrite s2) - | C_LEFT s => apply_left (rewrite s) - | C_RIGHT s => apply_right (rewrite s) - | C_SEQ s1 s2 => fun t : term => rewrite s2 (rewrite s1 t) + | C_DO_BOTH s1 s2 => apply_both (t_rewrite s1) (t_rewrite s2) + | C_LEFT s => apply_left (t_rewrite s) + | C_RIGHT s => apply_right (t_rewrite s) + | C_SEQ s1 s2 => fun t : term => t_rewrite s2 (t_rewrite s1 t) | C_NOP => fun t : term => t | C_OPP_PLUS => Topp_plus | C_OPP_OPP => Topp_opp @@ -2069,14 +2020,14 @@ Fixpoint rewrite (s : step) : term -> term := | C_MULT_COMM => Tmult_comm end. -Theorem rewrite_stable : forall s : step, term_stable (rewrite s). +Theorem t_rewrite_stable : forall s : step, term_stable (t_rewrite s). Proof. - simple induction s; simpl in |- *; + simple induction s; simpl; [ intros; apply apply_both_stable; auto | intros; apply apply_left_stable; auto | intros; apply apply_right_stable; auto - | unfold term_stable in |- *; intros; elim H0; apply H - | unfold term_stable in |- *; auto + | unfold term_stable; intros; elim H0; apply H + | unfold term_stable; auto | exact Topp_plus_stable | exact Topp_opp_stable | exact Topp_mult_r_stable @@ -2116,11 +2067,8 @@ Definition constant_not_nul (i : nat) (h : hyps) := Theorem constant_not_nul_valid : forall i : nat, valid_hyps (constant_not_nul i). Proof. - unfold valid_hyps, constant_not_nul in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; simpl in |- *. - - elim_beq i1 i0; auto; simpl in |- *; intros H1 H2; - elim H1; symmetry in |- *; auto. + unfold valid_hyps, constant_not_nul; intros i ep e lp H. + generalize (nth_valid ep e i lp H); Simplify. Qed. (* \paragraph{[O_CONSTANT_NEG]} *) @@ -2134,8 +2082,8 @@ Definition constant_neg (i : nat) (h : hyps) := Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i). Proof. - unfold valid_hyps, constant_neg in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; simpl in |- *. + unfold valid_hyps, constant_neg; intros; + generalize (nth_valid ep e i lp); Simplify; simpl. rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. Qed. @@ -2154,12 +2102,12 @@ Definition not_exact_divide (k1 k2 : int) (body : term) end. Theorem not_exact_divide_valid : - forall (k1 k2 : int) (body : term) (t i : nat), - valid_hyps (not_exact_divide k1 k2 body t i). + forall (k1 k2 : int) (body : term) (t0 i : nat), + valid_hyps (not_exact_divide k1 k2 body t0 i). Proof. - unfold valid_hyps, not_exact_divide in |- *; intros; + unfold valid_hyps, not_exact_divide; intros; generalize (nth_valid ep e i lp); Simplify. - rewrite (scalar_norm_add_stable t e), <-H1. + rewrite (scalar_norm_add_stable t0 e), <-H1. do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. absurd (interp_term e body * k1 + k2 = 0); [ now apply OMEGA4 | symmetry; auto ]. @@ -2186,16 +2134,16 @@ Definition contradiction (t i j : nat) (l : hyps) := Theorem contradiction_valid : forall t i j : nat, valid_hyps (contradiction t i j). Proof. - unfold valid_hyps, contradiction in |- *; intros t i j ep e l H; + unfold valid_hyps, contradiction; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; - simpl in |- *; intros z z' H1 H2; - generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term))); - pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *; - case (fusion_cancel t (t2 + t4)%term); simpl in |- *; - auto; intro k; elim (fusion_cancel_stable t); simpl in |- *. + simpl; intros z z' H1 H2; + generalize (eq_refl (interp_term e (fusion_cancel t (t2 + t4)%term))); + pattern (fusion_cancel t (t2 + t4)%term) at 2 3; + case (fusion_cancel t (t2 + t4)%term); simpl; + auto; intro k; elim (fusion_cancel_stable t); simpl. Simplify; intro H3. generalize (OMEGA2 _ _ H2 H1); rewrite H3. rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. @@ -2250,23 +2198,23 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := Theorem negate_contradict_valid : forall i j : nat, valid_hyps (negate_contradict i j). Proof. - unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H; + unfold valid_hyps, negate_contradict; intros i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; intros z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl in |- *; intros H1 H2; Simplify. + auto; simpl; intros H1 H2; Simplify. Qed. Theorem negate_contradict_inv_valid : forall t i j : nat, valid_hyps (negate_contradict_inv t i j). Proof. - unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H; + unfold valid_hyps, negate_contradict_inv; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); case (nth_hyps i l); auto; intros t1 t2; case t1; auto; intros z; auto; case (nth_hyps j l); auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl in |- *; intros H1 H2; Simplify; + auto; simpl; intros H1 H2; Simplify; [ rewrite <- scalar_norm_stable in H2; simpl in *; elim (mult_integral (interp_term e t4) (-(1))); intuition; @@ -2333,9 +2281,9 @@ Definition sum (k1 k2 : int) (trace : list t_fusion) Theorem sum_valid : forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t). Proof. - unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *; - Simplify; simpl in |- *; auto; try elim (fusion_stable t); - simpl in |- *; intros; + unfold valid2; intros k1 k2 t ep e p1 p2; unfold sum; + Simplify; simpl; auto; try elim (fusion_stable t); + simpl; intros; [ apply sum1; assumption | apply sum2; try assumption; apply sum4; assumption | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption @@ -2367,10 +2315,10 @@ Definition exact_divide (k : int) (body : term) (t : nat) Theorem exact_divide_valid : forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n). Proof. - unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; + unfold valid1, exact_divide; intros k1 k2 t ep e p1; Simplify; simpl; auto; subst; rewrite <- scalar_norm_stable; simpl; intros; - [ destruct (mult_integral _ _ (sym_eq H0)); intuition + [ destruct (mult_integral _ _ (eq_sym H0)); intuition | contradict H0; rewrite <- H0, mult_0_l; auto ]. Qed. @@ -2397,9 +2345,9 @@ Theorem divide_and_approx_valid : forall (k1 k2 : int) (body : term) (t : nat), valid1 (divide_and_approx k1 k2 body t). Proof. - unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1; + unfold valid1, divide_and_approx; intros k1 k2 body t ep e p1; Simplify; simpl; auto; subst; - elim (scalar_norm_add_stable t e); simpl in |- *. + elim (scalar_norm_add_stable t e); simpl. intro H2; apply mult_le_approx with (3 := H2); assumption. Qed. @@ -2421,9 +2369,9 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) := Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). Proof. - unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *; - auto; elim (scalar_norm_stable n e); simpl in |- *; - intros; symmetry in |- *; apply OMEGA8 with (2 := H0); + unfold valid2, merge_eq; intros n ep e p1 p2; Simplify; simpl; + auto; elim (scalar_norm_stable n e); simpl; + intros; symmetry ; apply OMEGA8 with (2 := H0); [ assumption | elim opp_eq_mult_neg_1; trivial ]. Qed. @@ -2440,8 +2388,8 @@ Definition constant_nul (i : nat) (h : hyps) := Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i). Proof. - unfold valid_hyps, constant_nul in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; simpl in |- *; + unfold valid_hyps, constant_nul; intros; + generalize (nth_valid ep e i lp); Simplify; simpl; intro H1; absurd (0 = 0); intuition. Qed. @@ -2453,7 +2401,7 @@ Definition state (m : int) (s : step) (prop1 prop2 : proposition) := match prop2 with | EqTerm b2 b3 => if beq Null 0 - then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term) + then EqTerm (Tint 0) (t_rewrite s (b1 + (- b3 + b2) * Tint m)%term) else TrueTerm | _ => TrueTerm end @@ -2462,8 +2410,8 @@ Definition state (m : int) (s : step) (prop1 prop2 : proposition) := Theorem state_valid : forall (m : int) (s : step), valid2 (state m s). Proof. - unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify; - simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; + unfold valid2; intros m s ep e p1 p2; unfold state; Simplify; + simpl; auto; elim (t_rewrite_stable s e); simpl; intros H1 H2; elim H1. now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. Qed. @@ -2490,18 +2438,18 @@ Theorem split_ineq_valid : valid_list_hyps f1 -> valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). Proof. - unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H; + unfold valid_list_hyps, split_ineq; intros i t f1 f2 H1 H2 ep e lp H; generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); - simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; - auto; intros z; simpl in |- *; auto; intro H3. + simpl; auto; intros t1 t2; case t1; simpl; + auto; intros z; simpl; auto; intro H3. Simplify. apply append_valid; elim (OMEGA19 (interp_term e t2)); - [ intro H4; left; apply H1; simpl in |- *; elim (add_norm_stable t); - simpl in |- *; auto - | intro H4; right; apply H2; simpl in |- *; elim (scalar_norm_add_stable t); - simpl in |- *; auto - | generalize H3; unfold not in |- *; intros E1 E2; apply E1; - symmetry in |- *; trivial ]. + [ intro H4; left; apply H1; simpl; elim (add_norm_stable t); + simpl; auto + | intro H4; right; apply H2; simpl; elim (scalar_norm_add_stable t); + simpl; auto + | generalize H3; unfold not; intros E1 E2; apply E1; + symmetry ; trivial ]. Qed. @@ -2532,49 +2480,49 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps := execute_omega cont (apply_oper_2 i1 i2 (state m s) l) end. -Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t). +Theorem omega_valid : forall tr : t_omega, valid_list_hyps (execute_omega tr). Proof. - simple induction t; simpl in |- *; - [ unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + simple induction tr; simpl; + [ unfold valid_list_hyps; simpl; intros; left; apply (constant_not_nul_valid n ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + | unfold valid_list_hyps; simpl; intros; left; apply (constant_neg_valid n ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; + | unfold valid_list_hyps, valid_hyps; intros k1 k2 body n t' Ht' m ep e lp H; apply Ht'; apply (apply_oper_1_valid m (divide_and_approx k1 k2 body n) (divide_and_approx_valid k1 k2 body n) ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; - apply (not_exact_divide_valid i i0 t0 n n0 ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; + | unfold valid_list_hyps; simpl; intros; left; + apply (not_exact_divide_valid _ _ _ _ _ ep e lp H) + | unfold valid_list_hyps, valid_hyps; intros k body n t' Ht' m ep e lp H; apply Ht'; apply (apply_oper_1_valid m (exact_divide k body n) (exact_divide_valid k body n) ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; + | unfold valid_list_hyps, valid_hyps; intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros; left; + | unfold valid_list_hyps; simpl; intros; left; apply (contradiction_valid n n0 n1 ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; + | unfold valid_list_hyps, valid_hyps; intros trace i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e lp H) - | intros t' i k1 H1 k2 H2; unfold valid_list_hyps in |- *; simpl in |- *; + | intros t' i k1 H1 k2 H2; unfold valid_list_hyps; simpl; intros ep e lp H; apply (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros i ep e lp H; left; + | unfold valid_list_hyps; simpl; intros i ep e lp H; left; apply (constant_nul_valid i ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros i j ep e lp H; left; + | unfold valid_list_hyps; simpl; intros i j ep e lp H; left; apply (negate_contradict_valid i j ep e lp H) - | unfold valid_list_hyps in |- *; simpl in |- *; intros n i j ep e lp H; + | unfold valid_list_hyps; simpl; intros n i j ep e lp H; left; apply (negate_contradict_inv_valid n i j ep e lp H) - | unfold valid_list_hyps, valid_hyps in |- *; + | unfold valid_list_hyps, valid_hyps; intros m s i1 i2 t' Ht' ep e lp H; apply Ht'; apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ]. Qed. @@ -2585,20 +2533,20 @@ Qed. Definition move_right (s : step) (p : proposition) := match p with - | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (t1 + - t2)%term) - | LeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + - t1)%term) - | GeqTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + - t2)%term) - | LtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t2 + Tint (-(1)) + - t1)%term) - | GtTerm t1 t2 => LeqTerm (Tint 0) (rewrite s (t1 + Tint (-(1)) + - t2)%term) - | NeqTerm t1 t2 => NeqTerm (Tint 0) (rewrite s (t1 + - t2)%term) + | EqTerm t1 t2 => EqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) + | LeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + - t1)%term) + | GeqTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) + | LtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t2 + Tint (-(1)) + - t1)%term) + | GtTerm t1 t2 => LeqTerm (Tint 0) (t_rewrite s (t1 + Tint (-(1)) + - t2)%term) + | NeqTerm t1 t2 => NeqTerm (Tint 0) (t_rewrite s (t1 + - t2)%term) | p => p end. Theorem move_right_valid : forall s : step, valid1 (move_right s). Proof. - unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *; - elim (rewrite_stable s e); simpl in |- *; - [ symmetry in |- *; apply egal_left; assumption + unfold valid1, move_right; intros s ep e p; Simplify; simpl; + elim (t_rewrite_stable s e); simpl; + [ symmetry ; apply egal_left; assumption | intro; apply le_left; assumption | intro; apply le_left; rewrite <- ge_le_iff; assumption | intro; apply lt_left; rewrite <- gt_lt_iff; assumption @@ -2611,7 +2559,7 @@ Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s). Theorem do_normalize_valid : forall (i : nat) (s : step), valid_hyps (do_normalize i s). Proof. - intros; unfold do_normalize in |- *; apply apply_oper_1_valid; + intros; unfold do_normalize; apply apply_oper_1_valid; apply move_right_valid. Qed. @@ -2625,7 +2573,7 @@ Fixpoint do_normalize_list (l : list step) (i : nat) Theorem do_normalize_list_valid : forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i). Proof. - simple induction l; simpl in |- *; unfold valid_hyps in |- *; + simple induction l; simpl; unfold valid_hyps; [ auto | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl'; apply (do_normalize_valid i a ep e lp); assumption ]. @@ -2641,10 +2589,10 @@ Qed. (* \subsubsection{Exécution de la trace} *) Theorem execute_goal : - forall (t : t_omega) (ep : list Prop) (env : list int) (l : hyps), - interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l. + forall (tr : t_omega) (ep : list Prop) (env : list int) (l : hyps), + interp_list_goal ep env (execute_omega tr l) -> interp_goal ep env l. Proof. - intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H). + intros; apply (goal_valid (execute_omega tr) (omega_valid tr) ep env l H). Qed. @@ -2654,8 +2602,8 @@ Theorem append_goal : interp_list_goal ep e (l1 ++ l2). Proof. intros ep e; simple induction l1; - [ simpl in |- *; intros l2 (H1, H2); assumption - | simpl in |- *; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. + [ simpl; intros l2 (H1, H2); assumption + | simpl; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ]. Qed. (* A simple decidability checker : if the proposition belongs to the @@ -2684,11 +2632,11 @@ Theorem decidable_correct : forall (ep : list Prop) (e : list int) (p : proposition), decidability p = true -> decidable (interp_proposition ep e p). Proof. - simple induction p; simpl in |- *; intros; + simple induction p; simpl; intros; [ apply dec_eq | apply dec_le | left; auto - | right; unfold not in |- *; auto + | right; unfold not; auto | apply dec_not; auto | apply dec_ge | apply dec_gt @@ -2724,7 +2672,7 @@ Theorem interp_full_false : forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition), (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c). Proof. - simple induction l; unfold interp_full in |- *; simpl in |- *; + simple induction l; unfold interp_full; simpl; [ auto | intros a l1 H1 c H2 H3; apply H1; auto ]. Qed. @@ -2744,12 +2692,12 @@ Theorem to_contradict_valid : forall (ep : list Prop) (e : list int) (lc : hyps * proposition), interp_goal ep e (to_contradict lc) -> interp_full ep e lc. Proof. - intros ep e lc; case lc; intros l c; simpl in |- *; - pattern (decidability c) in |- *; apply bool_eq_ind; - [ simpl in |- *; intros H H1; apply interp_full_false; intros H2; + intros ep e lc; case lc; intros l c; simpl; + pattern (decidability c); apply bool_eq_ind; + [ simpl; intros H H1; apply interp_full_false; intros H2; apply not_not; [ apply decidable_correct; assumption - | unfold not at 1 in |- *; intro H3; apply hyps_to_goal with (2 := H2); + | unfold not at 1; intro H3; apply hyps_to_goal with (2 := H2); auto ] | intros H1 H2; apply interp_full_false; intro H3; elim hyps_to_goal with (1 := H2); assumption ]. @@ -2813,7 +2761,7 @@ Theorem map_cons_val : interp_proposition ep e p -> interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l). Proof. - simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ]. + simple induction l; simpl; [ auto | intros; elim H1; intro H2; auto ]. Qed. Hint Resolve map_cons_val append_valid decidable_correct. @@ -2822,43 +2770,43 @@ Theorem destructure_hyps_valid : forall n : nat, valid_list_hyps (destructure_hyps n). Proof. simple induction n; - [ unfold valid_list_hyps in |- *; simpl in |- *; auto - | unfold valid_list_hyps at 2 in |- *; intros n1 H ep e lp; case lp; - [ simpl in |- *; auto + [ unfold valid_list_hyps; simpl; auto + | unfold valid_list_hyps at 2; intros n1 H ep e lp; case lp; + [ simpl; auto | intros p l; case p; try - (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; + (simpl; intros; apply map_cons_val; simpl; elim H0; auto); [ intro p'; case p'; try - (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; + (simpl; intros; apply map_cons_val; simpl; elim H0; auto); - [ simpl in |- *; intros p1 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; + [ simpl; intros p1 (H1, H2); + pattern (decidability p1); apply bool_eq_ind; intro H3; - [ apply H; simpl in |- *; split; + [ apply H; simpl; split; [ apply not_not; auto | assumption ] | auto ] - | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *; + | simpl; intros p1 p2 (H1, H2); apply H; simpl; elim not_or with (1 := H1); auto - | simpl in |- *; intros p1 p2 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; + | simpl; intros p1 p2 (H1, H2); + pattern (decidability p1); apply bool_eq_ind; intro H3; [ apply append_valid; elim not_and with (2 := H1); - [ intro; left; apply H; simpl in |- *; auto - | intro; right; apply H; simpl in |- *; auto + [ intro; left; apply H; simpl; auto + | intro; right; apply H; simpl; auto | auto ] | auto ] ] - | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid; - (elim H1; intro H3; simpl in |- *; [ left | right ]); - apply H; simpl in |- *; auto - | simpl in |- *; intros; apply H; simpl in |- *; tauto - | simpl in |- *; intros p1 p2 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; + | simpl; intros p1 p2 (H1, H2); apply append_valid; + (elim H1; intro H3; simpl; [ left | right ]); + apply H; simpl; auto + | simpl; intros; apply H; simpl; tauto + | simpl; intros p1 p2 (H1, H2); + pattern (decidability p1); apply bool_eq_ind; intro H3; [ apply append_valid; elim imp_simp with (2 := H1); - [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto - | intro H4; right; simpl in |- *; apply H; simpl in |- *; auto + [ intro H4; left; simpl; apply H; simpl; auto + | intro H4; right; simpl; apply H; simpl; auto | auto ] | auto ] ] ] ]. Qed. @@ -2881,8 +2829,8 @@ Theorem p_apply_left_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_apply_left f). Proof. - unfold prop_stable in |- *; intros f H ep e p; split; - (case p; simpl in |- *; auto; intros p1; elim (H ep e p1); tauto). + unfold prop_stable; intros f H ep e p; split; + (case p; simpl; auto; intros p1; elim (H ep e p1); tauto). Qed. Definition p_apply_right (f : proposition -> proposition) @@ -2899,8 +2847,8 @@ Theorem p_apply_right_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_apply_right f). Proof. - unfold prop_stable in |- *; intros f H ep e p; split; - (case p; simpl in |- *; auto; + unfold prop_stable; intros f H ep e p; split; + (case p; simpl; auto; [ intros p1; elim (H ep e p1); tauto | intros p1 p2; elim (H ep e p2); tauto | intros p1 p2; elim (H ep e p2); tauto @@ -2923,53 +2871,53 @@ Theorem p_invert_stable : forall f : proposition -> proposition, prop_stable f -> prop_stable (p_invert f). Proof. - unfold prop_stable in |- *; intros f H ep e p; split; - (case p; simpl in |- *; auto; - [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *; + unfold prop_stable; intros f H ep e p; split; + (case p; simpl; auto; + [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl; generalize (dec_eq (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; tauto - | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl in |- *; + unfold decidable; tauto + | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl; generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; rewrite le_lt_iff, <- gt_lt_iff; tauto - | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *; + unfold decidable; rewrite le_lt_iff, <- gt_lt_iff; tauto + | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl; generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; rewrite ge_le_iff, le_lt_iff; tauto - | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl in |- *; + unfold decidable; rewrite ge_le_iff, le_lt_iff; tauto + | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl; generalize (dec_gt (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; repeat rewrite le_lt_iff; + unfold decidable; repeat rewrite le_lt_iff; repeat rewrite gt_lt_iff; tauto - | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl in |- *; + | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl; generalize (dec_lt (interp_term e t1) (interp_term e t2)); - unfold decidable in |- *; repeat rewrite ge_le_iff; + unfold decidable; repeat rewrite ge_le_iff; repeat rewrite le_lt_iff; tauto - | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl in |- *; + | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl; generalize (dec_eq (interp_term e t1) (interp_term e t2)); unfold decidable; tauto ]). Qed. Theorem move_right_stable : forall s : step, prop_stable (move_right s). Proof. - unfold move_right, prop_stable in |- *; intros s ep e p; split; - [ Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *; - [ symmetry in |- *; apply egal_left; assumption + unfold move_right, prop_stable; intros s ep e p; split; + [ Simplify; simpl; elim (t_rewrite_stable s e); simpl; + [ symmetry ; apply egal_left; assumption | intro; apply le_left; assumption | intro; apply le_left; rewrite <- ge_le_iff; assumption | intro; apply lt_left; rewrite <- gt_lt_iff; assumption | intro; apply lt_left; assumption | intro; apply ne_left_2; assumption ] - | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s); - simpl in |- *; intro H1; - [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1; + | case p; simpl; intros; auto; generalize H; elim (t_rewrite_stable s); + simpl; intro H1; + [ rewrite (plus_0_r_reverse (interp_term e t1)); rewrite H1; rewrite plus_permute; rewrite plus_opp_r; rewrite plus_0_r; trivial - | apply (fun a b => plus_le_reg_r a b (- interp_term e t)); + | apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); rewrite plus_opp_r; assumption | rewrite ge_le_iff; - apply (fun a b => plus_le_reg_r a b (- interp_term e t0)); + apply (fun a b => plus_le_reg_r a b (- interp_term e t1)); rewrite plus_opp_r; assumption | rewrite gt_lt_iff; apply lt_left_inv; assumption | apply lt_left_inv; assumption - | unfold not in |- *; intro H2; apply H1; + | unfold not; intro H2; apply H1; rewrite H2; rewrite plus_opp_r; trivial ] ]. Qed. @@ -2985,12 +2933,12 @@ Fixpoint p_rewrite (s : p_step) : proposition -> proposition := Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s). Proof. - simple induction s; simpl in |- *; + simple induction s; simpl; [ intros; apply p_apply_left_stable; trivial | intros; apply p_apply_right_stable; trivial | intros; apply p_invert_stable; apply move_right_stable | apply move_right_stable - | unfold prop_stable in |- *; simpl in |- *; intros; split; auto ]. + | unfold prop_stable; simpl; intros; split; auto ]. Qed. Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := @@ -3002,11 +2950,11 @@ Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps := Theorem normalize_hyps_valid : forall l : list h_step, valid_hyps (normalize_hyps l). Proof. - simple induction l; unfold valid_hyps in |- *; simpl in |- *; + simple induction l; unfold valid_hyps; simpl; [ auto | intros n_s r; case n_s; intros n s H ep e lp H1; apply H; apply apply_oper_1_valid; - [ unfold valid1 in |- *; intros ep1 e1 p1 H2; + [ unfold valid1; intros ep1 e1 p1 H2; elim (p_rewrite_stable s ep1 e1 p1); auto | assumption ] ]. Qed. @@ -3073,21 +3021,21 @@ Theorem extract_valid : forall s : list direction, valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s). Proof. - unfold valid1, co_valid1 in |- *; simple induction s; + unfold valid1, co_valid1; simple induction s; [ split; - [ simpl in |- *; auto - | intros ep e p1; case p1; simpl in |- *; auto; intro p; - pattern (decidability p) in |- *; apply bool_eq_ind; + [ simpl; auto + | intros ep e p1; case p1; simpl; auto; intro p; + pattern (decidability p); apply bool_eq_ind; [ intro H; generalize (decidable_correct ep e p H); - unfold decidable in |- *; tauto - | simpl in |- *; auto ] ] + unfold decidable; tauto + | simpl; auto ] ] | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto; - case p; auto; simpl in |- *; intros; + case p; auto; simpl; intros; (apply H1; tauto) || (apply H2; tauto) || - (pattern (decidability p0) in |- *; apply bool_eq_ind; + (pattern (decidability p0); apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e p0 H3); - unfold decidable in |- *; intro H4; apply H1; + unfold decidable; intro H4; apply H1; tauto | intro; tauto ]) ]. Qed. @@ -3117,29 +3065,29 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := Theorem decompose_solve_valid : forall s : e_step, valid_list_goal (decompose_solve s). Proof. - intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s; - simpl in |- *; intros; + intro s; apply goal_valid; unfold valid_list_hyps; elim s; + simpl; intros; [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp))); - [ case (extract_hyp_pos l (nth_hyps n lp)); simpl in |- *; auto; - [ intro p; case p; simpl in |- *; auto; intros p1 p2 H2; - pattern (decidability p1) in |- *; apply bool_eq_ind; + [ case (extract_hyp_pos l (nth_hyps n lp)); simpl; auto; + [ intro p; case p; simpl; auto; intros p1 p2 H2; + pattern (decidability p1); apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; apply append_valid; elim H4; intro H5; - [ right; apply H0; simpl in |- *; tauto - | left; apply H; simpl in |- *; tauto ] - | simpl in |- *; auto ] - | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2; - [ intros H3; left; apply H; simpl in |- *; auto - | intros H3; right; apply H0; simpl in |- *; auto ] + [ right; apply H0; simpl; tauto + | left; apply H; simpl; tauto ] + | simpl; auto ] + | intros p1 p2 H2; apply append_valid; simpl; elim H2; + [ intros H3; left; apply H; simpl; auto + | intros H3; right; apply H0; simpl; auto ] | intros p1 p2 H2; - pattern (decidability p1) in |- *; apply bool_eq_ind; + pattern (decidability p1); apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; apply append_valid; elim H4; intro H5; - [ right; apply H0; simpl in |- *; tauto - | left; apply H; simpl in |- *; tauto ] - | simpl in |- *; auto ] ] + [ right; apply H0; simpl; tauto + | left; apply H; simpl; tauto ] + | simpl; auto ] ] | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ] - | intros; apply H; simpl in |- *; split; + | intros; apply H; simpl; split; [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto | auto ] | apply omega_valid with (1 := H) ]. @@ -3160,11 +3108,11 @@ Fixpoint reduce_lhyps (lp : lhyps) : lhyps := Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps. Proof. - unfold valid_lhyps in |- *; intros ep e lp; elim lp; - [ simpl in |- *; auto + unfold valid_lhyps; intros ep e lp; elim lp; + [ simpl; auto | intros a l HR; elim a; - [ simpl in |- *; tauto - | intros a1 l1; case l1; case a1; simpl in |- *; try tauto ] ]. + [ simpl; tauto + | intros a1 l1; case l1; case a1; simpl; try tauto ] ]. Qed. Theorem do_reduce_lhyps : @@ -3184,13 +3132,13 @@ Definition do_concl_to_hyp : interp_goal envp env (concl_to_hyp c :: l) -> interp_goal_concl c envp env l. Proof. - simpl in |- *; intros envp env c l; induction l as [| a l Hrecl]; - [ simpl in |- *; unfold concl_to_hyp in |- *; - pattern (decidability c) in |- *; apply bool_eq_ind; + simpl; intros envp env c l; induction l as [| a l Hrecl]; + [ simpl; unfold concl_to_hyp; + pattern (decidability c); apply bool_eq_ind; [ intro H; generalize (decidable_correct envp env c H); - unfold decidable in |- *; simpl in |- *; tauto - | simpl in |- *; intros H1 H2; elim H2; trivial ] - | simpl in |- *; tauto ]. + unfold decidable; simpl; tauto + | simpl; intros H1 H2; elim H2; trivial ] + | simpl; tauto ]. Qed. Definition omega_tactic (t1 : e_step) (t2 : list h_step) @@ -3203,7 +3151,7 @@ Theorem do_omega : interp_list_goal envp env (omega_tactic t1 t2 c l) -> interp_goal_concl c envp env l. Proof. - unfold omega_tactic in |- *; intros; apply do_concl_to_hyp; + unfold omega_tactic; intros; apply do_concl_to_hyp; apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1); apply do_reduce_lhyps; assumption. Qed. diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index f4368a1b..fb45e816 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -15,21 +15,27 @@ type result = | Kimp of Term.constr * Term.constr | Kufo;; +let meaningful_submodule = [ "Z"; "N"; "Pos" ] + +let string_of_global r = + let dp = Nametab.dirpath_of_global r in + let prefix = match Names.repr_dirpath dp with + | [] -> "" + | m::_ -> + let s = Names.string_of_id m in + if List.mem s meaningful_submodule then s^"." else "" + in + prefix^(Names.string_of_id (Nametab.basename_of_global r)) + let destructurate t = let c, args = Term.decompose_app t in match Term.kind_of_term c, args with | Term.Const sp, args -> - Kapp (Names.string_of_id - (Nametab.basename_of_global (Libnames.ConstRef sp)), - args) + Kapp (string_of_global (Libnames.ConstRef sp), args) | Term.Construct csp , args -> - Kapp (Names.string_of_id - (Nametab.basename_of_global (Libnames.ConstructRef csp)), - args) + Kapp (string_of_global (Libnames.ConstructRef csp), args) | Term.Ind isp, args -> - Kapp (Names.string_of_id - (Nametab.basename_of_global (Libnames.IndRef isp)), - args) + Kapp (string_of_global (Libnames.IndRef isp), args) | Term.Var id,[] -> Kvar(Names.string_of_id id) | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) | Term.Prod (Names.Name _,_,_),[] -> @@ -56,9 +62,13 @@ let coq_modules = @ [module_refl_path] @ [module_refl_path@["ZOmega"]] +let bin_module = [["Coq";"Numbers";"BinNums"]] +let z_module = [["Coq";"ZArith";"BinInt"]] let init_constant = Coqlib.gen_constant_in_modules "Omega" Coqlib.init_modules let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules +let z_constant = Coqlib.gen_constant_in_modules "Omega" z_module +let bin_constant = Coqlib.gen_constant_in_modules "Omega" bin_module (* Logic *) let coq_eq = lazy(init_constant "eq") @@ -168,21 +178,21 @@ let coq_do_omega = lazy (constant "do_omega") (* \subsection{Construction d'expressions} *) let do_left t = - if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop + if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) let do_right t = - if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop + if Term.eq_constr t (Lazy.force coq_c_nop) then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) let do_both t1 t2 = - if t1 = Lazy.force coq_c_nop then do_right t2 - else if t2 = Lazy.force coq_c_nop then do_left t1 + if Term.eq_constr t1 (Lazy.force coq_c_nop) then do_right t2 + else if Term.eq_constr t2 (Lazy.force coq_c_nop) then do_left t1 else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) let do_seq t1 t2 = - if t1 = Lazy.force coq_c_nop then t2 - else if t2 = Lazy.force coq_c_nop then t1 + if Term.eq_constr t1 (Lazy.force coq_c_nop) then t2 + else if Term.eq_constr t2 (Lazy.force coq_c_nop) then t1 else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) let rec do_list = function @@ -271,18 +281,18 @@ end module Z : Int = struct -let typ = lazy (constant "Z") -let plus = lazy (constant "Zplus") -let mult = lazy (constant "Zmult") -let opp = lazy (constant "Zopp") -let minus = lazy (constant "Zminus") +let typ = lazy (bin_constant "Z") +let plus = lazy (z_constant "Z.add") +let mult = lazy (z_constant "Z.mul") +let opp = lazy (z_constant "Z.opp") +let minus = lazy (z_constant "Z.sub") -let coq_xH = lazy (constant "xH") -let coq_xO = lazy (constant "xO") -let coq_xI = lazy (constant "xI") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") +let coq_xH = lazy (bin_constant "xH") +let coq_xO = lazy (bin_constant "xO") +let coq_xI = lazy (bin_constant "xI") +let coq_Z0 = lazy (bin_constant "Z0") +let coq_Zpos = lazy (bin_constant "Zpos") +let coq_Zneg = lazy (bin_constant "Zneg") let recognize t = let rec loop t = @@ -318,14 +328,14 @@ let mk = mk_Z let parse_term t = try match destructurate t with - | Kapp("Zplus",[t1;t2]) -> Tplus (t1,t2) - | Kapp("Zminus",[t1;t2]) -> Tminus (t1,t2) - | Kapp("Zmult",[t1;t2]) -> Tmult (t1,t2) - | Kapp("Zopp",[t]) -> Topp t - | Kapp("Zsucc",[t]) -> Tsucc t - | Kapp("Zpred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) + | Kapp("Z.add",[t1;t2]) -> Tplus (t1,t2) + | Kapp("Z.sub",[t1;t2]) -> Tminus (t1,t2) + | Kapp("Z.mul",[t1;t2]) -> Tmult (t1,t2) + | Kapp("Z.opp",[t]) -> Topp t + | Kapp("Z.succ",[t]) -> Tsucc t + | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - (try Tnum (recognize t) with _ -> Tother) + (try Tnum (recognize t) with e when Errors.noncritical e -> Tother) | _ -> Tother with e when Logic.catchable_exception e -> Tother @@ -334,19 +344,19 @@ let parse_rel gl t = | Kapp("eq",[typ;t1;t2]) when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2) | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) - | Kapp("Zle",[t1;t2]) -> Rle (t1,t2) - | Kapp("Zlt",[t1;t2]) -> Rlt (t1,t2) - | Kapp("Zge",[t1;t2]) -> Rge (t1,t2) - | Kapp("Zgt",[t1;t2]) -> Rgt (t1,t2) + | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) + | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) + | Kapp("Z.ge",[t1;t2]) -> Rge (t1,t2) + | Kapp("Z.gt",[t1;t2]) -> Rgt (t1,t2) | _ -> parse_logic_rel t with e when Logic.catchable_exception e -> Rother let is_scalar t = let rec aux t = match destructurate t with - | Kapp(("Zplus"|"Zminus"|"Zmult"),[t1;t2]) -> aux t1 & aux t2 - | Kapp(("Zopp"|"Zsucc"|"Zpred"),[t]) -> aux t + | Kapp(("Z.add"|"Z.sub"|"Z.mul"),[t1;t2]) -> aux t1 & aux t2 + | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true | _ -> false in - try aux t with _ -> false + try aux t with e when Errors.noncritical e -> false end diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 570bb187..e57230cb 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -219,23 +219,26 @@ let unintern_omega env id = calcul des variables utiles. *) let add_reified_atom t env = - try list_index0 t env.terms + try list_index0_f Term.eq_constr t env.terms with Not_found -> let i = List.length env.terms in env.terms <- env.terms @ [t]; i let get_reified_atom env = - try List.nth env.terms with _ -> failwith "get_reified_atom" + try List.nth env.terms + with e when Errors.noncritical e -> failwith "get_reified_atom" (* \subsection{Gestion de l'environnement de proposition pour Omega} *) (* ajout d'une proposition *) let add_prop env t = - try list_index0 t env.props + try list_index0_f Term.eq_constr t env.props with Not_found -> let i = List.length env.props in env.props <- env.props @ [t]; i (* accès a une proposition *) -let get_prop v env = try List.nth v env with _ -> failwith "get_prop" +let get_prop v env = + try List.nth v env + with e when Errors.noncritical e -> failwith "get_prop" (* \subsection{Gestion du nommage des équations} *) (* Ajout d'une equation dans l'environnement de reification *) @@ -247,7 +250,8 @@ let add_equation env e = (* accès a une equation *) let get_equation env id = try Hashtbl.find env.equations id - with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e + with Not_found as e -> + Printf.printf "Omega Equation %d non trouvée\n" id; raise e (* Affichage des termes réifiés *) let rec oprint ch = function @@ -349,7 +353,8 @@ let rec reified_of_formula env = function app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |] let reified_of_formula env f = - begin try reified_of_formula env f with e -> oprint stderr f; raise e end + try reified_of_formula env f + with reraise -> oprint stderr f; raise reraise let rec reified_of_proposition env = function Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> @@ -380,8 +385,8 @@ let rec reified_of_proposition env = function | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] let reified_of_proposition env f = - begin try reified_of_proposition env f - with e -> pprint stderr f; raise e end + try reified_of_proposition env f + with reraise -> pprint stderr f; raise reraise (* \subsection{Omega vers COQ réifié} *) @@ -397,11 +402,11 @@ let reified_of_omega env body constant = List.fold_right mk_coeff body coeff_constant let reified_of_omega env body c = - begin try + try reified_of_omega env body c - with e -> - display_eq display_omega_var (body,c); raise e - end + with reraise -> + display_eq display_omega_var (body,c); raise reraise + (* \section{Opérations sur les équations} Ces fonctions préparent les traces utilisées par la tactique réfléchie @@ -1000,10 +1005,11 @@ let rec solve_with_constraints all_solutions path = let weighted = filter_compatible_systems path all_solutions in let (winner_sol,winner_deps) = try select_smaller weighted - with e -> + with reraise -> Printf.printf "%d - %d\n" (List.length weighted) (List.length all_solutions); - List.iter display_depend path; raise e in + List.iter display_depend path; raise reraise + in build_tree winner_sol (List.rev path) winner_deps let find_path {o_hyp=id;o_path=p} env = diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 39c29a3d..98dd257d 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -1,154 +1,32 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Bintree.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export List. Require Export BinPos. - -Unset Boxed Definitions. +Require Arith.EqNat. Open Scope positive_scope. Ltac clean := try (simpl; congruence). -Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t. - -Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop. - -Lemma Gt_Eq_Gt : forall p q cmp, - (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt. -apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt)); -simpl;auto;congruence. -Qed. - -Lemma Gt_Lt_Gt : forall p q cmp, - (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt. -apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt)); -simpl;auto;congruence. -Qed. - -Lemma Gt_Psucc_Eq: forall p q, - (p ?= Psucc q) Gt = Gt -> (p ?= q) Eq = Gt. -intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence. -intro;apply Gt_Eq_Gt;auto. -apply Gt_Lt_Gt. -Qed. - -Lemma Eq_Psucc_Gt: forall p q, - (p ?= Psucc q) Eq = Eq -> (p ?= q) Eq = Gt. -intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence. -intro H;elim (Pcompare_not_Eq p (Psucc q));tauto. -intro H;apply Gt_Eq_Gt;auto. -intro H;rewrite Pcompare_Eq_eq with p q;auto. -generalize q;clear q IHq p H;induction q;simpl;auto. -intro H;elim (Pcompare_not_Eq p q);tauto. -Qed. - -Lemma Gt_Psucc_Gt : forall n p cmp cmp0, - (n?=p) cmp = Gt -> (Psucc n?=p) cmp0 = Gt. -induction n;intros [ | p | p];simpl;try congruence. -intros; apply IHn with cmp;trivial. -intros; apply IHn with Gt;trivial. -intros;apply Gt_Lt_Gt;trivial. -intros [ | | ] _ H. -apply Gt_Eq_Gt;trivial. -apply Gt_Lt_Gt;trivial. -trivial. -Qed. Lemma Gt_Psucc: forall p q, - (p ?= Psucc q) Eq = Gt -> (p ?= q) Eq = Gt. -intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence. -apply Gt_Psucc_Eq. -intro;apply Gt_Eq_Gt;apply IHq;auto. -apply Gt_Eq_Gt. -apply Gt_Lt_Gt. + (p ?= Pos.succ q) = Gt -> (p ?= q) = Gt. +Proof. +intros. rewrite <- Pos.compare_succ_succ. +now apply Pos.lt_gt, Pos.lt_lt_succ, Pos.gt_lt. Qed. Lemma Psucc_Gt : forall p, - (Psucc p ?= p) Eq = Gt. -induction p;simpl. -apply Gt_Eq_Gt;auto. -generalize p;clear p IHp. -induction p;simpl;auto. -reflexivity. + (Pos.succ p ?= p) = Gt. +Proof. +intros. apply Pos.lt_gt, Pos.lt_succ_diag_r. Qed. -Fixpoint pos_eq (m n:positive) {struct m} :bool := -match m, n with - xI mm, xI nn => pos_eq mm nn -| xO mm, xO nn => pos_eq mm nn -| xH, xH => true -| _, _ => false -end. - -Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. -induction m;simpl;intro n;destruct n;congruence || -(intro e;apply f_equal with positive;auto). -Defined. - -Theorem refl_pos_eq : forall m, pos_eq m m = true. -induction m;simpl;auto. -Qed. - -Definition pos_eq_dec : forall (m n:positive), {m=n}+{m<>n} . -fix 1;intros [mm|mm|] [nn|nn|];try (right;congruence). -case (pos_eq_dec mm nn). -intro e;left;apply (f_equal xI e). -intro ne;right;congruence. -case (pos_eq_dec mm nn). -intro e;left;apply (f_equal xO e). -intro ne;right;congruence. -left;reflexivity. -Defined. - -Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left _ (refl_equal m). -fix 1;intros [mm|mm|]. -simpl; rewrite pos_eq_dec_refl; reflexivity. -simpl; rewrite pos_eq_dec_refl; reflexivity. -reflexivity. -Qed. - -Theorem pos_eq_dec_ex : forall m n, - pos_eq m n =true -> exists h:m=n, - pos_eq_dec m n = left _ h. -fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence). -simpl;intro e. -elim (pos_eq_dec_ex _ _ e). -intros x ex; rewrite ex. -exists (f_equal xI x). -reflexivity. -simpl;intro e. -elim (pos_eq_dec_ex _ _ e). -intros x ex; rewrite ex. -exists (f_equal xO x). -reflexivity. -simpl. -exists (refl_equal xH). -reflexivity. -Qed. - -Fixpoint nat_eq (m n:nat) {struct m}: bool:= -match m, n with -O,O => true -| S mm,S nn => nat_eq mm nn -| _,_ => false -end. - -Theorem nat_eq_refl : forall m n, nat_eq m n = true -> m = n. -induction m;simpl;intro n;destruct n;congruence || -(intro e;apply f_equal with nat;auto). -Defined. - -Theorem refl_nat_eq : forall n, nat_eq n n = true. -induction n;simpl;trivial. -Defined. - Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A := match l with nil => None | x::q => @@ -156,21 +34,21 @@ match n with O => Some x | S m => Lget A m q end end . -Implicit Arguments Lget [A]. +Arguments Lget [A] n l. Lemma map_app : forall (A B:Set) (f:A -> B) l m, List.map f (l ++ m) = List.map f l ++ List.map f m. induction l. reflexivity. simpl. -intro m ; apply f_equal with (list B);apply IHl. +intro m ; apply f_equal;apply IHl. Qed. Lemma length_map : forall (A B:Set) (f:A -> B) l, length (List.map f l) = length l. induction l. reflexivity. -simpl; apply f_equal with nat;apply IHl. +simpl; apply f_equal;apply IHl. Qed. Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, @@ -182,7 +60,8 @@ simpl;auto. Qed. Lemma Lget_app : forall (A:Set) (a:A) l i, -Lget i (l ++ a :: nil) = if nat_eq i (length l) then Some a else Lget i l. +Lget i (l ++ a :: nil) = if Arith.EqNat.beq_nat i (length l) then Some a else Lget i l. +Proof. induction l;simpl Lget;simpl length. intros [ | i];simpl;reflexivity. intros [ | i];simpl. @@ -278,17 +157,20 @@ Qed. Theorem Tget_Tadd: forall i j a T, Tget i (Tadd j a T) = - match (i ?= j) Eq with + match (i ?= j) with Eq => PSome a | Lt => Tget i T | Gt => Tget i T end. +Proof. intros i j. -caseq ((i ?= j) Eq). -intro H;rewrite (Pcompare_Eq_eq _ _ H);intros a;clear i H. +case_eq (i ?= j). +intro H;rewrite (Pos.compare_eq _ _ H);intros a;clear i H. induction j;destruct T;simpl;try (apply IHj);congruence. +unfold Pos.compare. generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. +unfold Pos.compare. generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. Qed. @@ -299,7 +181,7 @@ mkStore {index:positive;contents:Tree}. Definition empty := mkStore xH Tempty. Definition push a S := -mkStore (Psucc (index S)) (Tadd (index S) a (contents S)). +mkStore (Pos.succ (index S)) (Tadd (index S) a (contents S)). Definition get i S := Tget i (contents S). @@ -312,7 +194,8 @@ Inductive Full : Store -> Type:= | F_push : forall a S, Full S -> Full (push a S). Theorem get_Full_Gt : forall S, Full S -> - forall i, (i ?= index S) Eq = Gt -> get i S = PNone. + forall i, (i ?= index S) = Gt -> get i S = PNone. +Proof. intros S W;induction W. unfold empty,index,get,contents;intros;apply Tget_Tempty. unfold index,get,push;simpl contents. @@ -331,7 +214,7 @@ intros a S. rewrite Tget_Tadd. rewrite Psucc_Gt. intro W. -change (get (Psucc (index S)) S =PNone). +change (get (Pos.succ (index S)) S =PNone). apply get_Full_Gt; auto. apply Psucc_Gt. Qed. @@ -339,16 +222,17 @@ Qed. Theorem get_push_Full : forall i a S, Full S -> get i (push a S) = - match (i ?= index S) Eq with + match (i ?= index S) with Eq => PSome a | Lt => get i S | Gt => PNone end. +Proof. intros i a S F. -caseq ((i ?= index S) Eq). -intro e;rewrite (Pcompare_Eq_eq _ _ e). +case_eq (i ?= index S). +intro e;rewrite (Pos.compare_eq _ _ e). destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. -rewrite Pcompare_refl;reflexivity. +rewrite Pos.compare_refl;reflexivity. intros;destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd. simpl index in H;rewrite H;reflexivity. intro H;generalize H;clear H. @@ -361,9 +245,10 @@ Qed. Lemma Full_push_compat : forall i a S, Full S -> forall x, get i S = PSome x -> get i (push a S) = PSome x. +Proof. intros i a S F x H. -caseq ((i ?= index S) Eq);intro test. -rewrite (Pcompare_Eq_eq _ _ test) in H. +case_eq (i ?= index S);intro test. +rewrite (Pos.compare_eq _ _ test) in H. rewrite (get_Full_Eq _ F) in H;congruence. rewrite <- H. rewrite (get_push_Full i a). @@ -375,13 +260,13 @@ Qed. Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. intros [ind cont] F one; inversion F. reflexivity. -simpl index in one;assert (h:=Psucc_not_one (index S)). +simpl index in one;assert (h:=Pos.succ_not_1 (index S)). congruence. Qed. Lemma push_not_empty: forall a S, (push a S) <> empty. intros a [ind cont];unfold push,empty. -simpl;intro H;injection H; intros _ ; apply Psucc_not_one. +simpl;intro H;injection H; intros _ ; apply Pos.succ_not_1. Qed. Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop := @@ -395,7 +280,7 @@ get i S = PSome x -> In x S F. induction F. intro i;rewrite get_empty; congruence. intro i;rewrite get_push_Full;trivial. -caseq ((i ?= index S) Eq);simpl. +case_eq (i ?= index S);simpl. left;congruence. right;eauto. congruence. @@ -403,34 +288,34 @@ Qed. End Store. -Implicit Arguments PNone [A]. -Implicit Arguments PSome [A]. +Arguments PNone [A]. +Arguments PSome [A] _. -Implicit Arguments Tempty [A]. -Implicit Arguments Branch0 [A]. -Implicit Arguments Branch1 [A]. +Arguments Tempty [A]. +Arguments Branch0 [A] _ _. +Arguments Branch1 [A] _ _ _. -Implicit Arguments Tget [A]. -Implicit Arguments Tadd [A]. +Arguments Tget [A] p T. +Arguments Tadd [A] p a T. -Implicit Arguments Tget_Tempty [A]. -Implicit Arguments Tget_Tadd [A]. +Arguments Tget_Tempty [A] p. +Arguments Tget_Tadd [A] i j a T. -Implicit Arguments mkStore [A]. -Implicit Arguments index [A]. -Implicit Arguments contents [A]. +Arguments mkStore [A] index contents. +Arguments index [A] s. +Arguments contents [A] s. -Implicit Arguments empty [A]. -Implicit Arguments get [A]. -Implicit Arguments push [A]. +Arguments empty [A]. +Arguments get [A] i S. +Arguments push [A] a S. -Implicit Arguments get_empty [A]. -Implicit Arguments get_push_Full [A]. +Arguments get_empty [A] i. +Arguments get_push_Full [A] i a S _. -Implicit Arguments Full [A]. -Implicit Arguments F_empty [A]. -Implicit Arguments F_push [A]. -Implicit Arguments In [A]. +Arguments Full [A] _. +Arguments F_empty [A]. +Arguments F_push [A] a S _. +Arguments In [A] x S F. Section Map. @@ -482,8 +367,8 @@ Defined. End Map. -Implicit Arguments Tmap [A B]. -Implicit Arguments map [A B]. -Implicit Arguments Full_map [A B f]. +Arguments Tmap [A B] f T. +Arguments map [A B] f S. +Arguments Full_map [A B f] S _. Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v index 3817f98c..3b596238 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -1,22 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: Rtauto.v 14641 2011-11-06 11:59:10Z herbelin $ *) - Require Export List. Require Export Bintree. Require Import Bool. -Unset Boxed Definitions. Declare ML Module "rtauto_plugin". -Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t. Ltac clean:=try (simpl;congruence). Inductive form:Set:= @@ -43,7 +39,7 @@ end. Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. induction m;simpl;destruct n;congruence || -(intro e;apply f_equal with positive;auto). +(intro e;apply f_equal;auto). Qed. Fixpoint form_eq (p q:form) {struct p} :bool := @@ -69,15 +65,15 @@ end. Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q. induction p;destruct q;simpl;clean. intro h;generalize (pos_eq_refl _ _ h);congruence. -caseq (form_eq p1 q1);clean. +case_eq (form_eq p1 q1);clean. intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -caseq (form_eq p1 q1);clean. +case_eq (form_eq p1 q1);clean. intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. -caseq (form_eq p1 q1);clean. +case_eq (form_eq p1 q1);clean. intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. Qed. -Implicit Arguments form_eq_refl [p q]. +Arguments form_eq_refl [p q] _. Section with_env. @@ -165,7 +161,7 @@ intros hyps F p g e; apply project_In. apply get_In with p;assumption. Qed. -Implicit Arguments project [hyps p g]. +Arguments project [hyps] F [p g] _. Inductive proof:Set := Ax : positive -> proof @@ -263,7 +259,7 @@ induction p;intros hyps F gl. (* cas Axiom *) Focus 1. -simpl;caseq (get p hyps);clean. +simpl;case_eq (get p hyps);clean. intros f nth_f e;rewrite <- (form_eq_refl e). apply project with p;trivial. @@ -276,10 +272,10 @@ apply IHp;try constructor;trivial. (* Cas Arrow_Elim *) Focus 1. -simpl check_proof;caseq (get p hyps);clean. -intros f ef;caseq (get p0 hyps);clean. +simpl check_proof;case_eq (get p hyps);clean. +intros f ef;case_eq (get p0 hyps);clean. intros f0 ef0;destruct f0;clean. -caseq (form_eq f f0_1);clean. +case_eq (form_eq f f0_1);clean. simpl;intros e check_p1. generalize (project F ef) (project F ef0) (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1); @@ -291,10 +287,10 @@ auto. (* cas Arrow_Destruct *) Focus 1. -simpl;caseq (get p1 hyps);clean. +simpl;case_eq (get p1 hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. -caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean. +case_eq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean. intros check_p1 check_p2. generalize (project F ef) (IHp1 (hyps \ f1_2 =>> f2 \ f1_1) @@ -305,7 +301,7 @@ simpl;apply compose3;auto. (* Cas False_Elim *) Focus 1. -simpl;caseq (get p hyps);clean. +simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. intros _; generalize (project F ef). apply compose1;apply False_ind. @@ -313,13 +309,13 @@ apply compose1;apply False_ind. (* Cas And_Intro *) Focus 1. simpl;destruct gl;clean. -caseq (check_proof hyps gl1 p1);clean. +case_eq (check_proof hyps gl1 p1);clean. intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2). apply compose2 ;simpl;auto. (* cas And_Elim *) Focus 1. -simpl;caseq (get p hyps);clean. +simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. intro check_p;generalize (project F ef) (IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p). @@ -327,7 +323,7 @@ simpl;apply compose2;intros [h1 h2];auto. (* cas And_Destruct *) Focus 1. -simpl;caseq (get p hyps);clean. +simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. intro H;generalize (project F ef) @@ -349,9 +345,9 @@ apply compose1;simpl;auto. (* cas Or_elim *) Focus 1. -simpl;caseq (get p1 hyps);clean. +simpl;case_eq (get p1 hyps);clean. intros f ef;destruct f;clean. -caseq (check_proof (hyps \ f1) gl p2);clean. +case_eq (check_proof (hyps \ f1) gl p2);clean. intros check_p1 check_p2;generalize (project F ef) (IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1) (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2); @@ -359,7 +355,7 @@ simpl;apply compose3;simpl;intro h;destruct h;auto. (* cas Or_Destruct *) Focus 1. -simpl;caseq (get p hyps);clean. +simpl;case_eq (get p hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. intro check_p0;generalize (project F ef) @@ -370,7 +366,7 @@ apply compose2;auto. (* cas Cut *) Focus 1. -simpl;caseq (check_proof hyps f p1);clean. +simpl;case_eq (check_proof hyps f p1);clean. intros check_p1 check_p2; generalize (IHp1 hyps F f check_p1) (IHp2 (hyps\f) (F_push f hyps F) gl check_p2); @@ -378,7 +374,7 @@ simpl; apply compose2;auto. Qed. Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True. -intros gl prf;caseq (check_proof empty gl prf);intro check_prf. +intros gl prf;case_eq (check_proof empty gl prf);intro check_prf. change (interp_ctx empty F_empty [[gl]]) ; apply interp_proof with prf;assumption. trivial. diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4 index 552f23f6..96277e65 100644 --- a/plugins/rtauto/g_rtauto.ml4 +++ b/plugins/rtauto/g_rtauto.ml4 @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: g_rtauto.ml4 14641 2011-11-06 11:59:10Z herbelin $*) - (*i camlp4deps: "parsing/grammar.cma" i*) TACTIC EXTEND rtauto diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 500138cf..c1e83004 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: proof_search.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Term open Util open Goptions @@ -49,6 +47,7 @@ let pruning = ref true let opt_pruning= {optsync=true; + optdepr=false; optname="Rtauto Pruning"; optkey=["Rtauto";"Pruning"]; optread=(fun () -> !pruning); @@ -510,8 +509,8 @@ let pp_gl gl= cut () ++ let pp = function - Incomplete(gl,ctx) -> msgnl (pp_gl gl) - | _ -> msg (str "<complete>") + Incomplete(gl,ctx) -> pp_gl gl ++ fnl () + | _ -> str "<complete>" let pp_info () = let count_info = diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli index 4d77a057..2adda33f 100644 --- a/plugins/rtauto/proof_search.mli +++ b/plugins/rtauto/proof_search.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: proof_search.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - type form= Atom of int | Arrow of form * form @@ -40,7 +38,7 @@ val branching: state -> state list val success: state -> bool -val pp: state -> unit +val pp: state -> Pp.std_ppcmds val pr_form : form -> unit diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 20b4c8f6..e8909f08 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -1,18 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: refl_tauto.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - module Search = Explore.Make(Proof_search) open Util open Term -open Termops open Names open Evd open Tacmach @@ -35,11 +32,11 @@ let data_constant = Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"] let l_true_equals_true = - lazy (mkApp(logic_constant "refl_equal", + lazy (mkApp(logic_constant "eq_refl", [|data_constant "bool";data_constant "true"|])) let pos_constant = - Coqlib.gen_constant "refl_tauto" ["NArith";"BinPos"] + Coqlib.gen_constant "refl_tauto" ["Numbers";"BinNums"] let l_xI = lazy (pos_constant "xI") let l_xO = lazy (pos_constant "xO") @@ -104,7 +101,7 @@ let rec make_form atom_env gls term = let cciterm=special_whd gls term in match kind_of_term cciterm with Prod(_,a,b) -> - if not (dependent (mkRel 1) b) && + if not (Termops.dependent (mkRel 1) b) && Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) a = InProp then @@ -144,7 +141,7 @@ let rec make_hyps atom_env gls lenv = function | (id,None,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in - if List.exists (dependent (mkVar id)) lenv || + if List.exists (Termops.dependent (mkVar id)) lenv || (Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) typ <> InProp) then @@ -244,6 +241,7 @@ let verbose = ref false let opt_verbose= {optsync=true; + optdepr=false; optname="Rtauto Verbose"; optkey=["Rtauto";"Verbose"]; optread=(fun () -> !verbose); @@ -255,6 +253,7 @@ let check = ref false let opt_check= {optsync=true; + optdepr=false; optname="Rtauto Check"; optkey=["Rtauto";"Check"]; optread=(fun () -> !check); @@ -267,14 +266,13 @@ open Pp let rtauto_tac gls= Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"]; let gamma={next=1;env=[]} in - let gl=gls.it.evar_concl in + let gl=pf_concl gls in let _= if Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) gl <> InProp then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in - let hyps=make_hyps gamma gls [gl] - (Environ.named_context_of_val gls.it.evar_hyps) in + let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in let formula= List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in let search_fun = diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index 085a45a5..e5fb646a 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: refl_tauto.mli 14641 2011-11-06 11:59:10Z herbelin $ *) - (* raises Not_found if no proof is found *) type atom_env= diff --git a/plugins/setoid_ring/Algebra_syntax.v b/plugins/setoid_ring/Algebra_syntax.v new file mode 100644 index 00000000..e896554e --- /dev/null +++ b/plugins/setoid_ring/Algebra_syntax.v @@ -0,0 +1,25 @@ + +Class Zero (A : Type) := zero : A. +Notation "0" := zero. +Class One (A : Type) := one : A. +Notation "1" := one. +Class Addition (A : Type) := addition : A -> A -> A. +Notation "_+_" := addition. +Notation "x + y" := (addition x y). +Class Multiplication {A B : Type} := multiplication : A -> B -> B. +Notation "_*_" := multiplication. +Notation "x * y" := (multiplication x y). +Class Subtraction (A : Type) := subtraction : A -> A -> A. +Notation "_-_" := subtraction. +Notation "x - y" := (subtraction x y). +Class Opposite (A : Type) := opposite : A -> A. +Notation "-_" := opposite. +Notation "- x" := (opposite(x)). +Class Equality {A : Type}:= equality : A -> A -> Prop. +Notation "_==_" := equality. +Notation "x == y" := (equality x y) (at level 70, no associativity). +Class Bracket (A B: Type):= bracket : A -> B. +Notation "[ x ]" := (bracket(x)). +Class Power {A B: Type} := power : A -> B -> A. +Notation "x ^ y" := (power x y). + diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v index 6998b656..ed35bb46 100644 --- a/plugins/setoid_ring/ArithRing.v +++ b/plugins/setoid_ring/ArithRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -21,17 +21,17 @@ Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat). Lemma nat_morph_N : semi_morph 0 1 plus mult (eq (A:=nat)) - 0%N 1%N Nplus Nmult Neq_bool nat_of_N. + 0%N 1%N N.add N.mul N.eqb N.to_nat. Proof. constructor;trivial. - exact nat_of_Nplus. - exact nat_of_Nmult. - intros x y H;rewrite (Neq_bool_ok _ _ H);trivial. + exact N2Nat.inj_add. + exact N2Nat.inj_mul. + intros x y H. apply N.eqb_eq in H. now subst. Qed. Ltac natcst t := match isnatcst t with - true => constr:(N_of_nat t) + true => constr:(N.of_nat t) | _ => constr:InitialRing.NotConstant end. diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v index 905625cc..b3c59457 100644 --- a/plugins/setoid_ring/BinList.v +++ b/plugins/setoid_ring/BinList.v @@ -1,16 +1,15 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Set Implicit Arguments. Require Import BinPos. Require Export List. -Require Export ListTactics. -Open Local Scope positive_scope. +Set Implicit Arguments. +Local Open Scope positive_scope. Section MakeBinList. Variable A : Type. @@ -18,76 +17,64 @@ Section MakeBinList. Fixpoint jump (p:positive) (l:list A) {struct p} : list A := match p with - | xH => tail l + | xH => tl l | xO p => jump p (jump p l) - | xI p => jump p (jump p (tail l)) + | xI p => jump p (jump p (tl l)) end. Fixpoint nth (p:positive) (l:list A) {struct p} : A:= match p with | xH => hd default l | xO p => nth p (jump p l) - | xI p => nth p (jump p (tail l)) + | xI p => nth p (jump p (tl l)) end. - Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). + Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l). Proof. - induction j;simpl;intros. - repeat rewrite IHj;trivial. - repeat rewrite IHj;trivial. - trivial. + induction j;simpl;intros; now rewrite ?IHj. Qed. - Lemma jump_Psucc : forall j l, - (jump (Psucc j) l) = (jump 1 (jump j l)). + Lemma jump_succ : forall j l, + jump (Pos.succ j) l = jump 1 (jump j l). Proof. induction j;simpl;intros. - repeat rewrite IHj;simpl;repeat rewrite jump_tl;trivial. - repeat rewrite jump_tl;trivial. - trivial. + - rewrite !IHj; simpl; now rewrite !jump_tl. + - now rewrite !jump_tl. + - trivial. Qed. - Lemma jump_Pplus : forall i j l, - (jump (i + j) l) = (jump i (jump j l)). + Lemma jump_add : forall i j l, + jump (i + j) l = jump i (jump j l). Proof. - induction i;intros. - rewrite xI_succ_xO;rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi;trivial. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial. + induction i using Pos.peano_ind; intros. + - now rewrite Pos.add_1_l, jump_succ. + - now rewrite Pos.add_succ_l, !jump_succ, IHi. Qed. - Lemma jump_Pdouble_minus_one : forall i l, - (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)). + Lemma jump_pred_double : forall i l, + jump (Pos.pred_double i) (tl l) = jump i (jump i l). Proof. induction i;intros;simpl. - repeat rewrite jump_tl;trivial. - rewrite IHi. do 2 rewrite <- jump_tl;rewrite IHi;trivial. - trivial. + - now rewrite !jump_tl. + - now rewrite IHi, <- 2 jump_tl, IHi. + - trivial. Qed. - - Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l). + Lemma nth_jump : forall p l, nth p (tl l) = hd default (jump p l). Proof. induction p;simpl;intros. - rewrite <-jump_tl;rewrite IHp;trivial. - rewrite <-jump_tl;rewrite IHp;trivial. - trivial. + - now rewrite <-jump_tl, IHp. + - now rewrite <-jump_tl, IHp. + - trivial. Qed. - Lemma nth_Pdouble_minus_one : - forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l). + Lemma nth_pred_double : + forall p l, nth (Pos.pred_double p) (tl l) = nth p (jump p l). Proof. induction p;simpl;intros. - repeat rewrite jump_tl;trivial. - rewrite jump_Pdouble_minus_one. - repeat rewrite <- jump_tl;rewrite IHp;trivial. - trivial. + - now rewrite !jump_tl. + - now rewrite jump_pred_double, <- !jump_tl, IHp. + - trivial. Qed. End MakeBinList. - - diff --git a/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v new file mode 100644 index 00000000..02194d4f --- /dev/null +++ b/plugins/setoid_ring/Cring.v @@ -0,0 +1,271 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Export List. +Require Import Setoid. +Require Import BinPos. +Require Import BinList. +Require Import Znumtheory. +Require Export Morphisms Setoid Bool. +Require Import ZArith_base. +Require Export Algebra_syntax. +Require Export Ncring. +Require Export Ncring_initial. +Require Export Ncring_tac. + +Class Cring {R:Type}`{Rr:Ring R} := + cring_mul_comm: forall x y:R, x * y == y * x. + +Ltac reify_goal lvar lexpr lterm:= + (*idtac lvar; idtac lexpr; idtac lterm;*) + match lexpr with + nil => idtac + | ?e1::?e2::_ => + match goal with + |- (?op ?u1 ?u2) => + change (op + (@Ring_polynom.PEeval + _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) + (@Ring_theory.pow_N _ 1 multiplication) lvar e1) + (@Ring_polynom.PEeval + _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) + (@Ring_theory.pow_N _ 1 multiplication) lvar e2)) + end + end. + +Section cring. +Context {R:Type}`{Rr:Cring R}. + +Lemma cring_eq_ext: ring_eq_ext _+_ _*_ -_ _==_. +Proof. +intros. apply mk_reqe; solve_proper. +Defined. + +Lemma cring_almost_ring_theory: + almost_ring_theory (R:=R) zero one _+_ _*_ _-_ -_ _==_. +intros. apply mk_art ;intros. +rewrite ring_add_0_l; reflexivity. +rewrite ring_add_comm; reflexivity. +rewrite ring_add_assoc; reflexivity. +rewrite ring_mul_1_l; reflexivity. +apply ring_mul_0_l. +rewrite cring_mul_comm; reflexivity. +rewrite ring_mul_assoc; reflexivity. +rewrite ring_distr_l; reflexivity. +rewrite ring_opp_mul_l; reflexivity. +apply ring_opp_add. +rewrite ring_sub_def ; reflexivity. Defined. + +Lemma cring_morph: + ring_morph zero one _+_ _*_ _-_ -_ _==_ + 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool + Ncring_initial.gen_phiZ. +intros. apply mkmorph ; intros; simpl; try reflexivity. +rewrite Ncring_initial.gen_phiZ_add; reflexivity. +rewrite ring_sub_def. unfold Z.sub. rewrite Ncring_initial.gen_phiZ_add. +rewrite Ncring_initial.gen_phiZ_opp; reflexivity. +rewrite Ncring_initial.gen_phiZ_mul; reflexivity. +rewrite Ncring_initial.gen_phiZ_opp; reflexivity. +rewrite (Zeqb_ok x y H). reflexivity. Defined. + +Lemma cring_power_theory : + @Ring_theory.power_theory R one _*_ _==_ N (fun n:N => n) + (@Ring_theory.pow_N _ 1 multiplication). +intros; apply Ring_theory.mkpow_th. reflexivity. Defined. + +Lemma cring_div_theory: + div_theory _==_ Z.add Z.mul Ncring_initial.gen_phiZ Z.quotrem. +intros. apply InitialRing.Ztriv_div_th. unfold Setoid_Theory. +simpl. apply ring_setoid. Defined. + +End cring. + +Ltac cring_gen := + match goal with + |- ?g => let lterm := lterm_goal g in + match eval red in (list_reifyl (lterm:=lterm)) with + | (?fv, ?lexpr) => + (*idtac "variables:";idtac fv; + idtac "terms:"; idtac lterm; + idtac "reifications:"; idtac lexpr; *) + reify_goal fv lexpr lterm; + match goal with + |- ?g => + generalize + (@Ring_polynom.ring_correct _ 0 1 _+_ _*_ _-_ -_ _==_ + ring_setoid + cring_eq_ext + cring_almost_ring_theory + Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool + Ncring_initial.gen_phiZ + cring_morph + N + (fun n:N => n) + (@Ring_theory.pow_N _ 1 multiplication) + cring_power_theory + Z.quotrem + cring_div_theory + O fv nil); + let rc := fresh "rc"in + intro rc; apply rc + end + end + end. + +Ltac cring_compute:= vm_compute; reflexivity. + +Ltac cring:= + intros; + cring_gen; + cring_compute. + +Instance Zcri: (Cring (Rr:=Zr)). +red. exact Z.mul_comm. Defined. + +(* Cring_simplify *) + +Ltac cring_simplify_aux lterm fv lexpr hyp := + match lterm with + | ?t0::?lterm => + match lexpr with + | ?e::?le => + let t := constr:(@Ring_polynom.norm_subst + Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool Z.quotrem O nil e) in + let te := + constr:(@Ring_polynom.Pphi_dev + _ 0 1 _+_ _*_ _-_ -_ + + Z 0%Z 1%Z Zeq_bool + Ncring_initial.gen_phiZ + get_signZ fv t) in + let eq1 := fresh "ring" in + let nft := eval vm_compute in t in + let t':= fresh "t" in + pose (t' := nft); + assert (eq1 : t = t'); + [vm_cast_no_check (eq_refl t')| + let eq2 := fresh "ring" in + assert (eq2:(@Ring_polynom.PEeval + _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n) + (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); + [let eq3 := fresh "ring" in + generalize (@ring_rw_correct _ 0 1 _+_ _*_ _-_ -_ _==_ + ring_setoid + cring_eq_ext + cring_almost_ring_theory + Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool + Ncring_initial.gen_phiZ + cring_morph + N + (fun n:N => n) + (@Ring_theory.pow_N _ 1 multiplication) + cring_power_theory + Z.quotrem + cring_div_theory + get_signZ get_signZ_th + O nil fv I nil (eq_refl nil) ); + intro eq3; apply eq3; reflexivity| + match hyp with + | 1%nat => rewrite eq2 + | ?H => try rewrite eq2 in H + end]; + let P:= fresh "P" in + match hyp with + | 1%nat => + rewrite eq1; + pattern (@Ring_polynom.Pphi_dev + _ 0 1 _+_ _*_ _-_ -_ + + Z 0%Z 1%Z Zeq_bool + Ncring_initial.gen_phiZ + get_signZ fv t'); + match goal with + |- (?p ?t) => set (P:=p) + end; + unfold t' in *; clear t' eq1 eq2; + unfold Pphi_dev, Pphi_avoid; simpl; + repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, + mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, + mkpow;simpl) + | ?H => + rewrite eq1 in H; + pattern (@Ring_polynom.Pphi_dev + _ 0 1 _+_ _*_ _-_ -_ + + Z 0%Z 1%Z Zeq_bool + Ncring_initial.gen_phiZ + get_signZ fv t') in H; + match type of H with + | (?p ?t) => set (P:=p) in H + end; + unfold t' in *; clear t' eq1 eq2; + unfold Pphi_dev, Pphi_avoid in H; simpl in H; + repeat (unfold mkmult1, mkmultm1, mkmult_c_pos, mkmult_c, + mkadd_mult, mkmult_c_pos, mkmult_pow, mkadd_mult, + mkpow in H;simpl in H) + end; unfold P in *; clear P + ]; cring_simplify_aux lterm fv le hyp + | nil => idtac + end + | nil => idtac + end. + +Ltac set_variables fv := + match fv with + | nil => idtac + | ?t::?fv => + let v := fresh "X" in + set (v:=t) in *; set_variables fv + end. + +Ltac deset n:= + match n with + | 0%nat => idtac + | S ?n1 => + match goal with + | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 + end + end. + +(* a est soit un terme de l'anneau, soit une liste de termes. +J'ai pas réussi à un décomposer les Vlists obtenues avec ne_constr_list + dans Tactic Notation *) + +Ltac cring_simplify_gen a hyp := + let lterm := + match a with + | _::_ => a + | _ => constr:(a::nil) + end in + match eval red in (list_reifyl (lterm:=lterm)) with + | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; + let n := eval compute in (length fv) in + idtac n; + let lt:=fresh "lt" in + set (lt:= lterm); + let lv:=fresh "fv" in + set (lv:= fv); + (* les termes de fv sont remplacés par des variables + pour pouvoir utiliser simpl ensuite sans risquer + des simplifications indésirables *) + set_variables fv; + let lterm1 := eval unfold lt in lt in + let lv1 := eval unfold lv in lv in + idtac lterm1; idtac lv1; + cring_simplify_aux lterm1 lv1 lexpr hyp; + clear lt lv; + (* on remet les termes de fv *) + deset n + end. + +Tactic Notation "cring_simplify" constr(lterm):= + cring_simplify_gen lterm 1%nat. + +Tactic Notation "cring_simplify" constr(lterm) "in" ident(H):= + cring_simplify_gen lterm H. + diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v index 6a755af2..6d454ba8 100644 --- a/plugins/setoid_ring/Field.v +++ b/plugins/setoid_ring/Field.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v index eee89e61..8ac952c0 100644 --- a/plugins/setoid_ring/Field_tac.v +++ b/plugins/setoid_ring/Field_tac.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -447,7 +447,7 @@ Ltac prove_field_eqn ope FLD fv expr := pose (res' := res); let lemma := get_L1 FLD in let lemma := - constr:(lemma O fv List.nil expr' res' I List.nil (refl_equal _)) in + constr:(lemma O fv List.nil expr' res' I List.nil (eq_refl _)) in let ty := type of lemma in let lhs := match ty with forall _, ?lhs=_ -> _ => lhs @@ -487,7 +487,7 @@ Ltac reduce_field_expr ope kont FLD fv expr := kont c. (* Hack to let a Ltac return a term in the context of a primitive tactic *) -Ltac return_term x := generalize (refl_equal x). +Ltac return_term x := generalize (eq_refl x). Ltac get_term := match goal with | |- ?x = _ -> _ => x diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index ccdec656..bc05c252 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -1,13 +1,13 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \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. +Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List Morphisms. Require Import ZArith_base. (*Require Import Omega.*) Set Implicit Arguments. @@ -27,7 +27,7 @@ Section MakeFieldPol. Notation "x == y" := (req x y) (at level 70, no associativity). (* Equality properties *) - Variable Rsth : Setoid_Theory R req. + Variable Rsth : Equivalence req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable SRinv_ext : forall p q, p == q -> / p == / q. @@ -75,7 +75,6 @@ Qed. (* Useful tactics *) - Add Setoid R req Rsth as R_set1. Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. @@ -96,7 +95,7 @@ Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) (ARsub_def ARth) . (* Power coefficients *) - Variable Cpow : Set. + Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. @@ -116,16 +115,17 @@ Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi (* add abstract semi-ring to help with some proofs *) Add Ring Rring : (ARth_SRth ARth). +Local Hint Extern 2 (_ == _) => f_equiv. (* additional ring properties *) Lemma rsub_0_l : forall r, 0 - r == - r. -intros; rewrite (ARsub_def ARth) in |- *;ring. +intros; rewrite (ARsub_def ARth);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. +intros; rewrite (ARsub_def ARth). +rewrite (ARopp_zero Rsth Reqe ARth); ring. Qed. (*************************************************************************** @@ -135,42 +135,40 @@ Qed. ***************************************************************************) Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p. +Proof. intros p q H. -rewrite rdiv_def in |- *. +rewrite rdiv_def. transitivity (/ q * q * p); [ ring | idtac ]. -rewrite rinv_l in |- *; auto. +rewrite rinv_l; 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. +Instance SRdiv_ext: Proper (req ==> req ==> req) rdiv. +Proof. +intros p1 p2 Ep q1 q2 Eq. transitivity (p1 * / q1); auto. transitivity (p2 * / q2); auto. Qed. -Hint Resolve SRdiv_ext . - - Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed. +Hint Resolve SRdiv_ext. 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. +Proof. +intros p q1 q2 H EQ. +rewrite <- (@rdiv_simpl q1 p) by trivial. +rewrite <- (@rdiv_simpl q2 p) by trivial. +rewrite !rdiv_def, !(ARmul_assoc ARth). +now rewrite EQ. Qed. Theorem field_is_integral_domain : forall r1 r2, ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0. Proof. -red in |- *; intros. -apply H0. +intros r1 r2 H1 H2. contradict H2. transitivity (1 * r2); auto. transitivity (/ r1 * r1 * r2); auto. -rewrite <- (ARmul_assoc ARth) in |- *. -rewrite H1 in |- *. +rewrite <- (ARmul_assoc ARth). +rewrite H2. apply ARmul_0_r with (1 := Rsth) (2 := ARth). Qed. @@ -179,15 +177,15 @@ Theorem ropp_neq_0 : forall r, 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 |- *. + rewrite <- (ARopp_mul_l ARth). + rewrite (ARmul_1_l ARth). reflexivity. Qed. Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1. intros. -rewrite (AFdiv_def AFth) in |- *. -rewrite (ARmul_comm ARth) in |- *. +rewrite (AFdiv_def AFth). +rewrite (ARmul_comm ARth). apply (AFinv_l AFth). trivial. Qed. @@ -203,14 +201,14 @@ Theorem rdiv2: 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). +assert (~ r2 * r4 == 0) by (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 |- *. +rewrite rdiv_simpl; trivial. +rewrite (ARdistr_r Rsth Reqe ARth). apply (Radd_ext Reqe). - transitivity (r2 * (r1 / r2) * r4); [ ring | auto ]. - transitivity (r2 * (r4 * (r3 / r4))); auto. - transitivity (r2 * r3); auto. +- transitivity (r2 * (r1 / r2) * r4); [ ring | auto ]. +- transitivity (r2 * (r4 * (r3 / r4))); auto. + transitivity (r2 * r3); auto. Qed. @@ -225,35 +223,36 @@ 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). + by (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 |- *. +rewrite rdiv_simpl; trivial. +rewrite (ARdistr_r Rsth Reqe ARth). 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. +Proof. intros r1 r2. transitivity (- (r1 * / r2)); auto. transitivity (- r1 * / r2); auto. Qed. Hint Resolve rdiv5 . -Theorem rdiv3: - forall r1 r2 r3 r4, +Theorem rdiv3 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. +Proof. +intros H2 H4. 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. +transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)). apply rdiv2; auto. -apply SRdiv_ext; auto. -transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto. +f_equiv. +transitivity (r1 * r4 + - (r3 * r2)); auto. Qed. @@ -279,13 +278,13 @@ intros r1 r2 H H0. assert (~ r1 / r2 == 0) as Hk. intros H1; case H. transitivity (r2 * (r1 / r2)); auto. - rewrite H1 in |- *; ring. + rewrite H1; ring. apply rmul_reg_l with (r1 / r2); auto. transitivity (/ (r1 / r2) * (r1 / r2)); auto. transitivity 1; auto. - repeat rewrite rdiv_def in |- *. + repeat rewrite rdiv_def. transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac | ring ]. - repeat rewrite rinv_l in |- *; auto. + repeat rewrite rinv_l; auto. Qed. Hint Resolve rdiv6 . @@ -296,11 +295,11 @@ Hint Resolve rdiv6 . (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). +assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial). apply rmul_reg_l with (r2 * r4); trivial. -rewrite rdiv_simpl in |- *; trivial. +rewrite rdiv_simpl; trivial. transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ]. -repeat rewrite rdiv_simpl in |- *; trivial. +repeat rewrite rdiv_simpl; trivial. Qed. Theorem rdiv4b: @@ -334,8 +333,8 @@ Theorem rdiv7: (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3). Proof. intros. -rewrite (rdiv_def (r1 / r2)) in |- *. -rewrite rdiv6 in |- *; trivial. +rewrite (rdiv_def (r1 / r2)). +rewrite rdiv6; trivial. apply rdiv4; trivial. Qed. @@ -373,14 +372,14 @@ 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 |- *. + rewrite rdiv_r_r; trivial. + symmetry . apply (ARmul_1_r Rsth ARth). - rewrite rdiv4 in |- *; trivial. - rewrite H1 in |- *. - rewrite (ARmul_comm ARth r2 r4) in |- *. - rewrite <- rdiv4 in |- *; trivial. - rewrite rdiv_r_r in |- * by trivial. + rewrite rdiv4; trivial. + rewrite H1. + rewrite (ARmul_comm ARth r2 r4). + rewrite <- rdiv4; trivial. + rewrite rdiv_r_r by trivial. apply (ARmul_1_r Rsth ARth). Qed. @@ -390,52 +389,16 @@ Qed. ***************************************************************************) -Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool := - match p1, p2 with - xH, xH => true - | xO p3, xO p4 => positive_eq p3 p4 - | xI p3, xI p4 => positive_eq p3 p4 - | _, _ => false - end. - -Theorem positive_eq_correct: - forall p1 p2, if positive_eq p1 p2 then p1 = p2 else p1 <> p2. -intros p1; elim p1; - (try (intros p2; case p2; simpl; auto; intros; discriminate)). -intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. -generalize (rec p4); case (positive_eq p3 p4); auto. -intros H1; apply f_equal with ( f := xI ); auto. -intros H1 H2; case H1; injection H2; auto. -intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4. -generalize (rec p4); case (positive_eq p3 p4); auto. -intros H1; apply f_equal with ( f := xO ); auto. -intros H1 H2; case H1; injection H2; auto. -Qed. - -Definition N_eq n1 n2 := - match n1, n2 with - | N0, N0 => true - | Npos p1, Npos p2 => positive_eq p1 p2 - | _, _ => false - end. - -Lemma N_eq_correct : forall n1 n2, if N_eq n1 n2 then n1 = n2 else n1 <> n2. -Proof. - intros [ |p1] [ |p2];simpl;trivial;try(intro H;discriminate H;fail). - assert (H:=positive_eq_correct p1 p2);destruct (positive_eq p1 p2); - [rewrite H;trivial | intro H1;injection H1;subst;apply H;trivial]. -Qed. - (* equality test *) Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := match e1, e2 with PEc c1, PEc c2 => ceqb c1 c2 - | PEX p1, PEX p2 => positive_eq p1 p2 + | PEX p1, PEX p2 => Pos.eqb p1 p2 | PEadd e3 e5, PEadd e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false | PEsub e3 e5, PEsub e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false | PEmul e3 e5, PEmul e4 e6 => if PExpr_eq e3 e4 then PExpr_eq e5 e6 else false | PEopp e3, PEopp e4 => PExpr_eq e3 e4 - | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false + | PEpow e3 n3, PEpow e4 n4 => if N.eqb n3 n4 then PExpr_eq e3 e4 else false | _, _ => false end. @@ -446,22 +409,14 @@ Qed. Add Morphism (pow_N rI rmul) with signature req ==> eq ==> req as pow_N_morph. intros x y H [|p];simpl;auto. apply pow_morph;trivial. Qed. -(* -Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n). -Proof. - intros; repeat rewrite pow_th.(rpow_pow_N). - destruct n;simpl. apply eq_refl. - induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl. -Qed. -*) + Theorem PExpr_eq_semi_correct: forall l e1 e2, PExpr_eq e1 e2 = true -> NPEeval l e1 == NPEeval l e2. intros l e1; elim e1. intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)). intros c2; apply (morph_eq CRmorph). intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)). -intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2); - (try (intros; discriminate)); intros H; rewrite H; auto. +intros p2; case Pos.eqb_spec; intros; now subst. 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); @@ -478,9 +433,8 @@ intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))). intros e4; generalize (rec e4); case (PExpr_eq e3 e4); (try (intros; discriminate)); auto. intros e3 rec n3 e2;(case e2;simpl;(try (intros;discriminate))). -intros e4 n4;generalize (N_eq_correct n3 n4);destruct (N_eq n3 n4); -intros;try discriminate. -repeat rewrite pow_th.(rpow_pow_N);rewrite H;rewrite (rec _ H0);auto. +intros e4 n4; case N.eqb_spec; try discriminate; intros EQ H; subst. +repeat rewrite pow_th.(rpow_pow_N). rewrite (rec _ H);auto. Qed. (* add *) @@ -497,8 +451,8 @@ Theorem NPEadd_correct: forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2). Proof. intros l e1 e2. -destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl; +destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect; + try (intro eq_c; rewrite eq_c); simpl;try apply eq_refl; try (ring [(morph0 CRmorph)]). apply (morph_add CRmorph). Qed. @@ -507,7 +461,7 @@ Definition NPEpow x n := match n with | N0 => PEc cI | Npos p => - if positive_eq p xH then x else + if Pos.eqb p xH then x else match x with | PEc c => if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) @@ -520,10 +474,10 @@ Theorem NPEpow_correct : forall l e n, Proof. destruct n;simpl. rewrite pow_th.(rpow_pow_N);simpl;auto. - generalize (positive_eq_correct p xH). - destruct (positive_eq p 1);intros. - rewrite H;rewrite pow_th.(rpow_pow_N). trivial. - clear H;destruct e;simpl;auto. + fold (p =? 1)%positive. + case Pos.eqb_spec; intros H; (rewrite H || clear H). + now rewrite pow_th.(rpow_pow_N). + destruct e;simpl;auto. repeat apply ceqb_rect;simpl;intros;rewrite pow_th.(rpow_pow_N);simpl. symmetry;induction p;simpl;trivial; ring [IHp H CRmorph.(morph1)]. symmetry; induction p;simpl;trivial;ring [IHp CRmorph.(morph0)]. @@ -539,7 +493,7 @@ Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := | _, PEc c => if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y | PEpow e1 n1, PEpow e2 n2 => - if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y + if N.eqb n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y | _, _ => PEmul x y end. @@ -549,15 +503,15 @@ Qed. Theorem NPEmul_correct : forall l e1 e2, NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). -induction e1;destruct e2; simpl in |- *;try reflexivity; +induction e1;destruct e2; simpl;try reflexivity; repeat apply ceqb_rect; - try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity; + try (intro eq_c; rewrite eq_c); simpl; try reflexivity; try ring [(morph0 CRmorph) (morph1 CRmorph)]. apply (morph_mul CRmorph). -assert (H:=N_eq_correct n n0);destruct (N_eq n n0). +case N.eqb_spec; intros H; try rewrite <- H; clear H. rewrite NPEpow_correct. simpl. repeat rewrite pow_th.(rpow_pow_N). -rewrite IHe1;rewrite <- H;destruct n;simpl;try ring. +rewrite IHe1; destruct n;simpl;try ring. apply pow_pos_mul. simpl;auto. Qed. @@ -575,9 +529,9 @@ Definition NPEsub e1 e2 := 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; +destruct e1; destruct e2; simpl; try reflexivity; try apply ceqb_rect; + try (intro eq_c; rewrite eq_c); simpl; + try rewrite (morph0 CRmorph); try reflexivity; try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). apply (morph_sub CRmorph). Qed. @@ -697,8 +651,8 @@ 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. +intros l l1 l2; elim l1; simpl app. + simpl; auto. destruct l0; simpl in *. destruct l2; firstorder. firstorder. @@ -713,8 +667,8 @@ Qed. 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. +unfold absurd_PCond; simpl. +red; intros. apply H. apply (morph0 CRmorph). Qed. @@ -743,10 +697,10 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) end end | PEpow e3 N0 => None - | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2) + | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pos.mul p3 p2) | _ => if PExpr_eq e1 e2 then - match Zminus (Zpos p1) (Zpos p2) with + match Z.pos_sub p1 p2 with | Zpos p => Some (Npos p, PEc cI) | Z0 => Some (N0, PEc cI) | Zneg p => Some (N0, NPEpow e2 (Npos p)) @@ -757,13 +711,19 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. - Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) - ARth.(ARmul_comm) ARth.(ARmul_assoc)). + Notation pow_pos_add := + (Ring_theory.pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). + + Lemma Z_pos_sub_gt p q : (p > q)%positive -> + Z.pos_sub p q = Zpos (p - q). + Proof. intros; now apply Z.pos_sub_gt, Pos.gt_lt. Qed. + + Ltac simpl_pos_sub := rewrite ?Z_pos_sub_gt in * by assumption. Lemma isIn_correct_aux : forall l e1 e2 p1 p2, match (if PExpr_eq e1 e2 then - match Zminus (Zpos p1) (Zpos p2) with + match Z.sub (Zpos p1) (Zpos p2) with | Zpos p => Some (Npos p, PEc cI) | Z0 => Some (N0, PEc cI) | Zneg p => Some (N0, NPEpow e2 (Npos p)) @@ -779,37 +739,29 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) Proof. intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2); case (PExpr_eq e1 e2); simpl; auto; intros H. - case_eq ((p1 ?= p2)%positive Eq);intros;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _). - rewrite (Pcompare_Eq_eq _ _ H0). - rewrite H by trivial. ring [ (morph1 CRmorph)]. - fold (NPEpow e2 (Npos (p2 - p1))). - rewrite NPEpow_correct;simpl. - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite H;trivial. split. 2:refine (refl_equal _). - rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. - repeat rewrite pow_th.(rpow_pow_N);simpl. - rewrite H;trivial. - change (ZtoN - match (p1 ?= p1 - p2)%positive Eq with - | Eq => 0 - | Lt => Zneg (p1 - p2 - p1) - | Gt => Zpos (p1 - (p1 - p2)) - end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))). - replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z. - split. - repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth). - rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl. - ring [ (morph1 CRmorph)]. - assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). - apply Zplus_gt_reg_l with (Zpos p2). - rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z. - apply Zplus_gt_compat_r. refine (refl_equal _). - simpl;rewrite H0;trivial. + rewrite Z.pos_sub_spec. + case Pos.compare_spec;intros;simpl. + - repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:reflexivity. + subst. rewrite H by trivial. ring [ (morph1 CRmorph)]. + - fold (p2 - p1 =? 1)%positive. + fold (NPEpow e2 (Npos (p2 - p1))). + rewrite NPEpow_correct;simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. + rewrite H;trivial. split. 2:reflexivity. + rewrite <- pow_pos_add. now rewrite Pos.add_comm, Pos.sub_add. + - repeat rewrite pow_th.(rpow_pow_N);simpl. + rewrite H;trivial. + rewrite Z.pos_sub_gt by now apply Pos.sub_decr. + replace (p1 - (p1 - p2))%positive with p2; + [| rewrite Pos.sub_sub_distr, Pos.add_comm; + auto using Pos.add_sub, Pos.sub_decr ]. + split. + simpl. ring [ (morph1 CRmorph)]. + now apply Z.lt_gt, Pos.sub_decr. Qed. Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2). -induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl. +induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_add;simpl. ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto. Qed. @@ -835,39 +787,39 @@ destruct n. destruct n;simpl. rewrite NPEmul_correct;repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4). - unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. + simpl_pos_sub. simpl in H3. rewrite pow_pos_mul. rewrite H1;rewrite H3. assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H. - rewrite <- pow_pos_plus. rewrite Pplus_minus. - split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial. + rewrite <- pow_pos_add. + rewrite Pos.add_comm, Pos.sub_add by (now apply Z.gt_lt in H4). + split. symmetry;apply ARth.(ARmul_assoc). reflexivity. repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4). - unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. - rewrite H2 in H1;simpl in H1. + simpl_pos_sub. simpl in H1, H3. assert (Zpos p1 > Zpos p6)%Z. apply Zgt_trans with (Zpos p4). exact H4. exact H2. - unfold Zgt in H;simpl in H;rewrite H. + simpl_pos_sub. split. 2:exact H. rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3. assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) == pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0. - rewrite <- pow_pos_plus. + rewrite <- pow_pos_add. replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. rewrite NPEmul_correct. simpl;ring. assert (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z. change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z). - rewrite <- Zplus_assoc. rewrite (Zplus_assoc (- Zpos p4)). - simpl. rewrite Pcompare_refl. simpl. reflexivity. - unfold Zminus, Zopp in H0. simpl in H0. - rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial. + rewrite <- Z.add_assoc. rewrite (Z.add_assoc (- Zpos p4)). + simpl. rewrite Z.pos_sub_diag. simpl. reflexivity. + unfold Z.sub, Z.opp in H0. simpl in H0. + simpl_pos_sub. inversion H0; trivial. simpl. repeat rewrite pow_th.(rpow_pow_N). - intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3. + intros H1 (H2,H3). simpl_pos_sub. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. simpl in H2. rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. split. ring [H2]. exact H3. @@ -878,8 +830,7 @@ destruct n. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. intros (H1, H2);rewrite H1;split. - unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1. - simpl in H1;ring [H1]. trivial. + simpl_pos_sub. simpl in H1;ring [H1]. trivial. trivial. destruct n. trivial. generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3. @@ -910,7 +861,7 @@ Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit : (NPEmul (common r1) (common r2)) (right r2) | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2 - | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2 + | PEpow e3 (Npos p3) => split_aux e3 (Pos.mul p3 p) e2 | _ => match isIn e1 p e2 xH with | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 @@ -937,9 +888,9 @@ Proof. repeat rewrite NPEpow_correct;simpl; repeat rewrite pow_th.(rpow_pow_N);simpl). intros (H, Hgt);split;try ring [H CRmorph.(morph1)]. - intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H. - simpl in H;split;try ring [H]. - rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial. + intros (H, Hgt). simpl_pos_sub. simpl in H;split;try ring [H]. + apply Z.gt_lt in Hgt. + now rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add. simpl;intros. repeat rewrite NPEmul_correct;simpl. rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)]. Qed. @@ -1061,13 +1012,13 @@ 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. + simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. + simpl; intros _ _; rewrite (morph1 CRmorph); exact rI_neq_rO. intros e1 Hrec1 e2 Hrec2 Hcond. simpl condition in Hcond. - simpl denum in |- *. - rewrite NPEmul_correct in |- *. - simpl in |- *. + simpl denum. + rewrite NPEmul_correct. + simpl. apply field_is_integral_domain. intros HH; case Hrec1; auto. apply PCond_app_inv_l with (1 := Hcond). @@ -1078,9 +1029,9 @@ intros l e; elim e. 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 |- *. + simpl denum. + rewrite NPEmul_correct. + simpl. apply field_is_integral_domain. intros HH; case Hrec1; auto. apply PCond_app_inv_l with (1 := Hcond). @@ -1091,9 +1042,9 @@ intros l e; elim e. 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 |- *. + simpl denum. + rewrite NPEmul_correct. + simpl. apply field_is_integral_domain. intros HH; apply Hrec1. apply PCond_app_inv_l with (1 := Hcond). @@ -1105,17 +1056,17 @@ intros l e; elim e. rewrite NPEmul_correct; simpl; rewrite HH; ring. intros e1 Hrec1 Hcond. simpl condition in Hcond. - simpl denum in |- *. + simpl denum. auto. intros e1 Hrec1 Hcond. simpl condition in Hcond. - simpl denum in |- *. + simpl denum. 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 |- *. + simpl denum. + rewrite NPEmul_correct. + simpl. apply field_is_integral_domain. intros HH; apply Hrec1. specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1. @@ -1258,9 +1209,9 @@ Theorem Fnorm_crossproduct: PCond l (condition nfe1 ++ condition nfe2) -> FEeval l fe1 == FEeval l fe2. intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2. -rewrite Fnorm_FEeval_PEeval in |- * by +rewrite Fnorm_FEeval_PEeval by apply PCond_app_inv_l with (1 := Hcond). - rewrite Fnorm_FEeval_PEeval in |- * by + rewrite Fnorm_FEeval_PEeval by apply PCond_app_inv_r with (1 := Hcond). apply cross_product_eq; trivial. apply Pcond_Fnorm. @@ -1355,9 +1306,9 @@ apply Fnorm_crossproduct; trivial. match goal with [ |- NPEeval l ?x == NPEeval l ?y] => rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec - O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x))); + O nil l I Logic.eq_refl x Logic.eq_refl); rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec - O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y))) + O nil l I Logic.eq_refl y Logic.eq_refl) end. trivial. Qed. @@ -1377,28 +1328,28 @@ Proof. intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; subst nfe1 nfe2 den lmp. apply Fnorm_crossproduct; trivial. -simpl in |- *. -rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite NPEmul_correct in |- *. -rewrite NPEmul_correct in |- *. -simpl in |- *. -repeat rewrite (ARmul_assoc ARth) in |- *. +simpl. +rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). +rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))). +rewrite NPEmul_correct. +rewrite NPEmul_correct. +simpl. +repeat rewrite (ARmul_assoc ARth). rewrite <-( let x := PEmul (num (Fnorm fe1)) (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. + Hlpe Logic.eq_refl + x Logic.eq_refl) in Hcrossprod. rewrite <-( let x := (PEmul (num (Fnorm fe2)) (rsplit_left (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. + Hlpe Logic.eq_refl + x Logic.eq_refl) in Hcrossprod. simpl in Hcrossprod. -rewrite Hcrossprod in |- *. +rewrite Hcrossprod. reflexivity. Qed. @@ -1417,28 +1368,28 @@ Proof. intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond; subst nfe1 nfe2 den lmp. apply Fnorm_crossproduct; trivial. -simpl in |- *. -rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *. -rewrite NPEmul_correct in |- *. -rewrite NPEmul_correct in |- *. -simpl in |- *. -repeat rewrite (ARmul_assoc ARth) in |- *. +simpl. +rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). +rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))). +rewrite NPEmul_correct. +rewrite NPEmul_correct. +simpl. +repeat rewrite (ARmul_assoc ARth). rewrite <-( let x := PEmul (num (Fnorm fe1)) (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. + Hlpe Logic.eq_refl + x Logic.eq_refl) in Hcrossprod. rewrite <-( let x := (PEmul (num (Fnorm fe2)) (rsplit_left (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l - Hlpe (refl_equal (Nmk_monpol_list lpe)) - x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. + Hlpe Logic.eq_refl + x Logic.eq_refl) in Hcrossprod. simpl in Hcrossprod. -rewrite Hcrossprod in |- *. +rewrite Hcrossprod. reflexivity. Qed. @@ -1558,7 +1509,7 @@ Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) := Lemma fcons_correct : forall l l1, PCond l (Fapp l1 nil) -> PCond l l1. -induction l1; simpl in |- *; intros. +induction l1; simpl; intros. trivial. elim PCond_fcons_inv with (1 := H); intros. destruct l1; auto. @@ -1639,7 +1590,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). simpl in H1. case (H _ H1); intros H2 H3. case (H0 _ H3); intros H4 H5; split; auto. - simpl in |- *. + simpl. apply field_is_integral_domain; trivial. simpl;intros. rewrite pow_th.(rpow_pow_N). destruct (H _ H0);split;auto. @@ -1667,7 +1618,7 @@ 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. +red; intro. absurd (false = true); auto; discriminate. Qed. @@ -1683,18 +1634,18 @@ Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := 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. + simpl; intros c l1. apply ceqb_rect_complete; intros. elim (@absurd_PCond_bottom l H0). split; trivial. - rewrite <- (morph0 CRmorph) in |- *; trivial. + rewrite <- (morph0 CRmorph); 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 |- *. + simpl. apply field_is_integral_domain; trivial. - simpl in |- *; intros p H l1. + simpl; intros p H l1. apply ceqb_rect_complete; intros. elim (@absurd_PCond_bottom l H1). destruct (H _ H1). @@ -1713,7 +1664,7 @@ 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; +unfold Fcons2; 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. @@ -1792,61 +1743,55 @@ 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. +elim p using Pos.peano_ind; simpl; 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. + repeat rewrite (ARadd_assoc ARth). + rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth); 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. +repeat rewrite <- (same_gen Rsth Reqe ARth). +case (Pos.compare_spec x y). + intros. + trivial. 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. + symmetry. + rewrite (ARadd_0_r Rsth ARth). + rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). + now rewrite Pos.add_comm, Pos.sub_add. + intros. 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. + rewrite (ARadd_0_r Rsth ARth). + rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth). + now rewrite Pos.add_comm, Pos.sub_add. 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. +destruct x; destruct y; simpl; intros; trivial. elim gen_phiPOS_not_0 with p. - symmetry in |- *. - rewrite (same_gen Rsth Reqe ARth) in |- *; trivial. + symmetry . + rewrite (same_gen Rsth Reqe ARth); 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. + rewrite (same_gen Rsth Reqe ARth); trivial. + rewrite gen_phiPOS_inj with (1 := H); 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. + N.eqb x y = true. +Proof. +intros. now apply N.eqb_eq, gen_phiN_inj. Qed. End AlmostField. @@ -1864,17 +1809,17 @@ Section Field. 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 |- *. + rewrite (Ropp_def Rth). + symmetry . apply (ARadd_0_r Rsth ARth). transitivity (y + (1 + - (1))). - repeat rewrite <- (ARplus_assoc ARth) in |- *. - repeat rewrite (ARadd_assoc ARth) in |- *. + repeat rewrite <- (ARplus_assoc ARth). + repeat rewrite (ARadd_assoc ARth). apply (Radd_ext Reqe). - repeat rewrite <- (ARadd_comm ARth 1) in |- *. + repeat rewrite <- (ARadd_comm ARth 1). trivial. reflexivity. - rewrite (Ropp_def Rth) in |- *. + rewrite (Ropp_def Rth). apply (ARadd_0_r Rsth ARth). Qed. @@ -1886,14 +1831,14 @@ Let gen_phiPOS_inject := Lemma gen_phiPOS_discr_sgn : forall x y, ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y. -red in |- *; intros. +red; intros. apply gen_phiPOS_not_0 with (y + x)%positive. -rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *. +rewrite (ARgen_phiPOS_add Rsth Reqe ARth). 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 |- *. + rewrite (same_gen Rsth Reqe ARth). + rewrite (same_gen Rsth Reqe ARth). trivial. apply (Ropp_def Rth). Qed. @@ -1901,33 +1846,33 @@ 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. +destruct x; destruct y; simpl; intros. trivial. elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. - symmetry in |- *; trivial. + rewrite (same_gen Rsth Reqe ARth). + symmetry ; 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 |- *. + rewrite (same_gen Rsth Reqe ARth). + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). + rewrite <- H. apply (ARopp_zero Rsth Reqe ARth). elim gen_phiPOS_not_0 with p. - rewrite (same_gen Rsth Reqe ARth) in |- *. + rewrite (same_gen Rsth Reqe ARth). trivial. - rewrite gen_phiPOS_inject with (1 := H) in |- *; trivial. + rewrite gen_phiPOS_inject with (1 := H); 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 |- *. + rewrite (same_gen Rsth Reqe ARth). + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). + rewrite H. apply (ARopp_zero Rsth Reqe ARth). elim gen_phiPOS_discr_sgn with p0 p. - symmetry in |- *; trivial. + symmetry ; 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. + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)). + rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)). + rewrite H; trivial. reflexivity. Qed. @@ -1936,8 +1881,8 @@ Lemma gen_phiZ_complete : forall x y, Zeq_bool x y = true. intros. replace y with x. - unfold Zeq_bool in |- *. - rewrite Zcompare_refl in |- *; trivial. + unfold Zeq_bool. + rewrite Z.compare_refl; trivial. apply gen_phiZ_inj; trivial. Qed. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index 026e70c8..e805151c 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -13,7 +13,6 @@ Require Import BinNat. Require Import Setoid. Require Import Ring_theory. Require Import Ring_polynom. -Require Import ZOdiv_def. Import List. Set Implicit Arguments. @@ -28,14 +27,14 @@ Definition NotConstant := false. Lemma Zsth : Setoid_Theory Z (@eq Z). Proof (Eqsth Z). -Lemma Zeqe : ring_eq_ext Zplus Zmult Zopp (@eq Z). -Proof (Eq_ext Zplus Zmult Zopp). +Lemma Zeqe : ring_eq_ext Z.add Z.mul Z.opp (@eq Z). +Proof (Eq_ext Z.add Z.mul Z.opp). -Lemma Zth : ring_theory Z0 (Zpos xH) Zplus Zmult Zminus Zopp (@eq Z). +Lemma Zth : ring_theory Z0 (Zpos xH) Z.add Z.mul Z.sub Z.opp (@eq Z). Proof. - constructor. exact Zplus_0_l. exact Zplus_comm. exact Zplus_assoc. - exact Zmult_1_l. exact Zmult_comm. exact Zmult_assoc. - exact Zmult_plus_distr_l. trivial. exact Zminus_diag. + constructor. exact Z.add_0_l. exact Z.add_comm. exact Z.add_assoc. + exact Z.mul_1_l. exact Z.mul_comm. exact Z.mul_assoc. + exact Z.mul_add_distr_r. trivial. exact Z.sub_diag. Qed. (** Two generic morphisms from Z to (abrbitrary) rings, *) @@ -93,12 +92,12 @@ Section ZMORPHISM. | _ => None end. - Lemma get_signZ_th : sign_theory Zopp Zeq_bool get_signZ. + Lemma get_signZ_th : sign_theory Z.opp Zeq_bool get_signZ. Proof. constructor. destruct c;intros;try discriminate. injection H;clear H;intros H1;subst c'. - simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial. + simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial. Qed. @@ -117,7 +116,7 @@ Section ZMORPHISM. Qed. Lemma ARgen_phiPOS_Psucc : forall x, - gen_phiPOS1 (Psucc x) == 1 + (gen_phiPOS1 x). + gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). Proof. induction x;simpl;norm. rewrite IHx;norm. @@ -128,7 +127,7 @@ Section ZMORPHISM. gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). Proof. induction x;destruct y;simpl;norm. - rewrite Pplus_carry_spec. + rewrite Pos.add_carry_spec. rewrite ARgen_phiPOS_Psucc. rewrite IHx;norm. add_push (gen_phiPOS1 y);add_push 1;rrefl. @@ -170,48 +169,28 @@ Section ZMORPHISM. rewrite H1;rrefl. Qed. - Lemma gen_phiZ1_add_pos_neg : forall x y, - gen_phiZ1 - match (x ?= y)%positive Eq with - | Eq => Z0 - | Lt => Zneg (y - x) - | Gt => Zpos (x - y) - end - == gen_phiPOS1 x + -gen_phiPOS1 y. + Lemma gen_phiZ1_pos_sub : forall x y, + gen_phiZ1 (Z.pos_sub x y) == gen_phiPOS1 x + -gen_phiPOS1 y. Proof. intros x y. - assert (H:= (Pcompare_Eq_eq x y)); assert (H0 := Pminus_mask_Gt x y). - generalize (Pminus_mask_Gt y x). - replace Eq with (CompOpp Eq);[intro H1;simpl|trivial]. - rewrite <- Pcompare_antisym in H1. - destruct ((x ?= y)%positive Eq). - rewrite H;trivial. rewrite (Ropp_def Rth);rrefl. - destruct H1 as [h [Heq1 [Heq2 Hor]]];trivial. - unfold Pminus; rewrite Heq1;rewrite <- Heq2. + rewrite Z.pos_sub_spec. + case Pos.compare_spec; intros H; simpl. + rewrite H. rewrite (Ropp_def Rth);rrefl. + rewrite <- (Pos.sub_add y x H) at 2. rewrite Pos.add_comm. rewrite (ARgen_phiPOS_add ARth);simpl;norm. rewrite (Ropp_def Rth);norm. - destruct H0 as [h [Heq1 [Heq2 Hor]]];trivial. - unfold Pminus; rewrite Heq1;rewrite <- Heq2. + rewrite <- (Pos.sub_add x y H) at 2. rewrite (ARgen_phiPOS_add ARth);simpl;norm. - add_push (gen_phiPOS1 h);rewrite (Ropp_def Rth); norm. + add_push (gen_phiPOS1 (x-y));rewrite (Ropp_def Rth); norm. Qed. - Lemma match_compOpp : forall x (B:Type) (be bl bg:B), - match CompOpp x with Eq => be | Lt => bl | Gt => bg end - = match x with Eq => be | Lt => bg | Gt => bl end. - Proof. destruct x;simpl;intros;trivial. Qed. - Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. Proof. intros x y; repeat rewrite same_genZ; generalize x y;clear x y. - induction x;destruct y;simpl;norm. + destruct x, y; simpl; norm. apply (ARgen_phiPOS_add ARth). - apply gen_phiZ1_add_pos_neg. - replace Eq with (CompOpp Eq);trivial. - rewrite <- Pcompare_antisym;simpl. - rewrite match_compOpp. - rewrite (Radd_comm Rth). - apply gen_phiZ1_add_pos_neg. + apply gen_phiZ1_pos_sub. + rewrite gen_phiZ1_pos_sub. apply (Radd_comm Rth). rewrite (ARgen_phiPOS_add ARth); norm. Qed. @@ -229,10 +208,10 @@ Section ZMORPHISM. (*proof that [.] satisfies morphism specifications*) Lemma gen_phiZ_morph : ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) - Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ. + Z.add Z.mul Z.sub Z.opp Zeq_bool gen_phiZ. Proof. assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) - Zplus Zmult Zeq_bool gen_phiZ). + Z.add Z.mul Zeq_bool gen_phiZ). apply mkRmorph;simpl;try rrefl. apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok. apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext). @@ -244,47 +223,28 @@ End ZMORPHISM. Lemma Nsth : Setoid_Theory N (@eq N). Proof (Eqsth N). -Lemma Nseqe : sring_eq_ext Nplus Nmult (@eq N). -Proof (Eq_s_ext Nplus Nmult). +Lemma Nseqe : sring_eq_ext N.add N.mul (@eq N). +Proof (Eq_s_ext N.add N.mul). -Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N). +Lemma Nth : semi_ring_theory 0%N 1%N N.add N.mul (@eq N). Proof. - constructor. exact Nplus_0_l. exact Nplus_comm. exact Nplus_assoc. - exact Nmult_1_l. exact Nmult_0_l. exact Nmult_comm. exact Nmult_assoc. - exact Nmult_plus_distr_r. + constructor. exact N.add_0_l. exact N.add_comm. exact N.add_assoc. + exact N.mul_1_l. exact N.mul_0_l. exact N.mul_comm. exact N.mul_assoc. + exact N.mul_add_distr_r. Qed. -Definition Nsub := SRsub Nplus. +Definition Nsub := SRsub N.add. Definition Nopp := (@SRopp N). -Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N). +Lemma Neqe : ring_eq_ext N.add N.mul Nopp (@eq N). Proof (SReqe_Reqe Nseqe). Lemma Nath : - almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N). + almost_ring_theory 0%N 1%N N.add N.mul Nsub Nopp (@eq N). Proof (SRth_ARth Nsth Nth). -Definition Neq_bool (x y:N) := - match Ncompare x y with - | Eq => true - | _ => false - end. - -Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y. - Proof. - intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); - destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. - Qed. - -Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y. - Proof. - intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); - destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. - Qed. +Lemma Neqb_ok : forall x y, N.eqb x y = true -> x = y. +Proof. exact (fun x y => proj1 (N.eqb_eq x y)). Qed. (**Same as above : definition of two,extensionaly equal, generic morphisms *) (**from N to any semi-ring*) @@ -307,9 +267,7 @@ Section NMORPHISM. Notation "x == y" := (req x y). Add Morphism radd : radd_ext4. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext4. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext4. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext5. exact (ARsub_ext Rsth Reqe ARth). Qed. - Ltac norm := gen_srewrite Rsth Reqe ARth. + Ltac norm := gen_srewrite_sr Rsth Reqe ARth. Definition gen_phiN1 x := match x with @@ -326,8 +284,8 @@ Section NMORPHISM. Lemma same_genN : forall x, [x] == gen_phiN1 x. Proof. - destruct x;simpl. rrefl. - rewrite (same_gen Rsth Reqe ARth);rrefl. + destruct x;simpl. reflexivity. + now rewrite (same_gen Rsth Reqe ARth). Qed. Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y]. @@ -349,11 +307,11 @@ Section NMORPHISM. (*gen_phiN satisfies morphism specifications*) Lemma gen_phiN_morph : ring_morph 0 1 radd rmul rsub ropp req - N0 (Npos xH) Nplus Nmult Nsub Nopp Neq_bool gen_phiN. + 0%N 1%N N.add N.mul Nsub Nopp N.eqb gen_phiN. Proof. - constructor;intros;simpl; try rrefl. - apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. - rewrite (Neq_bool_ok x y);trivial. rrefl. + constructor; simpl; try reflexivity. + apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult. + intros x y EQ. apply N.eqb_eq in EQ. now subst. Qed. End NMORPHISM. @@ -402,7 +360,7 @@ Fixpoint Nw_is0 (w : Nword) : bool := Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := match w1, w2 with | n1::w1', n2::w2' => - if Neq_bool n1 n2 then Nweq_bool w1' w2' else false + if N.eqb n1 n2 then Nweq_bool w1' w2' else false | nil, _ => Nw_is0 w2 | _, nil => Nw_is0 w1 end. @@ -438,14 +396,14 @@ Section NWORDMORPHISM. Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0. Proof. -induction w; simpl in |- *; intros; auto. +induction w; simpl; intros; auto. reflexivity. destruct a. destruct w. reflexivity. - rewrite IHw in |- *; trivial. + rewrite IHw; trivial. apply (ARopp_zero Rsth Reqe ARth). discriminate. @@ -454,7 +412,7 @@ Qed. Lemma gen_phiNword_cons : forall w n, gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w. induction w. - destruct n; simpl in |- *; norm. + destruct n; simpl; norm. intros. destruct n; norm. @@ -465,31 +423,31 @@ Qed. destruct w; intros. destruct n; norm. - unfold Nwcons in |- *. - rewrite gen_phiNword_cons in |- *. + unfold Nwcons. + rewrite gen_phiNword_cons. reflexivity. Qed. Lemma gen_phiNword_ok : forall w1 w2, Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2. induction w1; intros. - simpl in |- *. - rewrite (gen_phiNword0_ok _ H) in |- *. + simpl. + rewrite (gen_phiNword0_ok _ H). reflexivity. - rewrite gen_phiNword_cons in |- *. + rewrite gen_phiNword_cons. destruct w2. simpl in H. destruct a; try discriminate. - rewrite (gen_phiNword0_ok _ H) in |- *. + rewrite (gen_phiNword0_ok _ H). norm. simpl in H. - rewrite gen_phiNword_cons in |- *. - case_eq (Neq_bool a n); intros. + rewrite gen_phiNword_cons. + case_eq (N.eqb a n); intros H0. rewrite H0 in H. - rewrite <- (Neq_bool_ok _ _ H0) in |- *. - rewrite (IHw1 _ H) in |- *. + apply N.eqb_eq in H0. rewrite <- H0. + rewrite (IHw1 _ H). reflexivity. rewrite H0 in H; discriminate H. @@ -499,27 +457,27 @@ Qed. Lemma Nwadd_ok : forall x y, gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y. induction x; intros. - simpl in |- *. + simpl. norm. destruct y. simpl Nwadd; norm. - simpl Nwadd in |- *. - repeat rewrite gen_phiNword_cons in |- *. - rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- * by + simpl Nwadd. + repeat rewrite gen_phiNword_cons. + rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) by (destruct Reqe; constructor; trivial). - rewrite IHx in |- *. + rewrite IHx. norm. add_push (- gen_phiNword x); reflexivity. Qed. Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x. -simpl in |- *. -unfold Nwopp in |- *; simpl in |- *. +simpl. +unfold Nwopp; simpl. intros. -rewrite gen_phiNword_Nwcons in |- *; norm. +rewrite gen_phiNword_Nwcons; norm. Qed. Lemma Nwscal_ok : forall n x, @@ -527,12 +485,12 @@ Lemma Nwscal_ok : forall n x, induction x; intros. norm. - simpl Nwscal in |- *. - repeat rewrite gen_phiNword_cons in |- *. - rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- * + simpl Nwscal. + repeat rewrite gen_phiNword_cons. + rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) by (destruct Reqe; constructor; trivial). - rewrite IHx in |- *. + rewrite IHx. norm. Qed. @@ -542,19 +500,19 @@ induction x; intros. norm. destruct a. - simpl Nwmul in |- *. - rewrite Nwopp_ok in |- *. - rewrite IHx in |- *. - rewrite gen_phiNword_cons in |- *. + simpl Nwmul. + rewrite Nwopp_ok. + rewrite IHx. + rewrite gen_phiNword_cons. norm. - simpl Nwmul in |- *. - unfold Nwsub in |- *. - rewrite Nwadd_ok in |- *. - rewrite Nwscal_ok in |- *. - rewrite Nwopp_ok in |- *. - rewrite IHx in |- *. - rewrite gen_phiNword_cons in |- *. + simpl Nwmul. + unfold Nwsub. + rewrite Nwadd_ok. + rewrite Nwscal_ok. + rewrite Nwopp_ok. + rewrite IHx. + rewrite gen_phiNword_cons. norm. Qed. @@ -570,9 +528,9 @@ constructor. exact Nwadd_ok. intros. - unfold Nwsub in |- *. - rewrite Nwadd_ok in |- *. - rewrite Nwopp_ok in |- *. + unfold Nwsub. + rewrite Nwadd_ok. + rewrite Nwopp_ok. norm. exact Nwmul_ok. @@ -632,19 +590,19 @@ Qed. Variable zphi : Z -> R. - Lemma Ztriv_div_th : div_theory req Zplus Zmult zphi ZOdiv_eucl. + Lemma Ztriv_div_th : div_theory req Z.add Z.mul zphi Z.quotrem. Proof. constructor. - intros; generalize (ZOdiv_eucl_correct a b); case ZOdiv_eucl; intros; subst. - rewrite Zmult_comm; rsimpl. + intros; generalize (Z.quotrem_eq a b); case Z.quotrem; intros; subst. + rewrite Z.mul_comm; rsimpl. Qed. Variable nphi : N -> R. - Lemma Ntriv_div_th : div_theory req Nplus Nmult nphi Ndiv_eucl. + Lemma Ntriv_div_th : div_theory req N.add N.mul nphi N.div_eucl. constructor. - intros; generalize (Ndiv_eucl_correct a b); case Ndiv_eucl; intros; subst. - rewrite Nmult_comm; rsimpl. + intros; generalize (N.div_eucl_spec a b); case N.div_eucl; intros; subst. + rewrite N.mul_comm; rsimpl. Qed. End GEN_DIV. @@ -783,10 +741,10 @@ Ltac gen_ring_sign morph sspec := Ltac default_div_spec set reqe arth morph := match type of morph with | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - Z ?c0 ?c1 Zplus Zmult ?csub ?copp ?ceq_b ?phi => + Z ?c0 ?c1 Z.add Z.mul ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (Ztriv_div_th set phi)) | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req - N ?c0 ?c1 Nplus Nmult ?csub ?copp ?ceq_b ?phi => + N ?c0 ?c1 N.add N.mul ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (Ntriv_div_th set phi)) | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => @@ -878,7 +836,7 @@ Ltac isPcst t := | xO ?p => isPcst p | xH => constr:true (* nat -> positive *) - | P_of_succ_nat ?n => isnatcst n + | Pos.of_succ_nat ?n => isnatcst n | _ => constr:false end. @@ -895,9 +853,9 @@ Ltac isZcst t := | Zpos ?p => isPcst p | Zneg ?p => isPcst p (* injection nat -> Z *) - | Z_of_nat ?n => isnatcst n + | Z.of_nat ?n => isnatcst n (* injection N -> Z *) - | Z_of_N ?n => isNcst n + | Z.of_N ?n => isNcst n (* *) | _ => constr:false end. diff --git a/plugins/setoid_ring/Integral_domain.v b/plugins/setoid_ring/Integral_domain.v new file mode 100644 index 00000000..0c16fe1a --- /dev/null +++ b/plugins/setoid_ring/Integral_domain.v @@ -0,0 +1,43 @@ +Require Export Cring. + + +(* Definition of integral domains: commutative ring without zero divisor *) + +Class Integral_domain {R : Type}`{Rcr:Cring R} := { + integral_domain_product: + forall x y, x * y == 0 -> x == 0 \/ y == 0; + integral_domain_one_zero: not (1 == 0)}. + +Section integral_domain. + +Context {R:Type}`{Rid:Integral_domain R}. + +Lemma integral_domain_minus_one_zero: ~ - (1:R) == 0. +red;intro. apply integral_domain_one_zero. +assert (0 == - (0:R)). cring. +rewrite H0. rewrite <- H. cring. +Qed. + + +Definition pow (r : R) (n : nat) := Ring_theory.pow_N 1 mul r (N.of_nat n). + +Lemma pow_not_zero: forall p n, pow p n == 0 -> p == 0. +induction n. unfold pow; simpl. intros. absurd (1 == 0). +simpl. apply integral_domain_one_zero. + trivial. setoid_replace (pow p (S n)) with (p * (pow p n)). +intros. +case (integral_domain_product p (pow p n) H). trivial. trivial. +unfold pow; simpl. +clear IHn. induction n; simpl; try cring. + rewrite Ring_theory.pow_pos_succ. cring. apply ring_setoid. +apply ring_mult_comp. +apply ring_mul_assoc. +Qed. + +Lemma Rintegral_domain_pow: + forall c p r, ~c == 0 -> c * (pow p r) == ring0 -> p == ring0. +intros. case (integral_domain_product c (pow p r) H0). intros; absurd (c == ring0); auto. +intros. apply pow_not_zero with r. trivial. Qed. + +End integral_domain. + diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v index 8d7cb0ea..fae98d83 100644 --- a/plugins/setoid_ring/NArithRing.v +++ b/plugins/setoid_ring/NArithRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -18,4 +18,4 @@ Ltac Ncst t := | _ => constr:NotConstant end. -Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]). +Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]). diff --git a/plugins/setoid_ring/Ncring.v b/plugins/setoid_ring/Ncring.v new file mode 100644 index 00000000..7789ba3e --- /dev/null +++ b/plugins/setoid_ring/Ncring.v @@ -0,0 +1,306 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* non commutative rings *) + +Require Import Setoid. +Require Import BinPos. +Require Import BinNat. +Require Export Morphisms Setoid Bool. +Require Export ZArith_base. +Require Export Algebra_syntax. + +Set Implicit Arguments. + +Class Ring_ops(T:Type) + {ring0:T} + {ring1:T} + {add:T->T->T} + {mul:T->T->T} + {sub:T->T->T} + {opp:T->T} + {ring_eq:T->T->Prop}. + +Instance zero_notation(T:Type)`{Ring_ops T}:Zero T:= ring0. +Instance one_notation(T:Type)`{Ring_ops T}:One T:= ring1. +Instance add_notation(T:Type)`{Ring_ops T}:Addition T:= add. +Instance mul_notation(T:Type)`{Ring_ops T}:@Multiplication T T:= mul. +Instance sub_notation(T:Type)`{Ring_ops T}:Subtraction T:= sub. +Instance opp_notation(T:Type)`{Ring_ops T}:Opposite T:= opp. +Instance eq_notation(T:Type)`{Ring_ops T}:@Equality T:= ring_eq. + +Class Ring `{Ro:Ring_ops}:={ + ring_setoid: Equivalence _==_; + ring_plus_comp: Proper (_==_ ==> _==_ ==>_==_) _+_; + ring_mult_comp: Proper (_==_ ==> _==_ ==>_==_) _*_; + ring_sub_comp: Proper (_==_ ==> _==_ ==>_==_) _-_; + ring_opp_comp: Proper (_==_==>_==_) -_; + ring_add_0_l : forall x, 0 + x == x; + ring_add_comm : forall x y, x + y == y + x; + ring_add_assoc : forall x y z, x + (y + z) == (x + y) + z; + ring_mul_1_l : forall x, 1 * x == x; + ring_mul_1_r : forall x, x * 1 == x; + ring_mul_assoc : forall x y z, x * (y * z) == (x * y) * z; + ring_distr_l : forall x y z, (x + y) * z == x * z + y * z; + ring_distr_r : forall x y z, z * ( x + y) == z * x + z * y; + ring_sub_def : forall x y, x - y == x + -y; + ring_opp_def : forall x, x + -x == 0 +}. +(* inutile! je sais plus pourquoi j'ai mis ca... +Instance ring_Ring_ops(R:Type)`{Ring R} + :@Ring_ops R 0 1 addition multiplication subtraction opposite equality. +*) +Existing Instance ring_setoid. +Existing Instance ring_plus_comp. +Existing Instance ring_mult_comp. +Existing Instance ring_sub_comp. +Existing Instance ring_opp_comp. + +Section Ring_power. + +Context {R:Type}`{Ring R}. + + Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := + match i with + | xH => x + | xO i => let p := pow_pos x i in p * p + | xI i => let p := pow_pos x i in x * (p * p) + end. + + Definition pow_N (x:R) (p:N) := + match p with + | N0 => 1 + | Npos p => pow_pos x p + end. + +End Ring_power. + +Definition ZN(x:Z):= + match x with + Z0 => N0 + |Zpos p | Zneg p => Npos p +end. + +Instance power_ring {R:Type}`{Ring R} : Power:= + {power x y := pow_N x (ZN y)}. + +(** Interpretation morphisms definition*) + +Class Ring_morphism (C R:Type)`{Cr:Ring C} `{Rr:Ring R}`{Rh:Bracket C R}:= { + ring_morphism0 : [0] == 0; + ring_morphism1 : [1] == 1; + ring_morphism_add : forall x y, [x + y] == [x] + [y]; + ring_morphism_sub : forall x y, [x - y] == [x] - [y]; + ring_morphism_mul : forall x y, [x * y] == [x] * [y]; + ring_morphism_opp : forall x, [-x] == -[x]; + ring_morphism_eq : forall x y, x == y -> [x] == [y]}. + +Section Ring. + +Context {R:Type}`{Rr:Ring R}. + +(* Powers *) + +Lemma pow_pos_comm : forall x j, x * pow_pos x j == pow_pos x j * x. +Proof. +induction j; simpl. rewrite <- ring_mul_assoc. +rewrite <- ring_mul_assoc. +rewrite <- IHj. rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). +rewrite <- IHj. rewrite <- ring_mul_assoc. reflexivity. +rewrite <- ring_mul_assoc. rewrite <- IHj. +rewrite ring_mul_assoc. rewrite IHj. +rewrite <- ring_mul_assoc. rewrite IHj. reflexivity. reflexivity. +Qed. + +Lemma pow_pos_succ : forall x j, pow_pos x (Pos.succ j) == x * pow_pos x j. +Proof. +induction j; simpl. + rewrite IHj. +rewrite <- (ring_mul_assoc x (pow_pos x j) (x * pow_pos x j)). +rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)). + rewrite <- pow_pos_comm. +rewrite <- ring_mul_assoc. reflexivity. +reflexivity. reflexivity. +Qed. + +Lemma pow_pos_add : forall x i j, + pow_pos x (i + j) == pow_pos x i * pow_pos x j. +Proof. + intro x;induction i;intros. + rewrite Pos.xI_succ_xO;rewrite <- Pos.add_1_r. + rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. + repeat rewrite IHi. + rewrite Pos.add_comm;rewrite Pos.add_1_r; + rewrite pow_pos_succ. + simpl;repeat rewrite ring_mul_assoc. reflexivity. + rewrite <- Pos.add_diag;repeat rewrite <- Pos.add_assoc. + repeat rewrite IHi. rewrite ring_mul_assoc. reflexivity. + rewrite Pos.add_comm;rewrite Pos.add_1_r;rewrite pow_pos_succ. + simpl. reflexivity. + Qed. + + Definition id_phi_N (x:N) : N := x. + + Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n. + Proof. + intros; reflexivity. + Qed. + + (** Identity is a morphism *) + (* + Instance IDmorph : Ring_morphism _ _ _ (fun x => x). + Proof. + apply (Build_Ring_morphism H6 H6 (fun x => x));intros; + try reflexivity. trivial. + Qed. +*) + (** rings are almost rings*) + Lemma ring_mul_0_l : forall x, 0 * x == 0. + Proof. + intro x. setoid_replace (0*x) with ((0+1)*x + -x). + rewrite ring_add_0_l. rewrite ring_mul_1_l . + rewrite ring_opp_def . fold zero. reflexivity. + rewrite ring_distr_l . rewrite ring_mul_1_l . + rewrite <- ring_add_assoc ; rewrite ring_opp_def . + rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. + Qed. + + Lemma ring_mul_0_r : forall x, x * 0 == 0. + Proof. + intro x; setoid_replace (x*0) with (x*(0+1) + -x). + rewrite ring_add_0_l ; rewrite ring_mul_1_r . + rewrite ring_opp_def ; fold zero; reflexivity. + + rewrite ring_distr_r ;rewrite ring_mul_1_r . + rewrite <- ring_add_assoc ; rewrite ring_opp_def . + rewrite ring_add_comm ; rewrite ring_add_0_l ;reflexivity. + Qed. + + Lemma ring_opp_mul_l : forall x y, -(x * y) == -x * y. + Proof. + intros x y;rewrite <- (ring_add_0_l (- x * y)). + rewrite ring_add_comm . + rewrite <- (ring_opp_def (x*y)). + rewrite ring_add_assoc . + rewrite <- ring_distr_l. + rewrite (ring_add_comm (-x));rewrite ring_opp_def . + rewrite ring_mul_0_l;rewrite ring_add_0_l ;reflexivity. + Qed. + +Lemma ring_opp_mul_r : forall x y, -(x * y) == x * -y. + Proof. + intros x y;rewrite <- (ring_add_0_l (x * - y)). + rewrite ring_add_comm . + rewrite <- (ring_opp_def (x*y)). + rewrite ring_add_assoc . + rewrite <- ring_distr_r . + rewrite (ring_add_comm (-y));rewrite ring_opp_def . + rewrite ring_mul_0_r;rewrite ring_add_0_l ;reflexivity. + Qed. + + Lemma ring_opp_add : forall x y, -(x + y) == -x + -y. + Proof. + intros x y;rewrite <- (ring_add_0_l (-(x+y))). + rewrite <- (ring_opp_def x). + rewrite <- (ring_add_0_l (x + - x + - (x + y))). + rewrite <- (ring_opp_def y). + rewrite (ring_add_comm x). + rewrite (ring_add_comm y). + rewrite <- (ring_add_assoc (-y)). + rewrite <- (ring_add_assoc (- x)). + rewrite (ring_add_assoc y). + rewrite (ring_add_comm y). + rewrite <- (ring_add_assoc (- x)). + rewrite (ring_add_assoc y). + rewrite (ring_add_comm y);rewrite ring_opp_def . + rewrite (ring_add_comm (-x) 0);rewrite ring_add_0_l . + rewrite ring_add_comm; reflexivity. + Qed. + + Lemma ring_opp_opp : forall x, - -x == x. + Proof. + intros x; rewrite <- (ring_add_0_l (- -x)). + rewrite <- (ring_opp_def x). + rewrite <- ring_add_assoc ; rewrite ring_opp_def . + rewrite (ring_add_comm x); rewrite ring_add_0_l . reflexivity. + Qed. + + Lemma ring_sub_ext : + forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. + Proof. + intros. + setoid_replace (x1 - y1) with (x1 + -y1). + setoid_replace (x2 - y2) with (x2 + -y2). + rewrite H;rewrite H0;reflexivity. + rewrite ring_sub_def. reflexivity. + rewrite ring_sub_def. reflexivity. + Qed. + + Ltac mrewrite := + repeat first + [ rewrite ring_add_0_l + | rewrite <- (ring_add_comm 0) + | rewrite ring_mul_1_l + | rewrite ring_mul_0_l + | rewrite ring_distr_l + | reflexivity + ]. + + Lemma ring_add_0_r : forall x, (x + 0) == x. + Proof. intros; mrewrite. Qed. + + + Lemma ring_add_assoc1 : forall x y z, (x + y) + z == (y + z) + x. + Proof. + intros;rewrite <- (ring_add_assoc x). + rewrite (ring_add_comm x);reflexivity. + Qed. + + Lemma ring_add_assoc2 : forall x y z, (y + x) + z == (y + z) + x. + Proof. + intros; repeat rewrite <- ring_add_assoc. + rewrite (ring_add_comm x); reflexivity. + Qed. + + Lemma ring_opp_zero : -0 == 0. + Proof. + rewrite <- (ring_mul_0_r 0). rewrite ring_opp_mul_l. + repeat rewrite ring_mul_0_r. reflexivity. + Qed. + +End Ring. + +(** Some simplification tactics*) +Ltac gen_reflexivity := reflexivity. + +Ltac gen_rewrite := + repeat first + [ reflexivity + | progress rewrite ring_opp_zero + | rewrite ring_add_0_l + | rewrite ring_add_0_r + | rewrite ring_mul_1_l + | rewrite ring_mul_1_r + | rewrite ring_mul_0_l + | rewrite ring_mul_0_r + | rewrite ring_distr_l + | rewrite ring_distr_r + | rewrite ring_add_assoc + | rewrite ring_mul_assoc + | progress rewrite ring_opp_add + | progress rewrite ring_sub_def + | progress rewrite <- ring_opp_mul_l + | progress rewrite <- ring_opp_mul_r ]. + +Ltac gen_add_push x := +repeat (match goal with + | |- context [(?y + x) + ?z] => + progress rewrite (ring_add_assoc2 x y z) + | |- context [(x + ?y) + ?z] => + progress rewrite (ring_add_assoc1 x y z) + end). diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v new file mode 100644 index 00000000..528ad4f1 --- /dev/null +++ b/plugins/setoid_ring/Ncring_initial.v @@ -0,0 +1,209 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import ZArith_base. +Require Import Zpow_def. +Require Import BinInt. +Require Import BinNat. +Require Import Setoid. +Require Import BinList. +Require Import BinPos. +Require Import BinNat. +Require Import BinInt. +Require Import Setoid. +Require Export Ncring. +Require Export Ncring_polynom. +Import List. + +Set Implicit Arguments. + +(* An object to return when an expression is not recognized as a constant *) +Definition NotConstant := false. + +(** Z is a ring and a setoid*) + +Lemma Zsth : Equivalence (@eq Z). +Proof. exact Z.eq_equiv. Qed. + +Instance Zops:@Ring_ops Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z). + +Instance Zr: (@Ring _ _ _ _ _ _ _ _ Zops). +Proof. +constructor; try apply Zsth; try solve_proper. + exact Z.add_comm. exact Z.add_assoc. + exact Z.mul_1_l. exact Z.mul_1_r. exact Z.mul_assoc. + exact Z.mul_add_distr_r. intros; apply Z.mul_add_distr_l. exact Z.sub_diag. +Defined. + +(*Instance ZEquality: @Equality Z:= (@eq Z).*) + +(** Two generic morphisms from Z to (abrbitrary) rings, *) +(**second one is more convenient for proofs but they are ext. equal*) +Section ZMORPHISM. +Context {R:Type}`{Ring R}. + + Ltac rrefl := reflexivity. + + Fixpoint gen_phiPOS1 (p:positive) : R := + match p with + | xH => 1 + | xO p => (1 + 1) * (gen_phiPOS1 p) + | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p)) + end. + + Fixpoint gen_phiPOS (p:positive) : R := + match p with + | xH => 1 + | xO xH => (1 + 1) + | xO p => (1 + 1) * (gen_phiPOS p) + | xI xH => 1 + (1 +1) + | xI p => 1 + ((1 + 1) * (gen_phiPOS p)) + end. + + Definition gen_phiZ1 z := + match z with + | Zpos p => gen_phiPOS1 p + | Z0 => 0 + | Zneg p => -(gen_phiPOS1 p) + end. + + Definition gen_phiZ z := + match z with + | Zpos p => gen_phiPOS p + | Z0 => 0 + | Zneg p => -(gen_phiPOS p) + end. + Notation "[ x ]" := (gen_phiZ x). + + Definition get_signZ z := + match z with + | Zneg p => Some (Zpos p) + | _ => None + end. + + Ltac norm := gen_rewrite. + Ltac add_push := Ncring.gen_add_push. +Ltac rsimpl := simpl. + + Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. + Proof. + induction x;rsimpl. + rewrite IHx. destruct x;simpl;norm. + rewrite IHx;destruct x;simpl;norm. + reflexivity. + Qed. + + Lemma ARgen_phiPOS_Psucc : forall x, + gen_phiPOS1 (Pos.succ x) == 1 + (gen_phiPOS1 x). + Proof. + induction x;rsimpl;norm. + rewrite IHx. gen_rewrite. add_push 1. reflexivity. + Qed. + + Lemma ARgen_phiPOS_add : forall x y, + gen_phiPOS1 (x + y) == (gen_phiPOS1 x) + (gen_phiPOS1 y). + Proof. + induction x;destruct y;simpl;norm. + rewrite Pos.add_carry_spec. + rewrite ARgen_phiPOS_Psucc. + rewrite IHx;norm. + add_push (gen_phiPOS1 y);add_push 1;reflexivity. + rewrite IHx;norm;add_push (gen_phiPOS1 y);reflexivity. + rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity. + rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;reflexivity. + rewrite IHx;norm;add_push(gen_phiPOS1 y);reflexivity. + add_push 1;reflexivity. + rewrite ARgen_phiPOS_Psucc;norm;add_push 1;reflexivity. + Qed. + + Lemma ARgen_phiPOS_mult : + forall x y, gen_phiPOS1 (x * y) == gen_phiPOS1 x * gen_phiPOS1 y. + Proof. + induction x;intros;simpl;norm. + rewrite ARgen_phiPOS_add;simpl;rewrite IHx;norm. + rewrite IHx;reflexivity. + Qed. + + +(*morphisms are extensionaly equal*) + Lemma same_genZ : forall x, [x] == gen_phiZ1 x. + Proof. + destruct x;rsimpl; try rewrite same_gen; reflexivity. + Qed. + + Lemma gen_Zeqb_ok : forall x y, + Zeq_bool x y = true -> [x] == [y]. + Proof. + intros x y H7. + assert (H10 := Zeq_bool_eq x y H7);unfold IDphi in H10. + rewrite H10;reflexivity. + Qed. + + Lemma gen_phiZ1_add_pos_neg : forall x y, + gen_phiZ1 (Z.pos_sub x y) + == gen_phiPOS1 x + -gen_phiPOS1 y. + Proof. + intros x y. + generalize (Z.pos_sub_discr x y). + destruct (Z.pos_sub x y) as [|p|p]; intros; subst. + - now rewrite ring_opp_def. + - rewrite ARgen_phiPOS_add;simpl;norm. + add_push (gen_phiPOS1 p). rewrite ring_opp_def;norm. + - rewrite ARgen_phiPOS_add;simpl;norm. + rewrite ring_opp_def;norm. + Qed. + + Lemma match_compOpp : forall x (B:Type) (be bl bg:B), + match CompOpp x with Eq => be | Lt => bl | Gt => bg end + = match x with Eq => be | Lt => bg | Gt => bl end. + Proof. destruct x;simpl;intros;trivial. Qed. + + Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y]. + Proof. + intros x y; repeat rewrite same_genZ; generalize x y;clear x y. + induction x;destruct y;simpl;norm. + apply ARgen_phiPOS_add. + apply gen_phiZ1_add_pos_neg. + rewrite gen_phiZ1_add_pos_neg. rewrite ring_add_comm. +reflexivity. + rewrite ARgen_phiPOS_add. rewrite ring_opp_add. reflexivity. +Qed. + +Lemma gen_phiZ_opp : forall x, [- x] == - [x]. + Proof. + intros x. repeat rewrite same_genZ. generalize x ;clear x. + induction x;simpl;norm. + rewrite ring_opp_opp. reflexivity. + Qed. + + Lemma gen_phiZ_mul : forall x y, [x * y] == [x] * [y]. + Proof. + intros x y;repeat rewrite same_genZ. + destruct x;destruct y;simpl;norm; + rewrite ARgen_phiPOS_mult;try (norm;fail). + rewrite ring_opp_opp ;reflexivity. + Qed. + + Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y]. + Proof. intros;subst;reflexivity. Qed. + +(*proof that [.] satisfies morphism specifications*) +Global Instance gen_phiZ_morph : +(@Ring_morphism (Z:Type) R _ _ _ _ _ _ _ Zops Zr _ _ _ _ _ _ _ _ _ gen_phiZ) . (* beurk!*) + apply Build_Ring_morphism; simpl;try reflexivity. + apply gen_phiZ_add. intros. rewrite ring_sub_def. +replace (x-y)%Z with (x + (-y))%Z. +now rewrite gen_phiZ_add, gen_phiZ_opp, ring_sub_def. +reflexivity. + apply gen_phiZ_mul. apply gen_phiZ_opp. apply gen_phiZ_ext. + Defined. + +End ZMORPHISM. + +Instance multiplication_phi_ring{R:Type}`{Ring R} : Multiplication := + {multiplication x y := (gen_phiZ x) * y}. diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v new file mode 100644 index 00000000..8e4b613f --- /dev/null +++ b/plugins/setoid_ring/Ncring_polynom.v @@ -0,0 +1,584 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* A <X1,...,Xn>: non commutative polynomials on a commutative ring A *) + +Set Implicit Arguments. +Require Import Setoid. +Require Import BinList. +Require Import BinPos. +Require Import BinNat. +Require Import BinInt. +Require Export Ring_polynom. (* n'utilise que PExpr *) +Require Export Ncring. + +Section MakeRingPol. + +Context (C R:Type) `{Rh:Ring_morphism C R}. + +Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. + + Ltac rsimpl := repeat (gen_rewrite || rewrite phiCR_comm). + Ltac add_push := gen_add_push . + +(* Definition of non commutative multivariable polynomials + with coefficients in C : + *) + + Inductive Pol : Type := + | Pc : C -> Pol + | PX : Pol -> positive -> positive -> Pol -> Pol. + (* PX P i n Q represents P * X_i^n + Q *) +Definition cO:C . exact ring0. Defined. +Definition cI:C . exact ring1. Defined. + + Definition P0 := Pc 0. + Definition P1 := Pc 1. + +Variable Ceqb:C->C->bool. +Class Equalityb (A : Type):= {equalityb : A -> A -> bool}. +Notation "x =? y" := (equalityb x y) (at level 70, no associativity). +Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y). + +Instance equalityb_coef : Equalityb C := + {equalityb x y := Ceqb x y}. + + Fixpoint Peq (P P' : Pol) {struct P'} : bool := + match P, P' with + | Pc c, Pc c' => c =? c' + | PX P i n Q, PX P' i' n' Q' => + match Pos.compare i i', Pos.compare n n' with + | Eq, Eq => if Peq P P' then Peq Q Q' else false + | _,_ => false + end + | _, _ => false + end. + +Instance equalityb_pol : Equalityb Pol := + {equalityb x y := Peq x y}. + +(* Q a ses variables de queue < i *) + Definition mkPX P i n Q := + match P with + | Pc c => if c =? 0 then Q else PX P i n Q + | PX P' i' n' Q' => + match Pos.compare i i' with + | Eq => if Q' =? P0 then PX P' i (n + n') Q else PX P i n Q + | _ => PX P i n Q + end + end. + + Definition mkXi i n := PX P1 i n P0. + + Definition mkX i := mkXi i 1. + + (** Opposite of addition *) + + Fixpoint Popp (P:Pol) : Pol := + match P with + | Pc c => Pc (- c) + | PX P i n Q => PX (Popp P) i n (Popp Q) + end. + + Notation "-- P" := (Popp P)(at level 30). + + (** Addition et subtraction *) + + Fixpoint PaddCl (c:C)(P:Pol) {struct P} : Pol := + match P with + | Pc c1 => Pc (c + c1) + | PX P i n Q => PX P i n (PaddCl c Q) + end. + +(* Q quelconque *) + +Section PaddX. +Variable Padd:Pol->Pol->Pol. +Variable P:Pol. + +(* Xi^n * P + Q +les variables de tete de Q ne sont pas forcement < i +mais Q est normalisé : variables de tete decroissantes *) + +Fixpoint PaddX (i n:positive)(Q:Pol){struct Q}:= + match Q with + | Pc c => mkPX P i n Q + | PX P' i' n' Q' => + match Pos.compare i i' with + | (* i > i' *) + Gt => mkPX P i n Q + | (* i < i' *) + Lt => mkPX P' i' n' (PaddX i n Q') + | (* i = i' *) + Eq => match Z.pos_sub n n' with + | (* n > n' *) + Zpos k => mkPX (PaddX i k P') i' n' Q' + | (* n = n' *) + Z0 => mkPX (Padd P P') i n Q' + | (* n < n' *) + Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' + end + end + end. + +End PaddX. + +Fixpoint Padd (P1 P2: Pol) {struct P1} : Pol := + match P1 with + | Pc c => PaddCl c P2 + | PX P' i' n' Q' => + PaddX Padd P' i' n' (Padd Q' P2) + end. + + Notation "P ++ P'" := (Padd P P'). + +Definition Psub(P P':Pol):= P ++ (--P'). + + Notation "P -- P'" := (Psub P P')(at level 50). + + (** Multiplication *) + + Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := + match P with + | Pc c' => Pc (c' * c) + | PX P i n Q => mkPX (PmulC_aux P c) i n (PmulC_aux Q c) + end. + + Definition PmulC P c := + if c =? 0 then P0 else + if c =? 1 then P else PmulC_aux P c. + + Fixpoint Pmul (P1 P2 : Pol) {struct P2} : Pol := + match P2 with + | Pc c => PmulC P1 c + | PX P i n Q => + PaddX Padd (Pmul P1 P) i n (Pmul P1 Q) + end. + + Notation "P ** P'" := (Pmul P P')(at level 40). + + Definition Psquare (P:Pol) : Pol := P ** P. + + + (** Evaluation of a polynomial towards R *) + + Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R := + match P with + | Pc c => [c] + | PX P i n Q => + let x := nth 0 i l in + let xn := pow_pos x n in + (Pphi l P) * xn + (Pphi l Q) + end. + + Reserved Notation "P @ l " (at level 10, no associativity). + Notation "P @ l " := (Pphi l P). + + (** Proofs *) + + Ltac destr_pos_sub H := + match goal with |- context [Z.pos_sub ?x ?y] => + assert (H := Z.pos_sub_discr x y); destruct (Z.pos_sub x y) + end. + + Lemma Peq_ok : forall P P', + (P =? P') = true -> forall l, P@l == P'@ l. + Proof. + induction P;destruct P';simpl;intros ;try easy. + - now apply ring_morphism_eq, Ceqb_eq. + - specialize (IHP1 P'1). specialize (IHP2 P'2). + simpl in IHP1, IHP2. + destruct (Pos.compare_spec p p1); try discriminate; + destruct (Pos.compare_spec p0 p2); try discriminate. + destruct (Peq P2 P'1); try discriminate. + subst; now rewrite IHP1, IHP2. + Qed. + + Lemma Pphi0 : forall l, P0@l == 0. + Proof. + intros;simpl. + rewrite ring_morphism0. reflexivity. + Qed. + + Lemma Pphi1 : forall l, P1@l == 1. + Proof. + intros;simpl; rewrite ring_morphism1. reflexivity. + Qed. + + Lemma mkPX_ok : forall l P i n Q, + (mkPX P i n Q)@l == P@l * (pow_pos (nth 0 i l) n) + Q@l. + Proof. + intros l P i n Q;unfold mkPX. + destruct P;try (simpl;reflexivity). + assert (Hh := ring_morphism_eq c 0). +simpl; case_eq (Ceqb c 0);simpl;try reflexivity. +intros. + rewrite Hh. rewrite ring_morphism0. + rsimpl. apply Ceqb_eq. trivial. + destruct (Pos.compare_spec i p). + assert (Hh := @Peq_ok P3 P0). case_eq (P3=? P0). intro. simpl. + rewrite Hh. + rewrite Pphi0. rsimpl. rewrite Pos.add_comm. rewrite pow_pos_add;rsimpl. + subst;trivial. reflexivity. trivial. intros. simpl. reflexivity. simpl. reflexivity. + simpl. reflexivity. + Qed. + +Ltac Esimpl := + repeat (progress ( + match goal with + | |- context [?P@?l] => + match P with + | P0 => rewrite (Pphi0 l) + | P1 => rewrite (Pphi1 l) + | (mkPX ?P ?i ?n ?Q) => rewrite (mkPX_ok l P i n Q) + end + | |- context [[?c]] => + match c with + | 0 => rewrite ring_morphism0 + | 1 => rewrite ring_morphism1 + | ?x + ?y => rewrite ring_morphism_add + | ?x * ?y => rewrite ring_morphism_mul + | ?x - ?y => rewrite ring_morphism_sub + | - ?x => rewrite ring_morphism_opp + end + end)); + simpl; rsimpl. + + Lemma PaddCl_ok : forall c P l, (PaddCl c P)@l == [c] + P@l . + Proof. + induction P; simpl; intros; Esimpl; try reflexivity. + rewrite IHP2. rsimpl. +rewrite (ring_add_comm (P2 @ l * pow_pos (nth 0 p l) p0) [c]). +reflexivity. + Qed. + + Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. + Proof. + induction P;simpl;intros. rewrite ring_morphism_mul. +try reflexivity. + simpl. Esimpl. rewrite IHP1;rewrite IHP2;rsimpl. + Qed. + + Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. + Proof. + intros c P l; unfold PmulC. + assert (Hh:= ring_morphism_eq c 0);case_eq (c =? 0). intros. + rewrite Hh;Esimpl. apply Ceqb_eq;trivial. + assert (H1h:= ring_morphism_eq c 1);case_eq (c =? 1);intros. + rewrite H1h;Esimpl. apply Ceqb_eq;trivial. + apply PmulC_aux_ok. + Qed. + + Lemma Popp_ok : forall P l, (--P)@l == - P@l. + Proof. + induction P;simpl;intros. + Esimpl. + rewrite IHP1;rewrite IHP2;rsimpl. + Qed. + + Ltac Esimpl2 := + Esimpl; + repeat (progress ( + match goal with + | |- context [(PaddCl ?c ?P)@?l] => rewrite (PaddCl_ok c P l) + | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) + | |- context [(--?P)@?l] => rewrite (Popp_ok P l) + end)); Esimpl. + +Lemma PaddXPX: forall P i n Q, + PaddX Padd P i n Q = + match Q with + | Pc c => mkPX P i n Q + | PX P' i' n' Q' => + match Pos.compare i i' with + | (* i > i' *) + Gt => mkPX P i n Q + | (* i < i' *) + Lt => mkPX P' i' n' (PaddX Padd P i n Q') + | (* i = i' *) + Eq => match Z.pos_sub n n' with + | (* n > n' *) + Zpos k => mkPX (PaddX Padd P i k P') i' n' Q' + | (* n = n' *) + Z0 => mkPX (Padd P P') i n Q' + | (* n < n' *) + Zneg k => mkPX (Padd P (mkPX P' i k P0)) i n Q' + end + end + end. +induction Q; reflexivity. +Qed. + +Lemma PaddX_ok2 : forall P2, + (forall P l, (P2 ++ P) @ l == P2 @ l + P @ l) + /\ + (forall P k n l, + (PaddX Padd P2 k n P) @ l == + P2 @ l * pow_pos (nth 0 k l) n + P @ l). +induction P2;simpl;intros. split. intros. apply PaddCl_ok. + induction P. unfold PaddX. intros. rewrite mkPX_ok. + simpl. rsimpl. +intros. simpl. + destruct (Pos.compare_spec k p) as [Hh|Hh|Hh]. + destr_pos_sub H1h. Esimpl2. +rewrite Hh; trivial. rewrite H1h. reflexivity. +simpl. rewrite mkPX_ok. rewrite IHP1. Esimpl2. + rewrite Pos.add_comm in H1h. +rewrite H1h. +rewrite pow_pos_add. Esimpl2. +rewrite Hh; trivial. reflexivity. +rewrite mkPX_ok. rewrite PaddCl_ok. Esimpl2. rewrite Pos.add_comm in H1h. +rewrite H1h. Esimpl2. rewrite pow_pos_add. Esimpl2. +rewrite Hh; trivial. reflexivity. +rewrite mkPX_ok. rewrite IHP2. Esimpl2. +rewrite (ring_add_comm (P2 @ l * pow_pos (nth 0 p l) p0) + ([c] * pow_pos (nth 0 k l) n)). +reflexivity. assert (H1h := ring_morphism_eq c 0);case_eq (Ceqb c 0); + intros; simpl. +rewrite H1h;trivial. Esimpl2. apply Ceqb_eq; trivial. reflexivity. +decompose [and] IHP2_1. decompose [and] IHP2_2. clear IHP2_1 IHP2_2. +split. intros. rewrite H0. rewrite H1. +Esimpl2. +induction P. unfold PaddX. intros. rewrite mkPX_ok. simpl. reflexivity. +intros. rewrite PaddXPX. +destruct (Pos.compare_spec k p1) as [H3h|H3h|H3h]. +destr_pos_sub H4h. +rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. Esimpl2. +rewrite H4h. rewrite H3h;trivial. reflexivity. +rewrite mkPX_ok. rewrite IHP1. Esimpl2. rewrite H3h;trivial. +rewrite Pos.add_comm in H4h. +rewrite H4h. rewrite pow_pos_add. Esimpl2. +rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. +rewrite mkPX_ok. + Esimpl2. rewrite H3h;trivial. + rewrite Pos.add_comm in H4h. +rewrite H4h. rewrite pow_pos_add. Esimpl2. +rewrite mkPX_ok. simpl. rewrite IHP2. Esimpl2. +gen_add_push (P2 @ l * pow_pos (nth 0 p1 l) p2). try reflexivity. +rewrite mkPX_ok. simpl. reflexivity. +Qed. + +Lemma Padd_ok : forall P Q l, (P ++ Q) @ l == P @ l + Q @ l. +intro P. elim (PaddX_ok2 P); auto. +Qed. + +Lemma PaddX_ok : forall P2 P k n l, + (PaddX Padd P2 k n P) @ l == P2 @ l * pow_pos (nth 0 k l) n + P @ l. +intro P2. elim (PaddX_ok2 P2); auto. +Qed. + + Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. +unfold Psub. intros. rewrite Padd_ok. rewrite Popp_ok. rsimpl. + Qed. + + Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. +induction P'; simpl; intros. rewrite PmulC_ok. reflexivity. +rewrite PaddX_ok. rewrite IHP'1. rewrite IHP'2. Esimpl2. +Qed. + + Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. + Proof. + intros. unfold Psquare. apply Pmul_ok. + Qed. + + (** Definition of polynomial expressions *) + +(* + Inductive PExpr : Type := + | PEc : C -> PExpr + | PEX : positive -> PExpr + | PEadd : PExpr -> PExpr -> PExpr + | PEsub : PExpr -> PExpr -> PExpr + | PEmul : PExpr -> PExpr -> PExpr + | PEopp : PExpr -> PExpr + | PEpow : PExpr -> N -> PExpr. +*) + + (** Specification of the power function *) + Section POWER. + Variable Cpow : Set. + Variable Cp_phi : N -> Cpow. + Variable rpow : R -> Cpow -> R. + + Record power_theory : Prop := mkpow_th { + rpow_pow_N : forall r n, (rpow r (Cp_phi n))== (pow_N r n) + }. + + End POWER. + Variable Cpow : Set. + Variable Cp_phi : N -> Cpow. + Variable rpow : R -> Cpow -> R. + Variable pow_th : power_theory Cp_phi rpow. + + (** evaluation of polynomial expressions towards R *) + Fixpoint PEeval (l:list R) (pe:PExpr C) {struct pe} : R := + match pe with + | PEc c => [c] + | PEX j => nth 0 j l + | PEadd pe1 pe2 => (PEeval l pe1) + (PEeval l pe2) + | PEsub pe1 pe2 => (PEeval l pe1) - (PEeval l pe2) + | PEmul pe1 pe2 => (PEeval l pe1) * (PEeval l pe2) + | PEopp pe1 => - (PEeval l pe1) + | PEpow pe1 n => rpow (PEeval l pe1) (Cp_phi n) + end. + +Strategy expand [PEeval]. + + Definition mk_X j := mkX j. + + (** Correctness proofs *) + + Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. + Proof. + destruct p;simpl;intros;Esimpl;trivial. + Qed. + + Ltac Esimpl3 := + repeat match goal with + | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P1 P2 l) + | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P1 P2 l) + end;try Esimpl2;try reflexivity;try apply ring_add_comm. + +(* Power using the chinise algorithm *) + +Section POWER2. + Variable subst_l : Pol -> Pol. + Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := + match p with + | xH => subst_l (Pmul P res) + | xO p => Ppow_pos (Ppow_pos res P p) P p + | xI p => subst_l (Pmul P (Ppow_pos (Ppow_pos res P p) P p)) + end. + + Definition Ppow_N P n := + match n with + | N0 => P1 + | Npos p => Ppow_pos P1 P p + end. + + Fixpoint pow_pos_gen (R:Type)(m:R->R->R)(x:R) (i:positive) {struct i}: R := + match i with + | xH => x + | xO i => let p := pow_pos_gen m x i in m p p + | xI i => let p := pow_pos_gen m x i in m x (m p p) + end. + +Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall res P p, (Ppow_pos res P p)@l == (pow_pos_gen Pmul P p)@l * res@l. + Proof. + intros l subst_l_ok res P p. generalize res;clear res. + induction p;simpl;intros. try rewrite subst_l_ok. + repeat rewrite Pmul_ok. repeat rewrite IHp. + rsimpl. repeat rewrite Pmul_ok. repeat rewrite IHp. rsimpl. + try rewrite subst_l_ok. + repeat rewrite Pmul_ok. reflexivity. + Qed. + +Definition pow_N_gen (R:Type)(x1:R)(m:R->R->R)(x:R) (p:N) := + match p with + | N0 => x1 + | Npos p => pow_pos_gen m x p + end. + + Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> + forall P n, (Ppow_N P n)@l == (pow_N_gen P1 Pmul P n)@l. + Proof. destruct n;simpl. reflexivity. rewrite Ppow_pos_ok; trivial. Esimpl. Qed. + + End POWER2. + + (** Normalization and rewriting *) + + Section NORM_SUBST_REC. + Let subst_l (P:Pol) := P. + Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2). + Let Ppow_subst := Ppow_N subst_l. + + Fixpoint norm_aux (pe:PExpr C) : Pol := + match pe with + | PEc c => Pc c + | PEX j => mk_X j + | PEadd pe1 (PEopp pe2) => + Psub (norm_aux pe1) (norm_aux pe2) + | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) + | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) + | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) + | PEopp pe1 => Popp (norm_aux pe1) + | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n + end. + + Definition norm_subst pe := subst_l (norm_aux pe). + + + Lemma norm_aux_spec : + forall l pe, + PEeval l pe == (norm_aux pe)@l. + Proof. + intros. + induction pe. +Esimpl3. Esimpl3. simpl. + rewrite IHpe1;rewrite IHpe2. + destruct pe2; Esimpl3. +unfold Psub. +destruct pe1; destruct pe2; rewrite Padd_ok; rewrite Popp_ok; reflexivity. +simpl. unfold Psub. rewrite IHpe1;rewrite IHpe2. +destruct pe1. destruct pe2; rewrite Padd_ok; rewrite Popp_ok; try reflexivity. +Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. + Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. Esimpl3. +simpl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. reflexivity. +simpl. rewrite IHpe; Esimpl3. +simpl. + rewrite Ppow_N_ok; (intros;try reflexivity). + rewrite rpow_pow_N. Esimpl3. + induction n;simpl. Esimpl3. induction p; simpl. + try rewrite IHp;try rewrite IHpe; + repeat rewrite Pms_ok; + repeat rewrite Pmul_ok;reflexivity. +rewrite Pmul_ok. try rewrite IHp;try rewrite IHpe; + repeat rewrite Pms_ok; + repeat rewrite Pmul_ok;reflexivity. trivial. +exact pow_th. + Qed. + + Lemma norm_subst_spec : + forall l pe, + PEeval l pe == (norm_subst pe)@l. + Proof. + intros;unfold norm_subst. + unfold subst_l. apply norm_aux_spec. + Qed. + + End NORM_SUBST_REC. + + Fixpoint interp_PElist (l:list R) (lpe:list (PExpr C * PExpr C)) {struct lpe} : Prop := + match lpe with + | nil => True + | (me,pe)::lpe => + match lpe with + | nil => PEeval l me == PEeval l pe + | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe + end + end. + + + Lemma norm_subst_ok : forall l pe, + PEeval l pe == (norm_subst pe)@l. + Proof. + intros;apply norm_subst_spec. + Qed. + + + Lemma ring_correct : forall l pe1 pe2, + (norm_subst pe1 =? norm_subst pe2) = true -> + PEeval l pe1 == PEeval l pe2. + Proof. + simpl;intros. + do 2 (rewrite (norm_subst_ok l);trivial). + apply Peq_ok;trivial. + Qed. + +End MakeRingPol. diff --git a/plugins/setoid_ring/Ncring_tac.v b/plugins/setoid_ring/Ncring_tac.v new file mode 100644 index 00000000..44f8e7ff --- /dev/null +++ b/plugins/setoid_ring/Ncring_tac.v @@ -0,0 +1,308 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Import List. +Require Import Setoid. +Require Import BinPos. +Require Import BinList. +Require Import Znumtheory. +Require Export Morphisms Setoid Bool. +Require Import ZArith. +Require Import Algebra_syntax. +Require Export Ncring. +Require Import Ncring_polynom. +Require Import Ncring_initial. + + +Set Implicit Arguments. + +Class nth (R:Type) (t:R) (l:list R) (i:nat). + +Instance Ifind0 (R:Type) (t:R) l + : nth t(t::l) 0. + +Instance IfindS (R:Type) (t2 t1:R) l i + {_:nth t1 l i} + : nth t1 (t2::l) (S i) | 1. + +Class closed (T:Type) (l:list T). + +Instance Iclosed_nil T + : closed (T:=T) nil. + +Instance Iclosed_cons T t (l:list T) + {_:closed l} + : closed (t::l). + +Class reify (R:Type)`{Rr:Ring (T:=R)} (e:PExpr Z) (lvar:list R) (t:R). + +Instance reify_zero (R:Type) lvar op + `{Ring (T:=R)(ring0:=op)} + : reify (ring0:=op)(PEc 0%Z) lvar op. + +Instance reify_one (R:Type) lvar op + `{Ring (T:=R)(ring1:=op)} + : reify (ring1:=op) (PEc 1%Z) lvar op. + +Instance reifyZ0 (R:Type) lvar + `{Ring (T:=R)} + : reify (PEc Z0) lvar Z0|11. + +Instance reifyZpos (R:Type) lvar (p:positive) + `{Ring (T:=R)} + : reify (PEc (Zpos p)) lvar (Zpos p)|11. + +Instance reifyZneg (R:Type) lvar (p:positive) + `{Ring (T:=R)} + : reify (PEc (Zneg p)) lvar (Zneg p)|11. + +Instance reify_add (R:Type) + e1 lvar t1 e2 t2 op + `{Ring (T:=R)(add:=op)} + {_:reify (add:=op) e1 lvar t1} + {_:reify (add:=op) e2 lvar t2} + : reify (add:=op) (PEadd e1 e2) lvar (op t1 t2). + +Instance reify_mul (R:Type) + e1 lvar t1 e2 t2 op + `{Ring (T:=R)(mul:=op)} + {_:reify (mul:=op) e1 lvar t1} + {_:reify (mul:=op) e2 lvar t2} + : reify (mul:=op) (PEmul e1 e2) lvar (op t1 t2)|10. + +Instance reify_mul_ext (R:Type) `{Ring R} + lvar z e2 t2 + `{Ring (T:=R)} + {_:reify e2 lvar t2} + : reify (PEmul (PEc z) e2) lvar + (@multiplication Z _ _ z t2)|9. + +Instance reify_sub (R:Type) + e1 lvar t1 e2 t2 op + `{Ring (T:=R)(sub:=op)} + {_:reify (sub:=op) e1 lvar t1} + {_:reify (sub:=op) e2 lvar t2} + : reify (sub:=op) (PEsub e1 e2) lvar (op t1 t2). + +Instance reify_opp (R:Type) + e1 lvar t1 op + `{Ring (T:=R)(opp:=op)} + {_:reify (opp:=op) e1 lvar t1} + : reify (opp:=op) (PEopp e1) lvar (op t1). + +Instance reify_pow (R:Type) `{Ring R} + e1 lvar t1 n + `{Ring (T:=R)} + {_:reify e1 lvar t1} + : reify (PEpow e1 n) lvar (pow_N t1 n)|1. + +Instance reify_var (R:Type) t lvar i + `{nth R t lvar i} + `{Rr: Ring (T:=R)} + : reify (Rr:= Rr) (PEX Z (Pos.of_succ_nat i))lvar t + | 100. + +Class reifylist (R:Type)`{Rr:Ring (T:=R)} (lexpr:list (PExpr Z)) (lvar:list R) + (lterm:list R). + +Instance reify_nil (R:Type) lvar + `{Rr: Ring (T:=R)} + : reifylist (Rr:= Rr) nil lvar (@nil R). + +Instance reify_cons (R:Type) e1 lvar t1 lexpr2 lterm2 + `{Rr: Ring (T:=R)} + {_:reify (Rr:= Rr) e1 lvar t1} + {_:reifylist (Rr:= Rr) lexpr2 lvar lterm2} + : reifylist (Rr:= Rr) (e1::lexpr2) lvar (t1::lterm2). + +Definition list_reifyl (R:Type) lexpr lvar lterm + `{Rr: Ring (T:=R)} + {_:reifylist (Rr:= Rr) lexpr lvar lterm} + `{closed (T:=R) lvar} := (lvar,lexpr). + +Unset Implicit Arguments. + + +Ltac lterm_goal g := + match g with + | ?t1 == ?t2 => constr:(t1::t2::nil) + | ?t1 = ?t2 => constr:(t1::t2::nil) + | (_ ?t1 ?t2) => constr:(t1::t2::nil) + end. + +Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y. + intros x y H. rewrite (Zeq_bool_eq x y H). reflexivity. Qed. + +Ltac reify_goal lvar lexpr lterm:= + (*idtac lvar; idtac lexpr; idtac lterm;*) + match lexpr with + nil => idtac + | ?e1::?e2::_ => + match goal with + |- (?op ?u1 ?u2) => + change (op + (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N + (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) + lvar e1) + (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N + (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _) + lvar e2)) + end + end. + +Lemma comm: forall (R:Type)`{Ring R}(c : Z) (x : R), + x * (gen_phiZ c) == (gen_phiZ c) * x. +induction c. intros. simpl. gen_rewrite. simpl. intros. +rewrite <- same_gen. +induction p. simpl. gen_rewrite. rewrite IHp. reflexivity. +simpl. gen_rewrite. rewrite IHp. reflexivity. +simpl. gen_rewrite. +simpl. intros. rewrite <- same_gen. +induction p. simpl. generalize IHp. clear IHp. +gen_rewrite. intro IHp. rewrite IHp. reflexivity. +simpl. generalize IHp. clear IHp. +gen_rewrite. intro IHp. rewrite IHp. reflexivity. +simpl. gen_rewrite. Qed. + +Ltac ring_gen := + match goal with + |- ?g => let lterm := lterm_goal g in + match eval red in (list_reifyl (lterm:=lterm)) with + | (?fv, ?lexpr) => + (*idtac "variables:";idtac fv; + idtac "terms:"; idtac lterm; + idtac "reifications:"; idtac lexpr; *) + reify_goal fv lexpr lterm; + match goal with + |- ?g => + apply (@ring_correct Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ + (@gen_phiZ _ _ _ _ _ _ _ _ _) _ + (@comm _ _ _ _ _ _ _ _ _ _) Zeq_bool Zeqb_ok N (fun n:N => n) + (@pow_N _ _ _ _ _ _ _ _ _)); + [apply mkpow_th; reflexivity + |vm_compute; reflexivity] + end + end + end. + +Ltac non_commutative_ring:= + intros; + ring_gen. + +(* simplification *) + +Ltac ring_simplify_aux lterm fv lexpr hyp := + match lterm with + | ?t0::?lterm => + match lexpr with + | ?e::?le => (* e:PExpr Z est la réification de t0:R *) + let t := constr:(@Ncring_polynom.norm_subst + Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) Zops Zeq_bool e) in + (* t:Pol Z *) + let te := + constr:(@Ncring_polynom.Pphi Z + _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ fv t) in + let eq1 := fresh "ring" in + let nft := eval vm_compute in t in + let t':= fresh "t" in + pose (t' := nft); + assert (eq1 : t = t'); + [vm_cast_no_check (eq_refl t')| + let eq2 := fresh "ring" in + assert (eq2:(@Ncring_polynom.PEeval Z + _ 0 1 _+_ _*_ _-_ -_ _==_ _ Ncring_initial.gen_phiZ N (fun n:N => n) + (@Ring_theory.pow_N _ 1 multiplication) fv e) == te); + [apply (@Ncring_polynom.norm_subst_ok + Z _ 0%Z 1%Z Z.add Z.mul Z.sub Z.opp (@eq Z) + _ _ 0 1 _+_ _*_ _-_ -_ _==_ _ _ Ncring_initial.gen_phiZ _ + (@comm _ 0 1 _+_ _*_ _-_ -_ _==_ _ _) _ Zeqb_ok); + apply mkpow_th; reflexivity + | match hyp with + | 1%nat => rewrite eq2 + | ?H => try rewrite eq2 in H + end]; + let P:= fresh "P" in + match hyp with + | 1%nat => idtac "ok"; + rewrite eq1; + pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ + _ Ncring_initial.gen_phiZ fv t'); + match goal with + |- (?p ?t) => set (P:=p) + end; + unfold t' in *; clear t' eq1 eq2; simpl + | ?H => + rewrite eq1 in H; + pattern (@Ncring_polynom.Pphi Z _ 0 1 _+_ _*_ _-_ -_ _==_ + _ Ncring_initial.gen_phiZ fv t') in H; + match type of H with + | (?p ?t) => set (P:=p) in H + end; + unfold t' in *; clear t' eq1 eq2; simpl in H + end; unfold P in *; clear P + ]; ring_simplify_aux lterm fv le hyp + | nil => idtac + end + | nil => idtac + end. + +Ltac set_variables fv := + match fv with + | nil => idtac + | ?t::?fv => + let v := fresh "X" in + set (v:=t) in *; set_variables fv + end. + +Ltac deset n:= + match n with + | 0%nat => idtac + | S ?n1 => + match goal with + | h:= ?v : ?t |- ?g => unfold h in *; clear h; deset n1 + end + end. + +(* a est soit un terme de l'anneau, soit une liste de termes. +J'ai pas réussi à un décomposer les Vlists obtenues avec ne_constr_list + dans Tactic Notation *) + +Ltac ring_simplify_gen a hyp := + let lterm := + match a with + | _::_ => a + | _ => constr:(a::nil) + end in + match eval red in (list_reifyl (lterm:=lterm)) with + | (?fv, ?lexpr) => idtac lterm; idtac fv; idtac lexpr; + let n := eval compute in (length fv) in + idtac n; + let lt:=fresh "lt" in + set (lt:= lterm); + let lv:=fresh "fv" in + set (lv:= fv); + (* les termes de fv sont remplacés par des variables + pour pouvoir utiliser simpl ensuite sans risquer + des simplifications indésirables *) + set_variables fv; + let lterm1 := eval unfold lt in lt in + let lv1 := eval unfold lv in lv in + idtac lterm1; idtac lv1; + ring_simplify_aux lterm1 lv1 lexpr hyp; + clear lt lv; + (* on remet les termes de fv *) + deset n + end. + +Tactic Notation "non_commutative_ring_simplify" constr(lterm):= + ring_simplify_gen lterm 1%nat. + +Tactic Notation "non_commutative_ring_simplify" constr(lterm) "in" ident(H):= + ring_simplify_gen lterm H. + + diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index 56473adb..29372212 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -5,21 +5,21 @@ Require Import Rdefinitions. Require Import Rpow_def. Require Import Raxioms. -Open Local Scope R_scope. +Local Open 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. + symmetry ; apply Rplus_assoc. intro; apply Rmult_1_l. exact Rmult_comm. - symmetry in |- *; apply Rmult_assoc. + symmetry ; apply Rmult_assoc. intros m n p. - rewrite Rmult_comm in |- *. - rewrite (Rmult_comm n p) in |- *. - rewrite (Rmult_comm m p) in |- *. + rewrite Rmult_comm. + rewrite (Rmult_comm n p). + rewrite (Rmult_comm m p). apply Rmult_plus_distr_l. reflexivity. exact Rplus_opp_r. @@ -42,17 +42,17 @@ 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 |- *. + unfold Rminus. + rewrite (Rplus_comm (IZR (up x)) (- x)). + rewrite <- Rplus_assoc. + rewrite Rplus_opp_r. 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. + unfold Rminus. + rewrite (Rplus_comm (IZR (up x)) (- x)). + rewrite <- Rplus_assoc. + rewrite Rplus_opp_r. + rewrite Rplus_0_l; trivial. Qed. Notation Rset := (Eqsth R). @@ -61,7 +61,7 @@ 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 |- *. + rewrite Rplus_comm. apply Rplus_lt_compat_l. replace 1 with (0 + 1). apply Rlt_n_Sn. @@ -69,19 +69,19 @@ apply Rlt_trans with (0 + 1). Qed. Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0. -unfold Rgt in |- *. -induction x; simpl in |- *; intros. +unfold Rgt. +induction x; simpl; intros. apply Rlt_trans with (1 + 0). - rewrite Rplus_comm in |- *. + rewrite Rplus_comm. apply Rlt_n_Sn. apply Rplus_lt_compat_l. - rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. - rewrite Rmult_comm in |- *. + rewrite <- (Rmul_0_l Rset Rext RTheory 2). + rewrite Rmult_comm. apply Rmult_lt_compat_l. apply Rlt_0_2. trivial. - rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *. - rewrite Rmult_comm in |- *. + rewrite <- (Rmul_0_l Rset Rext RTheory 2). + rewrite Rmult_comm. apply Rmult_lt_compat_l. apply Rlt_0_2. trivial. @@ -93,9 +93,9 @@ Qed. Lemma Rgen_phiPOS_not_0 : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0. -red in |- *; intros. +red; intros. specialize (Rgen_phiPOS x). -rewrite H in |- *; intro. +rewrite H; intro. apply (Rlt_asym 0 0); trivial. Qed. @@ -107,23 +107,23 @@ Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0. Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x (n + m) = pow x n * pow x m. Proof. - intros x n; elim n; simpl in |- *; auto with real. + intros x n; elim n; simpl; auto with real. intros n0 H' m; rewrite H'; auto with real. Qed. -Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R)) nat_of_N pow. +Lemma R_power_theory : power_theory 1%R Rmult (@eq R) N.to_nat pow. Proof. constructor. destruct n. reflexivity. - simpl. induction p;simpl. - rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity. - unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial. - rewrite Rmult_comm;apply Rmult_1_l. + simpl. induction p. + - rewrite Pos2Nat.inj_xI. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp. + - rewrite Pos2Nat.inj_xO. simpl. now rewrite plus_0_r, Rdef_pow_add, IHp. + - simpl. rewrite Rmult_comm;apply Rmult_1_l. Qed. Ltac Rpow_tac t := match isnatcst t with | false => constr:(InitialRing.NotConstant) - | _ => constr:(N_of_nat t) + | _ => constr:(N.of_nat t) end. Add Field RField : Rfield diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v index 7b48f590..7c1bf981 100644 --- a/plugins/setoid_ring/Ring.v +++ b/plugins/setoid_ring/Ring.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -14,7 +14,7 @@ Require Export Ring_tac. Lemma BoolTheory : ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)). -split; simpl in |- *. +split; simpl. destruct x; reflexivity. destruct x; destruct y; reflexivity. destruct x; destruct y; destruct z; reflexivity. diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v index 9bc95a7f..dc5248b2 100644 --- a/plugins/setoid_ring/Ring_base.v +++ b/plugins/setoid_ring/Ring_base.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index d33a095f..b23ba352 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -1,20 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) Set Implicit Arguments. -Require Import Setoid. -Require Import BinList. -Require Import BinPos. -Require Import BinNat. -Require Import BinInt. +Require Import Setoid Morphisms BinList BinPos BinNat BinInt. Require Export Ring_theory. -Open Local Scope positive_scope. +Local Open Scope positive_scope. Import RingSyntax. Section MakeRingPol. @@ -25,7 +21,7 @@ Section MakeRingPol. Variable req : R -> R -> Prop. (* Ring properties *) - Variable Rsth : Setoid_Theory R req. + Variable Rsth : Equivalence req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. @@ -37,8 +33,8 @@ Section MakeRingPol. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. - (* Power coefficients *) - Variable Cpow : Set. + (* Power coefficients *) + Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. @@ -50,26 +46,47 @@ Section MakeRingPol. (* R notations *) Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). + Infix "+" := radd. Infix "*" := rmul. + Infix "-" := rsub. Notation "- x" := (ropp x). + Infix "==" := req. + Infix "^" := (pow_pos rmul). (* C notations *) - Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). - Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). - Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). + Infix "+!" := cadd. Infix "*!" := cmul. + Infix "-! " := csub. Notation "-! x" := (copp x). + Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (* Useful tactics *) - Add Setoid R req Rsth as R_set1. - Ltac rrefl := gen_reflexivity Rsth. - Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. - Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. - Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. - Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. + Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. + Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. + Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. + Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. + Ltac add_push := gen_add_push radd Rsth Reqe ARth. Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth. + Ltac add_permut_rec t := + match t with + | ?x + ?y => add_permut_rec y || add_permut_rec x + | _ => add_push t; apply (Radd_ext Reqe); [|reflexivity] + end. + + Ltac add_permut := + repeat (reflexivity || + match goal with |- ?t == _ => add_permut_rec t end). + + Ltac mul_permut_rec t := + match t with + | ?x * ?y => mul_permut_rec y || mul_permut_rec x + | _ => mul_push t; apply (Rmul_ext Reqe); [|reflexivity] + end. + + Ltac mul_permut := + repeat (reflexivity || + match goal with |- ?t == _ => mul_permut_rec t end). + + (* Definition of multivariable polynomials with coefficients in C : Type [Pol] represents [X1 ... Xn]. The representation is Horner's where a [n] variable polynomial @@ -104,31 +121,31 @@ Section MakeRingPol. match P, P' with | Pc c, Pc c' => c ?=! c' | Pinj j Q, Pinj j' Q' => - match Pcompare j j' Eq with + match j ?= j' with | Eq => Peq Q Q' | _ => false end | PX P i Q, PX P' i' Q' => - match Pcompare i i' Eq with + match i ?= i' with | Eq => if Peq P P' then Peq Q Q' else false | _ => false end | _, _ => false end. - Notation " P ?== P' " := (Peq P P'). + Infix "?==" := Peq. Definition mkPinj j P := match P with | Pc _ => P - | Pinj j' Q => Pinj ((j + j'):positive) Q + | Pinj j' Q => Pinj (j + j') Q | _ => Pinj j P end. Definition mkPinj_pred j P:= match j with | xH => P - | xO j => Pinj (Pdouble_minus_one j) P + | xO j => Pinj (Pos.pred_double j) P | xI j => Pinj (xO j) P end. @@ -156,14 +173,14 @@ Section MakeRingPol. (** Addition et subtraction *) - Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol := + Fixpoint PaddC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 +! c) | Pinj j Q => Pinj j (PaddC Q c) | PX P i Q => PX P i (PaddC Q c) end. - Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol := + Fixpoint PsubC (P:Pol) (c:C) : Pol := match P with | Pc c1 => Pc (c1 -! c) | Pinj j Q => Pinj j (PsubC Q c) @@ -175,11 +192,11 @@ Section MakeRingPol. Variable Pop : Pol -> Pol -> Pol. Variable Q : Pol. - Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol := + Fixpoint PaddI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC Q c) | Pinj j' Q' => - match ZPminus j' j with + match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PaddI k Q') @@ -187,16 +204,16 @@ Section MakeRingPol. | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PaddI (Pdouble_minus_one j) Q') + | xO j => PX P i (PaddI (Pos.pred_double j) Q') | xI j => PX P i (PaddI (xO j) Q') end end. - Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := + Fixpoint PsubI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PaddC (--Q) c) | Pinj j' Q' => - match ZPminus j' j with + match Z.pos_sub j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PsubI k Q') @@ -204,41 +221,41 @@ Section MakeRingPol. | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) - | xO j => PX P i (PsubI (Pdouble_minus_one j) Q') + | xO j => PX P i (PsubI (Pos.pred_double j) Q') | xI j => PX P i (PsubI (xO j) Q') end end. Variable P' : Pol. - Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol := + Fixpoint PaddX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX P' i' P | Pinj j Q' => match j with | xH => PX P' i' Q' - | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q') + | xO j => PX P' i' (Pinj (Pos.pred_double j) Q') | xI j => PX P' i' (Pinj (xO j) Q') end | PX P i Q' => - match ZPminus i i' with + match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PaddX k P) i Q' end end. - Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol := + Fixpoint PsubX (i':positive) (P:Pol) : Pol := match P with | Pc c => PX (--P') i' P | Pinj j Q' => match j with | xH => PX (--P') i' Q' - | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q') + | xO j => PX (--P') i' (Pinj (Pos.pred_double j) Q') | xI j => PX (--P') i' (Pinj (xO j) Q') end | PX P i Q' => - match ZPminus i i' with + match Z.pos_sub i i' with | Zpos k => mkPX (Pop (PX P k P0) P') i' Q' | Z0 => mkPX (Pop P P') i Q' | Zneg k => mkPX (PsubX k P) i Q' @@ -258,18 +275,18 @@ Section MakeRingPol. | Pinj j Q => match j with | xH => PX P' i' (Padd Q Q') - | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q') + | xO j => PX P' i' (Padd (Pinj (Pos.pred_double j) Q) Q') | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') end | PX P i Q => - match ZPminus i i' with + match Z.pos_sub i i' with | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') | Z0 => mkPX (Padd P P') i (Padd Q Q') | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q') end end end. - Notation "P ++ P'" := (Padd P P'). + Infix "++" := Padd. Fixpoint Psub (P P': Pol) {struct P'} : Pol := match P' with @@ -281,22 +298,22 @@ Section MakeRingPol. | Pinj j Q => match j with | xH => PX (--P') i' (Psub Q Q') - | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q') + | xO j => PX (--P') i' (Psub (Pinj (Pos.pred_double j) Q) Q') | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') end | PX P i Q => - match ZPminus i i' with + match Z.pos_sub i i' with | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') | Z0 => mkPX (Psub P P') i (Psub Q Q') | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q') end end end. - Notation "P -- P'" := (Psub P P'). + Infix "--" := Psub. (** Multiplication *) - Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := + Fixpoint PmulC_aux (P:Pol) (c:C) : Pol := match P with | Pc c' => Pc (c' *! c) | Pinj j Q => mkPinj j (PmulC_aux Q c) @@ -310,11 +327,11 @@ Section MakeRingPol. Section PmulI. Variable Pmul : Pol -> Pol -> Pol. Variable Q : Pol. - Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol := + Fixpoint PmulI (j:positive) (P:Pol) : Pol := match P with | Pc c => mkPinj j (PmulC Q c) | Pinj j' Q' => - match ZPminus j' j with + match Z.pos_sub j' j with | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) | Z0 => mkPinj j (Pmul Q' Q) | Zneg k => mkPinj j' (PmulI k Q') @@ -322,13 +339,12 @@ Section MakeRingPol. | PX P' i' Q' => match j with | xH => mkPX (PmulI xH P') i' (Pmul Q' Q) - | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q') + | xO j' => mkPX (PmulI j P') i' (PmulI (Pos.pred_double j') Q') | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') end end. End PmulI. -(* A symmetric version of the multiplication *) Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol := match P'' with @@ -341,7 +357,7 @@ Section MakeRingPol. let QQ' := match j with | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' + | xO j => Pmul (Pinj (Pos.pred_double j) Q) Q' | xI j => Pmul (Pinj (xO j) Q) Q' end in mkPX (Pmul P P') i' QQ' @@ -354,25 +370,7 @@ Section MakeRingPol. end end. -(* Non symmetric *) -(* - Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol := - match P' with - | Pc c' => PmulC P c' - | Pinj j' Q' => PmulI Pmul_aux Q' j' P - | PX P' i' Q' => - (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) - end. - - Definition Pmul P P' := - match P with - | Pc c => PmulC P' c - | Pinj j Q => PmulI Pmul_aux Q j P' - | PX P i Q => - (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') - end. -*) - Notation "P ** P'" := (Pmul P P'). + Infix "**" := Pmul. Fixpoint Psquare (P:Pol) : Pol := match P with @@ -387,26 +385,26 @@ Section MakeRingPol. (** Monomial **) + (** A monomial is X1^k1...Xi^ki. Its representation + is a simplified version of the polynomial representation: + + - [mon0] correspond to the polynom [P1]. + - [(zmon j M)] corresponds to [(Pinj j ...)], + i.e. skip j variable indices. + - [(vmon i M)] is X^i*M with X the current variable, + its corresponds to (PX P1 i ...)] + *) + Inductive Mon: Set := - mon0: Mon + | mon0: Mon | zmon: positive -> Mon -> Mon | vmon: positive -> Mon -> Mon. - Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R := - match M with - mon0 => rI - | zmon j M1 => Mphi (jump j l) M1 - | vmon i M1 => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Mphi (tail l) M1) * xi - end. - Definition mkZmon j M := match M with mon0 => mon0 | _ => zmon j M end. Definition zmon_pred j M := - match j with xH => M | _ => mkZmon (Ppred j) M end. + match j with xH => M | _ => mkZmon (Pos.pred j) M end. Definition mkVmon i M := match M with @@ -421,7 +419,7 @@ Section MakeRingPol. | Pinj j1 P1 => let (R,S) := CFactor P1 c in (mkPinj j1 R, mkPinj j1 S) - | PX P1 i Q1 => + | PX P1 i Q1 => let (R1, S1) := CFactor P1 c in let (R2, S2) := CFactor Q1 c in (mkPX R1 i R2, mkPX S1 i S2) @@ -429,13 +427,10 @@ Section MakeRingPol. Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol := match P, M with - _, mon0 => - if (ceqb c cI) then (Pc cO, P) else -(* if (ceqb c (copp cI)) then (Pc cO, Popp P) else Not in almost ring *) - CFactor P c + _, mon0 => if (ceqb c cI) then (Pc cO, P) else CFactor P c | Pc _, _ => (P, Pc cO) | Pinj j1 P1, zmon j2 M1 => - match (j1 ?= j2) Eq with + match j1 ?= j2 with Eq => let (R,S) := MFactor P1 c M1 in (mkPinj j1 R, mkPinj j1 S) | Lt => let (R,S) := MFactor P1 c (zmon (j2 - j1) M1) in @@ -449,7 +444,7 @@ Section MakeRingPol. let (R2, S2) := MFactor Q1 c M2 in (mkPX R1 i R2, mkPX S1 i S2) | PX P1 i Q1, vmon j M1 => - match (i ?= j) Eq with + match i ?= j with Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in (mkPX R1 i Q1, S1) | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in @@ -468,7 +463,7 @@ Section MakeRingPol. | _ => Some (Padd Q1 (Pmul P2 R1)) end. - Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol := + Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) : Pol := match POneSubst P1 cM1 P2 with Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end | _ => P1 @@ -480,14 +475,13 @@ Section MakeRingPol. | _ => None end. - Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: - Pol := + Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : Pol := match LM1 with cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n | _ => P1 end. - Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol := + Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) : option Pol := match LM1 with cons (M1,P2) LM2 => match PNSubst P1 M1 P2 n with @@ -497,7 +491,7 @@ Section MakeRingPol. | _ => None end. - Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol := + Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) : Pol := match PSubstL P1 LM1 n with Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end | _ => P1 @@ -505,658 +499,409 @@ Section MakeRingPol. (** Evaluation of a polynomial towards R *) - Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R := + Local Notation hd := (List.hd 0). + + Fixpoint Pphi(l:list R) (P:Pol) : R := match P with | Pc c => [c] | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => - let x := hd 0 l in - let xi := pow_pos rmul x i in - (Pphi l P) * xi + (Pphi (tail l) Q) + | PX P i Q => Pphi l P * (hd l) ^ i + Pphi (tail l) Q end. Reserved Notation "P @ l " (at level 10, no associativity). Notation "P @ l " := (Pphi l P). + + (** Evaluation of a monomial towards R *) + + Fixpoint Mphi(l:list R) (M: Mon) : R := + match M with + | mon0 => rI + | zmon j M1 => Mphi (jump j l) M1 + | vmon i M1 => Mphi (tail l) M1 * (hd l) ^ i + end. + + Notation "M @@ l" := (Mphi l M) (at level 10, no associativity). + (** Proofs *) - Lemma ZPminus_spec : forall x y, - match ZPminus x y with - | Z0 => x = y - | Zpos k => x = (y + k)%positive - | Zneg k => y = (x + k)%positive + + Ltac destr_pos_sub := + match goal with |- context [Z.pos_sub ?x ?y] => + generalize (Z.pos_sub_discr x y); destruct (Z.pos_sub x y) end. + + Lemma jump_add' i j (l:list R) : jump (i + j) l = jump j (jump i l). + Proof. rewrite Pos.add_comm. apply jump_add. Qed. + + Lemma Peq_ok P P' : (P ?== P') = true -> forall l, P@l == P'@ l. Proof. - induction x;destruct y. - replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - simpl;trivial. - replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial. - apply Pplus_xI_double_minus_one. - replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial. - assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial. - replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial. - replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO;trivial. - simpl;trivial. + revert P';induction P;destruct P';simpl; intros H l; try easy. + - now apply (morph_eq CRmorph). + - destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. + now rewrite IHP. + - specialize (IHP1 P'1); specialize (IHP2 P'2). + destruct (Pos.compare_spec p p0); [ subst | easy | easy ]. + destruct (P2 ?== P'1); [|easy]. + rewrite H in *. + now rewrite IHP1, IHP2. Qed. - Lemma Peq_ok : forall P P', - (P ?== P') = true -> forall l, P@l == P'@ l. + Lemma Peq_spec P P' : + BoolSpec (forall l, P@l == P'@l) True (P ?== P'). Proof. - induction P;destruct P';simpl;intros;try discriminate;trivial. - apply (morph_eq CRmorph);trivial. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite (IHP P' H); rewrite H1;trivial;rrefl. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); - try discriminate H. - rewrite H1;trivial. clear H1. - assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); - destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H] - |discriminate H]. - rewrite (H1 H);rewrite (H2 H);rrefl. + generalize (Peq_ok P P'). destruct (P ?== P'); auto. Qed. - Lemma Pphi0 : forall l, P0@l == 0. + Lemma Pphi0 l : P0@l == 0. Proof. - intros;simpl;apply (morph0 CRmorph). + simpl;apply (morph0 CRmorph). Qed. - Lemma Pphi1 : forall l, P1@l == 1. + Lemma Pphi1 l : P1@l == 1. Proof. - intros;simpl;apply (morph1 CRmorph). + simpl;apply (morph1 CRmorph). Qed. - Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l). + Lemma mkPinj_ok j l P : (mkPinj j P)@l == P@(jump j l). Proof. - intros j l p;destruct p;simpl;rsimpl. - rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl. + destruct P;simpl;rsimpl. + now rewrite jump_add'. Qed. - Let pow_pos_Pplus := - pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc). + Lemma pow_pos_add x i j : x^(j + i) == x^i * x^j. + Proof. + rewrite Pos.add_comm. + apply (pow_pos_add Rsth Reqe.(Rmul_ext) ARth.(ARmul_assoc)). + Qed. - Lemma mkPX_ok : forall l P i Q, - (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l). + Lemma ceqb_spec c c' : BoolSpec ([c] == [c']) True (c ?=! c'). Proof. - intros l P i Q;unfold mkPX. - destruct P;try (simpl;rrefl). - assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl. - rewrite (H (refl_equal true));rewrite (morph0 CRmorph). - rewrite mkPinj_ok;rsimpl;simpl;rrefl. - assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl. - rewrite (H (refl_equal true));trivial. - rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl. + generalize (morph_eq CRmorph c c'). + destruct (c ?=! c'); auto. Qed. - Ltac Esimpl := - repeat (progress ( - match goal with - | |- context [?P@?l] => - match P with - | P0 => rewrite (Pphi0 l) - | P1 => rewrite (Pphi1 l) - | (mkPinj ?j ?P) => rewrite (mkPinj_ok j l P) - | (mkPX ?P ?i ?Q) => rewrite (mkPX_ok l P i Q) - end - | |- context [[?c]] => - match c with - | cO => rewrite (morph0 CRmorph) - | cI => rewrite (morph1 CRmorph) - | ?x +! ?y => rewrite ((morph_add CRmorph) x y) - | ?x *! ?y => rewrite ((morph_mul CRmorph) x y) - | ?x -! ?y => rewrite ((morph_sub CRmorph) x y) - | -! ?x => rewrite ((morph_opp CRmorph) x) - end - end)); - rsimpl; simpl. - - Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. + Lemma mkPX_ok l P i Q : + (mkPX P i Q)@l == P@l * (hd l)^i + Q@(tail l). Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP2;rsimpl. + unfold mkPX. destruct P. + - case ceqb_spec; intros H; simpl; try reflexivity. + rewrite H, (morph0 CRmorph), mkPinj_ok; rsimpl. + - reflexivity. + - case Peq_spec; intros H; simpl; try reflexivity. + rewrite H, Pphi0, Pos.add_comm, pow_pos_add; rsimpl. Qed. - Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c]. + Hint Rewrite + Pphi0 + Pphi1 + mkPinj_ok + mkPX_ok + (morph0 CRmorph) + (morph1 CRmorph) + (morph0 CRmorph) + (morph_add CRmorph) + (morph_mul CRmorph) + (morph_sub CRmorph) + (morph_opp CRmorph) + : Esimpl. + + (* Quicker than autorewrite with Esimpl :-) *) + Ltac Esimpl := try rewrite_db Esimpl; rsimpl; simpl. + + Lemma PaddC_ok c P l : (PaddC P c)@l == P@l + [c]. Proof. - induction P;simpl;intros. - Esimpl. - rewrite IHP;rsimpl. + revert l;induction P;simpl;intros;Esimpl;trivial. rewrite IHP2;rsimpl. Qed. - Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c]. + Lemma PsubC_ok c P l : (PsubC P c)@l == P@l - [c]. Proof. - induction P;simpl;intros;Esimpl;trivial. - rewrite IHP1;rewrite IHP2;rsimpl. - mul_push ([c]);rrefl. + revert l;induction P;simpl;intros. + - Esimpl. + - rewrite IHP;rsimpl. + - rewrite IHP2;rsimpl. Qed. - Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. + Lemma PmulC_aux_ok c P l : (PmulC_aux P c)@l == P@l * [c]. Proof. - intros c P l; unfold PmulC. - assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO). - rewrite (H (refl_equal true));Esimpl. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - apply PmulC_aux_ok. + revert l;induction P;simpl;intros;Esimpl;trivial. + rewrite IHP1, IHP2;rsimpl. add_permut. mul_permut. Qed. - Lemma Popp_ok : forall P l, (--P)@l == - P@l. + Lemma PmulC_ok c P l : (PmulC P c)@l == P@l * [c]. Proof. - induction P;simpl;intros. - Esimpl. - apply IHP. - rewrite IHP1;rewrite IHP2;rsimpl. + unfold PmulC. + case ceqb_spec; intros H. + - rewrite H; Esimpl. + - case ceqb_spec; intros H'. + + rewrite H'; Esimpl. + + apply PmulC_aux_ok. Qed. - Ltac Esimpl2 := - Esimpl; - repeat (progress ( - match goal with - | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l) - | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l) - | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) - | |- context [(--?P)@?l] => rewrite (Popp_ok P l) - end)); Esimpl. - - Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l. + Lemma Popp_ok P l : (--P)@l == - P@l. Proof. - induction P';simpl;intros;Esimpl2. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rrefl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - destruct p0;simpl. - rewrite IHP2;simpl;rsimpl. - rewrite IHP2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. - Esimpl2;add_push [c];rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl. - rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1;rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1;rewrite IHP'2;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros;try apply (ARadd_comm ARth). - destruct p2;simpl;try apply (ARadd_comm ARth). - rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth). - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. - rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. - rewrite IHP'1;simpl;Esimpl. - rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. + revert l;induction P;simpl;intros. + - Esimpl. + - apply IHP. + - rewrite IHP1, IHP2;rsimpl. Qed. - Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l. + Hint Rewrite PaddC_ok PsubC_ok PmulC_ok Popp_ok : Esimpl. + + Lemma PaddX_ok P' P k l : + (forall P l, (P++P')@l == P@l + P'@l) -> + (PaddX Padd P' k P) @ l == P@l + P'@l * (hd l)^k. Proof. - induction P';simpl;intros;Esimpl2;trivial. - generalize P p l;clear P p l. - induction P;simpl;intros. - Esimpl2;apply (ARadd_comm ARth). - assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rsimpl. - rewrite H;Esimpl. rewrite IHP';Esimpl. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - rewrite H;Esimpl. rewrite IHP. - rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. - destruct p0;simpl. - rewrite IHP2;simpl;rsimpl. - rewrite IHP2;simpl. - rewrite jump_Pdouble_minus_one;rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. - repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. - destruct p0;simpl;Esimpl2. - rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. - add_push (P @ (jump p0 (jump p0 (tail l))));rrefl. - rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl. - add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. - rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl. - assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2. - rewrite IHP'1; rewrite IHP'2;rsimpl. - add_push (P3 @ (tail l));rewrite H;rrefl. - rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl. - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. - add_push (P3 @ (tail l));rrefl. - assert (forall P k l, - (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k). - induction P;simpl;intros. - rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. - destruct p2;simpl;rewrite Popp_ok;rsimpl. - apply (ARadd_comm ARth);trivial. - rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial. - apply (ARadd_comm ARth);trivial. - assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl. - rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl. - rewrite IHP'1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;Esimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite IHP1;rewrite H1;rewrite Pplus_comm. - rewrite pow_pos_Pplus;simpl;rsimpl. - add_push (P5 @ (tail l0));rrefl. - rewrite H0;rsimpl. - rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)). - rewrite H;rewrite Pplus_comm. - rewrite pow_pos_Pplus;rsimpl. + intros IHP'. + revert k l. induction P;simpl;intros. + - add_permut. + - destruct p; simpl; + rewrite ?jump_pred_double; add_permut. + - destr_pos_sub; intros ->;Esimpl. + + rewrite IHP';rsimpl. add_permut. + + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. -(* Proof for the symmetriv version *) - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : list R), - (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). + Lemma Padd_ok P' P l : (P ++ P')@l == P@l + P'@l. Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pplus_comm. - rewrite jump_Pplus;simpl;rrefl. - rewrite H1;rewrite Pplus_comm. - rewrite jump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. + revert P l; induction P';simpl;intros;Esimpl. + - revert p l; induction P;simpl;intros. + + Esimpl; add_permut. + + destr_pos_sub; intros ->;Esimpl. + * now rewrite IHP'. + * rewrite IHP';Esimpl. now rewrite jump_add'. + * rewrite IHP. now rewrite jump_add'. + + destruct p0;simpl. + * rewrite IHP2;simpl. rsimpl. + * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl. + * rewrite IHP'. rsimpl. + - destruct P;simpl. + + Esimpl. add_permut. + + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. + * rsimpl. add_permut. + * rewrite jump_pred_double. rsimpl. add_permut. + * rsimpl. add_permut. + + destr_pos_sub; intros ->; Esimpl. + * rewrite IHP'1, IHP'2;rsimpl. add_permut. + * rewrite IHP'1, IHP'2;simpl;Esimpl. + rewrite pow_pos_add;rsimpl. add_permut. + * rewrite PaddX_ok by trivial; rsimpl. + rewrite IHP'2, pow_pos_add; rsimpl. add_permut. Qed. -(* - Lemma PmulI_ok : - forall P', - (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) -> - forall (P : Pol) (p : positive) (l : list R), - (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l). + Lemma PsubX_ok P' P k l : + (forall P l, (P--P')@l == P@l - P'@l) -> + (PsubX Psub P' k P) @ l == P@l - P'@l * (hd l)^k. Proof. - induction P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2. - rewrite H1; rewrite H;rrefl. - rewrite H1; rewrite H. - rewrite Pplus_comm. - rewrite jump_Pplus;simpl;rrefl. - rewrite H1;rewrite Pplus_comm. - rewrite jump_Pplus;rewrite IHP;rrefl. - destruct p0;Esimpl2. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p);rrefl. - rewrite IHP1;rewrite IHP2;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl. - rewrite IHP1;simpl;rsimpl. - mul_push (pow_pos rmul (hd 0 l) p). - rewrite H;rrefl. + intros IHP'. + revert k l. induction P;simpl;intros. + - rewrite Popp_ok;rsimpl; add_permut. + - destruct p; simpl; + rewrite Popp_ok;rsimpl; + rewrite ?jump_pred_double; add_permut. + - destr_pos_sub; intros ->; Esimpl. + + rewrite IHP';rsimpl. add_permut. + + rewrite IHP', pow_pos_add;simpl;Esimpl. add_permut. + + rewrite IHP1, pow_pos_add;rsimpl. add_permut. Qed. - Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l. + Lemma Psub_ok P' P l : (P -- P')@l == P@l - P'@l. Proof. - induction P';simpl;intros. - Esimpl2;trivial. - apply PmulI_ok;trivial. - rewrite Padd_ok;Esimpl2. - rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl. + revert P l; induction P';simpl;intros;Esimpl. + - revert p l; induction P;simpl;intros. + + Esimpl; add_permut. + + destr_pos_sub; intros ->;Esimpl. + * rewrite IHP';rsimpl. + * rewrite IHP';Esimpl. now rewrite jump_add'. + * rewrite IHP. now rewrite jump_add'. + + destruct p0;simpl. + * rewrite IHP2;simpl. rsimpl. + * rewrite IHP2;simpl. rewrite jump_pred_double. rsimpl. + * rewrite IHP'. rsimpl. + - destruct P;simpl. + + Esimpl; add_permut. + + destruct p0;simpl;Esimpl; rewrite IHP'2; simpl. + * rsimpl. add_permut. + * rewrite jump_pred_double. rsimpl. add_permut. + * rsimpl. add_permut. + + destr_pos_sub; intros ->; Esimpl. + * rewrite IHP'1, IHP'2;rsimpl. add_permut. + * rewrite IHP'1, IHP'2;simpl;Esimpl. + rewrite pow_pos_add;rsimpl. add_permut. + * rewrite PsubX_ok by trivial;rsimpl. + rewrite IHP'2, pow_pos_add;rsimpl. add_permut. Qed. -*) -(* Proof for the symmetric version *) - Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Lemma PmulI_ok P' : + (forall P l, (Pmul P P') @ l == P @ l * P' @ l) -> + forall P p l, (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). Proof. - intros P P';generalize P;clear P;induction P';simpl;intros. - apply PmulC_ok. apply PmulI_ok;trivial. - destruct P. - rewrite (ARmul_comm ARth);Esimpl2;Esimpl2. - Esimpl2. rewrite IHP'1;Esimpl2. - assert (match p0 with - | xI j => Pinj (xO j) P ** P'2 - | xO j => Pinj (Pdouble_minus_one j) P ** P'2 - | 1 => P ** P'2 - end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). - destruct p0;simpl;rewrite IHP'2;Esimpl. - rewrite jump_Pdouble_minus_one;Esimpl. - rewrite H;Esimpl. - rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2. - repeat (rewrite IHP'1 || rewrite IHP'2);simpl. - rewrite PmulI_ok;trivial. - mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl. + intros IHP'. + induction P;simpl;intros. + - Esimpl; mul_permut. + - destr_pos_sub; intros ->;Esimpl. + + now rewrite IHP'. + + now rewrite IHP', jump_add'. + + now rewrite IHP, jump_add'. + - destruct p0;Esimpl; rewrite ?IHP1, ?IHP2; rsimpl. + + f_equiv. mul_permut. + + rewrite jump_pred_double. f_equiv. mul_permut. + + rewrite IHP'. f_equiv. mul_permut. Qed. -(* -Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. + Lemma Pmul_ok P P' l : (P**P')@l == P@l * P'@l. Proof. - destruct P;simpl;intros. - Esimpl2;apply (ARmul_comm ARth). - rewrite (PmulI_ok P (Pmul_aux_ok P)). - apply (ARmul_comm ARth). - rewrite Padd_ok; Esimpl2. - rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial. - rewrite Pmul_aux_ok;mul_push (P' @ l). - rewrite (ARmul_comm ARth (P' @ l));rrefl. + revert P l;induction P';simpl;intros. + - apply PmulC_ok. + - apply PmulI_ok;trivial. + - destruct P. + + rewrite (ARmul_comm ARth). Esimpl. + + Esimpl. f_equiv. rewrite IHP'1; Esimpl. + destruct p0;rewrite IHP'2;Esimpl. + rewrite jump_pred_double; Esimpl. + + rewrite Padd_ok, !mkPX_ok, Padd_ok, !mkPX_ok, + !IHP'1, !IHP'2, PmulI_ok; trivial. simpl. Esimpl. + add_permut; f_equiv; mul_permut. Qed. -*) - Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l. + Lemma Psquare_ok P l : (Psquare P)@l == P@l * P@l. Proof. - induction P;simpl;intros;Esimpl2. - apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2. - rewrite IHP1;rewrite IHP2. - mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l). - rrefl. + revert l;induction P;simpl;intros;Esimpl. + - apply IHP. + - rewrite Padd_ok, Pmul_ok;Esimpl. + rewrite IHP1, IHP2. + mul_push ((hd l)^p). now mul_push (P2@l). 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. + Lemma mkZmon_ok M j l : + (mkZmon j M) @@ l == (zmon j M) @@ l. + Proof. + destruct M; simpl; rsimpl. Qed. - Lemma zmon_pred_ok : forall M j l, - Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). + Lemma zmon_pred_ok M j l : + (zmon_pred j M) @@ (tail l) == (zmon j M) @@ l. Proof. - destruct j; simpl;intros auto; rsimpl. - rewrite mkZmon_ok;rsimpl. - rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl. + destruct j; simpl; rewrite ?mkZmon_ok; simpl; rsimpl. + rewrite jump_pred_double; rsimpl. Qed. - Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i. + Lemma mkVmon_ok M i l : + (mkVmon i M)@@l == M@@l * (hd l)^i. Proof. destruct M;simpl;intros;rsimpl. - rewrite zmon_pred_ok;simpl;rsimpl. - rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. + - rewrite zmon_pred_ok;simpl;rsimpl. + - rewrite pow_pos_add;rsimpl. Qed. - Lemma Mcphi_ok: forall P c l, - let (Q,R) := CFactor P c in - P@l == Q@l + (phi c) * (R@l). + Ltac destr_factor := match goal with + | H : context [CFactor ?P _] |- context [CFactor ?P ?c] => + destruct (CFactor P c); destr_factor; rewrite H; clear H + | H : context [MFactor ?P _ _] |- context [MFactor ?P ?c ?M] => + specialize (H M); destruct (MFactor P c M); destr_factor; rewrite H; clear H + | _ => idtac + end. + + Lemma Mcphi_ok P c l : + let (Q,R) := CFactor P c in + P@l == Q@l + [c] * R@l. Proof. - intros P; elim P; simpl; auto; clear P. - intros c c1 l; generalize (div_th.(div_eucl_th) c c1); case cdiv. - intros q r H; rewrite H. - Esimpl. - rewrite (ARadd_comm ARth); rsimpl. - intros i P Hrec c l. - generalize (Hrec c (jump i l)); case CFactor. - intros R1 S1; Esimpl; auto. - intros Q1 Qrec i R1 Rrec c l. - generalize (Qrec c l); case CFactor; intros S1 S2 HS. - generalize (Rrec c (tail l)); case CFactor; intros S3 S4 HS1. - rewrite HS; rewrite HS1; Esimpl. - apply (Radd_ext Reqe); rsimpl. - repeat rewrite <- (ARadd_assoc ARth). - apply (Radd_ext Reqe); rsimpl. - rewrite (ARadd_comm ARth); rsimpl. + revert l. + induction P as [c0 | j P IH | P1 IH1 i P2 IH2]; intros l; Esimpl. + - assert (H := div_th.(div_eucl_th) c0 c). + destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. + - destr_factor. Esimpl. + - destr_factor. Esimpl. add_permut. Qed. - Lemma Mphi_ok: forall P (cM: C * Mon) l, - let (c,M) := cM in - let (Q,R) := MFactor P c M in - P@l == Q@l + (phi c) * (Mphi l M) * (R@l). + Lemma Mphi_ok P (cM: C * Mon) l : + let (c,M) := cM in + let (Q,R) := MFactor P c M in + P@l == Q@l + [c] * M@@l * R@l. Proof. - intros P; elim P; simpl; auto; clear P. - intros c (c1, M) l; case M; simpl; auto. - assert (H1:= morph_eq CRmorph c1 cI);destruct (c1 ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - try rewrite (morph0 CRmorph); rsimpl. - generalize (div_th.(div_eucl_th) c c1); case (cdiv c c1). - intros q r H; rewrite H; clear H H1. - Esimpl. - rewrite (ARadd_comm ARth); rsimpl. - intros p m; Esimpl. - intros p m; Esimpl. - intros i P Hrec (c,M) l; case M; simpl; clear M. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - Esimpl. - generalize (Mcphi_ok P c (jump i l)); case CFactor. - intros R1 Q1 HH; rewrite HH; Esimpl. - intros j M. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec (c, M) (jump j l)); case (MFactor P c M); - simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); - case (MFactor P c (zmon (j -i) M)); simpl. - intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). - rewrite Pplus_comm; rewrite jump_Pplus; auto. - rewrite (morph0 CRmorph); rsimpl. - intros P2 m; rewrite (morph0 CRmorph); rsimpl. - - intros P2 Hrec1 i Q2 Hrec2 (c, M) l; case M; simpl; auto. - assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI). - rewrite (H1 (refl_equal true));Esimpl. - Esimpl. - generalize (Mcphi_ok P2 c l); case CFactor. - intros S1 S2 HS. - generalize (Mcphi_ok Q2 c (tail l)); case CFactor. - intros S3 S4 HS1; Esimpl; rewrite HS; rewrite HS1. - rsimpl. - apply (Radd_ext Reqe); rsimpl. - repeat rewrite <- (ARadd_assoc ARth). - apply (Radd_ext Reqe); rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - intros j M1. - generalize (Hrec1 (c,zmon j M1) l); - case (MFactor P2 c (zmon j M1)). - intros R1 S1 H1. - generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); - case (MFactor Q2 c (zmon_pred j M1)); simpl. - intros R2 S2 H2; rewrite H1; rewrite H2. - repeat rewrite mkPX_ok; simpl. - rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - rewrite zmon_pred_ok;rsimpl. - intros j M1. - case_eq ((i ?= j) Eq); intros He; simpl. - rewrite (Pcompare_Eq_eq _ _ He). - generalize (Hrec1 (c, mkZmon xH M1) l); case (MFactor P2 c (mkZmon xH M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite mkZmon_ok. - apply rmul_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - generalize (Hrec1 (c, vmon (j - i) M1) l); - case (MFactor P2 c (vmon (j - i) M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - apply rmul_ext; rsimpl. - rewrite <- (ARmul_comm ARth (Mphi (tail l) M1)); rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. - generalize (Hrec1 (c, mkZmon 1 M1) l); - case (MFactor P2 c (mkZmon 1 M1)); - simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. - rewrite H; rsimpl. - rewrite mkPX_ok; rsimpl. - repeat (rewrite <-(ARadd_assoc ARth)). - apply radd_ext; rsimpl. - rewrite (ARadd_comm ARth); rsimpl. - apply radd_ext; rsimpl. - rewrite mkZmon_ok. - repeat (rewrite <-(ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - rewrite mkPX_ok; simpl; rsimpl. - rewrite (morph0 CRmorph); rsimpl. - repeat (rewrite <-(ARmul_assoc ARth)). - rewrite (ARmul_comm ARth (Q3@l)); rsimpl. - apply rmul_ext; rsimpl. - rewrite (ARmul_comm ARth); rsimpl. - repeat (rewrite <- (ARmul_assoc ARth)). - apply rmul_ext; rsimpl. - rewrite <- pow_pos_Pplus. - rewrite (Pplus_minus _ _ He); rsimpl. + destruct cM as (c,M). revert M l. + induction P; destruct M; intros l; simpl; auto; + try (case ceqb_spec; intro He); + try (case Pos.compare_spec; intros He); rewrite ?He; + destr_factor; simpl; Esimpl. + - assert (H := div_th.(div_eucl_th) c0 c). + destruct cdiv as (q,r). rewrite H; Esimpl. add_permut. + - assert (H := Mcphi_ok P c). destr_factor. Esimpl. + - now rewrite <- jump_add, Pos.sub_add. + - assert (H2 := Mcphi_ok P2 c). assert (H3 := Mcphi_ok P3 c). + destr_factor. Esimpl. add_permut. + - rewrite zmon_pred_ok. simpl. add_permut. + - rewrite mkZmon_ok. simpl. add_permut. mul_permut. + - add_permut. mul_permut. + rewrite <- pow_pos_add, Pos.add_comm, Pos.sub_add by trivial; rsimpl. + - rewrite mkZmon_ok. simpl. Esimpl. add_permut. mul_permut. + rewrite <- pow_pos_add, Pos.sub_add by trivial; rsimpl. Qed. -(* Proof for the symmetric version *) - - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> phi (fst M1) * Mphi l (snd M1) == P2@l -> P1@l == P3@l. + Lemma POneSubst_ok P1 cM1 P2 P3 l : + POneSubst P1 cM1 P2 = Some P3 -> + [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. Proof. - intros P2 (cc,M1) P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 (cc, M1) l); case (MFactor P2 cc M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - (* new version *) - rewrite Padd_ok; rewrite PmulC_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - assert (P4 = Q1 ++ P3 ** PX i P5 P6). - injection H2; intros; subst;trivial. - rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl. - Qed. -(* - Lemma POneSubst_ok: forall P1 M1 P2 P3 l, - POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l. -Proof. - intros P2 M1 P3 P4 l; unfold POneSubst. - generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto. - intros Q1 R1; case R1. - intros c H; rewrite H. - generalize (morph_eq CRmorph c cO); - case (c ?=! cO); simpl; auto. - intros H1 H2; rewrite H1; auto; rsimpl. - discriminate. - intros _ H1 H2; injection H1; intros; subst. - rewrite H2; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok; rsimpl. - intros i P5 H; rewrite H. - intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl. - intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. - injection H2; intros; subst; rsimpl. - rewrite Padd_ok. - rewrite Pmul_ok; rsimpl. + destruct cM1 as (cc,M1). + unfold POneSubst. + assert (H := Mphi_ok P1 (cc, M1) l). simpl in H. + destruct MFactor as (R1,S1); simpl. rewrite H. clear H. + intros EQ EQ'. replace P3 with (R1 ++ P2 ** S1). + - rewrite EQ', Padd_ok, Pmul_ok; rsimpl. + - revert EQ. destruct S1; try now injection 1. + case ceqb_spec; now inversion 2. Qed. -*) - Lemma PNSubst1_ok: forall n P1 M1 P2 l, - [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. + + Lemma PNSubst1_ok n P1 cM1 P2 l : + [fst cM1] * (snd cM1)@@l == P2@l -> + P1@l == (PNSubst1 P1 cM1 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. + revert P1. induction n; simpl; intros P1; + generalize (POneSubst_ok P1 cM1 P2); destruct POneSubst; + intros; rewrite <- ?IHn; auto; reflexivity. Qed. - Lemma PNSubst_ok: forall n P1 M1 P2 l P3, - PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l. + Lemma PNSubst_ok n P1 cM1 P2 l P3 : + PNSubst P1 cM1 P2 n = Some P3 -> + [fst cM1] * (snd cM1)@@l == P2@l -> P1@l == P3@l. Proof. - intros n P2 (cc, M1) P3 l P4; unfold PNSubst. - generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); - case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate]. - intros P5 H1; case n; try (intros; discriminate). - intros n1 H2; injection H2; intros; subst. - rewrite <- PNSubst1_ok; auto. + unfold PNSubst. + assert (H := POneSubst_ok P1 cM1 P2); destruct POneSubst; try discriminate. + destruct n; inversion_clear 1. + intros. rewrite <- PNSubst1_ok; auto. Qed. - Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop := - match LM1 with - cons (M1,P2) LM2 => ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l) - | _ => True - end. + Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) : Prop := + match LM1 with + | (M1,P2) :: LM2 => ([fst M1] * (snd M1)@@l == 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. + Lemma PSubstL1_ok 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. + revert P1; induction LM1 as [|(M2,P2) LM2 IH]; simpl; intros. + - reflexivity. + - rewrite <- IH by intuition. now apply PNSubst1_ok. Qed. - Lemma PSubstL_ok: forall n LM1 P1 P2 l, - PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l. + Lemma PSubstL_ok 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. + revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros. + - discriminate. + - assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst. + * injection H; intros <-. rewrite <- PSubstL1_ok; intuition. + * now apply IH. Qed. - Lemma PNSubstL_ok: forall m n LM1 P1 l, - MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l. + Lemma PNSubstL_ok 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. + revert LM1 P1. induction m; simpl; intros; + assert (H' := PSubstL_ok n LM1 P2); destruct PSubstL; + auto; try reflexivity. + rewrite <- IHm; auto. Qed. (** Definition of polynomial expressions *) @@ -1190,58 +935,22 @@ Strategy expand [PEeval]. (** Correctness proofs *) - Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. + Lemma mkX_ok p l : nth 0 p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. - rewrite <-jump_tl;rewrite nth_jump;rrefl. - rewrite <- nth_jump. - rewrite nth_Pdouble_minus_one;rrefl. + - now rewrite <-jump_tl, nth_jump. + - now rewrite <- nth_jump, nth_pred_double. Qed. - Ltac Esimpl3 := - repeat match goal with - | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) - | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) - end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). - -(* Power using the chinise algorithm *) -(*Section POWER. - Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol := - match p with - | xH => P - | xO p => subst_l (Psquare (Ppow_pos P p)) - | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p))) - end. - - Definition Ppow_N P n := - match n with - | N0 => P1 - | Npos p => Ppow_pos P p - end. - - Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l. - Proof. - intros l subst_l_ok P. - induction p;simpl;intros;try rrefl;try rewrite subst_l_ok. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. - Qed. - - Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed. - - End POWER. *) + Hint Rewrite Padd_ok Psub_ok : Esimpl. Section POWER. Variable subst_l : Pol -> Pol. - Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := + Fixpoint Ppow_pos (res P:Pol) (p:positive) : Pol := match p with - | xH => subst_l (Pmul res P) + | xH => subst_l (res ** P) | xO p => Ppow_pos (Ppow_pos res P p) P p - | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P) + | xI p => subst_l ((Ppow_pos (Ppow_pos res P p) P p) ** P) end. Definition Ppow_N P n := @@ -1250,17 +959,23 @@ Section POWER. | Npos p => Ppow_pos P1 P p end. - Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. + Lemma Ppow_pos_ok l : + (forall P, subst_l P@l == P@l) -> + forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. Proof. - intros l subst_l_ok res P p. generalize res;clear res. - induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp. - rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl. + intros subst_l_ok res P p. revert res. + induction p;simpl;intros; rewrite ?subst_l_ok, ?Pmul_ok, ?IHp; + mul_permut. Qed. - Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> - forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. - Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl. Qed. + Lemma Ppow_N_ok l : + (forall P, subst_l P@l == P@l) -> + forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. + Proof. + destruct n;simpl. + - reflexivity. + - rewrite Ppow_pos_ok by trivial. Esimpl. + Qed. End POWER. @@ -1277,69 +992,66 @@ Section POWER. match pe with | PEc c => Pc c | PEX j => mk_X j - | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_aux pe1) (norm_aux pe2) - | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) - | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) - | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) - | PEopp pe1 => Popp (norm_aux pe1) + | PEadd (PEopp pe1) pe2 => (norm_aux pe2) -- (norm_aux pe1) + | PEadd pe1 (PEopp pe2) => (norm_aux pe1) -- (norm_aux pe2) + | PEadd pe1 pe2 => (norm_aux pe1) ++ (norm_aux pe2) + | PEsub pe1 pe2 => (norm_aux pe1) -- (norm_aux pe2) + | PEmul pe1 pe2 => (norm_aux pe1) ** (norm_aux pe2) + | PEopp pe1 => -- (norm_aux pe1) | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n end. Definition norm_subst pe := subst_l (norm_aux pe). - (* - Fixpoint norm_subst (pe:PExpr) : Pol := + (** Internally, [norm_aux] is expanded in a large number of cases. + To speed-up proofs, we use an alternative definition. *) + + Definition get_PEopp pe := match pe with - | PEc c => Pc c - | PEX j => subst_l (mk_X j) - | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) - | PEadd pe1 (PEopp pe2) => - Psub (norm_subst pe1) (norm_subst pe2) - | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2) - | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2) - | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) - | PEopp pe1 => Popp (norm_subst pe1) - | PEpow pe1 n => Ppow_subst (norm_subst pe1) n + | PEopp pe' => Some pe' + | _ => None end. - Lemma norm_subst_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. + Lemma norm_aux_PEadd pe1 pe2 : + norm_aux (PEadd pe1 pe2) = + match get_PEopp pe1, get_PEopp pe2 with + | Some pe1', _ => (norm_aux pe2) -- (norm_aux pe1') + | None, Some pe2' => (norm_aux pe1) -- (norm_aux pe2') + | None, None => (norm_aux pe1) ++ (norm_aux pe2) + end. Proof. - intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). - unfold subst_l;intros. - rewrite <- PNSubstL_ok;trivial. rrefl. - assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l). - intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl. - induction pe;simpl;Esimpl3. - rewrite subst_l_ok;apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe;rrefl. - unfold Ppow_subst. rewrite Ppow_N_ok. trivial. - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. + simpl (norm_aux (PEadd _ _)). + destruct pe1; [ | | | | | reflexivity | ]; + destruct pe2; simpl get_PEopp; reflexivity. Qed. -*) - Lemma norm_aux_spec : - forall l pe, MPcond lmp l -> - PEeval l pe == (norm_aux pe)@l. + + Lemma norm_aux_PEopp pe : + match get_PEopp pe with + | Some pe' => norm_aux pe = -- (norm_aux pe') + | None => True + end. + Proof. + now destruct pe. + Qed. + + Lemma norm_aux_spec l pe : + PEeval l pe == (norm_aux pe)@l. Proof. intros. - induction pe;simpl;Esimpl3. - apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. - rewrite IHpe1;rewrite IHpe2;rrefl. - rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. - rewrite IHpe;rrefl. - rewrite Ppow_N_ok by (intros;rrefl). - rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; - repeat rewrite Pmul_ok;rrefl. + induction pe. + - reflexivity. + - apply mkX_ok. + - simpl PEeval. rewrite IHpe1, IHpe2. + assert (H1 := norm_aux_PEopp pe1). + assert (H2 := norm_aux_PEopp pe2). + rewrite norm_aux_PEadd. + do 2 destruct get_PEopp; rewrite ?H1, ?H2; Esimpl; add_permut. + - simpl. rewrite IHpe1, IHpe2. Esimpl. + - simpl. rewrite IHpe1, IHpe2. now rewrite Pmul_ok. + - simpl. rewrite IHpe. Esimpl. + - simpl. rewrite Ppow_N_ok by reflexivity. + rewrite pow_th.(rpow_pow_N). destruct n0; simpl; Esimpl. + induction p;simpl; now rewrite ?IHp, ?IHpe, ?Pms_ok, ?Pmul_ok. Qed. Lemma norm_subst_spec : @@ -1347,7 +1059,7 @@ Section POWER. PEeval l pe == (norm_subst pe)@l. Proof. intros;unfold norm_subst. - unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial. + unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. Qed. End NORM_SUBST_REC. @@ -1514,27 +1226,27 @@ Section POWER. (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := match P with | Pc c => - let lm := add_pow_list (hd 0 fv) n lm in + let lm := add_pow_list (hd fv) n lm in mkadd_mult rP c lm | Pinj j Q => - add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) + add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd fv) n lm) | PX P i Q => - let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in + let rP := add_mult_dev rP P fv (N.add (Npos i) n) lm in if Q ?== P0 then rP - else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm) + else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd fv) n lm) end. Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) (lm:list (R*positive)) {struct P} : R := (* P@l * (hd 0 l)^n * lm *) match P with - | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm) - | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) + | Pc c => mkmult_c c (add_pow_list (hd fv) n lm) + | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd fv) n lm) | PX P i Q => - let rP := mult_dev P fv (Nplus (Npos i) n) lm in + let rP := mult_dev P fv (N.add (Npos i) n) lm in if Q ?== P0 then rP else - let lmq := add_pow_list (hd 0 fv) n lm in + let lmq := add_pow_list (hd fv) n lm in add_mult_dev rP Q (tail fv) N0 lmq end. @@ -1575,7 +1287,7 @@ Section POWER. (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). induction l;intros;simpl;Esimpl. destruct a;rewrite IHl;Esimpl. - rewrite (ARmul_comm ARth (pow_pos rmul r p)). rrefl. + rewrite (ARmul_comm ARth (pow_pos rmul r p)). reflexivity. intros;unfold rev'. rewrite H;simpl;Esimpl. Qed. @@ -1617,11 +1329,11 @@ Qed. Qed. Lemma add_mult_dev_ok : forall P rP fv n lm, - add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm. + add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd fv) n * r_list_pow lm. Proof. induction P;simpl;intros. - rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. - rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. + rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. + rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. change (match P3 with | Pc c => c ?=! cO | Pinj _ _ => false @@ -1630,17 +1342,19 @@ Qed. change match n with | N0 => Npos p | Npos q => Npos (p + q) - end with (Nplus (Npos p) n);trivial. + end with (N.add (Npos p) n);trivial. assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). - rewrite (H (refl_equal true)). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. - rewrite IHP2. - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + rewrite (H eq_refl). + rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. + add_permut. mul_permut. + rewrite IHP2. + rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. + add_permut. mul_permut. Qed. Lemma mult_dev_ok : forall P fv n lm, - mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm. + mult_dev P fv n lm == P@fv * pow_N rI rmul (hd fv) n * r_list_pow lm. Proof. induction P;simpl;intros;Esimpl. rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl. @@ -1653,13 +1367,15 @@ Qed. change match n with | N0 => Npos p | Npos q => Npos (p + q) - end with (Nplus (Npos p) n);trivial. + end with (N.add (Npos p) n);trivial. assert (H := Peq_ok P3 P0). destruct (P3 ?== P0). - rewrite (H (refl_equal true)). - rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + rewrite (H eq_refl). + rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. + mul_permut. rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok. - destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. + destruct n;simpl;Esimpl;rewrite pow_pos_add;Esimpl. + add_permut; mul_permut. Qed. Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P == P@fv. @@ -1676,18 +1392,18 @@ Qed. let mkmult_pow r x p := rmul r (mkpow x p) in Pphi_avoid mkpow mkopp_pow mkmult_pow. - Lemma local_mkpow_ok : - forall (r : R) (p : positive), + Lemma local_mkpow_ok r p : match p with | xI _ => rpow r (Cp_phi (Npos p)) | xO _ => rpow r (Cp_phi (Npos p)) | 1 => r end == pow_pos rmul r p. - Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed. + Proof. destruct p; now rewrite ?pow_th.(rpow_pow_N). Qed. Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. Proof. - unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl. + unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros; + now rewrite ?local_mkpow_ok. Qed. Lemma ring_rw_pow_correct : forall n lH l, @@ -1697,7 +1413,7 @@ Qed. PEeval l pe == Pphi_pow l npe. Proof. intros n lH l H1 lmp Heq1 pe npe Heq2. - rewrite Pphi_pow_ok. rewrite <- Heq2;rewrite <- Heq1. + rewrite Pphi_pow_ok, <- Heq2, <- Heq1. apply norm_subst_ok. trivial. Qed. @@ -1711,58 +1427,48 @@ Qed. Definition mkpow x p := match p with | xH => x - | xO p => mkmult_pow x x (Pdouble_minus_one p) + | xO p => mkmult_pow x x (Pos.pred_double p) | xI p => mkmult_pow x x (xO p) end. Definition mkopp_pow x p := match p with | xH => -x - | xO p => mkmult_pow (-x) x (Pdouble_minus_one p) + | xO p => mkmult_pow (-x) x (Pos.pred_double p) | xI p => mkmult_pow (-x) x (xO p) end. Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow. - Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p. + Lemma mkmult_pow_ok p r x : mkmult_pow r x p == r * x^p. Proof. - induction p;intros;simpl;Esimpl. - repeat rewrite IHp;Esimpl. - repeat rewrite IHp;Esimpl. + revert r; induction p;intros;simpl;Esimpl;rewrite !IHp;Esimpl. Qed. - Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p. + Lemma mkpow_ok p x : mkpow x p == x^p. Proof. destruct p;simpl;intros;Esimpl. - repeat rewrite mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO. - simpl;Esimpl. - trivial. + - rewrite !mkmult_pow_ok;Esimpl. + - rewrite mkmult_pow_ok;Esimpl. + change x with (x^1) at 1. + now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. Qed. - Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p. + Lemma mkopp_pow_ok p x : mkopp_pow x p == - x^p. Proof. destruct p;simpl;intros;Esimpl. - repeat rewrite mkmult_pow_ok;Esimpl. - rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. - rewrite <- Pplus_one_succ_l. - rewrite Psucc_o_double_minus_one_eq_xO. - simpl;Esimpl. - trivial. + - rewrite !mkmult_pow_ok;Esimpl. + - rewrite mkmult_pow_ok;Esimpl. + change x with (x^1) at 1. + now rewrite <- pow_pos_add, Pos.add_1_r, Pos.succ_pred_double. Qed. Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv. Proof. unfold Pphi_dev;intros;apply Pphi_avoid_ok. - intros;apply mkpow_ok. - intros;apply mkopp_pow_ok. - intros;apply mkmult_pow_ok. + - intros;apply mkpow_ok. + - intros;apply mkopp_pow_ok. + - intros;apply mkmult_pow_ok. Qed. Lemma ring_rw_correct : forall n lH l, @@ -1776,6 +1482,4 @@ Qed. apply norm_subst_ok. trivial. Qed. - End MakeRingPol. - diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index d33e9a82..7a7ffcfd 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -3,6 +3,7 @@ Require Import Setoid. Require Import BinPos. Require Import Ring_polynom. Require Import BinList. +Require Export ListTactics. Require Import InitialRing. Require Import Quote. Declare ML Module "newring_plugin". @@ -14,7 +15,7 @@ Ltac compute_assertion eqn t' t := let nft := eval vm_compute in t in pose (t' := nft); assert (eqn : t = t'); - [vm_cast_no_check (refl_equal t')|idtac]. + [vm_cast_no_check (eq_refl t')|idtac]. Ltac relation_carrier req := let ty := type of req in @@ -340,7 +341,7 @@ Ltac Ring RNG lemma lH := || idtac "can not automatically proof hypothesis :"; idtac " maybe a left member of a hypothesis is not a monomial") | vm_compute; - (exact (refl_equal true) || fail "not a valid ring equation")]). + (exact (eq_refl true) || fail "not a valid ring equation")]). Ltac Ring_norm_gen f RNG lemma lH rl := let mkFV := get_RingFV RNG in @@ -385,7 +386,7 @@ Ltac Ring_simplify_gen f RNG lH rl := let lemma := get_SimplifyLemma RNG in let l := fresh "to_rewrite" in pose (l:= rl); - generalize (refl_equal l); + generalize (eq_refl l); unfold l at 2; get_Pre RNG (); let rl := diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 4fbdcbaa..42ce4edc 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -1,14 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Require Import Setoid. -Require Import BinPos. -Require Import BinNat. +Require Import Setoid Morphisms BinPos BinNat. Set Implicit Arguments. @@ -35,48 +33,42 @@ Section Power. Variable rI : R. Variable rmul : R -> R -> R. Variable req : R -> R -> Prop. - Variable Rsth : Setoid_Theory R req. - Notation "x * y " := (rmul x y). - Notation "x == y" := (req x y). + Variable Rsth : Equivalence req. + Infix "*" := rmul. + Infix "==" := req. - Hypothesis mul_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2. - Hypothesis mul_comm : forall x y, x * y == y * x. + Hypothesis mul_ext : Proper (req ==> req ==> req) rmul. Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. - Add Setoid R req Rsth as R_set_Power. - Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed. - - Fixpoint pow_pos (x:R) (i:positive) {struct i}: R := + Fixpoint pow_pos (x:R) (i:positive) : R := match i with | xH => x - | xO i => let p := pow_pos x i in rmul p p - | xI i => let p := pow_pos x i in rmul x (rmul p p) + | xO i => let p := pow_pos x i in p * p + | xI i => let p := pow_pos x i in x * (p * p) end. - Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j. + Lemma pow_pos_swap x j : pow_pos x j * x == x * pow_pos x j. + Proof. + induction j; simpl; rewrite <- ?mul_assoc. + - f_equiv. now do 2 (rewrite IHj, mul_assoc). + - now do 2 (rewrite IHj, mul_assoc). + - reflexivity. + Qed. + + Lemma pow_pos_succ x j : + pow_pos x (Pos.succ j) == x * pow_pos x j. Proof. - induction j;simpl. - rewrite IHj. - rewrite (mul_comm x (pow_pos x j *pow_pos x j)). - setoid_rewrite (mul_comm x (pow_pos x j)) at 2. - repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - apply (Seq_refl _ _ Rsth). + induction j; simpl; try reflexivity. + rewrite IHj, <- mul_assoc; f_equiv. + now rewrite mul_assoc, pow_pos_swap, mul_assoc. Qed. - Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j. + Lemma pow_pos_add x i j : + pow_pos x (i + j) == pow_pos x i * pow_pos x j. Proof. - intro x;induction i;intros. - rewrite xI_succ_xO;rewrite Pplus_one_succ_r. - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi. - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc. - simpl;repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. - repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth). - rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc; - simpl. apply (Seq_refl _ _ Rsth). + induction i using Pos.peano_ind. + - now rewrite Pos.add_1_l, pow_pos_succ. + - now rewrite Pos.add_succ_l, !pow_pos_succ, IHi, mul_assoc. Qed. Definition pow_N (x:R) (p:N) := @@ -87,9 +79,9 @@ Section Power. Definition id_phi_N (x:N) : N := x. - Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n. + Lemma pow_N_pow_N x n : pow_N x (id_phi_N n) == pow_N x n. Proof. - intros; apply (Seq_refl _ _ Rsth). + reflexivity. Qed. End Power. @@ -98,19 +90,18 @@ Section DEFINITIONS. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). + Notation "0" := rO. Notation "1" := rI. + Infix "==" := req. Infix "+" := radd. Infix "*" := rmul. + Infix "-" := rsub. Notation "- x" := (ropp x). (** Semi Ring *) Record semi_ring_theory : Prop := mk_srt { SRadd_0_l : forall n, 0 + n == n; - SRadd_comm : forall n m, n + m == m + n ; + SRadd_comm : forall n m, n + m == m + n ; SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; SRmul_1_l : forall n, 1*n == n; SRmul_0_l : forall n, 0*n == 0; - SRmul_comm : forall n m, n*m == m*n; + SRmul_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 }. @@ -119,11 +110,11 @@ Section DEFINITIONS. (*Almost ring are no ring : Ropp_def is missing **) Record almost_ring_theory : Prop := mk_art { ARadd_0_l : forall x, 0 + x == x; - ARadd_comm : forall x y, x + y == y + x; + ARadd_comm : forall x y, x + y == y + x; ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z; ARmul_1_l : forall x, 1 * x == x; ARmul_0_l : forall x, 0 * x == 0; - ARmul_comm : forall x y, x * y == y * x; + ARmul_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; @@ -134,10 +125,10 @@ Section DEFINITIONS. (** Ring *) Record ring_theory : Prop := mk_rt { Radd_0_l : forall x, 0 + x == x; - Radd_comm : forall x y, x + y == y + x; + Radd_comm : forall x y, x + y == y + x; Radd_assoc : forall x y z, x + (y + z) == (x + y) + z; Rmul_1_l : forall x, 1 * x == x; - Rmul_comm : forall x y, x * y == y * x; + Rmul_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; @@ -148,19 +139,15 @@ Section DEFINITIONS. Record sring_eq_ext : Prop := mk_seqe { (* SRing operators are compatible with equality *) - SRadd_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; - SRmul_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2 + SRadd_ext : Proper (req ==> req ==> req) radd; + SRmul_ext : Proper (req ==> req ==> req) rmul }. Record ring_eq_ext : Prop := mk_reqe { (* Ring operators are compatible with equality *) - Radd_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2; - Rmul_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2; - Ropp_ext : forall x1 x2, x1 == x2 -> -x1 == -x2 + Radd_ext : Proper (req ==> req ==> req) radd; + Rmul_ext : Proper (req ==> req ==> req) rmul; + Ropp_ext : Proper (req ==> req) ropp }. (** Interpretation morphisms definition*) @@ -170,9 +157,9 @@ Section DEFINITIONS. Variable ceqb : C->C->bool. (* [phi] est un morphisme de [C] dans [R] *) Variable phi : C -> R. - Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y). - Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x). - Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). + Infix "+!" := cadd. Infix "-!" := csub. + Infix "*!" := cmul. Notation "-! x" := (copp x). + Infix "?=!" := ceqb. Notation "[ x ]" := (phi x). (*for semi rings*) Record semi_morph : Prop := mkRmorph { @@ -216,20 +203,18 @@ Section DEFINITIONS. End MORPHISM. (** Identity is a morphism *) - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid1. + Variable Rsth : Equivalence req. Variable reqb : R->R->bool. Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y. Definition IDphi (x:R) := x. Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi. Proof. - apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi);intros;unfold IDphi; - try apply (Seq_refl _ _ Rsth);auto. + now apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi). Qed. (** Specification of the power function *) Section POWER. - Variable Cpow : Set. + Variable Cpow : Type. Variable Cp_phi : N -> Cpow. Variable rpow : R -> Cpow -> R. @@ -239,35 +224,31 @@ Section DEFINITIONS. End POWER. - Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). + Definition pow_N_th := + mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). End DEFINITIONS. - - Section ALMOST_RING. Variable R : Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. - Notation "0" := rO. Notation "1" := rI. - Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). - Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). - Notation "x == y" := (req x y). + Notation "0" := rO. Notation "1" := rI. + Infix "==" := req. Infix "+" := radd. Infix "* " := rmul. + Infix "-" := rsub. Notation "- x" := (ropp x). (** Leibniz equality leads to a setoid theory and is extensional*) - Lemma Eqsth : Setoid_Theory R (@eq R). - Proof. constructor;red;intros;subst;trivial. Qed. + Lemma Eqsth : Equivalence (@eq R). + Proof. exact eq_equivalence. Qed. Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R). - Proof. constructor;intros;subst;trivial. Qed. + Proof. constructor;solve_proper. Qed. Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R). - Proof. constructor;intros;subst;trivial. Qed. + Proof. constructor;solve_proper. Qed. - Variable Rsth : Setoid_Theory R req. - Add Setoid R req Rsth as R_setoid2. - Ltac sreflexivity := apply (Seq_refl _ _ Rsth). + Variable Rsth : Equivalence req. Section SEMI_RING. Variable SReqe : sring_eq_ext radd rmul req. @@ -282,23 +263,24 @@ Section ALMOST_RING. Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y). Lemma SRopp_ext : forall x y, x == y -> -x == -y. - Proof. intros x y H;exact H. Qed. + Proof. intros x y H; exact H. Qed. Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req. Proof. - constructor. exact (SRadd_ext SReqe). exact (SRmul_ext SReqe). - exact SRopp_ext. + constructor. + - exact (SRadd_ext SReqe). + - exact (SRmul_ext SReqe). + - exact SRopp_ext. Qed. Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y. - Proof. intros;sreflexivity. Qed. + Proof. reflexivity. Qed. Lemma SRopp_add : forall x y, -(x + y) == -x + -y. - Proof. intros;sreflexivity. Qed. - + Proof. reflexivity. Qed. Lemma SRsub_def : forall x y, x - y == x + -y. - Proof. intros;sreflexivity. Qed. + Proof. reflexivity. Qed. Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req. Proof (mk_art 0 1 radd rmul SRsub SRopp req @@ -315,7 +297,7 @@ Section ALMOST_RING. Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req 0 1 radd rmul SRsub SRopp reqb (@IDphi R). Proof. - apply mkmorph;intros;try sreflexivity. unfold IDphi;auto. + now apply mkmorph. Qed. (* a semi_morph can be extended to a ring_morph for the almost_ring derived @@ -331,9 +313,7 @@ Section ALMOST_RING. ring_morph rO rI radd rmul SRsub SRopp req cO cI cadd cmul cadd (fun x => x) ceqb phi. Proof. - case Smorph; intros; constructor; auto. - unfold SRopp in |- *; intros. - setoid_reflexivity. + case Smorph; now constructor. Qed. End SEMI_RING. @@ -347,31 +327,28 @@ Section ALMOST_RING. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. (** Rings are almost rings*) - Lemma Rmul_0_l : forall x, 0 * x == 0. + Lemma Rmul_0_l x : 0 * x == 0. Proof. - intro x; setoid_replace (0*x) with ((0+1)*x + -x). - rewrite (Radd_0_l Rth); rewrite (Rmul_1_l Rth). - rewrite (Ropp_def Rth);sreflexivity. + setoid_replace (0*x) with ((0+1)*x + -x). + now rewrite (Radd_0_l Rth), (Rmul_1_l Rth), (Ropp_def Rth). - rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth). - rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). - rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity. + rewrite (Rdistr_l Rth), (Rmul_1_l Rth). + rewrite <- (Radd_assoc Rth), (Ropp_def Rth). + now rewrite (Radd_comm Rth), (Radd_0_l Rth). Qed. - Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y. + Lemma Ropp_mul_l x y : -(x * y) == -x * y. Proof. - intros x y;rewrite <-(Radd_0_l Rth (- x * y)). - rewrite (Radd_comm Rth). - rewrite <-(Ropp_def Rth (x*y)). - rewrite (Radd_assoc Rth). - rewrite <- (Rdistr_l Rth). - rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth). - rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity. + rewrite <-(Radd_0_l Rth (- x * y)). + rewrite (Radd_comm Rth), <-(Ropp_def Rth (x*y)). + rewrite (Radd_assoc Rth), <- (Rdistr_l Rth). + rewrite (Rth.(Radd_comm) (-x)), (Ropp_def Rth). + now rewrite Rmul_0_l, (Radd_0_l Rth). Qed. - Lemma Ropp_add : forall x y, -(x + y) == -x + -y. + Lemma Ropp_add x y : -(x + y) == -x + -y. Proof. - intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))). + rewrite <- ((Radd_0_l Rth) (-(x+y))). rewrite <- ((Ropp_def Rth) x). rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))). rewrite <- ((Ropp_def Rth) y). @@ -383,17 +360,17 @@ Section ALMOST_RING. rewrite ((Radd_comm Rth) y). rewrite <- ((Radd_assoc Rth) (- x)). rewrite ((Radd_assoc Rth) y). - rewrite ((Radd_comm Rth) y);rewrite (Ropp_def Rth). - rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth). - apply (Radd_comm Rth). + rewrite ((Radd_comm Rth) y), (Ropp_def Rth). + rewrite ((Radd_comm Rth) (-x) 0), (Radd_0_l Rth). + now apply (Radd_comm Rth). Qed. - Lemma Ropp_opp : forall x, - -x == x. + Lemma Ropp_opp x : - -x == x. Proof. - intros x; rewrite <- (Radd_0_l Rth (- -x)). + rewrite <- (Radd_0_l Rth (- -x)). rewrite <- (Ropp_def Rth x). - rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth). - rewrite ((Radd_comm Rth) x);apply (Radd_0_l Rth). + rewrite <- (Radd_assoc Rth), (Ropp_def Rth). + rewrite ((Radd_comm Rth) x); now apply (Radd_0_l Rth). Qed. Lemma Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. @@ -407,10 +384,10 @@ Section ALMOST_RING. Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C). Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool). Variable phi : C -> R. - Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). - Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). - Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - Variable Csth : Setoid_Theory C ceq. + Infix "+!" := cadd. Infix "*!" := cmul. + Infix "-!" := csub. Notation "-! x" := (copp x). + Notation "?=!" := ceqb. Notation "[ x ]" := (phi x). + Variable Csth : Equivalence ceq. Variable Ceqe : ring_eq_ext cadd cmul copp ceq. Add Setoid C ceq Csth as C_setoid. Add Morphism cadd : cadd_ext. exact (Radd_ext Ceqe). Qed. @@ -420,9 +397,9 @@ Section ALMOST_RING. Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi. Variable phi_ext : forall x y, ceq x y -> [x] == [y]. Add Morphism phi : phi_ext1. exact phi_ext. Qed. - Lemma Smorph_opp : forall x, [-!x] == -[x]. + Lemma Smorph_opp x : [-!x] == -[x]. Proof. - intros x;rewrite <- (Rth.(Radd_0_l) [-!x]). + rewrite <- (Rth.(Radd_0_l) [-!x]). rewrite <- ((Ropp_def Rth) [x]). rewrite ((Radd_comm Rth) [x]). rewrite <- (Radd_assoc Rth). @@ -430,17 +407,18 @@ Section ALMOST_RING. rewrite (Ropp_def Cth). rewrite (Smorph0 Smorph). rewrite (Radd_comm Rth (-[x])). - apply (Radd_0_l Rth);sreflexivity. + now apply (Radd_0_l Rth). Qed. - Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y]. + Lemma Smorph_sub x y : [x -! y] == [x] - [y]. Proof. - intros x y; rewrite (Rsub_def Cth);rewrite (Rsub_def Rth). - rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity. + rewrite (Rsub_def Cth), (Rsub_def Rth). + now rewrite (Smorph_add Smorph), Smorph_opp. Qed. - Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req - cO cI cadd cmul csub copp ceqb phi. + Lemma Smorph_morph : + ring_morph 0 1 radd rmul rsub ropp req + cO cI cadd cmul csub copp ceqb phi. Proof (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi (Smorph0 Smorph) (Smorph1 Smorph) @@ -458,17 +436,11 @@ elim ARth; intros. constructor; trivial. Qed. - Lemma ARsub_ext : - forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. + Instance ARsub_ext : Proper (req ==> req ==> req) rsub. Proof. - intros. - setoid_replace (x1 - y1) with (x1 + -y1). - setoid_replace (x2 - y2) with (x2 + -y2). - rewrite H;rewrite H0;sreflexivity. - apply (ARsub_def ARth). - apply (ARsub_def ARth). + intros x1 x2 Ex y1 y2 Ey. + now rewrite !(ARsub_def ARth), Ex, Ey. Qed. - Add Morphism rsub : rsub_ext. exact ARsub_ext. Qed. Ltac mrewrite := repeat first @@ -479,64 +451,56 @@ Qed. | rewrite (ARmul_0_l ARth) | rewrite <- ((ARmul_comm ARth) 0) | rewrite (ARdistr_l ARth) - | sreflexivity + | reflexivity | match goal with | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) end]. - Lemma ARadd_0_r : forall x, (x + 0) == x. - Proof. intros; mrewrite. Qed. + Lemma ARadd_0_r x : x + 0 == x. + Proof. mrewrite. Qed. - Lemma ARmul_1_r : forall x, x * 1 == x. - Proof. intros;mrewrite. Qed. + Lemma ARmul_1_r x : x * 1 == x. + Proof. mrewrite. Qed. - Lemma ARmul_0_r : forall x, x * 0 == 0. - Proof. intros;mrewrite. Qed. + Lemma ARmul_0_r x : x * 0 == 0. + Proof. mrewrite. Qed. - Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y. + Lemma ARdistr_r x y z : z * (x + y) == z*x + z*y. Proof. - intros;mrewrite. - repeat rewrite (ARth.(ARmul_comm) z);sreflexivity. + mrewrite. now rewrite !(ARth.(ARmul_comm) z). Qed. - Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x. + Lemma ARadd_assoc1 x y z : (x + y) + z == (y + z) + x. Proof. - intros;rewrite <-(ARth.(ARadd_assoc) x). - rewrite (ARth.(ARadd_comm) x);sreflexivity. + now rewrite <-(ARth.(ARadd_assoc) x), (ARth.(ARadd_comm) x). Qed. - Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x. + Lemma ARadd_assoc2 x y z : (y + x) + z == (y + z) + x. Proof. - intros; repeat rewrite <- (ARadd_assoc ARth); - rewrite ((ARadd_comm ARth) x); sreflexivity. + now rewrite <- !(ARadd_assoc ARth), ((ARadd_comm ARth) x). Qed. - Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x. + Lemma ARmul_assoc1 x y z : (x * y) * z == (y * z) * x. Proof. - intros;rewrite <-((ARmul_assoc ARth) x). - rewrite ((ARmul_comm ARth) x);sreflexivity. + now rewrite <- ((ARmul_assoc ARth) x), ((ARmul_comm ARth) x). Qed. - Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x. + Lemma ARmul_assoc2 x y z : (y * x) * z == (y * z) * x. Proof. - intros; repeat rewrite <- (ARmul_assoc ARth); - rewrite ((ARmul_comm ARth) x); sreflexivity. + now rewrite <- !(ARmul_assoc ARth), ((ARmul_comm ARth) x). Qed. - Lemma ARopp_mul_r : forall x y, - (x * y) == x * -y. + Lemma ARopp_mul_r x y : - (x * y) == x * -y. Proof. - intros;rewrite ((ARmul_comm ARth) x y); - rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth). + rewrite ((ARmul_comm ARth) x y), (ARopp_mul_l ARth). + now apply (ARmul_comm ARth). Qed. Lemma ARopp_zero : -0 == 0. Proof. - rewrite <- (ARmul_0_r 0); rewrite (ARopp_mul_l ARth). - repeat rewrite ARmul_0_r; sreflexivity. + now rewrite <- (ARmul_0_r 0), (ARopp_mul_l ARth), !ARmul_0_r. Qed. - - End ALMOST_RING. @@ -590,12 +554,29 @@ Ltac gen_srewrite Rsth Reqe ARth := | progress rewrite <- (ARopp_mul_l ARth) | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ]. +Ltac gen_srewrite_sr Rsth Reqe ARth := + repeat first + [ gen_reflexivity Rsth + | progress rewrite (ARopp_zero Rsth Reqe ARth) + | rewrite (ARadd_0_l ARth) + | rewrite (ARadd_0_r Rsth ARth) + | rewrite (ARmul_1_l ARth) + | rewrite (ARmul_1_r Rsth ARth) + | rewrite (ARmul_0_l ARth) + | rewrite (ARmul_0_r Rsth ARth) + | rewrite (ARdistr_l ARth) + | rewrite (ARdistr_r Rsth Reqe ARth) + | rewrite (ARadd_assoc ARth) + | rewrite (ARmul_assoc ARth) ]. + Ltac gen_add_push add Rsth Reqe ARth x := repeat (match goal with | |- context [add (add ?y x) ?z] => progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z) | |- context [add (add x ?y) ?z] => progress rewrite (ARadd_assoc1 Rsth ARth x y z) + | |- context [(add x ?y)] => + progress rewrite (ARadd_comm ARth x y) end). Ltac gen_mul_push mul Rsth Reqe ARth x := @@ -604,5 +585,6 @@ Ltac gen_mul_push mul Rsth Reqe ARth x := progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z) | |- context [mul (mul x ?y) ?z] => progress rewrite (ARmul_assoc1 Rsth ARth x y z) + | |- context [(mul x ?y)] => + progress rewrite (ARmul_comm ARth x y) end). - diff --git a/plugins/setoid_ring/Rings_Q.v b/plugins/setoid_ring/Rings_Q.v new file mode 100644 index 00000000..fd765471 --- /dev/null +++ b/plugins/setoid_ring/Rings_Q.v @@ -0,0 +1,30 @@ +Require Export Cring. +Require Export Integral_domain. + +(* Rational numbers *) +Require Import QArith. + +Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). + +Instance Qri : (Ring (Ro:=Qops)). +constructor. +try apply Q_Setoid. +apply Qplus_comp. +apply Qmult_comp. +apply Qminus_comp. +apply Qopp_comp. + exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. + exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. + apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. +reflexivity. exact Qplus_opp_r. +Defined. + +Instance Qcri: (Cring (Rr:=Qri)). +red. exact Qmult_comm. Defined. + +Lemma Q_one_zero: not (Qeq 1%Q 0%Q). +unfold Qeq. simpl. auto with *. Qed. + +Instance Qdi : (Integral_domain (Rcr:=Qcri)). +constructor. +exact Qmult_integral. exact Q_one_zero. Defined. diff --git a/plugins/setoid_ring/Rings_R.v b/plugins/setoid_ring/Rings_R.v new file mode 100644 index 00000000..fd219c23 --- /dev/null +++ b/plugins/setoid_ring/Rings_R.v @@ -0,0 +1,34 @@ +Require Export Cring. +Require Export Integral_domain. + +(* Real numbers *) +Require Import Reals. +Require Import RealField. + +Lemma Rsth : Setoid_Theory R (@eq R). +constructor;red;intros;subst;trivial. +Qed. + +Instance Rops: (@Ring_ops R 0%R 1%R Rplus Rmult Rminus Ropp (@eq R)). + +Instance Rri : (Ring (Ro:=Rops)). +constructor; +try (try apply Rsth; + try (unfold respectful, Proper; unfold equality; unfold eq_notation in *; + intros; try rewrite H; try rewrite H0; reflexivity)). + exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. + exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. + exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. +exact Rplus_opp_r. +Defined. + +Instance Rcri: (Cring (Rr:=Rri)). +red. exact Rmult_comm. Defined. + +Lemma R_one_zero: 1%R <> 0%R. +discrR. +Qed. + +Instance Rdi : (Integral_domain (Rcr:=Rcri)). +constructor. +exact Rmult_integral. exact R_one_zero. Defined. diff --git a/plugins/setoid_ring/Rings_Z.v b/plugins/setoid_ring/Rings_Z.v new file mode 100644 index 00000000..58a4d7ea --- /dev/null +++ b/plugins/setoid_ring/Rings_Z.v @@ -0,0 +1,14 @@ +Require Export Cring. +Require Export Integral_domain. +Require Export Ncring_initial. + +Instance Zcri: (Cring (Rr:=Zr)). +red. exact Z.mul_comm. Defined. + +Lemma Z_one_zero: 1%Z <> 0%Z. +omega. +Qed. + +Instance Zdi : (Integral_domain (Rcr:=Zcri)). +constructor. +exact Zmult_integral. exact Z_one_zero. Defined. diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v index 362542b9..3c4f6b86 100644 --- a/plugins/setoid_ring/ZArithRing.v +++ b/plugins/setoid_ring/ZArithRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -27,11 +27,7 @@ Ltac isZpow_coef t := | _ => constr:false end. -Definition N_of_Z x := - match x with - | Zpos p => Npos p - | _ => N0 - end. +Notation N_of_Z := Z.to_N (only parsing). Ltac Zpow_tac t := match isZpow_coef t with @@ -43,14 +39,14 @@ Ltac Zpower_neg := repeat match goal with | [|- ?G] => match G with - | context c [Zpower _ (Zneg _)] => + | context c [Z.pow _ (Zneg _)] => let t := context c [Z0] in change t end end. Add Ring Zr : Zth - (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc], + (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Z.succ], power_tac Zpower_theory [Zpow_tac], (* The two following option are not needed, it is the default chose when the set of coefficiant is usual ring Z *) diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 820246af..580e78f6 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -8,8 +8,6 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(*i $Id: newring.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pp open Util open Names @@ -18,8 +16,7 @@ open Closure open Environ open Libnames open Tactics -open Rawterm -open Termops +open Glob_term open Tacticals open Tacexpr open Pcoq @@ -87,7 +84,7 @@ let interp_map l c = with Not_found -> None let interp_map l t = - try Some(List.assoc t l) with Not_found -> None + try Some(list_assoc_f eq_constr t l) with Not_found -> None let protect_maps = ref Stringmap.empty let add_map s m = protect_maps := Stringmap.add s m !protect_maps @@ -98,13 +95,13 @@ let lookup_map map = let protect_red map env sigma c = kl (create_clos_infos betadeltaiota env) - (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);; + (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);; let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None ;; let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id,InHyp));; + Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Termops.InHyp));; TACTIC EXTEND protect_fv @@ -144,7 +141,7 @@ 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.globwit_constr (GVar(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" @@ -161,18 +158,18 @@ 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_secctx = None; const_entry_type = None; - const_entry_opaque = true; - const_entry_boxed = true}, + const_entry_opaque = true }, IsProof Lemma)) (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = - TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)) + TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args)) (* Calling a locally bound tactic *) let ltac_lcall tac args = - TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args)) + TacArg(dummy_loc,TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args)) let ltac_letin (x, e1) e2 = TacLetIn(false,[(dummy_loc,id_of_string x),e1],e2) @@ -188,8 +185,10 @@ let ltac_record flds = let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) let dummy_goal env = - {Evd.it = Evd.make_evar (named_context_val env) mkProp; - Evd.sigma = Evd.empty} + let (gl,_,sigma) = + Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Store.empty in + {Evd.it = gl; + Evd.sigma = sigma} let exec_tactic env n f args = let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in @@ -344,7 +343,7 @@ type ring_info = ring_pre_tac : glob_tactic_expr; ring_post_tac : glob_tactic_expr } -module Cmap = Map.Make(struct type t = constr let compare = compare end) +module Cmap = Map.Make(struct type t = constr let compare = constr_ord end) let from_carrier = ref Cmap.empty let from_relation = ref Cmap.empty @@ -415,7 +414,7 @@ let subst_th (subst,th) = let posttac'= subst_tactic subst th.ring_post_tac in if c' == th.ring_carrier && eq' == th.ring_req && - set' = th.ring_setoid && + eq_constr set' th.ring_setoid && ext' == th.ring_ext && morph' == th.ring_morph && th' == th.ring_th && @@ -440,7 +439,7 @@ let subst_th (subst,th) = ring_post_tac = posttac' } -let (theory_to_obj, obj_to_theory) = +let theory_to_obj : ring_info -> obj = let cache_th (name,th) = add_entry name th in declare_object {(default_object "tactic-new-ring-theory") with @@ -576,13 +575,13 @@ 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 -> + when eq_constr f (Lazy.force coq_almost_ring_theory) -> (None,r,zero,one,add,mul,Some sub,Some opp,req) | App(f,[|r;zero;one;add;mul;req|]) - when f = Lazy.force coq_semi_ring_theory -> + when eq_constr f (Lazy.force coq_semi_ring_theory) -> (Some true,r,zero,one,add,mul,None,None,req) | App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when f = Lazy.force coq_ring_theory -> + when eq_constr f (Lazy.force coq_ring_theory) -> (Some false,r,zero,one,add,mul,Some sub,Some opp,req) | _ -> error "bad ring structure" @@ -592,10 +591,10 @@ let dest_morph env sigma m_spec = match kind_of_term m_typ with App(f,[|r;zero;one;add;mul;sub;opp;req; c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|]) - when f = Lazy.force coq_ring_morph -> + when eq_constr f (Lazy.force coq_ring_morph) -> (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi) | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|]) - when f = Lazy.force coq_semi_morph -> + when eq_constr f (Lazy.force coq_semi_morph) -> (c,czero,cone,cadd,cmul,None,None,ceqb,phi) | _ -> error "bad morphism structure" @@ -626,23 +625,23 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = (match rk, opp, kind with Abstract, None, _ -> let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in - TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) + TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul])) | Abstract, Some opp, Some _ -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in - TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) + TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) | Abstract, Some opp, None -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in TacArg - (TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) + (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp])) | Computational _,_,_ -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in TacArg - (TacCall(dummy_loc,t,List.map carg [zero;one;zero;one])) + (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;zero;one])) | Morphism mth,_,_ -> let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in TacArg - (TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone]))) + (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone]))) let make_hyp env c = let t = Retyping.get_type_of env Evd.empty c in @@ -659,7 +658,7 @@ let interp_power env pow = match pow with | None -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in - (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) + (TacArg(dummy_loc,TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) | Some (tac, spec) -> let tac = match tac with @@ -832,7 +831,7 @@ let ring_lookup (f:glob_tactic_expr) lH rl t gl = TACTIC EXTEND ring_lookup | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> - [ let (t,lr) = list_sep_last lrt in ring_lookup (fst f) lH lr t] + [ let (t,lr) = list_sep_last lrt in ring_lookup f lH lr t] END @@ -893,18 +892,18 @@ 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 -> + when eq_constr 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 -> + when eq_constr 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 -> + when eq_constr 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) @@ -1016,7 +1015,7 @@ let subst_th (subst,th) = field_pre_tac = pretac'; field_post_tac = posttac' } -let (ftheory_to_obj, obj_to_ftheory) = +let ftheory_to_obj : field_info -> obj = let cache_th (name,th) = add_field_entry name th in declare_object {(default_object "tactic-new-field-theory") with @@ -1160,5 +1159,5 @@ let field_lookup (f:glob_tactic_expr) lH rl t gl = TACTIC EXTEND field_lookup | [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> - [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ] + [ let (t,l) = list_sep_last lt in field_lookup f lH l t ] END diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget index 6934375b..580df9b5 100644 --- a/plugins/setoid_ring/vo.itarget +++ b/plugins/setoid_ring/vo.itarget @@ -13,3 +13,13 @@ Ring_tac.vo Ring_theory.vo Ring.vo ZArithRing.vo +Algebra_syntax.vo +Cring.vo +Ncring.vo +Ncring_polynom.vo +Ncring_initial.vo +Ncring_tac.vo +Rings_Z.vo +Rings_R.vo +Rings_Q.vo +Integral_domain.vo
\ No newline at end of file diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml index 3fb6824b..f4d8b769 100644 --- a/plugins/subtac/eterm.ml +++ b/plugins/subtac/eterm.ml @@ -1,4 +1,3 @@ -(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) (** - Get types of existentials ; - Flatten dependency tree (prefix order) ; @@ -28,11 +27,15 @@ type oblinfo = ev_hyps: named_context; ev_status: obligation_definition_status; ev_chop: int option; - ev_source: hole_kind located; + ev_src: hole_kind located; ev_typ: types; ev_tac: tactic option; ev_deps: Intset.t } +(* spiwack: Store field for internalizing ev_tac in evar_infos' evar_extra. *) +open Store.Field +let evar_tactic = Store.field () + (** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) @@ -129,18 +132,29 @@ let rec chop_product n t = | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None | _ -> None -let evar_dependencies evm ev = +let evars_of_evar_info evi = + Intset.union (Evarutil.evars_of_term evi.evar_concl) + (Intset.union + (match evi.evar_body with + | Evar_empty -> Intset.empty + | Evar_defined b -> Evarutil.evars_of_term b) + (Evarutil.evars_of_named_context (evar_filtered_context evi))) + +let evar_dependencies evm oev = let one_step deps = Intset.fold (fun ev s -> let evi = Evd.find evm ev in - Intset.union (Evarutil.evars_of_evar_info evi) s) + let deps' = evars_of_evar_info evi in + if Intset.mem oev deps' then + raise (Invalid_argument ("Ill-formed evar map: cycle detected for evar " ^ string_of_int oev)) + else Intset.union deps' s) deps deps in let rec aux deps = let deps' = one_step deps in if Intset.equal deps deps' then deps else aux deps' - in aux (Intset.singleton ev) + in aux (Intset.singleton oev) let move_after (id, ev, deps as obl) l = let rec aux restdeps = function @@ -210,7 +224,7 @@ let eterm_obligations env name isevars evm fs ?status t ty = | Some s -> s, None | None -> Define true, None in - let tac = match ev.evar_extra with + let tac = match evar_tactic.get ev.evar_extra with | Some t -> if Dyn.tag t = "tactic" then Some (Tacinterp.interp @@ -218,9 +232,9 @@ let eterm_obligations env name isevars evm fs ?status t ty = else None | None -> None in - let info = { ev_name = (n, nstr); ev_hyps = hyps; - ev_status = status; ev_chop = chop; - ev_source = (loc, k); ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } + let info = { ev_name = (n, nstr); + ev_hyps = hyps; ev_status = status; ev_chop = chop; + ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } in (id, info) :: l) evn [] in @@ -231,12 +245,12 @@ let eterm_obligations env name isevars evm fs ?status t ty = let evars = List.map (fun (ev, info) -> let { ev_name = (_, name); ev_status = status; - ev_source = source; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info + ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info in let status = match status with | Define true when Idset.mem name transparent -> Define false | _ -> status - in name, typ, source, status, deps, tac) evts + in name, typ, src, status, deps, tac) evts in let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in let evmap f c = pi1 (subst_evar_constr evts 0 f c) in diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli index b4bbe3d5..a0b693de 100644 --- a/plugins/subtac/eterm.mli +++ b/plugins/subtac/eterm.mli @@ -1,12 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: eterm.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) open Environ open Tacmach open Term diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4 index ce6d12be..6e7a8d32 100644 --- a/plugins/subtac/g_subtac.ml4 +++ b/plugins/subtac/g_subtac.ml4 @@ -1,21 +1,17 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo" i*) - (* Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) -(* $Id: g_subtac.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Flags open Util @@ -37,14 +33,14 @@ module Tactic = Pcoq.Tactic module SubtacGram = struct - let gec s = Gram.Entry.create ("Subtac."^s) + let gec s = Gram.entry_create ("Subtac."^s) (* types *) - let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc" + let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.entry = gec "subtac_gallina_loc" - let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.Entry.e = gec "subtac_withtac" + let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.entry = gec "subtac_withtac" end -open Rawterm +open Glob_term open SubtacGram open Util open Pcoq @@ -79,14 +75,14 @@ type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstra let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype), (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype), (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) = - Genarg.create_arg "subtac_gallina_loc" + Genarg.create_arg None "subtac_gallina_loc" type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type let (wit_subtac_withtac : Genarg.tlevel withtac_argtype), (globwit_subtac_withtac : Genarg.glevel withtac_argtype), (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) = - Genarg.create_arg "subtac_withtac" + Genarg.create_arg None "subtac_withtac" VERNAC COMMAND EXTEND Subtac [ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ] @@ -94,7 +90,8 @@ VERNAC COMMAND EXTEND Subtac let try_catch_exn f e = try f e - with exn -> errorlabstrm "Program" (Cerrors.explain_exn exn) + with exn when Errors.noncritical exn -> + errorlabstrm "Program" (Errors.print exn) let subtac_obligation e = try_catch_exn Subtac_obligations.subtac_obligation e let next_obligation e = try_catch_exn Subtac_obligations.next_obligation e diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml index 95cacc38..ad248bfb 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - +open Compat open Global open Pp open Util @@ -27,7 +26,7 @@ open List open Recordops open Evarutil open Pretype_errors -open Rawterm +open Glob_term open Evarconv open Pattern open Vernacexpr @@ -50,7 +49,7 @@ open Tacinterp open Tacexpr let solve_tccs_in_type env id isevars evm c typ = - if not (evm = Evd.empty) then + if not (Evd.is_empty evm) then let stmt_id = Nameops.add_suffix id "_stmt" in let obls, _, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in match Subtac_obligations.add_definition stmt_id ~term:c' typ obls with @@ -83,13 +82,11 @@ let start_proof_com env isevars sopt kind (bl,t) hook = Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true [imps]; hook loc gr) -let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () - let start_proof_and_print env isevars idopt k t hook = start_proof_com env isevars idopt k t hook; - print_subgoals () + Vernacentries.print_subgoals () -let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) +let _ = Detyping.set_detype_anonymous (fun loc n -> GVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) let assumption_message id = Flags.if_verbose message ((string_of_id id) ^ " is assumed") @@ -142,12 +139,12 @@ let subtac (loc, command) = (fun _ _ -> ()) | DefineBody (bl, _, c, tycon) -> ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon)) - | VernacFixpoint (l, b) -> + | VernacFixpoint l -> List.iter (fun ((lid, _, _, _, _), _) -> check_fresh lid; Dumpglob.dump_definition lid false "fix") l; let _ = trace (str "Building fixpoint") in - ignore(Subtac_command.build_recursive l b) + ignore(Subtac_command.build_recursive l) | VernacStartTheoremProof (thkind, [Some id, (bl,t,guard)], lettop, hook) -> if guard <> None then @@ -172,10 +169,10 @@ let subtac (loc, command) = error "Declare Instance not supported here."; ignore(Subtac_classes.new_instance ~global:glob sup is props pri) - | VernacCoFixpoint (l, b) -> + | VernacCoFixpoint l -> if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; - ignore(Subtac_command.build_corecursive l b) + ignore(Subtac_command.build_corecursive l) (*| VernacEndProof e -> subtac_end_proof e*) @@ -219,6 +216,11 @@ let subtac (loc, command) = | Type_errors.TypeError (env, exn) as e -> raise e - | Pretype_errors.PretypeError (env, exn) as e -> raise e + | Pretype_errors.PretypeError (env, _, exn) as e -> raise e + + | (Loc.Exc_located (loc, Proof_type.LtacLocated (_,e')) | + Loc.Exc_located (loc, e') as e) -> raise e - | e -> raise e + | reraise -> + (* msg_warning (str "Uncaught exception: " ++ Errors.print e); *) + raise reraise diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml index 25aec39c..0b1ed9bb 100644 --- a/plugins/subtac/subtac_cases.ml +++ b/plugins/subtac/subtac_cases.ml @@ -1,14 +1,11 @@ -(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_cases.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Cases open Util open Names @@ -23,7 +20,7 @@ open Sign open Reductionops open Typeops open Type_errors -open Rawterm +open Glob_term open Retyping open Pretype_errors open Evarutil @@ -89,7 +86,7 @@ let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) = type rhs = { rhs_env : env; avoid_ids : identifier list; - it : rawconstr; + it : glob_constr; } type equation = @@ -158,22 +155,22 @@ let feed_history arg = function (* This is for non exhaustive error message *) -let rec rawpattern_of_partial_history args2 = function +let rec glob_pattern_of_partial_history args2 = function | Continuation (n, args1, h) -> let args3 = make_anonymous_patvars (n - (List.length args2)) in - build_rawpattern (List.rev_append args1 (args2@args3)) h + build_glob_pattern (List.rev_append args1 (args2@args3)) h | Result pl -> pl -and build_rawpattern args = function +and build_glob_pattern args = function | Top -> args | MakeAlias (AliasLeaf, rh) -> assert (args = []); - rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh + glob_pattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh | MakeAlias (AliasConstructor pci, rh) -> - rawpattern_of_partial_history + glob_pattern_of_partial_history [PatCstr (dummy_loc, pci, args, Anonymous)] rh -let complete_history = rawpattern_of_partial_history [] +let complete_history = glob_pattern_of_partial_history [] (* This is to build glued pattern-matching history and alias bodies *) @@ -237,7 +234,7 @@ type pattern_matching_problem = mat : matrix; caseloc : loc; casestyle: case_style; - typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment } + typing_function: type_constraint -> env -> glob_constr -> unsafe_judgment } (*--------------------------------------------------------------------------* * A few functions to infer the inductive type from the patterns instead of * @@ -345,7 +342,7 @@ let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = let pred = predicate 0 c in let env' = push_rel_context (context_of_arsign arsign) env in ignore(Typing.sort_of env' evm pred); pred - with _ -> lift nar c + with e when Errors.noncritical e -> lift nar c module Cases_F(Coercion : Coercion.S) : S = struct @@ -369,10 +366,10 @@ let find_tomatch_tycon isevars env loc = function | None -> empty_tycon let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) = - let loc = Some (loc_of_rawconstr tomatch) in + let loc = Some (loc_of_glob_constr tomatch) in let tycon = find_tomatch_tycon isevars env loc indopt in let j = typing_fun tycon env tomatch in - let evd, j = Coercion.inh_coerce_to_base (loc_of_rawconstr tomatch) env !isevars j in + let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !isevars j in isevars := evd; let typ = nf_evar ( !isevars) j.uj_type in let t = @@ -530,7 +527,7 @@ let extract_rhs pb = let occur_in_rhs na rhs = match na with | Anonymous -> false - | Name id -> occur_rawconstr id rhs.it + | Name id -> occur_glob_constr id rhs.it let is_dep_patt eqn = function | PatVar (_,name) -> occur_in_rhs name eqn.rhs @@ -604,7 +601,7 @@ let regeneralize_index_tomatch n = genrec 0 let rec replace_term n c k t = - if t = mkRel (n+k) then lift k c + if isRel t && destRel t = n+k then lift k c else map_constr_with_binders succ (replace_term n c) k t let replace_tomatch n c = @@ -1468,7 +1465,8 @@ let extract_arity_signatures env0 tomatchl tmsign = | None -> list_tabulate (fun _ -> Anonymous) nrealargs in let arsign = fst (get_arity env0 indf) in (na,None,build_dependent_inductive env0 indf) - ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with _ -> assert false) in + ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign + with e when Errors.noncritical e -> assert false) in let rec buildrec = function | [],[] -> [] | (_,tm)::ltm, x::tmsign -> @@ -1518,7 +1516,7 @@ let mk_JMeq typ x typ' y = mkApp (delayed_force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) let mk_JMeq_refl typ x = mkApp (delayed_force Subtac_utils.jmeq_refl, [| typ; x |]) -let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true)) +let hole = GHole (dummy_loc, Evd.QuestionMark (Evd.Define true)) let constr_of_pat env isevars arsign pat avoid = let rec typ env (ty, realargs) pat avoid = @@ -1534,7 +1532,7 @@ let constr_of_pat env isevars arsign pat avoid = | PatCstr (l,((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in let IndType (indf, _) = - try find_rectype env ( !isevars) (lift (-(List.length realargs)) ty) + try find_rectype env ( !isevars) (lift (-(List.length realargs)) ty) with Not_found -> error_case_not_inductive env {uj_val = ty; uj_type = Typing.type_of env !isevars ty} in @@ -1548,7 +1546,7 @@ let constr_of_pat env isevars arsign pat avoid = List.fold_right2 (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) -> let pat', sign', arg', typ', argtypargs, n', avoid = - typ env (lift (n - m) t, []) ua avoid + typ env (substl args (liftn (List.length sign) (succ (List.length args)) t), []) ua avoid in let args' = arg' :: List.map (lift n') args in let env' = push_rels sign' env in @@ -1607,12 +1605,12 @@ let vars_of_ctx ctx = match b with | Some t' when kind_of_term t' = Rel 0 -> prev, - (RApp (dummy_loc, - (RRef (dummy_loc, delayed_force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars + (GApp (dummy_loc, + (GRef (dummy_loc, delayed_force refl_ref)), [hole; GVar (dummy_loc, prev)])) :: vars | _ -> match na with Anonymous -> raise (Invalid_argument "vars_of_ctx") - | Name n -> n, RVar (dummy_loc, n) :: vars) + | Name n -> n, GVar (dummy_loc, n) :: vars) ctx (id_of_string "vars_of_ctx_error", []) in List.rev y @@ -1744,13 +1742,13 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let branch_name = id_of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in let branch = - let bref = RVar (dummy_loc, branch_name) in + let bref = GVar (dummy_loc, branch_name) in match vars_of_ctx rhs_rels with [] -> bref - | l -> RApp (dummy_loc, bref, l) + | l -> GApp (dummy_loc, bref, l) in let branch = match ineqs with - Some _ -> RApp (dummy_loc, branch, [ hole ]) + Some _ -> GApp (dummy_loc, branch, [ hole ]) | None -> branch in incr i; @@ -1786,7 +1784,7 @@ let abstract_tomatch env tomatchs tycon = Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon | _ -> let tycon = Option.map - (fun t -> subst_term_occ all_occurrences (lift 1 c) (lift 1 t)) tycon in + (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in let name = next_ident_away (id_of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, @@ -1848,7 +1846,7 @@ let build_dependent_signature env evars avoid tomatchs arsign = refl_arg :: refl_args, pred slift, (Name id, b, t) :: argsign')) - (env, 0, [], [], slift, []) args argsign + (env, neqs, [], [], slift, []) args argsign in let eq = mk_JMeq (lift (nargeqs + slift) appt) diff --git a/plugins/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli index bc2b2bb7..91142067 100644 --- a/plugins/subtac/subtac_cases.mli +++ b/plugins/subtac/subtac_cases.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtac_cases.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*i*) open Util open Names @@ -15,7 +13,7 @@ open Term open Evd open Environ open Inductiveops -open Rawterm +open Glob_term open Evarutil (*i*) diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml index 960bf162..f11f611f 100644 --- a/plugins/subtac/subtac_classes.ml +++ b/plugins/subtac/subtac_classes.ml @@ -1,19 +1,16 @@ -(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtac_classes.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pretyping open Evd open Environ open Term -open Rawterm +open Glob_term open Topconstr open Names open Libnames @@ -23,24 +20,28 @@ open Constrintern open Subtac_command open Typeclasses open Typeclasses_errors -open Termops open Decl_kinds open Entries open Util module SPretyping = Subtac_pretyping.Pretyping -let interp_constr_evars_gen evdref env ?(impls=[]) kind c = +let interp_constr_evars_gen evdref env ?(impls=Constrintern.empty_internalization_env) kind c = SPretyping.understand_tcc_evars evdref env kind - (intern_gen (kind=IsType) ~impls ( !evdref) env c) + (intern_gen (kind=IsType) ~impls !evdref env c) -let interp_casted_constr_evars evdref env ?(impls=[]) c typ = +let interp_casted_constr_evars evdref env ?(impls=Constrintern.empty_internalization_env) c typ = interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c let interp_context_evars evdref env params = - Constrintern.interp_context_gen + let impls_env, bl = Constrintern.interp_context_gen (fun env t -> SPretyping.understand_tcc_evars evdref env IsType t) - (SPretyping.understand_judgment_tcc evdref) !evdref env params + (SPretyping.understand_judgment_tcc evdref) !evdref env params in bl + +let interp_type_evars_impls ~evdref ?(impls=empty_internalization_env) env c = + let c = intern_gen true ~impls !evdref env c in + let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in + SPretyping.understand_tcc_evars ~fail_evar:false evdref env IsType c, imps let type_ctx_instance evars env ctx inst subst = let rec aux (subst, instctx) l = function @@ -51,7 +52,7 @@ let type_ctx_instance evars env ctx inst subst = | None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l | Some b -> substl subst b, l in - evars := resolve_typeclasses ~onlyargs:true ~fail:true env !evars; + evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; let d = na, Some c', t' in aux (c' :: subst, d :: instctx) l ctx | [] -> subst @@ -106,18 +107,20 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in Namegen.next_global_ident_away i (Termops.ids_of_context env) in + evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; + let ctx = Evarutil.nf_rel_context_evar !evars ctx + and ctx' = Evarutil.nf_rel_context_evar !evars ctx' in let env' = push_rel_context ctx env in - evars := Evarutil.nf_evar_map !evars; - evars := resolve_typeclasses ~onlyargs:false ~fail:true env !evars; let sigma = !evars in let subst = List.map (Evarutil.nf_evar sigma) subst in let props = match props with - | CRecord (loc, _, fs) -> + | Some (CRecord (loc, _, fs)) -> if List.length fs > List.length k.cl_props then Classes.mismatched_props env' (List.map snd fs) k.cl_props; Inl fs - | _ -> Inr props + | Some p -> Inr p + | None -> Inl [] in let subst = match props with @@ -138,7 +141,11 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p let (loc_mid, c) = List.find (fun (id', _) -> Name (snd (get_id id')) = id) rest in let rest' = List.filter (fun (id', _) -> Name (snd (get_id id')) <> id) rest in let (loc, mid) = get_id loc_mid in - Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); + List.iter + (fun (n, _, x) -> + if n = Name mid then + Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) x) + k.cl_projs; c :: props, rest' with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest @@ -151,6 +158,8 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst) in evars := Evarutil.nf_evar_map !evars; + evars := resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~fail:true env !evars; + evars := resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:false env !evars; let term, termtype = match subst with | Inl subst -> @@ -173,10 +182,9 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p Evarutil.check_evars env Evd.empty !evars termtype; let hook vis gr = let cst = match gr with ConstRef kn -> kn | _ -> assert false in - let inst = Typeclasses.new_instance k pri global (ConstRef cst) in Impargs.declare_manual_implicits false gr ~enriching:false [imps]; - Typeclasses.add_instance inst + Typeclasses.declare_instance pri (not global) (ConstRef cst) in let evm = Subtac_utils.evars_of_term !evars Evd.empty term in let obls, _, constr, typ = Eterm.eterm_obligations env id !evars evm 0 term termtype in - id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,false,Instance) ~hook obls + id, Subtac_obligations.add_definition id ~term:constr typ ~kind:(Global,Instance) ~hook obls diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli index 73ca5581..2c9fbaf5 100644 --- a/plugins/subtac/subtac_classes.mli +++ b/plugins/subtac/subtac_classes.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtac_classes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - (*i*) open Names open Decl_kinds @@ -35,7 +33,7 @@ val new_instance : ?global:bool -> local_binder list -> typeclass_constraint -> - constr_expr -> + constr_expr option -> ?generalize:bool -> int option -> identifier * Subtac_obligations.progress diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml index bdebdf85..0c03fb4c 100644 --- a/plugins/subtac/subtac_coercion.ml +++ b/plugins/subtac/subtac_coercion.ml @@ -1,13 +1,10 @@ -(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_coercion.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Util open Names open Term @@ -30,6 +27,9 @@ open Subtac_errors open Eterm open Pp +let app_opt env evars f t = + whd_betaiota !evars (app_opt f t) + let pair_of_array a = (a.(0), a.(1)) let make_name s = Name (id_of_string s) @@ -83,7 +83,8 @@ module Coercion = struct | Type _, Prop Null -> Prop Null | _, Type _ -> s2 - let hnf env isevars c = whd_betadeltaiota env ( !isevars) c + let hnf env isevars c = whd_betadeltaiota env isevars c + let hnf_nodelta env evars c = whd_betaiota evars c let lift_args n sign = let rec liftrec k = function @@ -93,15 +94,16 @@ module Coercion = struct liftrec (List.length sign) sign let rec mu env isevars t = - let isevars = ref isevars in let rec aux v = - let v = hnf env isevars v in + let v = hnf env !isevars v in match disc_subset v with Some (u, p) -> let f, ct = aux u in + let p = hnf env !isevars p in (Some (fun x -> - app_opt f (mkApp ((delayed_force sig_).proj1, - [| u; p; x |]))), + app_opt env isevars + f (mkApp ((delayed_force sig_).proj1, + [| u; p; x |]))), ct) | None -> (None, v) in aux t @@ -109,9 +111,8 @@ module Coercion = struct and coerce loc env isevars (x : Term.constr) (y : Term.constr) : (Term.constr -> Term.constr) option = - let x = nf_evar ( !isevars) x and y = nf_evar ( !isevars) y in let rec coerce_unify env x y = - let x = hnf env isevars x and y = hnf env isevars y in + let x = hnf env !isevars x and y = hnf env !isevars y in try isevars := the_conv_x_leq env x y !isevars; None @@ -144,7 +145,7 @@ module Coercion = struct let restargs = lift_args 1 (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) in - let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in + let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in let eq = mkApp (delayed_force eq_ind, [| eqT; hdx; hdy |]) in let evar = make_existential loc env isevars eq in @@ -170,7 +171,7 @@ module Coercion = struct let env' = push_rel (name', None, a') env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) - let coec1 = app_opt c1 (mkRel 1) in + let coec1 = app_opt env' isevars c1 (mkRel 1) in (* env, x : a' |- c1[x] : lift 1 a *) let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in (* env, x : a' |- c2 : b[c1[x]/x]] > b' *) @@ -180,7 +181,7 @@ module Coercion = struct Some (fun f -> mkLambda (name', a', - app_opt c2 + app_opt env' isevars c2 (mkApp (Term.lift 1 f, [| coec1 |]))))) | App (c, l), App (c', l') -> @@ -205,7 +206,7 @@ module Coercion = struct | Lambda (n, t, t') -> c, t' (*| Prod (n, t, t') -> t'*) | Evar (k, args) -> - let (evs, t) = Evarutil.define_evar_as_lambda !isevars (k,args) in + let (evs, t) = Evarutil.define_evar_as_lambda env !isevars (k,args) in isevars := evs; let (n, dom, rng) = destLambda t in let (domk, args) = destEvar dom in @@ -223,9 +224,9 @@ module Coercion = struct Some (fun x -> let x, y = - app_opt c1 (mkApp (existS.proj1, + app_opt env' isevars c1 (mkApp (existS.proj1, [| a; pb; x |])), - app_opt c2 (mkApp (existS.proj2, + app_opt env' isevars c2 (mkApp (existS.proj2, [| a; pb; x |])) in mkApp (existS.intro, [| a'; pb'; x ; y |])) @@ -243,9 +244,9 @@ module Coercion = struct Some (fun x -> let x, y = - app_opt c1 (mkApp (prod.proj1, + app_opt env isevars c1 (mkApp (prod.proj1, [| a; b; x |])), - app_opt c2 (mkApp (prod.proj2, + app_opt env isevars c2 (mkApp (prod.proj2, [| a; b; x |])) in mkApp (prod.intro, [| a'; b'; x ; y |])) @@ -279,7 +280,7 @@ module Coercion = struct Some (u, p) -> let c = coerce_unify env u y in let f x = - app_opt c (mkApp ((delayed_force sig_).proj1, + app_opt env isevars c (mkApp ((delayed_force sig_).proj1, [| u; p; x |])) in Some f | None -> @@ -288,7 +289,7 @@ module Coercion = struct let c = coerce_unify env x u in Some (fun x -> - let cx = app_opt c x in + let cx = app_opt env isevars c x in let evar = make_existential loc env isevars (mkApp (p, [| cx |])) in (mkApp @@ -303,7 +304,8 @@ module Coercion = struct let coerce_itf loc env isevars v t c1 = let evars = ref isevars in let coercion = coerce loc env evars t c1 in - !evars, Option.map (app_opt coercion) v + let t = Option.map (app_opt env evars coercion) v in + !evars, t (* Taken from pretyping/coercion.ml *) @@ -330,8 +332,8 @@ module Coercion = struct let apply_pattern_coercion loc pat p = List.fold_left (fun pat (co,n) -> - let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in - Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous)) + let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in + Glob_term.PatCstr (loc, co, list_tabulate f (n+1), Anonymous)) pat p (* raise Not_found if no coercion found *) @@ -354,37 +356,39 @@ module Coercion = struct jres), jres.uj_type) (hj,typ_cl) p) - with _ -> anomaly "apply_coercion" + with e when Errors.noncritical e -> anomaly "apply_coercion" let inh_app_fun env isevars j = - let t = whd_betadeltaiota env ( isevars) j.uj_type in + let isevars = ref isevars in + let t = hnf env !isevars j.uj_type in match kind_of_term t with - | Prod (_,_,_) -> (isevars,j) - | Evar ev when not (is_defined_evar isevars ev) -> - let (isevars',t) = define_evar_as_product isevars ev in + | Prod (_,_,_) -> (!isevars,j) + | Evar ev when not (is_defined_evar !isevars ev) -> + let (isevars',t) = define_evar_as_product !isevars ev in (isevars',{ uj_val = j.uj_val; uj_type = t }) | _ -> (try let t,p = - lookup_path_to_fun_from env ( isevars) j.uj_type in - (isevars,apply_coercion env ( isevars) p j t) + lookup_path_to_fun_from env !isevars j.uj_type in + (!isevars,apply_coercion env !isevars p j t) with Not_found -> try let coercef, t = mu env isevars t in - (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t }) + let res = { uj_val = app_opt env isevars coercef j.uj_val; uj_type = t } in + (!isevars, res) with NoSubtacCoercion | NoCoercion -> - (isevars,j)) + (!isevars,j)) let inh_tosort_force loc env isevars j = try let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in let j1 = apply_coercion env ( isevars) p j t in - (isevars,type_judgment env (j_nf_evar ( isevars) j1)) + (isevars, type_judgment env (j_nf_evar ( isevars) j1)) with Not_found -> error_not_a_type_loc loc env ( isevars) j let inh_coerce_to_sort loc env isevars j = - let typ = whd_betadeltaiota env ( isevars) j.uj_type in + let typ = hnf env isevars j.uj_type in match kind_of_term typ with | Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s }) | Evar ev when not (is_defined_evar isevars ev) -> @@ -394,15 +398,19 @@ module Coercion = struct inh_tosort_force loc env isevars j let inh_coerce_to_base loc env isevars j = - let typ = whd_betadeltaiota env ( isevars) j.uj_type in + let isevars = ref isevars in + let typ = hnf env !isevars j.uj_type in let ct, typ' = mu env isevars typ in - isevars, { uj_val = app_opt ct j.uj_val; - uj_type = typ' } + let res = + { uj_val = app_opt env isevars ct j.uj_val; + uj_type = typ' } + in !isevars, res let inh_coerce_to_prod loc env isevars t = - let typ = whd_betadeltaiota env ( isevars) (snd t) in + let isevars = ref isevars in + let typ = hnf env !isevars (snd t) in let _, typ' = mu env isevars typ in - isevars, (fst t, typ') + !isevars, (fst t, typ') let inh_coerce_to_fail env evd rigidonly v t c1 = if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t) @@ -411,10 +419,10 @@ module Coercion = struct else let v', t' = try - let t2,t1,p = lookup_path_between env ( evd) (t,c1) in + let t2,t1,p = lookup_path_between env evd (t,c1) in match v with Some v -> - let j = apply_coercion env ( evd) p + let j = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in Some j.uj_val, j.uj_type | None -> None, t @@ -430,8 +438,8 @@ module Coercion = struct try inh_coerce_to_fail env evd rigidonly v t c1 with NoCoercion -> match - kind_of_term (whd_betadeltaiota env ( evd) t), - kind_of_term (whd_betadeltaiota env ( evd) c1) + kind_of_term (whd_betadeltaiota env evd t), + kind_of_term (whd_betadeltaiota env evd c1) with | Prod (name,t1,t2), Prod (_,u1,u2) -> (* Conversion did not work, we may succeed with a coercion. *) @@ -455,23 +463,23 @@ module Coercion = struct (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *) let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) = match n with - None -> - let (evd', val') = - try - inh_conv_coerce_to_fail loc env evd rigidonly - (Some (nf_evar evd cj.uj_val)) - (nf_evar evd cj.uj_type) (nf_evar evd t) - with NoCoercion -> - let sigma = evd in - try - coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t - with NoSubtacCoercion -> - error_actual_type_loc loc env sigma cj t - in - let val' = match val' with Some v -> v | None -> assert(false) in - (evd',{ uj_val = val'; uj_type = t }) - | Some (init, cur) -> - (evd, cj) + | None -> + let cj = { cj with uj_type = hnf_nodelta env evd cj.uj_type } + and t = hnf_nodelta env evd t in + let (evd', val') = + try + inh_conv_coerce_to_fail loc env evd rigidonly + (Some cj.uj_val) cj.uj_type t + with NoCoercion -> + (try + coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t + with NoSubtacCoercion -> + error_actual_type_loc loc env evd cj t) + in + let val' = match val' with Some v -> v | None -> assert(false) in + (evd',{ uj_val = val'; uj_type = t }) + | Some (init, cur) -> + (evd, cj) let inh_conv_coerce_to = inh_conv_coerce_to_gen false let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true @@ -498,5 +506,5 @@ module Coercion = struct with NoSubtacCoercion -> error_cannot_coerce env' isevars (t, t')) else isevars - with _ -> isevars + with e when Errors.noncritical e -> isevars end diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml index a83611a4..537a8301 100644 --- a/plugins/subtac/subtac_command.ml +++ b/plugins/subtac/subtac_command.ml @@ -6,7 +6,7 @@ open Libobject open Pattern open Matching open Pp -open Rawterm +open Glob_term open Sign open Tacred open Util @@ -21,7 +21,6 @@ open Tacmach open Tactic_debug open Topconstr open Term -open Termops open Tacexpr open Safe_typing open Typing @@ -53,7 +52,7 @@ let evar_nf isevars c = Evarutil.nf_evar !isevars c let interp_gen kind isevars env - ?(impls=[]) ?(allow_patvar=false) ?(ltacvars=([],[])) + ?(impls=Constrintern.empty_internalization_env) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in let c' = SPretyping.understand_tcc_evars isevars env kind c' in @@ -62,13 +61,13 @@ let interp_gen kind isevars env let interp_constr isevars env c = interp_gen (OfType None) isevars env c -let interp_type_evars isevars env ?(impls=[]) c = +let interp_type_evars isevars env ?(impls=Constrintern.empty_internalization_env) c = interp_gen IsType isevars env ~impls c -let interp_casted_constr isevars env ?(impls=[]) c typ = +let interp_casted_constr isevars env ?(impls=Constrintern.empty_internalization_env) c typ = interp_gen (OfType (Some typ)) isevars env ~impls c -let interp_casted_constr_evars isevars env ?(impls=[]) c typ = +let interp_casted_constr_evars isevars env ?(impls=Constrintern.empty_internalization_env) c typ = interp_gen (OfType (Some typ)) isevars env ~impls c let interp_open_constr isevars env c = @@ -85,25 +84,25 @@ let interp_constr_judgment isevars env c = { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type } let locate_if_isevar loc na = function - | RHole _ -> + | GHole _ -> (try match na with - | Name id -> Reserve.find_reserved_type id + | Name id -> glob_constr_of_aconstr loc (Reserve.find_reserved_type id) | Anonymous -> raise Not_found - with Not_found -> RHole (loc, Evd.BinderType na)) + with Not_found -> GHole (loc, Evd.BinderType na)) | x -> x let interp_binder sigma env na t = let t = Constrintern.intern_gen true ( !sigma) env t in - SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_rawconstr t) na t) + SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_glob_constr t) na t) let interp_context_evars evdref env params = - let bl = Constrintern.intern_context false ( !evdref) env params in + let int_env, bl = Constrintern.intern_context false !evdref env Constrintern.empty_internalization_env params in let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> match b with None -> - let t' = locate_if_isevar (loc_of_rawconstr t) na t in + let t' = locate_if_isevar (loc_of_glob_constr t) na t in let t = SPretyping.understand_tcc_evars evdref env IsType t' in let d = (na,None,t) in let impls = @@ -133,7 +132,7 @@ let collect_non_rec env = let i = list_try_find_i (fun i f -> - if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec + if List.for_all (fun (_, def) -> not (Termops.occur_var env f def)) ldefrec then i else failwith "try_find_i") 0 lnamerec in @@ -184,11 +183,11 @@ let sigT = Lazy.lazy_from_fun build_sigma_type let sigT_info = lazy { ci_ind = destInd (Lazy.force sigT).typ; ci_npar = 2; - ci_cstr_nargs = [|2|]; + ci_cstr_ndecls = [|2|]; ci_pp_info = { ind_nargs = 0; style = LetStyle } } -let telescope = function +let rec telescope = function | [] -> assert false | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1 | (n, None, t) :: tl -> @@ -209,13 +208,14 @@ let telescope = function (List.rev tys) tl (mkRel 1, []) in ty, ((n, Some last, t) :: subst), constr - | _ -> raise (Invalid_argument "telescope") + | (n, Some b, t) :: tl -> let ty, subst, term = telescope tl in + ty, ((n, Some b, t) :: subst), lift 1 term let nf_evar_context isevars ctx = List.map (fun (n, b, t) -> (n, Option.map (Evarutil.nf_evar isevars) b, Evarutil.nf_evar isevars t)) ctx -let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = +let build_wellfounded (recname,n,bl,arityc,body) r measure notation = Coqlib.check_required_library ["Coq";"Program";"Wf"]; let sigma = Evd.empty in let isevars = ref (Evd.create_evar_defs sigma) in @@ -248,7 +248,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = | [(_, None, t); (_, None, u)], Sort (Prop Null) when Reductionops.is_conv env !isevars t u -> t | _, _ -> error () - with _ -> error () + with e when Errors.noncritical e -> error () in let measure = interp_casted_constr isevars binders_env measure relargty in let wf_rel, wf_rel_fun, measure_fn = @@ -300,11 +300,11 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = Constrintern.compute_internalization_data env Constrintern.Recursive full_arity impls in - let newimpls = [(recname, (r, l, impls @ - [Some (id_of_string "recproof", Impargs.Manual, (true, false))], - scopes @ [None]))] in - interp_casted_constr isevars ~impls:newimpls - (push_rel_context ctx env) body (lift 1 top_arity) + let newimpls = Idmap.singleton recname + (r, l, impls @ [(Some (id_of_string "recproof", Impargs.Manual, (true, false)))], + scopes @ [None]) in + interp_casted_constr isevars ~impls:newimpls + (push_rel_context ctx env) body (lift 1 top_arity) in let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in let prop = mkLambda (Name argname, argtyp, top_arity_let) in @@ -325,10 +325,10 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let body = it_mkLambda_or_LetIn (mkApp (constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let ce = - { const_entry_body = Evarutil.nf_evar !isevars body; + { const_entry_body = Evarutil.nf_evar !isevars body; + const_entry_secctx = None; const_entry_type = Some ty; - const_entry_opaque = false; - const_entry_boxed = false} + const_entry_opaque = false } in let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in let gr = ConstRef c in @@ -380,9 +380,16 @@ let rec unfold f b = | Some (x, b') -> x :: unfold f b' | None -> [] + +let find_annot loc id ctx = + try rel_index id ctx + with Not_found -> + user_err_loc(loc,"", + str "No parameter named " ++ Nameops.pr_id id ++ str".") + let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = match n with - | Some (loc, n) -> [rel_index n fixctx] + | Some (loc, id) -> [find_annot loc id fixctx] | None -> (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, @@ -417,7 +424,7 @@ let out_def = function | Some def -> def | None -> error "Program Fixpoint needs defined bodies." -let interp_recursive fixkind l boxed = +let interp_recursive fixkind l = let env = Global.env() in let fixl, ntnl = List.split l in let kind = fixkind <> IsCoFixpoint in @@ -433,7 +440,7 @@ let interp_recursive fixkind l boxed = let sort = Retyping.get_type_of env !evdref t in let fixprot = try mkApp (delayed_force Subtac_utils.fix_proto, [|sort; t|]) - with e -> t + with e when Errors.noncritical e -> t in (id,None,fixprot) :: env') [] fixnames fixtypes @@ -458,7 +465,7 @@ let interp_recursive fixkind l boxed = (* Instantiate evars and check all are resolved *) let evd = Evarconv.consider_remaining_unif_problems env_rec !evdref in let evd = Typeclasses.resolve_typeclasses - ~onlyargs:true ~split:true ~fail:false env_rec evd + ~filter:Typeclasses.no_goals ~split:true ~fail:false env_rec evd in let evd = Evarutil.nf_evar_map evd in let fixdefs = List.map (nf_evar evd) fixdefs in @@ -506,7 +513,7 @@ let out_n = function Some n -> n | None -> raise Not_found -let build_recursive l b = +let build_recursive l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> @@ -514,24 +521,24 @@ let build_recursive l b = (match n with Some n -> mkIdentC (snd n) | None -> errorlabstrm "Subtac_command.build_recursive" (str "Recursive argument required for well-founded fixpoints")) - ntn false) + ntn) | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] -> ignore(build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef lt_ref) r) - m ntn false) + m ntn) | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g -> let fixl = List.map (fun (((_,id),(n,ro),bl,typ,def),ntn) -> ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = n; Command.fix_body = def; Command.fix_type = typ},ntn)) l - in interp_recursive (IsFixpoint g) fixl b + in interp_recursive (IsFixpoint g) fixl | _, _ -> errorlabstrm "Subtac_command.build_recursive" (str "Well-founded fixpoints not allowed in mutually recursive blocks") -let build_corecursive l b = +let build_corecursive l = let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_annot = None; Command.fix_body = def; Command.fix_type = typ},ntn)) l in - interp_recursive IsCoFixpoint fixl b + interp_recursive IsCoFixpoint fixl diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli index 0f24915e..72549a01 100644 --- a/plugins/subtac/subtac_command.mli +++ b/plugins/subtac/subtac_command.mli @@ -43,7 +43,7 @@ val interp_binder : Evd.evar_map ref -> val telescope : - (Names.name * 'a option * Term.types) list -> + (Names.name * Term.types option * Term.types) list -> Term.types * (Names.name * Term.types option * Term.types) list * Term.constr @@ -51,10 +51,10 @@ val build_wellfounded : Names.identifier * 'a * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr -> Topconstr.constr_expr -> - Topconstr.constr_expr -> 'b -> 'c -> Subtac_obligations.progress + Topconstr.constr_expr -> 'b -> Subtac_obligations.progress val build_recursive : - (fixpoint_expr * decl_notation list) list -> bool -> unit + (fixpoint_expr * decl_notation list) list -> unit val build_corecursive : - (cofixpoint_expr * decl_notation list) list -> bool -> unit + (cofixpoint_expr * decl_notation list) list -> unit diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index 80e712e5..d8f46098 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -1,4 +1,3 @@ -(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) open Printf open Pp open Subtac_utils @@ -16,6 +15,7 @@ open Util open Evd open Declare open Proof_type +open Compat let ppwarn cmd = Pp.warn (str"Program:" ++ cmd) let pperror cmd = Util.errorlabstrm "Program" cmd @@ -30,13 +30,13 @@ let explain_no_obligations = function Some ident -> str "No obligations for program " ++ str (string_of_id ident) | None -> str "No obligations remaining" -type obligation_info = (Names.identifier * Term.types * hole_kind located * +type obligation_info = (Names.identifier * Term.types * hole_kind located * obligation_definition_status * Intset.t * tactic option) array type obligation = { obl_name : identifier; obl_type : types; - obl_source : hole_kind located; + obl_location : hole_kind located; obl_body : constr option; obl_status : obligation_definition_status; obl_deps : Intset.t; @@ -82,11 +82,29 @@ open Goptions let _ = declare_bool_option { optsync = true; + optdepr = false; optname = "transparency of Program obligations"; optkey = ["Transparent";"Obligations"]; optread = get_proofs_transparency; optwrite = set_proofs_transparency; } +(* true = hide obligations *) +let hide_obligations = ref false + +let set_hide_obligations = (:=) hide_obligations +let get_hide_obligations () = !hide_obligations + +open Goptions + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "Hidding of Program obligations"; + optkey = ["Hide";"Obligations"]; + optread = get_hide_obligations; + optwrite = set_hide_obligations; } + let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type let get_obligation_body expand obl = @@ -97,18 +115,54 @@ let get_obligation_body expand obl = | _ -> c else c +let obl_substitution expand obls deps = + Intset.fold + (fun x acc -> + let xobl = obls.(x) in + let oblb = + try get_obligation_body expand xobl + with e when Errors.noncritical e -> assert(false) + in (xobl.obl_name, (xobl.obl_type, oblb)) :: acc) + deps [] + let subst_deps expand obls deps t = - let subst = - Intset.fold - (fun x acc -> - let xobl = obls.(x) in - let oblb = - try get_obligation_body expand xobl - with _ -> assert(false) - in (xobl.obl_name, oblb) :: acc) - deps [] - in(* Termops.it_mkNamedProd_or_LetIn t subst *) - Term.replace_vars subst t + let subst = obl_substitution expand obls deps in + Term.replace_vars (List.map (fun (n, (_, b)) -> n, b) subst) t + +let rec prod_app t n = + match kind_of_term (strip_outer_cast t) with + | Prod (_,_,b) -> subst1 n b + | LetIn (_, b, t, b') -> prod_app (subst1 b b') n + | _ -> + errorlabstrm "prod_app" + (str"Needed a product, but didn't find one" ++ fnl ()) + + +(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) +let prod_applist t nL = List.fold_left prod_app t nL + +let replace_appvars subst = + let rec aux c = + let f, l = decompose_app c in + if isVar f then + try + let c' = List.map (map_constr aux) l in + let (t, b) = List.assoc (destVar f) subst in + mkApp (delayed_force hide_obligation, + [| prod_applist t c'; applistc b c' |]) + with Not_found -> map_constr aux c + else map_constr aux c + in map_constr aux + +let subst_prog expand obls ints prg = + let subst = obl_substitution expand obls ints in + if get_hide_obligations () then + (replace_appvars subst prg.prg_body, + replace_appvars subst (Termops.refresh_universes prg.prg_type)) + else + let subst' = List.map (fun (n, (_, b)) -> n, b) subst in + (Term.replace_vars subst' prg.prg_body, + Term.replace_vars subst' (Termops.refresh_universes prg.prg_type)) let subst_deps_obl obls obl = let t' = subst_deps true obls obl.obl_deps obl.obl_type in @@ -153,20 +207,32 @@ let _ = let progmap_union = ProgMap.fold ProgMap.add -let (input,output) = +let close sec = + if not (ProgMap.is_empty !from_prg) then + let keys = map_keys !from_prg in + errorlabstrm "Program" (str "Unsolved obligations when closing " ++ str sec ++ str":" ++ spc () ++ + prlist_with_sep spc (fun x -> Nameops.pr_id x) keys ++ + (str (if List.length keys = 1 then " has " else "have ") ++ + str "unsolved obligations")) + +let input : program_info ProgMap.t -> obj = declare_object { (default_object "Program state") with - classify_function = (fun () -> - if not (ProgMap.is_empty !from_prg) then - errorlabstrm "Program" (str "Unsolved obligations when closing module:" ++ spc () ++ - prlist_with_sep spc (fun x -> Nameops.pr_id x) - (map_keys !from_prg)); - Dispose) } + cache_function = (fun (na, pi) -> from_prg := pi); + load_function = (fun _ (_, pi) -> from_prg := pi); + discharge_function = (fun _ -> close "section"; None); + classify_function = (fun _ -> close "module"; Dispose) } open Evd let progmap_remove prg = - from_prg := ProgMap.remove prg.prg_name !from_prg + Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg)) + +let progmap_add n prg = + Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg)) + +let progmap_replace prg' = + Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg)) let rec intset_to = function -1 -> Intset.empty @@ -175,21 +241,16 @@ let rec intset_to = function let subst_body expand prg = let obls, _ = prg.prg_obligations in let ints = intset_to (pred (Array.length obls)) in - subst_deps expand obls ints prg.prg_body, - subst_deps expand obls ints (Termops.refresh_universes prg.prg_type) + subst_prog expand obls ints prg let declare_definition prg = let body, typ = subst_body true prg in - (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ - my_print_constr (Global.env()) body ++ str " : " ++ - my_print_constr (Global.env()) prg.prg_type); - with _ -> ()); - let (local, boxed, kind) = prg.prg_kind in + let (local, kind) = prg.prg_kind in let ce = { const_entry_body = body; + const_entry_secctx = None; const_entry_type = Some typ; - const_entry_opaque = false; - const_entry_boxed = boxed} + const_entry_opaque = false } in (Command.get_declare_definition_hook ()) ce; match local with @@ -207,7 +268,7 @@ let declare_definition prg = | (Global|Local) -> let c = Declare.declare_constant - prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind)) + prg.prg_name (DefinitionEntry ce,IsDefinition (snd prg.prg_kind)) in let gr = ConstRef c in if Impargs.is_implicit_args () || prg.prg_implicits <> [] then @@ -255,7 +316,7 @@ let declare_mutual_definition l = let fixkind = Option.get first.prg_fixkind in let arrrec, recvec = Array.of_list fixtypes, Array.of_list fixdefs in let fixdecls = (Array.of_list (List.map (fun x -> Name x.prg_name) l), arrrec, recvec) in - let (local,boxed,kind) = first.prg_kind in + let (local,kind) = first.prg_kind in let fixnames = first.prg_deps in let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in let indexes, fixdecls = @@ -269,7 +330,7 @@ let declare_mutual_definition l = None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l in (* Declare the recursive definitions *) - let kns = list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps in + let kns = list_map4 (declare_fix kind) fixnames fixdecls fixtypes fiximps in (* Declare notations *) List.iter Metasyntax.add_notation_interpretation first.prg_notations; Declare.recursive_message (fixkind<>IsCoFixpoint) indexes fixnames; @@ -287,9 +348,9 @@ let declare_obligation prg obl body = let opaque = if get_proofs_transparency () then false else opaque in let ce = { const_entry_body = body; + const_entry_secctx = None; const_entry_type = Some ty; - const_entry_opaque = opaque; - const_entry_boxed = false} + const_entry_opaque = opaque } in let constant = Declare.declare_constant obl.obl_name (DefinitionEntry ce,IsProof Property) @@ -307,14 +368,14 @@ let init_prog_info n b t deps fixkind notations obls impls kind reduce hook = assert(obls = [||]); let n = Nameops.add_suffix n "_obligation" in [| { obl_name = n; obl_body = None; - obl_source = (dummy_loc, QuestionMark Expand); obl_type = t; + obl_location = dummy_loc, InternalHole; obl_type = t; obl_status = Expand; obl_deps = Intset.empty; obl_tac = None } |], mkVar n | Some b -> Array.mapi (fun i (n, t, l, o, d, tac) -> { obl_name = n ; obl_body = None; - obl_source = l; obl_type = reduce t; obl_status = o; + obl_location = l; obl_type = reduce t; obl_status = o; obl_deps = d; obl_tac = tac }) obls, b in @@ -359,7 +420,7 @@ let obligations_message rem = let update_obls prg obls rem = let prg' = { prg with prg_obligations = (obls, rem) } in - from_prg := map_replace prg.prg_name prg' !from_prg; + progmap_replace prg'; obligations_message rem; if rem > 0 then Remain rem else ( @@ -384,12 +445,12 @@ let deps_remaining obls deps = else x :: acc) deps [] -let has_dependencies obls n = - let res = ref false in +let dependencies obls n = + let res = ref Intset.empty in Array.iteri (fun i obl -> if i <> n && Intset.mem n obl.obl_deps then - res := true) + res := Intset.add i !res) obls; !res @@ -437,12 +498,14 @@ let rec solve_obligation prg num tac = let obls = Array.copy obls in let _ = obls.(num) <- obl in let res = try update_obls prg obls (pred rem) - with e -> pperror (Cerrors.explain_exn e) + with e when Errors.noncritical e -> + pperror (Errors.print (Cerrors.process_vernac_interp_error e)) in match res with | Remain n when n > 0 -> - if has_dependencies obls num then - ignore(auto_solve_obligations (Some prg.prg_name) None) + let deps = dependencies obls num in + if deps <> Intset.empty then + ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps) | _ -> ()); trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ Subtac_utils.my_print_constr (Global.env ()) obl.obl_type); @@ -485,20 +548,25 @@ and solve_obligation_by_tac prg obls i tac = true else false with - | Compat.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) - | Compat.Exc_located(_, Refiner.FailError (_, s)) + | Loc.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) + | Loc.Exc_located(_, Refiner.FailError (_, s)) | Refiner.FailError (_, s) -> - user_err_loc (fst obl.obl_source, "solve_obligation", Lazy.force s) - | e -> false + user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s) + | Util.Anomaly _ as e -> raise e + | e when Errors.noncritical e -> false -and solve_prg_obligations prg tac = +and solve_prg_obligations prg ?oblset tac = let obls, rem = prg.prg_obligations in let rem = ref rem in let obls' = Array.copy obls in + let p = match oblset with + | None -> (fun _ -> true) + | Some s -> (fun i -> Intset.mem i s) + in let _ = Array.iteri (fun i x -> - if solve_obligation_by_tac prg obls' i tac then - decr rem) + if p i && solve_obligation_by_tac prg obls' i tac then + decr rem) obls' in update_obls prg obls' !rem @@ -520,9 +588,9 @@ and try_solve_obligation n prg tac = and try_solve_obligations n tac = try ignore (solve_obligations n tac) with NoObligations _ -> () -and auto_solve_obligations n tac : progress = +and auto_solve_obligations n ?oblset tac : progress = Flags.if_verbose msgnl (str "Solving obligations automatically..."); - try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent + try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent open Pp let show_obligations_of_prg ?(msg=true) prg = @@ -556,7 +624,7 @@ let show_term n = my_print_constr (Global.env ()) prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ my_print_constr (Global.env ()) prg.prg_body) -let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic +let add_definition n ?term t ?(implicits=[]) ?(kind=Global,Definition) ?tactic ?(reduce=reduce) ?(hook=fun _ _ -> ()) obls = Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked"); let prg = init_prog_info n term t [] None [] obls implicits kind reduce hook in @@ -568,23 +636,20 @@ let add_definition n ?term t ?(implicits=[]) ?(kind=Global,false,Definition) ?ta else ( let len = Array.length obls in let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in - from_prg := ProgMap.add n prg !from_prg; + progmap_add n prg; let res = auto_solve_obligations (Some n) tactic in match res with | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) -let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) +let add_mutual_definitions l ?tactic ?(kind=Global,Definition) ?(reduce=reduce) ?(hook=fun _ _ -> ()) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in - let upd = List.fold_left - (fun acc (n, b, t, imps, obls) -> - let prg = init_prog_info n (Some b) t deps (Some fixkind) - notations obls imps kind reduce hook - in ProgMap.add n prg acc) - !from_prg l - in - from_prg := upd; + List.iter + (fun (n, b, t, imps, obls) -> + let prg = init_prog_info n (Some b) t deps (Some fixkind) + notations obls imps kind reduce hook + in progmap_add n prg) l; let _defined = List.fold_left (fun finished x -> if finished then finished @@ -599,13 +664,14 @@ let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(reduce=re let admit_obligations n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in + let obls = Array.copy obls in Array.iteri (fun i x -> match x.obl_body with | None -> let x = subst_deps_obl obls x in - let kn = Declare.declare_constant x.obl_name (ParameterEntry (x.obl_type,false), - IsAssumption Conjectural) + let kn = Declare.declare_constant x.obl_name + (ParameterEntry (None, x.obl_type,None), IsAssumption Conjectural) in assumption_message x.obl_name; obls.(i) <- { x with obl_body = Some (mkConst kn) } diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli index 5f6d1a2e..c1d665aa 100644 --- a/plugins/subtac/subtac_obligations.mli +++ b/plugins/subtac/subtac_obligations.mli @@ -8,7 +8,7 @@ open Vernacexpr type obligation_info = (identifier * Term.types * hole_kind located * obligation_definition_status * Intset.t * tactic option) array - (* ident, type, source, (opaque or transparent, expand or define), + (* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) type progress = (* Resolution status of a program *) diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml index 9de7ddf2..fac6b567 100644 --- a/plugins/subtac/subtac_pretyping.ml +++ b/plugins/subtac/subtac_pretyping.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Global open Pp open Util @@ -26,7 +24,7 @@ open List open Recordops open Evarutil open Pretype_errors -open Rawterm +open Glob_term open Evarconv open Pattern @@ -60,20 +58,17 @@ let my_print_rec_info env t = str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++ str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++ str "Full type: " ++ my_print_constr env t.f_fulltype -(* trace (str "pretype for " ++ (my_print_rawconstr env c) ++ *) +(* trace (str "pretype for " ++ (my_print_glob_constr env c) ++ *) (* str " and tycon "++ my_print_tycon env tycon ++ *) (* str " in environment: " ++ my_print_env env); *) -let merge_evms x y = - Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y - let interp env isevars c tycon = let j = pretype tycon env isevars ([],[]) c in let _ = isevars := Evarutil.nf_evar_map !isevars in let evd = consider_remaining_unif_problems env !isevars in (* let unevd = undefined_evars evd in *) - let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in - let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in + let unevd' = Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations ~split:true ~fail:true env evd in + let unevd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars ~split:true ~fail:false env unevd' in let evm = unevd' in isevars := unevd'; nf_evar evm j.uj_val, nf_evar evm j.uj_type @@ -86,9 +81,9 @@ let find_with_index x l = open Vernacexpr -let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = +let coqintern_constr evd env : Topconstr.constr_expr -> Glob_term.glob_constr = Constrintern.intern_constr evd env -let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = +let coqintern_type evd env : Topconstr.constr_expr -> Glob_term.glob_constr = Constrintern.intern_type evd env let env_with_binders env isevars l = @@ -119,14 +114,14 @@ let subtac_process ?(is_type=false) env isevars id bl c tycon = | Some t -> let t = Topconstr.prod_constr_expr t bl in let t = coqintern_type !isevars env t in - let imps = Implicit_quantifiers.implicits_of_rawterm t in + let imps = Implicit_quantifiers.implicits_of_glob_constr t in let coqt, ttyp = interp env isevars t empty_tycon in mk_tycon coqt, Some imps in let c = coqintern_constr !isevars env c in let imps = match imps with | Some i -> i - | None -> Implicit_quantifiers.implicits_of_rawterm ~with_products:is_type c + | None -> Implicit_quantifiers.implicits_of_glob_constr ~with_products:is_type c in let coqc, ctyp = interp env isevars c tycon in let evm = non_instanciated_map env isevars !isevars in diff --git a/plugins/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli index 48906b23..fa767790 100644 --- a/plugins/subtac/subtac_pretyping.mli +++ b/plugins/subtac/subtac_pretyping.mli @@ -13,7 +13,7 @@ module Pretyping : Pretyping.S val interp : Environ.env -> Evd.evar_map ref -> - Rawterm.rawconstr -> + Glob_term.glob_constr -> Evarutil.type_constraint -> Term.constr * Term.constr val subtac_process : ?is_type:bool -> env -> evar_map ref -> identifier -> local_binder list -> diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml index 4f4ae92e..f0579711 100644 --- a/plugins/subtac/subtac_pretyping_F.ml +++ b/plugins/subtac/subtac_pretyping_F.ml @@ -1,21 +1,18 @@ -(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: subtac_pretyping_F.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pp +open Compat open Util open Names open Sign open Evd open Term -open Termops open Reductionops open Environ open Type_errors @@ -27,7 +24,7 @@ open List open Recordops open Evarutil open Pretype_errors -open Rawterm +open Glob_term open Evarconv open Pattern open Pretyping @@ -78,20 +75,20 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct for i = 0 to lt-1 do if not (e_cumul env evdref (vdefj.(i)).uj_type (lift lt lar.(i))) then - error_ill_typed_rec_body_loc loc env ( !evdref) + error_ill_typed_rec_body_loc loc env !evdref i lna vdefj lar done - let check_branches_message loc env evdref c (explft,lft) = + let check_branches_message loc env evdref ind c (explft,lft) = for i = 0 to Array.length explft - 1 do if not (e_cumul env evdref lft.(i) explft.(i)) then let sigma = !evdref in - error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i) + error_ill_formed_branch_loc loc env sigma c (ind,i) lft.(i) explft.(i) done (* coerce to tycon if any *) let inh_conv_coerce_to_tycon loc env evdref j = function - | None -> j_nf_evar !evdref j + | None -> j | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) evdref j t let push_rels vars env = List.fold_right push_rel vars env @@ -99,7 +96,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (* let evar_type_case evdref env ct pt lft p c = let (mind,bty,rslty) = type_case_branches env ( evdref) ct pt p c - in check_branches_message evdref env (c,ct) (bty,lft); (mind,rslty) + in check_branches_message evdref env mind (c,ct) (bty,lft); (mind,rslty) *) let strip_meta id = (* For Grammar v7 compatibility *) @@ -108,7 +105,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct else id let invert_ltac_bound_name env id0 id = - try mkRel (pi1 (lookup_rel_id id (rel_context env))) + try mkRel (pi1 (Termops.lookup_rel_id id (rel_context env))) with Not_found -> errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++ str " depends on pattern variable name " ++ pr_id id ++ @@ -117,7 +114,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let pretype_id loc env sigma (lvar,unbndltacvars) id = let id = strip_meta id in (* May happen in tactics defined by Grammar *) try - let (n,_,typ) = lookup_rel_id id (rel_context env) in + let (n,_,typ) = Termops.lookup_rel_id id (rel_context env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> try @@ -153,7 +150,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let s' = mkProd (Anonymous, ind, s) in let ccl = lift 1 (decomp n pj.uj_val) in let ccl' = mkLambda (Anonymous, ind, ccl) in - {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign} + {uj_val=Termops.it_mkLambda ccl' sign; uj_type=Termops.it_mkProd s' sign} (*************************************************************************) (* Main pretyping function *) @@ -162,9 +159,9 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let c = constr_of_global ref in make_judge c (Retyping.get_type_of env Evd.empty c) - let pretype_sort = function - | RProp c -> judge_of_prop_contents c - | RType _ -> judge_of_new_Type () + let pretype_sort evdref = function + | GProp c -> judge_of_prop_contents c + | GType _ -> evd_comb0 judge_of_new_Type evdref let split_tycon_lam loc env evd tycon = let rec real_split evd c = @@ -192,44 +189,44 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (* in environment [env], with existential variables [( evdref)] and *) (* the type constraint tycon *) let rec pretype (tycon : type_constraint) env evdref lvar c = -(* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *) +(* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_glob_constr env c ++ *) (* str " with tycon " ++ Evarutil.pr_tycon env tycon) *) (* with _ -> () *) (* in *) match c with - | RRef (loc,ref) -> + | GRef (loc,ref) -> inh_conv_coerce_to_tycon loc env evdref (pretype_ref evdref env ref) tycon - | RVar (loc, id) -> + | GVar (loc, id) -> inh_conv_coerce_to_tycon loc env evdref (pretype_id loc env !evdref lvar id) tycon - | REvar (loc, ev, instopt) -> + | GEvar (loc, ev, instopt) -> (* Ne faudrait-il pas s'assurer que hyps est bien un sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *) - let hyps = evar_context (Evd.find ( !evdref) ev) in + let hyps = evar_context (Evd.find !evdref ev) in let args = match instopt with | None -> instance_from_named_context hyps | Some inst -> failwith "Evar subtitutions not implemented" in let c = mkEvar (ev, args) in - let j = (Retyping.get_judgment_of env ( !evdref) c) in + let j = (Retyping.get_judgment_of env !evdref c) in inh_conv_coerce_to_tycon loc env evdref j tycon - | RPatVar (loc,(someta,n)) -> - anomaly "Found a pattern variable in a rawterm to type" + | GPatVar (loc,(someta,n)) -> + anomaly "Found a pattern variable in a glob_constr to type" - | RHole (loc,k) -> + | GHole (loc,k) -> let ty = match tycon with | Some (None, ty) -> ty | None | Some _ -> - e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in + e_new_evar evdref env ~src:(loc, InternalHole) (Termops.new_Type ()) in { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } - | RRec (loc,fixkind,names,bl,lar,vdef) -> + | GRec (loc,fixkind,names,bl,lar,vdef) -> let rec type_bl env ctxt = function [] -> ctxt | (na,k,None,ty)::bl -> @@ -260,7 +257,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct in push_rec_types (names,marked_ftys,[||]) env in - let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in + let fixi = match fixkind with GFix (vn, i) -> i | GCoFix i -> i in let vdefj = array_map2_i (fun i ctxt def -> @@ -284,10 +281,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in evar_type_fixpoint loc env evdref names ftys vdefj; - let ftys = Array.map (nf_evar ( !evdref)) ftys in - let fdefs = Array.map (fun x -> nf_evar ( !evdref) (j_val x)) vdefj in + let ftys = Array.map (nf_evar !evdref) ftys in + let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in let fixj = match fixkind with - | RFix (vn,i) -> + | GFix (vn,i) -> (* First, let's find the guard indexes. *) (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, @@ -303,16 +300,18 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let fixdecls = (names,ftys,fdefs) in let indexes = search_guard loc env possible_indexes fixdecls in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | RCoFix i -> + | GCoFix i -> let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e); + (try check_cofix env cofix + with e when Errors.noncritical e -> Loc.raise loc e); make_judge (mkCoFix cofix) ftys.(i) in inh_conv_coerce_to_tycon loc env evdref fixj tycon - | RSort (loc,s) -> - inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon + | GSort (loc,s) -> + let s' = pretype_sort evdref s in + inh_conv_coerce_to_tycon loc env evdref s' tycon - | RApp (loc,f,args) -> + | GApp (loc,f,args) -> let length = List.length args in let ftycon = let ty = @@ -325,40 +324,41 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct else tycon in match ty with - | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty + | Some (_, t) -> + if Subtac_coercion.disc_subset (whd_betadeltaiota env !evdref t) = None then ty + else None | _ -> None in let fj = pretype ftycon env evdref lvar f in - let floc = loc_of_rawconstr f in + let floc = loc_of_glob_constr f in let rec apply_rec env n resj tycon = function | [] -> resj | c::rest -> - let argloc = loc_of_rawconstr c in + let argloc = loc_of_glob_constr c in let resj = evd_comb1 (Coercion.inh_app_fun env) evdref resj in - let resty = whd_betadeltaiota env ( !evdref) resj.uj_type in + let resty = whd_betadeltaiota env !evdref resj.uj_type in match kind_of_term resty with | Prod (na,c1,c2) -> Option.iter (fun ty -> evdref := Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon; let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in evdref := evd; - let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in + let hj = pretype (mk_tycon c1) env evdref lvar c in let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in - let typ' = nf_evar !evdref typ in apply_rec env (n+1) - { uj_val = nf_evar !evdref value; - uj_type = nf_evar !evdref typ' } - (Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest + { uj_val = value; + uj_type = typ } + (Option.map (fun (abs, c) -> abs, c) tycon) rest | _ -> let hj = pretype empty_tycon env evdref lvar c in error_cant_apply_not_functional_loc - (join_loc floc argloc) env ( !evdref) + (join_loc floc argloc) env !evdref resj [hj] in - let resj = j_nf_evar ( !evdref) (apply_rec env 1 fj ftycon args) in + let resj = apply_rec env 1 fj ftycon args in let resj = - match kind_of_term resj.uj_val with + match kind_of_term (whd_evar !evdref resj.uj_val) with | App (f,args) when isInd f or isConst f -> let sigma = !evdref in let c = mkApp (f,Array.map (whd_evar sigma) args) in @@ -367,7 +367,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | _ -> resj in inh_conv_coerce_to_tycon loc env evdref resj tycon - | RLambda(loc,name,k,c1,c2) -> + | GLambda(loc,name,k,c1,c2) -> let tycon' = evd_comb1 (fun evd tycon -> match tycon with @@ -385,32 +385,32 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let resj = judge_of_abstraction env name j j' in inh_conv_coerce_to_tycon loc env evdref resj tycon - | RProd(loc,name,k,c1,c2) -> + | GProd(loc,name,k,c1,c2) -> let j = pretype_type empty_valcon env evdref lvar c1 in let var = (name,j.utj_val) in - let env' = push_rel_assum var env in + let env' = Termops.push_rel_assum var env in let j' = pretype_type empty_valcon env' evdref lvar c2 in let resj = try judge_of_product env name j j' - with TypeError _ as e -> Stdpp.raise_with_loc loc e in + with TypeError _ as e -> Loc.raise loc e in inh_conv_coerce_to_tycon loc env evdref resj tycon - | RLetIn(loc,name,c1,c2) -> + | GLetIn(loc,name,c1,c2) -> let j = pretype empty_tycon env evdref lvar c1 in - let t = refresh_universes j.uj_type in + let t = Termops.refresh_universes j.uj_type in let var = (name,Some j.uj_val,t) in let tycon = lift_tycon 1 tycon in let j' = pretype tycon (push_rel var env) evdref lvar c2 in { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } - | RLetTuple (loc,nal,(na,po),c,d) -> + | GLetTuple (loc,nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = - try find_rectype env ( !evdref) cj.uj_type + try find_rectype env !evdref cj.uj_type with Not_found -> - let cloc = loc_of_rawconstr c in - error_case_not_inductive_loc cloc env ( !evdref) cj + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj in let cstrs = get_constructors env indf in if Array.length cstrs <> 1 then @@ -434,14 +434,14 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | Some p -> let env_p = push_rels psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar ( !evdref) pj.utj_val in + let ccl = nf_evar !evdref pj.utj_val in let psign = make_arity_signature env true indf in (* with names *) let p = it_mkLambda_or_LetIn ccl psign in let inst = (Array.to_list cs.cs_concl_realargs) @[build_dependent_constructor cs] in let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist env ( !evdref) lp inst in + let fty = hnf_lam_applist env !evdref lp inst in let fj = pretype (mk_tycon fty) env_f evdref lvar d in let f = it_mkLambda_or_LetIn fj.uj_val fsign in let v = @@ -454,12 +454,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let tycon = lift_tycon cs.cs_nargs tycon in let fj = pretype tycon env_f evdref lvar d in let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let ccl = nf_evar ( !evdref) fj.uj_type in + let ccl = nf_evar !evdref fj.uj_type in let ccl = if noccur_between 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else - error_cant_find_case_type_loc loc env ( !evdref) + error_cant_find_case_type_loc loc env !evdref cj.uj_val in let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = @@ -469,13 +469,13 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct in { uj_val = v; uj_type = ccl }) - | RIf (loc,c,(na,po),b1,b2) -> + | GIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = - try find_rectype env ( !evdref) cj.uj_type + try find_rectype env !evdref cj.uj_type with Not_found -> - let cloc = loc_of_rawconstr c in - error_case_not_inductive_loc cloc env ( !evdref) cj in + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj in let cstrs = get_constructors env indf in if Array.length cstrs <> 2 then user_err_loc (loc,"", @@ -494,7 +494,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | Some p -> let env_p = push_rels psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar ( !evdref) pj.utj_val in + let ccl = nf_evar !evdref pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred; @@ -505,15 +505,14 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let p = match tycon with | Some (None, ty) -> ty | None | Some _ -> - e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) + e_new_evar evdref env ~src:(loc,InternalHole) (Termops.new_Type ()) in it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in - let pred = nf_evar ( !evdref) pred in - let p = nf_evar ( !evdref) p in - (* msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*) + let pred = nf_evar !evdref pred in + let p = nf_evar !evdref p in let f cs b = let n = rel_context_length cs.cs_args in - let pi = lift n pred in (* liftn n 2 pred ? *) + let pi = lift n pred in let pi = beta_applist (pi, [build_dependent_constructor cs]) in let csgn = if not !allow_anonymous_refs then @@ -527,7 +526,6 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct cs.cs_args in let env_c = push_rels csgn env in -(* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *) let bj = pretype (mk_tycon pi) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs.cs_args in let b1 = f cstrs.(0) b1 in @@ -539,12 +537,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct in { uj_val = v; uj_type = p } - | RCases (loc,sty,po,tml,eqns) -> + | GCases (loc,sty,po,tml,eqns) -> Cases.compile_cases loc sty ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) tycon env (* loc *) (po,tml,eqns) - | RCast (loc,c,k) -> + | GCast (loc,c,k) -> let cj = match k with CastCoerce -> @@ -553,25 +551,14 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | CastConv (k,t) -> let tj = pretype_type empty_valcon env evdref lvar t in let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in - (* User Casts are for helping pretyping, experimentally not to be kept*) - (* ... except for Correctness *) let v = mkCast (cj.uj_val, k, tj.utj_val) in { uj_val = v; uj_type = tj.utj_val } in inh_conv_coerce_to_tycon loc env evdref cj tycon - | RDynamic (loc,d) -> - if (Dyn.tag d) = "constr" then - let c = constr_out d in - let j = (Retyping.get_judgment_of env ( !evdref) c) in - j - (*inh_conv_coerce_to_tycon loc env evdref j tycon*) - else - user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic.")) - (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) and pretype_type valcon env evdref lvar = function - | RHole loc -> + | GHole loc -> (match valcon with | Some v -> let s = @@ -586,12 +573,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct { utj_val = v; utj_type = s } | None -> - let s = new_Type_sort () in + let s = Termops.new_Type_sort () in { utj_val = e_new_evar evdref env ~src:loc (mkSort s); utj_type = s}) | c -> let j = pretype empty_tycon env evdref lvar c in - let loc = loc_of_rawconstr c in + let loc = loc_of_glob_constr c in let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in match valcon with | None -> tj @@ -599,7 +586,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct if e_cumul env evdref v tj.utj_val then tj else error_unexpected_type_loc - (loc_of_rawconstr c) env ( !evdref) tj.utj_val v + (loc_of_glob_constr c) env !evdref tj.utj_val v let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c = let c' = match kind with @@ -607,15 +594,20 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in (pretype tycon env evdref lvar c).uj_val | IsType -> - (pretype_type empty_valcon env evdref lvar c).utj_val in - evdref := consider_remaining_unif_problems env !evdref; - if resolve_classes then - (evdref := Typeclasses.resolve_typeclasses ~onlyargs:false - ~split:true ~fail:fail_evar env !evdref; - evdref := consider_remaining_unif_problems env !evdref); - let c = if expand_evar then nf_evar !evdref c' else c' in - if fail_evar then check_evars env Evd.empty !evdref c; - c + (pretype_type empty_valcon env evdref lvar c).utj_val + in + if resolve_classes then + (try + evdref := Typeclasses.resolve_typeclasses ~filter:Subtac_utils.no_goals_or_obligations + ~split:true ~fail:true env !evdref; + evdref := Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars + ~split:true ~fail:false env !evdref + with e when Errors.noncritical e -> + if fail_evar then raise e else ()); + evdref := consider_remaining_unif_problems env !evdref; + let c = if expand_evar then nf_evar !evdref c' else c' in + if fail_evar then check_evars env Evd.empty !evdref c; + c (* TODO: comment faire remonter l'information si le typage a resolu des variables du sigma original. il faudrait que la fonction de typage @@ -654,8 +646,8 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let understand_type sigma env c = snd (ise_pretype_gen true false true sigma env ([],[]) IsType c) - let understand_ltac expand_evar sigma env lvar kind c = - ise_pretype_gen expand_evar false true sigma env lvar kind c + let understand_ltac ?(resolve_classes=false) expand_evar sigma env lvar kind c = + ise_pretype_gen expand_evar false resolve_classes sigma env lvar kind c let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c = ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml index 362c4ddc..e32bb9e0 100644 --- a/plugins/subtac/subtac_utils.ml +++ b/plugins/subtac/subtac_utils.ml @@ -15,10 +15,8 @@ let ($) f x = f x let contrib_name = "Program" let subtac_dir = [contrib_name] -let fix_sub_module = "Wf" -let utils_module = "Utils" -let fixsub_module = subtac_dir @ [fix_sub_module] -let utils_module = subtac_dir @ [utils_module] +let fixsub_module = subtac_dir @ ["Wf"] +let utils_module = subtac_dir @ ["Utils"] let tactics_module = subtac_dir @ ["Tactics"] let init_constant dir s () = gen_constant contrib_name dir s let init_reference dir s () = gen_reference contrib_name dir s @@ -27,7 +25,6 @@ let safe_init_constant md name () = check_required_library ("Coq"::md); init_constant md name () -let fixsub = init_constant fixsub_module "Fix_sub" let ex_pi1 = init_constant utils_module "ex_pi1" let ex_pi2 = init_constant utils_module "ex_pi2" @@ -55,11 +52,9 @@ let build_sig () = let sig_ = build_sig -let fix_proto = init_constant tactics_module "fix_proto" -let fix_proto_ref () = - match Nametab.global (make_ref "Program.Tactics.fix_proto") with - | ConstRef c -> c - | _ -> assert false +let fix_proto = safe_init_constant tactics_module "fix_proto" + +let hide_obligation = safe_init_constant tactics_module "obligation" let eq_ind = init_constant ["Init"; "Logic"] "eq" let eq_rec = init_constant ["Init"; "Logic"] "eq_rec" @@ -92,12 +87,6 @@ let ex_intro = init_reference ["Init"; "Logic"] "ex_intro" let proj1 = init_constant ["Init"; "Logic"] "proj1" let proj2 = init_constant ["Init"; "Logic"] "proj2" -let boolind = init_constant ["Init"; "Datatypes"] "bool" -let sumboolind = init_constant ["Init"; "Specif"] "sumbool" -let natind = init_constant ["Init"; "Datatypes"] "nat" -let intind = init_constant ["ZArith"; "binint"] "Z" -let existSind = init_constant ["Init"; "Specif"] "sigS" - let existS = build_sigma_type let prod = build_prod @@ -120,8 +109,8 @@ let my_print_rel_context env ctx = Printer.pr_rel_context env ctx let my_print_context = Termops.print_rel_context let my_print_named_context = Termops.print_named_context let my_print_env = Termops.print_env -let my_print_rawconstr = Printer.pr_rawconstr_env -let my_print_evardefs = Evd.pr_evar_map +let my_print_glob_constr = Printer.pr_glob_constr_env +let my_print_evardefs = Evd.pr_evar_map None let my_print_tycon_type = Evarutil.pr_tycon_type @@ -172,12 +161,11 @@ let print_args env args = Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "") let make_existential loc ?(opaque = Define true) env isevars c = - let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in - let (key, args) = destEvar evar in - (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++ - print_args env args ++ str " for type: "++ - my_print_constr env c) with _ -> ()); - evar + Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c + +let no_goals_or_obligations = function + | GoalEvar | QuestionMark _ -> false + | _ -> true let make_existential_expr loc env c = let key = Evarutil.new_untyped_evar () in @@ -244,7 +232,7 @@ let build_dependent_sum l = let hyptype = substl names t in trace (spc () ++ str ("treating evar " ^ string_of_id n)); (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) - with _ -> ()); + with e when Errors.noncritical e -> ()); let tac = assert_tac (Name n) hyptype in let conttac = (fun cont -> @@ -253,7 +241,7 @@ let build_dependent_sum l = ([intros; (tclTHENSEQ [constructor_tac false (Some 1) 1 - (Rawterm.ImplicitBindings [mkVar n]); + (Glob_term.ImplicitBindings [mkVar n]); cont]); ]))) in @@ -343,7 +331,7 @@ let destruct_ex ext ex = Ind i when i = Term.destInd (delayed_force ex_ind) && Array.length args = 2 -> let (dom, rng) = try (args.(0), args.(1)) - with _ -> assert(false) + with e when Errors.noncritical e -> assert(false) in let pi1 = (mk_ex_pi1 dom rng acc) in let rng_body = @@ -356,7 +344,7 @@ let destruct_ex ext ex = | _ -> [acc] in aux ex ext -open Rawterm +open Glob_term let id_of_name = function Name n -> n @@ -387,9 +375,9 @@ let solve_by_tac evi t = Inductiveops.control_only_guard (Global.env ()) const.Entries.const_entry_body; const.Entries.const_entry_body - with e -> + with reraise -> Pfedit.delete_current_proof(); - raise e + raise reraise (* let apply_tac t goal = t goal *) @@ -418,7 +406,6 @@ let string_of_intset d = open Printer open Ppconstr open Nameops -open Termops open Evd let pr_meta_map evd = @@ -430,11 +417,11 @@ let pr_meta_map evd = | (mv,Cltyp (na,b)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " : " ++ - print_constr b.rebus ++ fnl ()) + Termops.print_constr b.rebus ++ fnl ()) | (mv,Clval(na,b,_)) -> hov 0 (pr_meta mv ++ pr_name na ++ str " := " ++ - print_constr (fst b).rebus ++ fnl ()) + Termops.print_constr (fst b).rebus ++ fnl ()) in prlist pr_meta_binding ml @@ -445,11 +432,11 @@ let pr_evar_info evi = (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *) Printer.pr_named_context (Global.env()) (evar_context evi) in - let pty = print_constr evi.evar_concl in + let pty = Termops.print_constr evi.evar_concl in let pb = match evi.evar_body with | Evar_empty -> mt () - | Evar_defined c -> spc() ++ str"=> " ++ print_constr c + | Evar_defined c -> spc() ++ str"=> " ++ Termops.print_constr c in hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]") @@ -463,11 +450,11 @@ let pr_evar_map sigma = let pr_constraints pbs = h 0 (prlist_with_sep pr_fnl (fun (pbty,t1,t2) -> - print_constr t1 ++ spc() ++ + Termops.print_constr t1 ++ spc() ++ str (match pbty with | Reduction.CONV -> "==" | Reduction.CUMUL -> "<=") ++ - spc() ++ print_constr t2) pbs) + spc() ++ Termops.print_constr t2) pbs) let pr_evar_map evd = let pp_evm = @@ -486,4 +473,4 @@ let tactics_tac s = lazy(make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s)) let tactics_call tac args = - TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args)) + TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args)) diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli index f56c2932..112b1795 100644 --- a/plugins/subtac/subtac_utils.mli +++ b/plugins/subtac/subtac_utils.mli @@ -6,7 +6,7 @@ open Pp open Evd open Decl_kinds open Topconstr -open Rawterm +open Glob_term open Util open Evarutil open Names @@ -15,11 +15,9 @@ open Sign val ($) : ('a -> 'b) -> 'a -> 'b val contrib_name : string val subtac_dir : string list -val fix_sub_module : string val fixsub_module : string list val init_constant : string list -> string -> constr delayed val init_reference : string list -> string -> global_reference delayed -val fixsub : constr delayed val well_founded_ref : global_reference delayed val acc_ref : global_reference delayed val acc_inv_ref : global_reference delayed @@ -35,7 +33,8 @@ val build_sig : unit -> coq_sigma_data val sig_ : coq_sigma_data delayed val fix_proto : constr delayed -val fix_proto_ref : unit -> constant + +val hide_obligation : constr delayed val eq_ind : constr delayed val eq_rec : constr delayed @@ -52,11 +51,6 @@ val jmeq_ind : constr delayed val jmeq_rec : constr delayed val jmeq_refl : constr delayed -val boolind : constr delayed -val sumboolind : constr delayed -val natind : constr delayed -val intind : constr delayed -val existSind : constr delayed val existS : coq_sigma_data delayed val prod : coq_sigma_data delayed @@ -74,7 +68,7 @@ val my_print_context : env -> std_ppcmds val my_print_rel_context : env -> rel_context -> std_ppcmds val my_print_named_context : env -> std_ppcmds val my_print_env : env -> std_ppcmds -val my_print_rawconstr : env -> rawconstr -> std_ppcmds +val my_print_glob_constr : env -> glob_constr -> std_ppcmds val my_print_tycon_type : env -> type_constraint_type -> std_ppcmds @@ -88,6 +82,7 @@ val app_opt : ('a -> 'a) option -> 'a -> 'a val print_args : env -> constr array -> std_ppcmds val make_existential : loc -> ?opaque:obligation_definition_status -> env -> evar_map ref -> types -> constr +val no_goals_or_obligations : Typeclasses.evar_filter val make_existential_expr : loc -> 'a -> 'b -> constr_expr val string_of_hole_kind : hole_kind -> string val evars_of_term : evar_map -> evar_map -> constr -> evar_map diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index ae3afff4..bd2285bb 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -6,13 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id: ascii_syntax.ml 12406 2009-10-21 15:12:52Z soubiran $ i*) - open Pp open Util open Names open Pcoq -open Rawterm +open Glob_term open Topconstr open Libnames open Coqlib @@ -41,9 +39,9 @@ let interp_ascii dloc p = let rec aux n p = if n = 0 then [] else let mp = p mod 2 in - RRef (dloc,if mp = 0 then glob_false else glob_true) + GRef (dloc,if mp = 0 then glob_false else glob_true) :: (aux (n-1) (p/2)) in - RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p) + GApp (dloc,GRef(dloc,force glob_Ascii), aux 8 p) let interp_ascii_string dloc s = let p = @@ -59,12 +57,12 @@ let interp_ascii_string dloc s = let uninterp_ascii r = let rec uninterp_bool_list n = function | [] when n = 0 -> 0 - | RRef (_,k)::l when k = glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | RRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l) + | GRef (_,k)::l when k = glob_true -> 1+2*(uninterp_bool_list (n-1) l) + | GRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try let rec aux = function - | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l + | GApp (_,GRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) with @@ -80,4 +78,4 @@ let _ = Notation.declare_string_interpreter "char_scope" (ascii_path,ascii_module) interp_ascii_string - ([RRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true) + ([GRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true) diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index 7b92a92f..63b44008 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: nat_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - (* This file defines the printer for natural numbers in [nat] *) (*i*) @@ -16,7 +14,7 @@ open Pp open Util open Names open Coqlib -open Rawterm +open Glob_term open Libnames open Bigint open Coqlib @@ -30,19 +28,21 @@ open Names (* Parsing via scopes *) (* For example, (nat_of_string "3") is <<(S (S (S O)))>> *) +let threshold = of_int 5000 + let nat_of_int dloc n = if is_pos_or_zero n then begin - if less_than (of_string "5000") n then + if less_than threshold n then Flags.if_warn msg_warning (strbrk "Stack overflow or segmentation fault happens when " ++ strbrk "working with large numbers in nat (observed threshold " ++ strbrk "may vary from 5000 to 70000 depending on your system " ++ strbrk "limits and on the command executed)."); - let ref_O = RRef (dloc, glob_O) in - let ref_S = RRef (dloc, glob_S) in + let ref_O = GRef (dloc, glob_O) in + let ref_S = GRef (dloc, glob_S) in let rec mk_nat acc n = if n <> zero then - mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n) + mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n) else acc in @@ -58,8 +58,8 @@ let nat_of_int dloc n = exception Non_closed_number let rec int_of_nat = function - | RApp (_,RRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a) - | RRef (_,z) when z = glob_O -> zero + | GApp (_,GRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a) + | GRef (_,z) when z = glob_O -> zero | _ -> raise Non_closed_number let uninterp_nat p = @@ -75,4 +75,4 @@ let _ = Notation.declare_numeral_interpreter "nat_scope" (nat_path,["Coq";"Init";"Datatypes"]) nat_of_int - ([RRef (dummy_loc,glob_S); RRef (dummy_loc,glob_O)], uninterp_nat, true) + ([GRef (dummy_loc,glob_S); GRef (dummy_loc,glob_O)], uninterp_nat, true) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index a540a7d0..b8636a74 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -1,18 +1,16 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: numbers_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - (* digit-based syntax for int31, bigN bigZ and bigQ *) open Bigint open Libnames -open Rawterm +open Glob_term (*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***) @@ -48,30 +46,14 @@ let zn2z_WW = ConstructRef ((zn2z_id "zn2z",0),2) let bigN_module = ["Coq"; "Numbers"; "Natural"; "BigN"; "BigN" ] let bigN_path = make_path (bigN_module@["BigN"]) "t" -let bigN_t = make_mind_mpdot bigN_module "BigN" "t_" +let bigN_t = make_mind_mpdot bigN_module "BigN" "t'" let bigN_scope = "bigN_scope" (* number of inlined level of bigN (actually the level 0 to n_inlined-1 are inlined) *) -let n_inlined = of_string "7" -let bigN_constructor = - (* converts a bigint into an int the ugly way *) - let rec to_int i = - if equal i zero then - 0 - else - let (quo,rem) = div2_with_rest i in - if rem then - 2*(to_int quo)+1 - else - 2*(to_int quo) - in - fun i -> - ConstructRef ((bigN_t,0), - if less_than i n_inlined then - (to_int i)+1 - else - (to_int n_inlined)+1 - ) +let n_inlined = 7 + +let bigN_constructor i = + ConstructRef ((bigN_t,0),(min i n_inlined)+1) (*bigZ stuff*) let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ] @@ -100,9 +82,9 @@ exception Non_closed (* parses a *non-negative* integer (from bigint.ml) into an int31 wraps modulo 2^31 *) let int31_of_pos_bigint dloc n = - let ref_construct = RRef (dloc, int31_construct) in - let ref_0 = RRef (dloc, int31_0) in - let ref_1 = RRef (dloc, int31_1) in + let ref_construct = GRef (dloc, int31_construct) in + let ref_0 = GRef (dloc, int31_0) in + let ref_1 = GRef (dloc, int31_1) in let rec args counter n = if counter <= 0 then [] @@ -110,7 +92,7 @@ let int31_of_pos_bigint dloc n = let (q,r) = div2_with_rest n in (if r then ref_1 else ref_0)::(args (counter-1) q) in - RApp (dloc, ref_construct, List.rev (args 31 n)) + GApp (dloc, ref_construct, List.rev (args 31 n)) let error_negative dloc = Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.") @@ -127,12 +109,12 @@ let bigint_of_int31 = let rec args_parsing args cur = match args with | [] -> cur - | (RRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur) - | (RRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | (GRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur) + | (GRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in function - | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero + | GApp (_, GRef (_, c), args) when c=int31_construct -> args_parsing args zero | _ -> raise Non_closed let uninterp_int31 i = @@ -145,62 +127,61 @@ let uninterp_int31 i = let _ = Notation.declare_numeral_interpreter int31_scope (int31_path, int31_module) interp_int31 - ([RRef (Util.dummy_loc, int31_construct)], + ([GRef (Util.dummy_loc, int31_construct)], uninterp_int31, true) (*** Parsing for bigN in digital notation ***) (* the base for bigN (in Coq) that is 2^31 in our case *) -let base = pow two (of_string "31") +let base = pow two 31 -(* base of the bigN of height N : *) -let rank n = pow base (pow two n) +(* base of the bigN of height N : (2^31)^(2^n) *) +let rank n = + let rec rk n pow2 = + if n <= 0 then pow2 + else rk (n-1) (mult pow2 pow2) + in rk n base (* splits a number bi at height n, that is the rest needs 2^n int31 to be stored it is expected to be used only when the quotient would also need 2^n int31 to be stored *) let split_at n bi = - euclid bi (rank (sub_1 n)) + euclid bi (rank (n-1)) (* search the height of the Coq bigint needed to represent the integer bi *) let height bi = - let rec height_aux n = - if less_than bi (rank n) then - n - else - height_aux (add_1 n) - in - height_aux zero - + let rec hght n pow2 = + if less_than bi pow2 then n + else hght (n+1) (mult pow2 pow2) + in hght 0 base (* n must be a non-negative integer (from bigint.ml) *) let word_of_pos_bigint dloc hght n = - let ref_W0 = RRef (dloc, zn2z_W0) in - let ref_WW = RRef (dloc, zn2z_WW) in + let ref_W0 = GRef (dloc, zn2z_W0) in + let ref_WW = GRef (dloc, zn2z_WW) in let rec decomp hgt n = - if is_neg_or_zero hgt then + if hgt <= 0 then int31_of_pos_bigint dloc n else if equal n zero then - RApp (dloc, ref_W0, [RHole (dloc, Evd.InternalHole)]) + GApp (dloc, ref_W0, [GHole (dloc, Evd.InternalHole)]) else let (h,l) = split_at hgt n in - RApp (dloc, ref_WW, [RHole (dloc, Evd.InternalHole); - decomp (sub_1 hgt) h; - decomp (sub_1 hgt) l]) + GApp (dloc, ref_WW, [GHole (dloc, Evd.InternalHole); + decomp (hgt-1) h; + decomp (hgt-1) l]) in decomp hght n let bigN_of_pos_bigint dloc n = - let ref_constructor i = RRef (dloc, bigN_constructor i) in - let result h word = RApp (dloc, ref_constructor h, if less_than h n_inlined then - [word] - else - [Nat_syntax.nat_of_int dloc (sub h n_inlined); - word]) + let h = height n in + let ref_constructor = GRef (dloc, bigN_constructor h) in + let word = word_of_pos_bigint dloc h n in + let args = + if h < n_inlined then [word] + else [Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word] in - let hght = height n in - result hght (word_of_pos_bigint dloc hght n) + GApp (dloc, ref_constructor, args) let bigN_error_negative dloc = Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") @@ -217,23 +198,18 @@ let interp_bigN dloc n = let bigint_of_word = let rec get_height rc = match rc with - | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW -> - let hleft = get_height lft in - let hright = get_height rght in - add_1 - (if less_than hleft hright then - hright - else - hleft) - | _ -> zero + | GApp (_,GRef(_,c), [_;lft;rght]) when c = zn2z_WW -> + 1+max (get_height lft) (get_height rght) + | _ -> 0 in let rec transform hght rc = match rc with - | RApp (_,RRef(_,c),_) when c = zn2z_W0-> zero - | RApp (_,RRef(_,c), [_;lft;rght]) when c=zn2z_WW-> let new_hght = sub_1 hght in - add (mult (rank new_hght) - (transform (new_hght) lft)) - (transform (new_hght) rght) + | GApp (_,GRef(_,c),_) when c = zn2z_W0-> zero + | GApp (_,GRef(_,c), [_;lft;rght]) when c=zn2z_WW-> + let new_hght = hght-1 in + add (mult (rank new_hght) + (transform new_hght lft)) + (transform new_hght rght) | _ -> bigint_of_int31 rc in fun rc -> @@ -242,8 +218,8 @@ let bigint_of_word = let bigint_of_bigN rc = match rc with - | RApp (_,_,[one_arg]) -> bigint_of_word one_arg - | RApp (_,_,[_;second_arg]) -> bigint_of_word second_arg + | GApp (_,_,[one_arg]) -> bigint_of_word one_arg + | GApp (_,_,[_;second_arg]) -> bigint_of_word second_arg | _ -> raise Non_closed let uninterp_bigN rc = @@ -258,12 +234,12 @@ let uninterp_bigN rc = let bigN_list_of_constructors = let rec build i = - if less_than i (add_1 n_inlined) then - RRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i)) + if i < n_inlined+1 then + GRef (Util.dummy_loc, bigN_constructor i)::(build (i+1)) else [] in - build zero + build 0 (* Actually declares the interpreter for bigN *) let _ = Notation.declare_numeral_interpreter bigN_scope @@ -276,17 +252,17 @@ let _ = Notation.declare_numeral_interpreter bigN_scope (*** Parsing for bigZ in digital notation ***) let interp_bigZ dloc n = - let ref_pos = RRef (dloc, bigZ_pos) in - let ref_neg = RRef (dloc, bigZ_neg) in + let ref_pos = GRef (dloc, bigZ_pos) in + let ref_neg = GRef (dloc, bigZ_neg) in if is_pos_or_zero n then - RApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n]) + GApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n]) else - RApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg n)]) + GApp (dloc, ref_neg, [bigN_of_pos_bigint dloc (neg n)]) (* pretty printing functions for bigZ *) let bigint_of_bigZ = function - | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg - | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_neg -> + | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg + | GApp (_, GRef(_,c), [one_arg]) when c = bigZ_neg -> let opp_val = bigint_of_bigN one_arg in if equal opp_val zero then raise Non_closed @@ -305,19 +281,19 @@ let uninterp_bigZ rc = let _ = Notation.declare_numeral_interpreter bigZ_scope (bigZ_path, bigZ_module) interp_bigZ - ([RRef (Util.dummy_loc, bigZ_pos); - RRef (Util.dummy_loc, bigZ_neg)], + ([GRef (Util.dummy_loc, bigZ_pos); + GRef (Util.dummy_loc, bigZ_neg)], uninterp_bigZ, true) (*** Parsing for bigQ in digital notation ***) let interp_bigQ dloc n = - let ref_z = RRef (dloc, bigQ_z) in - RApp (dloc, ref_z, [interp_bigZ dloc n]) + let ref_z = GRef (dloc, bigQ_z) in + GApp (dloc, ref_z, [interp_bigZ dloc n]) let uninterp_bigQ rc = try match rc with - | RApp (_, RRef(_,c), [one_arg]) when c = bigQ_z -> + | GApp (_, GRef(_,c), [one_arg]) when c = bigQ_z -> Some (bigint_of_bigZ one_arg) | _ -> None (* we don't pretty-print yet fractions *) with Non_closed -> None @@ -326,5 +302,5 @@ let uninterp_bigQ rc = let _ = Notation.declare_numeral_interpreter bigQ_scope (bigQ_path, bigQ_module) interp_bigQ - ([RRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ, + ([GRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ, true) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 43e79c82..401c23f7 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: r_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ i*) - open Pp open Util open Names @@ -22,7 +20,7 @@ exception Non_closed_number (**********************************************************************) open Libnames -open Rawterm +open Glob_term open Bigint let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) @@ -48,24 +46,24 @@ let four = mult_2 two (* Unary representation of strictly positive numbers *) let rec small_r dloc n = - if equal one n then RRef (dloc, glob_R1) - else RApp(dloc,RRef (dloc,glob_Rplus), - [RRef (dloc, glob_R1);small_r dloc (sub_1 n)]) + if equal one n then GRef (dloc, glob_R1) + else GApp(dloc,GRef (dloc,glob_Rplus), + [GRef (dloc, glob_R1);small_r dloc (sub_1 n)]) let r_of_posint dloc n = - let r1 = RRef (dloc, glob_R1) in + let r1 = GRef (dloc, glob_R1) in let r2 = small_r dloc two in let rec r_of_pos n = if less_than n four then small_r dloc n else let (q,r) = div2_with_rest n in - let b = RApp(dloc,RRef(dloc,glob_Rmult),[r2;r_of_pos q]) in - if r then RApp(dloc,RRef(dloc,glob_Rplus),[r1;b]) else b in - if n <> zero then r_of_pos n else RRef(dloc,glob_R0) + let b = GApp(dloc,GRef(dloc,glob_Rmult),[r2;r_of_pos q]) in + if r then GApp(dloc,GRef(dloc,glob_Rplus),[r1;b]) else b in + if n <> zero then r_of_pos n else GRef(dloc,glob_R0) let r_of_int dloc z = if is_strictly_neg z then - RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) + GApp (dloc, GRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) else r_of_posint dloc z @@ -77,33 +75,33 @@ let bignat_of_r = (* for numbers > 1 *) let rec bignat_of_pos = function (* 1+1 *) - | RApp (_,RRef (_,p), [RRef (_,o1); RRef (_,o2)]) + | GApp (_,GRef (_,p), [GRef (_,o1); GRef (_,o2)]) when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two (* 1+(1+1) *) - | RApp (_,RRef (_,p1), [RRef (_,o1); - RApp(_,RRef (_,p2),[RRef(_,o2);RRef(_,o3)])]) + | GApp (_,GRef (_,p1), [GRef (_,o1); + GApp(_,GRef (_,p2),[GRef(_,o2);GRef(_,o3)])]) when p1 = glob_Rplus & p2 = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three (* (1+1)*b *) - | RApp (_,RRef (_,p), [a; b]) when p = glob_Rmult -> + | GApp (_,GRef (_,p), [a; b]) when p = glob_Rmult -> if bignat_of_pos a <> two then raise Non_closed_number; mult_2 (bignat_of_pos b) (* 1+(1+1)*b *) - | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])]) + | GApp (_,GRef (_,p1), [GRef (_,o); GApp (_,GRef (_,p2),[a;b])]) when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 -> if bignat_of_pos a <> two then raise Non_closed_number; add_1 (mult_2 (bignat_of_pos b)) | _ -> raise Non_closed_number in let bignat_of_r = function - | RRef (_,a) when a = glob_R0 -> zero - | RRef (_,a) when a = glob_R1 -> one + | GRef (_,a) when a = glob_R0 -> zero + | GRef (_,a) when a = glob_R1 -> one | r -> bignat_of_pos r in bignat_of_r let bigint_of_r = function - | RApp (_,RRef (_,o), [a]) when o = glob_Ropp -> + | GApp (_,GRef (_,o), [a]) when o = glob_Ropp -> let n = bignat_of_r a in if n = zero then raise Non_closed_number; neg n @@ -118,8 +116,8 @@ let uninterp_r p = let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0); - RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult); - RRef(dummy_loc,glob_R1)], + ([GRef(dummy_loc,glob_Ropp);GRef(dummy_loc,glob_R0); + GRef(dummy_loc,glob_Rplus);GRef(dummy_loc,glob_Rmult); + GRef(dummy_loc,glob_R1)], uninterp_r, false) diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 534605c8..d670f602 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(*i $Id: string_syntax.ml 12337 2009-09-17 15:58:14Z glondu $ i*) - open Pp open Util open Names @@ -15,7 +13,7 @@ open Pcoq open Libnames open Topconstr open Ascii_syntax -open Rawterm +open Glob_term open Coqlib exception Non_closed_string @@ -39,8 +37,8 @@ open Lazy let interp_string dloc s = let le = String.length s in let rec aux n = - if n = le then RRef (dloc, force glob_EmptyString) else - RApp (dloc,RRef (dloc, force glob_String), + if n = le then GRef (dloc, force glob_EmptyString) else + GApp (dloc,GRef (dloc, force glob_String), [interp_ascii dloc (int_of_char s.[n]); aux (n+1)]) in aux 0 @@ -48,11 +46,11 @@ let uninterp_string r = try let b = Buffer.create 16 in let rec aux = function - | RApp (_,RRef (_,k),[a;s]) when k = force glob_String -> + | GApp (_,GRef (_,k),[a;s]) when k = force glob_String -> (match uninterp_ascii a with | Some c -> Buffer.add_char b (Char.chr c); aux s | _ -> raise Non_closed_string) - | RRef (_,z) when z = force glob_EmptyString -> + | GRef (_,z) when z = force glob_EmptyString -> Some (Buffer.contents b) | _ -> raise Non_closed_string @@ -64,6 +62,6 @@ let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string - ([RRef (dummy_loc,static_glob_String); - RRef (dummy_loc,static_glob_EmptyString)], + ([GRef (dummy_loc,static_glob_String); + GRef (dummy_loc,static_glob_EmptyString)], uninterp_string, true) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index e6dcc35e..032e0036 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: z_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ *) - open Pcoq open Pp open Util @@ -23,18 +21,19 @@ exception Non_closed_number (**********************************************************************) open Libnames -open Rawterm +open Glob_term + +let binnums = ["Coq";"Numbers";"BinNums"] + let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) -let positive_module = ["Coq";"NArith";"BinPos"] let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id) -let positive_path = make_path positive_module "positive" +let positive_path = make_path binnums "positive" (* TODO: temporary hack *) let make_kn dir id = Libnames.encode_mind dir id -let positive_kn = - make_kn (make_dir positive_module) (id_of_string "positive") +let positive_kn = make_kn (make_dir binnums) (id_of_string "positive") let glob_positive = IndRef (positive_kn,0) let path_of_xI = ((positive_kn,0),1) let path_of_xO = ((positive_kn,0),2) @@ -44,13 +43,13 @@ let glob_xO = ConstructRef path_of_xO let glob_xH = ConstructRef path_of_xH let pos_of_bignat dloc x = - let ref_xI = RRef (dloc, glob_xI) in - let ref_xH = RRef (dloc, glob_xH) in - let ref_xO = RRef (dloc, glob_xO) in + let ref_xI = GRef (dloc, glob_xI) in + let ref_xH = GRef (dloc, glob_xH) in + let ref_xO = GRef (dloc, glob_xO) in let rec pos_of x = match div2_with_rest x with - | (q,false) -> RApp (dloc, ref_xO,[pos_of q]) - | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q]) + | (q,false) -> GApp (dloc, ref_xO,[pos_of q]) + | (q,true) when q <> zero -> GApp (dloc,ref_xI,[pos_of q]) | (q,true) -> ref_xH in pos_of x @@ -68,9 +67,9 @@ let interp_positive dloc n = (**********************************************************************) let rec bignat_of_pos = function - | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a) - | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a)) - | RRef (_, a) when a = glob_xH -> Bigint.one + | GApp (_, GRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a) + | GApp (_, GRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (_, a) when a = glob_xH -> Bigint.one | _ -> raise Non_closed_number let uninterp_positive p = @@ -84,11 +83,11 @@ let uninterp_positive p = (************************************************************************) let _ = Notation.declare_numeral_interpreter "positive_scope" - (positive_path,positive_module) + (positive_path,binnums) interp_positive - ([RRef (dummy_loc, glob_xI); - RRef (dummy_loc, glob_xO); - RRef (dummy_loc, glob_xH)], + ([GRef (dummy_loc, glob_xI); + GRef (dummy_loc, glob_xO); + GRef (dummy_loc, glob_xH)], uninterp_positive, true) @@ -96,21 +95,20 @@ let _ = Notation.declare_numeral_interpreter "positive_scope" (* Parsing N via scopes *) (**********************************************************************) -let binnat_module = ["Coq";"NArith";"BinNat"] -let n_kn = make_kn (make_dir binnat_module) (id_of_string "N") +let n_kn = make_kn (make_dir binnums) (id_of_string "N") let glob_n = IndRef (n_kn,0) let path_of_N0 = ((n_kn,0),1) let path_of_Npos = ((n_kn,0),2) let glob_N0 = ConstructRef path_of_N0 let glob_Npos = ConstructRef path_of_Npos -let n_path = make_path binnat_module "N" +let n_path = make_path binnums "N" let n_of_binnat dloc pos_or_neg n = if n <> zero then - RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n]) + GApp(dloc, GRef (dloc,glob_Npos), [pos_of_bignat dloc n]) else - RRef (dloc, glob_N0) + GRef (dloc, glob_N0) let error_negative dloc = user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".") @@ -124,8 +122,8 @@ let n_of_int dloc n = (**********************************************************************) let bignat_of_n = function - | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a - | RRef (_, a) when a = glob_N0 -> Bigint.zero + | GApp (_, GRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a + | GRef (_, a) when a = glob_N0 -> Bigint.zero | _ -> raise Non_closed_number let uninterp_n p = @@ -136,10 +134,10 @@ let uninterp_n p = (* Declaring interpreters and uninterpreters for N *) let _ = Notation.declare_numeral_interpreter "N_scope" - (n_path,binnat_module) + (n_path,binnums) n_of_int - ([RRef (dummy_loc, glob_N0); - RRef (dummy_loc, glob_Npos)], + ([GRef (dummy_loc, glob_N0); + GRef (dummy_loc, glob_Npos)], uninterp_n, true) @@ -147,9 +145,8 @@ let _ = Notation.declare_numeral_interpreter "N_scope" (* Parsing Z via scopes *) (**********************************************************************) -let binint_module = ["Coq";"ZArith";"BinInt"] -let z_path = make_path binint_module "Z" -let z_kn = make_kn (make_dir binint_module) (id_of_string "Z") +let z_path = make_path binnums "Z" +let z_kn = make_kn (make_dir binnums) (id_of_string "Z") let glob_z = IndRef (z_kn,0) let path_of_ZERO = ((z_kn,0),1) let path_of_POS = ((z_kn,0),2) @@ -162,18 +159,18 @@ let z_of_int dloc n = if n <> zero then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in - RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n]) + GApp(dloc, GRef (dloc,sgn), [pos_of_bignat dloc n]) else - RRef (dloc, glob_ZERO) + GRef (dloc, glob_ZERO) (**********************************************************************) (* Printing Z via scopes *) (**********************************************************************) let bigint_of_z = function - | RApp (_, RRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a - | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a) - | RRef (_, a) when a = glob_ZERO -> Bigint.zero + | GApp (_, GRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a + | GApp (_, GRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (_, a) when a = glob_ZERO -> Bigint.zero | _ -> raise Non_closed_number let uninterp_z p = @@ -185,10 +182,10 @@ let uninterp_z p = (* Declaring interpreters and uninterpreters for Z *) let _ = Notation.declare_numeral_interpreter "Z_scope" - (z_path,binint_module) + (z_path,binnums) z_of_int - ([RRef (dummy_loc, glob_ZERO); - RRef (dummy_loc, glob_POS); - RRef (dummy_loc, glob_NEG)], + ([GRef (dummy_loc, glob_ZERO); + GRef (dummy_loc, glob_POS); + GRef (dummy_loc, glob_NEG)], uninterp_z, true) diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml index 97287d18..653c2b7b 100644 --- a/plugins/xml/acic.ml +++ b/plugins/xml/acic.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) diff --git a/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4 index 631af9f0..97f7e2bd 100644 --- a/plugins/xml/acic2Xml.ml4 +++ b/plugins/xml/acic2Xml.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml index 0b98acd2..a14eda60 100644 --- a/plugins/xml/cic2acic.ml +++ b/plugins/xml/cic2acic.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) @@ -349,7 +349,7 @@ let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids if computeinnertypes then try Acic.CicHash.find terms_to_types tt -with _ -> +with e when e <> Sys.Break -> (*CSC: Warning: it really happens, for example in Ring_theory!!! *) Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false else diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml index d67c114e..c22c16f0 100644 --- a/plugins/xml/doubleTypeInference.ml +++ b/plugins/xml/doubleTypeInference.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) @@ -27,7 +27,7 @@ let cprop = ;; let whd_betadeltaiotacprop env _evar_map ty = - let module R = Rawterm in + let module R = Glob_term in let module C = Closure in let module CR = C.RedFlags in (*** CProp is made Opaque ***) @@ -147,7 +147,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types = (*CSC: universes. *) (try Typeops.judge_of_type u - with _ -> (* Successor of a non universe-variable universe anomaly *) + with e when e <> Sys.Break -> + (* Successor of a non universe-variable universe anomaly *) (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ; Typeops.judge_of_type (Termops.new_univ ()) ) diff --git a/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli index 3858b906..5c00bdc6 100644 --- a/plugins/xml/doubleTypeInference.mli +++ b/plugins/xml/doubleTypeInference.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4 index 3cfc52b7..cbc52c5f 100644 --- a/plugins/xml/dumptree.ml4 +++ b/plugins/xml/dumptree.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -42,7 +42,7 @@ let thin_sign osign sign = ;; let pr_tactic_xml = function - | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>" + | TacArg (_,Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>" | t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) t) ++ str "\"/>" ;; @@ -56,13 +56,11 @@ let pr_rule_xml pr = function hov 2 (str "<cmpdrule>" ++ fnl () ++ begin match cmpd with Tactic (texp, _) -> pr_tactic_xml texp - | Proof_instr (_,instr) -> pr_proof_instr_xml instr end ++ fnl () ++ pr subtree ) ++ fnl () ++ str "</cmpdrule>" | Daimon -> str "<daimon/>" | Decl_proof _ -> str "<proof/>" -(* | Change_evars -> str "<chgevars/>"*) ;; let pr_var_decl_xml env (id,c,typ) = @@ -109,17 +107,17 @@ let pr_context_xml env = let pr_subgoal_metas_xml metas env= let pr_one (meta, typ) = - fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++ + fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_goal_concl_style_env env typ) ++ str "\"/>" in List.fold_left (++) (mt ()) (List.map pr_one metas) ;; -let pr_goal_xml g = - let env = try evar_unfiltered_env g with _ -> empty_env in - if g.evar_extra = None then +let pr_goal_xml sigma g = + let env = try Goal.V82.unfiltered_env sigma g with _ -> empty_env in + if Decl_mode.try_get_info sigma g = None then (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++ - xmlstream (pr_ltype_env_at_top env g.evar_concl) ++ + xmlstream (pr_goal_concl_style_env env (Goal.V82.concl sigma g)) ++ str "\"/>" ++ (pr_context_xml env)) ++ fnl () ++ str "</goal>") @@ -129,23 +127,9 @@ let pr_goal_xml g = fnl () ++ str "</goal>") ;; -let rec print_proof_xml sigma osign pf = - let hyps = Environ.named_context_of_val pf.goal.evar_hyps in - let hyps' = thin_sign osign hyps in - match pf.ref with - | None -> hov 2 (str "<tree>" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "</tree>" - | Some(r,spfl) -> - hov 2 (str "<tree>" ++ fnl () ++ - (pr_goal_xml {pf.goal with evar_hyps=hyps'}) ++ fnl () ++ (pr_rule_xml (print_proof_xml sigma osign) r) ++ - (List.fold_left (fun x y -> x ++ fnl () ++ y) (mt ()) (List.map (print_proof_xml sigma hyps) spfl))) ++ fnl () ++ str "</tree>" -;; - let print_proof_xml () = - let pp = print_proof_xml Evd.empty Sign.empty_named_context - (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ()))) - in - msgnl pp -;; + Util.anomaly "Dump Tree command not supported in this version." + VERNAC COMMAND EXTEND DumpTree [ "Dump" "Tree" ] -> [ print_proof_xml () ] diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml index d871935b..2d16190b 100644 --- a/plugins/xml/proof2aproof.ml +++ b/plugins/xml/proof2aproof.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) @@ -59,30 +59,6 @@ let nf_evar sigma ~preserve = aux ;; -(* Unshares a proof-tree. *) -(* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *) -let rec unshare_proof_tree = - let module PT = Proof_type in - function {PT.open_subgoals = status ; - PT.goal = goal ; - PT.ref = ref} -> - let unshared_ref = - match ref with - None -> None - | Some (rule,pfs) -> - let unshared_rule = - match rule with - PT.Nested (cmpd, pf) -> - PT.Nested (cmpd, unshare_proof_tree pf) - | other -> other - in - Some (unshared_rule, List.map unshare_proof_tree pfs) - in - {PT.open_subgoals = status ; - PT.goal = goal ; - PT.ref = unshared_ref} -;; - module ProofTreeHash = Hashtbl.Make (struct @@ -94,83 +70,9 @@ module ProofTreeHash = let extract_open_proof sigma pf = - let module PT = Proof_type in - let module L = Logic in - let evd = ref (Evd.create_evar_defs sigma) in - let proof_tree_to_constr = ProofTreeHash.create 503 in - let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in - let unshared_constrs = ref S.empty in - let rec proof_extractor vl node = - let constr = - match node with - {PT.ref=Some(PT.Prim _,_)} as pf -> - L.prim_extractor proof_extractor vl pf - - | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} -> - let sgl,v = Refiner.frontier hidden_proof in - let flat_proof = v spfl in - ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ; - proof_extractor vl flat_proof - - | {PT.ref=None;PT.goal=goal} -> - let visible_rels = - Util.map_succeed - (fun id -> - (* Section variables are in the [id] list but are not *) - (* lambda abstracted in the term [vl] *) - try let n = Logic.proof_variable_index id vl in (n,id) - with Not_found -> failwith "caught") -(*CSC: the above function must be modified such that when it is found *) -(*CSC: it becomes a Rel; otherwise a Var. Then it can be already used *) -(*CSC: as the evar_instance. Ordering the instance becomes useless (it *) -(*CSC: will already be ordered. *) - (Termops.ids_of_named_context - (Environ.named_context_of_val goal.Evd.evar_hyps)) in - let sorted_rels = - Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in - let context = - let l = - List.map - (fun (_,id) -> Sign.lookup_named id - (Environ.named_context_of_val goal.Evd.evar_hyps)) - sorted_rels in - Environ.val_of_named_context l - in -(*CSC: the section variables in the right order must be added too *) - let evar_instance = List.map (fun (n,_) -> Term.mkRel n) sorted_rels in - (* let env = Global.env_of_context context in *) - let evd',evar = - Evarutil.new_evar_instance context !evd goal.Evd.evar_concl - evar_instance in - evd := evd' ; - evar - - | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor" - in - let unsharedconstr = - let evar_nf_constr = - nf_evar ( !evd) - ~preserve:(function e -> S.mem e !unshared_constrs) constr - in - Unshare.unshare - ~already_unshared:(function e -> S.mem e !unshared_constrs) - evar_nf_constr - in -(*CSC: debugging stuff to be removed *) -if ProofTreeHash.mem proof_tree_to_constr node then - Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ") - (Tactic_printer.print_proof ( !evd) [] node)) ; - ProofTreeHash.add proof_tree_to_constr node unsharedconstr ; - unshared_constrs := S.add unsharedconstr !unshared_constrs ; - unsharedconstr - in - let unshared_pf = unshare_proof_tree pf in - let pfterm = proof_extractor [] unshared_pf in - (pfterm, !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree, - unshared_pf) -;; + (* Deactivated and candidate for removal. (Apr. 2010) *) + () let extract_open_pftreestate pts = - extract_open_proof (Refiner.evc_of_pftreestate pts) - (Tacmach.proof_of_pftreestate pts) -;; + (* Deactivated and candidate for removal. (Apr. 2010) *) + () diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4 index 21c86c79..2f5eb6ac 100644 --- a/plugins/xml/proofTree2Xml.ml4 +++ b/plugins/xml/proofTree2Xml.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) @@ -14,11 +14,6 @@ let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";; -let std_ppcmds_to_string s = - Pp.msg_with Format.str_formatter s; - Format.flush_str_formatter () -;; - let idref_of_id id = "v" ^ id;; (* Transform a constr to an Xml.token Stream.t *) @@ -149,22 +144,24 @@ Pp.ppnl (Pp.(++) (Pp.str Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node in begin match tactic_expr with - | T.TacArg (T.Tacexp _) -> + | T.TacArg (_,T.Tacexp _) -> (* We don't need to keep the level of abstraction introduced at *) (* user-level invocation of tactic... (see Tacinterp.hide_interp)*) aux flat_proof old_hyps | _ -> (****** la tactique employee *) let prtac = Pptactic.pr_tactic (Global.env()) in - let tac = std_ppcmds_to_string (prtac tactic_expr) in + let tac = Pp.string_of_ppcmds (prtac tactic_expr) in let tacname= first_word tac in let of_attribute = ("name",tacname)::("script",tac)::of_attribute in (****** le but *) - let {Evd.evar_concl=concl; - Evd.evar_hyps=hyps}=goal in + + let concl = Goal.V82.concl sigma goal in + let hyps = Goal.V82.hyps sigma goal in let env = Global.env_of_context hyps in + let xgoal = X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in @@ -188,14 +185,12 @@ Pp.ppnl (Pp.(++) (Pp.str [<(build_hyps new_hyps) ; (aux flat_proof nhyps)>] end - | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} -> - Util.anomaly "Not Implemented" - | {PT.ref=Some(PT.Daimon,_)} -> X.xml_empty "Hidden_open_goal" of_attribute | {PT.ref=None;PT.goal=goal} -> X.xml_empty "Open_goal" of_attribute + | {PT.ref=Some(PT.Decl_proof _, _)} -> failwith "TODO: xml and decl_proof" in [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ; X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n"); diff --git a/plugins/xml/unshare.ml b/plugins/xml/unshare.ml index 344a1581..c854427d 100644 --- a/plugins/xml/unshare.ml +++ b/plugins/xml/unshare.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) diff --git a/plugins/xml/unshare.mli b/plugins/xml/unshare.mli index 4b96b22e..cace2de6 100644 --- a/plugins/xml/unshare.mli +++ b/plugins/xml/unshare.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) diff --git a/plugins/xml/xml.ml4 b/plugins/xml/xml.ml4 index 2d73074b..8a4eb39a 100644 --- a/plugins/xml/xml.ml4 +++ b/plugins/xml/xml.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) diff --git a/plugins/xml/xml.mli b/plugins/xml/xml.mli index ffaad957..0b6d5198 100644 --- a/plugins/xml/xml.mli +++ b/plugins/xml/xml.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) @@ -12,8 +12,6 @@ (* http://helm.cs.unibo.it *) (************************************************************************) -(*i $Id: xml.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - (* Tokens for XML cdata, empty elements and not-empty elements *) (* Usage: *) (* Str cdata *) diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index 7e7f890f..867aac71 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) @@ -143,7 +143,7 @@ let rec join_dirs cwd = | he::tail -> (try Unix.mkdir cwd 0o775 - with _ -> () (* Let's ignore the errors on mkdir *) + with e when e <> Sys.Break -> () (* Let's ignore the errors on mkdir *) ) ; let newcwd = cwd ^ "/" ^ he in join_dirs newcwd tail @@ -527,8 +527,10 @@ let print internal glob_ref kind xml_library_root = Cic2acic.Variable kn,mk_variable_obj id body typ | Ln.ConstRef kn -> let id = N.id_of_label (N.con_label kn) in - let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} = - G.lookup_constant kn in + let cb = G.lookup_constant kn in + let val0 = D.body_of_constant cb in + let typ = cb.D.const_type in + let hyps = cb.D.const_hyps 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,_) -> @@ -557,43 +559,13 @@ 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 pf = Tacmach.proof_of_pftreestate pftst in - let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in - let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree, - unshared_pf - = - Proof2aproof.extract_open_pftreestate pftst in - let env = Global.env () in - let obj = - mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in - let uri = - match kind with - Decl_kinds.Local, _ -> - let uri = - "cic:/" ^ String.concat "/" - (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.TVariable) - in - let kind_of_var = "VARIABLE","LocalFact" in - (match internal with - | Declare.KernelSilent -> () - | _ -> print_object_kind uri kind_of_var - ); uri - | Decl_kinds.Global, _ -> - let uri = Cic2acic.uri_of_declaration id Cic2acic.TConstant in - (match internal with - | Declare.KernelSilent -> () - | _ -> print_object_kind uri (kind_of_global_goal kind) - ); uri - in - print_object uri obj evar_map - (Some (Tacmach.evc_of_pftreestate pftst,unshared_pf,proof_tree_to_constr, - proof_tree_to_flattened_proof_tree)) fn -;; + if true then + Util.anomaly "Xmlcommand.show_pftreestate is not supported in this version." let show fn = let pftst = Pfedit.get_pftreestate () in let (id,kind,_,_) = Pfedit.current_proof_statement () in - show_pftreestate Declare.KernelVerbose fn (kind,pftst) id + show_pftreestate false fn (kind,pftst) id ;; @@ -680,7 +652,7 @@ let _ = end ; Option.iter (fun fn -> - let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in + let coqdoc = Filename.concat Envars.coqbin ("coqdoc" ^ Coq_config.exec_extension) in let options = " --html -s --body-only --no-index --latin1 --raw-comments" in let command cmd = if Sys.command cmd <> 0 then diff --git a/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli index eadf3cfd..ec50d623 100644 --- a/plugins/xml/xmlcommand.mli +++ b/plugins/xml/xmlcommand.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) @@ -12,8 +12,6 @@ (* http://helm.cs.unibo.it *) (************************************************************************) -(*i $Id: xmlcommand.mli 14641 2011-11-06 11:59:10Z herbelin $ i*) - (* print_global qid fn *) (* where qid is a long name denoting a definition/theorem or *) (* an inductive definition *) diff --git a/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4 index f9d5bac0..d65a1bd3 100644 --- a/plugins/xml/xmlentries.ml4 +++ b/plugins/xml/xmlentries.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) (* \VV/ **************************************************************) (* // * The HELM Project / The EU MoWGLI Project *) (* * University of Bologna *) @@ -14,8 +14,6 @@ (*i camlp4deps: "parsing/grammar.cma" i*) -(* $Id: xmlentries.ml4 14641 2011-11-06 11:59:10Z herbelin $ *) - open Util;; open Vernacinterp;; |