From 97fefe1fcca363a1317e066e7f4b99b9c1e9987b Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 12 Jan 2012 16:02:20 +0100 Subject: Imported Upstream version 8.4~beta --- plugins/cc/ccalgo.ml | 98 +- plugins/cc/ccalgo.mli | 13 +- plugins/cc/ccproof.ml | 10 +- plugins/cc/ccproof.mli | 4 +- plugins/cc/cctac.ml | 47 +- plugins/cc/cctac.mli | 4 +- plugins/cc/g_congruence.ml4 | 4 +- plugins/decl_mode/decl_expr.mli | 103 + plugins/decl_mode/decl_interp.ml | 471 +++ plugins/decl_mode/decl_interp.mli | 16 + plugins/decl_mode/decl_mode.ml | 123 + plugins/decl_mode/decl_mode.mli | 78 + plugins/decl_mode/decl_mode_plugin.mllib | 6 + plugins/decl_mode/decl_proof_instr.ml | 1501 ++++++++ plugins/decl_mode/decl_proof_instr.mli | 109 + plugins/decl_mode/g_decl_mode.ml4 | 408 +++ plugins/decl_mode/ppdecl_proof.ml | 188 + plugins/decl_mode/ppdecl_proof.mli | 2 + plugins/dp/Dp.v | 2 - plugins/dp/dp.ml | 23 +- plugins/dp/g_dp.ml4 | 4 +- plugins/dp/test2.v | 2 +- plugins/dp/zenon.v | 2 - plugins/extraction/ExtrOcamlBasic.v | 4 +- plugins/extraction/ExtrOcamlBigIntConv.v | 2 +- plugins/extraction/ExtrOcamlIntConv.v | 2 +- plugins/extraction/ExtrOcamlNatBigInt.v | 6 +- plugins/extraction/ExtrOcamlNatInt.v | 8 +- plugins/extraction/ExtrOcamlString.v | 2 +- plugins/extraction/ExtrOcamlZBigInt.v | 70 +- plugins/extraction/ExtrOcamlZInt.v | 66 +- plugins/extraction/big.ml | 2 +- plugins/extraction/common.ml | 37 +- plugins/extraction/common.mli | 15 +- plugins/extraction/extract_env.ml | 128 +- plugins/extraction/extract_env.mli | 10 +- plugins/extraction/extraction.ml | 178 +- plugins/extraction/extraction.mli | 4 +- plugins/extraction/g_extraction.ml4 | 8 +- plugins/extraction/haskell.ml | 158 +- plugins/extraction/haskell.mli | 4 +- plugins/extraction/miniml.mli | 50 +- plugins/extraction/mlutil.ml | 287 +- plugins/extraction/mlutil.mli | 11 +- plugins/extraction/modutil.ml | 91 +- plugins/extraction/modutil.mli | 7 +- plugins/extraction/ocaml.ml | 327 +- plugins/extraction/ocaml.mli | 4 +- plugins/extraction/scheme.ml | 29 +- plugins/extraction/scheme.mli | 4 +- plugins/extraction/table.ml | 219 +- plugins/extraction/table.mli | 38 +- plugins/field/LegacyField.v | 4 +- plugins/field/LegacyField_Compl.v | 4 +- plugins/field/LegacyField_Tactic.v | 4 +- plugins/field/LegacyField_Theory.v | 4 +- plugins/field/field.ml4 | 16 +- plugins/firstorder/formula.ml | 4 +- plugins/firstorder/formula.mli | 4 +- plugins/firstorder/g_ground.ml4 | 7 +- plugins/firstorder/ground.ml | 32 +- plugins/firstorder/ground.mli | 4 +- plugins/firstorder/instances.ml | 18 +- plugins/firstorder/instances.mli | 4 +- plugins/firstorder/rules.ml | 4 +- plugins/firstorder/rules.mli | 4 +- plugins/firstorder/sequent.ml | 71 +- plugins/firstorder/sequent.mli | 4 +- plugins/firstorder/unify.ml | 7 +- plugins/firstorder/unify.mli | 4 +- plugins/fourier/Fourier.v | 4 +- plugins/fourier/Fourier_util.v | 4 +- plugins/fourier/fourier.ml | 4 +- plugins/fourier/fourierR.ml | 40 +- plugins/fourier/g_fourier.ml4 | 4 +- plugins/funind/Recdef.v | 2 +- plugins/funind/functional_principles_proofs.ml | 62 +- plugins/funind/functional_principles_types.ml | 61 +- plugins/funind/functional_principles_types.mli | 6 +- plugins/funind/g_indfun.ml4 | 118 +- plugins/funind/glob_term_to_relation.ml | 1478 ++++++++ plugins/funind/glob_term_to_relation.mli | 16 + plugins/funind/glob_termops.ml | 712 ++++ plugins/funind/glob_termops.mli | 126 + plugins/funind/indfun.ml | 549 +-- plugins/funind/indfun.mli | 24 + plugins/funind/indfun_common.ml | 63 +- plugins/funind/indfun_common.mli | 15 +- plugins/funind/invfun.ml | 78 +- plugins/funind/merge.ml | 133 +- plugins/funind/rawterm_to_relation.ml | 1480 -------- plugins/funind/rawterm_to_relation.mli | 16 - plugins/funind/rawtermops.ml | 718 ---- plugins/funind/rawtermops.mli | 126 - plugins/funind/recdef.ml | 229 +- plugins/funind/recdef_plugin.mllib | 4 +- plugins/micromega/CheckerMaker.v | 5 +- plugins/micromega/Env.v | 16 +- plugins/micromega/EnvRing.v | 24 +- plugins/micromega/MExtraction.v | 19 +- plugins/micromega/OrderedRing.v | 2 +- plugins/micromega/Psatz.v | 20 +- plugins/micromega/QMicromega.v | 14 +- plugins/micromega/RMicromega.v | 480 ++- plugins/micromega/Refl.v | 2 +- plugins/micromega/RingMicromega.v | 195 +- plugins/micromega/Tauto.v | 248 +- plugins/micromega/VarMap.v | 225 +- plugins/micromega/ZCoeff.v | 8 +- plugins/micromega/ZMicromega.v | 327 +- plugins/micromega/certificate.ml | 1244 ++++--- plugins/micromega/coq_micromega.ml | 646 +++- plugins/micromega/csdpcert.ml | 4 +- plugins/micromega/g_micromega.ml4 | 16 +- plugins/micromega/mfourier.ml | 179 +- plugins/micromega/micromega.ml | 4625 ++++++++++++++++++------ plugins/micromega/micromega.mli | 1080 +++++- plugins/micromega/micromega_plugin.mllib | 1 + plugins/micromega/mutils.ml | 123 +- plugins/micromega/persistent_cache.ml | 79 +- plugins/micromega/polynomial.ml | 739 ++++ plugins/micromega/sos.ml | 74 +- plugins/micromega/sos.mli | 2 +- plugins/micromega/sos_types.ml | 2 +- plugins/nsatz/Nsatz.v | 599 ++- plugins/nsatz/ideal.ml | 6 +- plugins/nsatz/nsatz.ml4 | 88 +- plugins/nsatz/polynom.ml | 5 +- plugins/nsatz/polynom.mli | 2 +- plugins/omega/Omega.v | 4 +- plugins/omega/OmegaLemmas.v | 9 +- plugins/omega/OmegaPlugin.v | 4 +- plugins/omega/PreOmega.v | 115 +- plugins/omega/coq_omega.ml | 357 +- plugins/omega/g_omega.ml4 | 4 +- plugins/omega/omega.ml | 4 +- plugins/pluginsbyte.itarget | 1 + plugins/pluginsdyn.itarget | 1 + plugins/pluginsopt.itarget | 1 + plugins/quote/Quote.v | 5 +- plugins/quote/g_quote.ml4 | 6 +- plugins/quote/quote.ml | 28 +- plugins/ring/LegacyArithRing.v | 6 +- plugins/ring/LegacyNArithRing.v | 6 +- plugins/ring/LegacyRing.v | 4 +- plugins/ring/LegacyRing_theory.v | 4 +- plugins/ring/LegacyZArithRing.v | 6 +- plugins/ring/Ring_abstract.v | 6 +- plugins/ring/Ring_normalize.v | 15 +- plugins/ring/Setoid_ring.v | 4 +- plugins/ring/Setoid_ring_normalize.v | 15 +- plugins/ring/Setoid_ring_theory.v | 4 +- plugins/ring/g_ring.ml4 | 4 +- plugins/ring/ring.ml | 57 +- plugins/romega/ReflOmegaCore.v | 46 +- plugins/romega/const_omega.ml | 86 +- plugins/romega/refl_omega.ml | 4 +- plugins/rtauto/Bintree.v | 223 +- plugins/rtauto/Rtauto.v | 48 +- plugins/rtauto/g_rtauto.ml4 | 4 +- plugins/rtauto/proof_search.ml | 5 +- plugins/rtauto/proof_search.mli | 4 +- plugins/rtauto/refl_tauto.ml | 18 +- plugins/rtauto/refl_tauto.mli | 4 +- plugins/setoid_ring/Algebra_syntax.v | 25 + plugins/setoid_ring/ArithRing.v | 6 +- plugins/setoid_ring/BinList.v | 2 +- plugins/setoid_ring/Cring.v | 272 ++ plugins/setoid_ring/Field.v | 2 +- plugins/setoid_ring/Field_tac.v | 2 +- plugins/setoid_ring/Field_theory.v | 132 +- plugins/setoid_ring/InitialRing.v | 122 +- plugins/setoid_ring/Integral_domain.v | 44 + plugins/setoid_ring/NArithRing.v | 4 +- plugins/setoid_ring/Ncring.v | 305 ++ plugins/setoid_ring/Ncring_initial.v | 221 ++ plugins/setoid_ring/Ncring_polynom.v | 621 ++++ plugins/setoid_ring/Ncring_tac.v | 308 ++ plugins/setoid_ring/Ring.v | 2 +- plugins/setoid_ring/Ring_base.v | 2 +- plugins/setoid_ring/Ring_polynom.v | 24 +- plugins/setoid_ring/Ring_theory.v | 19 +- plugins/setoid_ring/Rings_Q.v | 30 + plugins/setoid_ring/Rings_R.v | 34 + plugins/setoid_ring/Rings_Z.v | 14 + plugins/setoid_ring/ZArithRing.v | 8 +- plugins/setoid_ring/newring.ml4 | 69 +- plugins/setoid_ring/vo.itarget | 10 + plugins/subtac/eterm.ml | 19 +- plugins/subtac/eterm.mli | 3 +- plugins/subtac/g_subtac.ml4 | 16 +- plugins/subtac/subtac.ml | 28 +- plugins/subtac/subtac_cases.ml | 51 +- plugins/subtac/subtac_cases.mli | 6 +- plugins/subtac/subtac_classes.ml | 39 +- plugins/subtac/subtac_classes.mli | 6 +- plugins/subtac/subtac_coercion.ml | 21 +- plugins/subtac/subtac_command.ml | 64 +- plugins/subtac/subtac_command.mli | 8 +- plugins/subtac/subtac_obligations.ml | 171 +- plugins/subtac/subtac_obligations.mli | 2 +- plugins/subtac/subtac_pretyping.ml | 19 +- plugins/subtac/subtac_pretyping.mli | 2 +- plugins/subtac/subtac_pretyping_F.ml | 167 +- plugins/subtac/subtac_utils.ml | 44 +- plugins/subtac/subtac_utils.mli | 14 +- plugins/syntax/ascii_syntax.ml | 16 +- plugins/syntax/nat_syntax.ml | 18 +- plugins/syntax/numbers_syntax.ml | 72 +- plugins/syntax/r_syntax.ml | 44 +- plugins/syntax/string_syntax.ml | 16 +- plugins/syntax/z_syntax.ml | 81 +- plugins/xml/acic.ml | 2 +- plugins/xml/acic2Xml.ml4 | 2 +- plugins/xml/cic2acic.ml | 2 +- plugins/xml/doubleTypeInference.ml | 4 +- plugins/xml/doubleTypeInference.mli | 2 +- plugins/xml/dumptree.ml4 | 32 +- plugins/xml/proof2aproof.ml | 108 +- plugins/xml/proofTree2Xml.ml4 | 21 +- plugins/xml/unshare.ml | 2 +- plugins/xml/unshare.mli | 2 +- plugins/xml/xml.ml4 | 2 +- plugins/xml/xml.mli | 4 +- plugins/xml/xmlcommand.ml | 46 +- plugins/xml/xmlcommand.mli | 4 +- plugins/xml/xmlentries.ml4 | 4 +- 227 files changed, 18301 insertions(+), 8612 deletions(-) create mode 100644 plugins/decl_mode/decl_expr.mli create mode 100644 plugins/decl_mode/decl_interp.ml create mode 100644 plugins/decl_mode/decl_interp.mli create mode 100644 plugins/decl_mode/decl_mode.ml create mode 100644 plugins/decl_mode/decl_mode.mli create mode 100644 plugins/decl_mode/decl_mode_plugin.mllib create mode 100644 plugins/decl_mode/decl_proof_instr.ml create mode 100644 plugins/decl_mode/decl_proof_instr.mli create mode 100644 plugins/decl_mode/g_decl_mode.ml4 create mode 100644 plugins/decl_mode/ppdecl_proof.ml create mode 100644 plugins/decl_mode/ppdecl_proof.mli create mode 100644 plugins/funind/glob_term_to_relation.ml create mode 100644 plugins/funind/glob_term_to_relation.mli create mode 100644 plugins/funind/glob_termops.ml create mode 100644 plugins/funind/glob_termops.mli create mode 100644 plugins/funind/indfun.mli delete mode 100644 plugins/funind/rawterm_to_relation.ml delete mode 100644 plugins/funind/rawterm_to_relation.mli delete mode 100644 plugins/funind/rawtermops.ml delete mode 100644 plugins/funind/rawtermops.mli create mode 100644 plugins/micromega/polynomial.ml create mode 100644 plugins/setoid_ring/Algebra_syntax.v create mode 100644 plugins/setoid_ring/Cring.v create mode 100644 plugins/setoid_ring/Integral_domain.v create mode 100644 plugins/setoid_ring/Ncring.v create mode 100644 plugins/setoid_ring/Ncring_initial.v create mode 100644 plugins/setoid_ring/Ncring_polynom.v create mode 100644 plugins/setoid_ring/Ncring_tac.v create mode 100644 plugins/setoid_ring/Rings_Q.v create mode 100644 plugins/setoid_ring/Rings_R.v create mode 100644 plugins/setoid_ring/Rings_Z.v (limited to 'plugins') diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 3c40cfb9..e3d27f71 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* !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} @@ -384,7 +422,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 +468,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 +479,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 +499,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 +514,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 +570,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 +729,11 @@ 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 new_hyps = + Environ.push_named_context_val (id,None,typ) (Goal.V82.hyps sigma gl) in + let gls = Goal.V82.new_goal_with sigma gl new_hyps in + state.gls<- gls; id let complete_one_class state i= @@ -763,14 +801,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 +826,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 +848,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 +871,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..78dbee3f 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..bb1d50c9 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..67819596 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 @@ -214,9 +211,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 +257,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 +278,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 +308,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 +318,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 +329,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 +349,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 +411,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 +453,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..32f56163 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..46fbcec7 --- /dev/null +++ b/plugins/decl_mode/decl_interp.mli @@ -0,0 +1,16 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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..af6aa4bf --- /dev/null +++ b/plugins/decl_mode/decl_mode.ml @@ -0,0 +1,123 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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..4e636598 --- /dev/null +++ b/plugins/decl_mode/decl_mode.mli @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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..c1553b35 --- /dev/null +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -0,0 +1,1501 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* (!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 _ -> + 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 _ -> 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 _ -> + 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..1205060a --- /dev/null +++ b/plugins/decl_mode/decl_proof_instr.mli @@ -0,0 +1,109 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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..27def8cc --- /dev/null +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -0,0 +1,408 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + 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 "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 *) + 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..b866efab --- /dev/null +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -0,0 +1,188 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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 index 5ddc4452..1b66c334 100644 --- a/plugins/dp/Dp.v +++ b/plugins/dp/Dp.v @@ -6,8 +6,6 @@ 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. diff --git a/plugins/dp/dp.ml b/plugins/dp/dp.ml index ceadd26e..837195e4 100644 --- a/plugins/dp/dp.ml +++ b/plugins/dp/dp.ml @@ -23,7 +23,6 @@ open Fol open Names open Nameops open Namegen -open Termops open Coqlib open Hipattern open Libnames @@ -37,7 +36,7 @@ let set_trace b = trace := b let timeout = ref 10 let set_timeout n = timeout := n -let (dp_timeout_obj,_) = +let dp_timeout_obj : int -> obj = declare_object {(default_object "Dp_timeout") with cache_function = (fun (_,x) -> set_timeout x); @@ -45,7 +44,7 @@ let (dp_timeout_obj,_) = let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x) -let (dp_debug_obj,_) = +let dp_debug_obj : bool -> obj = declare_object {(default_object "Dp_debug") with cache_function = (fun (_,x) -> set_debug x); @@ -53,7 +52,7 @@ let (dp_debug_obj,_) = let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x) -let (dp_trace_obj,_) = +let dp_trace_obj : bool -> obj = declare_object {(default_object "Dp_trace") with cache_function = (fun (_,x) -> set_trace x); @@ -148,7 +147,7 @@ let fresh_var = function 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 + let avoid = ref (Termops.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 @@ -183,7 +182,7 @@ let decomp_type_lambdas env 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 + | Prod (_,t,c) when not (Termops.dependent (mkRel 1) c) -> arrows_rec (t :: l) c | Cast (c,_,_) -> arrows_rec l c | _ -> List.rev l, c in @@ -195,8 +194,8 @@ let rec eta_expanse t vars env i = 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 + | Prod (n, a, b) when not (Termops.dependent (mkRel 1) b) -> + let avoid = Termops.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 @@ -469,7 +468,7 @@ and axiomatize_body env r id d = match r with | VarRef _ -> assert false | ConstRef c -> - begin match (Global.lookup_constant c).const_body with + begin match body_of_constant (Global.lookup_constant c) with | Some b -> let b = force b in let axioms = @@ -826,7 +825,7 @@ let prelude_files = ref ([] : string list) let set_prelude l = prelude_files := l -let (dp_prelude_obj,_) = +let dp_prelude_obj : string list -> obj = declare_object {(default_object "Dp_prelude") with cache_function = (fun (_,x) -> set_prelude x); @@ -1088,7 +1087,7 @@ let dp_hint l = in List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l) -let (dp_hint_obj,_) = +let dp_hint_obj : reference list -> obj = declare_object {(default_object "Dp_hint") with cache_function = (fun (_,l) -> dp_hint l); @@ -1114,7 +1113,7 @@ let dp_predefined qid s = with NotFO -> msg_warning (str " ignored (not a first order declaration)") -let (dp_predefined_obj,_) = +let dp_predefined_obj : reference * string -> obj = declare_object {(default_object "Dp_predefined") with cache_function = (fun (_,(id,s)) -> dp_predefined id s); diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4 index fc957ea6..001ccce8 100644 --- a/plugins/dp/g_dp.ml4 +++ b/plugins/dp/g_dp.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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]. +Arguments IN [A] _ _. Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l). zenon. diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v index f2400a7f..89028c4f 100644 --- a/plugins/dp/zenon.v +++ b/plugins/dp/zenon.v @@ -1,6 +1,4 @@ (* Copyright 2004 INRIA *) -(* $Id: zenon.v 11996 2009-03-20 01:22:58Z letouzey $ *) - Require Export Classical. Lemma zenon_nottrue : diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v index eab2f67c..c9556972 100644 --- a/plugins/extraction/ExtrOcamlBasic.v +++ b/plugins/extraction/ExtrOcamlBasic.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..69e72918 100644 --- a/plugins/extraction/ExtrOcamlBigIntConv.v +++ b/plugins/extraction/ExtrOcamlBigIntConv.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "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..a0cb26b5 100644 --- a/plugins/extraction/ExtrOcamlNatInt.v +++ b/plugins/extraction/ExtrOcamlNatInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "fun n m -> 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 nat_beq => "(=)".*) Extract Inlined Constant EqNat.beq_nat => "(=)". Extract Inlined Constant EqNat.eq_nat_decide => "(=)". @@ -72,4 +72,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..f8f942c8 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "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". +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". (** Zdiv and Zmod are quite complex to define in terms of (/) and (mod). For the moment we don't even try *) diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v index a7046626..55ba0ca1 100644 --- a/plugins/extraction/ExtrOcamlZInt.v +++ b/plugins/extraction/ExtrOcamlZInt.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 => "succ". +Extract Constant Pos.pred => "fun n -> max 1 (n-1)". +Extract Constant Pos.sub => "fun n m -> max 1 (n-m)". +Extract Constant Pos.mul => "( * )". +Extract Constant Pos.min => "min". +Extract Constant Pos.max => "max". +Extract Constant Pos.compare => + "fun x y -> if x=y then Eq else if x "fun x y c -> if x=y then c else if x "(+)". -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 => "succ". +Extract Constant N.pred => "fun n -> max 0 (n-1)". +Extract Constant N.sub => "fun n m -> max 0 (n-m)". +Extract Constant N.mul => "( * )". +Extract Constant N.min => "min". +Extract Constant N.max => "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 "(+)". -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 => "succ". +Extract Constant Z.pred => "pred". +Extract Constant Z.sub => "(-)". +Extract Constant Z.mul => "( * )". +Extract Constant Z.opp => "(~-)". +Extract Constant Z.abs => "abs". +Extract Constant Z.min => "min". +Extract Constant Z.max => "max". +Extract Constant Z.compare => "fun x y -> if x=y then Eq else if x "fun p -> p". -Extract Constant Zabs_N => "abs". +Extract Constant Z.of_N => "fun p -> p". +Extract Constant Z.abs_N => "abs". (** Zdiv and Zmod 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..4c33691d 100644 --- a/plugins/extraction/big.ml +++ b/plugins/extraction/big.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 @@ -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..02a496be 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..73062328 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 *) -(* 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,8 @@ 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 +173,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 @@ -200,9 +217,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,7 +239,7 @@ 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 mt = extract_seb_spec env mp1 (seb,seb') in @@ -231,7 +247,7 @@ and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with | 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 +299,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 +327,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 +361,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 *) @@ -488,13 +504,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 +524,8 @@ 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 _ -> 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 +540,41 @@ 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 | ([], [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 +585,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 +599,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..e587bf21 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 *) -(* 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..219b3913 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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: @@ -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; @@ -727,8 +746,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 @@ -792,22 +811,22 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt = (* 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. *) @@ -869,7 +888,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 +897,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 +907,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 @@ -925,34 +944,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 = snd (record_constant_type env kn (Some typ)) in + Dterm (r, MLaxiom, type_expunge env 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 +993,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 +1007,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 +1029,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..48f05acb 100644 --- a/plugins/extraction/extraction.mli +++ b/plugins/extraction/extraction.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ 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..96731ed2 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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,17 @@ 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)) | 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 +111,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 +123,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 +133,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 +181,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 +283,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..0f8949e3 100644 --- a/plugins/extraction/haskell.mli +++ b/plugins/extraction/haskell.mli @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..c244e046 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 @@ -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 _ -> 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..029e8cf4 100644 --- a/plugins/extraction/mlutil.mli +++ b/plugins/extraction/mlutil.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..9e8dd828 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* () | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt' @@ -58,7 +56,10 @@ let struct_iter do_decl do_spec s = | 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 s = + List.iter (function (_,sel) -> List.iter (se_iter do_decl do_spec) sel) s (*s Apply some fonctions upon all references in [ml_type], [ml_ast], [ml_decl], [ml_spec] and [ml_structure]. *) @@ -76,18 +77,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 +117,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 @@ -236,7 +244,7 @@ let rec optim_se top to_appear s = function 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) + if top && i && not (library ()) && not (List.mem r to_appear) then optim_se top to_appear s lse else let d = match optimize_fix a with @@ -254,7 +262,7 @@ let rec optim_se top to_appear s = function then s := Refmap'.add rv.(i) (dfix_to_mlfix rv av i) !s else all := false done; - if !all && top && not (modular ()) + if !all && top && not (library ()) && (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) @@ -271,7 +279,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 objects *) exception NoDepCheck @@ -281,15 +290,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 +313,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 +323,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 +339,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,7 +351,10 @@ 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 t; + t :: se' let rec depcheck_struct = function | [] -> [] @@ -350,13 +377,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 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..0565522b 100644 --- a/plugins/extraction/modutil.mli +++ b/plugins/extraction/modutil.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..ed69ec45 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 = @@ -137,7 +123,8 @@ let rec pp_type par vl t = | 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 +141,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 +163,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 +175,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)))) | 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 +201,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 +299,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 +328,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 +436,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 +444,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 +467,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..fd60c69d 100644 --- a/plugins/extraction/ocaml.mli +++ b/plugins/extraction/ocaml.mli @@ -1,12 +1,10 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..eeca083c 100644 --- a/plugins/extraction/scheme.mli +++ b/plugins/extraction/scheme.mli @@ -1,11 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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,25 +207,51 @@ 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) @@ -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" false -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,7 @@ 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 match g with | IndRef ((kn,i) as ip) -> let mib = Global.lookup_mind kn in @@ -805,5 +863,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..a3b7124e 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..011bc81e 100644 --- a/plugins/field/LegacyField.v +++ b/plugins/field/LegacyField.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..d67dceea 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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); @@ -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 diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 163b9891..46708053 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - 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..a4ee68fd 100644 --- a/plugins/firstorder/ground.mli +++ b/plugins/firstorder/ground.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 4802aaa3..16831d3e 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -1,20 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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,9 +123,9 @@ 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) @@ -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..be69b067 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..c5c2bb95 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* r0;; +let flin_coef f x = try (Constrhash.find f.fhom x) with _-> r0;; let flin_add f x c = let cx = flin_coef f x in - Hashtbl.remove f.fhom x; - Hashtbl.add f.fhom x (rplus cx c); + 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); ;; @@ -167,7 +171,7 @@ let rec flin_of_constr c = 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 +260,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 diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index ea766830..9276eda1 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 *) -(* - let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in + let e = Cerrors.process_vernac_interp_error e in + let goal = begin try (Printer.pr_goal g) with _ -> assert false end 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 = @@ -263,7 +263,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 +286,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 +350,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 +388,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 +406,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 +461,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 +489,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 +589,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 @@ -609,7 +609,7 @@ let my_orelse tac1 tac2 g = try tac1 g with e -> -(* observe (str "using snd tac since : " ++ Cerrors.explain_exn 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 +909,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 +936,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 +954,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 +964,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 +1009,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 +1052,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 @@ -1300,7 +1300,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 @@ -1400,10 +1400,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 +1416,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 +1438,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" @@ -1451,7 +1451,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = 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..6df9d574 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,7 +138,7 @@ 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 @@ -199,58 +197,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 +265,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 +281,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 +289,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 @@ -384,10 +381,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 @@ -450,7 +446,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 +471,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 +489,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 +503,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 @@ -584,7 +583,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 +638,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 +687,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..123399d5 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 *) -(* 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 "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 @@ -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/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml new file mode 100644 index 00000000..c88c6669 --- /dev/null +++ b/plugins/funind/glob_term_to_relation.ml @@ -0,0 +1,1478 @@ +open Printer +open Pp +open Names +open Term +open Glob_term +open Libnames +open Indfun_common +open Util +open Glob_termops + +let observe strm = + if do_observe () + then Pp.msgnl strm + else () +let observennl strm = + if do_observe () + then Pp.msg strm + else () + + +type binder_type = + | Lambda of name + | Prod of name + | LetIn of name + +type glob_context = (binder_type*glob_constr) list + +(* + 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_glob_context = + let compose_binder (bt,t) acc = + match bt with + | 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 globalized constructor expressions + from the rhs of a fixpoint equation. +*) + +type 'a build_entry_pre_return = + { + context : glob_context; (* the binding context of the result *) + value : 'a; (* The value *) + } + +type 'a build_entry_return = + { + result : 'a build_entry_pre_return list; + to_avoid : identifier list + } + +(* + [combine_results combine_fun res1 res2] combine two results [res1] and [res2] + w.r.t. [combine_fun]. + + Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] + and [res2_1,....] and we need to produce + [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........] +*) + +let combine_results + (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> + 'c build_entry_pre_return + ) + (res1: 'a build_entry_return) + (res2 : 'b build_entry_return) + : 'c build_entry_return + = + let pre_result = List.map + ( fun res1 -> (* for each result in arg_res *) + List.map (* we add it in each args_res *) + (fun res2 -> + combine_fun res1 res2 + ) + res2.result + ) + res1.result + in (* and then we flatten the map *) + { + result = List.concat pre_result; + to_avoid = list_union res1.to_avoid res2.to_avoid + } + + +(* + The combination function for an argument with a list of argument +*) + +let combine_args arg args = + { + context = arg.context@args.context; + (* Note that the binding context of [arg] MUST be placed before the one of + [args] in order to preserve possible type dependencies + *) + value = arg.value::args.value; + } + + +let ids_of_binder = function + | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] + | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] + +let rec change_vars_in_binder mapping = function + [] -> [] + | (bt,t)::l -> + let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in + (bt,change_vars mapping t):: + (if idmap_is_empty new_mapping + then l + else change_vars_in_binder new_mapping l + ) + +let rec replace_var_by_term_in_binder x_id term = function + | [] -> [] + | (bt,t)::l -> + (bt,replace_var_by_term x_id term t):: + if List.mem x_id (ids_of_binder bt) + then l + else replace_var_by_term_in_binder x_id term l + +let add_bt_names bt = List.append (ids_of_binder bt) + +let apply_args ctxt body args = + let need_convert_id avoid id = + List.exists (is_free_in id) args || List.mem id avoid + in + let need_convert avoid bt = + List.exists (need_convert_id avoid) (ids_of_binder bt) + in + let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = + match na with + | Name id when List.mem id avoid -> + let new_id = Namegen.next_ident_away id avoid in + Name new_id,Idmap.add id new_id mapping,new_id::avoid + | _ -> na,mapping,avoid + in + let next_bt_away bt (avoid:identifier list) = + match bt with + | LetIn na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + LetIn new_na,mapping,new_avoid + | Prod na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + Prod new_na,mapping,new_avoid + | Lambda na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + Lambda new_na,mapping,new_avoid + in + let rec do_apply avoid ctxt body args = + match ctxt,args with + | _,[] -> (* No more args *) + (ctxt,body) + | [],_ -> (* no more fun *) + let f,args' = 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' -> + let new_avoid,new_ctxt',new_body,new_id = + if need_convert_id avoid id + then + let new_avoid = id::avoid in + let new_id = Namegen.next_ident_away id new_avoid in + let new_avoid' = new_id :: new_avoid in + let mapping = Idmap.add id new_id Idmap.empty in + let new_ctxt' = change_vars_in_binder mapping ctxt' in + let new_body = change_vars mapping body in + new_avoid',new_ctxt',new_body,new_id + else + id::avoid,ctxt',body,id + in + let new_body = replace_var_by_term new_id arg new_body in + let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in + do_apply avoid new_ctxt' new_body args' + | (bt,t)::ctxt',_ -> + let new_avoid,new_ctxt',new_body,new_bt = + let new_avoid = add_bt_names bt avoid in + if need_convert avoid bt + then + let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in + ( + new_avoid, + change_vars_in_binder mapping ctxt', + change_vars mapping body, + new_bt + ) + else new_avoid,ctxt',body,bt + in + let new_ctxt',new_body = + do_apply new_avoid new_ctxt' new_body args + in + (new_bt,t)::new_ctxt',new_body + in + do_apply [] ctxt body args + + +let combine_app f args = + let new_ctxt,new_value = apply_args f.context f.value args.value in + { + (* Note that the binding context of [args] MUST be placed before the one of + the applied value in order to preserve possible type dependencies + *) + context = args.context@new_ctxt; + value = new_value; + } + +let combine_lam n t b = + { + context = []; + value = mkGLambda(n, compose_glob_context t.context t.value, + compose_glob_context b.context b.value ) + } + + + +let combine_prod n t b = + { context = t.context@((Prod n,t.value)::b.context); value = b.value} + +let combine_letin n t b = + { context = t.context@((LetIn n,t.value)::b.context); value = b.value} + + +let mk_result ctxt value avoid = + { + result = + [{context = ctxt; + value = value}] + ; + to_avoid = avoid + } +(************************************************* + Some functions to deal with overlapping patterns +**************************************************) + +let coq_True_ref = + lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") + +let coq_False_ref = + lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") + +(* + [make_discr_match_el \[e1,...en\]] builds match e1,...,en with + (the list of expresions on which we will do the matching) + *) +let make_discr_match_el = + List.map (fun e -> (e,(Anonymous,None))) + +(* + [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. + that is. + match ?????? with \\ + | pat_1 => False \\ + | pat_{i-1} => False \\ + | pat_i => True \\ + | pat_{i+1} => False \\ + \vdots + | pat_n => False + end +*) +let make_discr_match_brl i = + list_map_i + (fun j (_,idl,patl,_) -> + if j=i + then (dummy_loc,idl,patl, mkGRef (Lazy.force coq_True_ref)) + else (dummy_loc,idl,patl, mkGRef (Lazy.force coq_False_ref)) + ) + 0 +(* + [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff + brl_{i} is the first branch matched by [el] + + Used when we want to simulate the coq pattern matching algorithm +*) +let make_discr_match brl = + fun el i -> + mkGCases(None, + make_discr_match_el el, + make_discr_match_brl i brl) + +let pr_name = function + | Name id -> Ppconstr.pr_id id + | Anonymous -> str "_" + +(**********************************************************************) +(* functions used to build case expression from lettuple and if ones *) +(**********************************************************************) + +(* [build_constructors_of_type] construct the array of pattern of its inductive argument*) +let build_constructors_of_type ind' argl = + let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in + let npar = mib.Declarations.mind_nparams in + Array.mapi (fun i _ -> + let construct = ind',i+1 in + let constructref = ConstructRef(construct) in + let _implicit_positions_of_cst = + Impargs.implicits_of_global constructref + in + let cst_narg = + Inductiveops.mis_constructor_nargs_env + (Global.env ()) + construct + in + let argl = + if argl = [] + then + Array.to_list + (Array.init (cst_narg - npar) (fun _ -> mkGHole ()) + ) + else argl + in + let pat_as_term = + mkGApp(mkGRef (ConstructRef(ind',i+1)),argl) + in + 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,_ = glob_decompose_app b in + match f with + | GRef(_,ref) -> + begin + let ind_type = + match ref with + | VarRef _ | ConstRef _ -> + let constr_of_ref = constr_of_global ref in + let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in + let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in + let ret_type,_ = decompose_app ret_type in + if not (isInd ret_type) then + begin +(* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *) + raise (Invalid_argument "not an inductive") + end; + destInd ret_type + | IndRef ind -> ind + | ConstructRef c -> fst c + in + let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in + if not (Array.length ind_type_info.Declarations.mind_consnames = nb ) + then raise (Invalid_argument "find_type_of : not a valid inductive"); + ind_type + end + | 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") + + + + +(******************) +(* Main functions *) +(******************) + + + +let raw_push_named (na,raw_value,raw_typ) env = + match na with + | Anonymous -> env + | Name id -> + let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in + let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in + Environ.push_named (id,value,typ) env + + +let add_pat_variables pat typ env : Environ.env = + let rec add_pat_variables env pat typ : Environ.env = + observe (str "new rel env := " ++ Printer.pr_rel_context_of env); + + match pat with + | PatVar(_,na) -> Environ.push_rel (na,None,typ) env + | PatCstr(_,c,patl,na) -> + let Inductiveops.IndType(indf,indargs) = + try Inductiveops.find_rectype env Evd.empty typ + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + in + let new_env = add_pat_variables env pat typ in + let res = + fst ( + Sign.fold_rel_context + (fun (na,v,t) (env,ctxt) -> + match na with + | Anonymous -> assert false + | Name id -> + let new_t = substl ctxt t in + let new_v = Option.map (substl ctxt) v in + observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ + str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ + str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ + Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ + Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) + ); + (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt) + ) + (Environ.rel_context new_env) + ~init:(env,[]) + ) + in + observe (str "new var env := " ++ Printer.pr_named_context_of res); + res + + + + +let rec pattern_to_term_and_type env typ = function + | PatVar(loc,Anonymous) -> assert false + | PatVar(loc,Name id) -> + mkGVar id + | PatCstr(loc,constr,patternl,_) -> + let cst_narg = + Inductiveops.mis_constructor_nargs_env + (Global.env ()) + constr + in + let Inductiveops.IndType(indf,indargs) = + try Inductiveops.find_rectype env Evd.empty typ + with Not_found -> assert false + in + let constructors = Inductiveops.get_constructors env indf in + let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + let _,cstl = Inductiveops.dest_ind_family indf in + let csta = Array.of_list cstl in + let implicit_args = + Array.to_list + (Array.init + (cst_narg - List.length patternl) + (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i)) + ) + in + let patl_as_term = + List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl + in + mkGApp(mkGRef(ConstructRef constr), + implicit_args@patl_as_term + ) + +(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) + of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the + corresponding graphs. + + + The idea to transform a term [t] into a list of constructors [lc] is the following: + \begin{itemize} + \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding + to [body] and add (bind x. _) to each elements of [lc] + \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) + then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], + [g c1 ... cn] is an element of [lc] + \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then + compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn] + create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc] + \item if the term is a cast just treat its body part + \item + if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case + and concatenate them (informally, each branch of a match produces a new constructor) + \end{itemize} + + WARNING: The terms constructed here are only USING the 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. + We in fact not create a constructor list since then end of each constructor has not the expected form + but only the value of the function +*) + + +let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = + observe (str " Entering : " ++ Printer.pr_glob_constr rt); + match rt with + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> + (* do nothing (except changing type of course) *) + mk_result [] rt avoid + | 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 + combine_results combine_args arg_res ctxt_argsl + ) + args + (mk_result [] [] avoid) + in + begin + match f with + | GLambda _ -> + let rec aux t l = + match l with + | [] -> t + | u::l -> + match t with + | GLambda(loc,na,_,nat,b) -> + GLetIn(dummy_loc,na,u,aux b l) + | _ -> + GApp(dummy_loc,t,l) + in + build_entry_lc env funnames avoid (aux f args) + | 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 + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". + The "value" of this branch is then simply [res] + *) + let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in + let rt_typ = Typing.type_of env Evd.empty rt_as_constr in + let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in + let res = fresh_id args_res.to_avoid "res" in + let new_avoid = res::args_res.to_avoid in + let res_rt = mkGVar res in + let new_result = + List.map + (fun arg_res -> + let new_hyps = + [Prod (Name res),res_raw_type; + 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 } + | 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 + [ctxt, g v1 .... vn] + *) + { + args_res with + result = + List.map + (fun args_res -> + {args_res with value = mkGApp(f,args_res.value)}) + args_res.result + } + | 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 + *) + let new_n,new_b,new_avoid = + match n with + | Name id when List.exists (is_free_in id) args -> + (* need to alpha-convert the name *) + let new_id = Namegen.next_ident_away id avoid in + let new_avoid = id:: avoid in + let new_b = + replace_var_by_term + id + (GVar(dummy_loc,id)) + b + in + (Name new_id,new_b,new_avoid) + | _ -> n,b,avoid + in + build_entry_lc + env + funnames + avoid + (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 + | 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 (mkGApp(b,args)) + | GRec _ -> error "Not handled GRec" + | GProd _ -> error "Cannot apply a type" + end (* end of the application treatement *) + + | 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 + and combine the two result + *) + let t_res = build_entry_lc env funnames avoid t in + let new_n = + match n with + | Name _ -> n + | Anonymous -> Name (Indfun_common.fresh_id [] "_x") + in + let new_env = raw_push_named (new_n,None,t) env in + let b_res = build_entry_lc new_env funnames avoid b in + combine_results (combine_lam new_n) t_res b_res + | 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 + and combine the two result + *) + let t_res = build_entry_lc env funnames avoid t in + let new_env = raw_push_named (n,None,t) env in + let b_res = build_entry_lc new_env funnames avoid b in + combine_results (combine_prod n) t_res b_res + | 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] + and combine the two result + *) + let v_res = build_entry_lc env funnames avoid v in + let v_as_constr = Pretyping.Default.understand Evd.empty env v in + let v_type = Typing.type_of env Evd.empty v_as_constr in + let new_env = + match n with + Anonymous -> env + | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env + in + let b_res = build_entry_lc new_env funnames avoid b in + combine_results (combine_letin n) v_res b_res + | 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 + | 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_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 + assert (Array.length case_pats = 2); + let brl = + list_map_i + (fun i x -> (dummy_loc,[],[case_pats.(i)],x)) + 0 + [lhs;rhs] + in + let match_expr = + mkGCases(None,[(b,(Anonymous,None))],brl) + in + (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *) + build_entry_lc env funnames avoid match_expr + | GLetTuple(_,nal,_,b,e) -> + begin + let nal_as_glob_constr = + List.map + (function + Name id -> mkGVar id + | Anonymous -> mkGHole () + ) + nal + in + let b_as_constr = Pretyping.Default.understand Evd.empty env b in + let b_typ = Typing.type_of env Evd.empty b_as_constr in + let (ind,_) = + try Inductiveops.find_inductive env Evd.empty b_typ + with Not_found -> + errorlabstrm "" (str "Cannot find the inductive associated to " ++ + Printer.pr_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_glob_constr in + assert (Array.length case_pats = 1); + let br = + (dummy_loc,[],[case_pats.(0)],e) + in + let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in + build_entry_lc env funnames avoid match_expr + + end + | GRec _ -> error "Not handled GRec" + | GCast(_,b,_) -> + build_entry_lc env funnames avoid b +and build_entry_lc_from_case env funname make_discr + (el:tomatch_tuples) + (brl:Glob_term.cases_clauses) avoid : + glob_constr build_entry_return = + match el with + | [] -> assert false (* this case correspond to match with .... !*) + | el -> + (* this case correspond to + match el with brl end + we first compute the list of lists corresponding to [el] and + combine them . + Then for each elemeent of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list + *) + let case_resl = + List.fold_right + (fun (case_arg,_) ctxt_argsl -> + let arg_res = build_entry_lc env funname avoid case_arg in + combine_results combine_args arg_res ctxt_argsl + ) + el + (mk_result [] [] avoid) + in + let types = + List.map (fun (case_arg,_) -> + let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in + Typing.type_of env Evd.empty case_arg_as_constr + ) el + in + (****** The next works only if the match is not dependent ****) + let results = + List.map + (fun ca -> + let res = build_entry_lc_from_case_term + env types + funname (make_discr) + [] brl + case_resl.to_avoid + ca + in + res + ) + case_resl.result + in + { + result = List.concat (List.map (fun r -> r.result) results); + to_avoid = + List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results + } + +and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid + matched_expr = + match brl with + | [] -> (* computed_branches *) {result = [];to_avoid = avoid} + | br::brl' -> + (* alpha convertion to prevent name clashes *) + let _,idl,patl,return = alpha_br avoid br in + let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *) + (* building a list of precondition stating that we are not in this branch + (will be used in the following recursive calls) + *) + let new_env = List.fold_right2 add_pat_variables patl types env in + let not_those_patterns : (identifier list -> glob_constr -> glob_constr) list = + List.map2 + (fun pat typ -> + fun avoid pat'_as_term -> + let renamed_pat,_,_ = alpha_pat avoid pat in + let pat_ids = get_pattern_id renamed_pat in + let env_with_pat_ids = add_pat_variables pat typ new_env in + List.fold_right + (fun id acc -> + let typ_of_id = + Typing.type_of env_with_pat_ids Evd.empty (mkVar id) + in + let raw_typ_of_id = + Detyping.detype false [] + (Termops.names_of_rel_context env_with_pat_ids) typ_of_id + in + mkGProd (Name id,raw_typ_of_id,acc)) + pat_ids + (glob_make_neq pat'_as_term (pattern_to_term renamed_pat)) + ) + patl + types + in + (* Checking if we can be in this branch + (will be used in the following recursive calls) + *) + let unify_with_those_patterns : (cases_pattern -> bool*bool) list = + List.map + (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') + patl + in + (* + we first compute the other branch result (in ordrer to keep the order of the matching + as much as possible) + *) + let brl'_res = + build_entry_lc_from_case_term + env + types + funname + make_discr + ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) + brl' + avoid + matched_expr + in + (* We now create the precondition of this branch i.e. + 1- the list of variable appearing in the different patterns of this branch and + the list of equation stating than el = patl (List.flatten ...) + 2- If there exists a previous branch which pattern unify with the one of this branch + then a discrimination precond stating that we are not in a previous branch (if List.exists ...) + *) + let those_pattern_preconds = + (List.flatten + ( + list_map3 + (fun pat e typ_as_constr -> + let this_pat_ids = ids_of_pat pat in + let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in + let pat_as_term = pattern_to_term pat in + List.fold_right + (fun id acc -> + if Idset.mem id this_pat_ids + then (Prod (Name id), + let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in + let raw_typ_of_id = + Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id + in + raw_typ_of_id + )::acc + else acc + ) + idl + [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)] + ) + patl + matched_expr.value + types + ) + ) + @ + (if List.exists (function (unifl,_) -> + let (unif,_) = + List.split (List.map2 (fun x y -> x y) unifl patl) + in + List.for_all (fun x -> x) unif) patterns_to_prevent + then + let i = List.length patterns_to_prevent in + let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in + [(Prod Anonymous,make_discr pats_as_constr i )] + else + [] + ) + in + (* We compute the result of the value returned by the branch*) + let return_res = build_entry_lc new_env funname new_avoid return in + (* and combine it with the preconds computed for this branch *) + let this_branch_res = + List.map + (fun res -> + { context = matched_expr.context@those_pattern_preconds@res.context ; + value = res.value} + ) + return_res.result + in + { brl'_res with result = this_branch_res@brl'_res.result } + + +let is_res id = + try + String.sub (string_of_id id) 0 3 = "res" + with Invalid_argument _ -> false + + + +let same_raw_term rt1 rt2 = + match rt1,rt2 with + | 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_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 + let slrhs = List.length lrhs in + if same_raw_term lhd rhd && sllhs = slrhs + then + (* let _ = assert false in *) + List.fold_right2 decompose_raw_eq llhs lrhs acc + else (lhs,rhs)::acc + in + decompose_raw_eq lhs rhs [] + + +exception Continue +(* + The second phase which reconstruct the real type of the constructor. + 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_glob_constr rt); + + match rt with + | 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 + | GApp(_,(GVar(_,res_id) as res_rt),args') when is_res res_id -> + begin + match args' with + | (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 = + 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 + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + args new_crossed_types + (depth + 1) b + in + 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 + | 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_glob_constr rt); + let t' = + try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue + in + let is_in_b = is_free_in id b in + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = List.map (replace_var_by_term id rt) args in + let subst_b = + if is_in_b then b else replace_var_by_term id rt b + in + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = + rebuild_cons + new_env + nb_args relname + new_args new_crossed_types + (depth + 1) subst_b + in + 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 + let ind,args' = Inductive.find_inductive env ty' in + let mib,_ = Global.lookup_inductive ind in + let nparam = mib.Declarations.mind_nparams in + let params,arg' = + ((Util.list_chop nparam args')) + in + let rt_typ = + 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) + (mkGHole ())))) + in + let eq' = + GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt]) + in + 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 = + match kind_of_term eq'_as_constr with + | App(_,[|_;_;ty;_|]) -> + let ty = Array.to_list (snd (destApp ty)) in + let ty' = snd (Util.list_chop nparam ty) in + List.fold_left2 + (fun acc var_as_constr arg -> + if isRel var_as_constr + then + let (na,_,_) = + Environ.lookup_rel (destRel var_as_constr) env + in + match na with + | Anonymous -> acc + | Name id' -> + (id',Detyping.detype false [] + (Termops.names_of_rel_context env) + arg)::acc + else if isVar var_as_constr + then (destVar var_as_constr,Detyping.detype false [] + (Termops.names_of_rel_context env) + arg)::acc + else acc + ) + [] + arg' + ty' + | _ -> assert false + in + let is_in_b = is_free_in id b in + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = + List.fold_left + (fun args (id,rt) -> + List.map (replace_var_by_term id rt) args + ) + args + ((id,rt)::new_args) + in + let subst_b = + if is_in_b then b else replace_var_by_term id rt b + in + let new_env = + let t' = Pretyping.Default.understand Evd.empty env eq' in + Environ.push_rel (n,None,t') env + in + let new_b,id_to_exclude = + rebuild_cons + new_env + nb_args relname + new_args new_crossed_types + (depth + 1) subst_b + in + 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 + mkGProd(n,t,new_b),id_to_exclude + else new_b, Idset.add id id_to_exclude + *) + | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2]) + when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous + -> + begin + try + let l = decompose_raw_eq rt1 rt2 in + if List.length l > 1 + then + let new_rt = + List.fold_left + (fun acc (lhs,rhs) -> + mkGProd(Anonymous, + mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc) + ) + b + l + in + 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_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 = + rebuild_cons new_env + nb_args relname + args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> + new_b,Idset.remove id + (Idset.filter not_free_in_t id_to_exclude) + | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + end + | _ -> + 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 = + rebuild_cons new_env + nb_args relname + args new_crossed_types + (depth + 1) b + in + match n with + | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> + new_b,Idset.remove id + (Idset.filter not_free_in_t id_to_exclude) + | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude + end + | 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_glob_constr rt); + let t' = Pretyping.Default.understand Evd.empty env t in + match n with + | Name id -> + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + (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 + 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 + | 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 + let type_t' = Typing.type_of env Evd.empty t' in + let new_env = Environ.push_rel (n,Some t',type_t') env in + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + args (t::crossed_types) + (depth + 1 ) b in + match n with + | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> + new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) + | _ -> GLetIn(dummy_loc,n,t,new_b), + Idset.filter not_free_in_t id_to_exclude + end + | GLetTuple(_,nal,(na,rto),t,b) -> + assert (rto=None); + begin + let not_free_in_t id = not (is_free_in id t) in + let new_t,id_to_exclude' = + rebuild_cons env + nb_args + relname + args (crossed_types) + depth t + in + let t' = Pretyping.Default.understand Evd.empty env new_t in + let new_env = Environ.push_rel (na,None,t') env in + let new_b,id_to_exclude = + rebuild_cons new_env + nb_args relname + args (t::crossed_types) + (depth + 1) b + in +(* match n with *) +(* | Name id when Idset.mem id id_to_exclude -> *) +(* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *) +(* | _ -> *) + GLetTuple(dummy_loc,nal,(na,None),t,new_b), + Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude') + + end + + | _ -> mkGApp(mkGVar relname,args@[rt]),Idset.empty + + +(* debuging wrapper *) +let rebuild_cons env nb_args relname args crossed_types rt = +(* 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_glob_constr (fst res)); *) + res + + +(* naive implementation of parameter detection. + + A parameter is an argument which is only preceded by parameters and whose + calls are all syntaxically equal. + + TODO: Find a valid way to deal with implicit arguments here! +*) +let rec compute_cst_params relnames params = function + | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params + | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames -> + compute_cst_params_from_app [] (params,rtl) + | GApp(_,f,args) -> + List.fold_left (compute_cst_params relnames) params (f::args) + | 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 + | GCases _ -> + params (* If there is still cases at this point they can only be + discriminitation ones *) + | 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',(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 * Glob_term.glob_constr * bool) list array) csts = + let rels_params = + Array.mapi + (fun i args -> + List.fold_left + (fun params (_,cst) -> compute_cst_params relnames params cst) + args + csts.(i) + ) + args + in + let l = ref [] in + let _ = + try + list_iter_i + (fun i ((n,nt,is_defined) as param) -> + if array_for_all + (fun l -> + let (n',nt',is_defined') = List.nth l i in + n = n' && Topconstr.eq_glob_constr nt nt' && is_defined = is_defined') + rels_params + then + l := param::!l + ) + rels_params.(0) + with _ -> + () + in + List.rev !l + +let rec rebuild_return_type rt = + match rt with + | Topconstr.CProdN(loc,n,t') -> + Topconstr.CProdN(loc,n,rebuild_return_type t') + | Topconstr.CArrow(loc,t,t') -> + Topconstr.CArrow(loc,t,rebuild_return_type t') + | Topconstr.CLetIn(loc,na,t,t') -> + Topconstr.CLetIn(loc,na,t,rebuild_return_type t') + | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,GType None)) + + +let do_build_inductive + funnames (funsargs: (Names.name * glob_constr * bool) list list) + returned_types + (rtl:glob_constr list) = + let _time1 = System.get_time () in +(* 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 + let returned_types = Array.of_list returned_types in + (* alpha_renaming of the body to prevent variable capture during manipulation *) + let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in + let rta = Array.of_list rtl_alpha in + (*i The next call to mk_rel_id is valid since we are constructing the graph + Ensures by: obvious + i*) + let relnames = Array.map mk_rel_id funnames in + let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in + (* Construction of the pseudo constructors *) + let env = + Array.fold_right + (fun id env -> + Environ.push_named (id,None,Typing.type_of env Evd.empty (Constrintern.global_reference id)) env + ) + funnames + (Global.env ()) + in + 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 * 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_glob_constr Idset.empty t, + acc) + else + Topconstr.CProdN + (dummy_loc, + [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], + acc + ) + ) + rel_first_args + (rebuild_return_type returned_types.(i)) + in + (* We need to lift back our work topconstr but only with all information + We mimick a Set Printing All. + Then save the graphs and reset Printing options to their primitive values + *) + let rel_arities = Array.mapi rel_arity funsargs in + Util.array_fold_left2 (fun env rel_name rel_ar -> + Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities + in + (* and of the real constructors*) + let constr i res = + List.map + (function result (* (args',concl') *) -> + 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 "glob constr " ++ pr_glob_constr rt)) rt; *) + fst ( + rebuild_cons env_with_graphs nb_args relnames.(i) + [] + [] + rt + ) + ) + res.result + in + (* adding names to constructors *) + let next_constructor_id = ref (-1) in + let mk_constructor_id i = + incr next_constructor_id; + (*i The next call to mk_rel_id is valid since we are constructing the graph + Ensures by: obvious + i*) + id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) + in + let rel_constructors i rt : (identifier*glob_constr) list = + next_constructor_id := (-1); + List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) + in + let rel_constructors = Array.mapi rel_constructors resa in + (* Computing the set of parameters if asked *) + let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in + let nrel_params = List.length rels_params in + let rel_constructors = (* Taking into account the parameters in constructors *) + Array.map (List.map + (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) + rel_constructors + in + let rel_arity i funargs = (* Reduilding arities (with parameters) *) + let rel_first_args :(Names.name * 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_glob_constr Idset.empty t, + acc) + else + Topconstr.CProdN + (dummy_loc, + [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t], + acc + ) + ) + rel_first_args + (rebuild_return_type returned_types.(i)) + in + (* We need to lift back our work topconstr but only with all information + We mimick a Set Printing All. + Then save the graphs and reset Printing options to their primitive values + *) + let rel_arities = Array.mapi rel_arity funsargs in + let rel_params = + List.map + (fun (n,t,is_defined) -> + if is_defined + then + Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_glob_constr Idset.empty t) + else + Topconstr.LocalRawAssum + ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t) + ) + rels_params + in + let ext_rels_constructors = + Array.map (List.map + (fun (id,t) -> + false,((dummy_loc,id), + Flags.with_option + Flags.raw_print + (Constrextern.extern_glob_type Idset.empty) ((* zeta_normalize *) t) + ) + )) + (rel_constructors) + in + let rel_ind i ext_rel_constructors = + ((dummy_loc,relnames.(i)), + rel_params, + Some rel_arities.(i), + ext_rel_constructors),[] + in + let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in + let rel_inds = Array.to_list ext_rel_constructors in +(* let _ = *) +(* Pp.msgnl (\* observe *\) ( *) +(* str "Inductive" ++ spc () ++ *) +(* prlist_with_sep *) +(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) +(* (function ((_,id),_,params,ar,constr) -> *) +(* Ppconstr.pr_id id ++ spc () ++ *) +(* Ppconstr.pr_binders params ++ spc () ++ *) +(* str ":" ++ spc () ++ *) +(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) +(* prlist_with_sep *) +(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) +(* (function (_,((_,id),t)) -> *) +(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) +(* Ppconstr.pr_lconstr_expr t) *) +(* constr *) +(* ) *) +(* rel_inds *) +(* ) *) +(* in *) + let _time2 = System.get_time () in + try + with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true + with + | UserError(s,msg) as e -> + let _time3 = System.get_time () in +(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + rel_inds + in + let msg = + str "while trying to define"++ spc () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + ++ fnl () ++ + msg + in + observe (msg); + raise e + | e -> + let _time3 = System.get_time () in +(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) + let repacked_rel_inds = + List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) + rel_inds + in + let msg = + str "while trying to define"++ spc () ++ + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + ++ fnl () ++ + Errors.print e + in + observe msg; + raise e + + + +let build_inductive funnames funsargs returned_types rtl = + try + do_build_inductive funnames funsargs returned_types rtl + with e -> raise (Building_graph e) + + diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli new file mode 100644 index 00000000..5c91292b --- /dev/null +++ b/plugins/funind/glob_term_to_relation.mli @@ -0,0 +1,16 @@ + + + +(* + [build_inductive parametrize funnames funargs returned_types bodies] + constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments + and returning [returned_types] using bodies [bodies] +*) + +val build_inductive : + Names.identifier list -> (* The list of function name *) + (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *) + Topconstr.constr_expr list -> (* The list of function returned type *) + Glob_term.glob_constr list -> (* the list of body *) + unit + diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml new file mode 100644 index 00000000..cdd0eaf7 --- /dev/null +++ b/plugins/funind/glob_termops.ml @@ -0,0 +1,712 @@ +open Pp +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 glob_constr + In each of them the location is Util.dummy_loc +*) +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 glob_constrs + These are analogous to the ones constrs +*) +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 + 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 + glob_decompose_prod [] + +let glob_compose_prod = + List.fold_left (fun b (n,t) -> mkGProd(n,t,b)) + +let glob_compose_prod_or_letin = + List.fold_left ( + fun concl decl -> + match decl with + | (n,None,Some t) -> mkGProd(n,t,concl) + | (n,Some bdy,None) -> mkGLetIn(n,bdy,concl) + | _ -> assert false) + +let glob_decompose_prod_n n = + let rec glob_decompose_prod i args c = + if i<=0 then args,c + else + match c with + | GProd(_,n,_,t,b) -> + glob_decompose_prod (i-1) ((n,t)::args) b + | rt -> args,rt + in + glob_decompose_prod n [] + + +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 + | 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 + glob_decompose_prod n [] + + +let glob_decompose_app = + let rec decompose_rapp acc rt = +(* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *) + match rt with + | GApp(_,rt,rtl) -> + decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt + | rt -> rt,List.rev acc + in + decompose_rapp [] + + + + +(* [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]) + +(* [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]) + +(* [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]) + +(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding + to [P1 \/ ( .... \/ Pn)] +*) +let rec glob_make_or_list = function + | [] -> raise (Invalid_argument "mk_or") + | [e] -> e + | e::l -> glob_make_or e (glob_make_or_list l) + + +let remove_name_from_mapping mapping na = + match na with + | Anonymous -> mapping + | Name id -> Idmap.remove id mapping + +let change_vars = + let rec change_vars mapping rt = + match rt with + | GRef _ -> rt + | GVar(loc,id) -> + let new_id = + try + Idmap.find id mapping + with Not_found -> id + in + GVar(loc,new_id) + | GEvar _ -> rt + | GPatVar _ -> rt + | GApp(loc,rt',rtl) -> + GApp(loc, + change_vars mapping rt', + List.map (change_vars mapping) rtl + ) + | GLambda(loc,name,k,t,b) -> + GLambda(loc, + name, + k, + change_vars mapping t, + change_vars (remove_name_from_mapping mapping name) b + ) + | GProd(loc,name,k,t,b) -> + GProd(loc, + name, + k, + change_vars mapping t, + change_vars (remove_name_from_mapping mapping name) b + ) + | GLetIn(loc,name,def,b) -> + GLetIn(loc, + name, + change_vars mapping def, + change_vars (remove_name_from_mapping mapping name) b + ) + | GLetTuple(loc,nal,(na,rto),b,e) -> + let new_mapping = List.fold_left remove_name_from_mapping mapping nal in + GLetTuple(loc, + nal, + (na, Option.map (change_vars mapping) rto), + change_vars mapping b, + change_vars new_mapping e + ) + | 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 + ) + | 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 + ) + | 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 + then br + else (loc,idl,patl,change_vars new_mapping res) + in + change_vars + + + +let rec alpha_pat excluded pat = + match pat with + | PatVar(loc,Anonymous) -> + let new_id = Indfun_common.fresh_id excluded "_x" in + PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty + | PatVar(loc,Name id) -> + if List.mem id excluded + then + let new_id = Namegen.next_ident_away id excluded in + PatVar(loc,Name new_id),(new_id::excluded), + (Idmap.add id new_id Idmap.empty) + else pat,excluded,Idmap.empty + | PatCstr(loc,constr,patl,na) -> + let new_na,new_excluded,map = + match na with + | Name id when List.mem id excluded -> + let new_id = Namegen.next_ident_away id excluded in + Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty + | _ -> na,excluded,Idmap.empty + in + let new_patl,new_excluded,new_map = + List.fold_left + (fun (patl,excluded,map) pat -> + let new_pat,new_excluded,new_map = alpha_pat excluded pat in + (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map) + ) + ([],new_excluded,map) + patl + in + PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map + +let alpha_patl excluded patl = + let patl,new_excluded,map = + List.fold_left + (fun (patl,excluded,map) pat -> + let new_pat,new_excluded,new_map = alpha_pat excluded pat in + new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map) + ) + ([],excluded,Idmap.empty) + patl + in + (List.rev patl,new_excluded,map) + + + + +let raw_get_pattern_id pat acc = + let rec get_pattern_id pat = + match pat with + | PatVar(loc,Anonymous) -> assert false + | PatVar(loc,Name id) -> + [id] + | PatCstr(loc,constr,patternl,_) -> + List.fold_right + (fun pat idl -> + let idl' = get_pattern_id pat in + idl'@idl + ) + patternl + [] + in + (get_pattern_id pat)@acc + +let get_pattern_id pat = raw_get_pattern_id pat [] + +let rec alpha_rt excluded rt = + let new_rt = + match rt with + | 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 + 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 + 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 + 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 + then t,b + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in + (t,replace b) + in + let new_excluded = new_id::excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + 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 = + if new_id = id + then t,b + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in + (t,replace b) + in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + 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 + then t,b + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in + (t,replace b) + in + let new_excluded = new_id::excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in + GLetIn(loc,Name new_id,new_t,new_b) + + + | GLetTuple(loc,nal,(na,rto),t,b) -> + let rev_new_nal,new_excluded,mapping = + List.fold_left + (fun (nal,excluded,mapping) na -> + match na with + | Anonymous -> (na::nal,excluded,mapping) + | Name id -> + let new_id = Namegen.next_ident_away id excluded in + if new_id = id + then + na::nal,id::excluded,mapping + else + (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) + ) + ([],excluded,Idmap.empty) + nal + in + let new_nal = List.rev rev_new_nal in + let new_rto,new_t,new_b = + if idmap_is_empty mapping + then rto,t,b + else let replace = change_vars mapping in + (Option.map replace rto, t,replace b) + in + let new_t = alpha_rt new_excluded new_t in + let new_b = alpha_rt new_excluded new_b in + let new_rto = Option.map (alpha_rt new_excluded) new_rto in + 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 + 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 + ) + | 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 + ) + in + new_rt + +and alpha_br excluded (loc,ids,patl,res) = + let new_patl,new_excluded,mapping = alpha_patl excluded patl in + let new_ids = List.fold_right raw_get_pattern_id new_patl [] in + let new_excluded = new_ids@excluded in + let renamed_res = change_vars mapping res in + let new_res = alpha_rt new_excluded renamed_res in + (loc,new_ids,new_patl,new_res) + +(* + [is_free_in id rt] checks if [id] is a free variable in [rt] +*) +let is_free_in id = + let rec is_free_in = function + | 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) + | GCases(_,_,_,el,brl) -> + (List.exists (fun (e,_) -> is_free_in e) el) || + List.exists is_free_in_br brl + | 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) + + | GIf(_,cond,_,br1,br2) -> + is_free_in cond || is_free_in br1 || is_free_in br2 + | 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 + is_free_in + + + +let rec pattern_to_term = function + | PatVar(loc,Anonymous) -> assert false + | PatVar(loc,Name id) -> + mkGVar id + | PatCstr(loc,constr,patternl,_) -> + let cst_narg = + Inductiveops.mis_constructor_nargs_env + (Global.env ()) + constr + in + let implicit_args = + Array.to_list + (Array.init + (cst_narg - List.length patternl) + (fun _ -> mkGHole ()) + ) + in + let patl_as_term = + List.map pattern_to_term patternl + in + mkGApp(mkGRef(Libnames.ConstructRef constr), + implicit_args@patl_as_term + ) + + + +let replace_var_by_term x_id term = + let rec replace_var_by_pattern rt = + match rt with + | 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 + ) + | 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 + ) + | 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 + ) + | 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 + ) + | GLetTuple(_,nal,_,_,_) + when List.exists (function Name id -> id = x_id | _ -> false) nal -> + rt + | 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 + ) + | 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 + ) + | 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 + ) + | 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 + else (loc,idl,patl,replace_var_by_pattern res) + in + replace_var_by_pattern + + + + +(* checking unifiability of patterns *) +exception NotUnifiable + +let rec are_unifiable_aux = function + | [] -> () + | eq::eqs -> + match eq with + | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs + | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + if constructor2 <> constructor1 + then raise NotUnifiable + else + let eqs' = + try ((List.combine cpl1 cpl2)@eqs) + with _ -> anomaly "are_unifiable_aux" + in + are_unifiable_aux eqs' + +let are_unifiable pat1 pat2 = + try + are_unifiable_aux [pat1,pat2]; + true + with NotUnifiable -> false + + +let rec eq_cases_pattern_aux = function + | [] -> () + | eq::eqs -> + match eq with + | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + if constructor2 <> constructor1 + then raise NotUnifiable + else + let eqs' = + try ((List.combine cpl1 cpl2)@eqs) + with _ -> anomaly "eq_cases_pattern_aux" + in + eq_cases_pattern_aux eqs' + | _ -> raise NotUnifiable + +let eq_cases_pattern pat1 pat2 = + try + eq_cases_pattern_aux [pat1,pat2]; + true + with NotUnifiable -> false + + + +let ids_of_pat = + let rec ids_of_pat ids = function + | PatVar(_,Anonymous) -> ids + | PatVar(_,Name id) -> Idset.add id ids + | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl + in + ids_of_pat Idset.empty + +let id_of_name = function + | Names.Anonymous -> id_of_string "x" + | Names.Name x -> x + +(* TODO: finish Rec caes *) +let ids_of_glob_constr c = + let rec ids_of_glob_constr acc c = + let idof = id_of_name in + match c with + | 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_glob_constr [] c) + + + + + +let zeta_normalize = + let rec zeta_normalize_term rt = + match rt with + | GRef _ -> rt + | GVar _ -> rt + | GEvar _ -> rt + | GPatVar _ -> rt + | GApp(loc,rt',rtl) -> + GApp(loc, + zeta_normalize_term rt', + List.map zeta_normalize_term rtl + ) + | GLambda(loc,name,k,t,b) -> + GLambda(loc, + name, + k, + zeta_normalize_term t, + zeta_normalize_term b + ) + | GProd(loc,name,k,t,b) -> + GProd(loc, + name, + k, + zeta_normalize_term t, + zeta_normalize_term b + ) + | GLetIn(_,Name id,def,b) -> + zeta_normalize_term (replace_var_by_term id def b) + | 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 + ) + | 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 + ) + | 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 + ) + | 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 + zeta_normalize_term + + + + +let expand_as = + + let rec add_as map pat = + match pat with + | PatVar _ -> map + | PatCstr(_,_,patl,Name id) -> + Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) + | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl + in + let rec expand_as map rt = + match rt with + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> rt + | GVar(_,id) -> + begin + try + Idmap.find id map + with Not_found -> rt + end + | 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) + | 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) + | 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) + in + expand_as Idmap.empty 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..8caeca57 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,7 +75,7 @@ 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 = @@ -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,56 +125,43 @@ 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 ) @@ -189,34 +172,31 @@ let build_newrecursive 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 -> + 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 ()) + (str "Cannot build inversion information" ++ + if do_observe () then (fnl() ++ Errors.print e') else mt ()) with _ -> () 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!") @@ -366,21 +349,18 @@ let generate_principle on_error with 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 @@ -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..dd475315 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -76,8 +76,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 +90,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,9 +120,9 @@ 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) + (try (match Declarations.body_of_constant (Global.lookup_constant sp) with + | Some c -> Declarations.force c + | _ -> assert false) with _ -> assert false) |_ -> assert false @@ -158,6 +158,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 +181,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 @@ -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); 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..0b04a572 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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,12 +59,13 @@ 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 = begin try (Printer.pr_goal g) with _ -> assert false end in try let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v with e -> + let e' = Cerrors.process_vernac_interp_error e 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;; @@ -84,7 +84,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 +248,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 +313,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 +395,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 +424,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 +434,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 +526,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 +547,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,7 +563,7 @@ 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 ] @@ -636,7 +636,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 +686,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 +733,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 @@ -763,7 +763,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 +784,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 = @@ -806,7 +806,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g 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))) + correctness_lemma = Some (destConst (Constrintern.global_reference (mk_correct_id f_id))) } ) @@ -818,7 +818,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 @@ -858,7 +858,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g 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))) + completeness_lemma = Some (destConst (Constrintern.global_reference (mk_complete_id f_id))) } ) funs; @@ -955,7 +955,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..4eedf8dc 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Pervasives.compare x f = 0 + | GVar (_,x) -> Pervasives.compare x f = 0 | _ -> false (** [ident_global_exist id] returns true if identifier [id] is linked @@ -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,10 +792,10 @@ 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)) + try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) with _ -> [] in let params2 = - try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) + try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) with _ -> [] in let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 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/rawterm_to_relation.ml b/plugins/funind/rawterm_to_relation.ml deleted file mode 100644 index b74422a3..00000000 --- a/plugins/funind/rawterm_to_relation.ml +++ /dev/null @@ -1,1480 +0,0 @@ -open Printer -open Pp -open Names -open Term -open Rawterm -open Libnames -open Indfun_common -open Util -open Rawtermops - -let observe strm = - if do_observe () - then Pp.msgnl strm - else () -let observennl strm = - if do_observe () - then Pp.msg strm - else () - - -type binder_type = - | Lambda of name - | Prod of name - | LetIn of name - -type raw_context = (binder_type*rawconstr) list - -(* - compose_raw_context [(bt_1,n_1,t_1);......] rt returns - b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the - binders corresponding to the bt_i's -*) -let compose_raw_context = - let compose_binder (bt,t) acc = - match bt with - | Lambda n -> mkRLambda(n,t,acc) - | Prod n -> mkRProd(n,t,acc) - | LetIn n -> mkRLetIn(n,t,acc) - in - List.fold_right compose_binder - - -(* - The main part deals with building a list of raw constructor expressions - from the rhs of a fixpoint equation. -*) - -type 'a build_entry_pre_return = - { - context : raw_context; (* the binding context of the result *) - value : 'a; (* The value *) - } - -type 'a build_entry_return = - { - result : 'a build_entry_pre_return list; - to_avoid : identifier list - } - -(* - [combine_results combine_fun res1 res2] combine two results [res1] and [res2] - w.r.t. [combine_fun]. - - Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] - and [res2_1,....] and we need to produce - [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........] -*) - -let combine_results - (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> - 'c build_entry_pre_return - ) - (res1: 'a build_entry_return) - (res2 : 'b build_entry_return) - : 'c build_entry_return - = - let pre_result = List.map - ( fun res1 -> (* for each result in arg_res *) - List.map (* we add it in each args_res *) - (fun res2 -> - combine_fun res1 res2 - ) - res2.result - ) - res1.result - in (* and then we flatten the map *) - { - result = List.concat pre_result; - to_avoid = list_union res1.to_avoid res2.to_avoid - } - - -(* - The combination function for an argument with a list of argument -*) - -let combine_args arg args = - { - context = arg.context@args.context; - (* Note that the binding context of [arg] MUST be placed before the one of - [args] in order to preserve possible type dependencies - *) - value = arg.value::args.value; - } - - -let ids_of_binder = function - | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] - | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] - -let rec change_vars_in_binder mapping = function - [] -> [] - | (bt,t)::l -> - let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in - (bt,change_vars mapping t):: - (if idmap_is_empty new_mapping - then l - else change_vars_in_binder new_mapping l - ) - -let rec replace_var_by_term_in_binder x_id term = function - | [] -> [] - | (bt,t)::l -> - (bt,replace_var_by_term x_id term t):: - if List.mem x_id (ids_of_binder bt) - then l - else replace_var_by_term_in_binder x_id term l - -let add_bt_names bt = List.append (ids_of_binder bt) - -let apply_args ctxt body args = - let need_convert_id avoid id = - List.exists (is_free_in id) args || List.mem id avoid - in - let need_convert avoid bt = - List.exists (need_convert_id avoid) (ids_of_binder bt) - in - let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = - match na with - | Name id when List.mem id avoid -> - let new_id = Namegen.next_ident_away id avoid in - Name new_id,Idmap.add id new_id mapping,new_id::avoid - | _ -> na,mapping,avoid - in - let next_bt_away bt (avoid:identifier list) = - match bt with - | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in - LetIn new_na,mapping,new_avoid - | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in - Prod new_na,mapping,new_avoid - | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in - Lambda new_na,mapping,new_avoid - in - let rec do_apply avoid ctxt body args = - match ctxt,args with - | _,[] -> (* No more args *) - (ctxt,body) - | [],_ -> (* no more fun *) - let f,args' = raw_decompose_app body in - (ctxt,mkRApp(f,args'@args)) - | (Lambda Anonymous,t)::ctxt',arg::args' -> - do_apply avoid ctxt' body args' - | (Lambda (Name id),t)::ctxt',arg::args' -> - let new_avoid,new_ctxt',new_body,new_id = - if need_convert_id avoid id - then - let new_avoid = id::avoid in - let new_id = Namegen.next_ident_away id new_avoid in - let new_avoid' = new_id :: new_avoid in - let mapping = Idmap.add id new_id Idmap.empty in - let new_ctxt' = change_vars_in_binder mapping ctxt' in - let new_body = change_vars mapping body in - new_avoid',new_ctxt',new_body,new_id - else - id::avoid,ctxt',body,id - in - let new_body = replace_var_by_term new_id arg new_body in - let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in - do_apply avoid new_ctxt' new_body args' - | (bt,t)::ctxt',_ -> - let new_avoid,new_ctxt',new_body,new_bt = - let new_avoid = add_bt_names bt avoid in - if need_convert avoid bt - then - let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in - ( - new_avoid, - change_vars_in_binder mapping ctxt', - change_vars mapping body, - new_bt - ) - else new_avoid,ctxt',body,bt - in - let new_ctxt',new_body = - do_apply new_avoid new_ctxt' new_body args - in - (new_bt,t)::new_ctxt',new_body - in - do_apply [] ctxt body args - - -let combine_app f args = - let new_ctxt,new_value = apply_args f.context f.value args.value in - { - (* Note that the binding context of [args] MUST be placed before the one of - the applied value in order to preserve possible type dependencies - *) - context = args.context@new_ctxt; - value = new_value; - } - -let combine_lam n t b = - { - context = []; - value = mkRLambda(n, compose_raw_context t.context t.value, - compose_raw_context b.context b.value ) - } - - - -let combine_prod n t b = - { context = t.context@((Prod n,t.value)::b.context); value = b.value} - -let combine_letin n t b = - { context = t.context@((LetIn n,t.value)::b.context); value = b.value} - - -let mk_result ctxt value avoid = - { - result = - [{context = ctxt; - value = value}] - ; - to_avoid = avoid - } -(************************************************* - Some functions to deal with overlapping patterns -**************************************************) - -let coq_True_ref = - lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") - -let coq_False_ref = - lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") - -(* - [make_discr_match_el \[e1,...en\]] builds match e1,...,en with - (the list of expresions on which we will do the matching) - *) -let make_discr_match_el = - List.map (fun e -> (e,(Anonymous,None))) - -(* - [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. - that is. - match ?????? with \\ - | pat_1 => False \\ - | pat_{i-1} => False \\ - | pat_i => True \\ - | pat_{i+1} => False \\ - \vdots - | pat_n => False - end -*) -let make_discr_match_brl i = - list_map_i - (fun j (_,idl,patl,_) -> - if j=i - then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref)) - else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref)) - ) - 0 -(* - [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff - brl_{i} is the first branch matched by [el] - - Used when we want to simulate the coq pattern matching algorithm -*) -let make_discr_match brl = - fun el i -> - mkRCases(None, - make_discr_match_el el, - make_discr_match_brl i brl) - -let pr_name = function - | Name id -> Ppconstr.pr_id id - | Anonymous -> str "_" - -(**********************************************************************) -(* functions used to build case expression from lettuple and if ones *) -(**********************************************************************) - -(* [build_constructors_of_type] construct the array of pattern of its inductive argument*) -let build_constructors_of_type ind' argl = - let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in - let npar = mib.Declarations.mind_nparams in - Array.mapi (fun i _ -> - let construct = ind',i+1 in - let constructref = ConstructRef(construct) in - let _implicit_positions_of_cst = - Impargs.implicits_of_global constructref - in - let cst_narg = - Inductiveops.mis_constructor_nargs_env - (Global.env ()) - construct - in - let argl = - if argl = [] - then - Array.to_list - (Array.init (cst_narg - npar) (fun _ -> mkRHole ()) - ) - else argl - in - let pat_as_term = - mkRApp(mkRRef (ConstructRef(ind',i+1)),argl) - in - cases_pattern_of_rawconstr Anonymous pat_as_term - ) - ind.Declarations.mind_consnames - -(* [find_type_of] very naive attempts to discover the type of an if or a letin *) -let rec find_type_of nb b = - let f,_ = raw_decompose_app b in - match f with - | RRef(_,ref) -> - begin - let ind_type = - match ref with - | VarRef _ | ConstRef _ -> - let constr_of_ref = constr_of_global ref in - let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in - let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in - let ret_type,_ = decompose_app ret_type in - if not (isInd ret_type) then - begin -(* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *) - raise (Invalid_argument "not an inductive") - end; - destInd ret_type - | IndRef ind -> ind - | ConstructRef c -> fst c - in - let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in - if not (Array.length ind_type_info.Declarations.mind_consnames = nb ) - then raise (Invalid_argument "find_type_of : not a valid inductive"); - ind_type - end - | RCast(_,b,_) -> find_type_of nb b - | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *) - | _ -> raise (Invalid_argument "not a ref") - - - - -(******************) -(* Main functions *) -(******************) - - - -let raw_push_named (na,raw_value,raw_typ) env = - match na with - | Anonymous -> env - | Name id -> - let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in - let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in - Environ.push_named (id,value,typ) env - - -let add_pat_variables pat typ env : Environ.env = - let rec add_pat_variables env pat typ : Environ.env = - observe (str "new rel env := " ++ Printer.pr_rel_context_of env); - - match pat with - | PatVar(_,na) -> Environ.push_rel (na,None,typ) env - | PatCstr(_,c,patl,na) -> - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env Evd.empty typ - with Not_found -> assert false - in - let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in - List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) - in - let new_env = add_pat_variables env pat typ in - let res = - fst ( - Sign.fold_rel_context - (fun (na,v,t) (env,ctxt) -> - match na with - | Anonymous -> assert false - | Name id -> - let new_t = substl ctxt t in - let new_v = Option.map (substl ctxt) v in - observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++ - str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++ - str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++ - Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++ - Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ()) - ); - (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt) - ) - (Environ.rel_context new_env) - ~init:(env,[]) - ) - in - observe (str "new var env := " ++ Printer.pr_named_context_of res); - res - - - - -let rec pattern_to_term_and_type env typ = function - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> - mkRVar id - | PatCstr(loc,constr,patternl,_) -> - let cst_narg = - Inductiveops.mis_constructor_nargs_env - (Global.env ()) - constr - in - let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env Evd.empty typ - with Not_found -> assert false - in - let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in - let _,cstl = Inductiveops.dest_ind_family indf in - let csta = Array.of_list cstl in - let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i)) - ) - in - let patl_as_term = - List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl - in - mkRApp(mkRRef(ConstructRef constr), - implicit_args@patl_as_term - ) - -(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) - of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the - corresponding graphs. - - - The idea to transform a term [t] into a list of constructors [lc] is the following: - \begin{itemize} - \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding - to [body] and add (bind x. _) to each elements of [lc] - \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) - then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], - then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], - [g c1 ... cn] is an element of [lc] - \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then - compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], - then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn] - create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc] - \item if the term is a cast just treat its body part - \item - if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case - and concatenate them (informally, each branch of a match produces a new constructor) - \end{itemize} - - WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. - We must wait to have complete all the current calculi to set the recursive calls. - At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by - a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. - We in fact not create a constructor list since then end of each constructor has not the expected form - but only the value of the function -*) - - -let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = - observe (str " Entering : " ++ Printer.pr_rawconstr rt); - match rt with - | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> - (* do nothing (except changing type of course) *) - mk_result [] rt avoid - | RApp(_,_,_) -> - let f,args = raw_decompose_app rt in - let args_res : (rawconstr list) build_entry_return = - List.fold_right (* create the arguments lists of constructors and combine them *) - (fun arg ctxt_argsl -> - let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in - combine_results combine_args arg_res ctxt_argsl - ) - args - (mk_result [] [] avoid) - in - begin - match f with - | RLambda _ -> - 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) - | _ -> - RApp(dummy_loc,t,l) - in - build_entry_lc env funnames avoid (aux f args) - | RVar(_,id) when Idset.mem id funnames -> - (* if we have [f t1 ... tn] with [f]$\in$[fnames] - then we create a fresh variable [res], - add [res] and its "value" (i.e. [res v1 ... vn]) to each - pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and - a pseudo value "v1 ... vn". - The "value" of this branch is then simply [res] - *) - let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in - let rt_typ = Typing.type_of env Evd.empty rt_as_constr in - let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in - let res = fresh_id args_res.to_avoid "res" in - let new_avoid = res::args_res.to_avoid in - let res_rt = mkRVar res in - let new_result = - List.map - (fun arg_res -> - let new_hyps = - [Prod (Name res),res_raw_type; - Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)] - in - {context = arg_res.context@new_hyps; value = res_rt } - ) - args_res.result - in - { result = new_result; to_avoid = new_avoid } - | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> - (* if have [g t1 ... tn] with [g] not appearing in [funnames] - then - foreach [ctxt,v1 ... vn] in [args_res] we return - [ctxt, g v1 .... vn] - *) - { - args_res with - result = - List.map - (fun args_res -> - {args_res with value = mkRApp(f,args_res.value)}) - args_res.result - } - | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *) - | RLetIn(_,n,t,b) -> - (* if we have [(let x := v in b) t1 ... tn] , - we discard our work and compute the list of constructor for - [let x = v in (b t1 ... tn)] up to alpha conversion - *) - let new_n,new_b,new_avoid = - match n with - | Name id when List.exists (is_free_in id) args -> - (* need to alpha-convert the name *) - let new_id = Namegen.next_ident_away id avoid in - let new_avoid = id:: avoid in - let new_b = - replace_var_by_term - id - (RVar(dummy_loc,id)) - b - in - (Name new_id,new_b,new_avoid) - | _ -> n,b,avoid - in - build_entry_lc - env - funnames - avoid - (mkRLetIn(new_n,t,mkRApp(new_b,args))) - | RCases _ | RIf _ | RLetTuple _ -> - (* we have [(match e1, ...., en with ..... end) t1 tn] - we first compute the result from the case and - then combine each of them with each of args one - *) - let f_res = build_entry_lc env funnames args_res.to_avoid f in - combine_results combine_app f_res args_res - | RDynamic _ ->error "Not handled RDynamic" - | RCast(_,b,_) -> - (* for an applied cast we just trash the cast part - and restart the work. - - WARNING: We need to restart since [b] itself should be an application term - *) - build_entry_lc env funnames avoid (mkRApp(b,args)) - | RRec _ -> error "Not handled RRec" - | RProd _ -> error "Cannot apply a type" - end (* end of the application treatement *) - - | RLambda(_,n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env funnames avoid t in - let new_n = - match n with - | Name _ -> n - | Anonymous -> Name (Indfun_common.fresh_id [] "_x") - in - let new_env = raw_push_named (new_n,None,t) env in - let b_res = build_entry_lc new_env funnames avoid b in - combine_results (combine_lam new_n) t_res b_res - | RProd(_,n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type - and combine the two result - *) - let t_res = build_entry_lc env funnames avoid t in - let new_env = raw_push_named (n,None,t) env in - let b_res = build_entry_lc new_env funnames avoid b in - combine_results (combine_prod n) t_res b_res - | RLetIn(_,n,v,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the value [t] - and combine the two result - *) - let v_res = build_entry_lc env funnames avoid v in - let v_as_constr = Pretyping.Default.understand Evd.empty env v in - let v_type = Typing.type_of env Evd.empty v_as_constr in - let new_env = - match n with - Anonymous -> env - | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env - in - let b_res = build_entry_lc new_env funnames avoid b in - combine_results (combine_letin n) v_res b_res - | RCases(_,_,_,el,brl) -> - (* we create the discrimination function - and treat the case itself - *) - let make_discr = make_discr_match brl in - build_entry_lc_from_case env funnames make_discr el brl avoid - | RIf(_,b,(na,e_option),lhs,rhs) -> - let b_as_constr = Pretyping.Default.understand Evd.empty env b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ - with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ - Printer.pr_rawconstr b ++ str " in " ++ - Printer.pr_rawconstr rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type ind [] in - assert (Array.length case_pats = 2); - let brl = - list_map_i - (fun i x -> (dummy_loc,[],[case_pats.(i)],x)) - 0 - [lhs;rhs] - in - let match_expr = - mkRCases(None,[(b,(Anonymous,None))],brl) - in - (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) - build_entry_lc env funnames avoid match_expr - | RLetTuple(_,nal,_,b,e) -> - begin - let nal_as_rawconstr = - List.map - (function - Name id -> mkRVar id - | Anonymous -> mkRHole () - ) - nal - in - let b_as_constr = Pretyping.Default.understand Evd.empty env b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ - with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ - Printer.pr_rawconstr b ++ str " in " ++ - Printer.pr_rawconstr rt ++ str ". try again with a cast") - in - let case_pats = build_constructors_of_type ind nal_as_rawconstr in - assert (Array.length case_pats = 1); - let br = - (dummy_loc,[],[case_pats.(0)],e) - in - let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in - build_entry_lc env funnames avoid match_expr - - end - | RRec _ -> error "Not handled RRec" - | RCast(_,b,_) -> - build_entry_lc env funnames avoid b - | RDynamic _ -> error "Not handled RDynamic" -and build_entry_lc_from_case env funname make_discr - (el:tomatch_tuples) - (brl:Rawterm.cases_clauses) avoid : - rawconstr build_entry_return = - match el with - | [] -> assert false (* this case correspond to match with .... !*) - | el -> - (* this case correspond to - match el with brl end - we first compute the list of lists corresponding to [el] and - combine them . - Then for each elemeent of the combinations, - we compute the result we compute one list per branch in [brl] and - finally we just concatenate those list - *) - let case_resl = - List.fold_right - (fun (case_arg,_) ctxt_argsl -> - let arg_res = build_entry_lc env funname avoid case_arg in - combine_results combine_args arg_res ctxt_argsl - ) - el - (mk_result [] [] avoid) - in - let types = - List.map (fun (case_arg,_) -> - let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in - Typing.type_of env Evd.empty case_arg_as_constr - ) el - in - (****** The next works only if the match is not dependent ****) - let results = - List.map - (fun ca -> - let res = build_entry_lc_from_case_term - env types - funname (make_discr) - [] brl - case_resl.to_avoid - ca - in - res - ) - case_resl.result - in - { - result = List.concat (List.map (fun r -> r.result) results); - to_avoid = - List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results - } - -and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid - matched_expr = - match brl with - | [] -> (* computed_branches *) {result = [];to_avoid = avoid} - | br::brl' -> - (* alpha convertion to prevent name clashes *) - let _,idl,patl,return = alpha_br avoid br in - let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *) - (* building a list of precondition stating that we are not in this branch - (will be used in the following recursive calls) - *) - let new_env = List.fold_right2 add_pat_variables patl types env in - let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = - List.map2 - (fun pat typ -> - fun avoid pat'_as_term -> - let renamed_pat,_,_ = alpha_pat avoid pat in - let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables pat typ new_env in - List.fold_right - (fun id acc -> - let typ_of_id = - Typing.type_of env_with_pat_ids Evd.empty (mkVar id) - in - let raw_typ_of_id = - Detyping.detype false [] - (Termops.names_of_rel_context env_with_pat_ids) typ_of_id - in - mkRProd (Name id,raw_typ_of_id,acc)) - pat_ids - (raw_make_neq pat'_as_term (pattern_to_term renamed_pat)) - ) - patl - types - in - (* Checking if we can be in this branch - (will be used in the following recursive calls) - *) - let unify_with_those_patterns : (cases_pattern -> bool*bool) list = - List.map - (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') - patl - in - (* - we first compute the other branch result (in ordrer to keep the order of the matching - as much as possible) - *) - let brl'_res = - build_entry_lc_from_case_term - env - types - funname - make_discr - ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent) - brl' - avoid - matched_expr - in - (* We now create the precondition of this branch i.e. - 1- the list of variable appearing in the different patterns of this branch and - the list of equation stating than el = patl (List.flatten ...) - 2- If there exists a previous branch which pattern unify with the one of this branch - then a discrimination precond stating that we are not in a previous branch (if List.exists ...) - *) - let those_pattern_preconds = - (List.flatten - ( - list_map3 - (fun pat e typ_as_constr -> - let this_pat_ids = ids_of_pat pat in - let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in - let pat_as_term = pattern_to_term pat in - List.fold_right - (fun id acc -> - if Idset.mem id this_pat_ids - then (Prod (Name id), - let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in - let raw_typ_of_id = - Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id - in - raw_typ_of_id - )::acc - else acc - ) - idl - [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)] - ) - patl - matched_expr.value - types - ) - ) - @ - (if List.exists (function (unifl,_) -> - let (unif,_) = - List.split (List.map2 (fun x y -> x y) unifl patl) - in - List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in - let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in - [(Prod Anonymous,make_discr pats_as_constr i )] - else - [] - ) - in - (* We compute the result of the value returned by the branch*) - let return_res = build_entry_lc new_env funname new_avoid return in - (* and combine it with the preconds computed for this branch *) - let this_branch_res = - List.map - (fun res -> - { context = matched_expr.context@those_pattern_preconds@res.context ; - value = res.value} - ) - return_res.result - in - { brl'_res with result = this_branch_res@brl'_res.result } - - -let is_res id = - try - String.sub (string_of_id id) 0 3 = "res" - with Invalid_argument _ -> false - - - -let same_raw_term rt1 rt2 = - match rt1,rt2 with - | RRef(_,r1), RRef (_,r2) -> r1=r2 - | RHole _, RHole _ -> 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 "llhs := " ++ int (List.length llhs)); - observe (str "lrhs := " ++ int (List.length lrhs)); - let sllhs = List.length llhs in - let slrhs = List.length lrhs in - if same_raw_term lhd rhd && sllhs = slrhs - then - (* let _ = assert false in *) - List.fold_right2 decompose_raw_eq llhs lrhs acc - else (lhs,rhs)::acc - in - decompose_raw_eq lhs rhs [] - - -exception Continue -(* - The second phase which reconstruct the real type of the constructor. - rebuild the raw constructors expression. - eliminates some meaningless equalities, applies some rewrites...... -*) -let rec rebuild_cons env nb_args relname args crossed_types depth rt = - observe (str "rebuilding : " ++ pr_rawconstr rt); - - match rt with - | RProd(_,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 -> - begin - match args' with - | (RVar(_,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]) - in - let t' = Pretyping.Default.understand Evd.empty env new_t in - let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - mkRProd(n,new_t,new_b), - Idset.filter not_free_in_t id_to_exclude - | _ -> (* the first args is the name of the function! *) - assert false - end - | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(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); - let t' = - try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = List.map (replace_var_by_term id rt) args in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkRProd(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 - let ind,args' = Inductive.find_inductive env ty' in - let mib,_ = Global.lookup_inductive ind in - let nparam = mib.Declarations.mind_nparams in - let params,arg' = - ((Util.list_chop nparam args')) - in - let rt_typ = - RApp(Util.dummy_loc, - RRef (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 ())))) - in - let eq' = - RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt]) - in - observe (str "computing new type for jmeq : " ++ pr_rawconstr eq'); - let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in - observe (str " computing new type for jmeq : done") ; - let new_args = - match kind_of_term eq'_as_constr with - | App(_,[|_;_;ty;_|]) -> - let ty = Array.to_list (snd (destApp ty)) in - let ty' = snd (Util.list_chop nparam ty) in - List.fold_left2 - (fun acc var_as_constr arg -> - if isRel var_as_constr - then - let (na,_,_) = - Environ.lookup_rel (destRel var_as_constr) env - in - match na with - | Anonymous -> acc - | Name id' -> - (id',Detyping.detype false [] - (Termops.names_of_rel_context env) - arg)::acc - else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype false [] - (Termops.names_of_rel_context env) - arg)::acc - else acc - ) - [] - arg' - ty' - | _ -> assert false - in - let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = - List.fold_left - (fun args (id,rt) -> - List.map (replace_var_by_term id rt) args - ) - args - ((id,rt)::new_args) - in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in - let new_env = - let t' = Pretyping.Default.understand Evd.empty env eq' in - Environ.push_rel (n,None,t') env - in - let new_b,id_to_exclude = - rebuild_cons - new_env - nb_args relname - new_args new_crossed_types - (depth + 1) subst_b - in - mkRProd(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 - else new_b, Idset.add id id_to_exclude - *) - | RApp(loc1,RRef(loc2,eq_as_ref),[ty;rt1;rt2]) - when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous - -> - begin - try - let l = decompose_raw_eq rt1 rt2 in - if List.length l > 1 - then - let new_rt = - List.fold_left - (fun acc (lhs,rhs) -> - mkRProd(Anonymous, - mkRApp(mkRRef(eq_as_ref),[mkRHole ();lhs;rhs]),acc) - ) - b - l - in - 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); - 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 = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id - (Idset.filter not_free_in_t id_to_exclude) - | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude - end - | _ -> - observe (str "computing new type for prod : " ++ pr_rawconstr 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 = - rebuild_cons new_env - nb_args relname - args new_crossed_types - (depth + 1) b - in - match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id - (Idset.filter not_free_in_t id_to_exclude) - | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude - end - | RLambda(_,n,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); - let t' = Pretyping.Default.understand Evd.empty env t in - match n with - | Name id -> - let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - (args@[mkRVar id])new_crossed_types - (depth + 1 ) b - in - if Idset.mem id id_to_exclude && depth >= nb_args - then - new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) - else - RProd(dummy_loc,n,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) -> - begin - let not_free_in_t id = not (is_free_in id t) in - let t' = Pretyping.Default.understand Evd.empty env t in - let type_t' = Typing.type_of env Evd.empty t' in - let new_env = Environ.push_rel (n,Some t',type_t') env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1 ) b in - match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) - | _ -> RLetIn(dummy_loc,n,t,new_b), - Idset.filter not_free_in_t id_to_exclude - end - | RLetTuple(_,nal,(na,rto),t,b) -> - assert (rto=None); - begin - let not_free_in_t id = not (is_free_in id t) in - let new_t,id_to_exclude' = - rebuild_cons env - nb_args - relname - args (crossed_types) - depth t - in - let t' = Pretyping.Default.understand Evd.empty env new_t in - let new_env = Environ.push_rel (na,None,t') env in - let new_b,id_to_exclude = - rebuild_cons new_env - nb_args relname - args (t::crossed_types) - (depth + 1) b - in -(* match n with *) -(* | Name id when Idset.mem id id_to_exclude -> *) -(* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *) -(* | _ -> *) - RLetTuple(dummy_loc,nal,(na,None),t,new_b), - Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude') - - end - - | _ -> mkRApp(mkRVar relname,args@[rt]),Idset.empty - - -(* debuging wrapper *) -let rebuild_cons 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)); - let res = - rebuild_cons env nb_args relname args crossed_types 0 rt - in - observe (str " leads to "++ pr_rawconstr (fst res)); - res - - -(* naive implementation of parameter detection. - - A parameter is an argument which is only preceded by parameters and whose - calls are all syntaxically equal. - - TODO: Find a valid way to deal with implicit arguments here! -*) -let rec compute_cst_params relnames params = function - | RRef _ | RVar _ | REvar _ | RPatVar _ -> params - | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames -> - compute_cst_params_from_app [] (params,rtl) - | RApp(_,f,args) -> - List.fold_left (compute_cst_params relnames) params (f::args) - | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> - let t_params = compute_cst_params relnames params t in - compute_cst_params relnames t_params b - | RCases _ -> - params (* If there is still cases at this point they can only be - discriminitation ones *) - | RSort _ -> params - | RHole _ -> params - | RIf _ | RRec _ | RCast _ | RDynamic _ -> - raise (UserError("compute_cst_params", str "Not handled case")) -and compute_cst_params_from_app acc (params,rtl) = - match params,rtl with - | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' - when id_ord id id' == 0 && not is_defined -> - compute_cst_params_from_app (param::acc) (params',rtl') - | _ -> List.rev acc - -let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts = - let rels_params = - Array.mapi - (fun i args -> - List.fold_left - (fun params (_,cst) -> compute_cst_params relnames params cst) - args - csts.(i) - ) - args - in - let l = ref [] in - let _ = - try - list_iter_i - (fun i ((n,nt,is_defined) as param) -> - if array_for_all - (fun l -> - let (n',nt',is_defined') = List.nth l i in - n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined') - rels_params - then - l := param::!l - ) - rels_params.(0) - with _ -> - () - in - List.rev !l - -let rec rebuild_return_type rt = - match rt with - | Topconstr.CProdN(loc,n,t') -> - Topconstr.CProdN(loc,n,rebuild_return_type t') - | Topconstr.CArrow(loc,t,t') -> - Topconstr.CArrow(loc,t,rebuild_return_type t') - | Topconstr.CLetIn(loc,na,t,t') -> - Topconstr.CLetIn(loc,na,t,rebuild_return_type t') - | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None)) - - -let do_build_inductive - funnames (funsargs: (Names.name * rawconstr * bool) list list) - returned_types - (rtl:rawconstr list) = - let _time1 = System.get_time () in -(* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *) - let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in - let funnames = Array.of_list funnames in - let funsargs = Array.of_list funsargs in - let returned_types = Array.of_list returned_types in - (* alpha_renaming of the body to prevent variable capture during manipulation *) - let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in - let rta = Array.of_list rtl_alpha in - (*i The next call to mk_rel_id is valid since we are constructing the graph - Ensures by: obvious - i*) - let relnames = Array.map mk_rel_id funnames in - let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in - (* Construction of the pseudo constructors *) - let env = - Array.fold_right - (fun id env -> - Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env - ) - funnames - (Global.env ()) - in - let resa = Array.map (build_entry_lc env funnames_as_set []) rta in - let env_with_graphs = - let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Rawterm.rawconstr * 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, - acc) - else - Topconstr.CProdN - (dummy_loc, - [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t], - acc - ) - ) - rel_first_args - (rebuild_return_type returned_types.(i)) - in - (* We need to lift back our work topconstr but only with all information - We mimick a Set Printing All. - Then save the graphs and reset Printing options to their primitive values - *) - let rel_arities = Array.mapi rel_arity funsargs in - Util.array_fold_left2 (fun env rel_name rel_ar -> - Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities - in - (* and of the real constructors*) - let constr i res = - List.map - (function result (* (args',concl') *) -> - let rt = compose_raw_context result.context result.value in - let nb_args = List.length funsargs.(i) in - (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *) - fst ( - rebuild_cons env_with_graphs nb_args relnames.(i) - [] - [] - rt - ) - ) - res.result - in - (* adding names to constructors *) - let next_constructor_id = ref (-1) in - let mk_constructor_id i = - incr next_constructor_id; - (*i The next call to mk_rel_id is valid since we are constructing the graph - Ensures by: obvious - i*) - id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) - in - let rel_constructors i rt : (identifier*rawconstr) list = - next_constructor_id := (-1); - List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) - in - let rel_constructors = Array.mapi rel_constructors resa in - (* Computing the set of parameters if asked *) - let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in - let nrel_params = List.length rels_params in - let rel_constructors = (* Taking into account the parameters in constructors *) - Array.map (List.map - (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) - rel_constructors - in - let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = - (snd (list_chop nrel_params funargs)) - in - List.fold_right - (fun (n,t,is_defined) acc -> - if is_defined - then - Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, - acc) - else - Topconstr.CProdN - (dummy_loc, - [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t], - acc - ) - ) - rel_first_args - (rebuild_return_type returned_types.(i)) - in - (* We need to lift back our work topconstr but only with all information - We mimick a Set Printing All. - Then save the graphs and reset Printing options to their primitive values - *) - let rel_arities = Array.mapi rel_arity funsargs in - let rel_params = - List.map - (fun (n,t,is_defined) -> - if is_defined - then - Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t) - else - Topconstr.LocalRawAssum - ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t) - ) - rels_params - in - let ext_rels_constructors = - Array.map (List.map - (fun (id,t) -> - false,((dummy_loc,id), - Flags.with_option - Flags.raw_print - (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t) - ) - )) - (rel_constructors) - in - let rel_ind i ext_rel_constructors = - ((dummy_loc,relnames.(i)), - rel_params, - Some rel_arities.(i), - ext_rel_constructors),[] - in - let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in - let rel_inds = Array.to_list ext_rel_constructors in -(* let _ = *) -(* Pp.msgnl (\* observe *\) ( *) -(* str "Inductive" ++ spc () ++ *) -(* prlist_with_sep *) -(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *) -(* (function ((_,id),_,params,ar,constr) -> *) -(* Ppconstr.pr_id id ++ spc () ++ *) -(* Ppconstr.pr_binders params ++ spc () ++ *) -(* str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *) -(* prlist_with_sep *) -(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *) -(* (function (_,((_,id),t)) -> *) -(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *) -(* Ppconstr.pr_lconstr_expr t) *) -(* constr *) -(* ) *) -(* rel_inds *) -(* ) *) -(* in *) - let _time2 = System.get_time () in - try - with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true - with - | UserError(s,msg) as e -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) - ++ fnl () ++ - msg - in - observe (msg); - raise e - | e -> - let _time3 = System.get_time () in -(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = - List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) - rel_inds - in - let msg = - str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) - ++ fnl () ++ - Cerrors.explain_exn e - in - observe msg; - raise e - - - -let build_inductive funnames funsargs returned_types rtl = - try - do_build_inductive funnames funsargs returned_types rtl - with e -> raise (Building_graph e) - - diff --git a/plugins/funind/rawterm_to_relation.mli b/plugins/funind/rawterm_to_relation.mli deleted file mode 100644 index a314050f..00000000 --- a/plugins/funind/rawterm_to_relation.mli +++ /dev/null @@ -1,16 +0,0 @@ - - - -(* - [build_inductive parametrize funnames funargs returned_types bodies] - constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments - and returning [returned_types] using bodies [bodies] -*) - -val build_inductive : - Names.identifier list -> (* The list of function name *) - (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *) - Topconstr.constr_expr list -> (* The list of function returned type *) - Rawterm.rawconstr list -> (* the list of body *) - unit - diff --git a/plugins/funind/rawtermops.ml b/plugins/funind/rawtermops.ml deleted file mode 100644 index e31f1452..00000000 --- a/plugins/funind/rawtermops.ml +++ /dev/null @@ -1,718 +0,0 @@ -open Pp -open Rawterm -open Util -open Names -(* Ocaml 3.06 Map.S does not handle is_empty *) -let idmap_is_empty m = m = Idmap.empty - -(* - Some basic functions to rebuild rawconstr - In each of them the location is Util.dummy_loc -*) -let mkRRef ref = RRef(dummy_loc,ref) -let mkRVar id = RVar(dummy_loc,id) -let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl) -let mkRLambda(n,t,b) = RLambda(dummy_loc,n,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)) - -(* - Some basic functions to decompose rawconstrs - These are analogous to the ones constrs -*) -let raw_decompose_prod = - let rec raw_decompose_prod args = function - | RProd(_,n,k,t,b) -> - raw_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 - | rt -> args,rt - in - raw_decompose_prod [] - -let raw_compose_prod = - List.fold_left (fun b (n,t) -> mkRProd(n,t,b)) - -let raw_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) - | _ -> assert false) - -let raw_decompose_prod_n n = - let rec raw_decompose_prod i args c = - if i<=0 then args,c - else - match c with - | RProd(_,n,_,t,b) -> - raw_decompose_prod (i-1) ((n,t)::args) b - | rt -> args,rt - in - raw_decompose_prod n [] - - -let raw_decompose_prod_or_letin_n n = - let rec raw_decompose_prod i args c = - if i<=0 then args,c - else - match c with - | RProd(_,n,_,t,b) -> - raw_decompose_prod (i-1) ((n,None,Some t)::args) b - | RLetIn(_,n,t,b) -> - raw_decompose_prod (i-1) ((n,Some t,None)::args) b - | rt -> args,rt - in - raw_decompose_prod n [] - - -let raw_decompose_app = - let rec decompose_rapp acc rt = -(* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *) - match rt with - | RApp(_,rt,rtl) -> - decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt - | rt -> rt,List.rev acc - in - decompose_rapp [] - - - - -(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) -let raw_make_eq ?(typ= mkRHole ()) t1 t2 = - mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) - -(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) -let raw_make_neq t1 t2 = - mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2]) - -(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) -let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) - -(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -let rec raw_make_or_list = function - | [] -> raise (Invalid_argument "mk_or") - | [e] -> e - | e::l -> raw_make_or e (raw_make_or_list l) - - -let remove_name_from_mapping mapping na = - match na with - | Anonymous -> mapping - | Name id -> Idmap.remove id mapping - -let change_vars = - let rec change_vars mapping rt = - match rt with - | RRef _ -> rt - | RVar(loc,id) -> - let new_id = - try - Idmap.find id mapping - with Not_found -> id - in - RVar(loc,new_id) - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> - RApp(loc, - change_vars mapping rt', - List.map (change_vars mapping) rtl - ) - | RLambda(loc,name,k,t,b) -> - RLambda(loc, - name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | RProd(loc,name,k,t,b) -> - RProd(loc, - name, - k, - change_vars mapping t, - change_vars (remove_name_from_mapping mapping name) b - ) - | RLetIn(loc,name,def,b) -> - RLetIn(loc, - name, - change_vars mapping def, - change_vars (remove_name_from_mapping mapping name) b - ) - | RLetTuple(loc,nal,(na,rto),b,e) -> - let new_mapping = List.fold_left remove_name_from_mapping mapping nal in - RLetTuple(loc, - nal, - (na, Option.map (change_vars mapping) rto), - change_vars mapping b, - change_vars new_mapping e - ) - | RCases(loc,sty,infos,el,brl) -> - RCases(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, - 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" - and change_vars_br mapping ((loc,idl,patl,res) as br) = - let new_mapping = List.fold_right Idmap.remove idl mapping in - if idmap_is_empty new_mapping - then br - else (loc,idl,patl,change_vars new_mapping res) - in - change_vars - - - -let rec alpha_pat excluded pat = - match pat with - | PatVar(loc,Anonymous) -> - let new_id = Indfun_common.fresh_id excluded "_x" in - PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty - | PatVar(loc,Name id) -> - if List.mem id excluded - then - let new_id = Namegen.next_ident_away id excluded in - PatVar(loc,Name new_id),(new_id::excluded), - (Idmap.add id new_id Idmap.empty) - else pat,excluded,Idmap.empty - | PatCstr(loc,constr,patl,na) -> - let new_na,new_excluded,map = - match na with - | Name id when List.mem id excluded -> - let new_id = Namegen.next_ident_away id excluded in - Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty - | _ -> na,excluded,Idmap.empty - in - let new_patl,new_excluded,new_map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map) - ) - ([],new_excluded,map) - patl - in - PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map - -let alpha_patl excluded patl = - let patl,new_excluded,map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in - new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map) - ) - ([],excluded,Idmap.empty) - patl - in - (List.rev patl,new_excluded,map) - - - - -let raw_get_pattern_id pat acc = - let rec get_pattern_id pat = - match pat with - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> - [id] - | PatCstr(loc,constr,patternl,_) -> - List.fold_right - (fun pat idl -> - let idl' = get_pattern_id pat in - idl'@idl - ) - patternl - [] - in - (get_pattern_id pat)@acc - -let get_pattern_id pat = raw_get_pattern_id pat [] - -let rec alpha_rt excluded rt = - let new_rt = - match rt with - | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt - | RLambda(loc,Anonymous,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) -> - 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) -> - 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) -> - let new_id = Namegen.next_ident_away id excluded in - let t,b = - if new_id = id - then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in - (t,replace b) - in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - RLambda(loc,Name new_id,k,new_t,new_b) - | RProd(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 = - if new_id = id - then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in - (t,replace b) - in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - RProd(loc,Name new_id,k,new_t,new_b) - | RLetIn(loc,Name id,t,b) -> - let new_id = Namegen.next_ident_away id excluded in - let t,b = - if new_id = id - then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in - (t,replace b) - in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in - RLetIn(loc,Name new_id,new_t,new_b) - - - | RLetTuple(loc,nal,(na,rto),t,b) -> - let rev_new_nal,new_excluded,mapping = - List.fold_left - (fun (nal,excluded,mapping) na -> - match na with - | Anonymous -> (na::nal,excluded,mapping) - | Name id -> - let new_id = Namegen.next_ident_away id excluded in - if new_id = id - then - na::nal,id::excluded,mapping - else - (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) - ) - ([],excluded,Idmap.empty) - nal - in - let new_nal = List.rev rev_new_nal in - let new_rto,new_t,new_b = - if idmap_is_empty mapping - then rto,t,b - else let replace = change_vars mapping in - (Option.map replace rto, t,replace b) - in - let new_t = alpha_rt new_excluded new_t in - let new_b = alpha_rt new_excluded new_b in - let new_rto = Option.map (alpha_rt new_excluded) new_rto in - RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) - | RCases(loc,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, - (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, - alpha_rt excluded f, - List.map (alpha_rt excluded) args - ) - in - new_rt - -and alpha_br excluded (loc,ids,patl,res) = - let new_patl,new_excluded,mapping = alpha_patl excluded patl in - let new_ids = List.fold_right raw_get_pattern_id new_patl [] in - let new_excluded = new_ids@excluded in - let renamed_res = change_vars mapping res in - let new_res = alpha_rt new_excluded renamed_res in - (loc,new_ids,new_patl,new_res) - -(* - [is_free_in id rt] checks if [id] is a free variable in [rt] -*) -let is_free_in id = - let rec is_free_in = function - | RRef _ -> false - | RVar(_,id') -> id_ord id' id == 0 - | REvar _ -> false - | RPatVar _ -> false - | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) - | RLambda(_,n,_,t,b) | RProd(_,n,_,t,b) | RLetIn(_,n,t,b) -> - let check_in_b = - match n with - | Name id' -> id_ord id' id <> 0 - | _ -> true - in - is_free_in t || (check_in_b && is_free_in b) - | RCases(_,_,_,el,brl) -> - (List.exists (fun (e,_) -> is_free_in e) el) || - List.exists is_free_in_br brl - | RLetTuple(_,nal,_,b,t) -> - let check_in_nal = - not (List.exists (function Name id' -> id'= id | _ -> false) nal) - in - is_free_in t || (check_in_nal && is_free_in b) - - | RIf(_,cond,_,br1,br2) -> - is_free_in cond || is_free_in br1 || is_free_in br2 - | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> false - | RHole _ -> false - | RCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t - | RCast (_,b,CastCoerce) -> is_free_in b - | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) - and is_free_in_br (_,ids,_,rt) = - (not (List.mem id ids)) && is_free_in rt - in - is_free_in - - - -let rec pattern_to_term = function - | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> - mkRVar id - | PatCstr(loc,constr,patternl,_) -> - let cst_narg = - Inductiveops.mis_constructor_nargs_env - (Global.env ()) - constr - in - let implicit_args = - Array.to_list - (Array.init - (cst_narg - List.length patternl) - (fun _ -> mkRHole ()) - ) - in - let patl_as_term = - List.map pattern_to_term patternl - in - mkRApp(mkRRef(Libnames.ConstructRef constr), - implicit_args@patl_as_term - ) - - - -let replace_var_by_term x_id term = - let rec replace_var_by_pattern rt = - match rt with - | RRef _ -> rt - | RVar(_,id) when id_ord id x_id == 0 -> term - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> - RApp(loc, - replace_var_by_pattern rt', - List.map replace_var_by_pattern rtl - ) - | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt - | RLambda(loc,name,k,t,b) -> - RLambda(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, - 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, - name, - replace_var_by_pattern def, - replace_var_by_pattern b - ) - | RLetTuple(_,nal,_,_,_) - when List.exists (function Name id -> id = x_id | _ -> false) nal -> - rt - | RLetTuple(loc,nal,(na,rto),def,b) -> - RLetTuple(loc, - nal, - (na,Option.map replace_var_by_pattern rto), - replace_var_by_pattern def, - replace_var_by_pattern b - ) - | RCases(loc,sty,infos,el,brl) -> - RCases(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, - (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")) - and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = - if List.exists (fun id -> id_ord id x_id == 0) idl - then br - else (loc,idl,patl,replace_var_by_pattern res) - in - replace_var_by_pattern - - - - -(* checking unifiability of patterns *) -exception NotUnifiable - -let rec are_unifiable_aux = function - | [] -> () - | eq::eqs -> - match eq with - | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 - then raise NotUnifiable - else - let eqs' = - try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "are_unifiable_aux" - in - are_unifiable_aux eqs' - -let are_unifiable pat1 pat2 = - try - are_unifiable_aux [pat1,pat2]; - true - with NotUnifiable -> false - - -let rec eq_cases_pattern_aux = function - | [] -> () - | eq::eqs -> - match eq with - | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 - then raise NotUnifiable - else - let eqs' = - try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "eq_cases_pattern_aux" - in - eq_cases_pattern_aux eqs' - | _ -> raise NotUnifiable - -let eq_cases_pattern pat1 pat2 = - try - eq_cases_pattern_aux [pat1,pat2]; - true - with NotUnifiable -> false - - - -let ids_of_pat = - let rec ids_of_pat ids = function - | PatVar(_,Anonymous) -> ids - | PatVar(_,Name id) -> Idset.add id ids - | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl - in - ids_of_pat Idset.empty - -let id_of_name = function - | Names.Anonymous -> id_of_string "x" - | Names.Name x -> x - -(* TODO: finish Rec caes *) -let ids_of_rawterm c = - let rec ids_of_rawterm acc c = - let idof = id_of_name in - match c with - | RVar (_,id) -> id::acc - | RApp (loc,g,args) -> - ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc - | RLambda (loc,na,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 _) -> [] - in - (* build the set *) - List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c) - - - - - -let zeta_normalize = - let rec zeta_normalize_term rt = - match rt with - | RRef _ -> rt - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> - RApp(loc, - zeta_normalize_term rt', - List.map zeta_normalize_term rtl - ) - | RLambda(loc,name,k,t,b) -> - RLambda(loc, - name, - k, - zeta_normalize_term t, - zeta_normalize_term b - ) - | RProd(loc,name,k,t,b) -> - RProd(loc, - name, - k, - zeta_normalize_term t, - zeta_normalize_term b - ) - | RLetIn(_,Name id,def,b) -> - zeta_normalize_term (replace_var_by_term id def b) - | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b - | RLetTuple(loc,nal,(na,rto),def,b) -> - RLetTuple(loc, - nal, - (na,Option.map zeta_normalize_term rto), - zeta_normalize_term def, - zeta_normalize_term b - ) - | RCases(loc,sty,infos,el,brl) -> - RCases(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, - (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")) - and zeta_normalize_br (loc,idl,patl,res) = - (loc,idl,patl,zeta_normalize_term res) - in - zeta_normalize_term - - - - -let expand_as = - - let rec add_as map pat = - match pat with - | PatVar _ -> map - | PatCstr(_,_,patl,Name id) -> - Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) - | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl - in - let rec expand_as map rt = - match rt with - | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt - | RVar(_,id) -> - begin - try - Idmap.find id map - with Not_found -> rt - end - | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args) - | RLambda(loc,na,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), - expand_as map v, expand_as map b) - | RIf(loc,e,(na,po),br1,br2) -> - RIf(loc,expand_as map e,(na,Option.map (expand_as map) po), - expand_as map br1, expand_as map br2) - | RRec _ -> error "Not handled RRec" - | RDynamic _ -> error "Not handled RDynamic" - | RCast(loc,b,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, - List.map (expand_as_br map) brl) - and expand_as_br map (loc,idl,cpl,rt) = - (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) - in - expand_as Idmap.empty diff --git a/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 83868da9..55ebd31b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - if not (Queue.is_empty debug_queue) + if not (Stack.is_empty debug_queue) then - print_debug_queue e; + print_debug_queue true 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;; -*) - let observe_tac s tac g = if Tacinterp.get_debug () <> Tactic_debug.DebugOff then do_observe_tac s tac g @@ -145,9 +136,9 @@ 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) + (try (match body_of_constant (Global.lookup_constant sp) with + | Some c -> Declarations.force c + | _ -> assert false) with _ -> anomaly ("Cannot find definition of constant "^ (string_of_id (id_of_label (con_label sp)))) @@ -180,11 +171,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 @@ -193,7 +196,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 @@ -217,7 +220,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 @@ -227,15 +230,16 @@ 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" | Sort(_) -> (fun l -> expr), [] - | Cast(b,_,_) -> find_call_occs nb_lam f b + | Cast(b,_,_) -> find_call_occs nb_arg nb_lam f b | Prod(_,_,_) -> error "find_call_occs : Prod" | 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),[] @@ -243,7 +247,7 @@ let rec (find_call_occs : int -> constr -> constr -> 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)) -> @@ -256,7 +260,7 @@ let rec (find_call_occs : int -> constr -> constr -> | 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" @@ -369,15 +373,15 @@ 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 _ -> 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 ) ] @@ -430,7 +434,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 @@ -529,8 +533,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) @@ -572,7 +576,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 @@ -618,7 +622,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 @@ -657,13 +661,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 @@ -671,7 +675,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 = @@ -683,16 +687,16 @@ 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 )) @@ -831,7 +835,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 = @@ -864,6 +868,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 @@ -871,7 +876,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 ) @@ -882,9 +887,9 @@ 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 @@ -918,7 +923,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 @@ -934,6 +939,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 @@ -943,20 +955,16 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ try (add_suffix current_proof_name "_subproof") with _ -> anomaly "open_new_goal with an unamed theorem" in - let sign = Global.named_context () in - let sign = clear_proofs sign in + let 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 @@ -1000,7 +1008,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ 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] ] ) @@ -1101,38 +1109,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)]) - 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) + GVar(d0,v_id)]) 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) = @@ -1152,7 +1153,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)))); @@ -1194,7 +1195,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 @@ -1202,8 +1203,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 @@ -1258,7 +1259,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 ) @@ -1293,12 +1294,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 @@ -1307,38 +1308,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 @@ -1349,7 +1347,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 @@ -1382,12 +1380,12 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num generate_induction_principle using_lemmas : unit = let function_type = interp_constr Evd.empty (Global.env()) type_of_f in let env = push_named (function_name,None,function_type) (Global.env()) in -(* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) + (* 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 @@ -1406,7 +1404,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 @@ -1420,14 +1418,15 @@ 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) + try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) with e -> begin if Tacinterp.get_debug () <> Tactic_debug.DebugOff - then 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 _ -> ()); *) 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..3031fd22 100644 --- a/plugins/micromega/CheckerMaker.v +++ b/plugins/micromega/CheckerMaker.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* D. - Definition jump (j:positive) (e:Env) := fun x => e (Pplus x j). + Definition jump (j:positive) (e:Env) := fun x => e (Pplus 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 (x:D) (e: Env) := nth xH e. Definition tail (e: Env) := jump xH e. - Lemma psucc : forall p, (match p with + Lemma psucc : forall p, (match p with | xI y' => xO (Psucc y') | xO y' => xI y' | 1%positive => 2%positive diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 8968a014..309ebdef 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. @@ -105,12 +105,12 @@ 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 @@ -421,7 +421,7 @@ Section MakeRingPol. _, 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 +435,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 @@ -537,10 +537,10 @@ Section MakeRingPol. 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); + assert (H1 := Pos.compare_eq p p0); destruct (p ?= p0); try discriminate H. rewrite (IHP P' H); rewrite H1;trivial;rrefl. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); + assert (H1 := Pos.compare_eq p p0); destruct (p ?= p0); try discriminate H. rewrite H1;trivial. clear H1. assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); @@ -1019,8 +1019,8 @@ Qed. 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). + case_eq (i ?= j); intros He; simpl. + rewrite (Pos.compare_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)); @@ -1048,8 +1048,8 @@ Qed. 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). + case_eq (i ?= j); intros He; simpl. + rewrite (Pos.compare_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. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 5afe7e37..19a98f87 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* "( * )" [ "(,)" ]. -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..97517957 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* + 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 Zsucc in * ; + (*cbv delta - [Zplus Zminus Zopp Zmult Zpower Zgt Zge Zle Zlt 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 Zsucc 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..f64504a5 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (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 (nat_of_P ?X)] |- _ => + revert H ; + let HH := fresh in + assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (nat_of_P X)) + | |- context[INR (nat_of_P ?X)] => + let HH := fresh in + assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (nat_of_P X)) + end. + +Ltac add_eq expr val := set (temp := expr) ; + generalize (refl_equal 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 nat_of_P_mult_morphism. + 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 nat_of_P_mult_morphism. + 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 Pmult_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 Zopp_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 Zmult_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. (*Nnat.nat_of_N*) + +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 nat_of_N 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 nat_of_N pow R_of_Rcst. + +Definition QReval_formula := + eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IQR nat_of_N 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..b839195c 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 *) -(* 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,7 +318,7 @@ 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 sor.(SORplus_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'. @@ -490,6 +491,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) *) @@ -546,6 +640,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 +687,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 +706,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 +719,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 +755,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 +769,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 +783,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 +801,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 +826,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 +839,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); @@ -841,6 +937,63 @@ Proof. 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 +1034,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..b3ccdfcc 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (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..f41252b7 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 *) -(* 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..2bf3d8c3 100644 --- a/plugins/micromega/ZCoeff.v +++ b/plugins/micromega/ZCoeff.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [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,8 +146,8 @@ 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]. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index d6245681..461f53b5 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (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); + (fun x : 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; + (fun x : N => x) (pow_N 1 Zmult) 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); + (fun x : 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; + (fun x : N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst; intuition (auto with zarith). Transparent padd. Qed. +Definition Zunsat := check_inconsistent 0 Zeq_bool Zle_bool. + +Definition Zdeduce := nformula_plus_nformula 0 Zplus 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 *) @@ -273,6 +276,26 @@ Definition ceiling (a b:Z) : Z := | _ => q + 1 end. + +Require Import Znumtheory. + +Lemma Zdivide_ceiling : forall a b, (b | a) -> ceiling a b = Zdiv a b. +Proof. + unfold ceiling. + intros. + apply Zdivide_mod in H. + case_eq (Zdiv_eucl a b). + intros. + change z with (fst (z,z0)). + rewrite <- H0. + change (fst (Zdiv_eucl a b)) with (Zdiv a b). + change z0 with (snd (z,z0)). + rewrite <- H0. + change (snd (Zdiv_eucl a b)) with (Zmod a b). + rewrite H. + reflexivity. +Qed. + Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x >= b -> x >= ceiling b a. Proof. unfold ceiling. @@ -307,40 +330,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). +| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof +(*| SplitProof : PolC Z -> ZArithProof -> ZArithProof -> ZArithProof*). -(* 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). -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 @@ -566,9 +562,11 @@ 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 (Zgt_bool g Z0) (andb (negb (Zeq_bool c Z0)) (negb (Zeq_bool (Zgcd 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 Some (p,c,NonStrict) @@ -596,16 +594,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. - - +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 +612,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 +625,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 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 + | _ , _ => true + end + | _ , _ => false + end +end. @@ -702,7 +695,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)). @@ -729,7 +722,6 @@ Proof. 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 +733,51 @@ 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 (Zgt_bool g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Zgcd 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 (Zgt_bool 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 Zminus 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 Zplus_0_r in H2. + apply Zmult_integral 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 Zeq_minus. + 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. @@ -762,7 +792,7 @@ Proof. case_eq (makeCuttingPlane (PsubC Zminus 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 +801,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,23 +813,24 @@ 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 (Zgt_bool g 0 && (negb (Zeq_bool c 0) && negb (Zeq_bool (Zgcd 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. + 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. (**) - discriminate. + destruct (makeCuttingPlane p); discriminate. discriminate. destruct (makeCuttingPlane (PsubC Zminus p 1)) ; discriminate. destruct (makeCuttingPlane p) ; discriminate. @@ -816,11 +847,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,55 +899,54 @@ 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 0 Zplus Zmult (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 0 Zplus Zmult (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. + clear HZ0 Hop1 Hop2 HCutL HCutR H0 H1. + revert Hfix. generalize (-z1). clear z1. intro z1. revert z1 z2. induction pf;simpl ;intros. @@ -931,16 +961,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]]. + destruct (HH _ H1) as [pr [Hin Hcheker]]. assert (make_impl (eval_nformula env) ((PsubC Zminus 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 +984,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 +1008,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 +1063,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..540d1b9c 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* ) = 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,209 @@ 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 -> + 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) -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 +405,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 +497,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 +511,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 +532,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 +544,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 +570,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 +579,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 ""; 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..1ad49bb8 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 *) -(* "") 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,13 @@ struct ["Coq";"Reals" ; "Rpow_def"]; ["LRing_normalise"]] + let bin_module = [["Coq";"Numbers";"BinNums"]] + + let r_modules = + [["Coq";"Reals" ; "Rdefinitions"]; + ["Coq";"Reals" ; "Rpow_def"] ; +] + (** * Initialization : a large amount of Caml symbols are derived from * ZMicromega.v @@ -227,6 +307,8 @@ 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 constant = gen_constant_in_modules "Omicron" coq_modules *) let coq_and = lazy (init_constant "and") @@ -244,34 +326,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 (init_constant "pair") + let coq_None = lazy (init_constant "None") + let coq_option = lazy (init_constant "option") - 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_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_N0 = lazy (constant "N0") - let coq_N0 = lazy (constant "Npos") + 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") @@ -305,16 +395,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 +538,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 +583,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 +602,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 +620,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 @@ -768,12 +897,17 @@ struct then (Pp.pp (Pp.str "parse_expr: "); Pp.pp_flush ();Pp.pp (Printer.prterm term); 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 +915,34 @@ 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 _ -> (* 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) + ) + | _ -> parse_variable env term ) - | _ -> constant_or_variable env term - ) - | _ -> constant_or_variable env term in + | _ -> parse_variable env term in parse_expr env term let zop_spec = @@ -836,27 +972,57 @@ 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 + (assoc_const op rconst_assoc) (rconstant args.(0)) (rconstant args.(1)) + 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_flush ()); + let res = rconstant term in + if debug then + (Printf.printf "rconstant -> %a" 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 +1036,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 @@ -932,7 +1098,7 @@ 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 @@ -941,17 +1107,17 @@ struct 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 +1126,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 = @@ -1024,9 +1190,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 @@ -1103,6 +1269,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 @@ -1139,13 +1326,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 +1350,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,14 +1446,14 @@ 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 ; + end ; *) let res = try prover.compact prf remap with x -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) @@ -1327,6 +1513,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 +1539,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 +1567,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 +1602,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 +1747,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 +1892,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 +1914,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 +1936,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 +1953,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 z -> (*Printexc.print_backtrace stdout ;*) raise z + +let xnlia gl = + try + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec + [ nlinear_Z ] gl + with z -> (*Printexc.print_backtrace stdout ;*) raise z + + (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index 3b47007c..1604b0eb 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* [ 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..d9201722 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 @@ -913,7 +793,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..c4dbf6af 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* () + | e::l -> f o e ; output_string o ";" ; pp_list f o l + + let finally f rst = try let res = f () in @@ -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,20 @@ 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 -> 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 _ -> ()) [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..ed9fdcea 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 *) -(* 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 } @@ -98,10 +95,20 @@ let read_key_elem inch = | End_of_file -> None | _ -> raise InvalidTableFormat + +let unlock fd = + try + let pos = lseek fd 0 SEEK_CUR in + ignore (lseek fd 0 SEEK_SET) ; + lockf fd F_ULOCK 0 ; + ignore (lseek fd pos SEEK_SET) + with exc -> failwith (Printexc.to_string exc) + 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 +116,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 *) + lockf finch F_RLOCK 0 ; + 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 + lockf out F_LOCK 0 ; + (try + Table.iter + (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; + flush outch ; + with _ -> () ) + ; + unlock out ; + { outch = outch ; + status = Open ; + htbl = htbl + } end @@ -147,9 +165,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] + lockf fd F_LOCK 0 ; + 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..14d312a5 --- /dev/null +++ b/plugins/micromega/polynomial.ml @@ -0,0 +1,739 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* ) = 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 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..3d907e19 100644 --- a/plugins/micromega/sos.mli +++ b/plugins/micromega/sos.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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,23 +49,25 @@ 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 Zplus Zeq_bool. Definition PolZmul : PolZ -> PolZ -> PolZ := - @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool. + @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool. Definition PolZeq := @Peq Z Zeq_bool. @@ -140,51 +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) + nat_of_N 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 Rext: ring_eq_ext add mul opp _==_. +apply mk_reqe. intros. rewrite H ; rewrite H0; cring. + intros. rewrite H; rewrite H0; cring. +intros. rewrite H; cring. Qed. -Lemma Rset : Setoid_Theory R ring_eq. +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 _==_ nat_of_N pow. +apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. +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) + intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) R_power_theory) with (lmp:= List.nil). compute;trivial. Qed. @@ -194,7 +162,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 +175,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 +210,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 (nat_of_N t2) | (PEc t1) => (IZR1 t1) | (PEX n) => List.nth (pred (nat_of_P 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 +289,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 _; @@ -371,51 +315,13 @@ Ltac nsatz_call radicalmax info nparam p lp kont := 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 +329,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) (nat_of_N 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_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. -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. +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. -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]. - -Ltac nsatz_domainR:= - nsatz_domainpv ltac:pretacR 6%N 1%Z (@Datatypes.nil R) (@Datatypes.nil R) - ltac:simplR Rdi; - discrR. - - -Goal forall x y:R, x = y -> (x*x-x+1)%R = ((y*y-y)+1+0)%R. -nsatz_domainR. +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)). -(* 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}. +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. -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. - -Ltac pretacZ := -replaceZ; -replace Zri with (@domain_ring _ Zdi) in *; [idtac | reflexivity]. +Instance Rcri: (Cring (Rr:=Rri)). +red. exact Rmult_comm. Defined. -Ltac nsatz_domainZ:= -nsatz_domainpv ltac:pretacZ 6%N 1%Z (@Datatypes.nil Z) (@Datatypes.nil Z) ltac:simplZ Zdi. +Instance Rdi : (Integral_domain (Rcr:=Rcri)). +constructor. +exact Rmult_integral. exact R_one_zero. Defined. - -(* 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]. +Instance Zcri: (Cring (Rr:=Zr)). +red. exact Zmult_comm. Defined. -Ltac nsatz_domainQ:= -nsatz_domainpv ltac:pretacQ 6%N 1%Z (@Datatypes.nil Q) (@Datatypes.nil Q) ltac:simplQ Qdi. +Instance Zdi : (Integral_domain (Rcr:=Zcri)). +constructor. +exact Zmult_integral. exact Z_one_zero. Defined. -(* 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. - -Goal forall x y:Z, x = y -> (x*x-x+1)%Z = ((y*y-y)+1+0)%Z. -nsatz. -Qed. - -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..b635fd1f 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* !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; @@ -992,7 +992,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..e48643b4 100644 --- a/plugins/nsatz/nsatz.ml4 +++ b/plugins/nsatz/nsatz.ml4 @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* - 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 @@ -467,7 +474,7 @@ let remove_zeros zero lci = done; !lcr) lr in - info ("useless spolynomials: " + info ("unuseful spolynomials: " ^string_of_int (m-List.length lr)^"\n"); info ("useful spolynomials: " ^string_of_int (List.length lr)^"\n"); @@ -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..45fcb2d2 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli index 980a8306..b82b43b1 100644 --- a/plugins/nsatz/polynom.mli +++ b/plugins/nsatz/polynom.mli @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 Zmult_1_r, Zplus_0_r. apply Zle_0_nat. +Qed. diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v index 69a6ea72..a3ab34a9 100644 --- a/plugins/omega/OmegaPlugin.v +++ b/plugins/omega/OmegaPlugin.v @@ -1,11 +1,9 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 * + pose proof (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 * + pose proof (Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * (* O -> Z0 *) | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H @@ -184,20 +182,9 @@ Ltac zify_nat_op := 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 (Zle_0_nat a); hide_Z_of_nat a + | |- context [ Z_of_nat ?a ] => pose proof (Zle_0_nat a); hide_Z_of_nat a end. Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. @@ -223,17 +210,17 @@ Ltac zify_positive_rel := | 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) (* II: less than *) - | H : context [ (?a change (a change (a change (a change (a 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 := @@ -282,11 +269,9 @@ Ltac zify_positive_op := (* 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 * + pose proof (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 * + pose proof (Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * (* xO *) | H : context [ Zpos (xO ?a) ] |- _ => @@ -320,18 +305,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 + | _ : Zpos ?a > 0 |- _ => hide_Zpos a + | _ : context [ Zpos ?a ] |- _ => pose proof (Zgt_pos_0 a); hide_Zpos a + | |- context [ Zpos ?a ] => pose proof (Zgt_pos_0 a); hide_Zpos a end. Ltac zify_positive := @@ -358,25 +334,25 @@ Ltac zify_N_rel := | 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) (* II: less than *) - | H : (?a generalize (Z_of_N_lt _ _ H); clear H; intro H - | |- (?a apply (Z_of_N_lt_rev a b) - | H : context [ (?a rewrite (Z_of_N_lt_iff a b) in H - | |- context [ (?a rewrite (Z_of_N_lt_iff a b) + | 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) (* 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 : (?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) (* 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 : (?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) (* 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 : (?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) end. Ltac zify_N_op := @@ -413,25 +389,14 @@ Ltac zify_N_op := (* 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 * + pose proof (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 * + pose proof (Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult 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 (Z_of_N_le_0 a); hide_Z_of_N a + | |- context [ Z_of_N ?a ] => pose proof (Z_of_N_le_0 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..d7dfe149 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 *) -(* 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,8 @@ 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"]] + (* Zarith *) let coq_xH = lazy (constant "xH") let coq_xO = lazy (constant "xO") @@ -184,6 +186,7 @@ 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_Zpred = lazy (constant "Zpred") let coq_Zgt = lazy (constant "Zgt") let coq_Zle = lazy (constant "Zle") let coq_Z_of_nat = lazy (constant "Z_of_nat") @@ -191,13 +194,13 @@ let coq_inj_plus = lazy (constant "inj_plus") let coq_inj_mult = lazy (constant "inj_mult") let coq_inj_minus1 = lazy (constant "inj_minus1") let coq_inj_minus2 = lazy (constant "inj_minus2") -let coq_inj_S = lazy (constant "inj_S") -let coq_inj_le = lazy (constant "inj_le") -let coq_inj_lt = lazy (constant "inj_lt") -let coq_inj_ge = lazy (constant "inj_ge") -let coq_inj_gt = lazy (constant "inj_gt") -let coq_inj_neq = lazy (constant "inj_neq") -let coq_inj_eq = lazy (constant "inj_eq") +let coq_inj_S = lazy (z_constant "inj_S") +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") @@ -255,6 +258,7 @@ 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") @@ -323,6 +327,7 @@ let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant") let sp_Zsucc = lazy (evaluable_ref_of_constr "Zsucc" coq_Zsucc) +let sp_Zpred = lazy (evaluable_ref_of_constr "Zpred" coq_Zpred) 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) @@ -356,7 +361,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 +381,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 +422,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 = @@ -891,6 +904,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 @@ -1548,6 +1565,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 +1609,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 +1637,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 +1658,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 +1691,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 +1775,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 +1793,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..84cc8464 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 *) -(* 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..04cbdccb 100644 --- a/plugins/pluginsbyte.itarget +++ b/plugins/pluginsbyte.itarget @@ -1,6 +1,7 @@ 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 diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget index 5d502411..bbadfe69 100644 --- a/plugins/pluginsdyn.itarget +++ b/plugins/pluginsdyn.itarget @@ -1,6 +1,7 @@ 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 diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget index 2f72dab8..74b3f527 100644 --- a/plugins/pluginsopt.itarget +++ b/plugins/pluginsopt.itarget @@ -1,6 +1,7 @@ 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 diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v index 55bb8bae..e2d8e67e 100644 --- a/plugins/quote/Quote.v +++ b/plugins/quote/Quote.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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> in Tacinterp.interp tac diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index baba7e1b..fbb75420 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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) -> @@ -243,7 +240,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 +370,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 +390,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 +419,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 +427,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 +475,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..fd5bcd93 100644 --- a/plugins/ring/LegacyArithRing.v +++ b/plugins/ring/LegacyArithRing.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true | S n', S m' => nateq n' m' diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v index ae7e62e0..5dcd6d84 100644 --- a/plugins/ring/LegacyNArithRing.v +++ b/plugins/ring/LegacyNArithRing.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true | _ => false diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v index e53e60d3..d19e9f58 100644 --- a/plugins/ring/LegacyRing.v +++ b/plugins/ring/LegacyRing.v @@ -1,13 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* true | _ => false diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v index e6e2dda9..1763d70a 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 *) -(* n = m. Proof. @@ -749,11 +746,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. diff --git a/plugins/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v index da4e3756..106a946d 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 *) -(* n = m. Proof. @@ -1014,11 +1011,11 @@ 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. diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v index f07cbaf6..dd722f80 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 *) -(* 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); @@ -380,8 +377,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 +398,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 +440,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 = @@ -458,14 +461,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 +504,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 +518,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 +558,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 = @@ -575,14 +578,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 +619,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 = @@ -637,14 +640,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 +686,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 +698,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 +826,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 c82abfc8..56ae921e 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -868,11 +868,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 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 +1014,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 @@ -2038,12 +2038,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,7 +2069,7 @@ 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 |- *; [ intros; apply apply_both_stable; auto @@ -2453,7 +2453,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 @@ -2463,7 +2463,7 @@ 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 |- *; + simpl in |- *; auto; elim (t_rewrite_stable s e); simpl in |- *; intros H1 H2; elim H1. now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. Qed. @@ -2585,19 +2585,19 @@ 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 |- *; + elim (t_rewrite_stable s e); simpl in |- *; [ symmetry in |- *; apply egal_left; assumption | intro; apply le_left; assumption | intro; apply le_left; rewrite <- ge_le_iff; assumption @@ -2950,14 +2950,14 @@ 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 |- *; + [ Simplify; simpl in |- *; elim (t_rewrite_stable s e); simpl in |- *; [ symmetry in |- *; 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); + | case p; simpl in |- *; intros; auto; generalize H; elim (t_rewrite_stable s); simpl in |- *; intro H1; [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1; rewrite plus_permute; rewrite plus_opp_r; diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index f4368a1b..e810e15c 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,12 +328,12 @@ 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) | _ -> Tother @@ -334,17 +344,17 @@ 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 diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 570bb187..4a6d462e 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -219,7 +219,7 @@ 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 @@ -230,7 +230,7 @@ let get_reified_atom env = (* \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 diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 39c29a3d..77f8f834 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -1,154 +1,32 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* (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 ?= Psucc 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. + (Psucc 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. @@ -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. @@ -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,8 +245,9 @@ 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. +case_eq (i ?= index S);intro test. rewrite (Pcompare_Eq_eq _ _ test) in H. rewrite (get_Full_Eq _ F) in H;congruence. rewrite <- H. @@ -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..9cae7a44 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -1,22 +1,18 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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..8d103d1b 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 *) -(* !pruning); diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli index 4d77a057..b236aa72 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 *) -(* - 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..643433b0 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 *) -(* 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..06822ae1 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 *) -(* 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 _+_ _*_ -_ _==_. +intros. apply mk_reqe;intros. +rewrite H. rewrite H0. reflexivity. +rewrite H. rewrite H0. reflexivity. + rewrite H. reflexivity. 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 Zplus Zmult Zminus Zopp 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 Zminus. 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 _==_ Zplus Zmult 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 Zplus Zmult Zminus Zopp 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 Zmult_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 Zplus Zmult Zminus Zopp 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 (refl_equal 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 Zplus Zmult Zminus Zopp 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 (refl_equal 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..90f2f497 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 *) -(* Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. @@ -390,52 +390,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. @@ -460,8 +424,7 @@ 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 +441,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 *) @@ -507,7 +469,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 +482,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 +501,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. @@ -554,10 +516,10 @@ induction e1;destruct e2; simpl in |- *;try reflexivity; try (intro eq_c; rewrite eq_c in |- *); simpl in |- *; try reflexivity; try ring [(morph0 CRmorph) (morph1 CRmorph)]. apply (morph_mul CRmorph). -assert (H:=N_eq_correct n n0);destruct (N_eq n n0). +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. @@ -760,6 +722,14 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc)). + Lemma Z_pos_sub_gt : forall p q, (p > q)%positive -> + Z.pos_sub p q = Zpos (p - q). + Proof. + intros. apply Z.pos_sub_gt. now apply 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 @@ -779,10 +749,12 @@ 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. + rewrite Z.pos_sub_spec. + case_eq ((p1 ?= p2)%positive);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 (p2 - p1 =? 1)%positive. fold (NPEpow e2 (Npos (p2 - p1))). rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. @@ -790,22 +762,17 @@ Proof. 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))). + change (Z.pos_sub p1 (p1-p2)) with (Zpos p1 - Zpos (p1 -p2))%Z. 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. + rewrite Zplus_assoc, Z.add_opp_diag_r. 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. + simpl. now simpl_pos_sub. 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). @@ -835,7 +802,7 @@ 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) == @@ -845,11 +812,10 @@ destruct n. split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial. repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4). - unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. - rewrite H2 in H1;simpl in H1. + 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 * @@ -863,11 +829,11 @@ destruct n. (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. + simpl. rewrite Z.pos_sub_diag. 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. + 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 +844,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. @@ -937,8 +902,7 @@ 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]. + intros (H, Hgt). simpl_pos_sub. simpl in H;split;try ring [H]. rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial. simpl;intros. repeat rewrite NPEmul_correct;simpl. rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)]. @@ -1805,25 +1769,24 @@ Lemma gen_phiPOS_inj : forall x y, x = y. intros x y. repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *. -ElimPcompare x y; intro. +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. + now apply Pos.lt_gt. + 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. + now apply Pos.lt_gt. Qed. @@ -1841,12 +1804,9 @@ 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. diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index 026e70c8..763dbe7b 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 *) -(* 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. @@ -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. @@ -486,10 +444,10 @@ induction w1; intros. simpl in H. rewrite gen_phiNword_cons in |- *. - case_eq (Neq_bool a n); intros. + 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. @@ -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. diff --git a/plugins/setoid_ring/Integral_domain.v b/plugins/setoid_ring/Integral_domain.v new file mode 100644 index 00000000..5a224e38 --- /dev/null +++ b/plugins/setoid_ring/Integral_domain.v @@ -0,0 +1,44 @@ +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_Psucc. cring. apply ring_setoid. +apply ring_mult_comp. +apply cring_mul_comm. +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..fafd16ab 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 *) -(* 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..9a30fa47 --- /dev/null +++ b/plugins/setoid_ring/Ncring.v @@ -0,0 +1,305 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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. +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_Psucc : forall x j, pow_pos x (Psucc 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_Pplus : forall x i j, + pow_pos x (i + j) == pow_pos x i * pow_pos x j. + Proof. + intro x;induction i;intros. + rewrite xI_succ_xO;rewrite Pplus_one_succ_r. + rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. + repeat rewrite IHi. + rewrite Pplus_comm;rewrite <- Pplus_one_succ_r; + rewrite pow_pos_Psucc. + simpl;repeat rewrite ring_mul_assoc. reflexivity. + rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc. + repeat rewrite IHi. rewrite ring_mul_assoc. reflexivity. + rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc. + 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..3c79f7d9 --- /dev/null +++ b/plugins/setoid_ring/Ncring_initial.v @@ -0,0 +1,221 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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 (Psucc 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 Pplus_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. + rewrite Z.pos_sub_spec. + assert (HH0 := Pminus_mask_Gt x y). unfold Pos.gt in HH0. + assert (HH1 := Pminus_mask_Gt y x). unfold Pos.gt in HH1. + rewrite Pos.compare_antisym in HH1. + destruct (Pos.compare_spec x y) as [HH|HH|HH]. + subst. rewrite ring_opp_def;reflexivity. + destruct HH1 as [h [HHeq1 [HHeq2 HHor]]];trivial. + unfold Pminus; rewrite HHeq1;rewrite <- HHeq2. + rewrite ARgen_phiPOS_add;simpl;norm. + rewrite ring_opp_def;norm. + destruct HH0 as [h [HHeq1 [HHeq2 HHor]]];trivial. + unfold Pminus; rewrite HHeq1;rewrite <- HHeq2. + rewrite ARgen_phiPOS_add;simpl;norm. + add_push (gen_phiPOS1 h). 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 (Zminus x y) with (x + (-y))%Z. rewrite gen_phiZ_add. +rewrite gen_phiZ_opp. rewrite ring_sub_def. reflexivity. +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..c0d31587 --- /dev/null +++ b/plugins/setoid_ring/Ncring_polynom.v @@ -0,0 +1,621 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* : 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 Pcompare i i' Eq, Pcompare n n' Eq 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 Pcompare i i' Eq 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 Pcompare i i' Eq with + | (* i > i' *) + Gt => mkPX P i n Q + | (* i < i' *) + Lt => mkPX P' i' n' (PaddX i n Q') + | (* i = i' *) + Eq => match ZPminus 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 *) + Lemma ZPminus_spec : forall x y, + match ZPminus x y with + | Z0 => x = y + | Zpos k => x = (y + k)%positive + | Zneg k => y = (x + k)%positive + end. + Proof. + induction x;destruct y. + replace (ZPminus (xI x) (xI y)) with (Zdouble (ZPminus x y));trivial. + assert (Hh := IHx y);destruct (ZPminus x y);unfold Zdouble; +rewrite Hh;trivial. + replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y)); +trivial. + assert (Hh := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one; +rewrite Hh;trivial. + apply Pplus_xI_double_minus_one. + simpl;trivial. + replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y)); +trivial. + assert (Hh := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one; +rewrite Hh;trivial. + apply Pplus_xI_double_minus_one. + replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial. + assert (Hh := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite Hh; +trivial. + replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO;trivial. + replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial. + replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial. + rewrite <- Pplus_one_succ_l. + rewrite Psucc_o_double_minus_one_eq_xO;trivial. + simpl;trivial. + Qed. + + Lemma Peq_ok : forall P P', + (P =? P') = true -> forall l, P@l == P'@ l. + Proof. + induction P;destruct P';simpl;intros;try discriminate;trivial. + apply ring_morphism_eq. + apply Ceqb_eq ;trivial. + assert (H1h := IHP1 P'1);assert (H2h := IHP2 P'2). + simpl in H1h. destruct (Peq P2 P'1). simpl in H2h; +destruct (Peq P3 P'2). + rewrite (H1h);trivial . rewrite (H2h);trivial. +assert (H3h := Pcompare_Eq_eq p p1); + destruct (Pos.compare_cont p p1 Eq); +assert (H4h := Pcompare_Eq_eq p0 p2); +destruct (Pos.compare_cont p0 p2 Eq); try (discriminate H). + rewrite H3h;trivial. rewrite H4h;trivial. reflexivity. + destruct (Pos.compare_cont p p1 Eq); destruct (Pos.compare_cont p0 p2 Eq); + try (discriminate H). + destruct (Pos.compare_cont p p1 Eq); destruct (Pos.compare_cont p0 p2 Eq); + try (discriminate H). + 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. assert (Hh1 := Pcompare_Eq_eq i p); +destruct (Pos.compare_cont i p Eq). + assert (Hh := @Peq_ok P3 P0). case_eq (P3=? P0). intro. simpl. + rewrite Hh. + rewrite Pphi0. rsimpl. rewrite Pplus_comm. rewrite pow_pos_Pplus;rsimpl. +rewrite Hh1;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 Pcompare i i' Eq 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 ZPminus 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. assert (Hh := Pcompare_Eq_eq k p); + destruct (Pos.compare_cont k p Eq). + assert (H1h := ZPminus_spec n p0);destruct (ZPminus n p0). Esimpl2. +rewrite Hh; trivial. rewrite H1h. reflexivity. +simpl. rewrite mkPX_ok. rewrite IHP1. Esimpl2. + rewrite Pplus_comm in H1h. +rewrite H1h. +rewrite pow_pos_Pplus. Esimpl2. +rewrite Hh; trivial. reflexivity. +rewrite mkPX_ok. rewrite PaddCl_ok. Esimpl2. rewrite Pplus_comm in H1h. +rewrite H1h. Esimpl2. rewrite pow_pos_Pplus. 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. +assert (H3h := Pcompare_Eq_eq k p1); + destruct (Pos.compare_cont k p1 Eq). +assert (H4h := ZPminus_spec n p2);destruct (ZPminus n p2). +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 Pplus_comm in H4h. +rewrite H4h. rewrite pow_pos_Pplus. Esimpl2. +rewrite mkPX_ok. simpl. rewrite H0. rewrite H1. +rewrite mkPX_ok. + Esimpl2. rewrite H3h;trivial. + rewrite Pplus_comm in H4h. +rewrite H4h. rewrite pow_pos_Pplus. 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..34731eb3 --- /dev/null +++ b/plugins/setoid_ring/Ncring_tac.v @@ -0,0 +1,308 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* 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 Zplus Zmult Zminus Zopp (@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 (refl_equal 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 Zplus Zmult Zminus Zopp (@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/Ring.v b/plugins/setoid_ring/Ring.v index 7b48f590..c44c2edf 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 *) -(* Cpow. Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. @@ -104,12 +104,12 @@ 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 @@ -435,7 +435,7 @@ Section MakeRingPol. 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 +449,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 @@ -552,10 +552,10 @@ Section MakeRingPol. 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); + assert (H1 := Pos.compare_eq p p0); destruct (p ?= p0); try discriminate H. rewrite (IHP P' H); rewrite H1;trivial;rrefl. - assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq); + assert (H1 := Pos.compare_eq p p0); destruct (p ?= p0); try discriminate H. rewrite H1;trivial. clear H1. assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2); @@ -947,8 +947,8 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. 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). + case_eq (i ?= j); intros He; simpl. + rewrite (Pos.compare_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)); @@ -987,8 +987,8 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. 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). + case_eq (i ?= j); intros He; simpl. + rewrite (Pos.compare_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. diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 4fbdcbaa..ab992552 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -1,6 +1,6 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* Cpow. Variable rpow : R -> Cpow -> R. @@ -590,6 +590,21 @@ 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] => 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..88904865 --- /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 Zmult_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..d3ed36ee 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 *) -(* 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 diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 820246af..9d61c06d 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 *) -(* 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..5ed335d0 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. *) @@ -210,7 +213,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 +221,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 +234,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..03d76f29 100644 --- a/plugins/subtac/eterm.mli +++ b/plugins/subtac/eterm.mli @@ -1,12 +1,11 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* errorlabstrm "Program" (Cerrors.explain_exn exn) + with 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..710149ae 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -1,13 +1,12 @@ (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* 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 +141,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 +171,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 +218,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 + | e -> + (* msg_warning (str "Uncaught exception: " ++ Errors.print e); *) + raise e diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml index 25aec39c..368d8bac 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 *) -(* 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 * @@ -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 = @@ -1518,7 +1515,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 +1531,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 +1545,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 +1604,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 +1741,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 +1783,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, diff --git a/plugins/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli index bc2b2bb7..77537d33 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 *) -(* 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 @@ -113,11 +114,12 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p 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 +140,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 @@ -173,10 +179,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..5b5c0203 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 *) -(* 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..74f31a90 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 *) -(* 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 @@ -330,8 +327,8 @@ module Coercion = struct let apply_pattern_coercion loc pat p = List.fold_left (fun pat (co,n) -> - let f i = if i - 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 +427,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. *) diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml index a83611a4..ecae6759 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 @@ -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 @@ -417,7 +417,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 @@ -506,7 +506,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 +514,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 d3a63410..64d9f72c 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 _ -> 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 ( @@ -437,7 +498,7 @@ 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 -> pperror (Errors.print (Cerrors.process_vernac_interp_error e)) in match res with | Remain n when n > 0 -> @@ -485,10 +546,11 @@ and solve_obligation_by_tac prg obls i tac = true else false with - | Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s))) - | Stdpp.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) + user_err_loc (fst obl.obl_location, "solve_obligation", Lazy.force s) + | Util.Anomaly _ as e -> raise e | e -> false and solve_prg_obligations prg tac = @@ -556,7 +618,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 +630,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 @@ -604,8 +663,8 @@ let admit_obligations n = 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..7c0d1232 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 *) -(* 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 @@ -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..d5d427c7 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 *) -(* 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,17 @@ 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 -> 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 = @@ -329,13 +327,13 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | _ -> 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 := @@ -353,10 +351,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | _ -> 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 = j_nf_evar !evdref (apply_rec env 1 fj ftycon args) in let resj = match kind_of_term resj.uj_val with | App (f,args) when isInd f or isConst f -> @@ -367,7 +365,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 +383,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 +432,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 +452,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 +467,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 +492,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,11 +503,11 @@ 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 + 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 f cs b = let n = rel_context_length cs.cs_args 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 -> @@ -560,18 +558,9 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct 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 +575,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 +588,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 +596,19 @@ 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 ~onlyargs:true + ~split:true ~fail:true env !evdref; + evdref := Typeclasses.resolve_typeclasses ~onlyargs:false + ~split:true ~fail:false env !evdref + with 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 diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml index 362c4ddc..28bbdd35 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 @@ -253,7 +242,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 @@ -356,7 +345,7 @@ let destruct_ex ext ex = | _ -> [acc] in aux ex ext -open Rawterm +open Glob_term let id_of_name = function Name n -> n @@ -418,7 +407,6 @@ let string_of_intset d = open Printer open Ppconstr open Nameops -open Termops open Evd let pr_meta_map evd = @@ -430,11 +418,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 +433,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 +451,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 +474,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..de96cc60 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 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..446ae522 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 *) -(* 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 +56,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 +73,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..19a3c899 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 *) -(* 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,7 +143,7 @@ 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) @@ -176,24 +174,24 @@ let height bi = (* 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 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); + GApp (dloc, ref_WW, [GHole (dloc, Evd.InternalHole); decomp (sub_1 hgt) h; decomp (sub_1 hgt) 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 + let ref_constructor i = GRef (dloc, bigN_constructor i) in + let result h word = GApp (dloc, ref_constructor h, if less_than h n_inlined then [word] else [Nat_syntax.nat_of_int dloc (sub h n_inlined); @@ -217,7 +215,7 @@ 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 -> + | GApp (_,GRef(_,c), [_;lft;rght]) when c = zn2z_WW -> let hleft = get_height lft in let hright = get_height rght in add_1 @@ -229,8 +227,8 @@ let bigint_of_word = 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 + | GApp (_,GRef(_,c),_) when c = zn2z_W0-> zero + | GApp (_,GRef(_,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) @@ -242,8 +240,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 = @@ -259,7 +257,7 @@ 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)) + GRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i)) else [] in @@ -276,17 +274,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 +303,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 +324,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..b9c0bcd6 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 *) -(* 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..f8bce8f7 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 *) -(* 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 *) -(* str "" + | TacArg (_,Tacexp t) -> str "" | t -> str "" ;; @@ -56,13 +56,11 @@ let pr_rule_xml pr = function hov 2 (str "" ++ 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 "" | Daimon -> str "" | Decl_proof _ -> str "" -(* | Change_evars -> str ""*) ;; let pr_var_decl_xml env (id,c,typ) = @@ -115,11 +113,11 @@ let pr_subgoal_metas_xml metas env= 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 "" ++ fnl () ++ str "" ++ (pr_context_xml env)) ++ fnl () ++ str "") @@ -129,23 +127,9 @@ let pr_goal_xml g = fnl () ++ str "") ;; -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 "" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "" - | Some(r,spfl) -> - hov 2 (str "" ++ 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 "" -;; - 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 *) -(* - 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 *) -(* + | 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 "\n" ; X.xml_cdata ("\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 *) -(* 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 *) -(*