summaryrefslogtreecommitdiff
path: root/plugins
diff options
context:
space:
mode:
Diffstat (limited to 'plugins')
-rw-r--r--plugins/cc/ccalgo.ml98
-rw-r--r--plugins/cc/ccalgo.mli13
-rw-r--r--plugins/cc/ccproof.ml10
-rw-r--r--plugins/cc/ccproof.mli4
-rw-r--r--plugins/cc/cctac.ml47
-rw-r--r--plugins/cc/cctac.mli4
-rw-r--r--plugins/cc/g_congruence.ml44
-rw-r--r--plugins/decl_mode/decl_expr.mli103
-rw-r--r--plugins/decl_mode/decl_interp.ml471
-rw-r--r--plugins/decl_mode/decl_interp.mli16
-rw-r--r--plugins/decl_mode/decl_mode.ml123
-rw-r--r--plugins/decl_mode/decl_mode.mli78
-rw-r--r--plugins/decl_mode/decl_mode_plugin.mllib6
-rw-r--r--plugins/decl_mode/decl_proof_instr.ml1501
-rw-r--r--plugins/decl_mode/decl_proof_instr.mli109
-rw-r--r--plugins/decl_mode/g_decl_mode.ml4408
-rw-r--r--plugins/decl_mode/ppdecl_proof.ml188
-rw-r--r--plugins/decl_mode/ppdecl_proof.mli2
-rw-r--r--plugins/dp/Dp.v2
-rw-r--r--plugins/dp/dp.ml23
-rw-r--r--plugins/dp/g_dp.ml44
-rw-r--r--plugins/dp/test2.v2
-rw-r--r--plugins/dp/zenon.v2
-rw-r--r--plugins/extraction/ExtrOcamlBasic.v4
-rw-r--r--plugins/extraction/ExtrOcamlBigIntConv.v2
-rw-r--r--plugins/extraction/ExtrOcamlIntConv.v2
-rw-r--r--plugins/extraction/ExtrOcamlNatBigInt.v6
-rw-r--r--plugins/extraction/ExtrOcamlNatInt.v8
-rw-r--r--plugins/extraction/ExtrOcamlString.v2
-rw-r--r--plugins/extraction/ExtrOcamlZBigInt.v70
-rw-r--r--plugins/extraction/ExtrOcamlZInt.v66
-rw-r--r--plugins/extraction/big.ml2
-rw-r--r--plugins/extraction/common.ml37
-rw-r--r--plugins/extraction/common.mli15
-rw-r--r--plugins/extraction/extract_env.ml128
-rw-r--r--plugins/extraction/extract_env.mli10
-rw-r--r--plugins/extraction/extraction.ml178
-rw-r--r--plugins/extraction/extraction.mli4
-rw-r--r--plugins/extraction/g_extraction.ml48
-rw-r--r--plugins/extraction/haskell.ml158
-rw-r--r--plugins/extraction/haskell.mli4
-rw-r--r--plugins/extraction/miniml.mli50
-rw-r--r--plugins/extraction/mlutil.ml287
-rw-r--r--plugins/extraction/mlutil.mli11
-rw-r--r--plugins/extraction/modutil.ml91
-rw-r--r--plugins/extraction/modutil.mli7
-rw-r--r--plugins/extraction/ocaml.ml327
-rw-r--r--plugins/extraction/ocaml.mli4
-rw-r--r--plugins/extraction/scheme.ml29
-rw-r--r--plugins/extraction/scheme.mli4
-rw-r--r--plugins/extraction/table.ml219
-rw-r--r--plugins/extraction/table.mli38
-rw-r--r--plugins/field/LegacyField.v4
-rw-r--r--plugins/field/LegacyField_Compl.v4
-rw-r--r--plugins/field/LegacyField_Tactic.v4
-rw-r--r--plugins/field/LegacyField_Theory.v4
-rw-r--r--plugins/field/field.ml416
-rw-r--r--plugins/firstorder/formula.ml4
-rw-r--r--plugins/firstorder/formula.mli4
-rw-r--r--plugins/firstorder/g_ground.ml47
-rw-r--r--plugins/firstorder/ground.ml32
-rw-r--r--plugins/firstorder/ground.mli4
-rw-r--r--plugins/firstorder/instances.ml18
-rw-r--r--plugins/firstorder/instances.mli4
-rw-r--r--plugins/firstorder/rules.ml4
-rw-r--r--plugins/firstorder/rules.mli4
-rw-r--r--plugins/firstorder/sequent.ml71
-rw-r--r--plugins/firstorder/sequent.mli4
-rw-r--r--plugins/firstorder/unify.ml7
-rw-r--r--plugins/firstorder/unify.mli4
-rw-r--r--plugins/fourier/Fourier.v4
-rw-r--r--plugins/fourier/Fourier_util.v4
-rw-r--r--plugins/fourier/fourier.ml4
-rw-r--r--plugins/fourier/fourierR.ml40
-rw-r--r--plugins/fourier/g_fourier.ml44
-rw-r--r--plugins/funind/Recdef.v2
-rw-r--r--plugins/funind/functional_principles_proofs.ml62
-rw-r--r--plugins/funind/functional_principles_types.ml61
-rw-r--r--plugins/funind/functional_principles_types.mli6
-rw-r--r--plugins/funind/g_indfun.ml4118
-rw-r--r--plugins/funind/glob_term_to_relation.ml (renamed from plugins/funind/rawterm_to_relation.ml)298
-rw-r--r--plugins/funind/glob_term_to_relation.mli (renamed from plugins/funind/rawterm_to_relation.mli)4
-rw-r--r--plugins/funind/glob_termops.ml (renamed from plugins/funind/rawtermops.ml)438
-rw-r--r--plugins/funind/glob_termops.mli126
-rw-r--r--plugins/funind/indfun.ml549
-rw-r--r--plugins/funind/indfun.mli24
-rw-r--r--plugins/funind/indfun_common.ml63
-rw-r--r--plugins/funind/indfun_common.mli15
-rw-r--r--plugins/funind/invfun.ml78
-rw-r--r--plugins/funind/merge.ml133
-rw-r--r--plugins/funind/rawtermops.mli126
-rw-r--r--plugins/funind/recdef.ml229
-rw-r--r--plugins/funind/recdef_plugin.mllib4
-rw-r--r--plugins/micromega/CheckerMaker.v5
-rw-r--r--plugins/micromega/Env.v16
-rw-r--r--plugins/micromega/EnvRing.v24
-rw-r--r--plugins/micromega/MExtraction.v19
-rw-r--r--plugins/micromega/OrderedRing.v2
-rw-r--r--plugins/micromega/Psatz.v20
-rw-r--r--plugins/micromega/QMicromega.v14
-rw-r--r--plugins/micromega/RMicromega.v480
-rw-r--r--plugins/micromega/Refl.v2
-rw-r--r--plugins/micromega/RingMicromega.v195
-rw-r--r--plugins/micromega/Tauto.v248
-rw-r--r--plugins/micromega/VarMap.v225
-rw-r--r--plugins/micromega/ZCoeff.v8
-rw-r--r--plugins/micromega/ZMicromega.v327
-rw-r--r--plugins/micromega/certificate.ml1244
-rw-r--r--plugins/micromega/coq_micromega.ml646
-rw-r--r--plugins/micromega/csdpcert.ml4
-rw-r--r--plugins/micromega/g_micromega.ml416
-rw-r--r--plugins/micromega/mfourier.ml179
-rw-r--r--plugins/micromega/micromega.ml4625
-rw-r--r--plugins/micromega/micromega.mli1080
-rw-r--r--plugins/micromega/micromega_plugin.mllib1
-rw-r--r--plugins/micromega/mutils.ml123
-rw-r--r--plugins/micromega/persistent_cache.ml79
-rw-r--r--plugins/micromega/polynomial.ml739
-rw-r--r--plugins/micromega/sos.ml74
-rw-r--r--plugins/micromega/sos.mli2
-rw-r--r--plugins/micromega/sos_types.ml2
-rw-r--r--plugins/nsatz/Nsatz.v599
-rw-r--r--plugins/nsatz/ideal.ml6
-rw-r--r--plugins/nsatz/nsatz.ml488
-rw-r--r--plugins/nsatz/polynom.ml5
-rw-r--r--plugins/nsatz/polynom.mli2
-rw-r--r--plugins/omega/Omega.v4
-rw-r--r--plugins/omega/OmegaLemmas.v9
-rw-r--r--plugins/omega/OmegaPlugin.v4
-rw-r--r--plugins/omega/PreOmega.v115
-rw-r--r--plugins/omega/coq_omega.ml357
-rw-r--r--plugins/omega/g_omega.ml44
-rw-r--r--plugins/omega/omega.ml4
-rw-r--r--plugins/pluginsbyte.itarget1
-rw-r--r--plugins/pluginsdyn.itarget1
-rw-r--r--plugins/pluginsopt.itarget1
-rw-r--r--plugins/quote/Quote.v5
-rw-r--r--plugins/quote/g_quote.ml46
-rw-r--r--plugins/quote/quote.ml28
-rw-r--r--plugins/ring/LegacyArithRing.v6
-rw-r--r--plugins/ring/LegacyNArithRing.v6
-rw-r--r--plugins/ring/LegacyRing.v4
-rw-r--r--plugins/ring/LegacyRing_theory.v4
-rw-r--r--plugins/ring/LegacyZArithRing.v6
-rw-r--r--plugins/ring/Ring_abstract.v6
-rw-r--r--plugins/ring/Ring_normalize.v15
-rw-r--r--plugins/ring/Setoid_ring.v4
-rw-r--r--plugins/ring/Setoid_ring_normalize.v15
-rw-r--r--plugins/ring/Setoid_ring_theory.v4
-rw-r--r--plugins/ring/g_ring.ml44
-rw-r--r--plugins/ring/ring.ml57
-rw-r--r--plugins/romega/ReflOmegaCore.v46
-rw-r--r--plugins/romega/const_omega.ml86
-rw-r--r--plugins/romega/refl_omega.ml4
-rw-r--r--plugins/rtauto/Bintree.v223
-rw-r--r--plugins/rtauto/Rtauto.v48
-rw-r--r--plugins/rtauto/g_rtauto.ml44
-rw-r--r--plugins/rtauto/proof_search.ml5
-rw-r--r--plugins/rtauto/proof_search.mli4
-rw-r--r--plugins/rtauto/refl_tauto.ml18
-rw-r--r--plugins/rtauto/refl_tauto.mli4
-rw-r--r--plugins/setoid_ring/Algebra_syntax.v25
-rw-r--r--plugins/setoid_ring/ArithRing.v6
-rw-r--r--plugins/setoid_ring/BinList.v2
-rw-r--r--plugins/setoid_ring/Cring.v272
-rw-r--r--plugins/setoid_ring/Field.v2
-rw-r--r--plugins/setoid_ring/Field_tac.v2
-rw-r--r--plugins/setoid_ring/Field_theory.v132
-rw-r--r--plugins/setoid_ring/InitialRing.v122
-rw-r--r--plugins/setoid_ring/Integral_domain.v44
-rw-r--r--plugins/setoid_ring/NArithRing.v4
-rw-r--r--plugins/setoid_ring/Ncring.v305
-rw-r--r--plugins/setoid_ring/Ncring_initial.v221
-rw-r--r--plugins/setoid_ring/Ncring_polynom.v621
-rw-r--r--plugins/setoid_ring/Ncring_tac.v308
-rw-r--r--plugins/setoid_ring/Ring.v2
-rw-r--r--plugins/setoid_ring/Ring_base.v2
-rw-r--r--plugins/setoid_ring/Ring_polynom.v24
-rw-r--r--plugins/setoid_ring/Ring_theory.v19
-rw-r--r--plugins/setoid_ring/Rings_Q.v30
-rw-r--r--plugins/setoid_ring/Rings_R.v34
-rw-r--r--plugins/setoid_ring/Rings_Z.v14
-rw-r--r--plugins/setoid_ring/ZArithRing.v8
-rw-r--r--plugins/setoid_ring/newring.ml469
-rw-r--r--plugins/setoid_ring/vo.itarget10
-rw-r--r--plugins/subtac/eterm.ml19
-rw-r--r--plugins/subtac/eterm.mli3
-rw-r--r--plugins/subtac/g_subtac.ml416
-rw-r--r--plugins/subtac/subtac.ml28
-rw-r--r--plugins/subtac/subtac_cases.ml51
-rw-r--r--plugins/subtac/subtac_cases.mli6
-rw-r--r--plugins/subtac/subtac_classes.ml39
-rw-r--r--plugins/subtac/subtac_classes.mli6
-rw-r--r--plugins/subtac/subtac_coercion.ml21
-rw-r--r--plugins/subtac/subtac_command.ml64
-rw-r--r--plugins/subtac/subtac_command.mli8
-rw-r--r--plugins/subtac/subtac_obligations.ml171
-rw-r--r--plugins/subtac/subtac_obligations.mli2
-rw-r--r--plugins/subtac/subtac_pretyping.ml19
-rw-r--r--plugins/subtac/subtac_pretyping.mli2
-rw-r--r--plugins/subtac/subtac_pretyping_F.ml167
-rw-r--r--plugins/subtac/subtac_utils.ml44
-rw-r--r--plugins/subtac/subtac_utils.mli14
-rw-r--r--plugins/syntax/ascii_syntax.ml16
-rw-r--r--plugins/syntax/nat_syntax.ml18
-rw-r--r--plugins/syntax/numbers_syntax.ml72
-rw-r--r--plugins/syntax/r_syntax.ml44
-rw-r--r--plugins/syntax/string_syntax.ml16
-rw-r--r--plugins/syntax/z_syntax.ml81
-rw-r--r--plugins/xml/acic.ml2
-rw-r--r--plugins/xml/acic2Xml.ml42
-rw-r--r--plugins/xml/cic2acic.ml2
-rw-r--r--plugins/xml/doubleTypeInference.ml4
-rw-r--r--plugins/xml/doubleTypeInference.mli2
-rw-r--r--plugins/xml/dumptree.ml432
-rw-r--r--plugins/xml/proof2aproof.ml108
-rw-r--r--plugins/xml/proofTree2Xml.ml421
-rw-r--r--plugins/xml/unshare.ml2
-rw-r--r--plugins/xml/unshare.mli2
-rw-r--r--plugins/xml/xml.ml42
-rw-r--r--plugins/xml/xml.mli4
-rw-r--r--plugins/xml/xmlcommand.ml46
-rw-r--r--plugins/xml/xmlcommand.mli4
-rw-r--r--plugins/xml/xmlentries.ml44
224 files changed, 16461 insertions, 6772 deletions
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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ccalgo.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* This file implements the basic congruence-closure algorithm by *)
(* Downey,Sethi and Tarjan. *)
@@ -30,6 +28,7 @@ let debug f x =
let _=
let gdopt=
{ optsync=true;
+ optdepr=false;
optname="Congruence Verbose";
optkey=["Congruence";"Verbose"];
optread=(fun ()-> !cc_verbose);
@@ -105,6 +104,26 @@ type term=
| Appli of term*term
| Constructor of cinfo (* constructor arity + nhyps *)
+let rec term_equal t1 t2 =
+ match t1, t2 with
+ | Symb c1, Symb c2 -> eq_constr c1 c2
+ | Product (s1, t1), Product (s2, t2) -> s1 = s2 && t1 = t2
+ | Eps i1, Eps i2 -> id_ord i1 i2 = 0
+ | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2
+ | Constructor {ci_constr=c1; ci_arity=i1; ci_nhyps=j1},
+ Constructor {ci_constr=c2; ci_arity=i2; ci_nhyps=j2} ->
+ i1 = i2 && j1 = j2 && eq_constructor c1 c2
+ | _ -> t1 = t2
+
+open Hashtbl_alt.Combine
+
+let rec hash_term = function
+ | Symb c -> combine 1 (hash_constr c)
+ | Product (s1, s2) -> combine3 2 (Hashtbl.hash s1) (Hashtbl.hash s2)
+ | Eps i -> combine 3 (Hashtbl.hash i)
+ | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2)
+ | Constructor {ci_constr=c; ci_arity=i; ci_nhyps=j} -> combine4 5 (Hashtbl.hash c) i j
+
type ccpattern =
PApp of term * ccpattern list (* arguments are reversed *)
| PVar of int
@@ -172,13 +191,32 @@ type node =
vertex:vertex;
term:term}
+module Constrhash = Hashtbl.Make
+ (struct type t = constr
+ let equal = eq_constr
+ let hash = hash_constr
+ end)
+module Typehash = Constrhash
+
+module Termhash = Hashtbl.Make
+ (struct type t = term
+ let equal = term_equal
+ let hash = hash_term
+ end)
+
+module Identhash = Hashtbl.Make
+ (struct type t = identifier
+ let equal = Pervasives.(=)
+ let hash = Hashtbl.hash
+ end)
+
type forest=
{mutable max_size:int;
mutable size:int;
mutable map: node array;
- axioms: (constr,term*term) Hashtbl.t;
+ axioms: (term*term) Constrhash.t;
mutable epsilons: pa_constructor list;
- syms:(term,int) Hashtbl.t}
+ syms: int Termhash.t}
type state =
{uf: forest;
@@ -189,10 +227,10 @@ type state =
mutable diseq: disequality list;
mutable quant: quant_eq list;
mutable pa_classes: Intset.t;
- q_history: (identifier,int array) Hashtbl.t;
+ q_history: (int array) Identhash.t;
mutable rew_depth:int;
mutable changed:bool;
- by_type: (types,Intset.t) Hashtbl.t;
+ by_type: Intset.t Typehash.t;
mutable gls:Proof_type.goal Tacmach.sigma}
let dummy_node =
@@ -207,8 +245,8 @@ let empty depth gls:state =
size=0;
map=Array.create init_size dummy_node;
epsilons=[];
- axioms=Hashtbl.create init_size;
- syms=Hashtbl.create init_size};
+ axioms=Constrhash.create init_size;
+ syms=Termhash.create init_size};
terms=Intset.empty;
combine=Queue.create ();
marks=Queue.create ();
@@ -216,9 +254,9 @@ let empty depth gls:state =
diseq=[];
quant=[];
pa_classes=Intset.empty;
- q_history=Hashtbl.create init_size;
+ q_history=Identhash.create init_size;
rew_depth=depth;
- by_type=Hashtbl.create init_size;
+ by_type=Constrhash.create init_size;
changed=false;
gls=gls}
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ccalgo.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util
open Term
open Names
@@ -24,6 +22,8 @@ type term =
| Appli of term*term
| Constructor of cinfo (* constructor arity + nhyps *)
+val term_equal : term -> term -> bool
+
type patt_kind =
Normal
| Trivial of types
@@ -66,13 +66,16 @@ type explanation =
| Contradiction of disequality
| Incomplete
+module Constrhash : Hashtbl.S with type key = constr
+module Termhash : Hashtbl.S with type key = term
+
val constr_of_term : term -> constr
val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit
val forest : state -> forest
-val axioms : forest -> (constr, term * term) Hashtbl.t
+val axioms : forest -> (term * term) Constrhash.t
val epsilons : forest -> pa_constructor list
@@ -127,7 +130,7 @@ val do_match : state ->
val init_pb_stack : state -> matching_problem Stack.t
-val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun
+val paf_of_patt : int Termhash.t -> ccpattern -> pa_fun
val find_instances : state -> (quant_eq * int array) list
diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml
index 6981c5a0..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ccproof.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* This file uses the (non-compressed) union-find structure to generate *)
(* proof-trees that will be transformed into proof-terms in cctac.ml4 *)
@@ -45,7 +43,7 @@ let rec ptrans p1 p3=
| Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) ->
ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5
| _, _ ->
- if p1.p_rhs = p3.p_lhs then
+ if term_equal p1.p_rhs p3.p_lhs then
{p_lhs=p1.p_lhs;
p_rhs=p3.p_rhs;
p_rule=Trans (p1,p3)}
@@ -70,13 +68,13 @@ let rec psym p =
| Congr (p1,p2)-> pcongr (psym p1) (psym p2)
let pax axioms s =
- let l,r = Hashtbl.find axioms s in
+ let l,r = Constrhash.find axioms s in
{p_lhs=l;
p_rhs=r;
p_rule=Ax s}
let psymax axioms s =
- let l,r = Hashtbl.find axioms s in
+ let l,r = Constrhash.find axioms s in
{p_lhs=r;
p_rhs=l;
p_rule=SymAx s}
diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli
index a58637f9..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ccproof.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Ccalgo
open Names
open Term
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
index 5b477b4d..ec31f891 100644
--- a/plugins/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,8 +8,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: cctac.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* This file is the interface between the c-c algorithm and Coq *)
open Evd
@@ -20,7 +18,6 @@ open Nameops
open Inductiveops
open Declarations
open Term
-open Termops
open Tacmach
open Tactics
open Tacticals
@@ -66,8 +63,8 @@ let rec decompose_term env sigma t=
let tf=decompose_term env sigma f in
let targs=Array.map (decompose_term env sigma) args in
Array.fold_left (fun s t->Appli (s,t)) tf targs
- | Prod (_,a,_b) when not (dependent (mkRel 1) _b) ->
- let b = pop _b in
+ | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) ->
+ let b = Termops.pop _b in
let sort_b = sf_of env sigma b in
let sort_a = sf_of env sigma a in
Appli(Appli(Product (sort_a,sort_b) ,
@@ -113,8 +110,8 @@ let rec pattern_of_constr env sigma c =
(array_map_to_list (pattern_of_constr env sigma) args) in
PApp (pf,List.rev pargs),
List.fold_left Intset.union Intset.empty lrels
- | Prod (_,a,_b) when not (dependent (mkRel 1) _b) ->
- let b =pop _b in
+ | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) ->
+ let b = Termops.pop _b in
let pa,sa = pattern_of_constr env sigma a in
let pb,sb = pattern_of_constr env sigma b in
let sort_b = sf_of env sigma b in
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: cctac.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Term
open Proof_type
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index eb58c5eb..881b9bee 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,8 +8,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_congruence.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Cctac
open Tactics
open Tacticals
diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli
new file mode 100644
index 00000000..fa6acaeb
--- /dev/null
+++ b/plugins/decl_mode/decl_expr.mli
@@ -0,0 +1,103 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Names
+open Util
+open Tacexpr
+
+type 'it statement =
+ {st_label:name;
+ st_it:'it}
+
+type thesis_kind =
+ Plain
+ | For of identifier
+
+type 'this or_thesis =
+ This of 'this
+ | Thesis of thesis_kind
+
+type side = Lhs | Rhs
+
+type elim_type =
+ ET_Case_analysis
+ | ET_Induction
+
+type block_type =
+ B_proof
+ | B_claim
+ | B_focus
+ | B_elim of elim_type
+
+type ('it,'constr,'tac) cut =
+ {cut_stat: 'it;
+ cut_by: 'constr list option;
+ cut_using: 'tac option}
+
+type ('var,'constr) hyp =
+ Hvar of 'var
+ | Hprop of 'constr statement
+
+type ('constr,'tac) casee =
+ Real of 'constr
+ | Virtual of ('constr statement,'constr,'tac) cut
+
+type ('hyp,'constr,'pat,'tac) bare_proof_instr =
+ | Pthen of ('hyp,'constr,'pat,'tac) bare_proof_instr
+ | Pthus of ('hyp,'constr,'pat,'tac) bare_proof_instr
+ | Phence of ('hyp,'constr,'pat,'tac) bare_proof_instr
+ | Pcut of ('constr or_thesis statement,'constr,'tac) cut
+ | Prew of side * ('constr statement,'constr,'tac) cut
+ | Psuffices of ((('hyp,'constr) hyp list * 'constr or_thesis),'constr,'tac) cut
+ | Passume of ('hyp,'constr) hyp list
+ | Plet of ('hyp,'constr) hyp list
+ | Pgiven of ('hyp,'constr) hyp list
+ | Pconsider of 'constr*('hyp,'constr) hyp list
+ | Pclaim of 'constr statement
+ | Pfocus of 'constr statement
+ | Pdefine of identifier * 'hyp list * 'constr
+ | Pcast of identifier or_thesis * 'constr
+ | Psuppose of ('hyp,'constr) hyp list
+ | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list)
+ | Ptake of 'constr list
+ | Pper of elim_type * ('constr,'tac) casee
+ | Pend of block_type
+ | Pescape
+
+type emphasis = int
+
+type ('hyp,'constr,'pat,'tac) gen_proof_instr=
+ {emph: emphasis;
+ instr: ('hyp,'constr,'pat,'tac) bare_proof_instr }
+
+
+type raw_proof_instr =
+ ((identifier*(Topconstr.constr_expr option)) located,
+ Topconstr.constr_expr,
+ Topconstr.cases_pattern_expr,
+ raw_tactic_expr) gen_proof_instr
+
+type glob_proof_instr =
+ ((identifier*(Genarg.glob_constr_and_expr option)) located,
+ Genarg.glob_constr_and_expr,
+ Topconstr.cases_pattern_expr,
+ Tacexpr.glob_tactic_expr) gen_proof_instr
+
+type proof_pattern =
+ {pat_vars: Term.types statement list;
+ pat_aliases: (Term.constr*Term.types) statement list;
+ pat_constr: Term.constr;
+ pat_typ: Term.types;
+ pat_pat: Glob_term.cases_pattern;
+ pat_expr: Topconstr.cases_pattern_expr}
+
+type proof_instr =
+ (Term.constr statement,
+ Term.constr,
+ proof_pattern,
+ Tacexpr.glob_tactic_expr) gen_proof_instr
diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml
new file mode 100644
index 00000000..b3e076c4
--- /dev/null
+++ b/plugins/decl_mode/decl_interp.ml
@@ -0,0 +1,471 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Util
+open Names
+open Topconstr
+open Tacinterp
+open Tacmach
+open Decl_expr
+open Decl_mode
+open Pretyping.Default
+open Glob_term
+open Term
+open Pp
+open Compat
+
+(* INTERN *)
+
+let glob_app (loc,hd,args) = if args =[] then hd else GApp(loc,hd,args)
+
+let intern_justification_items globs =
+ Option.map (List.map (intern_constr globs))
+
+let intern_justification_method globs =
+ Option.map (intern_pure_tactic globs)
+
+let intern_statement intern_it globs st =
+ {st_label=st.st_label;
+ st_it=intern_it globs st.st_it}
+
+let intern_no_bind intern_it globs x =
+ globs,intern_it globs x
+
+let intern_constr_or_thesis globs = function
+ Thesis n -> Thesis n
+ | This c -> This (intern_constr globs c)
+
+let add_var id globs=
+ let l1,l2=globs.ltacvars in
+ {globs with ltacvars= (id::l1),(id::l2)}
+
+let add_name nam globs=
+ match nam with
+ Anonymous -> globs
+ | Name id -> add_var id globs
+
+let intern_hyp iconstr globs = function
+ Hvar (loc,(id,topt)) -> add_var id globs,
+ Hvar (loc,(id,Option.map (intern_constr globs) topt))
+ | Hprop st -> add_name st.st_label globs,
+ Hprop (intern_statement iconstr globs st)
+
+let intern_hyps iconstr globs hyps =
+ snd (list_fold_map (intern_hyp iconstr) globs hyps)
+
+let intern_cut intern_it globs cut=
+ let nglobs,nstat=intern_it globs cut.cut_stat in
+ {cut_stat=nstat;
+ cut_by=intern_justification_items nglobs cut.cut_by;
+ cut_using=intern_justification_method nglobs cut.cut_using}
+
+let intern_casee globs = function
+ Real c -> Real (intern_constr globs c)
+ | Virtual cut -> Virtual
+ (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut)
+
+let intern_hyp_list args globs =
+ let intern_one globs (loc,(id,opttyp)) =
+ (add_var id globs),
+ (loc,(id,Option.map (intern_constr globs) opttyp)) in
+ list_fold_map intern_one globs args
+
+let intern_suffices_clause globs (hyps,c) =
+ let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in
+ nglobs,(nhyps,intern_constr_or_thesis nglobs c)
+
+let intern_fundecl args body globs=
+ let nglobs,nargs = intern_hyp_list args globs in
+ nargs,intern_constr nglobs body
+
+let rec add_vars_of_simple_pattern globs = function
+ CPatAlias (loc,p,id) ->
+ add_vars_of_simple_pattern (add_var id globs) p
+(* Loc.raise loc
+ (UserError ("simple_pattern",str "\"as\" is not allowed here"))*)
+ | CPatOr (loc, _)->
+ Loc.raise loc
+ (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here"))
+ | CPatDelimiters (_,_,p) ->
+ add_vars_of_simple_pattern globs p
+ | CPatCstr (_,_,pl) | CPatCstrExpl (_,_,pl) ->
+ List.fold_left add_vars_of_simple_pattern globs pl
+ | CPatNotation(_,_,(pl,pll)) ->
+ List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll))
+ | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs
+ | _ -> globs
+
+let rec intern_bare_proof_instr globs = function
+ Pthus i -> Pthus (intern_bare_proof_instr globs i)
+ | Pthen i -> Pthen (intern_bare_proof_instr globs i)
+ | Phence i -> Phence (intern_bare_proof_instr globs i)
+ | Pcut c -> Pcut
+ (intern_cut
+ (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c)
+ | Psuffices c ->
+ Psuffices (intern_cut intern_suffices_clause globs c)
+ | Prew (s,c) -> Prew
+ (s,intern_cut
+ (intern_no_bind (intern_statement intern_constr)) globs c)
+ | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps)
+ | Pcase (params,pat,hyps) ->
+ let nglobs,nparams = intern_hyp_list params globs in
+ let nnglobs= add_vars_of_simple_pattern nglobs pat in
+ let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in
+ Pcase (nparams,pat,nhyps)
+ | Ptake witl -> Ptake (List.map (intern_constr globs) witl)
+ | Pconsider (c,hyps) -> Pconsider (intern_constr globs c,
+ intern_hyps intern_constr globs hyps)
+ | Pper (et,c) -> Pper (et,intern_casee globs c)
+ | Pend bt -> Pend bt
+ | Pescape -> Pescape
+ | Passume hyps -> Passume (intern_hyps intern_constr globs hyps)
+ | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps)
+ | Plet hyps -> Plet (intern_hyps intern_constr globs hyps)
+ | Pclaim st -> Pclaim (intern_statement intern_constr globs st)
+ | Pfocus st -> Pfocus (intern_statement intern_constr globs st)
+ | Pdefine (id,args,body) ->
+ let nargs,nbody = intern_fundecl args body globs in
+ Pdefine (id,nargs,nbody)
+ | Pcast (id,typ) ->
+ Pcast (id,intern_constr globs typ)
+
+let rec intern_proof_instr globs instr=
+ {emph = instr.emph;
+ instr = intern_bare_proof_instr globs instr.instr}
+
+(* INTERP *)
+
+let interp_justification_items sigma env =
+ Option.map (List.map (fun c ->understand sigma env (fst c)))
+
+let interp_constr check_sort sigma env c =
+ if check_sort then
+ understand_type sigma env (fst c)
+ else
+ understand sigma env (fst c)
+
+let special_whd env =
+ let infos=Closure.create_clos_infos Closure.betadeltaiota env in
+ (fun t -> Closure.whd_val infos (Closure.inject t))
+
+let _eq = Libnames.constr_of_global (Coqlib.glob_eq)
+
+let decompose_eq env id =
+ let typ = Environ.named_type id env in
+ let whd = special_whd env typ in
+ match kind_of_term whd with
+ App (f,args)->
+ if eq_constr f _eq && (Array.length args)=3
+ then args.(0)
+ else error "Previous step is not an equality."
+ | _ -> error "Previous step is not an equality."
+
+let get_eq_typ info env =
+ let typ = decompose_eq env (get_last env) in
+ typ
+
+let interp_constr_in_type typ sigma env c =
+ understand sigma env (fst c) ~expected_type:typ
+
+let interp_statement interp_it sigma env st =
+ {st_label=st.st_label;
+ st_it=interp_it sigma env st.st_it}
+
+let interp_constr_or_thesis check_sort sigma env = function
+ Thesis n -> Thesis n
+ | This c -> This (interp_constr check_sort sigma env c)
+
+let abstract_one_hyp inject h glob =
+ match h with
+ Hvar (loc,(id,None)) ->
+ GProd (dummy_loc,Name id, Explicit, GHole (loc,Evd.BinderType (Name id)), glob)
+ | Hvar (loc,(id,Some typ)) ->
+ GProd (dummy_loc,Name id, Explicit, fst typ, glob)
+ | Hprop st ->
+ GProd (dummy_loc,st.st_label, Explicit, inject st.st_it, glob)
+
+let glob_constr_of_hyps inject hyps head =
+ List.fold_right (abstract_one_hyp inject) hyps head
+
+let glob_prop = GSort (dummy_loc,GProp Null)
+
+let rec match_hyps blend names constr = function
+ [] -> [],substl names constr
+ | hyp::q ->
+ let (name,typ,body)=destProd constr in
+ let st= {st_label=name;st_it=substl names typ} in
+ let qnames=
+ match name with
+ Anonymous -> mkMeta 0 :: names
+ | Name id -> mkVar id :: names in
+ let qhyp = match hyp with
+ Hprop st' -> Hprop (blend st st')
+ | Hvar _ -> Hvar st in
+ let rhyps,head = match_hyps blend qnames body q in
+ qhyp::rhyps,head
+
+let interp_hyps_gen inject blend sigma env hyps head =
+ let constr=understand sigma env (glob_constr_of_hyps inject hyps head) in
+ match_hyps blend [] constr hyps
+
+let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma env hyps glob_prop)
+
+let dummy_prefix= id_of_string "__"
+
+let rec deanonymize ids =
+ function
+ PatVar (loc,Anonymous) ->
+ let (found,known) = !ids in
+ let new_id=Namegen.next_ident_away dummy_prefix known in
+ let _= ids:= (loc,new_id) :: found , new_id :: known in
+ PatVar (loc,Name new_id)
+ | PatVar (loc,Name id) as pat ->
+ let (found,known) = !ids in
+ let _= ids:= (loc,id) :: found , known in
+ pat
+ | PatCstr(loc,cstr,lpat,nam) ->
+ PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam)
+
+let rec glob_of_pat =
+ function
+ PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable"
+ | PatVar (loc,Name id) ->
+ GVar (loc,id)
+ | PatCstr(loc,((ind,_) as cstr),lpat,_) ->
+ let mind= fst (Global.lookup_inductive ind) in
+ let rec add_params n q =
+ if n<=0 then q else
+ add_params (pred n) (GHole(dummy_loc,
+ Evd.TomatchTypeParameter(ind,n))::q) in
+ let args = List.map glob_of_pat lpat in
+ glob_app(loc,GRef(dummy_loc,Libnames.ConstructRef cstr),
+ add_params mind.Declarations.mind_nparams args)
+
+let prod_one_hyp = function
+ (loc,(id,None)) ->
+ (fun glob ->
+ GProd (dummy_loc,Name id, Explicit,
+ GHole (loc,Evd.BinderType (Name id)), glob))
+ | (loc,(id,Some typ)) ->
+ (fun glob ->
+ GProd (dummy_loc,Name id, Explicit, fst typ, glob))
+
+let prod_one_id (loc,id) glob =
+ GProd (dummy_loc,Name id, Explicit,
+ GHole (loc,Evd.BinderType (Name id)), glob)
+
+let let_in_one_alias (id,pat) glob =
+ GLetIn (dummy_loc,Name id, glob_of_pat pat, glob)
+
+let rec bind_primary_aliases map pat =
+ match pat with
+ PatVar (_,_) -> map
+ | PatCstr(loc,_,lpat,nam) ->
+ let map1 =
+ match nam with
+ Anonymous -> map
+ | Name id -> (id,pat)::map
+ in
+ List.fold_left bind_primary_aliases map1 lpat
+
+let bind_secondary_aliases map subst =
+ List.fold_left (fun map (ids,idp) -> (ids,List.assoc idp map)::map) map subst
+
+let bind_aliases patvars subst patt =
+ let map = bind_primary_aliases [] patt in
+ let map1 = bind_secondary_aliases map subst in
+ List.rev map1
+
+let interp_pattern env pat_expr =
+ let patvars,pats = Constrintern.intern_pattern env pat_expr in
+ match pats with
+ [] -> anomaly "empty pattern list"
+ | [subst,patt] ->
+ (patvars,bind_aliases patvars subst patt,patt)
+ | _ -> anomaly "undetected disjunctive pattern"
+
+let rec match_args dest names constr = function
+ [] -> [],names,substl names constr
+ | _::q ->
+ let (name,typ,body)=dest constr in
+ let st={st_label=name;st_it=substl names typ} in
+ let qnames=
+ match name with
+ Anonymous -> assert false
+ | Name id -> mkVar id :: names in
+ let args,bnames,body = match_args dest qnames body q in
+ st::args,bnames,body
+
+let rec match_aliases names constr = function
+ [] -> [],names,substl names constr
+ | _::q ->
+ let (name,c,typ,body)=destLetIn constr in
+ let st={st_label=name;st_it=(substl names c,substl names typ)} in
+ let qnames=
+ match name with
+ Anonymous -> assert false
+ | Name id -> mkVar id :: names in
+ let args,bnames,body = match_aliases qnames body q in
+ st::args,bnames,body
+
+let detype_ground c = Detyping.detype false [] [] c
+
+let interp_cases info sigma env params (pat:cases_pattern_expr) hyps =
+ let et,pinfo =
+ match info.pm_stack with
+ Per(et,pi,_,_)::_ -> et,pi
+ | _ -> error "No proof per cases/induction/inversion in progress." in
+ let mib,oib=Global.lookup_inductive pinfo.per_ind in
+ let num_params = pinfo.per_nparams in
+ let _ =
+ let expected = mib.Declarations.mind_nparams - num_params in
+ if List.length params <> expected then
+ errorlabstrm "suppose it is"
+ (str "Wrong number of extra arguments: " ++
+ (if expected = 0 then str "none" else int expected) ++ spc () ++
+ str "expected.") in
+ let app_ind =
+ let rind = GRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in
+ let rparams = List.map detype_ground pinfo.per_params in
+ let rparams_rec =
+ List.map
+ (fun (loc,(id,_)) ->
+ GVar (loc,id)) params in
+ let dum_args=
+ list_tabulate (fun _ -> GHole (dummy_loc,Evd.QuestionMark (Evd.Define false)))
+ oib.Declarations.mind_nrealargs in
+ glob_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in
+ let pat_vars,aliases,patt = interp_pattern env pat in
+ let inject = function
+ Thesis (Plain) -> Glob_term.GSort(dummy_loc,GProp Null)
+ | Thesis (For rec_occ) ->
+ if not (List.mem rec_occ pat_vars) then
+ errorlabstrm "suppose it is"
+ (str "Variable " ++ Nameops.pr_id rec_occ ++
+ str " does not occur in pattern.");
+ Glob_term.GSort(dummy_loc,GProp Null)
+ | This (c,_) -> c in
+ let term1 = glob_constr_of_hyps inject hyps glob_prop in
+ let loc_ids,npatt =
+ let rids=ref ([],pat_vars) in
+ let npatt= deanonymize rids patt in
+ List.rev (fst !rids),npatt in
+ let term2 =
+ GLetIn(dummy_loc,Anonymous,
+ GCast(dummy_loc,glob_of_pat npatt,
+ CastConv (DEFAULTcast,app_ind)),term1) in
+ let term3=List.fold_right let_in_one_alias aliases term2 in
+ let term4=List.fold_right prod_one_id loc_ids term3 in
+ let term5=List.fold_right prod_one_hyp params term4 in
+ let constr = understand sigma env term5 in
+ let tparams,nam4,rest4 = match_args destProd [] constr params in
+ let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in
+ let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in
+ let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in
+ let blend st st' =
+ match st'.st_it with
+ Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label}
+ | This _ -> {st_it = This st.st_it;st_label=st.st_label} in
+ let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in
+ tparams,{pat_vars=tpatvars;
+ pat_aliases=taliases;
+ pat_constr=pat_pat;
+ pat_typ=pat_typ;
+ pat_pat=patt;
+ pat_expr=pat},thyps
+
+let interp_cut interp_it sigma env cut=
+ let nenv,nstat = interp_it sigma env cut.cut_stat in
+ {cut with
+ cut_stat=nstat;
+ cut_by=interp_justification_items sigma nenv cut.cut_by}
+
+let interp_no_bind interp_it sigma env x =
+ env,interp_it sigma env x
+
+let interp_suffices_clause sigma env (hyps,cot)=
+ let (locvars,_) as res =
+ match cot with
+ This (c,_) ->
+ let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in
+ nhyps,This nc
+ | Thesis Plain as th -> interp_hyps sigma env hyps,th
+ | Thesis (For n) -> error "\"thesis for\" is not applicable here." in
+ let push_one hyp env0 =
+ match hyp with
+ (Hprop st | Hvar st) ->
+ match st.st_label with
+ Name id -> Environ.push_named (id,None,st.st_it) env0
+ | _ -> env in
+ let nenv = List.fold_right push_one locvars env in
+ nenv,res
+
+let interp_casee sigma env = function
+ Real c -> Real (understand sigma env (fst c))
+ | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut)
+
+let abstract_one_arg = function
+ (loc,(id,None)) ->
+ (fun glob ->
+ GLambda (dummy_loc,Name id, Explicit,
+ GHole (loc,Evd.BinderType (Name id)), glob))
+ | (loc,(id,Some typ)) ->
+ (fun glob ->
+ GLambda (dummy_loc,Name id, Explicit, fst typ, glob))
+
+let glob_constr_of_fun args body =
+ List.fold_right abstract_one_arg args (fst body)
+
+let interp_fun sigma env args body =
+ let constr=understand sigma env (glob_constr_of_fun args body) in
+ match_args destLambda [] constr args
+
+let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = function
+ Pthus i -> Pthus (interp_bare_proof_instr info sigma env i)
+ | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i)
+ | Phence i -> Phence (interp_bare_proof_instr info sigma env i)
+ | Pcut c -> Pcut (interp_cut
+ (interp_no_bind (interp_statement
+ (interp_constr_or_thesis true)))
+ sigma env c)
+ | Psuffices c ->
+ Psuffices (interp_cut interp_suffices_clause sigma env c)
+ | Prew (s,c) -> Prew (s,interp_cut
+ (interp_no_bind (interp_statement
+ (interp_constr_in_type (get_eq_typ info env))))
+ sigma env c)
+
+ | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps)
+ | Pcase (params,pat,hyps) ->
+ let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in
+ Pcase (tparams,tpat,thyps)
+ | Ptake witl ->
+ Ptake (List.map (fun c -> understand sigma env (fst c)) witl)
+ | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c,
+ interp_hyps sigma env hyps)
+ | Pper (et,c) -> Pper (et,interp_casee sigma env c)
+ | Pend bt -> Pend bt
+ | Pescape -> Pescape
+ | Passume hyps -> Passume (interp_hyps sigma env hyps)
+ | Pgiven hyps -> Pgiven (interp_hyps sigma env hyps)
+ | Plet hyps -> Plet (interp_hyps sigma env hyps)
+ | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st)
+ | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st)
+ | Pdefine (id,args,body) ->
+ let nargs,_,nbody = interp_fun sigma env args body in
+ Pdefine (id,nargs,nbody)
+ | Pcast (id,typ) ->
+ Pcast(id,interp_constr true sigma env typ)
+
+let rec interp_proof_instr info sigma env instr=
+ {emph = instr.emph;
+ instr = interp_bare_proof_instr info sigma env instr.instr}
+
+
+
diff --git a/plugins/decl_mode/decl_interp.mli b/plugins/decl_mode/decl_interp.mli
new file mode 100644
index 00000000..46fbcec7
--- /dev/null
+++ b/plugins/decl_mode/decl_interp.mli
@@ -0,0 +1,16 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Tacinterp
+open Decl_expr
+open Mod_subst
+
+
+val intern_proof_instr : glob_sign -> raw_proof_instr -> glob_proof_instr
+val interp_proof_instr : Decl_mode.pm_info ->
+ Evd.evar_map -> Environ.env -> glob_proof_instr -> proof_instr
diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml
new file mode 100644
index 00000000..af6aa4bf
--- /dev/null
+++ b/plugins/decl_mode/decl_mode.ml
@@ -0,0 +1,123 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Names
+open Term
+open Evd
+open Util
+
+
+let daimon_flag = ref false
+
+let set_daimon_flag () = daimon_flag:=true
+let clear_daimon_flag () = daimon_flag:=false
+let get_daimon_flag () = !daimon_flag
+
+
+
+(* Information associated to goals. *)
+open Store.Field
+
+type split_tree=
+ Skip_patt of Idset.t * split_tree
+ | Split_patt of Idset.t * inductive *
+ (bool array * (Idset.t * split_tree) option) array
+ | Close_patt of split_tree
+ | End_patt of (identifier * (int * int))
+
+type elim_kind =
+ EK_dep of split_tree
+ | EK_nodep
+ | EK_unknown
+
+type recpath = int option*Declarations.wf_paths
+
+type per_info =
+ {per_casee:constr;
+ per_ctype:types;
+ per_ind:inductive;
+ per_pred:constr;
+ per_args:constr list;
+ per_params:constr list;
+ per_nparams:int;
+ per_wf:recpath}
+
+type stack_info =
+ Per of Decl_expr.elim_type * per_info * elim_kind * identifier list
+ | Suppose_case
+ | Claim
+ | Focus_claim
+
+type pm_info =
+ { pm_stack : stack_info list}
+let info = Store.field ()
+
+
+(* Current proof mode *)
+
+type command_mode =
+ Mode_tactic
+ | Mode_proof
+ | Mode_none
+
+let mode_of_pftreestate pts =
+ (* spiwack: it used to be "top_goal_..." but this should be fine *)
+ let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in
+ let goal = List.hd goals in
+ if info.get (Goal.V82.extra sigma goal) = None then
+ Mode_tactic
+ else
+ Mode_proof
+
+let get_current_mode () =
+ try
+ mode_of_pftreestate (Pfedit.get_pftreestate ())
+ with _ -> 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 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Names
+open Term
+open Evd
+open Tacmach
+
+val set_daimon_flag : unit -> unit
+val clear_daimon_flag : unit -> unit
+val get_daimon_flag : unit -> bool
+
+type command_mode =
+ Mode_tactic
+ | Mode_proof
+ | Mode_none
+
+val mode_of_pftreestate : Proof.proof -> command_mode
+
+val get_current_mode : unit -> command_mode
+
+val check_not_proof_mode : string -> unit
+
+type split_tree=
+ Skip_patt of Idset.t * split_tree
+ | Split_patt of Idset.t * inductive *
+ (bool array * (Idset.t * split_tree) option) array
+ | Close_patt of split_tree
+ | End_patt of (identifier * (int * int))
+
+type elim_kind =
+ EK_dep of split_tree
+ | EK_nodep
+ | EK_unknown
+
+type recpath = int option*Declarations.wf_paths
+
+type per_info =
+ {per_casee:constr;
+ per_ctype:types;
+ per_ind:inductive;
+ per_pred:constr;
+ per_args:constr list;
+ per_params:constr list;
+ per_nparams:int;
+ per_wf:recpath}
+
+type stack_info =
+ Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list
+ | Suppose_case
+ | Claim
+ | Focus_claim
+
+type pm_info =
+ {pm_stack : stack_info list }
+
+val info : pm_info Store.Field.t
+
+val get_info : Evd.evar_map -> Proof_type.goal -> pm_info
+
+val try_get_info : Evd.evar_map -> Proof_type.goal -> pm_info option
+
+val get_stack : Proof.proof -> stack_info list
+
+val get_top_stack : Proof.proof -> stack_info list
+
+val get_last: Environ.env -> identifier
+
+val focus : Proof.proof -> unit
+
+val unfocus : Proof.proof -> unit
+
+val maximal_unfocus : Proof.proof -> unit
diff --git a/plugins/decl_mode/decl_mode_plugin.mllib b/plugins/decl_mode/decl_mode_plugin.mllib
new file mode 100644
index 00000000..39342dbd
--- /dev/null
+++ b/plugins/decl_mode/decl_mode_plugin.mllib
@@ -0,0 +1,6 @@
+Decl_mode
+Decl_interp
+Decl_proof_instr
+Ppdecl_proof
+G_decl_mode
+Decl_mode_plugin_mod
diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml
new file mode 100644
index 00000000..c1553b35
--- /dev/null
+++ b/plugins/decl_mode/decl_proof_instr.ml
@@ -0,0 +1,1501 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Util
+open Pp
+open Evd
+
+open Refiner
+open Proof_type
+open Tacmach
+open Tacinterp
+open Decl_expr
+open Decl_mode
+open Decl_interp
+open Glob_term
+open Names
+open Nameops
+open Declarations
+open Tactics
+open Tacticals
+open Term
+open Termops
+open Namegen
+open Reductionops
+open Goptions
+
+
+(* Strictness option *)
+
+let get_its_info gls = get_info gls.sigma gls.it
+
+let get_strictness,set_strictness =
+ let strictness = ref false in
+ (fun () -> (!strictness)),(fun b -> strictness:=b)
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optdepr = false;
+ optname = "strict mode";
+ optkey = ["Strict";"Proofs"];
+ optread = get_strictness;
+ optwrite = set_strictness }
+
+let tcl_change_info_gen info_gen =
+ (fun gls ->
+ let concl = pf_concl gls in
+ let hyps = Goal.V82.hyps (project gls) (sig_it gls) in
+ let extra = Goal.V82.extra (project gls) (sig_it gls) in
+ let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in
+ let sigma = Goal.V82.partial_solution sigma (sig_it gls) ev in
+ { it = [gl] ; sigma= sigma } )
+
+open Store.Field
+
+let tcl_change_info info gls =
+ let info_gen = Decl_mode.info.set info in
+ tcl_change_info_gen info_gen gls
+
+let tcl_erase_info gls = tcl_change_info_gen (Decl_mode.info.remove) gls
+
+let special_whd gl=
+ let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
+ (fun t -> Closure.whd_val infos (Closure.inject t))
+
+let special_nf gl=
+ let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
+ (fun t -> Closure.norm_val infos (Closure.inject t))
+
+let is_good_inductive env ind =
+ let mib,oib = Inductive.lookup_mind_specif env ind in
+ oib.mind_nrealargs = 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib))
+
+let check_not_per pts =
+ if not (Proof.is_done pts) then
+ match get_stack pts with
+ Per (_,_,_,_)::_ ->
+ error "You are inside a proof per cases/induction.\n\
+Please \"suppose\" something or \"end\" it now."
+ | _ -> ()
+
+let mk_evd metalist gls =
+ let evd0= create_goal_evar_defs (sig_sig gls) in
+ let add_one (meta,typ) evd =
+ meta_declare meta typ evd in
+ List.fold_right add_one metalist evd0
+
+let is_tmp id = (string_of_id id).[0] = '_'
+
+let tmp_ids gls =
+ let ctx = pf_hyps gls in
+ match ctx with
+ [] -> []
+ | _::q -> List.filter is_tmp (ids_of_named_context q)
+
+let clean_tmp gls =
+ let clean_id id0 gls0 =
+ tclTRY (clear [id0]) gls0 in
+ let rec clean_all = function
+ [] -> tclIDTAC
+ | id :: rest -> tclTHEN (clean_id id) (clean_all rest)
+ in
+ clean_all (tmp_ids gls) gls
+
+let assert_postpone id t =
+ assert_tac (Name id) t
+
+(* start a proof *)
+
+
+let start_proof_tac gls=
+ let info={pm_stack=[]} in
+ tcl_change_info info gls
+
+let go_to_proof_mode () =
+ Pfedit.by start_proof_tac;
+ let p = Proof_global.give_me_the_proof () in
+ Decl_mode.focus p
+
+(* closing gaps *)
+
+let daimon_tac gls =
+ set_daimon_flag ();
+ {it=[];sigma=sig_sig gls}
+
+
+(* marking closed blocks *)
+
+let rec is_focussing_instr = function
+ Pthus i | Pthen i | Phence i -> is_focussing_instr i
+ | Pescape | Pper _ | Pclaim _ | Pfocus _
+ | Psuppose _ | Pcase (_,_,_) -> true
+ | _ -> false
+
+let mark_rule_as_done = function
+ Decl_proof true -> Decl_proof false
+ | Decl_proof false ->
+ anomaly "already marked as done"
+ | _ -> anomaly "mark_rule_as_done"
+
+
+(* post-instruction focus management *)
+
+(* spiwack: This used to fail if there was no focusing command
+ above, but I don't think it ever happened. I hope it doesn't mess
+ things up*)
+let goto_current_focus pts =
+ Decl_mode.maximal_unfocus pts
+
+let goto_current_focus_or_top pts =
+ goto_current_focus pts
+
+(* return *)
+
+let close_tactic_mode pts =
+ try goto_current_focus pts
+ with Not_found ->
+ error "\"return\" cannot be used outside of Declarative Proof Mode."
+
+let return_from_tactic_mode () =
+ close_tactic_mode (Proof_global.give_me_the_proof ())
+
+(* end proof/claim *)
+
+let close_block bt pts =
+ if Proof.no_focused_goal pts then
+ goto_current_focus pts
+ else
+ let stack =
+ if Proof.is_done pts then
+ get_top_stack pts
+ else
+ get_stack pts
+ in
+ match bt,stack with
+ B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] ->
+ (goto_current_focus pts)
+ | _, Claim::_ ->
+ error "\"end claim\" expected."
+ | _, Focus_claim::_ ->
+ error "\"end focus\" expected."
+ | _, [] ->
+ error "\"end proof\" expected."
+ | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) ->
+ begin
+ match et with
+ ET_Case_analysis -> error "\"end cases\" expected."
+ | ET_Induction -> error "\"end induction\" expected."
+ end
+ | _,_ -> anomaly "Lonely suppose on stack."
+
+
+(* utility for suppose / suppose it is *)
+
+let close_previous_case pts =
+ if
+ Proof.is_done pts
+ then
+ match get_top_stack pts with
+ Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..."
+ | Suppose_case :: Per (et,_,_,_) :: _ ->
+ goto_current_focus (pts)
+ | _ -> error "Not inside a proof per cases or induction."
+ else
+ match get_stack pts with
+ Per (et,_,_,_) :: _ -> ()
+ | Suppose_case :: Per (et,_,_,_) :: _ ->
+ goto_current_focus ((pts))
+ | _ -> error "Not inside a proof per cases or induction."
+
+(* Proof instructions *)
+
+(* automation *)
+
+let filter_hyps f gls =
+ let filter_aux (id,_,_) =
+ if f id then
+ tclIDTAC
+ else
+ tclTRY (clear [id]) in
+ tclMAP filter_aux (pf_hyps gls) gls
+
+let local_hyp_prefix = id_of_string "___"
+
+let add_justification_hyps keep items gls =
+ let add_aux c gls=
+ match kind_of_term c with
+ Var id ->
+ keep:=Idset.add id !keep;
+ tclIDTAC gls
+ | _ ->
+ let id=pf_get_new_id local_hyp_prefix gls in
+ keep:=Idset.add id !keep;
+ tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere)
+ (thin_body [id]) gls in
+ tclMAP add_aux items gls
+
+let prepare_goal items gls =
+ let tokeep = ref Idset.empty in
+ let auxres = add_justification_hyps tokeep items gls in
+ tclTHENLIST
+ [ (fun _ -> auxres);
+ filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls
+
+let my_automation_tac = ref
+ (fun gls -> anomaly "No automation registered")
+
+let register_automation_tac tac = my_automation_tac:= tac
+
+let automation_tac gls = !my_automation_tac gls
+
+let justification tac gls=
+ tclORELSE
+ (tclSOLVE [tclTHEN tac assumption])
+ (fun gls ->
+ if get_strictness () then
+ error "Insufficient justification."
+ else
+ begin
+ msg_warning (str "Insufficient justification.");
+ daimon_tac gls
+ end) gls
+
+let default_justification elems gls=
+ justification (tclTHEN (prepare_goal elems) automation_tac) gls
+
+(* code for conclusion refining *)
+
+let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s)
+
+let _and = constant ["Init";"Logic"] "and"
+
+let _and_rect = constant ["Init";"Logic"] "and_rect"
+
+let _prod = constant ["Init";"Datatypes"] "prod"
+
+let _prod_rect = constant ["Init";"Datatypes"] "prod_rect"
+
+let _ex = constant ["Init";"Logic"] "ex"
+
+let _ex_ind = constant ["Init";"Logic"] "ex_ind"
+
+let _sig = constant ["Init";"Specif"] "sig"
+
+let _sig_rect = constant ["Init";"Specif"] "sig_rect"
+
+let _sigT = constant ["Init";"Specif"] "sigT"
+
+let _sigT_rect = constant ["Init";"Specif"] "sigT_rect"
+
+type stackd_elt =
+{se_meta:metavariable;
+ se_type:types;
+ se_last_meta:metavariable;
+ se_meta_list:(metavariable*types) list;
+ se_evd: evar_map}
+
+let rec replace_in_list m l = function
+ [] -> raise Not_found
+ | c::q -> if m=fst c then l@q else c::replace_in_list m l q
+
+let enstack_subsubgoals env se stack gls=
+ let hd,params = decompose_app (special_whd gls se.se_type) in
+ match kind_of_term hd with
+ Ind ind when is_good_inductive env ind ->
+ let mib,oib=
+ Inductive.lookup_mind_specif env ind in
+ let gentypes=
+ Inductive.arities_of_constructors ind (mib,oib) in
+ let process i gentyp =
+ let constructor = mkConstruct(ind,succ i)
+ (* constructors numbering*) in
+ let appterm = applist (constructor,params) in
+ let apptype = Term.prod_applist gentyp params in
+ let rc,_ = Reduction.dest_prod env apptype in
+ let rec meta_aux last lenv = function
+ [] -> (last,lenv,[])
+ | (nam,_,typ)::q ->
+ let nlast=succ last in
+ let (llast,holes,metas) =
+ meta_aux nlast (mkMeta nlast :: lenv) q in
+ (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in
+ let (nlast,holes,nmetas) =
+ meta_aux se.se_last_meta [] (List.rev rc) in
+ let refiner = applist (appterm,List.rev holes) in
+ let evd = meta_assign se.se_meta
+ (refiner,(Conv,TypeProcessed (* ? *))) se.se_evd in
+ let ncreated = replace_in_list
+ se.se_meta nmetas se.se_meta_list in
+ let evd0 = List.fold_left
+ (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in
+ List.iter (fun (m,typ) ->
+ Stack.push
+ {se_meta=m;
+ se_type=typ;
+ se_evd=evd0;
+ se_meta_list=ncreated;
+ se_last_meta=nlast} stack) (List.rev nmetas)
+ in
+ Array.iteri process gentypes
+ | _ -> ()
+
+let rec nf_list evd =
+ function
+ [] -> []
+ | (m,typ)::others ->
+ if meta_defined evd m then
+ nf_list evd others
+ else
+ (m,nf_meta evd typ)::nf_list evd others
+
+let find_subsubgoal c ctyp skip submetas gls =
+ let env= pf_env gls in
+ let concl = pf_concl gls in
+ let evd = mk_evd ((0,concl)::submetas) gls in
+ let stack = Stack.create () in
+ let max_meta =
+ List.fold_left (fun a (m,_) -> max a m) 0 submetas in
+ let _ = Stack.push
+ {se_meta=0;
+ se_type=concl;
+ se_last_meta=max_meta;
+ se_meta_list=[0,concl];
+ se_evd=evd} stack in
+ let rec dfs n =
+ let se = Stack.pop stack in
+ try
+ let unifier =
+ Unification.w_unify env se.se_evd Reduction.CUMUL
+ ~flags:Unification.elim_flags ctyp se.se_type in
+ if n <= 0 then
+ {se with
+ se_evd=meta_assign se.se_meta
+ (c,(Conv,TypeNotProcessed (* ?? *))) unifier;
+ se_meta_list=replace_in_list
+ se.se_meta submetas se.se_meta_list}
+ else
+ dfs (pred n)
+ with _ ->
+ 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 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Refiner
+open Names
+open Term
+open Tacmach
+open Decl_mode
+
+val go_to_proof_mode: unit -> unit
+val return_from_tactic_mode: unit -> unit
+
+val register_automation_tac: tactic -> unit
+
+val automation_tac : tactic
+
+val concl_refiner:
+ Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr
+
+val do_instr: Decl_expr.raw_proof_instr -> Proof.proof -> unit
+val proof_instr: Decl_expr.raw_proof_instr -> unit
+
+val tcl_change_info : Decl_mode.pm_info -> tactic
+
+val execute_cases :
+ Names.name ->
+ Decl_mode.per_info ->
+ (Term.constr -> Proof_type.tactic) ->
+ (Names.Idset.elt * (Term.constr option * Term.constr list) list) list ->
+ Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic
+
+val tree_of_pats :
+ identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
+ split_tree
+
+val add_branch :
+ identifier * (int * int) -> (Glob_term.cases_pattern*recpath) list list ->
+ split_tree -> split_tree
+
+val append_branch :
+ identifier *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
+ (Names.Idset.t * Decl_mode.split_tree) option ->
+ (Names.Idset.t * Decl_mode.split_tree) option
+
+val append_tree :
+ identifier * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list ->
+ split_tree -> split_tree
+
+val build_dep_clause : Term.types Decl_expr.statement list ->
+ Decl_expr.proof_pattern ->
+ Decl_mode.per_info ->
+ (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis)
+ Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types
+
+val register_dep_subcase :
+ Names.identifier * (int * int) ->
+ Environ.env ->
+ Decl_mode.per_info ->
+ Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind
+
+val thesis_for : Term.constr ->
+ Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr
+
+val close_previous_case : Proof.proof -> unit
+
+val pop_stacks :
+ (Names.identifier *
+ (Term.constr option * Term.constr list) list) list ->
+ (Names.identifier *
+ (Term.constr option * Term.constr list) list) list
+
+val push_head : Term.constr ->
+ Names.Idset.t ->
+ (Names.identifier *
+ (Term.constr option * Term.constr list) list) list ->
+ (Names.identifier *
+ (Term.constr option * Term.constr list) list) list
+
+val push_arg : Term.constr ->
+ (Names.identifier *
+ (Term.constr option * Term.constr list) list) list ->
+ (Names.identifier *
+ (Term.constr option * Term.constr list) list) list
+
+val hrec_for:
+ Names.identifier ->
+ Decl_mode.per_info -> Proof_type.goal Tacmach.sigma ->
+ Names.identifier -> Term.constr
+
+val consider_match :
+ bool ->
+ (Names.Idset.elt*bool) list ->
+ Names.Idset.elt list ->
+ (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list ->
+ Proof_type.tactic
+
+val init_tree:
+ Names.Idset.t ->
+ Names.inductive ->
+ int option * Declarations.wf_paths ->
+ (int ->
+ (int option * Declarations.recarg Rtree.t) array ->
+ (Names.Idset.t * Decl_mode.split_tree) option) ->
+ Decl_mode.split_tree
diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4
new file mode 100644
index 00000000..27def8cc
--- /dev/null
+++ b/plugins/decl_mode/g_decl_mode.ml4
@@ -0,0 +1,408 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* arnaud: veiller à l'aspect tutorial des commentaires *)
+
+open Pp
+open Tok
+open Decl_expr
+open Names
+open Term
+open Genarg
+open Pcoq
+
+open Pcoq.Constr
+open Pcoq.Tactic
+open Pcoq.Vernac_
+
+let pr_goal gs =
+ let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in
+ let env = Goal.V82.unfiltered_env sigma g in
+ let preamb,thesis,penv,pc =
+ (str " *** Declarative Mode ***" ++ fnl ()++fnl ()),
+ (str "thesis := " ++ fnl ()),
+ Printer.pr_context_of env,
+ Printer.pr_ltype_env_at_top env (Goal.V82.concl sigma g)
+ in
+ preamb ++
+ str" " ++ hv 0 (penv ++ fnl () ++
+ str (Printer.emacs_str "") ++
+ str "============================" ++ fnl () ++
+ thesis ++ str " " ++ pc) ++ fnl ()
+
+(* arnaud: rebrancher ça
+let pr_open_subgoals () =
+ let p = Proof_global.give_me_the_proof () in
+ let { Evd.it = goals ; sigma = sigma } = Proof.V82.subgoals p in
+ let close_cmd = Decl_mode.get_end_command p in
+ pr_subgoals close_cmd sigma goals
+*)
+
+let pr_proof_instr instr =
+ Util.anomaly "Cannot print a proof_instr"
+ (* arnaud: Il nous faut quelque chose de type extr_genarg_printer si on veut aller
+ dans cette direction
+ Ppdecl_proof.pr_proof_instr (Global.env()) instr
+ *)
+let pr_raw_proof_instr instr =
+ Util.anomaly "Cannot print a raw proof_instr"
+let pr_glob_proof_instr instr =
+ Util.anomaly "Cannot print a non-interpreted proof_instr"
+
+let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }=
+ Decl_interp.interp_proof_instr
+ (Decl_mode.get_info sigma gl)
+ (sigma)
+ (Goal.V82.env sigma gl)
+
+let vernac_decl_proof () =
+ let pf = Proof_global.give_me_the_proof () in
+ if Proof.is_done pf then
+ Util.error "Nothing left to prove here."
+ else
+ Proof.transaction pf begin fun () ->
+ Decl_proof_instr.go_to_proof_mode () ;
+ Proof_global.set_proof_mode "Declarative" ;
+ Vernacentries.print_subgoals ()
+ end
+
+(* spiwack: some bureaucracy is not performed here *)
+let vernac_return () =
+ Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () ->
+ Decl_proof_instr.return_from_tactic_mode () ;
+ Proof_global.set_proof_mode "Declarative" ;
+ Vernacentries.print_subgoals ()
+ end
+
+let vernac_proof_instr instr =
+ Proof.transaction (Proof_global.give_me_the_proof ()) begin fun () ->
+ Decl_proof_instr.proof_instr instr;
+ Vernacentries.print_subgoals ()
+ end
+
+(* We create a new parser entry [proof_mode]. The Declarative proof mode
+ will replace the normal parser entry for tactics with this one. *)
+let proof_mode = Gram.entry_create "vernac:proof_command"
+(* Auxiliary grammar entry. *)
+let proof_instr = Gram.entry_create "proofmode:instr"
+
+(* Before we can write an new toplevel command (see below)
+ which takes a [proof_instr] as argument, we need to declare
+ how to parse it, print it, globalise it and interprete it.
+ Normally we could do that easily through ARGUMENT EXTEND,
+ but as the parsing is fairly complicated we will do it manually to
+ indirect through the [proof_instr] grammar entry. *)
+(* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *)
+
+(* [Genarg.create_arg] creates a new embedding into Genarg. *)
+let (wit_proof_instr,globwit_proof_instr,rawwit_proof_instr) =
+ Genarg.create_arg "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 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Util
+open Pp
+open Decl_expr
+open Names
+open Nameops
+
+let pr_constr = Printer.pr_constr_env
+let pr_tac = Pptactic.pr_glob_tactic
+let pr_pat mpat = Ppconstr.pr_cases_pattern_expr mpat.pat_expr
+
+let pr_label = function
+ Anonymous -> mt ()
+ | Name id -> pr_id id ++ spc () ++ str ":" ++ spc ()
+
+let pr_justification_items env = function
+ Some [] -> mt ()
+ | Some (_::_ as l) ->
+ spc () ++ str "by" ++ spc () ++
+ prlist_with_sep (fun () -> str ",") (pr_constr env) l
+ | None -> spc () ++ str "by *"
+
+let pr_justification_method env = function
+ None -> mt ()
+ | Some tac ->
+ spc () ++ str "using" ++ spc () ++ pr_tac env tac
+
+let pr_statement pr_it env st =
+ pr_label st.st_label ++ pr_it env st.st_it
+
+let pr_or_thesis pr_this env = function
+ Thesis Plain -> str "thesis"
+ | Thesis (For id) ->
+ str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id
+ | This c -> pr_this env c
+
+let pr_cut pr_it env c =
+ hov 1 (pr_it env c.cut_stat) ++
+ pr_justification_items env c.cut_by ++
+ pr_justification_method env c.cut_using
+
+let type_or_thesis = function
+ Thesis _ -> Term.mkProp
+ | This c -> c
+
+let _I x = x
+
+let rec print_hyps pconstr gtyp env sep _be _have hyps =
+ let pr_sep = if sep then str "and" ++ spc () else mt () in
+ match hyps with
+ (Hvar _ ::_) as rest ->
+ spc () ++ pr_sep ++ str _have ++
+ print_vars pconstr gtyp env false _be _have rest
+ | Hprop st :: rest ->
+ begin
+ let nenv =
+ match st.st_label with
+ Anonymous -> env
+ | Name id -> Environ.push_named (id,None,gtyp st.st_it) env in
+ spc() ++ pr_sep ++ pr_statement pconstr env st ++
+ print_hyps pconstr gtyp nenv true _be _have rest
+ end
+ | [] -> mt ()
+
+and print_vars pconstr gtyp env sep _be _have vars =
+ match vars with
+ Hvar st :: rest ->
+ begin
+ let nenv =
+ match st.st_label with
+ Anonymous -> anomaly "anonymous variable"
+ | Name id -> Environ.push_named (id,None,st.st_it) env in
+ let pr_sep = if sep then pr_comma () else mt () in
+ spc() ++ pr_sep ++
+ pr_statement pr_constr env st ++
+ print_vars pconstr gtyp nenv true _be _have rest
+ end
+ | (Hprop _ :: _) as rest ->
+ let _st = if _be then
+ str "be such that"
+ else
+ str "such that" in
+ spc() ++ _st ++ print_hyps pconstr gtyp env false _be _have rest
+ | [] -> mt ()
+
+let pr_suffices_clause env (hyps,c) =
+ print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++
+ str "to show" ++ spc () ++ pr_or_thesis pr_constr env c
+
+let pr_elim_type = function
+ ET_Case_analysis -> str "cases"
+ | ET_Induction -> str "induction"
+
+let pr_casee env =function
+ Real c -> str "on" ++ spc () ++ pr_constr env c
+ | Virtual cut -> str "of" ++ spc () ++ pr_cut (pr_statement pr_constr) env cut
+
+let pr_side = function
+ Lhs -> str "=~"
+ | Rhs -> str "~="
+
+let rec pr_bare_proof_instr _then _thus env = function
+ | Pescape -> str "escape"
+ | Pthen i -> pr_bare_proof_instr true _thus env i
+ | Pthus i -> pr_bare_proof_instr _then true env i
+ | Phence i -> pr_bare_proof_instr true true env i
+ | Pcut c ->
+ begin
+ match _then,_thus with
+ false,false -> str "have" ++ spc () ++
+ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
+ | false,true -> str "thus" ++ spc () ++
+ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
+ | true,false -> str "then" ++ spc () ++
+ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
+ | true,true -> str "hence" ++ spc () ++
+ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c
+ end
+ | Psuffices c ->
+ str "suffices" ++ pr_cut pr_suffices_clause env c
+ | Prew (sid,c) ->
+ (if _thus then str "thus" else str " ") ++ spc () ++
+ pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c
+ | Passume hyps ->
+ str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps
+ | Plet hyps ->
+ str "let" ++ print_vars pr_constr _I env false true "let" hyps
+ | Pclaim st ->
+ str "claim" ++ spc () ++ pr_statement pr_constr env st
+ | Pfocus st ->
+ str "focus on" ++ spc () ++ pr_statement pr_constr env st
+ | Pconsider (id,hyps) ->
+ str "consider" ++ print_vars pr_constr _I env false false "consider" hyps
+ ++ spc () ++ str "from " ++ pr_constr env id
+ | Pgiven hyps ->
+ str "given" ++ print_vars pr_constr _I env false false "given" hyps
+ | Ptake witl ->
+ str "take" ++ spc () ++
+ prlist_with_sep pr_comma (pr_constr env) witl
+ | Pdefine (id,args,body) ->
+ str "define" ++ spc () ++ pr_id id ++ spc () ++
+ prlist_with_sep spc
+ (fun st -> str "(" ++
+ pr_statement pr_constr env st ++ str ")") args ++ spc () ++
+ str "as" ++ (pr_constr env body)
+ | Pcast (id,typ) ->
+ str "reconsider" ++ spc () ++
+ pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++
+ str "as" ++ spc () ++ (pr_constr env typ)
+ | Psuppose hyps ->
+ str "suppose" ++
+ print_hyps pr_constr _I env false false "we have" hyps
+ | Pcase (params,pat,hyps) ->
+ str "suppose it is" ++ spc () ++ pr_pat pat ++
+ (if params = [] then mt () else
+ (spc () ++ str "with" ++ spc () ++
+ prlist_with_sep spc
+ (fun st -> str "(" ++
+ pr_statement pr_constr env st ++ str ")") params ++ spc ()))
+ ++
+ (if hyps = [] then mt () else
+ (spc () ++ str "and" ++
+ print_hyps (pr_or_thesis pr_constr) type_or_thesis
+ env false false "we have" hyps))
+ | Pper (et,c) ->
+ str "per" ++ spc () ++ pr_elim_type et ++ spc () ++
+ pr_casee env c
+ | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et
+ | _ -> anomaly "unprintable instruction"
+
+let pr_emph = function
+ 0 -> str " "
+ | 1 -> str "* "
+ | 2 -> str "** "
+ | 3 -> str "*** "
+ | _ -> anomaly "unknown emphasis"
+
+let pr_proof_instr env instr =
+ pr_emph instr.emph ++ spc () ++
+ pr_bare_proof_instr false false env instr.instr
+
diff --git a/plugins/decl_mode/ppdecl_proof.mli b/plugins/decl_mode/ppdecl_proof.mli
new file mode 100644
index 00000000..fd6fb663
--- /dev/null
+++ b/plugins/decl_mode/ppdecl_proof.mli
@@ -0,0 +1,2 @@
+
+val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds
diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v
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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,8 +8,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_dp.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Dp
TACTIC EXTEND Simplify
diff --git a/plugins/dp/test2.v b/plugins/dp/test2.v
index 0940b135..ce660052 100644
--- a/plugins/dp/test2.v
+++ b/plugins/dp/test2.v
@@ -73,7 +73,7 @@ zenon.
Inductive IN (A:Set) : A -> list A -> Prop :=
| IN1 : forall x l, IN A x (x::l)
| IN2: forall x l, IN A x l -> forall y, IN A x (y::l).
-Implicit Arguments IN [A].
+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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,8 +8,6 @@
(** Extraction to Ocaml : use of basic Ocaml types *)
-Scheme Equality for nat.
-
Extract Inductive bool => bool [ true false ].
Extract Inductive option => option [ Some None ].
Extract Inductive unit => unit [ "()" ].
diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v
index e38d41e3..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v
index b059b2a0..697ea6b3 100644
--- a/plugins/extraction/ExtrOcamlIntConv.v
+++ b/plugins/extraction/ExtrOcamlIntConv.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v
index 1fb83c5b..0a303b63 100644
--- a/plugins/extraction/ExtrOcamlNatBigInt.v
+++ b/plugins/extraction/ExtrOcamlNatBigInt.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,7 +8,7 @@
(** Extraction of [nat] into Ocaml's [big_int] *)
-Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import Arith Even Div2 EqNat Euclid.
Require Import ExtrOcamlBasic.
(** NB: The extracted code should be linked with [nums.cm(x)a]
@@ -36,7 +36,7 @@ Extract Constant pred => "fun n -> Big.max Big.zero (Big.pred n)".
Extract Constant minus => "fun n m -> Big.max Big.zero (Big.sub n m)".
Extract Constant max => "Big.max".
Extract Constant min => "Big.min".
-Extract Constant nat_beq => "Big.eq".
+(*Extract Constant nat_beq => "Big.eq".*)
Extract Constant EqNat.beq_nat => "Big.eq".
Extract Constant EqNat.eq_nat_decide => "Big.eq".
diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v
index e577ebe1..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,7 +8,7 @@
(** Extraction of [nat] into Ocaml's [int] *)
-Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import Arith Even Div2 EqNat Euclid.
Require Import ExtrOcamlBasic.
(** Disclaimer: trying to obtain efficient certified programs
@@ -45,7 +45,7 @@ Extract Constant minus => "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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v
index 5ca6bd7b..12607b3a 100644
--- a/plugins/extraction/ExtrOcamlZBigInt.v
+++ b/plugins/extraction/ExtrOcamlZBigInt.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,7 +8,7 @@
(** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *)
-Require Import ZArith NArith ZOdiv_def.
+Require Import ZArith NArith.
Require Import ExtrOcamlBasic.
(** NB: The extracted code should be linked with [nums.cm(x)a]
@@ -36,42 +36,44 @@ Extract Inductive N => "Big.big_int"
(** Efficient (but uncertified) versions for usual functions *)
-Extract Constant Pplus => "Big.add".
-Extract Constant Psucc => "Big.succ".
-Extract Constant Ppred => "fun n -> Big.max Big.one (Big.pred n)".
-Extract Constant Pminus => "fun n m -> Big.max Big.one (Big.sub n m)".
-Extract Constant Pmult => "Big.mult".
-Extract Constant Pmin => "Big.min".
-Extract Constant Pmax => "Big.max".
-Extract Constant Pcompare =>
+Extract Constant Pos.add => "Big.add".
+Extract Constant Pos.succ => "Big.succ".
+Extract Constant Pos.pred => "fun n -> Big.max Big.one (Big.pred n)".
+Extract Constant Pos.sub => "fun n m -> Big.max Big.one (Big.sub n m)".
+Extract Constant Pos.mul => "Big.mult".
+Extract Constant Pos.min => "Big.min".
+Extract Constant Pos.max => "Big.max".
+Extract Constant Pos.compare =>
+ "fun x y -> Big.compare_case Eq Lt Gt x y".
+Extract Constant Pos.compare_cont =>
"fun x y c -> Big.compare_case c Lt Gt x y".
-Extract Constant Nplus => "Big.add".
-Extract Constant Nsucc => "Big.succ".
-Extract Constant Npred => "fun n -> Big.max Big.zero (Big.pred n)".
-Extract Constant Nminus => "fun n m -> Big.max Big.zero (Big.sub n m)".
-Extract Constant Nmult => "Big.mult".
-Extract Constant Nmin => "Big.min".
-Extract Constant Nmax => "Big.max".
-Extract Constant Ndiv =>
+Extract Constant N.add => "Big.add".
+Extract Constant N.succ => "Big.succ".
+Extract Constant N.pred => "fun n -> Big.max Big.zero (Big.pred n)".
+Extract Constant N.sub => "fun n m -> Big.max Big.zero (Big.sub n m)".
+Extract Constant N.mul => "Big.mult".
+Extract Constant N.min => "Big.min".
+Extract Constant N.max => "Big.max".
+Extract Constant N.div =>
"fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b".
-Extract Constant Nmod =>
+Extract Constant N.modulo =>
"fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b".
-Extract Constant Ncompare => "Big.compare_case Eq Lt Gt".
-
-Extract Constant Zplus => "Big.add".
-Extract Constant Zsucc => "Big.succ".
-Extract Constant Zpred => "Big.pred".
-Extract Constant Zminus => "Big.sub".
-Extract Constant Zmult => "Big.mult".
-Extract Constant Zopp => "Big.opp".
-Extract Constant Zabs => "Big.abs".
-Extract Constant Zmin => "Big.min".
-Extract Constant Zmax => "Big.max".
-Extract Constant Zcompare => "Big.compare_case Eq Lt Gt".
-
-Extract Constant Z_of_N => "fun p -> p".
-Extract Constant Zabs_N => "Big.abs".
+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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,7 +8,7 @@
(** Extraction of [positive], [N] and [Z] into Ocaml's [int] *)
-Require Import ZArith NArith ZOdiv_def.
+Require Import ZArith NArith.
Require Import ExtrOcamlBasic.
(** Disclaimer: trying to obtain efficient certified programs
@@ -33,44 +33,46 @@ Extract Inductive N => int [ "0" "" ]
(** Efficient (but uncertified) versions for usual functions *)
-Extract Constant Pplus => "(+)".
-Extract Constant Psucc => "succ".
-Extract Constant Ppred => "fun n -> max 1 (n-1)".
-Extract Constant Pminus => "fun n m -> max 1 (n-m)".
-Extract Constant Pmult => "( * )".
-Extract Constant Pmin => "min".
-Extract Constant Pmax => "max".
-Extract Constant Pcompare =>
+Extract Constant Pos.add => "(+)".
+Extract Constant Pos.succ => "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<y then Lt else Gt".
+Extract Constant Pos.compare_cont =>
"fun x y c -> if x=y then c else if x<y then Lt else Gt".
-Extract Constant Nplus => "(+)".
-Extract Constant Nsucc => "succ".
-Extract Constant Npred => "fun n -> max 0 (n-1)".
-Extract Constant Nminus => "fun n m -> max 0 (n-m)".
-Extract Constant Nmult => "( * )".
-Extract Constant Nmin => "min".
-Extract Constant Nmax => "max".
-Extract Constant Ndiv => "fun a b -> if b=0 then 0 else a/b".
-Extract Constant Nmod => "fun a b -> if b=0 then a else a mod b".
-Extract Constant Ncompare =>
+Extract Constant N.add => "(+)".
+Extract Constant N.succ => "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<y then Lt else Gt".
-Extract Constant Zplus => "(+)".
-Extract Constant Zsucc => "succ".
-Extract Constant Zpred => "pred".
-Extract Constant Zminus => "(-)".
-Extract Constant Zmult => "( * )".
-Extract Constant Zopp => "(~-)".
-Extract Constant Zabs => "abs".
-Extract Constant Zmin => "min".
-Extract Constant Zmax => "max".
-Extract Constant Zcompare =>
+Extract Constant Z.add => "(+)".
+Extract Constant Z.succ => "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<y then Lt else Gt".
-Extract Constant Z_of_N => "fun p -> p".
-Extract Constant Zabs_N => "abs".
+Extract Constant Z.of_N => "fun p -> p".
+Extract Constant Z.abs_N => "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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index 9713fcd2..0bd5b843 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: common.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Pp
open Util
open Names
@@ -35,17 +33,41 @@ let is_mp_bound = function MPbound _ -> true | _ -> false
let pp_par par st = if par then str "(" ++ st ++ str ")" else st
+(** [pp_apply] : a head part applied to arguments, possibly with parenthesis *)
+
let pp_apply st par args = match args with
| [] -> st
| _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args))
+(** Same as [pp_apply], but with also protection of the head by parenthesis *)
+
+let pp_apply2 st par args =
+ let par' = args <> [] || par in
+ pp_apply (pp_par par' st) par args
+
let pr_binding = function
| [] -> mt ()
| l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l
+let pp_tuple_light f = function
+ | [] -> mt ()
+ | [x] -> f true x
+ | l ->
+ pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l)
+
+let pp_tuple f = function
+ | [] -> mt ()
+ | [x] -> f x
+ | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l)
+
+let pp_boxed_tuple f = function
+ | [] -> mt ()
+ | [x] -> f x
+ | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l))
+
(** By default, in module Format, you can do horizontal placing of blocks
even if they include newlines, as long as the number of chars in the
- blocks are less that a line length. To avoid this awkward situation,
+ blocks is less that a line length. To avoid this awkward situation,
we attach a big virtual size to [fnl] newlines. *)
let fnl () = stras (1000000,"") ++ fnl ()
@@ -54,8 +76,6 @@ let fnl2 () = fnl () ++ fnl ()
let space_if = function true -> str " " | false -> mt ()
-let sec_space_if = function true -> spc () | false -> mt ()
-
let is_digit = function
| '0'..'9' -> true
| _ -> false
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: common.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Names
open Libnames
open Miniml
@@ -22,10 +20,19 @@ open Pp
val fnl : unit -> std_ppcmds
val fnl2 : unit -> std_ppcmds
val space_if : bool -> std_ppcmds
-val sec_space_if : bool -> std_ppcmds
val pp_par : bool -> std_ppcmds -> std_ppcmds
+
+(** [pp_apply] : a head part applied to arguments, possibly with parenthesis *)
val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds
+
+(** Same as [pp_apply], but with also protection of the head by parenthesis *)
+val pp_apply2 : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds
+
+val pp_tuple_light : (bool -> 'a -> std_ppcmds) -> 'a list -> std_ppcmds
+val pp_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+val pp_boxed_tuple : ('a -> std_ppcmds) -> 'a list -> std_ppcmds
+
val pr_binding : identifier list -> std_ppcmds
val rename_id : identifier -> Idset.t -> identifier
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index 3fa674d3..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: extract_env.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Term
open Declarations
open Names
@@ -40,21 +38,19 @@ let toplevel_env () =
in l,seb
| _ -> failwith "caught"
in
- match current_toplevel () with
- | _ -> SEBstruct (List.rev (map_succeed get_reference seg))
-
+ SEBstruct (List.rev (map_succeed get_reference seg))
+
let environment_until dir_opt =
let rec parse = function
| [] when dir_opt = None -> [current_toplevel (), toplevel_env ()]
| [] -> []
| d :: l ->
- let mb = Global.lookup_module (MPfile d) in
- (* If -dont-load-proof has been used, mod_expr is None,
- we try with mod_type *)
- let meb = Option.default mb.mod_type mb.mod_expr in
- if dir_opt = Some d then [MPfile d, meb]
- else (MPfile d, meb) :: (parse l)
+ match (Global.lookup_module (MPfile d)).mod_expr with
+ | Some meb ->
+ if dir_opt = Some d then [MPfile d, meb]
+ else (MPfile d, meb) :: (parse l)
+ | _ -> assert false
in parse (Library.loaded_libraries ())
@@ -68,6 +64,9 @@ module type VISIT = sig
(* Add the module_path and all its prefixes to the mp visit list *)
val add_mp : module_path -> unit
+ (* Same, but we'll keep all fields of these modules *)
+ val add_mp_all : module_path -> unit
+
(* Add kernel_name / constant / reference / ... in the visit lists.
These functions silently add the mp of their arg in the mp list *)
val add_ind : mutual_inductive -> unit
@@ -81,6 +80,7 @@ module type VISIT = sig
val needed_ind : mutual_inductive -> bool
val needed_con : constant -> bool
val needed_mp : module_path -> bool
+ val needed_mp_all : module_path -> bool
end
module Visit : VISIT = struct
@@ -88,16 +88,26 @@ module Visit : VISIT = struct
(for inductives and modules names) and a Cset_env for constants
(and still the remaining MPset) *)
type must_visit =
- { mutable ind : KNset.t; mutable con : KNset.t; mutable mp : MPset.t }
+ { mutable ind : KNset.t; mutable con : KNset.t;
+ mutable mp : MPset.t; mutable mp_all : MPset.t }
(* the imperative internal visit lists *)
- let v = { ind = KNset.empty ; con = KNset.empty ; mp = MPset.empty }
+ let v = { ind = KNset.empty ; con = KNset.empty ;
+ mp = MPset.empty; mp_all = MPset.empty }
(* the accessor functions *)
- let reset () = v.ind <- KNset.empty; v.con <- KNset.empty; v.mp <- MPset.empty
+ let reset () =
+ v.ind <- KNset.empty;
+ v.con <- KNset.empty;
+ v.mp <- MPset.empty;
+ v.mp_all <- MPset.empty
let needed_ind i = KNset.mem (user_mind i) v.ind
let needed_con c = KNset.mem (user_con c) v.con
- let needed_mp mp = MPset.mem mp v.mp
+ let needed_mp mp = MPset.mem mp v.mp || MPset.mem mp v.mp_all
+ let needed_mp_all mp = MPset.mem mp v.mp_all
let add_mp mp =
check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp
+ let add_mp_all mp =
+ check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp;
+ v.mp_all <- MPset.add mp v.mp_all
let add_ind i =
let kn = user_mind i in
v.ind <- KNset.add kn v.ind; add_mp (modpath kn)
@@ -120,12 +130,17 @@ let check_arity env cb =
let check_fix env cb i =
match cb.const_body with
- | None -> raise Impossible
- | Some lbody ->
- match kind_of_term (Declarations.force lbody) with
+ | Def lbody ->
+ (match kind_of_term (Declarations.force lbody) with
| Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd)
| CoFix (j,recd) when i=j -> check_arity env cb; (false,recd)
- | _ -> raise Impossible
+ | _ -> raise Impossible)
+ | Undef _ | OpaqueDef _ -> raise Impossible
+
+let prec_declaration_equal (na1, ca1, ta1) (na2, ca2, ta2) =
+ na1 = na2 &&
+ array_equal eq_constr ca1 ca2 &&
+ array_equal eq_constr ta1 ta2
let factor_fix env l cb msb =
let _,recd as check = check_fix env cb 0 in
@@ -139,7 +154,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: extract_env.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(*s This module declares the extraction commands. *)
open Names
@@ -15,9 +13,15 @@ open Libnames
val simple_extraction : reference -> unit
val full_extraction : string option -> reference list -> unit
+val separate_extraction : reference list -> unit
val extraction_library : bool -> identifier -> unit
(* For debug / external output via coqtop.byte + Drop : *)
val mono_environment :
global_reference list -> module_path list -> Miniml.ml_structure
+
+(* Used by the Relation Extraction plugin *)
+
+val print_one_decl :
+ Miniml.ml_structure -> module_path -> Miniml.ml_decl -> unit
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index 27f32a4a..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: extraction.ml 14786 2011-12-10 12:55:19Z letouzey $ i*)
-
(*i*)
open Util
open Names
@@ -48,8 +46,6 @@ let sort_of env c =
Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c)
with SingletonInductiveBecomesProp id -> error_singleton_become_prop id
-let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None
-
(*S Generation of flags and signatures. *)
(* The type [flag] gives us information about any Coq term:
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: extraction.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(*s Extraction from Coq terms to Miniml. *)
open Names
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index ebd4de0d..11a2d0e0 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -63,6 +63,12 @@ VERNAC COMMAND EXTEND Extraction
-> [ full_extraction (Some f) l ]
END
+VERNAC COMMAND EXTEND SeparateExtraction
+(* Same, with content splitted in several files *)
+| [ "Separate" "Extraction" ne_global_list(l) ]
+ -> [ separate_extraction l ]
+END
+
(* Modular extraction (one Coq library = one ML module) *)
VERNAC COMMAND EXTEND ExtractionLibrary
| [ "Extraction" "Library" ident(m) ]
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
index aeacef93..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: haskell.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(*s Production of Haskell syntax. *)
open Pp
@@ -47,15 +45,15 @@ let preamble mod_name used_modules usf =
(if used_modules = [] then mt () else fnl ()) ++
(if not usf.magic then mt ()
else str "\
-unsafeCoerce :: a -> b
-#ifdef __GLASGOW_HASKELL__
-import qualified GHC.Base
-unsafeCoerce = GHC.Base.unsafeCoerce#
-#else
--- HUGS
-import qualified IOExts
-unsafeCoerce = IOExts.unsafeCoerce
-#endif" ++ fnl2 ())
+\nunsafeCoerce :: a -> b\
+\n#ifdef __GLASGOW_HASKELL__\
+\nimport qualified GHC.Base\
+\nunsafeCoerce = GHC.Base.unsafeCoerce#\
+\n#else\
+\n-- HUGS\
+\nimport qualified IOExts\
+\nunsafeCoerce = IOExts.unsafeCoerce\
+\n#endif" ++ fnl2 ())
++
(if not usf.mldummy then mt ()
else str "__ :: any" ++ fnl () ++
@@ -78,17 +76,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: haskell.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
val haskell_descr : Miniml.language_descr
diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli
index aaf2d0c3..5a19cc3f 100644
--- a/plugins/extraction/miniml.mli
+++ b/plugins/extraction/miniml.mli
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: miniml.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(*s Target language for extraction: a core ML called MiniML. *)
open Pp
@@ -73,8 +71,7 @@ type ml_ind_packet = {
ip_logical : bool;
ip_sign : signature;
ip_vars : identifier list;
- ip_types : (ml_type list) array;
- mutable ip_optim_id_ok : bool option
+ ip_types : (ml_type list) array
}
(* [ip_nparams] contains the number of parameters. *)
@@ -99,28 +96,17 @@ type ml_ident =
| Tmp of identifier
(** We now store some typing information on constructors
- and cases to avoid type-unsafe optimisations.
- For cases, we also store the set of branches to merge
- in a common pattern, either "_ -> c" or "x -> f x"
+ and cases to avoid type-unsafe optimisations. This will be
+ either the type of the applied constructor or the type
+ of the head of the match.
*)
-type constructor_info = {
- c_kind : inductive_kind;
- c_typs : ml_type list;
-}
-
-type branch_same =
- | BranchNone
- | BranchFun of Intset.t
- | BranchCst of Intset.t
+(** Nota : the constructor [MLtuple] and the extension of [MLcase]
+ to general patterns have been proposed by P.N. Tollitte for
+ his Relation Extraction plugin. [MLtuple] is currently not
+ used by the main extraction, as well as deep patterns. *)
-type match_info = {
- m_kind : inductive_kind;
- m_typs : ml_type list;
- m_same : branch_same
-}
-
-type ml_branch = global_reference * ml_ident list * ml_ast
+type ml_branch = ml_ident list * ml_pattern * ml_ast
and ml_ast =
| MLrel of int
@@ -128,24 +114,32 @@ and ml_ast =
| MLlam of ml_ident * ml_ast
| MLletin of ml_ident * ml_ast * ml_ast
| MLglob of global_reference
- | MLcons of constructor_info * global_reference * ml_ast list
- | MLcase of match_info * ml_ast * ml_branch array
+ | MLcons of ml_type * global_reference * ml_ast list
+ | MLtuple of ml_ast list
+ | MLcase of ml_type * ml_ast * ml_branch array
| MLfix of int * identifier array * ml_ast array
| MLexn of string
| MLdummy
| MLaxiom
| MLmagic of ml_ast
+and ml_pattern =
+ | Pcons of global_reference * ml_pattern list
+ | Ptuple of ml_pattern list
+ | Prel of int (** Cf. the idents in the branch. [Prel 1] is the last one. *)
+ | Pwild
+ | Pusual of global_reference (** Shortcut for Pcons (r,[Prel n;...;Prel 1]) **)
+
(*s ML declarations. *)
type ml_decl =
- | Dind of kernel_name * ml_ind
+ | Dind of mutual_inductive * ml_ind
| Dtype of global_reference * identifier list * ml_type
| Dterm of global_reference * ml_ast * ml_type
| Dfix of global_reference array * ml_ast array * ml_type array
type ml_spec =
- | Sind of kernel_name * ml_ind
+ | Sind of mutual_inductive * ml_ind
| Stype of global_reference * identifier list * ml_type option
| Sval of global_reference * ml_type
diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml
index 3c7ee0f2..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: mlutil.ml 14786 2011-12-10 12:55:19Z letouzey $ i*)
-
(*i*)
open Pp
open Util
@@ -56,18 +54,6 @@ let new_meta _ =
incr meta_count;
Tmeta {id = !meta_count; contents = None}
-(*s Sustitution of [Tvar i] by [t] in a ML type. *)
-
-let type_subst i t0 t =
- let rec subst t = match t with
- | Tvar j when i = j -> t0
- | Tmeta {contents=None} -> t
- | Tmeta {contents=Some u} -> subst u
- | Tarr (a,b) -> Tarr (subst a, subst b)
- | Tglob (r, l) -> Tglob (r, List.map subst l)
- | a -> a
- in subst t
-
(* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *)
let type_subst_list l t =
@@ -378,54 +364,61 @@ let ast_iter_rel f =
| MLlam (_,a) -> iter (n+1) a
| MLletin (_,a,b) -> iter n a; iter (n+1) b
| MLcase (_,a,v) ->
- iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v
+ iter n a; Array.iter (fun (l,_,t) -> iter (n + (List.length l)) t) v
| MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v
| MLapp (a,l) -> iter n a; List.iter (iter n) l
- | MLcons (_,_,l) -> List.iter (iter n) l
+ | MLcons (_,_,l) | MLtuple l -> List.iter (iter n) l
| MLmagic a -> iter n a
| MLglob _ | MLexn _ | MLdummy | MLaxiom -> ()
in iter 0
(*s Map over asts. *)
-let ast_map_case f (c,ids,a) = (c,ids,f a)
+let ast_map_branch f (c,ids,a) = (c,ids,f a)
+
+(* Warning: in [ast_map] we assume that [f] does not change the type
+ of [MLcons] and of [MLcase] heads *)
let ast_map f = function
| MLlam (i,a) -> MLlam (i, f a)
| MLletin (i,a,b) -> MLletin (i, f a, f b)
- | MLcase (i,a,v) -> MLcase (i,f a, Array.map (ast_map_case f) v)
+ | MLcase (typ,a,v) -> MLcase (typ,f a, Array.map (ast_map_branch f) v)
| MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v)
| MLapp (a,l) -> MLapp (f a, List.map f l)
- | MLcons (i,c,l) -> MLcons (i,c, List.map f l)
+ | MLcons (typ,c,l) -> MLcons (typ,c, List.map f l)
+ | MLtuple l -> MLtuple (List.map f l)
| MLmagic a -> MLmagic (f a)
| MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
(*s Map over asts, with binding depth as parameter. *)
-let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a)
+let ast_map_lift_branch f n (ids,p,a) = (ids,p, f (n+(List.length ids)) a)
+
+(* Same warning as for [ast_map]... *)
let ast_map_lift f n = function
| MLlam (i,a) -> MLlam (i, f (n+1) a)
| MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b)
- | MLcase (i,a,v) -> MLcase (i,f n a,Array.map (ast_map_lift_case f n) v)
+ | MLcase (typ,a,v) -> MLcase (typ,f n a,Array.map (ast_map_lift_branch f n) v)
| MLfix (i,ids,v) ->
let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v)
| MLapp (a,l) -> MLapp (f n a, List.map (f n) l)
- | MLcons (i,c,l) -> MLcons (i,c, List.map (f n) l)
+ | MLcons (typ,c,l) -> MLcons (typ,c, List.map (f n) l)
+ | MLtuple l -> MLtuple (List.map (f n) l)
| MLmagic a -> MLmagic (f n a)
| MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
(*s Iter over asts. *)
-let ast_iter_case f (c,ids,a) = f a
+let ast_iter_branch f (c,ids,a) = f a
let ast_iter f = function
| MLlam (i,a) -> f a
| MLletin (i,a,b) -> f a; f b
- | MLcase (_,a,v) -> f a; Array.iter (ast_iter_case f) v
+ | MLcase (_,a,v) -> f a; Array.iter (ast_iter_branch f) v
| MLfix (i,ids,v) -> Array.iter f v
| MLapp (a,l) -> f a; List.iter f l
- | MLcons (_,c,l) -> List.iter f l
+ | MLcons (_,_,l) | MLtuple l -> List.iter f l
| MLmagic a -> f a
| MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> ()
@@ -446,15 +439,6 @@ let ast_occurs_itvl k k' t =
ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false
with Found -> true
-(*s Number of occurences of [Rel k] (resp. [Rel 1]) in [t]. *)
-
-let nb_occur_k k t =
- let cpt = ref 0 in
- ast_iter_rel (fun i -> if i = k then incr cpt) t;
- !cpt
-
-let nb_occur t = nb_occur_k 1 t
-
(* Number of occurences of [Rel 1] in [t], with special treatment of match:
occurences in different branches aren't added, but we rather use max. *)
@@ -464,13 +448,13 @@ let nb_occur_match =
| MLcase(_,a,v) ->
(nb k a) +
Array.fold_left
- (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v
+ (fun r (ids,_,a) -> max r (nb (k+(List.length ids)) a)) 0 v
| MLletin (_,a,b) -> (nb k a) + (nb (k+1) b)
| MLfix (_,ids,v) -> let k = k+(Array.length ids) in
Array.fold_left (fun r a -> r+(nb k a)) 0 v
| MLlam (_,a) -> nb (k+1) a
| MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l
- | MLcons (_,_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l
+ | MLcons (_,_,l) | MLtuple l -> List.fold_left (fun r a -> r+(nb k a)) 0 l
| MLmagic a -> nb k a
| MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0
in nb 1
@@ -530,6 +514,39 @@ let gen_subst v d t =
| a -> ast_map_lift subst n a
in subst 0 t
+(*S Operations concerning match patterns *)
+
+let is_basic_pattern = function
+ | Prel _ | Pwild -> true
+ | Pusual _ | Pcons _ | Ptuple _ -> false
+
+let has_deep_pattern br =
+ let deep = function
+ | Pcons (_,l) | Ptuple l -> not (List.for_all is_basic_pattern l)
+ | Pusual _ | Prel _ | Pwild -> false
+ in
+ array_exists (function (_,pat,_) -> deep pat) br
+
+let is_regular_match br =
+ if Array.length br = 0 then false (* empty match becomes MLexn *)
+ else
+ try
+ let get_r (ids,pat,c) =
+ match pat with
+ | Pusual r -> r
+ | Pcons (r,l) ->
+ if not (list_for_all_i (fun i -> (=) (Prel i)) 1 (List.rev l))
+ then raise Impossible;
+ r
+ | _ -> raise Impossible
+ in
+ let ind = match get_r br.(0) with
+ | ConstructRef (ind,_) -> ind
+ | _ -> raise Impossible
+ in
+ array_for_all_i (fun i tr -> get_r tr = ConstructRef (ind,i+1)) 0 br
+ with Impossible -> false
+
(*S Operations concerning lambdas. *)
(*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns
@@ -577,7 +594,6 @@ let rec many_lams id a = function
| 0 -> a
| n -> many_lams id (MLlam (id,a)) (pred n)
-let anonym_lams a n = many_lams anonymous a n
let anonym_tmp_lams a n = many_lams (Tmp anonymous_name) a n
let dummy_lams a n = many_lams Dummy a n
@@ -679,26 +695,31 @@ let rec ast_glob_subst s t = match t with
expansion of type definitions.
*)
-(*s [branch_as_function b typs (r,l,c)] tries to see branch [c]
+(*s [branch_as_function b typ (l,p,c)] tries to see branch [c]
as a function [f] applied to [MLcons(r,l)]. For that it transforms
any [MLcons(r,l)] in [MLrel 1] and raises [Impossible]
if any variable in [l] occurs outside such a [MLcons] *)
-let branch_as_fun typs (r,l,c) =
+let branch_as_fun typ (l,p,c) =
let nargs = List.length l in
+ let cons = match p with
+ | Pusual r -> MLcons (typ, r, eta_args nargs)
+ | Pcons (r,pl) ->
+ let pat2rel = function Prel i -> MLrel i | _ -> raise Impossible in
+ MLcons (typ, r, List.map pat2rel pl)
+ | _ -> raise Impossible
+ in
let rec genrec n = function
| MLrel i as c ->
let i' = i-n in
if i'<1 then c
else if i'>nargs then MLrel (i-nargs+1)
else raise Impossible
- | MLcons(i,r',args) when
- r=r' && (test_eta_args_lift n nargs args) && typs = i.c_typs ->
- MLrel (n+1)
+ | MLcons _ as cons' when cons' = ast_lift n cons -> MLrel (n+1)
| a -> ast_map_lift genrec n a
in genrec 0 c
-(*s [branch_as_cst (r,l,c)] tries to see branch [c] as a constant
+(*s [branch_as_cst (l,p,c)] tries to see branch [c] as a constant
independent from the pattern [MLcons(r,l)]. For that is raises [Impossible]
if any variable in [l] occurs in [c], and otherwise returns [c] lifted to
appear like a function with one arg (for uniformity with [branch_as_fun]).
@@ -706,7 +727,7 @@ let branch_as_fun typs (r,l,c) =
empty, i.e. when [r] is a constant constructor
*)
-let branch_as_cst (_,l,c) =
+let branch_as_cst (l,_,c) =
let n = List.length l in
if ast_occurs_itvl 1 n c then raise Impossible;
ast_lift (1-n) c
@@ -745,20 +766,27 @@ let census_add, census_max, census_clean =
constant.
*)
-let factor_branches o typs br =
- census_clean ();
- for i = 0 to Array.length br - 1 do
- if o.opt_case_idr then
- (try census_add (branch_as_fun typs br.(i)) i with Impossible -> ());
- if o.opt_case_cst then
- (try census_add (branch_as_cst br.(i)) i with Impossible -> ());
- done;
- let br_factor, br_set = census_max MLdummy in
- census_clean ();
- let n = Intset.cardinal br_set in
- if n = 0 then None
- else if Array.length br >= 2 && n < 2 then None
- else Some (br_factor, br_set)
+let is_opt_pat (_,p,_) = match p with
+ | Prel _ | Pwild -> true
+ | _ -> false
+
+let factor_branches o typ br =
+ if array_exists is_opt_pat br then None (* already optimized *)
+ else begin
+ census_clean ();
+ for i = 0 to Array.length br - 1 do
+ if o.opt_case_idr then
+ (try census_add (branch_as_fun typ br.(i)) i with Impossible -> ());
+ if o.opt_case_cst then
+ (try census_add (branch_as_cst br.(i)) i with Impossible -> ());
+ done;
+ let br_factor, br_set = census_max MLdummy in
+ census_clean ();
+ let n = Intset.cardinal br_set in
+ if n = 0 then None
+ else if Array.length br >= 2 && n < 2 then None
+ else Some (br_factor, br_set)
+ end
(*s If all branches are functions, try to permut the case and the functions. *)
@@ -781,14 +809,14 @@ let rec permut_case_fun br acc =
let br = Array.copy br in
let ids = ref [] in
for i = 0 to Array.length br - 1 do
- let (r,l,t) = br.(i) in
+ let (l,p,t) = br.(i) in
let local_nb = nb_lams t in
if local_nb < !nb then (* t = MLexn ... *)
- br.(i) <- (r,l,remove_n_lams local_nb t)
+ br.(i) <- (l,p,remove_n_lams local_nb t)
else begin
let local_ids,t = collect_n_lams !nb t in
ids := merge_ids !ids local_ids;
- br.(i) <- (r,l,permut_rels !nb (List.length l) t)
+ br.(i) <- (l,p,permut_rels !nb (List.length l) t)
end
done;
(!ids,br)
@@ -796,32 +824,43 @@ let rec permut_case_fun br acc =
(*S Generalized iota-reduction. *)
-(* Definition of a generalized iota-redex: it's a [MLcase(e,_)]
- with [(is_iota_gen e)=true]. Any generalized iota-redex is
- transformed into beta-redexes. *)
-
-let rec is_iota_gen = function
- | MLcons _ -> true
- | MLcase(_,_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br
- | _ -> false
-
-let constructor_index = function
- | ConstructRef (_,j) -> pred j
- | _ -> assert false
-
-let iota_gen br =
+(* Definition of a generalized iota-redex: it's a [MLcase(e,br)]
+ where the head [e] is a [MLcons] or made of [MLcase]'s with
+ [MLcons] as leaf branches.
+ A generalized iota-redex is transformed into beta-redexes. *)
+
+(* In [iota_red], we try to simplify a [MLcase(_,MLcons(typ,r,a),br)].
+ Argument [i] is the branch we consider, we should lift what
+ comes from [br] by [lift] *)
+
+let rec iota_red i lift br ((typ,r,a) as cons) =
+ if i >= Array.length br then raise Impossible;
+ let (ids,p,c) = br.(i) in
+ match p with
+ | Pusual r' | Pcons (r',_) when r'<>r -> iota_red (i+1) lift br cons
+ | Pusual r' ->
+ let c = named_lams (List.rev ids) c in
+ let c = ast_lift lift c
+ in MLapp (c,a)
+ | Prel 1 when List.length ids = 1 ->
+ let c = MLlam (List.hd ids, c) in
+ let c = ast_lift lift c
+ in MLapp(c,[MLcons(typ,r,a)])
+ | Pwild when ids = [] -> ast_lift lift c
+ | _ -> raise Impossible (* TODO: handle some more cases *)
+
+(* [iota_gen] is an extension of [iota_red] where we allow to
+ traverse matches in the head of the first match *)
+
+let iota_gen br hd =
let rec iota k = function
- | MLcons (i,r,a) ->
- let (_,ids,c) = br.(constructor_index r) in
- let c = List.fold_right (fun id t -> MLlam (id,t)) ids c in
- let c = ast_lift k c in
- MLapp (c,a)
- | MLcase(i,e,br') ->
+ | MLcons (typ,r,a) -> iota_red 0 k br (typ,r,a)
+ | MLcase(typ,e,br') ->
let new_br =
- Array.map (fun (n,i,c)->(n,i,iota (k+(List.length i)) c)) br'
- in MLcase(i,e, new_br)
- | _ -> assert false
- in iota 0
+ Array.map (fun (i,p,c)->(i,p,iota (k+(List.length i)) c)) br'
+ in MLcase(typ,e,new_br)
+ | _ -> raise Impossible
+ in iota 0 hd
let is_atomic = function
| MLrel _ | MLglob _ | MLexn _ | MLdummy -> true
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: mlutil.mli 14786 2011-12-10 12:55:19Z letouzey $ i*)
-
open Util
open Names
open Term
@@ -20,7 +18,6 @@ open Table
val reset_meta_count : unit -> unit
val new_meta : 'a -> ml_type
-val type_subst : int -> ml_type -> ml_type -> ml_type
val type_subst_list : ml_type list -> ml_type -> ml_type
val type_subst_vect : ml_type array -> ml_type -> ml_type
@@ -118,9 +115,11 @@ val normalize : ml_ast -> ml_ast
val optimize_fix : ml_ast -> ml_ast
val inline : global_reference -> ml_ast -> bool
+val is_basic_pattern : ml_pattern -> bool
+val has_deep_pattern : ml_branch array -> bool
+val is_regular_match : ml_branch array -> bool
+
exception Impossible
-val branch_as_fun : ml_type list -> ml_branch -> ml_ast
-val branch_as_cst : ml_branch -> ml_ast
(* Classification of signatures *)
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
index ffa38def..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: modutil.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Names
open Declarations
open Environ
@@ -28,7 +26,7 @@ let rec msid_of_mt = function
(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a
[ml_structure]. *)
-let struct_iter do_decl do_spec s =
+let se_iter do_decl do_spec =
let rec mt_iter = function
| MTident _ -> ()
| 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: modutil.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Names
open Declarations
open Environ
@@ -38,4 +36,5 @@ val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
optimizations. The first argument is the list of objects we want to appear.
*)
-val optimize_struct : global_reference list -> ml_structure -> ml_structure
+val optimize_struct : global_reference list * module_path list ->
+ ml_structure -> ml_structure
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index c07a1758..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: ocaml.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(*s Production of Ocaml syntax. *)
open Pp
@@ -31,22 +29,6 @@ let pp_tvar id =
then str ("'"^s)
else str ("' "^s)
-let pp_tuple_light f = function
- | [] -> mt ()
- | [x] -> f true x
- | l ->
- pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l)
-
-let pp_tuple f = function
- | [] -> mt ()
- | [x] -> f x
- | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l)
-
-let pp_boxed_tuple f = function
- | [] -> mt ()
- | [x] -> f x
- | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l))
-
let pp_abst = function
| [] -> mt ()
| l ->
@@ -59,6 +41,10 @@ let pp_parameters l =
let pp_string_parameters l =
(pp_boxed_tuple str l ++ space_if (l<>[]))
+let pp_letin pat def body =
+ let fstline = str "let " ++ pat ++ str " =" ++ spc () ++ def in
+ hv 0 (hv 0 (hov 2 fstline ++ spc () ++ str "in") ++ spc () ++ hov 0 body)
+
(*s Ocaml renaming issues. *)
let keywords =
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: ocaml.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
val ocaml_descr : Miniml.language_descr
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index 1f04ca59..21507655 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: scheme.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(*s Production of Scheme syntax. *)
open Pp
@@ -87,7 +85,7 @@ let rec pp_expr env args =
++ spc () ++ hov 0 (pp_expr env' [] a2)))))
| MLglob r ->
apply (pp_global Term r)
- | MLcons (info,r,args') ->
+ | MLcons (_,r,args') ->
assert (args=[]);
let st =
str "`" ++
@@ -95,9 +93,12 @@ let rec pp_expr env args =
(if args' = [] then mt () else spc ()) ++
prlist_with_sep spc (pp_cons_args env) args')
in
- if info.c_kind = Coinductive then paren (str "delay " ++ st) else st
+ if is_coinductive r then paren (str "delay " ++ st) else st
+ | MLtuple _ -> error "Cannot handle tuples in Scheme yet."
+ | MLcase (_,_,pv) when not (is_regular_match pv) ->
+ error "Cannot handle general patterns in Scheme yet."
| MLcase (_,t,pv) when is_custom_match pv ->
- let mkfun (_,ids,e) =
+ let mkfun (ids,_,e) =
if ids <> [] then named_lams (List.rev ids) e
else dummy_lams (ast_lift 1 e) 1
in
@@ -107,9 +108,9 @@ let rec pp_expr env args =
(str (find_custom_match pv) ++ fnl () ++
prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv
++ pp_expr env [] t)))
- | MLcase (info,t, pv) ->
- let e =
- if info.m_kind <> Coinductive then pp_expr env [] t
+ | MLcase (typ,t, pv) ->
+ let e =
+ if not (is_coinductive_type typ) then pp_expr env [] t
else paren (str "force" ++ spc () ++ pp_expr env [] t)
in
apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv)))
@@ -126,14 +127,18 @@ let rec pp_expr env args =
| MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"")
and pp_cons_args env = function
- | MLcons (info,r,args) when info.c_kind<>Coinductive ->
+ | MLcons (_,r,args) when is_coinductive r ->
paren (pp_global Cons r ++
(if args = [] then mt () else spc ()) ++
prlist_with_sep spc (pp_cons_args env) args)
| e -> str "," ++ pp_expr env [] e
-
-and pp_one_pat env (r,ids,t) =
+and pp_one_pat env (ids,p,t) =
+ let r = match p with
+ | Pusual r -> r
+ | Pcons (r,l) -> r (* cf. the check [is_regular_match] above *)
+ | _ -> assert false
+ in
let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
let args =
if ids = [] then mt ()
diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli
index c7c3d8b5..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: scheme.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
val scheme_descr : Miniml.language_descr
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index 67cf2210..238befd2 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: table.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Names
open Term
open Declarations
@@ -21,23 +19,11 @@ open Util
open Pp
open Miniml
-(** Sets and maps for [global_reference] that work modulo equivalent
- on the user part of the name (otherwise use Refset / Refmap ) *)
-
-module RefOrd = struct
- type t = global_reference
- let compare x y =
- let make_name = function
- | ConstRef con -> ConstRef(constant_of_kn(user_con con))
- | IndRef (kn,i) -> IndRef(mind_of_kn(user_mind kn),i)
- | ConstructRef ((kn,i),j)-> ConstructRef((mind_of_kn(user_mind kn),i),j)
- | VarRef id -> VarRef id
- in
- Pervasives.compare (make_name x) (make_name y)
-end
+(** Sets and maps for [global_reference] that use the "user" [kernel_name]
+ instead of the canonical one *)
-module Refmap' = Map.Make(RefOrd)
-module Refset' = Set.Make(RefOrd)
+module Refmap' = Map.Make(RefOrdered_env)
+module Refset' = Set.Make(RefOrdered_env)
(*S Utilities about [module_path] and [kernel_names] and [global_reference] *)
@@ -71,11 +57,6 @@ let raw_string_of_modfile = function
| MPfile f -> String.capitalize (string_of_id (List.hd (repr_dirpath f)))
| _ -> assert false
-let rec modfile_of_mp = function
- | (MPfile _) as mp -> mp
- | MPdot (mp,_) -> modfile_of_mp mp
- | _ -> raise Not_found
-
let current_toplevel () = fst (Lib.current_prefix ())
let is_toplevel mp =
@@ -109,12 +90,6 @@ let common_prefix_from_list mp0 mpl =
| mp :: l -> if MPset.mem mp prefixes then Some mp else f l
in f mpl
-let rec parse_labels ll = function
- | MPdot (mp,l) -> parse_labels (l::ll) mp
- | mp -> mp,ll
-
-let labels_of_mp mp = parse_labels [] mp
-
let rec parse_labels2 ll mp1 = function
| mp when mp1=mp -> mp,ll
| MPdot (mp,l) -> parse_labels2 (l::ll) mp1 mp
@@ -125,10 +100,6 @@ let labels_of_ref r =
let mp,_,l = repr_of_r r in
parse_labels2 [l] mp_top mp
-let rec add_labels_mp mp = function
- | [] -> mp
- | l :: ll -> add_labels_mp (MPdot (mp,l)) ll
-
(*S The main tables: constants, inductives, records, ... *)
@@ -156,6 +127,39 @@ let add_ind kn mib ml_ind =
inductives := Mindmap_env.add kn (mib,ml_ind) !inductives
let lookup_ind kn = Mindmap_env.find kn !inductives
+let inductive_kinds =
+ ref (Mindmap_env.empty : inductive_kind Mindmap_env.t)
+let init_inductive_kinds () = inductive_kinds := Mindmap_env.empty
+let add_inductive_kind kn k =
+ inductive_kinds := Mindmap_env.add kn k !inductive_kinds
+let is_coinductive r =
+ let kn = match r with
+ | ConstructRef ((kn,_),_) -> kn
+ | IndRef (kn,_) -> kn
+ | _ -> assert false
+ in
+ try Mindmap_env.find kn !inductive_kinds = Coinductive
+ with Not_found -> false
+
+let is_coinductive_type = function
+ | Tglob (r,_) -> is_coinductive r
+ | _ -> false
+
+let get_record_fields r =
+ let kn = match r with
+ | ConstructRef ((kn,_),_) -> kn
+ | IndRef (kn,_) -> kn
+ | _ -> assert false
+ in
+ try match Mindmap_env.find kn !inductive_kinds with
+ | Record f -> f
+ | _ -> []
+ with Not_found -> []
+
+let record_fields_of_type = function
+ | Tglob (r,_) -> get_record_fields r
+ | _ -> []
+
(*s Recursors table. *)
(* NB: here we can use the equivalence between canonical
@@ -203,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: table.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Names
open Libnames
open Miniml
@@ -21,6 +19,7 @@ val safe_basename_of_global : global_reference -> identifier
(*s Warning and Error messages. *)
val warning_axioms : unit -> unit
+val warning_opaques : bool -> unit
val warning_both_mod_and_cst :
qualid -> module_path -> global_reference -> unit
val warning_id : string -> unit
@@ -59,10 +58,8 @@ val at_toplevel : module_path -> bool
val visible_con : constant -> bool
val mp_length : module_path -> int
val prefixes_mp : module_path -> MPset.t
-val modfile_of_mp : module_path -> module_path
val common_prefix_from_list :
module_path -> module_path list -> module_path option
-val add_labels_mp : module_path -> label list -> module_path
val get_nth_label_mp : int -> module_path -> label
val labels_of_ref : global_reference -> module_path * label list
@@ -77,6 +74,14 @@ val lookup_type : constant -> ml_schema
val add_ind : mutual_inductive -> mutual_inductive_body -> ml_ind -> unit
val lookup_ind : mutual_inductive -> mutual_inductive_body * ml_ind
+val add_inductive_kind : mutual_inductive -> inductive_kind -> unit
+val is_coinductive : global_reference -> bool
+val is_coinductive_type : ml_type -> bool
+(* What are the fields of a record (empty for a non-record) *)
+val get_record_fields :
+ global_reference -> global_reference option list
+val record_fields_of_type : ml_type -> global_reference option list
+
val add_recursors : Environ.env -> mutual_inductive -> unit
val is_recursor : global_reference -> bool
@@ -88,8 +93,15 @@ val add_info_axiom : global_reference -> unit
val remove_info_axiom : global_reference -> unit
val add_log_axiom : global_reference -> unit
+val add_opaque : global_reference -> unit
+val remove_opaque : global_reference -> unit
+
val reset_tables : unit -> unit
+(*s AccessOpaque parameter *)
+
+val access_opaque : unit -> bool
+
(*s AutoInline parameter *)
val auto_inline : unit -> bool
@@ -98,6 +110,10 @@ val auto_inline : unit -> bool
val type_expand : unit -> bool
+(*s KeepSingleton parameter *)
+
+val keep_singleton : unit -> bool
+
(*s Optimize parameter *)
type opt_flag =
@@ -120,11 +136,20 @@ val optims : unit -> opt_flag
type lang = Ocaml | Haskell | Scheme
val lang : unit -> lang
-(*s Extraction mode: modular or monolithic *)
+(*s Extraction modes: modular or monolithic, library or minimal ?
+
+Nota:
+ - Recursive Extraction : monolithic, minimal
+ - Separate Extraction : modular, minimal
+ - Extraction Library : modular, library
+*)
val set_modular : bool -> unit
val modular : unit -> bool
+val set_library : bool -> unit
+val library : unit -> bool
+
(*s Table for custom inlining *)
val to_inline : global_reference -> bool
@@ -158,6 +183,7 @@ val extract_constant_inline :
val extract_inductive :
reference -> string -> string list -> string option -> unit
+
type int_or_id = ArgInt of int | ArgId of identifier
val extraction_implicit : reference -> int_or_id list -> unit
diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v
index 9017f8d5..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyField.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Export LegacyField_Compl.
Require Export LegacyField_Theory.
Require Export LegacyField_Tactic.
diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v
index 52e049a5..97c70c0e 100644
--- a/plugins/field/LegacyField_Compl.v
+++ b/plugins/field/LegacyField_Compl.v
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyField_Compl.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Import List.
Definition assoc_2nd :=
diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v
index f6626e4a..810443f8 100644
--- a/plugins/field/LegacyField_Tactic.v
+++ b/plugins/field/LegacyField_Tactic.v
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyField_Tactic.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Import List.
Require Import LegacyRing.
Require Export LegacyField_Compl.
diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v
index 8d10bc8e..20ffbc27 100644
--- a/plugins/field/LegacyField_Theory.v
+++ b/plugins/field/LegacyField_Theory.v
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyField_Theory.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Import List.
Require Import Peano_dec.
Require Import LegacyRing.
diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4
index 37aa457d..9e4f4d74 100644
--- a/plugins/field/field.ml4
+++ b/plugins/field/field.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,8 +8,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: field.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Names
open Pp
open Proof_type
@@ -39,18 +37,20 @@ let constr_of_opt a opt =
| None -> mkApp (init_constant "None",[|ac3|])
| Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|])
+module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
+
(* Table of theories *)
-let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t)
+let th_tab = ref (Cmap.empty : constr Cmap.t)
let lookup env typ =
- try Gmap.find typ !th_tab
+ try Cmap.find typ !th_tab
with Not_found ->
errorlabstrm "field"
(str "No field is declared for type" ++ spc() ++
Printer.pr_lconstr_env env typ)
let _ =
- let init () = th_tab := Gmap.empty in
+ let init () = th_tab := Cmap.empty in
let freeze () = !th_tab in
let unfreeze fs = th_tab := fs in
Summary.declare_summary "field"
@@ -59,7 +59,7 @@ let _ =
Summary.init_function = init }
let load_addfield _ = ()
-let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab
+let cache_addfield (_,(typ,th)) = th_tab := Cmap.add typ th !th_tab
let subst_addfield (subst,(typ,th as obj)) =
let typ' = subst_mps subst typ in
let th' = subst_mps subst th in
@@ -67,7 +67,7 @@ let subst_addfield (subst,(typ,th as obj)) =
(typ',th')
(* Declaration of the Add Field library object *)
-let (in_addfield,out_addfield)=
+let in_addfield : types * constr -> Libobject.obj =
Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with
Libobject.open_function = (fun i o -> if i=1 then cache_addfield o);
Libobject.cache_function = cache_addfield;
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
index 1f3fd595..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: formula.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Hipattern
open Names
open Term
diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli
index a831c087..379aaff1 100644
--- a/plugins/firstorder/formula.mli
+++ b/plugins/firstorder/formula.mli
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: formula.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Term
open Names
open Libnames
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index 8e68506c..4a38c48d 100644
--- a/plugins/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,8 +8,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_ground.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Formula
open Sequent
open Ground
@@ -29,6 +27,7 @@ let ground_depth=ref 3
let _=
let gdopt=
{ optsync=true;
+ optdepr=false;
optname="Firstorder Depth";
optkey=["Firstorder";"Depth"];
optread=(fun ()->Some !ground_depth);
@@ -44,6 +43,7 @@ let congruence_depth=ref 100
let _=
let gdopt=
{ optsync=true;
+ optdepr=false;
optname="Congruence Depth";
optkey=["Congruence";"Depth"];
optread=(fun ()->Some !congruence_depth);
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ground.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Formula
open Sequent
open Rules
@@ -18,32 +16,6 @@ open Tactics
open Tacticals
open Libnames
-(*
-let old_search=ref !Auto.searchtable
-
-(* I use this solution as a means to know whether hints have changed,
-but this prevents the GC from collecting the previous table,
-resulting in some limited space wasting*)
-
-let update_flags ()=
- if not ( !Auto.searchtable == !old_search ) then
- begin
- old_search:=!Auto.searchtable;
- let predref=ref Names.KNpred.empty in
- let f p_a_t =
- match p_a_t.Auto.code with
- Auto.Unfold_nth (ConstRef kn)->
- predref:=Names.KNpred.add kn !predref
- | _ ->() in
- let g _ l=List.iter f l in
- let h _ hdb=Auto.Hint_db.iter g hdb in
- Util.Stringmap.iter h !Auto.searchtable;
- red_flags:=
- Closure.RedFlags.red_add_transparent
- Closure.betaiotazeta (Names.Idpred.full,!predref)
- end
-*)
-
let update_flags ()=
let predref=ref Names.Cpred.empty in
let f coe=
@@ -61,7 +33,7 @@ let ground_tac solver startseq gl=
update_flags ();
let rec toptac skipped seq gl=
if Tacinterp.get_debug()=Tactic_debug.DebugOn 0
- then Pp.msgnl (Printer.pr_goal (sig_it gl));
+ then Pp.msgnl (Printer.pr_goal gl);
tclORELSE (axiom_tac seq.gl seq)
begin
try
diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli
index 8328bb3a..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ground.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
val ground_tac: Tacmach.tactic ->
(Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml
index 4802aaa3..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: instances.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Formula
open Sequent
open Unify
open Rules
open Util
open Term
-open Rawterm
+open Glob_term
open Tacmach
open Tactics
open Tacticals
@@ -35,11 +33,11 @@ let compare_instance inst1 inst2=
| Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1
| Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1
-let compare_gr id1 id2=
+let compare_gr id1 id2 =
if id1==id2 then 0 else
if id1==dummy_id then 1
else if id2==dummy_id then -1
- else Pervasives.compare id1 id2
+ else Libnames.RefOrdered.compare id1 id2
module OrderedInstance=
struct
@@ -125,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: instances.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Term
open Tacmach
open Names
diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml
index e6d73fb6..23eeb2f6 100644
--- a/plugins/firstorder/rules.ml
+++ b/plugins/firstorder/rules.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: rules.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util
open Names
open Term
diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli
index a5a6b614..7d1e57f4 100644
--- a/plugins/firstorder/rules.mli
+++ b/plugins/firstorder/rules.mli
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: rules.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Term
open Tacmach
open Names
diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
index faac286e..f75678c6 100644
--- a/plugins/firstorder/sequent.ml
+++ b/plugins/firstorder/sequent.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: sequent.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Term
open Util
open Formula
@@ -59,71 +57,10 @@ struct
(priority e1.pat) - (priority e2.pat)
end
-(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
- the immediate subterms of [c1] of [c2] if needed; Cast's,
- application associativity, binders name and Cases annotations are
- not taken into account *)
-
-let rec compare_list f l1 l2=
- match l1,l2 with
- [],[]-> 0
- | [],_ -> -1
- | _,[] -> 1
- | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2
-
-let compare_array f v1 v2=
- let l=Array.length v1 in
- let c=l - Array.length v2 in
- if c=0 then
- let rec comp_aux i=
- if i<0 then 0
- else
- let ci=f v1.(i) v2.(i) in
- if ci=0 then
- comp_aux (i-1)
- else ci
- in comp_aux (l-1)
- else c
-
-let compare_constr_int f t1 t2 =
- match kind_of_term t1, kind_of_term t2 with
- | Rel n1, Rel n2 -> n1 - n2
- | Meta m1, Meta m2 -> m1 - m2
- | Var id1, Var id2 -> Pervasives.compare id1 id2
- | Sort s1, Sort s2 -> Pervasives.compare s1 s2
- | Cast (c1,_,_), _ -> f c1 t2
- | _, Cast (c2,_,_) -> f t1 c2
- | Prod (_,t1,c1), Prod (_,t2,c2)
- | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
- (f =? f) t1 t2 c1 c2
- | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
- ((f =? f) ==? f) b1 b2 t1 t2 c1 c2
- | App (_,_), App (_,_) ->
- let c1,l1=decompose_app t1
- and c2,l2=decompose_app t2 in
- (f =? (compare_list f)) c1 c2 l1 l2
- | Evar (e1,l1), Evar (e2,l2) ->
- ((-) =? (compare_array f)) e1 e2 l1 l2
- | Const c1, Const c2 -> Pervasives.compare c1 c2
- | Ind c1, Ind c2 -> Pervasives.compare c1 c2
- | Construct c1, Construct c2 -> Pervasives.compare c1 c2
- | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
- ((f =? f) ==? (compare_array f)) p1 p2 c1 c2 bl1 bl2
- | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
- ((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
- ln1 ln2 tl1 tl2 bl1 bl2
- | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
- ((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
- ln1 ln2 tl1 tl2 bl1 bl2
- | _ -> Pervasives.compare t1 t2
-
-let rec compare_constr m n=
- compare_constr_int compare_constr m n
-
module OrderedConstr=
struct
type t=constr
- let compare=compare_constr
+ let compare=constr_ord
end
type h_item = global_reference * (int*constr) option
@@ -132,7 +69,7 @@ module Hitem=
struct
type t = h_item
let compare (id1,co1) (id2,co2)=
- (Pervasives.compare
+ (Libnames.RefOrdered.compare
=? (fun oc1 oc2 ->
match oc1,oc2 with
Some (m1,c1),Some (m2,c2) ->
@@ -283,7 +220,7 @@ let extend_with_auto_hints l seq gl=
seqref:=add_formula Hint gr typ !seqref gl
with Not_found->())
| _-> () in
- let g _ l=List.iter f l in
+ let g _ l = List.iter f l in
let h dbname=
let hdb=
try
diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli
index ef052605..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: sequent.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Term
open Util
open Formula
diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml
index 4e0ad108..299a0054 100644
--- a/plugins/firstorder/unify.ml
+++ b/plugins/firstorder/unify.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: unify.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Util
open Formula
open Tacmach
@@ -91,9 +89,8 @@ let unif t1 t2=
let value i t=
let add x y=
if x<0 then y else if y<0 then x else x+y in
- let tref=mkMeta i in
let rec vaux term=
- if term=tref then 0 else
+ if isMeta term && destMeta term = i then 0 else
let f v t=add v (vaux t) in
let vr=fold_constr f (-1) term in
if vr<0 then -1 else vr+1 in
diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli
index 4e0d88d3..06865611 100644
--- a/plugins/firstorder/unify.mli
+++ b/plugins/firstorder/unify.mli
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: unify.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Term
exception UFAIL of constr*constr
diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v
index d6447111..a1113d2d 100644
--- a/plugins/fourier/Fourier.v
+++ b/plugins/fourier/Fourier.v
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Fourier.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* "Fourier's method to solve linear inequations/equations systems.".*)
Require Export LegacyRing.
diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v
index 7c5b5ed7..3d16f189 100644
--- a/plugins/fourier/Fourier_util.v
+++ b/plugins/fourier/Fourier_util.v
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Fourier_util.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Export Rbase.
Comments "Lemmas used by the tactic Fourier".
diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml
index 1a92c716..6c4d4d15 100644
--- a/plugins/fourier/fourier.ml
+++ b/plugins/fourier/fourier.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: fourier.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* Méthode d'élimination de Fourier *)
(* Référence:
Auteur(s) : Fourier, Jean-Baptiste-Joseph
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 2cabcf52..48493785 100644
--- a/plugins/fourier/fourierR.ml
+++ b/plugins/fourier/fourierR.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: fourierR.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
@@ -31,17 +29,23 @@ qui donne le coefficient d'un terme du calcul des constructions,
qui est zéro si le terme n'y est pas.
*)
-type flin = {fhom:(constr , rational)Hashtbl.t;
+module Constrhash = Hashtbl.Make
+ (struct type t = constr
+ let equal = eq_constr
+ let hash = hash_constr
+ end)
+
+type flin = {fhom: rational Constrhash.t;
fcste:rational};;
-let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};;
+let flin_zero () = {fhom=Constrhash.create 50;fcste=r0};;
-let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;;
+let flin_coef f x = try (Constrhash.find f.fhom x) with _-> 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,8 +8,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_fourier.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open FourierR
TACTIC EXTEND fourier
diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v
index 763ed82f..b29b8362 100644
--- a/plugins/funind/Recdef.v
+++ b/plugins/funind/Recdef.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index 3590e698..1d1e4a2a 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1,7 +1,6 @@
open Printer
open Util
open Term
-open Termops
open Namegen
open Names
open Declarations
@@ -35,9 +34,10 @@ let observennl strm =
let do_observe_tac s tac g =
try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v
with e ->
- let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
+ 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -16,19 +16,20 @@ open Indfun
open Genarg
open Pcoq
open Tacticals
+open Constr
let pr_binding prc = function
- | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
- | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
+ | loc, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ cut () ++ prc c)
+ | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c)
let pr_bindings prc prlc = function
- | Rawterm.ImplicitBindings l ->
+ | Glob_term.ImplicitBindings l ->
brk (1,1) ++ str "with" ++ brk (1,1) ++
Util.prlist_with_sep spc prc l
- | Rawterm.ExplicitBindings l ->
+ | Glob_term.ExplicitBindings l ->
brk (1,1) ++ str "with" ++ brk (1,1) ++
Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
- | Rawterm.NoBindings -> mt ()
+ | Glob_term.NoBindings -> mt ()
let pr_with_bindings prc prlc (c,bl) =
prc c ++ hv 0 (pr_bindings prc prlc bl)
@@ -55,7 +56,6 @@ let pr_fun_ind_using_typed prc prlc _ opt_c =
ARGUMENT EXTEND fun_ind_using
- TYPED AS constr_with_bindings_opt
PRINTED BY pr_fun_ind_using_typed
RAW_TYPED AS constr_with_bindings_opt
RAW_PRINTED BY pr_fun_ind_using
@@ -129,85 +129,36 @@ ARGUMENT EXTEND auto_using'
| [ ] -> [ [] ]
END
-let pr_rec_annotation2_aux s r id l =
- str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++
- Util.pr_opt Nameops.pr_id id ++
- Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}"
-
-let pr_rec_annotation2 = function
- | Struct id -> str "{struct" ++ Nameops.pr_id id ++ str "}"
- | Wf(r,id,l) -> pr_rec_annotation2_aux "wf" r id l
- | Mes(r,id,l) -> pr_rec_annotation2_aux "measure" r id l
-
-VERNAC ARGUMENT EXTEND rec_annotation2
-PRINTED BY pr_rec_annotation2
- [ "{" "struct" ident(id) "}"] -> [ Struct id ]
-| [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ]
-| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ]
-END
-
-let pr_binder2 (idl,c) =
- str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++
- str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")"
+module Gram = Pcoq.Gram
+module Vernac = Pcoq.Vernac_
+module Tactic = Pcoq.Tactic
-VERNAC ARGUMENT EXTEND binder2
-PRINTED BY pr_binder2
- [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> [ (idl,c) ]
-END
+module FunctionGram =
+struct
+ let gec s = Gram.entry_create ("Function."^s)
+ (* types *)
+ let function_rec_definition_loc : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located Gram.entry = gec "function_rec_definition_loc"
+end
+open FunctionGram
-let make_binder2 (idl,c) =
- LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c)
-
-let pr_rec_definition2 (id,bl,annot,type_,def) =
- Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++
- Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++
- Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++
- Ppconstr.pr_lconstr_expr def
-
-VERNAC ARGUMENT EXTEND rec_definition2
-PRINTED BY pr_rec_definition2
- [ ident(id) binder2_list(bl)
- rec_annotation2_opt(annot) ":" lconstr(type_)
- ":=" lconstr(def)] ->
- [ (id,bl,annot,type_,def) ]
-END
+GEXTEND Gram
+ GLOBAL: function_rec_definition_loc ;
-let make_rec_definitions2 (id,bl,annot,type_,def) =
- let bl = List.map make_binder2 bl in
- let names = List.map snd (Topconstr.names_of_local_assums bl) in
- let check_one_name () =
- if List.length names > 1 then
- Util.user_err_loc
- (Util.dummy_loc,"Function",
- Pp.str "the recursive argument needs to be specified");
- in
- let check_exists_args an =
- try
- let id = match an with
- | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id
- | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args"
- in
- (try ignore(Util.list_index0 (Name id) names); annot
- with Not_found -> Util.user_err_loc
- (Util.dummy_loc,"Function",
- Pp.str "No argument named " ++ Nameops.pr_id id)
- )
- with Failure "check_exists_args" -> check_one_name ();annot
- in
- let ni =
- match annot with
- | None ->
- annot
- | Some an ->
- check_exists_args an
- in
- ((Util.dummy_loc,id), ni, bl, type_, def)
+ function_rec_definition_loc:
+ [ [ g = Vernac.rec_definition -> loc, g ]]
+ ;
+ END
+type 'a function_rec_definition_loc_argtype = ((Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) located, 'a) Genarg.abstract_argument_type
+let (wit_function_rec_definition_loc : Genarg.tlevel function_rec_definition_loc_argtype),
+ (globwit_function_rec_definition_loc : Genarg.glevel function_rec_definition_loc_argtype),
+ (rawwit_function_rec_definition_loc : Genarg.rlevel function_rec_definition_loc_argtype) =
+ Genarg.create_arg "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/rawterm_to_relation.ml b/plugins/funind/glob_term_to_relation.ml
index b74422a3..c88c6669 100644
--- a/plugins/funind/rawterm_to_relation.ml
+++ b/plugins/funind/glob_term_to_relation.ml
@@ -2,11 +2,11 @@ open Printer
open Pp
open Names
open Term
-open Rawterm
+open Glob_term
open Libnames
open Indfun_common
open Util
-open Rawtermops
+open Glob_termops
let observe strm =
if do_observe ()
@@ -23,31 +23,31 @@ type binder_type =
| Prod of name
| LetIn of name
-type raw_context = (binder_type*rawconstr) list
+type glob_context = (binder_type*glob_constr) list
(*
- compose_raw_context [(bt_1,n_1,t_1);......] rt returns
+ compose_glob_context [(bt_1,n_1,t_1);......] rt returns
b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the
binders corresponding to the bt_i's
*)
-let compose_raw_context =
+let compose_glob_context =
let compose_binder (bt,t) acc =
match bt with
- | Lambda n -> mkRLambda(n,t,acc)
- | Prod n -> mkRProd(n,t,acc)
- | LetIn n -> mkRLetIn(n,t,acc)
+ | Lambda n -> mkGLambda(n,t,acc)
+ | Prod n -> mkGProd(n,t,acc)
+ | LetIn n -> mkGLetIn(n,t,acc)
in
List.fold_right compose_binder
(*
- The main part deals with building a list of raw constructor expressions
+ The main part deals with building a list of globalized constructor expressions
from the rhs of a fixpoint equation.
*)
type 'a build_entry_pre_return =
{
- context : raw_context; (* the binding context of the result *)
+ context : glob_context; (* the binding context of the result *)
value : 'a; (* The value *)
}
@@ -159,8 +159,8 @@ let apply_args ctxt body args =
| _,[] -> (* No more args *)
(ctxt,body)
| [],_ -> (* no more fun *)
- let f,args' = raw_decompose_app body in
- (ctxt,mkRApp(f,args'@args))
+ let f,args' = glob_decompose_app body in
+ (ctxt,mkGApp(f,args'@args))
| (Lambda Anonymous,t)::ctxt',arg::args' ->
do_apply avoid ctxt' body args'
| (Lambda (Name id),t)::ctxt',arg::args' ->
@@ -215,8 +215,8 @@ let combine_app f args =
let combine_lam n t b =
{
context = [];
- value = mkRLambda(n, compose_raw_context t.context t.value,
- compose_raw_context b.context b.value )
+ value = mkGLambda(n, compose_glob_context t.context t.value,
+ compose_glob_context b.context b.value )
}
@@ -269,8 +269,8 @@ let make_discr_match_brl i =
list_map_i
(fun j (_,idl,patl,_) ->
if j=i
- then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref))
- else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref))
+ then (dummy_loc,idl,patl, mkGRef (Lazy.force coq_True_ref))
+ else (dummy_loc,idl,patl, mkGRef (Lazy.force coq_False_ref))
)
0
(*
@@ -281,7 +281,7 @@ let make_discr_match_brl i =
*)
let make_discr_match brl =
fun el i ->
- mkRCases(None,
+ mkGCases(None,
make_discr_match_el el,
make_discr_match_brl i brl)
@@ -312,22 +312,22 @@ let build_constructors_of_type ind' argl =
if argl = []
then
Array.to_list
- (Array.init (cst_narg - npar) (fun _ -> mkRHole ())
+ (Array.init (cst_narg - npar) (fun _ -> mkGHole ())
)
else argl
in
let pat_as_term =
- mkRApp(mkRRef (ConstructRef(ind',i+1)),argl)
+ mkGApp(mkGRef (ConstructRef(ind',i+1)),argl)
in
- cases_pattern_of_rawconstr Anonymous pat_as_term
+ cases_pattern_of_glob_constr Anonymous pat_as_term
)
ind.Declarations.mind_consnames
(* [find_type_of] very naive attempts to discover the type of an if or a letin *)
let rec find_type_of nb b =
- let f,_ = raw_decompose_app b in
+ let f,_ = glob_decompose_app b in
match f with
- | RRef(_,ref) ->
+ | GRef(_,ref) ->
begin
let ind_type =
match ref with
@@ -350,8 +350,8 @@ let rec find_type_of nb b =
then raise (Invalid_argument "find_type_of : not a valid inductive");
ind_type
end
- | RCast(_,b,_) -> find_type_of nb b
- | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *)
+ | GCast(_,b,_) -> find_type_of nb b
+ | GApp _ -> assert false (* we have decomposed any application via glob_decompose_app *)
| _ -> raise (Invalid_argument "not a ref")
@@ -419,7 +419,7 @@ let add_pat_variables pat typ env : Environ.env =
let rec pattern_to_term_and_type env typ = function
| PatVar(loc,Anonymous) -> assert false
| PatVar(loc,Name id) ->
- mkRVar id
+ mkGVar id
| PatCstr(loc,constr,patternl,_) ->
let cst_narg =
Inductiveops.mis_constructor_nargs_env
@@ -445,7 +445,7 @@ let rec pattern_to_term_and_type env typ = function
let patl_as_term =
List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl
in
- mkRApp(mkRRef(ConstructRef constr),
+ mkGApp(mkGRef(ConstructRef constr),
implicit_args@patl_as_term
)
@@ -472,7 +472,7 @@ let rec pattern_to_term_and_type env typ = function
and concatenate them (informally, each branch of a match produces a new constructor)
\end{itemize}
- WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed.
+ WARNING: The terms constructed here are only USING the glob_constr syntax but are highly bad formed.
We must wait to have complete all the current calculi to set the recursive calls.
At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by
a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later.
@@ -481,15 +481,15 @@ let rec pattern_to_term_and_type env typ = function
*)
-let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
- observe (str " Entering : " ++ Printer.pr_rawconstr rt);
+let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return =
+ observe (str " Entering : " ++ Printer.pr_glob_constr rt);
match rt with
- | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ ->
+ | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ ->
(* do nothing (except changing type of course) *)
mk_result [] rt avoid
- | RApp(_,_,_) ->
- let f,args = raw_decompose_app rt in
- let args_res : (rawconstr list) build_entry_return =
+ | GApp(_,_,_) ->
+ let f,args = glob_decompose_app rt in
+ let args_res : (glob_constr list) build_entry_return =
List.fold_right (* create the arguments lists of constructors and combine them *)
(fun arg ctxt_argsl ->
let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in
@@ -500,19 +500,19 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
in
begin
match f with
- | RLambda _ ->
+ | GLambda _ ->
let rec aux t l =
match l with
| [] -> t
| u::l ->
match t with
- | RLambda(loc,na,_,nat,b) ->
- RLetIn(dummy_loc,na,u,aux b l)
+ | GLambda(loc,na,_,nat,b) ->
+ GLetIn(dummy_loc,na,u,aux b l)
| _ ->
- RApp(dummy_loc,t,l)
+ GApp(dummy_loc,t,l)
in
build_entry_lc env funnames avoid (aux f args)
- | RVar(_,id) when Idset.mem id funnames ->
+ | GVar(_,id) when Idset.mem id funnames ->
(* if we have [f t1 ... tn] with [f]$\in$[fnames]
then we create a fresh variable [res],
add [res] and its "value" (i.e. [res v1 ... vn]) to each
@@ -525,20 +525,20 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in
let res = fresh_id args_res.to_avoid "res" in
let new_avoid = res::args_res.to_avoid in
- let res_rt = mkRVar res in
+ let res_rt = mkGVar res in
let new_result =
List.map
(fun arg_res ->
let new_hyps =
[Prod (Name res),res_raw_type;
- Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)]
+ Prod Anonymous,mkGApp(res_rt,(mkGVar id)::arg_res.value)]
in
{context = arg_res.context@new_hyps; value = res_rt }
)
args_res.result
in
{ result = new_result; to_avoid = new_avoid }
- | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ ->
+ | GVar _ | GEvar _ | GPatVar _ | GHole _ | GSort _ | GRef _ ->
(* if have [g t1 ... tn] with [g] not appearing in [funnames]
then
foreach [ctxt,v1 ... vn] in [args_res] we return
@@ -549,11 +549,11 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
result =
List.map
(fun args_res ->
- {args_res with value = mkRApp(f,args_res.value)})
+ {args_res with value = mkGApp(f,args_res.value)})
args_res.result
}
- | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *)
- | RLetIn(_,n,t,b) ->
+ | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *)
+ | GLetIn(_,n,t,b) ->
(* if we have [(let x := v in b) t1 ... tn] ,
we discard our work and compute the list of constructor for
[let x = v in (b t1 ... tn)] up to alpha conversion
@@ -567,7 +567,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
let new_b =
replace_var_by_term
id
- (RVar(dummy_loc,id))
+ (GVar(dummy_loc,id))
b
in
(Name new_id,new_b,new_avoid)
@@ -577,27 +577,26 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
env
funnames
avoid
- (mkRLetIn(new_n,t,mkRApp(new_b,args)))
- | RCases _ | RIf _ | RLetTuple _ ->
+ (mkGLetIn(new_n,t,mkGApp(new_b,args)))
+ | GCases _ | GIf _ | GLetTuple _ ->
(* we have [(match e1, ...., en with ..... end) t1 tn]
we first compute the result from the case and
then combine each of them with each of args one
*)
let f_res = build_entry_lc env funnames args_res.to_avoid f in
combine_results combine_app f_res args_res
- | RDynamic _ ->error "Not handled RDynamic"
- | RCast(_,b,_) ->
+ | GCast(_,b,_) ->
(* for an applied cast we just trash the cast part
and restart the work.
WARNING: We need to restart since [b] itself should be an application term
*)
- build_entry_lc env funnames avoid (mkRApp(b,args))
- | RRec _ -> error "Not handled RRec"
- | RProd _ -> error "Cannot apply a type"
+ build_entry_lc env funnames avoid (mkGApp(b,args))
+ | GRec _ -> error "Not handled GRec"
+ | GProd _ -> error "Cannot apply a type"
end (* end of the application treatement *)
- | RLambda(_,n,_,t,b) ->
+ | GLambda(_,n,_,t,b) ->
(* we first compute the list of constructor
corresponding to the body of the function,
then the one corresponding to the type
@@ -612,7 +611,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
let new_env = raw_push_named (new_n,None,t) env in
let b_res = build_entry_lc new_env funnames avoid b in
combine_results (combine_lam new_n) t_res b_res
- | RProd(_,n,_,t,b) ->
+ | GProd(_,n,_,t,b) ->
(* we first compute the list of constructor
corresponding to the body of the function,
then the one corresponding to the type
@@ -622,7 +621,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
let new_env = raw_push_named (n,None,t) env in
let b_res = build_entry_lc new_env funnames avoid b in
combine_results (combine_prod n) t_res b_res
- | RLetIn(_,n,v,b) ->
+ | GLetIn(_,n,v,b) ->
(* we first compute the list of constructor
corresponding to the body of the function,
then the one corresponding to the value [t]
@@ -638,21 +637,21 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
in
let b_res = build_entry_lc new_env funnames avoid b in
combine_results (combine_letin n) v_res b_res
- | RCases(_,_,_,el,brl) ->
+ | GCases(_,_,_,el,brl) ->
(* we create the discrimination function
and treat the case itself
*)
let make_discr = make_discr_match brl in
build_entry_lc_from_case env funnames make_discr el brl avoid
- | RIf(_,b,(na,e_option),lhs,rhs) ->
+ | GIf(_,b,(na,e_option),lhs,rhs) ->
let b_as_constr = Pretyping.Default.understand Evd.empty env b in
let b_typ = Typing.type_of env Evd.empty b_as_constr in
let (ind,_) =
try Inductiveops.find_inductive env Evd.empty b_typ
with Not_found ->
errorlabstrm "" (str "Cannot find the inductive associated to " ++
- Printer.pr_rawconstr b ++ str " in " ++
- Printer.pr_rawconstr rt ++ str ". try again with a cast")
+ Printer.pr_glob_constr b ++ str " in " ++
+ Printer.pr_glob_constr rt ++ str ". try again with a cast")
in
let case_pats = build_constructors_of_type ind [] in
assert (Array.length case_pats = 2);
@@ -663,17 +662,17 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
[lhs;rhs]
in
let match_expr =
- mkRCases(None,[(b,(Anonymous,None))],brl)
+ mkGCases(None,[(b,(Anonymous,None))],brl)
in
- (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
+ (* Pp.msgnl (str "new case := " ++ Printer.pr_glob_constr match_expr); *)
build_entry_lc env funnames avoid match_expr
- | RLetTuple(_,nal,_,b,e) ->
+ | GLetTuple(_,nal,_,b,e) ->
begin
- let nal_as_rawconstr =
+ let nal_as_glob_constr =
List.map
(function
- Name id -> mkRVar id
- | Anonymous -> mkRHole ()
+ Name id -> mkGVar id
+ | Anonymous -> mkGHole ()
)
nal
in
@@ -683,26 +682,25 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
try Inductiveops.find_inductive env Evd.empty b_typ
with Not_found ->
errorlabstrm "" (str "Cannot find the inductive associated to " ++
- Printer.pr_rawconstr b ++ str " in " ++
- Printer.pr_rawconstr rt ++ str ". try again with a cast")
+ Printer.pr_glob_constr b ++ str " in " ++
+ Printer.pr_glob_constr rt ++ str ". try again with a cast")
in
- let case_pats = build_constructors_of_type ind nal_as_rawconstr in
+ let case_pats = build_constructors_of_type ind nal_as_glob_constr in
assert (Array.length case_pats = 1);
let br =
(dummy_loc,[],[case_pats.(0)],e)
in
- let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in
+ let match_expr = mkGCases(None,[b,(Anonymous,None)],[br]) in
build_entry_lc env funnames avoid match_expr
end
- | RRec _ -> error "Not handled RRec"
- | RCast(_,b,_) ->
+ | GRec _ -> error "Not handled GRec"
+ | GCast(_,b,_) ->
build_entry_lc env funnames avoid b
- | RDynamic _ -> error "Not handled RDynamic"
and build_entry_lc_from_case env funname make_discr
(el:tomatch_tuples)
- (brl:Rawterm.cases_clauses) avoid :
- rawconstr build_entry_return =
+ (brl:Glob_term.cases_clauses) avoid :
+ glob_constr build_entry_return =
match el with
| [] -> assert false (* this case correspond to match <nothing> with .... !*)
| el ->
@@ -762,7 +760,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
(will be used in the following recursive calls)
*)
let new_env = List.fold_right2 add_pat_variables patl types env in
- let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list =
+ let not_those_patterns : (identifier list -> glob_constr -> glob_constr) list =
List.map2
(fun pat typ ->
fun avoid pat'_as_term ->
@@ -778,9 +776,9 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
Detyping.detype false []
(Termops.names_of_rel_context env_with_pat_ids) typ_of_id
in
- mkRProd (Name id,raw_typ_of_id,acc))
+ mkGProd (Name id,raw_typ_of_id,acc))
pat_ids
- (raw_make_neq pat'_as_term (pattern_to_term renamed_pat))
+ (glob_make_neq pat'_as_term (pattern_to_term renamed_pat))
)
patl
types
@@ -835,7 +833,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve
else acc
)
idl
- [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)]
+ [(Prod Anonymous,glob_make_eq ~typ pat_as_term e)]
)
patl
matched_expr.value
@@ -879,16 +877,16 @@ let is_res id =
let same_raw_term rt1 rt2 =
match rt1,rt2 with
- | RRef(_,r1), RRef (_,r2) -> r1=r2
- | RHole _, RHole _ -> true
+ | GRef(_,r1), GRef (_,r2) -> r1=r2
+ | GHole _, GHole _ -> true
| _ -> false
let decompose_raw_eq lhs rhs =
let rec decompose_raw_eq lhs rhs acc =
- observe (str "decomposing eq for " ++ pr_rawconstr lhs ++ str " " ++ pr_rawconstr rhs);
- let (rhd,lrhs) = raw_decompose_app rhs in
- let (lhd,llhs) = raw_decompose_app lhs in
- observe (str "lhd := " ++ pr_rawconstr lhd);
- observe (str "rhd := " ++ pr_rawconstr rhd);
+ observe (str "decomposing eq for " ++ pr_glob_constr lhs ++ str " " ++ pr_glob_constr rhs);
+ let (rhd,lrhs) = glob_decompose_app rhs in
+ let (lhd,llhs) = glob_decompose_app lhs in
+ observe (str "lhd := " ++ pr_glob_constr lhd);
+ observe (str "rhd := " ++ pr_glob_constr rhd);
observe (str "llhs := " ++ int (List.length llhs));
observe (str "lrhs := " ++ int (List.length lrhs));
let sllhs = List.length llhs in
@@ -905,29 +903,29 @@ let decompose_raw_eq lhs rhs =
exception Continue
(*
The second phase which reconstruct the real type of the constructor.
- rebuild the raw constructors expression.
+ rebuild the globalized constructors expression.
eliminates some meaningless equalities, applies some rewrites......
*)
let rec rebuild_cons env nb_args relname args crossed_types depth rt =
- observe (str "rebuilding : " ++ pr_rawconstr rt);
+ observe (str "rebuilding : " ++ pr_glob_constr rt);
match rt with
- | RProd(_,n,k,t,b) ->
+ | GProd(_,n,k,t,b) ->
let not_free_in_t id = not (is_free_in id t) in
let new_crossed_types = t::crossed_types in
begin
match t with
- | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id ->
+ | GApp(_,(GVar(_,res_id) as res_rt),args') when is_res res_id ->
begin
match args' with
- | (RVar(_,this_relname))::args' ->
+ | (GVar(_,this_relname))::args' ->
(*i The next call to mk_rel_id is
valid since we are constructing the graph
Ensures by: obvious
i*)
let new_t =
- mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt])
+ mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt])
in
let t' = Pretyping.Default.understand Evd.empty env new_t in
let new_env = Environ.push_rel (n,None,t') env in
@@ -937,17 +935,17 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
args new_crossed_types
(depth + 1) b
in
- mkRProd(n,new_t,new_b),
+ mkGProd(n,new_t,new_b),
Idset.filter not_free_in_t id_to_exclude
| _ -> (* the first args is the name of the function! *)
assert false
end
- | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt])
+ | GApp(loc1,GRef(loc2,eq_as_ref),[ty;GVar(loc3,id);rt])
when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous
->
begin
try
- observe (str "computing new type for eq : " ++ pr_rawconstr rt);
+ observe (str "computing new type for eq : " ++ pr_glob_constr rt);
let t' =
try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue
in
@@ -968,7 +966,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
new_args new_crossed_types
(depth + 1) subst_b
in
- mkRProd(n,t,new_b),id_to_exclude
+ mkGProd(n,t,new_b),id_to_exclude
with Continue ->
let jmeq = Libnames.IndRef (destInd (jmeq ())) in
let ty' = Pretyping.Default.understand Evd.empty env ty in
@@ -979,20 +977,20 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
((Util.list_chop nparam args'))
in
let rt_typ =
- RApp(Util.dummy_loc,
- RRef (Util.dummy_loc,Libnames.IndRef ind),
+ GApp(Util.dummy_loc,
+ GRef (Util.dummy_loc,Libnames.IndRef ind),
(List.map
(fun p -> Detyping.detype false []
(Termops.names_of_rel_context env)
p) params)@(Array.to_list
(Array.make
(List.length args' - nparam)
- (mkRHole ()))))
+ (mkGHole ()))))
in
let eq' =
- RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt])
+ GApp(loc1,GRef(loc2,jmeq),[ty;GVar(loc3,id);rt_typ;rt])
in
- observe (str "computing new type for jmeq : " ++ pr_rawconstr eq');
+ observe (str "computing new type for jmeq : " ++ pr_glob_constr eq');
let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in
observe (str " computing new type for jmeq : done") ;
let new_args =
@@ -1051,14 +1049,14 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
new_args new_crossed_types
(depth + 1) subst_b
in
- mkRProd(n,eq',new_b),id_to_exclude
+ mkGProd(n,eq',new_b),id_to_exclude
end
(* J.F:. keep this comment it explain how to remove some meaningless equalities
if keep_eq then
- mkRProd(n,t,new_b),id_to_exclude
+ mkGProd(n,t,new_b),id_to_exclude
else new_b, Idset.add id id_to_exclude
*)
- | RApp(loc1,RRef(loc2,eq_as_ref),[ty;rt1;rt2])
+ | GApp(loc1,GRef(loc2,eq_as_ref),[ty;rt1;rt2])
when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous
->
begin
@@ -1069,8 +1067,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
let new_rt =
List.fold_left
(fun acc (lhs,rhs) ->
- mkRProd(Anonymous,
- mkRApp(mkRRef(eq_as_ref),[mkRHole ();lhs;rhs]),acc)
+ mkGProd(Anonymous,
+ mkGApp(mkGRef(eq_as_ref),[mkGHole ();lhs;rhs]),acc)
)
b
l
@@ -1078,7 +1076,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
rebuild_cons env nb_args relname args crossed_types depth new_rt
else raise Continue
with Continue ->
- observe (str "computing new type for prod : " ++ pr_rawconstr rt);
+ observe (str "computing new type for prod : " ++ pr_glob_constr rt);
let t' = Pretyping.Default.understand Evd.empty env t in
let new_env = Environ.push_rel (n,None,t') env in
let new_b,id_to_exclude =
@@ -1091,10 +1089,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
| Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
new_b,Idset.remove id
(Idset.filter not_free_in_t id_to_exclude)
- | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+ | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
end
| _ ->
- observe (str "computing new type for prod : " ++ pr_rawconstr rt);
+ observe (str "computing new type for prod : " ++ pr_glob_constr rt);
let t' = Pretyping.Default.understand Evd.empty env t in
let new_env = Environ.push_rel (n,None,t') env in
let new_b,id_to_exclude =
@@ -1107,13 +1105,13 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
| Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
new_b,Idset.remove id
(Idset.filter not_free_in_t id_to_exclude)
- | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+ | _ -> mkGProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
end
- | RLambda(_,n,k,t,b) ->
+ | GLambda(_,n,k,t,b) ->
begin
let not_free_in_t id = not (is_free_in id t) in
let new_crossed_types = t :: crossed_types in
- observe (str "computing new type for lambda : " ++ pr_rawconstr rt);
+ observe (str "computing new type for lambda : " ++ pr_glob_constr rt);
let t' = Pretyping.Default.understand Evd.empty env t in
match n with
| Name id ->
@@ -1121,19 +1119,19 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
- (args@[mkRVar id])new_crossed_types
+ (args@[mkGVar id])new_crossed_types
(depth + 1 ) b
in
if Idset.mem id id_to_exclude && depth >= nb_args
then
new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
else
- RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude
+ GProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude
| _ -> anomaly "Should not have an anonymous function here"
(* We have renamed all the anonymous functions during alpha_renaming phase *)
end
- | RLetIn(_,n,t,b) ->
+ | GLetIn(_,n,t,b) ->
begin
let not_free_in_t id = not (is_free_in id t) in
let t' = Pretyping.Default.understand Evd.empty env t in
@@ -1147,10 +1145,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
match n with
| Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
- | _ -> RLetIn(dummy_loc,n,t,new_b),
+ | _ -> GLetIn(dummy_loc,n,t,new_b),
Idset.filter not_free_in_t id_to_exclude
end
- | RLetTuple(_,nal,(na,rto),t,b) ->
+ | GLetTuple(_,nal,(na,rto),t,b) ->
assert (rto=None);
begin
let not_free_in_t id = not (is_free_in id t) in
@@ -1173,22 +1171,22 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
(* | Name id when Idset.mem id id_to_exclude -> *)
(* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *)
(* | _ -> *)
- RLetTuple(dummy_loc,nal,(na,None),t,new_b),
+ GLetTuple(dummy_loc,nal,(na,None),t,new_b),
Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude')
end
- | _ -> mkRApp(mkRVar relname,args@[rt]),Idset.empty
+ | _ -> mkGApp(mkGVar relname,args@[rt]),Idset.empty
(* debuging wrapper *)
let rebuild_cons env nb_args relname args crossed_types rt =
- observe (str "rebuild_cons : rt := "++ pr_rawconstr rt ++
- str "nb_args := " ++ str (string_of_int nb_args));
+(* observennl (str "rebuild_cons : rt := "++ pr_glob_constr rt ++ *)
+(* str "nb_args := " ++ str (string_of_int nb_args)); *)
let res =
rebuild_cons env nb_args relname args crossed_types 0 rt
in
- observe (str " leads to "++ pr_rawconstr (fst res));
+(* observe (str " leads to "++ pr_glob_constr (fst res)); *)
res
@@ -1200,30 +1198,30 @@ let rebuild_cons env nb_args relname args crossed_types rt =
TODO: Find a valid way to deal with implicit arguments here!
*)
let rec compute_cst_params relnames params = function
- | RRef _ | RVar _ | REvar _ | RPatVar _ -> params
- | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames ->
+ | GRef _ | GVar _ | GEvar _ | GPatVar _ -> params
+ | GApp(_,GVar(_,relname'),rtl) when Idset.mem relname' relnames ->
compute_cst_params_from_app [] (params,rtl)
- | RApp(_,f,args) ->
+ | GApp(_,f,args) ->
List.fold_left (compute_cst_params relnames) params (f::args)
- | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) ->
+ | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetIn(_,_,t,b) | GLetTuple(_,_,_,t,b) ->
let t_params = compute_cst_params relnames params t in
compute_cst_params relnames t_params b
- | RCases _ ->
+ | GCases _ ->
params (* If there is still cases at this point they can only be
discriminitation ones *)
- | RSort _ -> params
- | RHole _ -> params
- | RIf _ | RRec _ | RCast _ | RDynamic _ ->
+ | GSort _ -> params
+ | GHole _ -> params
+ | GIf _ | GRec _ | GCast _ ->
raise (UserError("compute_cst_params", str "Not handled case"))
and compute_cst_params_from_app acc (params,rtl) =
match params,rtl with
| _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *)
- | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl'
+ | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl'
when id_ord id id' == 0 && not is_defined ->
compute_cst_params_from_app (param::acc) (params',rtl')
| _ -> List.rev acc
-let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts =
+let compute_params_name relnames (args : (Names.name * Glob_term.glob_constr * bool) list array) csts =
let rels_params =
Array.mapi
(fun i args ->
@@ -1242,7 +1240,7 @@ let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool)
if array_for_all
(fun l ->
let (n',nt',is_defined') = List.nth l i in
- n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined')
+ n = n' && Topconstr.eq_glob_constr nt nt' && is_defined = is_defined')
rels_params
then
l := param::!l
@@ -1261,15 +1259,15 @@ let rec rebuild_return_type rt =
Topconstr.CArrow(loc,t,rebuild_return_type t')
| Topconstr.CLetIn(loc,na,t,t') ->
Topconstr.CLetIn(loc,na,t,rebuild_return_type t')
- | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None))
+ | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,GType None))
let do_build_inductive
- funnames (funsargs: (Names.name * rawconstr * bool) list list)
+ funnames (funsargs: (Names.name * glob_constr * bool) list list)
returned_types
- (rtl:rawconstr list) =
+ (rtl:glob_constr list) =
let _time1 = System.get_time () in
-(* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *)
+(* Pp.msgnl (prlist_with_sep fnl Printer.pr_glob_constr rtl); *)
let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in
let funnames = Array.of_list funnames in
let funsargs = Array.of_list funsargs in
@@ -1286,7 +1284,7 @@ let do_build_inductive
let env =
Array.fold_right
(fun id env ->
- Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env
+ Environ.push_named (id,None,Typing.type_of env Evd.empty (Constrintern.global_reference id)) env
)
funnames
(Global.env ())
@@ -1294,19 +1292,19 @@ let do_build_inductive
let resa = Array.map (build_entry_lc env funnames_as_set []) rta in
let env_with_graphs =
let rel_arity i funargs = (* Reduilding arities (with parameters) *)
- let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list =
+ let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list =
funargs
in
List.fold_right
(fun (n,t,is_defined) acc ->
if is_defined
then
- Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
+ Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t,
acc)
else
Topconstr.CProdN
(dummy_loc,
- [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
+ [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t],
acc
)
)
@@ -1325,9 +1323,9 @@ let do_build_inductive
let constr i res =
List.map
(function result (* (args',concl') *) ->
- let rt = compose_raw_context result.context result.value in
+ let rt = compose_glob_context result.context result.value in
let nb_args = List.length funsargs.(i) in
- (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *)
+ (* with_full_print (fun rt -> Pp.msgnl (str "glob constr " ++ pr_glob_constr rt)) rt; *)
fst (
rebuild_cons env_with_graphs nb_args relnames.(i)
[]
@@ -1346,7 +1344,7 @@ let do_build_inductive
i*)
id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
in
- let rel_constructors i rt : (identifier*rawconstr) list =
+ let rel_constructors i rt : (identifier*glob_constr) list =
next_constructor_id := (-1);
List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
in
@@ -1360,19 +1358,19 @@ let do_build_inductive
rel_constructors
in
let rel_arity i funargs = (* Reduilding arities (with parameters) *)
- let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list =
+ let rel_first_args :(Names.name * Glob_term.glob_constr * bool ) list =
(snd (list_chop nrel_params funargs))
in
List.fold_right
(fun (n,t,is_defined) acc ->
if is_defined
then
- Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
+ Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_glob_constr Idset.empty t,
acc)
else
Topconstr.CProdN
(dummy_loc,
- [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
+ [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_glob_constr Idset.empty t],
acc
)
)
@@ -1389,10 +1387,10 @@ let do_build_inductive
(fun (n,t,is_defined) ->
if is_defined
then
- Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t)
+ Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_glob_constr Idset.empty t)
else
Topconstr.LocalRawAssum
- ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t)
+ ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_glob_constr Idset.empty t)
)
rels_params
in
@@ -1402,7 +1400,7 @@ let do_build_inductive
false,((dummy_loc,id),
Flags.with_option
Flags.raw_print
- (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t)
+ (Constrextern.extern_glob_type Idset.empty) ((* zeta_normalize *) t)
)
))
(rel_constructors)
@@ -1465,7 +1463,7 @@ let do_build_inductive
str "while trying to define"++ spc () ++
Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
++ fnl () ++
- Cerrors.explain_exn e
+ Errors.print e
in
observe msg;
raise e
diff --git a/plugins/funind/rawterm_to_relation.mli b/plugins/funind/glob_term_to_relation.mli
index a314050f..5c91292b 100644
--- a/plugins/funind/rawterm_to_relation.mli
+++ b/plugins/funind/glob_term_to_relation.mli
@@ -9,8 +9,8 @@
val build_inductive :
Names.identifier list -> (* The list of function name *)
- (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *)
+ (Names.name*Glob_term.glob_constr*bool) list list -> (* The list of function args *)
Topconstr.constr_expr list -> (* The list of function returned type *)
- Rawterm.rawconstr list -> (* the list of body *)
+ Glob_term.glob_constr list -> (* the list of body *)
unit
diff --git a/plugins/funind/rawtermops.ml b/plugins/funind/glob_termops.ml
index e31f1452..cdd0eaf7 100644
--- a/plugins/funind/rawtermops.ml
+++ b/plugins/funind/glob_termops.ml
@@ -1,89 +1,89 @@
open Pp
-open Rawterm
+open Glob_term
open Util
open Names
(* Ocaml 3.06 Map.S does not handle is_empty *)
let idmap_is_empty m = m = Idmap.empty
(*
- Some basic functions to rebuild rawconstr
+ Some basic functions to rebuild glob_constr
In each of them the location is Util.dummy_loc
*)
-let mkRRef ref = RRef(dummy_loc,ref)
-let mkRVar id = RVar(dummy_loc,id)
-let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl)
-let mkRLambda(n,t,b) = RLambda(dummy_loc,n,Explicit,t,b)
-let mkRProd(n,t,b) = RProd(dummy_loc,n,Explicit,t,b)
-let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b)
-let mkRCases(rto,l,brl) = RCases(dummy_loc,Term.RegularStyle,rto,l,brl)
-let mkRSort s = RSort(dummy_loc,s)
-let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous)
-let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
+let mkGRef ref = GRef(dummy_loc,ref)
+let mkGVar id = GVar(dummy_loc,id)
+let mkGApp(rt,rtl) = GApp(dummy_loc,rt,rtl)
+let mkGLambda(n,t,b) = GLambda(dummy_loc,n,Explicit,t,b)
+let mkGProd(n,t,b) = GProd(dummy_loc,n,Explicit,t,b)
+let mkGLetIn(n,t,b) = GLetIn(dummy_loc,n,t,b)
+let mkGCases(rto,l,brl) = GCases(dummy_loc,Term.RegularStyle,rto,l,brl)
+let mkGSort s = GSort(dummy_loc,s)
+let mkGHole () = GHole(dummy_loc,Evd.BinderType Anonymous)
+let mkGCast(b,t) = GCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
(*
- Some basic functions to decompose rawconstrs
+ Some basic functions to decompose glob_constrs
These are analogous to the ones constrs
*)
-let raw_decompose_prod =
- let rec raw_decompose_prod args = function
- | RProd(_,n,k,t,b) ->
- raw_decompose_prod ((n,t)::args) b
+let glob_decompose_prod =
+ let rec glob_decompose_prod args = function
+ | GProd(_,n,k,t,b) ->
+ glob_decompose_prod ((n,t)::args) b
| rt -> args,rt
in
- raw_decompose_prod []
-
-let raw_decompose_prod_or_letin =
- let rec raw_decompose_prod args = function
- | RProd(_,n,k,t,b) ->
- raw_decompose_prod ((n,None,Some t)::args) b
- | RLetIn(_,n,t,b) ->
- raw_decompose_prod ((n,Some t,None)::args) b
+ glob_decompose_prod []
+
+let glob_decompose_prod_or_letin =
+ let rec glob_decompose_prod args = function
+ | GProd(_,n,k,t,b) ->
+ glob_decompose_prod ((n,None,Some t)::args) b
+ | GLetIn(_,n,t,b) ->
+ glob_decompose_prod ((n,Some t,None)::args) b
| rt -> args,rt
in
- raw_decompose_prod []
+ glob_decompose_prod []
-let raw_compose_prod =
- List.fold_left (fun b (n,t) -> mkRProd(n,t,b))
+let glob_compose_prod =
+ List.fold_left (fun b (n,t) -> mkGProd(n,t,b))
-let raw_compose_prod_or_letin =
+let glob_compose_prod_or_letin =
List.fold_left (
fun concl decl ->
match decl with
- | (n,None,Some t) -> mkRProd(n,t,concl)
- | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl)
+ | (n,None,Some t) -> mkGProd(n,t,concl)
+ | (n,Some bdy,None) -> mkGLetIn(n,bdy,concl)
| _ -> assert false)
-let raw_decompose_prod_n n =
- let rec raw_decompose_prod i args c =
+let glob_decompose_prod_n n =
+ let rec glob_decompose_prod i args c =
if i<=0 then args,c
else
match c with
- | RProd(_,n,_,t,b) ->
- raw_decompose_prod (i-1) ((n,t)::args) b
+ | GProd(_,n,_,t,b) ->
+ glob_decompose_prod (i-1) ((n,t)::args) b
| rt -> args,rt
in
- raw_decompose_prod n []
+ glob_decompose_prod n []
-let raw_decompose_prod_or_letin_n n =
- let rec raw_decompose_prod i args c =
+let glob_decompose_prod_or_letin_n n =
+ let rec glob_decompose_prod i args c =
if i<=0 then args,c
else
match c with
- | RProd(_,n,_,t,b) ->
- raw_decompose_prod (i-1) ((n,None,Some t)::args) b
- | RLetIn(_,n,t,b) ->
- raw_decompose_prod (i-1) ((n,Some t,None)::args) b
+ | GProd(_,n,_,t,b) ->
+ glob_decompose_prod (i-1) ((n,None,Some t)::args) b
+ | GLetIn(_,n,t,b) ->
+ glob_decompose_prod (i-1) ((n,Some t,None)::args) b
| rt -> args,rt
in
- raw_decompose_prod n []
+ glob_decompose_prod n []
-let raw_decompose_app =
+let glob_decompose_app =
let rec decompose_rapp acc rt =
-(* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *)
+(* msgnl (str "glob_decompose_app on : "++ Printer.pr_glob_constr rt); *)
match rt with
- | RApp(_,rt,rtl) ->
+ | GApp(_,rt,rtl) ->
decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt
| rt -> rt,List.rev acc
in
@@ -92,24 +92,24 @@ let raw_decompose_app =
-(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
-let raw_make_eq ?(typ= mkRHole ()) t1 t2 =
- mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1])
+(* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *)
+let glob_make_eq ?(typ= mkGHole ()) t1 t2 =
+ mkGApp(mkGRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1])
-(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
-let raw_make_neq t1 t2 =
- mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2])
+(* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *)
+let glob_make_neq t1 t2 =
+ mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2])
-(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *)
-let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
+(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *)
+let glob_make_or t1 t2 = mkGApp (mkGRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
-(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
+(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding
to [P1 \/ ( .... \/ Pn)]
*)
-let rec raw_make_or_list = function
+let rec glob_make_or_list = function
| [] -> raise (Invalid_argument "mk_or")
| [e] -> e
- | e::l -> raw_make_or e (raw_make_or_list l)
+ | e::l -> glob_make_or e (glob_make_or_list l)
let remove_name_from_mapping mapping na =
@@ -120,70 +120,69 @@ let remove_name_from_mapping mapping na =
let change_vars =
let rec change_vars mapping rt =
match rt with
- | RRef _ -> rt
- | RVar(loc,id) ->
+ | GRef _ -> rt
+ | GVar(loc,id) ->
let new_id =
try
Idmap.find id mapping
with Not_found -> id
in
- RVar(loc,new_id)
- | REvar _ -> rt
- | RPatVar _ -> rt
- | RApp(loc,rt',rtl) ->
- RApp(loc,
+ GVar(loc,new_id)
+ | GEvar _ -> rt
+ | GPatVar _ -> rt
+ | GApp(loc,rt',rtl) ->
+ GApp(loc,
change_vars mapping rt',
List.map (change_vars mapping) rtl
)
- | RLambda(loc,name,k,t,b) ->
- RLambda(loc,
+ | GLambda(loc,name,k,t,b) ->
+ GLambda(loc,
name,
k,
change_vars mapping t,
change_vars (remove_name_from_mapping mapping name) b
)
- | RProd(loc,name,k,t,b) ->
- RProd(loc,
+ | GProd(loc,name,k,t,b) ->
+ GProd(loc,
name,
k,
change_vars mapping t,
change_vars (remove_name_from_mapping mapping name) b
)
- | RLetIn(loc,name,def,b) ->
- RLetIn(loc,
+ | GLetIn(loc,name,def,b) ->
+ GLetIn(loc,
name,
change_vars mapping def,
change_vars (remove_name_from_mapping mapping name) b
)
- | RLetTuple(loc,nal,(na,rto),b,e) ->
+ | GLetTuple(loc,nal,(na,rto),b,e) ->
let new_mapping = List.fold_left remove_name_from_mapping mapping nal in
- RLetTuple(loc,
+ GLetTuple(loc,
nal,
(na, Option.map (change_vars mapping) rto),
change_vars mapping b,
change_vars new_mapping e
)
- | RCases(loc,sty,infos,el,brl) ->
- RCases(loc,sty,
+ | GCases(loc,sty,infos,el,brl) ->
+ GCases(loc,sty,
infos,
List.map (fun (e,x) -> (change_vars mapping e,x)) el,
List.map (change_vars_br mapping) brl
)
- | RIf(loc,b,(na,e_option),lhs,rhs) ->
- RIf(loc,
+ | GIf(loc,b,(na,e_option),lhs,rhs) ->
+ GIf(loc,
change_vars mapping b,
(na,Option.map (change_vars mapping) e_option),
change_vars mapping lhs,
change_vars mapping rhs
)
- | RRec _ -> error "Local (co)fixes are not supported"
- | RSort _ -> rt
- | RHole _ -> rt
- | RCast(loc,b,CastConv (k,t)) ->
- RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t))
- | RCast(loc,b,CastCoerce) ->
- RCast(loc,change_vars mapping b,CastCoerce)
- | RDynamic _ -> error "Not handled RDynamic"
+ | GRec _ -> error "Local (co)fixes are not supported"
+ | GSort _ -> rt
+ | GHole _ -> rt
+ | GCast(loc,b,CastConv (k,t)) ->
+ GCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t))
+ | GCast(loc,b,CastCoerce) ->
+ GCast(loc,change_vars mapping b,CastCoerce)
and change_vars_br mapping ((loc,idl,patl,res) as br) =
let new_mapping = List.fold_right Idmap.remove idl mapping in
if idmap_is_empty new_mapping
@@ -262,22 +261,22 @@ let get_pattern_id pat = raw_get_pattern_id pat []
let rec alpha_rt excluded rt =
let new_rt =
match rt with
- | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt
- | RLambda(loc,Anonymous,k,t,b) ->
+ | GRef _ | GVar _ | GEvar _ | GPatVar _ -> rt
+ | GLambda(loc,Anonymous,k,t,b) ->
let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in
let new_excluded = new_id :: excluded in
let new_t = alpha_rt new_excluded t in
let new_b = alpha_rt new_excluded b in
- RLambda(loc,Name new_id,k,new_t,new_b)
- | RProd(loc,Anonymous,k,t,b) ->
+ GLambda(loc,Name new_id,k,new_t,new_b)
+ | GProd(loc,Anonymous,k,t,b) ->
let new_t = alpha_rt excluded t in
let new_b = alpha_rt excluded b in
- RProd(loc,Anonymous,k,new_t,new_b)
- | RLetIn(loc,Anonymous,t,b) ->
+ GProd(loc,Anonymous,k,new_t,new_b)
+ | GLetIn(loc,Anonymous,t,b) ->
let new_t = alpha_rt excluded t in
let new_b = alpha_rt excluded b in
- RLetIn(loc,Anonymous,new_t,new_b)
- | RLambda(loc,Name id,k,t,b) ->
+ GLetIn(loc,Anonymous,new_t,new_b)
+ | GLambda(loc,Name id,k,t,b) ->
let new_id = Namegen.next_ident_away id excluded in
let t,b =
if new_id = id
@@ -289,8 +288,8 @@ let rec alpha_rt excluded rt =
let new_excluded = new_id::excluded in
let new_t = alpha_rt new_excluded t in
let new_b = alpha_rt new_excluded b in
- RLambda(loc,Name new_id,k,new_t,new_b)
- | RProd(loc,Name id,k,t,b) ->
+ GLambda(loc,Name new_id,k,new_t,new_b)
+ | GProd(loc,Name id,k,t,b) ->
let new_id = Namegen.next_ident_away id excluded in
let new_excluded = new_id::excluded in
let t,b =
@@ -302,8 +301,8 @@ let rec alpha_rt excluded rt =
in
let new_t = alpha_rt new_excluded t in
let new_b = alpha_rt new_excluded b in
- RProd(loc,Name new_id,k,new_t,new_b)
- | RLetIn(loc,Name id,t,b) ->
+ GProd(loc,Name new_id,k,new_t,new_b)
+ | GLetIn(loc,Name id,t,b) ->
let new_id = Namegen.next_ident_away id excluded in
let t,b =
if new_id = id
@@ -315,10 +314,10 @@ let rec alpha_rt excluded rt =
let new_excluded = new_id::excluded in
let new_t = alpha_rt new_excluded t in
let new_b = alpha_rt new_excluded b in
- RLetIn(loc,Name new_id,new_t,new_b)
+ GLetIn(loc,Name new_id,new_t,new_b)
- | RLetTuple(loc,nal,(na,rto),t,b) ->
+ | GLetTuple(loc,nal,(na,rto),t,b) ->
let rev_new_nal,new_excluded,mapping =
List.fold_left
(fun (nal,excluded,mapping) na ->
@@ -345,28 +344,27 @@ let rec alpha_rt excluded rt =
let new_t = alpha_rt new_excluded new_t in
let new_b = alpha_rt new_excluded new_b in
let new_rto = Option.map (alpha_rt new_excluded) new_rto in
- RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
- | RCases(loc,sty,infos,el,brl) ->
+ GLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
+ | GCases(loc,sty,infos,el,brl) ->
let new_el =
List.map (function (rt,i) -> alpha_rt excluded rt, i) el
in
- RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl)
- | RIf(loc,b,(na,e_o),lhs,rhs) ->
- RIf(loc,alpha_rt excluded b,
+ GCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl)
+ | GIf(loc,b,(na,e_o),lhs,rhs) ->
+ GIf(loc,alpha_rt excluded b,
(na,Option.map (alpha_rt excluded) e_o),
alpha_rt excluded lhs,
alpha_rt excluded rhs
)
- | RRec _ -> error "Not handled RRec"
- | RSort _ -> rt
- | RHole _ -> rt
- | RCast (loc,b,CastConv (k,t)) ->
- RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
- | RCast (loc,b,CastCoerce) ->
- RCast(loc,alpha_rt excluded b,CastCoerce)
- | RDynamic _ -> error "Not handled RDynamic"
- | RApp(loc,f,args) ->
- RApp(loc,
+ | GRec _ -> error "Not handled GRec"
+ | GSort _ -> rt
+ | GHole _ -> rt
+ | GCast (loc,b,CastConv (k,t)) ->
+ GCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
+ | GCast (loc,b,CastCoerce) ->
+ GCast(loc,alpha_rt excluded b,CastCoerce)
+ | GApp(loc,f,args) ->
+ GApp(loc,
alpha_rt excluded f,
List.map (alpha_rt excluded) args
)
@@ -386,35 +384,34 @@ and alpha_br excluded (loc,ids,patl,res) =
*)
let is_free_in id =
let rec is_free_in = function
- | RRef _ -> false
- | RVar(_,id') -> id_ord id' id == 0
- | REvar _ -> false
- | RPatVar _ -> false
- | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
- | RLambda(_,n,_,t,b) | RProd(_,n,_,t,b) | RLetIn(_,n,t,b) ->
+ | GRef _ -> false
+ | GVar(_,id') -> id_ord id' id == 0
+ | GEvar _ -> false
+ | GPatVar _ -> false
+ | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
+ | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) ->
let check_in_b =
match n with
| Name id' -> id_ord id' id <> 0
| _ -> true
in
is_free_in t || (check_in_b && is_free_in b)
- | RCases(_,_,_,el,brl) ->
+ | GCases(_,_,_,el,brl) ->
(List.exists (fun (e,_) -> is_free_in e) el) ||
List.exists is_free_in_br brl
- | RLetTuple(_,nal,_,b,t) ->
+ | GLetTuple(_,nal,_,b,t) ->
let check_in_nal =
not (List.exists (function Name id' -> id'= id | _ -> false) nal)
in
is_free_in t || (check_in_nal && is_free_in b)
- | RIf(_,cond,_,br1,br2) ->
+ | GIf(_,cond,_,br1,br2) ->
is_free_in cond || is_free_in br1 || is_free_in br2
- | RRec _ -> raise (UserError("",str "Not handled RRec"))
- | RSort _ -> false
- | RHole _ -> false
- | RCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t
- | RCast (_,b,CastCoerce) -> is_free_in b
- | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+ | GRec _ -> raise (UserError("",str "Not handled GRec"))
+ | GSort _ -> false
+ | GHole _ -> false
+ | GCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t
+ | GCast (_,b,CastCoerce) -> is_free_in b
and is_free_in_br (_,ids,_,rt) =
(not (List.mem id ids)) && is_free_in rt
in
@@ -425,7 +422,7 @@ let is_free_in id =
let rec pattern_to_term = function
| PatVar(loc,Anonymous) -> assert false
| PatVar(loc,Name id) ->
- mkRVar id
+ mkGVar id
| PatCstr(loc,constr,patternl,_) ->
let cst_narg =
Inductiveops.mis_constructor_nargs_env
@@ -436,13 +433,13 @@ let rec pattern_to_term = function
Array.to_list
(Array.init
(cst_narg - List.length patternl)
- (fun _ -> mkRHole ())
+ (fun _ -> mkGHole ())
)
in
let patl_as_term =
List.map pattern_to_term patternl
in
- mkRApp(mkRRef(Libnames.ConstructRef constr),
+ mkGApp(mkGRef(Libnames.ConstructRef constr),
implicit_args@patl_as_term
)
@@ -451,69 +448,68 @@ let rec pattern_to_term = function
let replace_var_by_term x_id term =
let rec replace_var_by_pattern rt =
match rt with
- | RRef _ -> rt
- | RVar(_,id) when id_ord id x_id == 0 -> term
- | RVar _ -> rt
- | REvar _ -> rt
- | RPatVar _ -> rt
- | RApp(loc,rt',rtl) ->
- RApp(loc,
+ | GRef _ -> rt
+ | GVar(_,id) when id_ord id x_id == 0 -> term
+ | GVar _ -> rt
+ | GEvar _ -> rt
+ | GPatVar _ -> rt
+ | GApp(loc,rt',rtl) ->
+ GApp(loc,
replace_var_by_pattern rt',
List.map replace_var_by_pattern rtl
)
- | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
- | RLambda(loc,name,k,t,b) ->
- RLambda(loc,
+ | GLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+ | GLambda(loc,name,k,t,b) ->
+ GLambda(loc,
name,
k,
replace_var_by_pattern t,
replace_var_by_pattern b
)
- | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
- | RProd(loc,name,k,t,b) ->
- RProd(loc,
+ | GProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+ | GProd(loc,name,k,t,b) ->
+ GProd(loc,
name,
k,
replace_var_by_pattern t,
replace_var_by_pattern b
)
- | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
- | RLetIn(loc,name,def,b) ->
- RLetIn(loc,
+ | GLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
+ | GLetIn(loc,name,def,b) ->
+ GLetIn(loc,
name,
replace_var_by_pattern def,
replace_var_by_pattern b
)
- | RLetTuple(_,nal,_,_,_)
+ | GLetTuple(_,nal,_,_,_)
when List.exists (function Name id -> id = x_id | _ -> false) nal ->
rt
- | RLetTuple(loc,nal,(na,rto),def,b) ->
- RLetTuple(loc,
+ | GLetTuple(loc,nal,(na,rto),def,b) ->
+ GLetTuple(loc,
nal,
(na,Option.map replace_var_by_pattern rto),
replace_var_by_pattern def,
replace_var_by_pattern b
)
- | RCases(loc,sty,infos,el,brl) ->
- RCases(loc,sty,
+ | GCases(loc,sty,infos,el,brl) ->
+ GCases(loc,sty,
infos,
List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el,
List.map replace_var_by_pattern_br brl
)
- | RIf(loc,b,(na,e_option),lhs,rhs) ->
- RIf(loc, replace_var_by_pattern b,
+ | GIf(loc,b,(na,e_option),lhs,rhs) ->
+ GIf(loc, replace_var_by_pattern b,
(na,Option.map replace_var_by_pattern e_option),
replace_var_by_pattern lhs,
replace_var_by_pattern rhs
)
- | RRec _ -> raise (UserError("",str "Not handled RRec"))
- | RSort _ -> rt
- | RHole _ -> rt
- | RCast(loc,b,CastConv(k,t)) ->
- RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
- | RCast(loc,b,CastCoerce) ->
- RCast(loc,replace_var_by_pattern b,CastCoerce)
- | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+ | GRec _ -> raise (UserError("",str "Not handled GRec"))
+ | GSort _ -> rt
+ | GHole _ -> rt
+ | GCast(loc,b,CastConv(k,t)) ->
+ GCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
+ | GCast(loc,b,CastCoerce) ->
+ GCast(loc,replace_var_by_pattern b,CastCoerce)
and replace_var_by_pattern_br ((loc,idl,patl,res) as br) =
if List.exists (fun id -> id_ord id x_id == 0) idl
then br
@@ -586,28 +582,28 @@ let id_of_name = function
| Names.Name x -> x
(* TODO: finish Rec caes *)
-let ids_of_rawterm c =
- let rec ids_of_rawterm acc c =
+let ids_of_glob_constr c =
+ let rec ids_of_glob_constr acc c =
let idof = id_of_name in
match c with
- | RVar (_,id) -> id::acc
- | RApp (loc,g,args) ->
- ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc
- | RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
- | RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
- | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
- | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc
- | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc
- | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc
- | RLetTuple (_,nal,(na,po),b,c) ->
- List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
- | RCases (loc,sty,rtntypopt,tml,brchl) ->
- List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl)
- | RRec _ -> failwith "Fix inside a constructor branch"
- | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> []
+ | GVar (_,id) -> id::acc
+ | GApp (loc,g,args) ->
+ ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc
+ | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
+ | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc
+ | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc
+ | GCast (loc,c,CastConv(k,t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc
+ | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc
+ | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc
+ | GLetTuple (_,nal,(na,po),b,c) ->
+ List.map idof nal @ ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc
+ | GCases (loc,sty,rtntypopt,tml,brchl) ->
+ List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_glob_constr [] c) brchl)
+ | GRec _ -> failwith "Fix inside a constructor branch"
+ | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> []
in
(* build the set *)
- List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c)
+ List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_glob_constr [] c)
@@ -616,59 +612,58 @@ let ids_of_rawterm c =
let zeta_normalize =
let rec zeta_normalize_term rt =
match rt with
- | RRef _ -> rt
- | RVar _ -> rt
- | REvar _ -> rt
- | RPatVar _ -> rt
- | RApp(loc,rt',rtl) ->
- RApp(loc,
+ | GRef _ -> rt
+ | GVar _ -> rt
+ | GEvar _ -> rt
+ | GPatVar _ -> rt
+ | GApp(loc,rt',rtl) ->
+ GApp(loc,
zeta_normalize_term rt',
List.map zeta_normalize_term rtl
)
- | RLambda(loc,name,k,t,b) ->
- RLambda(loc,
+ | GLambda(loc,name,k,t,b) ->
+ GLambda(loc,
name,
k,
zeta_normalize_term t,
zeta_normalize_term b
)
- | RProd(loc,name,k,t,b) ->
- RProd(loc,
+ | GProd(loc,name,k,t,b) ->
+ GProd(loc,
name,
k,
zeta_normalize_term t,
zeta_normalize_term b
)
- | RLetIn(_,Name id,def,b) ->
+ | GLetIn(_,Name id,def,b) ->
zeta_normalize_term (replace_var_by_term id def b)
- | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
- | RLetTuple(loc,nal,(na,rto),def,b) ->
- RLetTuple(loc,
+ | GLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
+ | GLetTuple(loc,nal,(na,rto),def,b) ->
+ GLetTuple(loc,
nal,
(na,Option.map zeta_normalize_term rto),
zeta_normalize_term def,
zeta_normalize_term b
)
- | RCases(loc,sty,infos,el,brl) ->
- RCases(loc,sty,
+ | GCases(loc,sty,infos,el,brl) ->
+ GCases(loc,sty,
infos,
List.map (fun (e,x) -> (zeta_normalize_term e,x)) el,
List.map zeta_normalize_br brl
)
- | RIf(loc,b,(na,e_option),lhs,rhs) ->
- RIf(loc, zeta_normalize_term b,
+ | GIf(loc,b,(na,e_option),lhs,rhs) ->
+ GIf(loc, zeta_normalize_term b,
(na,Option.map zeta_normalize_term e_option),
zeta_normalize_term lhs,
zeta_normalize_term rhs
)
- | RRec _ -> raise (UserError("",str "Not handled RRec"))
- | RSort _ -> rt
- | RHole _ -> rt
- | RCast(loc,b,CastConv(k,t)) ->
- RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
- | RCast(loc,b,CastCoerce) ->
- RCast(loc,zeta_normalize_term b,CastCoerce)
- | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+ | GRec _ -> raise (UserError("",str "Not handled GRec"))
+ | GSort _ -> rt
+ | GHole _ -> rt
+ | GCast(loc,b,CastConv(k,t)) ->
+ GCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
+ | GCast(loc,b,CastCoerce) ->
+ GCast(loc,zeta_normalize_term b,CastCoerce)
and zeta_normalize_br (loc,idl,patl,res) =
(loc,idl,patl,zeta_normalize_term res)
in
@@ -688,29 +683,28 @@ let expand_as =
in
let rec expand_as map rt =
match rt with
- | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt
- | RVar(_,id) ->
+ | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ -> rt
+ | GVar(_,id) ->
begin
try
Idmap.find id map
with Not_found -> rt
end
- | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args)
- | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b)
- | RProd(loc,na,k,t,b) -> RProd(loc,na,k,expand_as map t, expand_as map b)
- | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b)
- | RLetTuple(loc,nal,(na,po),v,b) ->
- RLetTuple(loc,nal,(na,Option.map (expand_as map) po),
+ | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args)
+ | GLambda(loc,na,k,t,b) -> GLambda(loc,na,k,expand_as map t, expand_as map b)
+ | GProd(loc,na,k,t,b) -> GProd(loc,na,k,expand_as map t, expand_as map b)
+ | GLetIn(loc,na,v,b) -> GLetIn(loc,na, expand_as map v,expand_as map b)
+ | GLetTuple(loc,nal,(na,po),v,b) ->
+ GLetTuple(loc,nal,(na,Option.map (expand_as map) po),
expand_as map v, expand_as map b)
- | RIf(loc,e,(na,po),br1,br2) ->
- RIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
+ | GIf(loc,e,(na,po),br1,br2) ->
+ GIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
expand_as map br1, expand_as map br2)
- | RRec _ -> error "Not handled RRec"
- | RDynamic _ -> error "Not handled RDynamic"
- | RCast(loc,b,CastConv(kind,t)) -> RCast(loc,expand_as map b,CastConv(kind,expand_as map t))
- | RCast(loc,b,CastCoerce) -> RCast(loc,expand_as map b,CastCoerce)
- | RCases(loc,sty,po,el,brl) ->
- RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
+ | GRec _ -> error "Not handled GRec"
+ | GCast(loc,b,CastConv(kind,t)) -> GCast(loc,expand_as map b,CastConv(kind,expand_as map t))
+ | GCast(loc,b,CastCoerce) -> GCast(loc,expand_as map b,CastCoerce)
+ | GCases(loc,sty,po,el,brl) ->
+ GCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
List.map (expand_as_br map) brl)
and expand_as_br map (loc,idl,cpl,rt) =
(loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli
new file mode 100644
index 00000000..bfd15357
--- /dev/null
+++ b/plugins/funind/glob_termops.mli
@@ -0,0 +1,126 @@
+open Glob_term
+
+(* Ocaml 3.06 Map.S does not handle is_empty *)
+val idmap_is_empty : 'a Names.Idmap.t -> bool
+
+
+(* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *)
+val get_pattern_id : cases_pattern -> Names.identifier list
+
+(* [pattern_to_term pat] returns a glob_constr corresponding to [pat].
+ [pat] must not contain occurences of anonymous pattern
+*)
+val pattern_to_term : cases_pattern -> glob_constr
+
+(*
+ Some basic functions to rebuild glob_constr
+ In each of them the location is Util.dummy_loc
+*)
+val mkGRef : Libnames.global_reference -> glob_constr
+val mkGVar : Names.identifier -> glob_constr
+val mkGApp : glob_constr*(glob_constr list) -> glob_constr
+val mkGLambda : Names.name * glob_constr * glob_constr -> glob_constr
+val mkGProd : Names.name * glob_constr * glob_constr -> glob_constr
+val mkGLetIn : Names.name * glob_constr * glob_constr -> glob_constr
+val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr
+val mkGSort : glob_sort -> glob_constr
+val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *)
+val mkGCast : glob_constr* glob_constr -> glob_constr
+(*
+ Some basic functions to decompose glob_constrs
+ These are analogous to the ones constrs
+*)
+val glob_decompose_prod : glob_constr -> (Names.name*glob_constr) list * glob_constr
+val glob_decompose_prod_or_letin :
+ glob_constr -> (Names.name*glob_constr option*glob_constr option) list * glob_constr
+val glob_decompose_prod_n : int -> glob_constr -> (Names.name*glob_constr) list * glob_constr
+val glob_decompose_prod_or_letin_n : int -> glob_constr ->
+ (Names.name*glob_constr option*glob_constr option) list * glob_constr
+val glob_compose_prod : glob_constr -> (Names.name*glob_constr) list -> glob_constr
+val glob_compose_prod_or_letin: glob_constr ->
+ (Names.name*glob_constr option*glob_constr option) list -> glob_constr
+val glob_decompose_app : glob_constr -> glob_constr*(glob_constr list)
+
+
+(* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *)
+val glob_make_eq : ?typ:glob_constr -> glob_constr -> glob_constr -> glob_constr
+(* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *)
+val glob_make_neq : glob_constr -> glob_constr -> glob_constr
+(* [glob_make_or P1 P2] build the glob_constr corresponding to [P1 \/ P2] *)
+val glob_make_or : glob_constr -> glob_constr -> glob_constr
+
+(* [glob_make_or_list [P1;...;Pn]] build the glob_constr corresponding
+ to [P1 \/ ( .... \/ Pn)]
+*)
+val glob_make_or_list : glob_constr list -> glob_constr
+
+
+(* alpha_conversion functions *)
+
+
+
+(* Replace the var mapped in the glob_constr/context *)
+val change_vars : Names.identifier Names.Idmap.t -> glob_constr -> glob_constr
+
+
+
+(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t.
+ the result does not share variables with [avoid]. This function create
+ a fresh variable for each occurence of the anonymous pattern.
+
+ Also returns a mapping from old variables to new ones and the concatenation of
+ [avoid] with the variables appearing in the result.
+*)
+ val alpha_pat :
+ Names.Idmap.key list ->
+ Glob_term.cases_pattern ->
+ Glob_term.cases_pattern * Names.Idmap.key list *
+ Names.identifier Names.Idmap.t
+
+(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt
+ conventions and does not share bound variables with avoid
+*)
+val alpha_rt : Names.identifier list -> glob_constr -> glob_constr
+
+(* same as alpha_rt but for case branches *)
+val alpha_br : Names.identifier list ->
+ Util.loc * Names.identifier list * Glob_term.cases_pattern list *
+ Glob_term.glob_constr ->
+ Util.loc * Names.identifier list * Glob_term.cases_pattern list *
+ Glob_term.glob_constr
+
+
+(* Reduction function *)
+val replace_var_by_term :
+ Names.identifier ->
+ Glob_term.glob_constr -> Glob_term.glob_constr -> Glob_term.glob_constr
+
+
+
+(*
+ [is_free_in id rt] checks if [id] is a free variable in [rt]
+*)
+val is_free_in : Names.identifier -> glob_constr -> bool
+
+
+val are_unifiable : cases_pattern -> cases_pattern -> bool
+val eq_cases_pattern : cases_pattern -> cases_pattern -> bool
+
+
+
+(*
+ ids_of_pat : cases_pattern -> Idset.t
+ returns the set of variables appearing in a pattern
+*)
+val ids_of_pat : cases_pattern -> Names.Idset.t
+
+(* TODO: finish this function (Fix not treated) *)
+val ids_of_glob_constr: glob_constr -> Names.Idset.t
+
+(*
+ removing let_in construction in a glob_constr
+*)
+val zeta_normalize : Glob_term.glob_constr -> Glob_term.glob_constr
+
+
+val expand_as : glob_constr -> glob_constr
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index a61671f8..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -16,7 +16,6 @@ open Tacticals
open Tactics
open Indfun_common
open Tacmach
-open Termops
open Sign
open Hiddentac
@@ -24,17 +23,17 @@ open Hiddentac
let pr_binding prc =
function
- | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
- | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
+ | loc, Glob_term.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
+ | loc, Glob_term.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
let pr_bindings prc prlc = function
- | Rawterm.ImplicitBindings l ->
+ | Glob_term.ImplicitBindings l ->
brk (1,1) ++ str "with" ++ brk (1,1) ++
Util.prlist_with_sep spc prc l
- | Rawterm.ExplicitBindings l ->
+ | Glob_term.ExplicitBindings l ->
brk (1,1) ++ str "with" ++ brk (1,1) ++
Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l
- | Rawterm.NoBindings -> mt ()
+ | Glob_term.NoBindings -> mt ()
let pr_with_bindings prc prlc (c,bl) =
@@ -60,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,7 +8,6 @@
(* Merging of induction principles. *)
-(*i $Id: i*)
open Libnames
open Tactics
open Indfun_common
@@ -21,12 +20,12 @@ open Term
open Termops
open Declarations
open Environ
-open Rawterm
-open Rawtermops
+open Glob_term
+open Glob_termops
(** {1 Utilities} *)
-(** {2 Useful operations on constr and rawconstr} *)
+(** {2 Useful operations on constr and glob_constr} *)
let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
@@ -61,7 +60,7 @@ let string_of_name nme = string_of_id (id_of_name nme)
(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
let isVarf f x =
match x with
- | RVar (_,x) -> Pervasives.compare x f = 0
+ | GVar (_,x) -> Pervasives.compare x f = 0
| _ -> false
(** [ident_global_exist id] returns true if identifier [id] is linked
@@ -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/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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,10 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: recdef.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Term
-open Termops
open Namegen
open Environ
open Declarations
@@ -36,7 +33,7 @@ open Proof_type
open Vernacinterp
open Pfedit
open Topconstr
-open Rawterm
+open Glob_term
open Pretyping
open Pretyping.Default
open Safe_typing
@@ -69,45 +66,39 @@ let pf_get_new_id id g =
let h_intros l =
tclMAP h_intro l
-let debug_queue = Queue.create ()
+let debug_queue = Stack.create ()
-let rec print_debug_queue e =
- let lmsg,goal = Queue.pop debug_queue in
- if Queue.is_empty debug_queue
- then
- msgnl (lmsg ++ (str " raised exception " ++ Cerrors.explain_exn e) ++ str " on goal " ++ goal)
- else
+let rec print_debug_queue b e =
+ if not (Stack.is_empty debug_queue)
+ then
begin
- print_debug_queue e;
- msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal);
+ let lmsg,goal = Stack.pop debug_queue in
+ if b then
+ msgnl (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+ else
+ begin
+ msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal);
+ end;
+ print_debug_queue false e;
end
+
let do_observe_tac s tac g =
- let goal = Printer.pr_goal (sig_it g) in
- let lmsg = (str "recdef ") ++ (str s) in
- Queue.add (lmsg,goal) debug_queue;
+ let goal = Printer.pr_goal g in
+ let lmsg = (str "recdef : ") ++ (str s) in
+ Stack.push (lmsg,goal) debug_queue;
try
let v = tac g in
- ignore(Queue.pop debug_queue);
+ ignore(Stack.pop debug_queue);
v
with e ->
- if not (Queue.is_empty debug_queue)
+ 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -12,6 +12,8 @@
(* *)
(************************************************************************)
+(* FK: scheduled for deletion *)
+(*
Require Import Setoid.
Require Import Decidable.
Require Import List.
@@ -127,3 +129,4 @@ apply <- negate_correct. intro; now elim H3. exact (H1 H2).
Qed.
End CheckerMaker.
+*) \ No newline at end of file
diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v
index 5aa30fed..5f6c60be 100644
--- a/plugins/micromega/Env.v
+++ b/plugins/micromega/Env.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -17,27 +17,21 @@ Require Import Coq.Arith.Max.
Require Import List.
Set Implicit Arguments.
-(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v)
- -- this is harmless and spares a lot of Empty.
- This means smaller proof-terms.
- BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up.
-*)
-
Section S.
Variable D :Type.
Definition Env := positive -> D.
- Definition jump (j:positive) (e:Env) := fun x => e (Pplus x j).
+ Definition jump (j:positive) (e:Env) := fun x => e (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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -43,7 +43,7 @@ Section MakeRingPol.
cO cI cadd cmul csub copp ceqb phi.
(* Power coefficients *)
- Variable Cpow : Set.
+ Variable Cpow : Type.
Variable Cp_phi : N -> Cpow.
Variable rpow : R -> Cpow -> R.
Variable pow_th : power_theory rI rmul req Cp_phi rpow.
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -23,7 +23,7 @@ Require Import NArith.
Require Import QArith.
Extract Inductive prod => "( * )" [ "(,)" ].
-Extract Inductive List.list => list [ "[]" "(::)" ].
+Extract Inductive list => list [ "[]" "(::)" ].
Extract Inductive bool => bool [ true false ].
Extract Inductive sumbool => bool [ true false ].
Extract Inductive option => option [ Some None ].
@@ -38,10 +38,23 @@ Extract Inductive sumor => option [ Some None ].
Let's rather use the ocaml && *)
Extract Inlined Constant andb => "(&&)".
+Require Import Reals.
+
+Extract Constant R => "int".
+Extract Constant R0 => "0".
+Extract Constant R1 => "1".
+Extract Constant Rplus => "( + )".
+Extract Constant Rmult => "( * )".
+Extract Constant Ropp => "fun x -> - x".
+Extract Constant Rinv => "fun x -> 1 / x".
+
Extraction "micromega.ml"
List.map simpl_cone (*map_cone indexes*)
denorm Qpower
- n_of_Z Nnat.N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
+ n_of_Z N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
+
+
+
(* Local Variables: *)
(* coding: utf-8 *)
diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v
index e4f91fb6..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v
index fde0f29a..7f6cf79b 100644
--- a/plugins/micromega/Psatz.v
+++ b/plugins/micromega/Psatz.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -18,7 +18,7 @@ Require Import RMicromega.
Require Import QArith.
Require Export Ring_normalize.
Require Import ZArith.
-Require Import Raxioms.
+Require Import Rdefinitions.
Require Export RingMicromega.
Require Import VarMap.
Require Tauto.
@@ -66,6 +66,7 @@ Ltac psatzl dom :=
change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
| R =>
+ unfold Rdiv in * ;
psatzl_R ;
(* If csdp is not installed, the previous step might not produce any
progress: the rest of the tactical will then fail. Hence the 'try'. *)
@@ -75,12 +76,25 @@ Ltac psatzl dom :=
| _ => fail "Unsupported domain"
end in tac.
+
+Ltac lra :=
+ first [ psatzl R | psatzl Q ].
+
Ltac lia :=
- xlia ;
+ zify ; unfold 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -173,8 +173,15 @@ Require Import Tauto.
Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
+Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool.
+
+Definition qdeduce := nformula_plus_nformula 0 Qplus Qeq_bool.
+
+
+
Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool :=
@tauto_checker (Formula Q) (NFormula Q)
+ qunsat qdeduce
Qnormalise
Qnegate QWitness QWeakChecker f w.
@@ -186,6 +193,11 @@ Proof.
unfold QTautoChecker.
apply (tauto_checker_sound Qeval_formula Qeval_nformula).
apply Qeval_nformula_dec.
+ intros until env.
+ unfold eval_nformula. unfold RingMicromega.eval_nformula.
+ destruct t.
+ apply (check_inconsistent_sound Qsor QSORaddon) ; auto.
+ unfold qdeduce. apply (nformula_plus_nformula_correct Qsor QSORaddon).
intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_normalise_correct Qsor QSORaddon).
intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor QSORaddon).
intros t w0.
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
index 305d553c..2be99da1 100644
--- a/plugins/micromega/RMicromega.v
+++ b/plugins/micromega/RMicromega.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -16,6 +16,10 @@ Require Import OrderedRing.
Require Import RingMicromega.
Require Import Refl.
Require Import Raxioms RIneq Rpow_def DiscrR.
+Require Import QArith.
+Require Import Qfield.
+
+
Require Setoid.
(*Declare ML Module "micromega_plugin".*)
@@ -60,32 +64,405 @@ Proof.
apply (Rmult_lt_compat_r) ; auto.
Qed.
-Require ZMicromega.
-(* R with coeffs in Z *)
+Definition IQR := fun x : Q => (IZR (Qnum x) * / IZR (' Qden x))%R.
+
+
+Lemma Rinv_elim : forall x y z,
+ y <> 0 -> (z * y = x <-> x * / y = z).
+Proof.
+ intros.
+ split ; intros.
+ subst.
+ rewrite Rmult_assoc.
+ rewrite Rinv_r; auto.
+ ring.
+ subst.
+ rewrite Rmult_assoc.
+ rewrite (Rmult_comm (/ y)).
+ rewrite Rinv_r ; auto.
+ ring.
+Qed.
+
+Ltac INR_nat_of_P :=
+ match goal with
+ | H : context[INR (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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
index b10cf784..4af65086 100644
--- a/plugins/micromega/RingMicromega.v
+++ b/plugins/micromega/RingMicromega.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -308,7 +308,7 @@ Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B :
| Some x => f x
end.
-Implicit Arguments map_option [A B].
+Arguments map_option [A B] f o.
Definition map_option2 (A B C : Type) (f : A -> B -> option C)
(o: option A) (o': option B) : option C :=
@@ -318,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,7 +8,7 @@
(* *)
(* Micromega: A reflexive tactic using the Positivstellensatz *)
(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* Frédéric Besson (Irisa/Inria) 2006-20011 *)
(* *)
(************************************************************************)
@@ -41,6 +41,37 @@ Set Implicit Arguments.
| I f1 f2 => (eval_f ev f1) -> (eval_f ev f2)
end.
+ Lemma eval_f_morph : forall A (ev ev' : A -> Prop) (f : BFormula A),
+ (forall a, ev a <-> ev' a) -> (eval_f ev f <-> eval_f ev' f).
+ Proof.
+ induction f ; simpl ; try tauto.
+ intros.
+ assert (H' := H a).
+ auto.
+ Qed.
+
+
+
+ Fixpoint map_bformula (T U : Type) (fct : T -> U) (f : BFormula T) : BFormula U :=
+ match f with
+ | TT => TT _
+ | FF => FF _
+ | X p => X _ p
+ | A a => A (fct a)
+ | Cj f1 f2 => Cj (map_bformula fct f1) (map_bformula fct f2)
+ | D f1 f2 => D (map_bformula fct f1) (map_bformula fct f2)
+ | N f => N (map_bformula fct f)
+ | I f1 f2 => I (map_bformula fct f1) (map_bformula fct f2)
+ end.
+
+ Lemma eval_f_map : forall T U (fct: T-> U) env f ,
+ eval_f env (map_bformula fct f) = eval_f (fun x => env (fct x)) f.
+ Proof.
+ induction f ; simpl ; try (rewrite IHf1 ; rewrite IHf2) ; auto.
+ rewrite <- IHf. auto.
+ Qed.
+
+
Lemma map_simpl : forall A B f l, @map A B f l = match l with
| nil => nil
@@ -52,6 +83,7 @@ Set Implicit Arguments.
+
Section S.
Variable Env : Type.
@@ -64,6 +96,15 @@ Set Implicit Arguments.
Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).
+ Variable unsat : Term' -> bool.
+
+ Variable unsat_prop : forall t, unsat t = true ->
+ forall env, eval' env t -> False.
+
+ Variable deduce : Term' -> Term' -> option Term'.
+
+ Variable deduce_prop : forall env t t' u,
+ eval' env t -> eval' env t' -> deduce t t' = Some u -> eval' env u.
Definition clause := list Term'.
Definition cnf := list clause.
@@ -76,8 +117,48 @@ Set Implicit Arguments.
Definition ff : cnf := cons (@nil Term') nil.
+ Fixpoint add_term (t: Term') (cl : clause) : option clause :=
+ match cl with
+ | nil =>
+ match deduce t t with
+ | None => Some (t ::nil)
+ | Some u => if unsat u then None else Some (t::nil)
+ end
+ | t'::cl =>
+ match deduce t t' with
+ | None =>
+ match add_term t cl with
+ | None => None
+ | Some cl' => Some (t' :: cl')
+ end
+ | Some u =>
+ if unsat u then None else
+ match add_term t cl with
+ | None => None
+ | Some cl' => Some (t' :: cl')
+ end
+ end
+ end.
+
+ Fixpoint or_clause (cl1 cl2 : clause) : option clause :=
+ match cl1 with
+ | nil => Some cl2
+ | t::cl => match add_term t cl2 with
+ | None => None
+ | Some cl' => or_clause cl cl'
+ end
+ end.
+
+(* Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
+ List.map (fun x => (t++x)) f. *)
+
Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
- List.map (fun x => (t++x)) f.
+ List.fold_right (fun e acc =>
+ match or_clause t e with
+ | None => acc
+ | Some cl => cl :: acc
+ end) nil f.
+
Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
match f with
@@ -102,46 +183,154 @@ Set Implicit Arguments.
| I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2)
end.
- Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj (fun cl => ~ make_conj env cl) f.
+ Definition eval_clause (env : Env) (cl : clause) := ~ make_conj (eval' env) cl.
+
+ Definition eval_cnf (env : Env) (f:cnf) := make_conj (eval_clause env) f.
+
+
+ Lemma eval_cnf_app : forall env x y, eval_cnf env (x++y) -> eval_cnf env x /\ eval_cnf env y.
+ Proof.
+ unfold eval_cnf.
+ intros.
+ rewrite make_conj_app in H ; auto.
+ Qed.
+
+
+ Definition eval_opt_clause (env : Env) (cl: option clause) :=
+ match cl with
+ | None => True
+ | Some cl => eval_clause env cl
+ end.
- Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y.
+ Lemma add_term_correct : forall env t cl , eval_opt_clause env (add_term t cl) -> eval_clause env (t::cl).
+ Proof.
+ induction cl.
+ (* BC *)
+ simpl.
+ case_eq (deduce t t) ; auto.
+ intros until 0.
+ case_eq (unsat t0) ; auto.
+ unfold eval_clause.
+ rewrite make_conj_cons.
+ intros. intro.
+ apply unsat_prop with (1:= H) (env := env).
+ apply deduce_prop with (3:= H0) ; tauto.
+ (* IC *)
+ simpl.
+ case_eq (deduce t a).
+ intro u.
+ case_eq (unsat u).
+ simpl. intros.
+ unfold eval_clause.
+ intro.
+ apply unsat_prop with (1:= H) (env:= env).
+ repeat rewrite make_conj_cons in H2.
+ apply deduce_prop with (3:= H0); tauto.
+ intro.
+ case_eq (add_term t cl) ; intros.
+ simpl in H2.
+ rewrite H0 in IHcl.
+ simpl in IHcl.
+ unfold eval_clause in *.
+ intros.
+ repeat rewrite make_conj_cons in *.
+ tauto.
+ rewrite H0 in IHcl ; simpl in *.
+ unfold eval_clause in *.
+ intros.
+ repeat rewrite make_conj_cons in *.
+ tauto.
+ case_eq (add_term t cl) ; intros.
+ simpl in H1.
+ unfold eval_clause in *.
+ repeat rewrite make_conj_cons in *.
+ rewrite H in IHcl.
+ simpl in IHcl.
+ tauto.
+ simpl in *.
+ rewrite H in IHcl.
+ simpl in IHcl.
+ unfold eval_clause in *.
+ repeat rewrite make_conj_cons in *.
+ tauto.
+ Qed.
+
+
+ Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') -> eval_clause env cl \/ eval_clause env cl'.
Proof.
- unfold eval_cnf.
+ induction cl.
+ simpl. tauto.
+ intros until 0.
+ simpl.
+ assert (HH := add_term_correct env a cl').
+ case_eq (add_term a cl').
+ simpl in *.
+ intros.
+ apply IHcl in H0.
+ rewrite H in HH.
+ simpl in HH.
+ unfold eval_clause in *.
+ destruct H0.
+ repeat rewrite make_conj_cons in *.
+ tauto.
+ apply HH in H0.
+ apply not_make_conj_cons in H0 ; auto.
+ repeat rewrite make_conj_cons in *.
+ tauto.
+ simpl.
intros.
- rewrite make_conj_app in H ; auto.
+ rewrite H in HH.
+ simpl in HH.
+ unfold eval_clause in *.
+ assert (HH' := HH Coq.Init.Logic.I).
+ apply not_make_conj_cons in HH'; auto.
+ repeat rewrite make_conj_cons in *.
+ tauto.
Qed.
+
-
- Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj (eval' env) t) \/ (eval_cnf (eval' env) f).
+ Lemma or_clause_cnf_correct : forall env t f, eval_cnf env (or_clause_cnf t f) -> (eval_clause env t) \/ (eval_cnf env f).
Proof.
unfold eval_cnf.
unfold or_clause_cnf.
+ intros until t.
+ set (F := (fun (e : clause) (acc : list clause) =>
+ match or_clause t e with
+ | Some cl => cl :: acc
+ | None => acc
+ end)).
induction f.
- simpl.
- intros ; right;auto.
+ auto.
(**)
- rewrite map_simpl.
+ simpl.
intros.
- rewrite make_conj_cons in H.
- destruct H as [HH1 HH2].
- generalize (IHf HH2) ; clear IHf ; intro.
- destruct H.
- left ; auto.
- rewrite make_conj_cons.
- destruct (not_make_conj_app _ _ _ (no_middle_eval' env) HH1).
- tauto.
+ destruct f.
+ simpl in H.
+ simpl in IHf.
+ unfold F in H.
+ revert H.
+ intros.
+ apply or_clause_correct.
+ destruct (or_clause t a) ; simpl in * ; auto.
+ unfold F in H at 1.
+ revert H.
+ assert (HH := or_clause_correct t a env).
+ destruct (or_clause t a); simpl in HH ;
+ rewrite make_conj_cons in * ; intuition.
+ rewrite make_conj_cons in *.
tauto.
Qed.
- Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf (eval' env) f -> eval_cnf (eval' env) (a::f).
+
+ Lemma eval_cnf_cons : forall env a f, (~ make_conj (eval' env) a) -> eval_cnf env f -> eval_cnf env (a::f).
Proof.
intros.
unfold eval_cnf in *.
rewrite make_conj_cons ; eauto.
Qed.
- Lemma or_cnf_correct : forall env f f', eval_cnf (eval' env) (or_cnf f f') -> (eval_cnf (eval' env) f) \/ (eval_cnf (eval' env) f').
+ Lemma or_cnf_correct : forall env f f', eval_cnf env (or_cnf f f') -> (eval_cnf env f) \/ (eval_cnf env f').
Proof.
induction f.
unfold eval_cnf.
@@ -153,19 +342,19 @@ Set Implicit Arguments.
destruct (eval_cnf_app _ _ _ H).
clear H.
destruct (IHf _ H0).
- destruct (or_clause_correct _ _ _ H1).
+ destruct (or_clause_cnf_correct _ _ _ H1).
left.
apply eval_cnf_cons ; auto.
right ; auto.
right ; auto.
Qed.
- Variable normalise_correct : forall env t, eval_cnf (eval' env) (normalise t) -> eval env t.
+ Variable normalise_correct : forall env t, eval_cnf env (normalise t) -> eval env t.
- Variable negate_correct : forall env t, eval_cnf (eval' env) (negate t) -> ~ eval env t.
+ Variable negate_correct : forall env t, eval_cnf env (negate t) -> ~ eval env t.
- Lemma xcnf_correct : forall f pol env, eval_cnf (eval' env) (xcnf pol f) -> eval_f (eval env) (if pol then f else N f).
+ Lemma xcnf_correct : forall f pol env, eval_cnf env (xcnf pol f) -> eval_f (eval env) (if pol then f else N f).
Proof.
induction f.
(* TT *)
@@ -175,15 +364,19 @@ Set Implicit Arguments.
(* FF *)
unfold eval_cnf.
destruct pol; simpl ; auto.
+ unfold eval_clause ; simpl.
+ tauto.
(* P *)
simpl.
destruct pol ; intros ;simpl.
unfold eval_cnf in H.
(* Here I have to drop the proposition *)
simpl in H.
+ unfold eval_clause in H ; simpl in H.
tauto.
(* Here, I could store P in the clause *)
unfold eval_cnf in H;simpl in H.
+ unfold eval_clause in H ; simpl in H.
tauto.
(* A *)
simpl.
@@ -282,7 +475,7 @@ Set Implicit Arguments.
end
end.
- Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf (eval' env) t.
+ Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf env t.
Proof.
unfold eval_cnf.
induction t.
@@ -319,7 +512,6 @@ Set Implicit Arguments.
-
End S.
(* Local Variables: *)
diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v
index 7d25524a..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -18,11 +18,12 @@ Require Import Coq.Arith.Max.
Require Import List.
Set Implicit Arguments.
-(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v)
- -- this is harmless and spares a lot of Empty.
- This means smaller proof-terms.
- BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up.
-*)
+(*
+ * This adds a Leaf constructor to the varmap data structure (plugins/quote/Quote.v)
+ * --- it is harmless and spares a lot of Empty.
+ * It also means smaller proof-terms.
+ * As a side note, by dropping the polymorphism, one gets small, yet noticeable, speed-up.
+ *)
Section MakeVarMap.
Variable A : Type.
@@ -33,7 +34,7 @@ Section MakeVarMap.
| Leaf : A -> t
| Node : t -> A -> t -> t .
- Fixpoint find (vm : t ) (p:positive) {struct vm} : A :=
+ Fixpoint find (vm : t) (p:positive) {struct vm} : A :=
match vm with
| Empty => default
| Leaf i => i
@@ -44,216 +45,6 @@ Section MakeVarMap.
end
end.
- (* an off_map (a map with offset) offers the same functionalites as /plugins/setoid_ring/BinList.v - it is used in EnvRing.v *)
-(*
- Definition off_map := (option positive *t )%type.
-
-
-
- Definition jump (j:positive) (l:off_map ) :=
- let (o,m) := l in
- match o with
- | None => (Some j,m)
- | Some j0 => (Some (j+j0)%positive,m)
- end.
-
- Definition nth (n:positive) (l: off_map ) :=
- let (o,m) := l in
- let idx := match o with
- | None => n
- | Some i => i + n
- end%positive in
- find idx m.
-
-
- Definition hd (l:off_map) := nth xH l.
-
-
- Definition tail (l:off_map ) := jump xH l.
-
-
- Lemma psucc : forall p, (match p with
- | xI y' => xO (Psucc y')
- | xO y' => xI y'
- | 1%positive => 2%positive
- end) = (p+1)%positive.
- Proof.
- destruct p.
- auto with zarith.
- rewrite xI_succ_xO.
- auto with zarith.
- reflexivity.
- Qed.
-
- Lemma jump_Pplus : forall i j l,
- (jump (i + j) l) = (jump i (jump j l)).
- Proof.
- unfold jump.
- destruct l.
- destruct o.
- rewrite Pplus_assoc.
- reflexivity.
- reflexivity.
- Qed.
-
- Lemma jump_simpl : forall p l,
- jump p l =
- match p with
- | xH => tail l
- | xO p => jump p (jump p l)
- | xI p => jump p (jump p (tail l))
- end.
- Proof.
- destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus.
- (* xI p = p + p + 1 *)
- rewrite xI_succ_xO.
- rewrite Pplus_diag.
- rewrite <- Pplus_one_succ_r.
- reflexivity.
- (* xO p = p + p *)
- rewrite Pplus_diag.
- reflexivity.
- reflexivity.
- Qed.
-
- Ltac jump_s :=
- repeat
- match goal with
- | |- context [jump xH ?e] => rewrite (jump_simpl xH)
- | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
- | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
- end.
-
- Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
- Proof.
- unfold tail.
- intros.
- repeat rewrite <- jump_Pplus.
- rewrite Pplus_comm.
- reflexivity.
- Qed.
-
- Lemma jump_Psucc : forall j l,
- (jump (Psucc j) l) = (jump 1 (jump j l)).
- Proof.
- intros.
- rewrite <- jump_Pplus.
- rewrite Pplus_one_succ_r.
- rewrite Pplus_comm.
- reflexivity.
- Qed.
-
- Lemma jump_Pdouble_minus_one : forall i l,
- (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
- Proof.
- unfold tail.
- intros.
- repeat rewrite <- jump_Pplus.
- rewrite <- Pplus_one_succ_r.
- rewrite Psucc_o_double_minus_one_eq_xO.
- rewrite Pplus_diag.
- reflexivity.
- Qed.
-
- Lemma jump_x0_tail : forall p l, jump (xO p) (tail l) = jump (xI p) l.
- Proof.
- intros.
- jump_s.
- repeat rewrite <- jump_Pplus.
- reflexivity.
- Qed.
-
-
- Lemma nth_spec : forall p l,
- nth p l =
- match p with
- | xH => hd l
- | xO p => nth p (jump p l)
- | xI p => nth p (jump p (tail l))
- end.
- Proof.
- unfold nth.
- destruct l.
- destruct o.
- simpl.
- rewrite psucc.
- destruct p.
- replace (p0 + xI p)%positive with ((p + (p0 + 1) + p))%positive.
- reflexivity.
- rewrite xI_succ_xO.
- rewrite Pplus_one_succ_r.
- rewrite <- Pplus_diag.
- rewrite Pplus_comm.
- symmetry.
- rewrite (Pplus_comm p0).
- rewrite <- Pplus_assoc.
- rewrite (Pplus_comm 1)%positive.
- rewrite <- Pplus_assoc.
- reflexivity.
- (**)
- replace ((p0 + xO p))%positive with (p + p0 + p)%positive.
- reflexivity.
- rewrite <- Pplus_diag.
- rewrite <- Pplus_assoc.
- rewrite Pplus_comm.
- rewrite Pplus_assoc.
- reflexivity.
- reflexivity.
- simpl.
- destruct p.
- rewrite xI_succ_xO.
- rewrite Pplus_one_succ_r.
- rewrite <- Pplus_diag.
- symmetry.
- rewrite Pplus_comm.
- rewrite Pplus_assoc.
- reflexivity.
- rewrite Pplus_diag.
- reflexivity.
- reflexivity.
- Qed.
-
-
- Lemma nth_jump : forall p l, nth p (tail l) = hd (jump p l).
- Proof.
- destruct l.
- unfold tail.
- unfold hd.
- unfold jump.
- unfold nth.
- destruct o.
- symmetry.
- rewrite Pplus_comm.
- rewrite <- Pplus_assoc.
- rewrite (Pplus_comm p0).
- reflexivity.
- rewrite Pplus_comm.
- reflexivity.
- Qed.
-
- Lemma nth_Pdouble_minus_one :
- forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
- Proof.
- destruct l.
- unfold tail.
- unfold nth, jump.
- destruct o.
- rewrite ((Pplus_comm p)).
- rewrite <- (Pplus_assoc p0).
- rewrite Pplus_diag.
- rewrite <- Psucc_o_double_minus_one_eq_xO.
- rewrite Pplus_one_succ_r.
- rewrite (Pplus_comm (Pdouble_minus_one p)).
- rewrite Pplus_assoc.
- rewrite (Pplus_comm p0).
- reflexivity.
- rewrite <- Pplus_one_succ_l.
- rewrite Psucc_o_double_minus_one_eq_xO.
- rewrite Pplus_diag.
- reflexivity.
- Qed.
-
-*)
End MakeVarMap.
diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v
index cf2bca49..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -138,7 +138,7 @@ Qed.
Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y].
Proof.
-unfold Zlt; intros x y H;
+intros x y H.
do 2 rewrite (same_genZ sor.(SORsetoid) ring_ops_wd sor.(SORrt));
destruct x; destruct y; simpl in *; try discriminate.
apply phi_pos1_pos.
@@ -146,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,7 +8,7 @@
(* *)
(* Micromega: A reflexive tactic using the Positivstellensatz *)
(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* Frédéric Besson (Irisa/Inria) 2006-2011 *)
(* *)
(************************************************************************)
@@ -194,27 +194,27 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z) :=
| OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
end.
-Require Import Tauto.
+Require Import Tauto BinNums.
Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
List.map (fun x => x::nil) (xnormalise t).
-Lemma normalise_correct : forall env t, eval_cnf (eval_nformula env) (normalise t) <-> Zeval_formula env t.
+Lemma normalise_correct : forall env t, eval_cnf eval_nformula env (normalise t) <-> Zeval_formula env t.
Proof.
Opaque padd.
unfold normalise, xnormalise ; simpl; intros env t.
rewrite Zeval_formula_compat.
- unfold eval_cnf.
+ unfold eval_cnf, eval_clause.
destruct t as [lhs o rhs]; case_eq o; simpl;
repeat rewrite eval_pol_sub;
repeat rewrite eval_pol_add;
repeat rewrite <- eval_pol_norm ; simpl in *;
unfold eval_expr;
generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
- (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
+ (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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -15,153 +15,18 @@
(* We take as input a list of polynomials [p1...pn] and return an unfeasibility
certificate polynomial. *)
-(*open Micromega.Polynomial*)
+type var = int
+
+
+
open Big_int
open Num
-open Sos_lib
+open Polynomial
module Mc = Micromega
module Ml2C = Mutils.CamlToCoq
module C2Ml = Mutils.CoqToCaml
-let (<+>) = add_num
-let (<->) = minus_num
-let (<*>) = mult_num
-
-type var = Mc.positive
-
-module Monomial :
-sig
- type t
- val const : t
- val var : var -> t
- val find : var -> t -> int
- val mult : var -> t -> t
- val prod : t -> t -> t
- val compare : t -> t -> int
- val pp : out_channel -> t -> unit
- val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
-end
- =
-struct
- (* A monomial is represented by a multiset of variables *)
- module Map = Map.Make(struct type t = var let compare = Pervasives.compare end)
- open Map
-
- type t = int Map.t
-
- (* The monomial that corresponds to a constant *)
- let const = Map.empty
-
- (* The monomial 'x' *)
- let var x = Map.add x 1 Map.empty
-
- (* Get the degre of a variable in a monomial *)
- let find x m = try find x m with Not_found -> 0
-
- (* Multiply a monomial by a variable *)
- let mult x m = add x ( (find x m) + 1) m
-
- (* Product of monomials *)
- let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2
-
- (* Total ordering of monomials *)
- let compare m1 m2 = Map.compare Pervasives.compare m1 m2
-
- let pp o m = Map.iter (fun k v ->
- if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k)
- else Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m
-
- let fold = fold
-
-end
-
-
-module Poly :
- (* A polynomial is a map of monomials *)
- (*
- This is probably a naive implementation
- (expected to be fast enough - Coq is probably the bottleneck)
- *The new ring contribution is using a sparse Horner representation.
- *)
-sig
- type t
- val get : Monomial.t -> t -> num
- val variable : var -> t
- val add : Monomial.t -> num -> t -> t
- val constant : num -> t
- val mult : Monomial.t -> num -> t -> t
- val product : t -> t -> t
- val addition : t -> t -> t
- val uminus : t -> t
- val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a
- val pp : out_channel -> t -> unit
- val compare : t -> t -> int
- val is_null : t -> bool
-end =
-struct
- (*normalisation bug : 0*x ... *)
- module P = Map.Make(Monomial)
- open P
-
- type t = num P.t
-
- let pp o p = P.iter (fun k v ->
- if compare_num v (Int 0) <> 0
- then
- if Monomial.compare Monomial.const k = 0
- then Printf.fprintf o "%s " (string_of_num v)
- else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p
-
- (* Get the coefficient of monomial mn *)
- let get : Monomial.t -> t -> num =
- fun mn p -> try find mn p with Not_found -> (Int 0)
-
-
- (* The polynomial 1.x *)
- let variable : var -> t =
- fun x -> add (Monomial.var x) (Int 1) empty
-
- (*The constant polynomial *)
- let constant : num -> t =
- fun c -> add (Monomial.const) c empty
-
- (* The addition of a monomial *)
-
- let add : Monomial.t -> num -> t -> t =
- fun mn v p ->
- let vl = (get mn p) <+> v in
- add mn vl p
-
-
- (** Design choice: empty is not a polynomial
- I do not remember why ....
- **)
-
- (* The product by a monomial *)
- let mult : Monomial.t -> num -> t -> t =
- fun mn v p ->
- fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty
-
-
- let addition : t -> t -> t =
- fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2
-
-
- let product : t -> t -> t =
- fun p1 p2 ->
- fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty
-
-
- let uminus : t -> t =
- fun p -> map (fun v -> minus_num v) p
-
- let fold = P.fold
-
- let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p true
-
- let compare = compare compare_num
-end
open Mutils
type 'a number_spec = {
@@ -178,10 +43,10 @@ let z_spec = {
number_to_num = (fun x -> Big_int (C2Ml.z_big_int x));
zero = Mc.Z0;
unit = Mc.Zpos Mc.XH;
- mult = Mc.zmult;
+ mult = Mc.Z.mul;
eqb = Mc.zeq_bool
}
-
+
let q_spec = {
bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH});
@@ -195,56 +60,58 @@ let q_spec = {
let r_spec = z_spec
-
-
let dev_form n_spec p =
- let rec dev_form p =
+ let rec dev_form p =
match p with
| Mc.PEc z -> Poly.constant (n_spec.number_to_num z)
- | Mc.PEX v -> Poly.variable v
- | Mc.PEmul(p1,p2) ->
+ | Mc.PEX v -> Poly.variable (C2Ml.positive v)
+ | Mc.PEmul(p1,p2) ->
let p1 = dev_form p1 in
let p2 = dev_form p2 in
- Poly.product p1 p2
+ Poly.product p1 p2
| Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2)
| Mc.PEopp p -> Poly.uminus (dev_form p)
| Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2))
- | Mc.PEpow(p,n) ->
+ | Mc.PEpow(p,n) ->
let p = dev_form p in
let n = C2Ml.n n in
- let rec pow n =
- if n = 0
+ let rec pow n =
+ if n = 0
then Poly.constant (n_spec.number_to_num n_spec.unit)
else Poly.product p (pow (n-1)) in
pow n in
dev_form p
-let monomial_to_polynomial mn =
- Monomial.fold
- (fun v i acc ->
- let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
- if acc = Mc.PEc (Mc.Zpos Mc.XH)
- then mn
- else Mc.PEmul(mn,acc))
- mn
- (Mc.PEc (Mc.Zpos Mc.XH))
+let monomial_to_polynomial mn =
+ Monomial.fold
+ (fun v i acc ->
+ let v = Ml2C.positive v in
+ let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
+ if acc = Mc.PEc (Mc.Zpos Mc.XH)
+ then mn
+ else Mc.PEmul(mn,acc))
+ mn
+ (Mc.PEc (Mc.Zpos Mc.XH))
+
-let list_to_polynomial vars l =
+
+let list_to_polynomial vars l =
assert (List.for_all (fun x -> ceiling_num x =/ x) l);
let var x = monomial_to_polynomial (List.nth vars x) in
+
let rec xtopoly p i = function
| [] -> p
- | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l
+ | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l
else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
- let mn =
+ let mn =
if c = Mc.PEc (Mc.Zpos Mc.XH)
then var i
else Mc.PEmul (c,var i) in
let p' = if p = Mc.PEc Mc.Z0 then mn else
Mc.PEadd (mn, p) in
xtopoly p' (i+1) l in
-
+
xtopoly (Mc.PEc Mc.Z0) 0 l
let rec fixpoint f x =
@@ -252,61 +119,54 @@ let rec fixpoint f x =
if y' = x then y'
else fixpoint f y'
-
-
-
-
-
-
-
-let rec_simpl_cone n_spec e =
- let simpl_cone =
+let rec_simpl_cone n_spec e =
+ let simpl_cone =
Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in
let rec rec_simpl_cone = function
- | Mc.PsatzMulE(t1, t2) ->
+ | Mc.PsatzMulE(t1, t2) ->
simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
- | Mc.PsatzAdd(t1,t2) ->
+ | Mc.PsatzAdd(t1,t2) ->
simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2))
| x -> simpl_cone x in
rec_simpl_cone e
-
-
+
+
let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c
-
-type cone_prod =
- Const of cone
- | Ideal of cone *cone
- | Mult of cone * cone
+
+type cone_prod =
+ Const of cone
+ | Ideal of cone *cone
+ | Mult of cone * cone
| Other of cone
and cone = Mc.zWitness
let factorise_linear_cone c =
-
- let rec cone_list c l =
+
+ let rec cone_list c l =
match c with
| Mc.PsatzAdd (x,r) -> cone_list r (x::l)
| _ -> c :: l in
-
+
let factorise c1 c2 =
match c1 , c2 with
- | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') ->
+ | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') ->
if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
- | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') ->
+ | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') ->
if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
| _ -> None in
-
+
let rec rebuild_cone l pending =
match l with
| [] -> (match pending with
| None -> Mc.PsatzZ
| Some p -> p
)
- | e::l ->
+ | e::l ->
(match pending with
- | None -> rebuild_cone l (Some e)
+ | None -> rebuild_cone l (Some e)
| Some p -> (match factorise p e with
| None -> Mc.PsatzAdd(p, rebuild_cone l (Some e))
| Some f -> rebuild_cone l (Some f) )
@@ -316,15 +176,15 @@ let factorise_linear_cone c =
-(* The binding with Fourier might be a bit obsolete
+(* The binding with Fourier might be a bit obsolete
-- how does it handle equalities ? *)
(* Certificates are elements of the cone such that P = 0 *)
(* To begin with, we search for certificates of the form:
- a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0
+ a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0
where pi >= 0 qi > 0
- ai >= 0
+ ai >= 0
bi >= 0
Sum bi + c >= 1
This is a linear problem: each monomial is considered as a variable.
@@ -334,216 +194,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 "<linear_prover"; flush stdout ;
+ let res = linear_prover sys in
+ Printf.printf ">"; flush stdout ;
+ res
+ else linear_prover
+
+
+
+
+(** A single constraint can be unsat for the following reasons:
+ - 0 >= c for c a negative constant
+ - 0 = c for c a non-zero constant
+ - e = c when the coeffs of e are all integers and c is rational
+*)
+
+type checksat =
+ | Tauto (* Tautology *)
+ | Unsat of prf_rule (* Unsatisfiable *)
+ | Cut of cstr_compat * prf_rule (* Cutting plane *)
+ | Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *)
+
+
+(** [check_sat]
+ - detects constraints that are not satisfiable;
+ - normalises constraints and generate cuts.
+*)
+
+let check_sat (cstr,prf) =
+ let {coeffs=coeffs ; op=op ; cst=cst} = cstr in
+ match coeffs with
+ | [] ->
+ if eval_op op (Int 0) cst then Tauto else Unsat prf
+ | _ ->
+ let gcdi = (gcd_list (List.map snd coeffs)) in
+ let gcd = Big_int gcdi in
+ if eq_num gcd (Int 1)
+ then Normalise(cstr,prf)
+ else
+ if sign_num (mod_num cst gcd) = 0
+ then (* We can really normalise *)
+ begin
+ assert (sign_num gcd >=1 ) ;
+ let cstr = {
+ coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
+ op = op ; cst = cst // gcd
+ } in
+ Normalise(cstr,Gcd(gcdi,prf))
+ (* Normalise(cstr,CutPrf prf)*)
+ end
+ else
+ match op with
+ | Eq -> Unsat (CutPrf prf)
+ | Ge ->
+ let cstr = {
+ coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
+ op = op ; cst = ceiling_num (cst // gcd)
+ } in Cut(cstr,CutPrf prf)
+
+
+(** Proof generating pivoting over variable v *)
+let pivot v (c1,p1) (c2,p2) =
+ let {coeffs = v1 ; op = op1 ; cst = n1} = c1
+ and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
+
+
+
+ (* Could factorise gcd... *)
+ let xpivot cv1 cv2 =
+ (
+ {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ;
+ op = Proof.add_op op1 op2 ;
+ cst = n1 */ cv1 +/ n2 */ cv2 },
+
+ AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in
+
+ match Vect.get v v1 , Vect.get v v2 with
+ | None , _ | _ , None -> None
+ | Some a , Some b ->
+ if (sign_num a) * (sign_num b) = -1
+ then
+ let cv1 = abs_num b
+ and cv2 = abs_num a in
+ Some (xpivot cv1 cv2)
+ else
+ if op1 = Eq
+ then
+ let cv1 = minus_num (b */ (Int (sign_num a)))
+ and cv2 = abs_num a in
+ Some (xpivot cv1 cv2)
+ else if op2 = Eq
+ then
+ let cv1 = abs_num b
+ and cv2 = minus_num (a */ (Int (sign_num b))) in
+ Some (xpivot cv1 cv2)
+ else None (* op2 could be Eq ... this might happen *)
+
+exception FoundProof of prf_rule
+
+let rec simpl_sys sys =
+ List.fold_left (fun acc (c,p) ->
+ match check_sat (c,p) with
+ | Tauto -> acc
+ | Unsat prf -> raise (FoundProof prf)
+ | Cut(c,p) -> (c,p)::acc
+ | Normalise (c,p) -> (c,p)::acc) [] sys
+
+
+(** [ext_gcd a b] is the extended Euclid algorithm.
+ [ext_gcd a b = (x,y,g)] iff [ax+by=g]
+ Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
+*)
+let rec ext_gcd a b =
+ if sign_big_int b = 0
+ then (unit_big_int,zero_big_int)
+ else
+ let (q,r) = quomod_big_int a b in
+ let (s,t) = ext_gcd b r in
+ (t, sub_big_int s (mult_big_int q t))
+
+
+let pp_ext_gcd a b =
+ let a' = big_int_of_int a in
+ let b' = big_int_of_int b in
+
+ let (x,y) = ext_gcd a' b' in
+ Printf.fprintf stdout "%s * %s + %s * %s = %s\n"
+ (string_of_big_int x) (string_of_big_int a')
+ (string_of_big_int y) (string_of_big_int b')
+ (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b')))
+
+exception Result of (int * (proof * cstr_compat))
+
+let split_equations psys =
+ List.partition (fun (c,p) -> c.op = Eq)
+
+
+let extract_coprime (c1,p1) (c2,p2) =
+ let rec exist2 vect1 vect2 =
+ match vect1 , vect2 with
+ | _ , [] | [], _ -> None
+ | (v1,n1)::vect1' , (v2, n2) :: vect2' ->
+ if v1 = v2
+ then
+ if compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int = 0
+ then Some (v1,n1,n2)
+ else
+ exist2 vect1' vect2'
+ else
+ if v1 < v2
+ then exist2 vect1' vect2
+ else exist2 vect1 vect2' in
+
+ if c1.op = Eq && c2.op = Eq
+ then exist2 c1.coeffs c2.coeffs
+ else None
+
+let extract2 pred l =
+ let rec xextract2 rl l =
+ match l with
+ | [] -> (None,rl) (* Did not find *)
+ | e::l ->
+ match extract (pred e) l with
+ | None,_ -> xextract2 (e::rl) l
+ | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in
+
+ xextract2 [] l
+
+
+let extract_coprime_equation psys =
+ extract2 extract_coprime psys
+
+
+let apply_and_normalise f psys =
+ List.fold_left (fun acc pc' ->
+ match f pc' with
+ | None -> pc'::acc
+ | Some pc' ->
+ match check_sat pc' with
+ | Tauto -> acc
+ | Unsat prf -> raise (FoundProof prf)
+ | Cut(c,p) -> (c,p)::acc
+ | Normalise (c,p) -> (c,p)::acc
+ ) [] psys
+
+
+
+
+let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys
+
+
+let reduce_coprime psys =
+ let oeq,sys = extract_coprime_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some((v,n1,n2),(c1,p1),(c2,p2) ) ->
+ let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in
+ let l1' = Big_int l1 and l2' = Big_int l2 in
+ let cstr =
+ {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs);
+ op = Eq ;
+ cst = (l1' */ c1.cst) +/ (l2' */ c2.cst)
+ } in
+ let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in
+
+ Some (pivot_sys v (cstr,prf) ((c1,p1)::sys))
+
+(** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *)
+let reduce_unary psys =
+ let is_unary_equation (cstr,prf) =
+ if cstr.op = Eq
+ then
+ try
+ Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
+ with Not_found -> None
+ else None in
+
+ let (oeq,sys) = extract is_unary_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) ->
+ Some(pivot_sys v pc sys)
+
+let reduce_non_lin_unary psys =
+
+ let is_unary_equation (cstr,prf) =
+ if cstr.op = Eq
+ then
+ try
+ let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in
+ let x' = LinPoly.MonT.retrieve x in
+ if List.for_all (fun (y,_) -> y = x || snd (Monomial.div (LinPoly.MonT.retrieve y) x') = 0) cstr.coeffs
+ then Some x
+ else None
+ with Not_found -> None
+ else None in
+
+
+ let (oeq,sys) = extract is_unary_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) ->
+ Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys)
+
+let reduce_var_change psys =
+
+ let rec rel_prime vect =
+ match vect with
+ | [] -> None
+ | (x,v)::vect ->
+ let v = numerator v in
+ try
+ let (x',v') = List.find (fun (_,v') ->
+ let v' = numerator v' in
+ eq_big_int (gcd_big_int v v') unit_big_int) vect in
+ Some ((x,v),(x',numerator v'))
+ with Not_found -> rel_prime vect in
+
+ let rel_prime (cstr,prf) = if cstr.op = Eq then rel_prime cstr.coeffs else None in
+
+ let (oeq,sys) = extract rel_prime psys in
+
+ match oeq with
+ | None -> None
+ | Some(((x,v),(x',v')),(c,p)) ->
+ let (l1,l2) = ext_gcd v v' in
+ let l1,l2 = Big_int l1 , Big_int l2 in
+
+ let get v vect =
+ match Vect.get v vect with
+ | None -> Int 0
+ | Some n -> n in
+
+ let pivot_eq (c',p') =
+ let {coeffs = coeffs ; op = op ; cst = cst} = c' in
+ let vx = get x coeffs in
+ let vx' = get x' coeffs in
+ let m = minus_num (vx */ l1 +/ vx' */ l2) in
+ Some ({coeffs =
+ Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} ,
+ AddPrf(MulC(([], m),p),p')) in
+
+ Some (apply_and_normalise pivot_eq sys)
+
+
+
+
+ let reduce_pivot psys =
+ let is_equation (cstr,prf) =
+ if cstr.op = Eq
+ then
+ try
+ Some (fst (List.hd cstr.coeffs))
+ with Not_found -> None
+ else None in
+ let (oeq,sys) = extract is_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) ->
+ if debug then
+ Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst);
+ Some(pivot_sys v pc sys)
+
+
+
+
+
+ let iterate_until_stable f x =
+ let rec iter x =
+ match f x with
+ | None -> x
+ | Some x' -> iter x' in
+ iter x
+
+ let rec app_funs l x =
+ match l with
+ | [] -> None
+ | f::fl ->
+ match f x with
+ | None -> app_funs fl x
+ | Some x' -> Some x'
+
+ let reduction_equations psys =
+ iterate_until_stable (app_funs
+ [reduce_unary ; reduce_coprime ;
+ reduce_var_change (*; reduce_pivot*)]) psys
+
+ let reduction_non_lin_equations psys =
+ iterate_until_stable (app_funs
+ [reduce_non_lin_unary (*; reduce_coprime ;
+ reduce_var_change ; reduce_pivot *)]) psys
+
+
+
+
+ (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *)
+ let get_bound sys =
+ let is_small (v,i) =
+ match Itv.range i with
+ | None -> false
+ | Some i -> i <=/ (Int 1) in
+
+ let select_best (x1,i1) (x2,i2) =
+ if Itv.smaller_itv i1 i2
+ then (x1,i1) else (x2,i2) in
+
+ (* For lia, there are no equations => these precautions are not needed *)
+ (* For nlia, there are equations => do not enumerate over equations! *)
+ let all_planes sys =
+ let (eq,ineq) = List.partition (fun c -> c.op = Eq) sys in
+ match eq with
+ | [] -> List.rev_map (fun c -> c.coeffs) ineq
+ | _ ->
+ List.fold_left (fun acc c ->
+ if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq
+ then acc else c.coeffs ::acc) [] ineq in
+
+ let smallest_interval =
+ List.fold_left
+ (fun acc vect ->
+ if is_small acc
+ then acc
+ else
+ match Fourier.optimise vect sys with
+ | None -> acc
+ | Some i ->
+ if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ;
+ select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in
+ let smallest_interval =
+ match smallest_interval
+ with
+ | (x,(Some i, Some j)) -> Some(i,x,j)
+ | x -> None (* This should not be possible *)
+ in
+ match smallest_interval with
+ | Some (lb,e,ub) ->
+ let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in
+ let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in
+ (match
+ (* x <= ub -> x > ub *)
+ xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys),
+ (* lb <= x -> lb > x *)
+ xlinear_prover
+ ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys)
+ with
+ | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub)
+ | _ -> failwith "Interval without proof"
+ )
+ | None -> None
+
+
+ let check_sys sys =
+ List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys
+
+
+ let xlia reduction_equations sys =
+
+ let rec enum_proof (id:int) (sys:prf_sys) : proof option =
+ if debug then (Printf.printf "enum_proof\n" ; flush stdout) ;
+ assert (check_sys sys) ;
+
+ let nsys,prf = List.split sys in
+ match get_bound nsys with
+ | None -> None (* Is the systeme really unbounded ? *)
+ | Some(prf1,(lb,e,ub),prf2) ->
+ if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ;
+ (match start_enum id e (ceiling_num lb) (floor_num ub) sys
+ with
+ | Some prfl ->
+ Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl))
+ | None -> None
+ )
+
+ and start_enum id e clb cub sys =
+ if clb >/ cub
+ then Some []
+ else
+ let eq = {coeffs = e ; op = Eq ; cst = clb} in
+ match aux_lia (id+1) ((eq, Def id) :: sys) with
+ | None -> None
+ | Some prf ->
+ match start_enum id e (clb +/ (Int 1)) cub sys with
+ | None -> None
+ | Some l -> Some (prf::l)
+
+ and aux_lia (id:int) (sys:prf_sys) : proof option =
+ assert (check_sys sys) ;
+ if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ;
+ try
+ let sys = reduction_equations sys in
+ if debug then
+ Printf.printf "after reduction: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ;
+ match linear_prover sys with
+ | Some prf -> Some (Step(id,prf,Done))
+ | None -> enum_proof id sys
+ with FoundProof prf ->
+ (* [reduction_equations] can find a proof *)
+ Some(Step(id,prf,Done)) in
+
+ (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*)
+ let id = List.length sys in
+ let orpf =
+ try
+ let sys = simpl_sys sys in
+ aux_lia id sys
+ with FoundProof pr -> Some(Step(id,pr,Done)) in
+ match orpf with
+ | None -> None
+ | Some prf ->
+ (*Printf.printf "direct proof %a\n" output_proof prf ; *)
+ let env = mapi (fun _ i -> i) sys in
+ let prf = compile_proof env prf in
+ (*try
+ if Mc.zChecker sys' prf then Some prf else
+ raise Certificate.BadCertificate
+ with Failure s -> (Printf.printf "%s" s ; Some prf)
+ *) Some prf
+
+
+ let cstr_compat_of_poly (p,o) =
+ let (v,c) = LinPoly.linpol_of_pol p in
+ {coeffs = v ; op = o ; cst = minus_num c }
+
+
+ let lia sys =
+ LinPoly.MonT.clear ();
+ let sys = List.map (develop_constraint z_spec) sys in
+ let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in
+ let sys = mapi (fun c i -> (c,Hyp i)) sys in
+ xlia reduction_equations sys
+
+
+ let nlia sys =
+ LinPoly.MonT.clear ();
+ let sys = List.map (develop_constraint z_spec) sys in
+ let sys = mapi (fun c i -> (c,Hyp i)) sys in
+
+ let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
+
+ let module MonMap = Map.Make(Monomial) in
+
+ let collect_square =
+ List.fold_left (fun acc ((p,_),_) -> Poly.fold
+ (fun m _ acc ->
+ match Monomial.sqrt m with
+ | None -> acc
+ | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in
+ let sys = MonMap.fold (fun s m acc ->
+ let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in
+ let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in
+ ((m, Ge), (Square s))::acc) collect_square sys in
+
+(* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*)
+
+ let sys =
+ if is_linear then sys
+ else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') ->
+ ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in
+
+ let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in
+ assert (check_sys sys) ;
+ xlia (if is_linear then reduction_equations else reduction_non_lin_equations) sys
+
+
+
(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
index 4eb26afd..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -12,7 +12,7 @@
(* *)
(* - Modules ISet, M, Mc, Env, Cache, CacheZ *)
(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2009 *)
+(* Frédéric Besson (Irisa/Inria) 2006-20011 *)
(* *)
(************************************************************************)
@@ -55,7 +55,7 @@ type 'cst atom = 'cst Micromega.formula
* Micromega's encoding of formulas.
* By order of appearance: boolean constants, variables, atoms, conjunctions,
* disjunctions, negation, implication.
- *)
+*)
type 'cst formula =
| TT
@@ -86,6 +86,18 @@ let rec pp_formula o f =
| None -> "") pp_formula f2
| N(f) -> Printf.fprintf o "N(%a)" pp_formula f
+
+let rec map_atoms fct f =
+ match f with
+ | TT -> TT
+ | FF -> FF
+ | X x -> X x
+ | A (at,tg,cstr) -> A(fct at,tg,cstr)
+ | C (f1,f2) -> C(map_atoms fct f1, map_atoms fct f2)
+ | D (f1,f2) -> D(map_atoms fct f1, map_atoms fct f2)
+ | N f -> N(map_atoms fct f)
+ | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2)
+
(**
* Collect the identifiers of a (string of) implications. Implication labels
* are inherited from Coq/CoC's higher order dependent type constructor (Pi).
@@ -125,7 +137,9 @@ let ff : 'cst cnf = [ [] ]
* and the freeform formulas ('cst formula) that is retrieved from Coq.
*)
-type 'cst mc_cnf = ('cst Micromega.nFormula) list list
+module Mc = Micromega
+
+type 'cst mc_cnf = ('cst Mc.nFormula) list list
(**
* From a freeform formula, build a cnf.
@@ -134,7 +148,12 @@ type 'cst mc_cnf = ('cst Micromega.nFormula) list list
* and RingMicromega.v).
*)
-let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) =
+type 'a tagged_option = T of tag list | S of 'a
+
+let cnf
+ (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf)
+ (unsat : 'cst Mc.nFormula -> bool) (deduce : 'cst Mc.nFormula -> 'cst Mc.nFormula -> 'cst Mc.nFormula option) (f:'cst formula) =
+
let negate a t =
List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in
@@ -143,26 +162,79 @@ let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf)
let and_cnf x y = x @ y in
- let or_clause_cnf t f = List.map (fun x -> t@x) f in
+let rec add_term t0 = function
+ | [] ->
+ (match deduce (fst t0) (fst t0) with
+ | Some u -> if unsat u then T [snd t0] else S (t0::[])
+ | None -> S (t0::[]))
+ | t'::cl0 ->
+ (match deduce (fst t0) (fst t') with
+ | Some u ->
+ if unsat u
+ then T [snd t0 ; snd t']
+ else (match add_term t0 cl0 with
+ | S cl' -> S (t'::cl')
+ | T l -> T l)
+ | None ->
+ (match add_term t0 cl0 with
+ | S cl' -> S (t'::cl')
+ | T l -> T l)) in
+
+
+ let rec or_clause cl1 cl2 =
+ match cl1 with
+ | [] -> S cl2
+ | t0::cl ->
+ (match add_term t0 cl2 with
+ | S cl' -> or_clause cl cl'
+ | T l -> T l) in
+
+
+
+ let or_clause_cnf t f =
+ List.fold_right (fun e (acc,tg) ->
+ match or_clause t e with
+ | S cl -> (cl :: acc,tg)
+ | T l -> (acc,tg@l)) f ([],[]) in
+
let rec or_cnf f f' =
match f with
- | [] -> tt
- | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in
+ | [] -> tt,[]
+ | e :: rst ->
+ let (rst_f',t) = or_cnf rst f' in
+ let (e_f', t') = or_clause_cnf e f' in
+ (rst_f' @ e_f', t @ t') in
+
let rec xcnf (polarity : bool) f =
match f with
- | TT -> if polarity then tt else ff
- | FF -> if polarity then ff else tt
- | X p -> if polarity then ff else ff
- | A(x,t,_) -> if polarity then normalise x t else negate x t
+ | TT -> if polarity then (tt,[]) else (ff,[])
+ | FF -> if polarity then (ff,[]) else (tt,[])
+ | X p -> if polarity then (ff,[]) else (ff,[])
+ | A(x,t,_) -> ((if polarity then normalise x t else negate x t),[])
| N(e) -> xcnf (not polarity) e
- | C(e1,e2) ->
- (if polarity then and_cnf else or_cnf) (xcnf polarity e1) (xcnf polarity e2)
+ | C(e1,e2) ->
+ let e1,t1 = xcnf polarity e1 in
+ let e2,t2 = xcnf polarity e2 in
+ if polarity
+ then and_cnf e1 e2, t1 @ t2
+ else let f',t' = or_cnf e1 e2 in
+ (f', t1 @ t2 @ t')
| D(e1,e2) ->
- (if polarity then or_cnf else and_cnf) (xcnf polarity e1) (xcnf polarity e2)
+ let e1,t1 = xcnf polarity e1 in
+ let e2,t2 = xcnf polarity e2 in
+ if polarity
+ then let f',t' = or_cnf e1 e2 in
+ (f', t1 @ t2 @ t')
+ else and_cnf e1 e2, t1 @ t2
| I(e1,_,e2) ->
- (if polarity then or_cnf else and_cnf) (xcnf (not polarity) e1) (xcnf polarity e2) in
+ let e1 , t1 = (xcnf (not polarity) e1) in
+ let e2 , t2 = (xcnf polarity e2) in
+ if polarity
+ then let f',t' = or_cnf e1 e2 in
+ (f', t1 @ t2 @ t')
+ else and_cnf e1 e2, t1 @ t2 in
xcnf true f
@@ -212,6 +284,7 @@ struct
["RingMicromega"];
["EnvRing"];
["Coq"; "micromega"; "ZMicromega"];
+ ["Coq"; "micromega"; "RMicromega"];
["Coq" ; "micromega" ; "Tauto"];
["Coq" ; "micromega" ; "RingMicromega"];
["Coq" ; "micromega" ; "EnvRing"];
@@ -220,6 +293,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -28,7 +28,7 @@ type csdp_certificate = S of Sos_types.positivstellensatz option | F of string
type provername = string * int option
-let debug = true
+let debug = false
let flags = [Open_append;Open_binary;Open_creat]
let chan = open_out_gen flags 0o666 "trace"
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 9b6842bd..3b6b6987 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,18 +8,18 @@
(* *)
(* Micromega: A reflexive tactic using the Positivstellensatz *)
(* *)
+(* * Mappings from Coq tactics to Caml function calls *)
+(* *)
(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
(* *)
(************************************************************************)
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_micromega.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Quote
open Ring
open Mutils
-open Rawterm
+open Glob_term
open Util
let out_arg = function
@@ -35,6 +35,11 @@ TACTIC EXTEND ZOmicron
[ "xlia" ] -> [ Coq_micromega.xlia]
END
+TACTIC EXTEND Nlia
+[ "xnlia" ] -> [ Coq_micromega.xnlia]
+END
+
+
TACTIC EXTEND Sos_Z
| [ "sos_Z" ] -> [ Coq_micromega.sos_Z]
@@ -57,8 +62,6 @@ TACTIC EXTEND QOmicron
[ "psatzl_Q" ] -> [ Coq_micromega.psatzl_Q]
END
-
-
TACTIC EXTEND ROmicron
[ "psatzl_R" ] -> [ Coq_micromega.psatzl_R]
END
@@ -68,7 +71,6 @@ TACTIC EXTEND RMicromega
| [ "psatz_R" ] -> [ Coq_micromega.psatz_R (-1) ]
END
-
TACTIC EXTEND QMicromega
| [ "psatz_Q" int_or_var(i) ] -> [ Coq_micromega.psatz_Q (out_arg i) ]
| [ "psatz_Q" ] -> [ Coq_micromega.psatz_Q (-1) ]
diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
index 6250e324..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,12 +8,23 @@
(* *)
(* Micromega: A reflexive tactic using the Positivstellensatz *)
(* *)
+(* ** Utility functions ** *)
+(* *)
+(* - Modules CoqToCaml, CamlToCoq *)
+(* - Modules Cmp, Tag, TagSet *)
+(* *)
(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
(* *)
(************************************************************************)
let debug = false
+let rec pp_list f o l =
+ match l with
+ | [] -> ()
+ | e::l -> f o e ; output_string o ";" ; pp_list f o l
+
+
let finally f rst =
try
let res = f () in
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
(* *)
-(* A persistent hashtable *)
+(* A persistent hashtable *)
(* *)
-(* Frédéric Besson (Inria Rennes) 2009 *)
+(* Frédéric Besson (Inria Rennes) 2009-2011 *)
(* *)
(************************************************************************)
@@ -20,8 +20,7 @@ module type PHashtable =
val create : int -> string -> 'a t
(** [create i f] creates an empty persistent table
- with initial size i
- associated with file [f] *)
+ with initial size i associated with file [f] *)
val open_in : string -> 'a t
@@ -40,7 +39,7 @@ module type PHashtable =
val close : 'a t -> unit
(** [close tbl] is closing the table.
Once closed, a table cannot be used.
- i.e, copy, find,add will raise UnboundTable *)
+ i.e, find,add will raise UnboundTable *)
val memo : string -> (key -> 'a) -> (key -> 'a)
(** [memo cache f] returns a memo function for [f] using file [cache] as persistent table.
@@ -52,20 +51,17 @@ open Hashtbl
module PHashtable(Key:HashedType) : PHashtable with type key = Key.t =
struct
+ open Unix
type key = Key.t
module Table = Hashtbl.Make(Key)
-
-
exception InvalidTableFormat
exception UnboundTable
-
type mode = Closed | Open
-
type 'a t =
{
outch : out_channel ;
@@ -75,8 +71,9 @@ struct
let create i f =
+ let flags = [O_WRONLY; O_TRUNC;O_CREAT] in
{
- outch = open_out_bin f ;
+ outch = out_channel_of_descr (openfile f flags 0o666);
status = Open ;
htbl = Table.create i
}
@@ -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 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-20011 *)
+(* *)
+(************************************************************************)
+
+open Num
+module Utils = Mutils
+open Utils
+
+type var = int
+
+
+let (<+>) = add_num
+let (<->) = minus_num
+let (<*>) = mult_num
+
+
+module Monomial :
+sig
+ type t
+ val const : t
+ val is_const : t -> bool
+ val var : var -> t
+ val is_var : t -> bool
+ val find : var -> t -> int
+ val mult : var -> t -> t
+ val prod : t -> t -> t
+ val exp : t -> int -> t
+ val div : t -> t -> t * int
+ val compare : t -> t -> int
+ val pp : out_channel -> t -> unit
+ val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a
+ val sqrt : t -> t option
+end
+ =
+struct
+ (* A monomial is represented by a multiset of variables *)
+ module Map = Map.Make(struct type t = var let compare = Pervasives.compare end)
+ open Map
+
+ type t = int Map.t
+
+ let pp o m = Map.iter
+ (fun k v ->
+ if v = 1 then Printf.fprintf o "x%i." k
+ else Printf.fprintf o "x%i^%i." k v) m
+
+
+ (* The monomial that corresponds to a constant *)
+ let const = Map.empty
+
+ let sum_degree m = Map.fold (fun _ n s -> s + n) m 0
+
+ (* Total ordering of monomials *)
+ let compare: t -> t -> int =
+ fun m1 m2 ->
+ let s1 = sum_degree m1
+ and s2 = sum_degree m2 in
+ if s1 = s2 then Map.compare Pervasives.compare m1 m2
+ else Pervasives.compare s1 s2
+
+ let is_const m = (m = Map.empty)
+
+ (* The monomial 'x' *)
+ let var x = Map.add x 1 Map.empty
+
+ let is_var m =
+ try
+ not (Map.fold (fun _ i fk ->
+ if fk = true (* first key *)
+ then
+ if i = 1 then false
+ else raise Not_found
+ else raise Not_found) m true)
+ with Not_found -> false
+
+ let sqrt m =
+ if is_const m then None
+ else
+ try
+ Some (Map.fold (fun v i acc ->
+ let i' = i / 2 in
+ if i mod 2 = 0
+ then add v i' m
+ else raise Not_found) m const)
+ with Not_found -> None
+
+ (* Get the degre of a variable in a monomial *)
+ let find x m = try find x m with Not_found -> 0
+
+ (* Multiply a monomial by a variable *)
+ let mult x m = add x ( (find x m) + 1) m
+
+ (* Product of monomials *)
+ let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2
+
+
+ let exp m n =
+ let rec exp acc n =
+ if n = 0 then acc
+ else exp (prod acc m) (n - 1) in
+
+ exp const n
+
+
+ (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *)
+ let div m1 m2 =
+ let n = fold (fun x i n -> let i' = find x m1 in
+ let nx = i' / i in
+ min n nx) m2 max_int in
+
+ let mr = fold (fun x i' m ->
+ let i = find x m2 in
+ let ir = i' - i * n in
+ if ir = 0 then m
+ else add x ir m) m1 empty in
+ (mr,n)
+
+
+ let fold = fold
+
+end
+
+module Poly :
+ (* A polynomial is a map of monomials *)
+ (*
+ This is probably a naive implementation
+ (expected to be fast enough - Coq is probably the bottleneck)
+ *The new ring contribution is using a sparse Horner representation.
+ *)
+sig
+ type t
+ val get : Monomial.t -> t -> num
+ val variable : var -> t
+ val add : Monomial.t -> num -> t -> t
+ val constant : num -> t
+ val mult : Monomial.t -> num -> t -> t
+ val product : t -> t -> t
+ val addition : t -> t -> t
+ val uminus : t -> t
+ val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a
+ val pp : out_channel -> t -> unit
+ val compare : t -> t -> int
+ val is_null : t -> bool
+ val is_linear : t -> bool
+end =
+struct
+ (*normalisation bug : 0*x ... *)
+ module P = Map.Make(Monomial)
+ open P
+
+ type t = num P.t
+
+ let pp o p = P.iter
+ (fun k v ->
+ if Monomial.compare Monomial.const k = 0
+ then Printf.fprintf o "%s " (string_of_num v)
+ else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p
+
+ (* Get the coefficient of monomial mn *)
+ let get : Monomial.t -> t -> num =
+ fun mn p -> try find mn p with Not_found -> (Int 0)
+
+
+ (* The polynomial 1.x *)
+ let variable : var -> t =
+ fun x -> add (Monomial.var x) (Int 1) empty
+
+ (*The constant polynomial *)
+ let constant : num -> t =
+ fun c -> add (Monomial.const) c empty
+
+ (* The addition of a monomial *)
+
+ let add : Monomial.t -> num -> t -> t =
+ fun mn v p ->
+ if sign_num v = 0 then p
+ else
+ let vl = (get mn p) <+> v in
+ if sign_num vl = 0 then
+ remove mn p
+ else add mn vl p
+
+
+ (** Design choice: empty is not a polynomial
+ I do not remember why ....
+ **)
+
+ (* The product by a monomial *)
+ let mult : Monomial.t -> num -> t -> t =
+ fun mn v p ->
+ if sign_num v = 0
+ then constant (Int 0)
+ else
+ fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty
+
+
+ let addition : t -> t -> t =
+ fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2
+
+
+ let product : t -> t -> t =
+ fun p1 p2 ->
+ fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty
+
+
+ let uminus : t -> t =
+ fun p -> map (fun v -> minus_num v) p
+
+ let fold = P.fold
+
+ let is_null p = fold (fun mn vl b -> b & sign_num vl = 0) p true
+
+ let compare = compare compare_num
+
+ let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true
+
+(* let is_linear p =
+ let res = is_linear p in
+ Printf.printf "is_linear %a = %b\n" pp p res ; res
+*)
+end
+
+
+module Vect =
+ struct
+ (** [t] is the type of vectors.
+ A vector [(x1,v1) ; ... ; (xn,vn)] is such that:
+ - variables indexes are ordered (x1 <c ... < xn
+ - values are all non-zero
+ *)
+ type var = int
+ type t = (var * num) list
+
+(** [equal v1 v2 = true] if the vectors are syntactically equal.
+ ([num] is not handled by [Pervasives.equal] *)
+
+ let rec equal v1 v2 =
+ match v1 , v2 with
+ | [] , [] -> true
+ | [] , _ -> false
+ | _::_ , [] -> false
+ | (i1,n1)::v1 , (i2,n2)::v2 ->
+ (i1 = i2) && n1 =/ n2 && equal v1 v2
+
+ let hash v =
+ let rec hash i = function
+ | [] -> i
+ | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in
+ Hashtbl.hash (hash 0 v )
+
+
+ let null = []
+
+ let pp_vect o vect =
+ List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect
+
+ let from_list (l: num list) =
+ let rec xfrom_list i l =
+ match l with
+ | [] -> []
+ | e::l ->
+ if e <>/ Int 0
+ then (i,e)::(xfrom_list (i+1) l)
+ else xfrom_list (i+1) l in
+
+ xfrom_list 0 l
+
+ let zero_num = Int 0
+ let unit_num = Int 1
+
+
+ let to_list m =
+ let rec xto_list i l =
+ match l with
+ | [] -> []
+ | (x,v)::l' ->
+ if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in
+ xto_list 0 m
+
+
+ let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst
+
+ let rec update i f t =
+ match t with
+ | [] -> cons i (f zero_num) []
+ | (k,v)::l ->
+ match Pervasives.compare i k with
+ | 0 -> cons k (f v) l
+ | -1 -> cons i (f zero_num) t
+ | 1 -> (k,v) ::(update i f l)
+ | _ -> failwith "compare_num"
+
+ let rec set i n t =
+ match t with
+ | [] -> cons i n []
+ | (k,v)::l ->
+ match Pervasives.compare i k with
+ | 0 -> cons k n l
+ | -1 -> cons i n t
+ | 1 -> (k,v) :: (set i n l)
+ | _ -> failwith "compare_num"
+
+ let gcd m =
+ let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in
+ if Big_int.compare_big_int res Big_int.zero_big_int = 0
+ then Big_int.unit_big_int else res
+
+ let rec mul z t =
+ match z with
+ | Int 0 -> []
+ | Int 1 -> t
+ | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t
+
+
+ let rec add v1 v2 =
+ match v1 , v2 with
+ | (x1,n1)::v1' , (x2,n2)::v2' ->
+ if x1 = x2
+ then
+ let n' = n1 +/ n2 in
+ if n' =/ Int 0 then add v1' v2'
+ else
+ let res = add v1' v2' in
+ (x1,n') ::res
+ else if x1 < x2
+ then let res = add v1' v2 in
+ (x1, n1)::res
+ else let res = add v1 v2' in
+ (x2, n2)::res
+ | [] , [] -> []
+ | [] , _ -> v2
+ | _ , [] -> v1
+
+
+
+
+ let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical
+ [
+ (fun () -> Pervasives.compare (fst x) (fst y));
+ (fun () -> compare_num (snd x) (snd y))])
+
+ (** [tail v vect] returns
+ - [None] if [v] is not a variable of the vector [vect]
+ - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect]
+ and [rst] is the remaining of the vector
+ We exploit that vectors are ordered lists
+ *)
+ let rec tail (v:var) (vect:t) =
+ match vect with
+ | [] -> None
+ | (v',vl)::vect' ->
+ match Pervasives.compare v' v with
+ | 0 -> Some (vl,vect) (* Ok, found *)
+ | -1 -> tail v vect' (* Might be in the tail *)
+ | _ -> None (* Hopeless *)
+
+ let get v vect =
+ match tail v vect with
+ | None -> None
+ | Some(vl,_) -> Some vl
+
+
+ let rec fresh v =
+ match v with
+ | [] -> 1
+ | [v,_] -> v + 1
+ | _::v -> fresh v
+
+ end
+
+type vector = Vect.t
+
+type cstr_compat = {coeffs : vector ; op : op ; cst : num}
+and op = |Eq | Ge
+
+let string_of_op = function Eq -> "=" | Ge -> ">="
+
+let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} =
+ Printf.fprintf o "%a %s %s" Vect.pp_vect coeffs (string_of_op op) (string_of_num cst)
+
+let opMult o1 o2 =
+ match o1, o2 with
+ | Eq , Eq -> Eq
+ | Eq , Ge | Ge , Eq -> Ge
+ | Ge , Ge -> Ge
+
+let opAdd o1 o2 =
+ match o1 , o2 with
+ | Eq , _ | _ , Eq -> Eq
+ | Ge , Ge -> Ge
+
+
+
+
+open Big_int
+
+type index = int
+
+type prf_rule =
+ | Hyp of int
+ | Def of int
+ | Cst of big_int
+ | Zero
+ | Square of (Vect.t * num)
+ | MulC of (Vect.t * num) * prf_rule
+ | Gcd of big_int * prf_rule
+ | MulPrf of prf_rule * prf_rule
+ | AddPrf of prf_rule * prf_rule
+ | CutPrf of prf_rule
+
+type proof =
+ | Done
+ | Step of int * prf_rule * proof
+ | Enum of int * prf_rule * Vect.t * prf_rule * proof list
+
+
+let rec output_prf_rule o = function
+ | Hyp i -> Printf.fprintf o "Hyp %i" i
+ | Def i -> Printf.fprintf o "Def %i" i
+ | Cst c -> Printf.fprintf o "Cst %s" (string_of_big_int c)
+ | Zero -> Printf.fprintf o "Zero"
+ | Square _ -> Printf.fprintf o "( )^2"
+ | MulC(p,pr) -> Printf.fprintf o "P * %a" output_prf_rule pr
+ | MulPrf(p1,p2) -> Printf.fprintf o "%a * %a" output_prf_rule p1 output_prf_rule p2
+ | AddPrf(p1,p2) -> Printf.fprintf o "%a + %a" output_prf_rule p1 output_prf_rule p2
+ | CutPrf(p) -> Printf.fprintf o "[%a]" output_prf_rule p
+ | Gcd(c,p) -> Printf.fprintf o "(%a)/%s" output_prf_rule p (string_of_big_int c)
+
+let rec output_proof o = function
+ | Done -> Printf.fprintf o "."
+ | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf
+ | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i
+ output_prf_rule p1 Vect.pp_vect v output_prf_rule p2
+ (pp_list output_proof) pl
+
+let rec pr_rule_max_id = function
+ | Hyp i | Def i -> i
+ | Cst _ | Zero | Square _ -> -1
+ | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p
+ | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2)
+
+let rec proof_max_id = function
+ | Done -> -1
+ | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf))
+ | Enum(i,p1,_,p2,l) ->
+ let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in
+ List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l
+
+let rec pr_rule_def_cut id = function
+ | MulC(p,prf) ->
+ let (bds,id',prf') = pr_rule_def_cut id prf in
+ (bds, id', MulC(p,prf'))
+ | MulPrf(p1,p2) ->
+ let (bds1,id,p1) = pr_rule_def_cut id p1 in
+ let (bds2,id,p2) = pr_rule_def_cut id p2 in
+ (bds2@bds1,id,MulPrf(p1,p2))
+ | AddPrf(p1,p2) ->
+ let (bds1,id,p1) = pr_rule_def_cut id p1 in
+ let (bds2,id,p2) = pr_rule_def_cut id p2 in
+ (bds2@bds1,id,AddPrf(p1,p2))
+ | CutPrf p ->
+ let (bds,id,p) = pr_rule_def_cut id p in
+ ((id,p)::bds,id+1,Def id)
+ | Gcd(c,p) ->
+ let (bds,id,p) = pr_rule_def_cut id p in
+ ((id,p)::bds,id+1,Def id)
+ | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x)
+
+
+(* Do not define top-level cuts *)
+let pr_rule_def_cut id = function
+ | CutPrf p ->
+ let (bds,ids,p') = pr_rule_def_cut id p in
+ bds,ids, CutPrf p'
+ | p -> pr_rule_def_cut id p
+
+
+let rec implicit_cut p =
+ match p with
+ | CutPrf p -> implicit_cut p
+ | _ -> p
+
+
+let rec normalise_proof id prf =
+ match prf with
+ | Done -> (id,Done)
+ | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done))
+ | Step(i,p,prf) ->
+ let bds,id,p' = pr_rule_def_cut id p in
+ let (id,prf) = normalise_proof id prf in
+ let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc))
+ (Step(i,p',prf)) bds in
+
+ (id,prf)
+ | Enum(i,p1,v,p2,pl) ->
+ (* Why do I have top-level cuts ? *)
+(* let p1 = implicit_cut p1 in
+ let p2 = implicit_cut p2 in
+ let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in
+ (List.fold_left max 0 ids ,
+ Enum(i,p1,v,p2,prfs))
+*)
+
+ let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in
+ let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in
+ let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in
+ (List.fold_left max 0 ids ,
+ List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc))
+ (Enum(i,p1',v,p2',prfs)) (bds2@bds1))
+
+
+let normalise_proof id prf =
+ let res = normalise_proof id prf in
+ if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ;
+ res
+
+
+
+let add_proof x y =
+ match x, y with
+ | Zero , p | p , Zero -> p
+ | _ -> AddPrf(x,y)
+
+
+let mul_proof c p =
+ match sign_big_int c with
+ | 0 -> Zero (* This is likely to be a bug *)
+ | -1 -> MulC(([],Big_int c),p) (* [p] should represent an equality *)
+ | 1 ->
+ if eq_big_int c unit_big_int
+ then p
+ else MulPrf(Cst c,p)
+ | _ -> assert false
+
+
+let mul_proof_ext (p,c) prf =
+ match p with
+ | [] -> mul_proof (numerator c) prf
+ | _ -> MulC((p,c),prf)
+
+
+
+(*
+ let rec scale_prf_rule = function
+ | Hyp i -> (unit_big_int, Hyp i)
+ | Def i -> (unit_big_int, Def i)
+ | Cst c -> (unit_big_int, Cst i)
+ | Zero -> (unit_big_int, Zero)
+ | Square p -> (unit_big_int,Square p)
+ | Div(c,pr) ->
+ let (bi,pr') = scale_prf_rule pr in
+ (mult_big_int c bi , pr')
+ | MulC(p,pr) ->
+ let bi,pr' = scale_prf_rule pr in
+ (bi,MulC p,pr')
+ | MulPrf(p1,p2) ->
+ let b1,p1 = scale_prf_rule p1 in
+ let b2,p2 = scale_prf_rule p2 in
+
+
+ | AddPrf(p1,p2) ->
+ let b1,p1 = scale_prf_rule p1 in
+ let b2,p2 = scale_prf_rule p2 in
+ let g = gcd_big_int
+*)
+
+
+
+
+
+module LinPoly =
+struct
+ type t = Vect.t * num
+
+ module MonT =
+ struct
+ module MonoMap = Map.Make(Monomial)
+ module IntMap = Map.Make(struct type t = int let compare = Pervasives.compare end)
+
+ (** A hash table might be preferable but requires a hash function. *)
+ let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty)
+ let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty)
+ let fresh = ref 0
+
+ let clear () =
+ index_of_monomial := MonoMap.empty;
+ monomial_of_index := IntMap.empty ;
+ fresh := 0
+
+
+ let register m =
+ try
+ MonoMap.find m !index_of_monomial
+ with Not_found ->
+ begin
+ let res = !fresh in
+ index_of_monomial := MonoMap.add m res !index_of_monomial ;
+ monomial_of_index := IntMap.add res m !monomial_of_index ;
+ incr fresh ; res
+ end
+
+ let retrieve i = IntMap.find i !monomial_of_index
+
+
+ end
+
+ let normalise (v,c) =
+ (List.sort (fun x y -> Pervasives.compare (fst x) (fst y)) v , c)
+
+
+ let output_mon o (x,v) =
+ Printf.fprintf o "%s.%a +" (string_of_num v) Monomial.pp (MonT.retrieve x)
+
+
+
+ let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} =
+ Printf.fprintf o "%a %s %s" (pp_list output_mon) coeffs (string_of_op op) (string_of_num cst)
+
+
+
+ let linpol_of_pol p =
+ let (v,c) =
+ Poly.fold
+ (fun mon num (vct,cst) ->
+ if Monomial.is_const mon then (vct,num)
+ else
+ let vr = MonT.register mon in
+ ((vr,num)::vct,cst)) p ([], Int 0) in
+ normalise (v,c)
+
+ let mult v m (vect,c) =
+ if Monomial.is_const m
+ then
+ (Vect.mul v vect, v <*> c)
+ else
+ if sign_num v <> 0
+ then
+ let hd =
+ if sign_num c <> 0
+ then [MonT.register m,v <*> c]
+ else [] in
+
+ let vect = hd @ (List.map (fun (x,n) ->
+ let x = MonT.retrieve x in
+ let x_m = MonT.register (Monomial.prod m x) in
+ (x_m, v <*> n)) vect ) in
+ normalise (vect , Int 0)
+ else ([],Int 0)
+
+ let mult v m (vect,c) =
+ let (vect',c') = mult v m (vect,c) in
+ if debug then
+ Printf.printf "mult %s %a (%a,%s) -> (%a,%s)\n" (string_of_num v) Monomial.pp m
+ (pp_list output_mon) vect (string_of_num c)
+ (pp_list output_mon) vect' (string_of_num c') ;
+ (vect',c')
+
+
+
+ let make_lin_pol v mon =
+ if Monomial.is_const mon
+ then [] , v
+ else [MonT.register mon, v],Int 0
+
+
+
+
+
+
+ let xpivot_eq (c,prf) x v (c',prf') =
+ if debug then Printf.printf "xpivot_eq {%a} %a %s {%a}\n"
+ output_cstr c
+ Monomial.pp (MonT.retrieve x)
+ (string_of_num v) output_cstr c' ;
+
+
+ let {coeffs = coeffs ; op = op ; cst = cst} = c' in
+ let m = MonT.retrieve x in
+
+ let apply_pivot (vqn,q,n) (c',prf') =
+ (* Morally, we have (Vect.get (q*x^n) c'.coeffs) = vmn with n >=0 *)
+
+ let cc' = abs_num v in
+ let cc_num = Int (- (sign_num v)) <*> vqn in
+ let cc_mon = Monomial.prod q (Monomial.exp m (n-1)) in
+
+ let (c_coeff,c_cst) = mult cc_num cc_mon (c.coeffs, minus_num c.cst) in
+
+ let c' = {coeffs = Vect.add (Vect.mul cc' c'.coeffs) c_coeff ; op = op ; cst = (minus_num c_cst) <+> (cc' <*> c'.cst)} in
+ let prf' = add_proof
+ (mul_proof_ext (make_lin_pol cc_num cc_mon) prf)
+ (mul_proof (numerator cc') prf') in
+
+ if debug then Printf.printf "apply_pivot -> {%a}\n" output_cstr c' ;
+ (c',prf') in
+
+
+ let cmp (q,n) (q',n') =
+ if n < n' then -1
+ else if n = n' then Monomial.compare q q'
+ else 1 in
+
+
+ let find_pivot (c',prf') =
+ let (v,q,n) = List.fold_left
+ (fun (v,q,n) (x,v') ->
+ let x = MonT.retrieve x in
+ let (q',n') = Monomial.div x m in
+ if cmp (q,n) (q',n') = -1 then (v',q',n') else (v,q,n)) (Int 0, Monomial.const,0) c'.coeffs in
+ if n > 0 then Some (v,q,n) else None in
+
+ let rec pivot (q,n) (c',prf') =
+ match find_pivot (c',prf') with
+ | None -> (c',prf')
+ | Some(v,q',n') ->
+ if cmp (q',n') (q,n) = -1
+ then pivot (q',n') (apply_pivot (v,q',n') (c',prf'))
+ else (c',prf') in
+
+ pivot (Monomial.const,max_int) (c',prf')
+
+
+ let pivot_eq x (c,prf) =
+ match Vect.get x c.coeffs with
+ | None -> (fun x -> None)
+ | Some v -> fun cp' -> Some (xpivot_eq (c,prf) x v cp')
+
+
+end
diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml
index 3029496b..6ddc48e7 100644
--- a/plugins/micromega/sos.ml
+++ b/plugins/micromega/sos.ml
@@ -526,17 +526,17 @@ let sdpa_run_succeeded =
(* ------------------------------------------------------------------------- *)
let sdpa_default_parameters =
-"100 unsigned int maxIteration;
-1.0E-7 double 0.0 < epsilonStar;
-1.0E2 double 0.0 < lambdaStar;
-2.0 double 1.0 < omegaStar;
--1.0E5 double lowerBound;
-1.0E5 double upperBound;
-0.1 double 0.0 <= betaStar < 1.0;
-0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;
-0.9 double 0.0 < gammaStar < 1.0;
-1.0E-7 double 0.0 < epsilonDash;
-";;
+"100 unsigned int maxIteration;\
+\n1.0E-7 double 0.0 < epsilonStar;\
+\n1.0E2 double 0.0 < lambdaStar;\
+\n2.0 double 1.0 < omegaStar;\
+\n-1.0E5 double lowerBound;\
+\n1.0E5 double upperBound;\
+\n0.1 double 0.0 <= betaStar < 1.0;\
+\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\
+\n0.9 double 0.0 < gammaStar < 1.0;\
+\n1.0E-7 double 0.0 < epsilonDash;\
+\n";;
(* ------------------------------------------------------------------------- *)
(* These were suggested by Makoto Yamashita for problems where we are *)
@@ -544,17 +544,17 @@ let sdpa_default_parameters =
(* ------------------------------------------------------------------------- *)
let sdpa_alt_parameters =
-"1000 unsigned int maxIteration;
-1.0E-7 double 0.0 < epsilonStar;
-1.0E4 double 0.0 < lambdaStar;
-2.0 double 1.0 < omegaStar;
--1.0E5 double lowerBound;
-1.0E5 double upperBound;
-0.1 double 0.0 <= betaStar < 1.0;
-0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;
-0.9 double 0.0 < gammaStar < 1.0;
-1.0E-7 double 0.0 < epsilonDash;
-";;
+"1000 unsigned int maxIteration;\
+\n1.0E-7 double 0.0 < epsilonStar;\
+\n1.0E4 double 0.0 < lambdaStar;\
+\n2.0 double 1.0 < omegaStar;\
+\n-1.0E5 double lowerBound;\
+\n1.0E5 double upperBound;\
+\n0.1 double 0.0 <= betaStar < 1.0;\
+\n0.2 double 0.0 <= betaBar < 1.0, betaStar <= betaBar;\
+\n0.9 double 0.0 < gammaStar < 1.0;\
+\n1.0E-7 double 0.0 < epsilonDash;\
+\n";;
let sdpa_params = sdpa_alt_parameters;;
@@ -563,21 +563,21 @@ let sdpa_params = sdpa_alt_parameters;;
(* ------------------------------------------------------------------------- *)
let csdp_default_parameters =
-"axtol=1.0e-8
-atytol=1.0e-8
-objtol=1.0e-8
-pinftol=1.0e8
-dinftol=1.0e8
-maxiter=100
-minstepfrac=0.9
-maxstepfrac=0.97
-minstepp=1.0e-8
-minstepd=1.0e-8
-usexzgap=1
-tweakgap=0
-affine=0
-printlevel=1
-";;
+"axtol=1.0e-8\
+\natytol=1.0e-8\
+\nobjtol=1.0e-8\
+\npinftol=1.0e8\
+\ndinftol=1.0e8\
+\nmaxiter=100\
+\nminstepfrac=0.9\
+\nmaxstepfrac=0.97\
+\nminstepp=1.0e-8\
+\nminstepd=1.0e-8\
+\nusexzgap=1\
+\ntweakgap=0\
+\naffine=0\
+\nprintlevel=1\
+\n";;
let csdp_params = csdp_default_parameters;;
diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli
index 23219be2..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml
index 6bd463ef..91aa5855 100644
--- a/plugins/micromega/sos_types.ml
+++ b/plugins/micromega/sos_types.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v
index ac321ba2..9a0c9090 100644
--- a/plugins/nsatz/Nsatz.v
+++ b/plugins/nsatz/Nsatz.v
@@ -1,20 +1,19 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
(*
- Tactic nsatz: proofs of polynomials equalities in a domain (ring without zero divisor).
- Reification is done by type classes, following a technique shown by Mathieu
-Sozeau. Verification of certificate is done by a code written by Benjamin
-Gregoire, following an idea of Laurent Théry.
-
+ Tactic nsatz: proofs of polynomials equalities in an integral domain
+(commutative ring without zero divisor).
+
Examples: see test-suite/success/Nsatz.v
-Loïc Pottier, july 2010
+Reification is done using type classes, defined in Ncring_tac.v
+
*)
Require Import List.
@@ -22,74 +21,27 @@ Require Import Setoid.
Require Import BinPos.
Require Import BinList.
Require Import Znumtheory.
-Require Import Ring_polynom Ring_tac InitialRing.
Require Export Morphisms Setoid Bool.
+Require Export Algebra_syntax.
+Require Export Ncring.
+Require Export Ncring_initial.
+Require Export Ncring_tac.
+Require Export Integral_domain.
+Require Import DiscrR.
Declare ML Module "nsatz_plugin".
-Class Zero (A : Type) := {zero : A}.
-Notation "0" := zero.
-Class One (A : Type) := {one : A}.
-Notation "1" := one.
-Class Addition (A : Type) := {addition : A -> A -> A}.
-Notation "x + y" := (addition x y).
-Class Multiplication (A : Type) := {multiplication : A -> A -> A}.
-Notation "x * y" := (multiplication x y).
-Class Subtraction (A : Type) := {subtraction : A -> A -> A}.
-Notation "x - y" := (subtraction x y).
-Class Opposite (A : Type) := {opposite : A -> A}.
-Notation "- x" := (opposite x).
-
-Class Ring (R:Type) := {
- ring0: R; ring1: R;
- ring_plus: R->R->R; ring_mult: R->R->R;
- ring_sub: R->R->R; ring_opp: R->R;
- ring_eq : R -> R -> Prop;
- ring_ring:
- ring_theory ring0 ring1 ring_plus ring_mult ring_sub
- ring_opp ring_eq;
- ring_setoid: Equivalence ring_eq;
- ring_plus_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_plus;
- ring_mult_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_mult;
- ring_sub_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_sub;
- ring_opp_comp: Proper (ring_eq==>ring_eq) ring_opp
-}.
-
-Class Domain (R : Type) := {
- domain_ring:> Ring R;
- domain_axiom_product:
- forall x y, ring_eq (ring_mult x y) ring0 -> (ring_eq x ring0) \/ (ring_eq y ring0);
- domain_axiom_one_zero: not (ring_eq ring1 ring0)}.
-
-Section domain.
-
-Variable R: Type.
-Variable Rd: Domain R.
-
-Existing Instance ring_setoid.
-Existing Instance ring_plus_comp.
-Existing Instance ring_mult_comp.
-Existing Instance ring_sub_comp.
-Existing Instance ring_opp_comp.
-
-Add Ring Rr: (@ring_ring R (@domain_ring R Rd)).
-
-Instance zero_ring : Zero R := {zero := ring0}.
-Instance one_ring : One R := {one := ring1}.
-Instance addition_ring : Addition R := {addition x y := ring_plus x y}.
-Instance multiplication_ring : Multiplication R := {multiplication x y := ring_mult x y}.
-Instance subtraction_ring : Subtraction R := {subtraction x y := ring_sub x y}.
-Instance opposite_ring : Opposite R := {opposite x := ring_opp x}.
-
-Infix "==" := ring_eq (at level 70, no associativity).
+Section nsatz1.
+
+Context {R:Type}`{Rid:Integral_domain R}.
Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y.
intros x y H; setoid_replace x with ((x - y) + y); simpl;
- [setoid_rewrite H | idtac]; simpl; ring.
+ [setoid_rewrite H | idtac]; simpl. cring. cring.
Qed.
Lemma psos_r1: forall x y, x == y -> x - y == 0.
-intros x y H; simpl; setoid_rewrite H; simpl; ring.
+intros x y H; simpl; setoid_rewrite H; simpl; cring.
Qed.
Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0).
@@ -97,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -363,7 +363,7 @@ let stringPcut p =
nsP2:=10;
let res =
if (length p)> !nsP2
- then (stringP [hd p])^" + "^(string_of_int (length p))^" termes"
+ then (stringP [hd p])^" + "^(string_of_int (length p))^" terms"
else stringP p in
(*Polynomesrec.nsP1:= max_int;*)
nsP2:= max_int;
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -16,7 +16,7 @@ open Closure
open Environ
open Libnames
open Tactics
-open Rawterm
+open Glob_term
open Tacticals
open Tacexpr
open Pcoq
@@ -180,21 +180,24 @@ let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul")
let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp")
let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow")
-let tlist = lazy (gen_constant "CC" ["Lists";"List"] "list")
-let lnil = lazy (gen_constant "CC" ["Lists";"List"] "nil")
-let lcons = lazy (gen_constant "CC" ["Lists";"List"] "cons")
+let datatypes = ["Init";"Datatypes"]
+let binnums = ["Numbers";"BinNums"]
-let tz = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z")
-let z0 = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Z0")
-let zpos = lazy (gen_constant "CC" ["ZArith";"BinInt"] "Zpos")
-let zneg = lazy(gen_constant "CC" ["ZArith";"BinInt"] "Zneg")
+let tlist = lazy (gen_constant "CC" datatypes "list")
+let lnil = lazy (gen_constant "CC" datatypes "nil")
+let lcons = lazy (gen_constant "CC" datatypes "cons")
-let pxI = lazy(gen_constant "CC" ["NArith";"BinPos"] "xI")
-let pxO = lazy(gen_constant "CC" ["NArith";"BinPos"] "xO")
-let pxH = lazy(gen_constant "CC" ["NArith";"BinPos"] "xH")
+let tz = lazy (gen_constant "CC" binnums "Z")
+let z0 = lazy (gen_constant "CC" binnums "Z0")
+let zpos = lazy (gen_constant "CC" binnums "Zpos")
+let zneg = lazy(gen_constant "CC" binnums "Zneg")
-let nN0 = lazy (gen_constant "CC" ["NArith";"BinNat"] "N0")
-let nNpos = lazy(gen_constant "CC" ["NArith";"BinNat"] "Npos")
+let pxI = lazy(gen_constant "CC" binnums "xI")
+let pxO = lazy(gen_constant "CC" binnums "xO")
+let pxH = lazy(gen_constant "CC" binnums "xH")
+
+let nN0 = lazy (gen_constant "CC" binnums "N0")
+let nNpos = lazy(gen_constant "CC" binnums "Npos")
let mkt_app name l = mkApp (Lazy.force name, Array.of_list l)
@@ -237,14 +240,14 @@ else
let rec parse_pos p =
match kind_of_term p with
| App (a,[|p2|]) ->
- if a = Lazy.force pxO then num_2 */ (parse_pos p2)
+ if eq_constr a (Lazy.force pxO) then num_2 */ (parse_pos p2)
else num_1 +/ (num_2 */ (parse_pos p2))
| _ -> num_1
let parse_z z =
match kind_of_term z with
| App (a,[|p2|]) ->
- if a = Lazy.force zpos then parse_pos p2 else (num_0 -/ (parse_pos p2))
+ if eq_constr a (Lazy.force zpos) then parse_pos p2 else (num_0 -/ (parse_pos p2))
| _ -> num_0
let parse_n z =
@@ -256,15 +259,15 @@ let parse_n z =
let rec parse_term p =
match kind_of_term p with
| App (a,[|_;p2|]) ->
- if a = Lazy.force ttvar then Var (string_of_num (parse_pos p2))
- else if a = Lazy.force ttconst then Const (parse_z p2)
- else if a = Lazy.force ttopp then Opp (parse_term p2)
+ if eq_constr a (Lazy.force ttvar) then Var (string_of_num (parse_pos p2))
+ else if eq_constr a (Lazy.force ttconst) then Const (parse_z p2)
+ else if eq_constr a (Lazy.force ttopp) then Opp (parse_term p2)
else Zero
| App (a,[|_;p2;p3|]) ->
- if a = Lazy.force ttadd then Add (parse_term p2, parse_term p3)
- else if a = Lazy.force ttsub then Sub (parse_term p2, parse_term p3)
- else if a = Lazy.force ttmul then Mul (parse_term p2, parse_term p3)
- else if a = Lazy.force ttpow then
+ if eq_constr a (Lazy.force ttadd) then Add (parse_term p2, parse_term p3)
+ else if eq_constr a (Lazy.force ttsub) then Sub (parse_term p2, parse_term p3)
+ else if eq_constr a (Lazy.force ttmul) then Mul (parse_term p2, parse_term p3)
+ else if eq_constr a (Lazy.force ttpow) then
Pow (parse_term p2, int_of_num (parse_n p3))
else Zero
| _ -> Zero
@@ -323,6 +326,8 @@ open PIdeal
let term_pol_sparse np t=
let d = !nvars in
let rec aux t =
+(* info ("conversion de: "^(string_of_term t)^"\n");*)
+ let res =
match t with
| Zero -> zeroP
| Const r ->
@@ -339,9 +344,11 @@ let term_pol_sparse np t=
| Sub (t1,t2) -> plusP (aux t1) (oppP (aux t2))
| Mul (t1,t2) -> multP (aux t1) (aux t2)
| Pow (t1,n) -> puisP (aux t1) n
- in (*info ("conversion de: "^(string_of_term t)^"\n");*)
+ in
+(* info ("donne: "^(stringP res)^"\n");*)
+ res
+ in
let res= aux t in
- (*info ("donne: "^(stringP res)^"\n");*)
res
(* sparse polynomial to term *)
@@ -364,7 +371,7 @@ let polrec_to_term p =
(* approximation of the Horner form used in the tactic ring *)
let pol_sparse_to_term n2 p =
- info "pol_sparse_to_term ->\n";
+ (* info "pol_sparse_to_term ->\n";*)
let p = PIdeal.repr p in
let rec aux p =
match p with
@@ -408,7 +415,7 @@ let pol_sparse_to_term n2 p =
then Var (string_of_int (i0))
else pow (Var (string_of_int (i0)),e0) in
add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2))))
- in info "-> pol_sparse_to_term\n";
+ in (*info "-> pol_sparse_to_term\n";*)
aux p
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -282,12 +282,11 @@ let rec multx n v p =
p2.(i+n)<-p1.(i);
done;
Prec (x,p2)
- |_ -> if p = (Pint coef0) then (Pint coef0)
+ |_ -> if equal p (Pint coef0) then (Pint coef0)
else (let p2=Array.create (n+1) (Pint coef0) in
p2.(n)<-p;
Prec (v,p2))
-
(* product *)
let rec multP p q =
match (p,q) with
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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v
index c8a06265..3f9d0f44 100644
--- a/plugins/omega/Omega.v
+++ b/plugins/omega/Omega.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -13,8 +13,6 @@
(* *)
(**************************************************************************)
-(* $Id: Omega.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* We do not require [ZArith] anymore, but only what's necessary for Omega *)
Require Export ZArith_base.
Require Export OmegaLemmas.
diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v
index ec9faedd..5b6f4670 100644
--- a/plugins/omega/OmegaLemmas.v
+++ b/plugins/omega/OmegaLemmas.v
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(*i $Id: OmegaLemmas.v 12337 2009-09-17 15:58:14Z glondu $ i*)
-
Require Import ZArith_base.
Open Local Scope Z_scope.
@@ -300,3 +298,10 @@ Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop)
Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop)
(H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x).
+
+Theorem intro_Z :
+ forall n:nat, exists y : Z, Z_of_nat n = y /\ 0 <= y * 1 + 0.
+Proof.
+ intros n; exists (Z_of_nat n); split; trivial.
+ rewrite 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: OmegaPlugin.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Declare ML Module "omega_plugin".
diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v
index a5a085a9..46fd5682 100644
--- a/plugins/omega/PreOmega.v
+++ b/plugins/omega/PreOmega.v
@@ -28,7 +28,7 @@ Open Local Scope Z_scope.
Ltac zify_unop_core t thm a :=
(* Let's introduce the specification theorem for t *)
- let H:= fresh "H" in assert (H:=thm a);
+ pose proof (thm a);
(* Then we replace (t a) everywhere with a fresh variable *)
let z := fresh "z" in set (z:=t a) in *; clearbody z.
@@ -159,11 +159,9 @@ Ltac zify_nat_op :=
(* mult -> Zmult and a positivity hypothesis *)
| H : context [ Z_of_nat (mult ?a ?b) ] |- _ =>
- let H:= fresh "H" in
- assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
+ 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<?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H
- | |- context [ (?a<?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b)
+ | H : context [ (?a < ?b)%positive ] |- _ => change (a<b)%positive with (Zpos a<Zpos b) in H
+ | |- context [ (?a < ?b)%positive ] => change (a<b)%positive with (Zpos a<Zpos b)
(* III: less or equal *)
- | H : context [ (?a<=?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H
- | |- context [ (?a<=?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b)
+ | H : context [ (?a <= ?b)%positive ] |- _ => change (a<=b)%positive with (Zpos a<=Zpos b) in H
+ | |- context [ (?a <= ?b)%positive ] => change (a<=b)%positive with (Zpos a<=Zpos b)
(* IV: greater than *)
- | H : context [ (?a>?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H
- | |- context [ (?a>?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b)
+ | H : context [ (?a > ?b)%positive ] |- _ => change (a>b)%positive with (Zpos a>Zpos b) in H
+ | |- context [ (?a > ?b)%positive ] => change (a>b)%positive with (Zpos a>Zpos b)
(* V: greater or equal *)
- | H : context [ (?a>=?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H
- | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
+ | H : context [ (?a >= ?b)%positive ] |- _ => change (a>=b)%positive with (Zpos a>=Zpos b) in H
+ | |- context [ (?a >= ?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b)
end.
Ltac zify_positive_op :=
@@ -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<?b)%N |- _ => generalize (Z_of_N_lt _ _ H); clear H; intro H
- | |- (?a<?b)%N => apply (Z_of_N_lt_rev a b)
- | H : context [ (?a<?b)%N ] |- _ => rewrite (Z_of_N_lt_iff a b) in H
- | |- context [ (?a<?b)%N ] => rewrite (Z_of_N_lt_iff a b)
+ | H : (?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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -13,8 +13,6 @@
(* *)
(**************************************************************************)
-(* $Id: coq_omega.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util
open Pp
open Reduction
@@ -22,7 +20,6 @@ open Proof_type
open Names
open Nameops
open Term
-open Termops
open Declarations
open Environ
open Sign
@@ -60,6 +57,7 @@ open Goptions
let _ =
declare_bool_option
{ optsync = false;
+ optdepr = false;
optname = "Omega system time displaying flag";
optkey = ["Omega";"System"];
optread = read display_system_flag;
@@ -68,6 +66,7 @@ let _ =
let _ =
declare_bool_option
{ optsync = false;
+ optdepr = false;
optname = "Omega action display flag";
optkey = ["Omega";"Action"];
optread = read display_action_flag;
@@ -76,6 +75,7 @@ let _ =
let _ =
declare_bool_option
{ optsync = false;
+ optdepr = false;
optname = "Omega old style flag";
optkey = ["Omega";"OldStyle"];
optread = read old_style_flag;
@@ -128,12 +128,12 @@ let intern_id,unintern_id =
let mk_then = tclTHENLIST
-let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c])
+let exists_tac c = constructor_tac false (Some 1) 1 (Glob_term.ImplicitBindings [c])
let generalize_tac t = generalize_time (generalize t)
let elim t = elim_time (simplest_elim t)
let exact t = exact_time (Tactics.refine t)
-let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s]
+let unfold s = Tactics.unfold_in_concl [Termops.all_occurrences, Lazy.force s]
let rev_assoc k =
let rec loop = function
@@ -150,7 +150,7 @@ let tag_hypothesis,tag_of_hyp, hyp_of_tag =
let hide_constr,find_constr,clear_tables,dump_tables =
let l = ref ([]:(constr * (identifier * identifier * bool)) list) in
(fun h id eg b -> l := (h,(id,eg,b)):: !l),
- (fun h -> try List.assoc h !l with Not_found -> failwith "find_contr"),
+ (fun h -> try list_assoc_f eq_constr h !l with Not_found -> failwith "find_contr"),
(fun () -> l := []),
(fun () -> !l)
@@ -169,6 +169,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -15,8 +15,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_omega.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Coq_omega
open Refiner
diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml
index 8bb10194..3a5aece7 100644
--- a/plugins/omega/omega.ml
+++ b/plugins/omega/omega.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -214,7 +214,7 @@ let rec display_action print_var = function
constant factors.\n" e1.id e2.id
| NEGATE_CONTRADICT(e1,e2,b) ->
Printf.printf
- "Equations E%d and E%d state that their body is at the same time
+ "Equations E%d and E%d state that their body is at the same time \
equal and different\n" e1.id e2.id
| CONSTANT_NOT_NUL (e,k) ->
Printf.printf "Equation E%d states %s = 0.\n" e (sbi k)
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
index 1485c147..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Quote.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Declare ML Module "quote_plugin".
(***********************************************************************
@@ -28,7 +26,6 @@ Declare ML Module "quote_plugin".
***********************************************************************)
Set Implicit Arguments.
-Unset Boxed Definitions.
Section variables_map.
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index 3c51223a..1f4ea97f 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,14 +8,12 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_quote.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util
open Tacexpr
open Quote
let make_cont k x =
- let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> fst k)) in
+ let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> k)) in
let x = TacDynamic(dummy_loc, Pretyping.constr_in x) in
let tac = <:tactic<let cont := $k in cont $x>> in
Tacinterp.interp tac
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
index baba7e1b..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: quote.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* The `Quote' tactic *)
(* The basic idea is to automatize the inversion of interpetation functions
@@ -111,7 +109,6 @@ open Pattern
open Matching
open Tacmach
open Tactics
-open Proof_trees
open Tacexpr
(*i*)
@@ -169,7 +166,7 @@ exchange ?1 and ?2 in the example above)
module ConstrSet = Set.Make(
struct
type t = constr
- let compare = (Pervasives.compare : t->t->int)
+ let compare = constr_ord
end)
type inversion_scheme = {
@@ -211,7 +208,7 @@ let compute_lhs typ i nargsi =
let compute_rhs bodyi index_of_f =
let rec aux c =
match kind_of_term c with
- | App (j, args) when j = mkRel (index_of_f) (* recursive call *) ->
+ | App (j, args) when isRel j && destRel j = index_of_f (* recursive call *) ->
let i = destRel (array_last args) in
PMeta (Some (coerce_meta_in i))
| App (f,args) ->
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* Instantiation of the Ring tactic for the naturals of Arith $*)
Require Import Bool.
@@ -17,7 +15,7 @@ Require Import Eqdep_dec.
Open Local Scope nat_scope.
-Unboxed Fixpoint nateq (n m:nat) {struct m} : bool :=
+Fixpoint nateq (n m:nat) {struct m} : bool :=
match n, m with
| O, O => true
| S n', S m' => nateq n' m'
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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyNArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* Instantiation of the Ring tactic for the binary natural numbers *)
Require Import Bool.
@@ -16,7 +14,7 @@ Require Export ZArith_base.
Require Import NArith.
Require Import Eqdep_dec.
-Unboxed Definition Neq (n m:N) :=
+Definition Neq (n m:N) :=
match (n ?= m)%N with
| Datatypes.Eq => true
| _ => false
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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Export Bool.
Require Export LegacyRing_theory.
Require Export Quote.
diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v
index bf61aee1..ca3355a6 100644
--- a/plugins/ring/LegacyRing_theory.v
+++ b/plugins/ring/LegacyRing_theory.v
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyRing_theory.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Export Bool.
Set Implicit Arguments.
diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v
index d1412104..5845062d 100644
--- a/plugins/ring/LegacyZArithRing.v
+++ b/plugins/ring/LegacyZArithRing.v
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyZArithRing.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* Instantiation of the Ring tactic for the binary integers of ZArith *)
Require Export LegacyArithRing.
@@ -15,7 +13,7 @@ Require Export ZArith_base.
Require Import Eqdep_dec.
Require Import LegacyRing.
-Unboxed Definition Zeq (x y:Z) :=
+Definition Zeq (x y:Z) :=
match (x ?= y)%Z with
| Datatypes.Eq => true
| _ => false
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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Ring_abstract.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Import LegacyRing_theory.
Require Import Quote.
Require Import Ring_normalize.
-Unset Boxed Definitions.
-
Section abstract_semi_rings.
Inductive aspolynomial : Type :=
diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v
index dd4e7314..c6dff3e0 100644
--- a/plugins/ring/Ring_normalize.v
+++ b/plugins/ring/Ring_normalize.v
@@ -1,18 +1,15 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Ring_normalize.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Import LegacyRing_theory.
Require Import Quote.
Set Implicit Arguments.
-Unset Boxed Definitions.
Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
Proof.
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Setoid_ring.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Export Setoid_ring_theory.
Require Export Quote.
Require Export Setoid_ring_normalize.
diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v
index c4527cfb..ad75a8a4 100644
--- a/plugins/ring/Setoid_ring_normalize.v
+++ b/plugins/ring/Setoid_ring_normalize.v
@@ -1,18 +1,15 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Setoid_ring_normalize.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Import Setoid_ring_theory.
Require Import Quote.
Set Implicit Arguments.
-Unset Boxed Definitions.
Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
Proof.
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Setoid_ring_theory.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Export Bool.
Require Export Setoid.
diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4
index c5a33f39..e306a531 100644
--- a/plugins/ring/g_ring.ml4
+++ b/plugins/ring/g_ring.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,8 +8,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_ring.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Quote
open Ring
open Tacticals
diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml
index 6e67272c..98d6361c 100644
--- a/plugins/ring/ring.ml
+++ b/plugins/ring/ring.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ring.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* ML part of the Ring tactic *)
open Pp
@@ -21,7 +19,6 @@ open Reductionops
open Tacticals
open Tacexpr
open Tacmach
-open Proof_trees
open Printer
open Equality
open Vernacinterp
@@ -138,7 +135,7 @@ let mkLApp(fc,v) = mkApp(Lazy.force fc, v)
module OperSet =
Set.Make (struct
type t = global_reference
- let compare = (Pervasives.compare : t->t->int)
+ let compare = (RefOrdered.compare : t->t->int)
end)
type morph =
@@ -169,7 +166,7 @@ type theory =
(* Theories are stored in a table which is synchronised with the Reset
mechanism. *)
-module Cmap = Map.Make(struct type t = constr let compare = compare end)
+module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
let theories_map = ref Cmap.empty
@@ -265,7 +262,7 @@ let subst_th (subst,(c,th as obj)) =
(c',th')
-let (theory_to_obj, obj_to_theory) =
+let theory_to_obj : constr * theory -> obj =
let cache_th (_,(c, th)) = theories_map_add (c,th) in
declare_object {(default_object "tactic-ring-theory") with
open_function = (fun i o -> if i=1 then cache_th o);
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Bintree.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Export List.
Require Export BinPos.
-
-Unset Boxed Definitions.
+Require Arith.EqNat.
Open Scope positive_scope.
Ltac clean := try (simpl; congruence).
-Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
-
-Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop.
-
-Lemma Gt_Eq_Gt : forall p q cmp,
- (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt.
-apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Eq = Gt -> (p ?= q) cmp = Gt));
-simpl;auto;congruence.
-Qed.
-
-Lemma Gt_Lt_Gt : forall p q cmp,
- (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt.
-apply (Pcompare_ind (fun p q cmp _ => (p ?= q) Lt = Gt -> (p ?= q) cmp = Gt));
-simpl;auto;congruence.
-Qed.
-
-Lemma Gt_Psucc_Eq: forall p q,
- (p ?= Psucc q) Gt = Gt -> (p ?= q) Eq = Gt.
-intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
-intro;apply Gt_Eq_Gt;auto.
-apply Gt_Lt_Gt.
-Qed.
-
-Lemma Eq_Psucc_Gt: forall p q,
- (p ?= Psucc q) Eq = Eq -> (p ?= q) Eq = Gt.
-intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
-intro H;elim (Pcompare_not_Eq p (Psucc q));tauto.
-intro H;apply Gt_Eq_Gt;auto.
-intro H;rewrite Pcompare_Eq_eq with p q;auto.
-generalize q;clear q IHq p H;induction q;simpl;auto.
-intro H;elim (Pcompare_not_Eq p q);tauto.
-Qed.
-
-Lemma Gt_Psucc_Gt : forall n p cmp cmp0,
- (n?=p) cmp = Gt -> (Psucc n?=p) cmp0 = Gt.
-induction n;intros [ | p | p];simpl;try congruence.
-intros; apply IHn with cmp;trivial.
-intros; apply IHn with Gt;trivial.
-intros;apply Gt_Lt_Gt;trivial.
-intros [ | | ] _ H.
-apply Gt_Eq_Gt;trivial.
-apply Gt_Lt_Gt;trivial.
-trivial.
-Qed.
Lemma Gt_Psucc: forall p q,
- (p ?= Psucc q) Eq = Gt -> (p ?= q) Eq = Gt.
-intros p q;generalize p;clear p;induction q;destruct p;simpl;auto;try congruence.
-apply Gt_Psucc_Eq.
-intro;apply Gt_Eq_Gt;apply IHq;auto.
-apply Gt_Eq_Gt.
-apply Gt_Lt_Gt.
+ (p ?= 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Rtauto.v 14641 2011-11-06 11:59:10Z herbelin $ *)
-
Require Export List.
Require Export Bintree.
Require Import Bool.
-Unset Boxed Definitions.
Declare ML Module "rtauto_plugin".
-Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
Ltac clean:=try (simpl;congruence).
Inductive form:Set:=
@@ -43,7 +39,7 @@ end.
Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n.
induction m;simpl;destruct n;congruence ||
-(intro e;apply f_equal with positive;auto).
+(intro e;apply f_equal;auto).
Qed.
Fixpoint form_eq (p q:form) {struct p} :bool :=
@@ -69,15 +65,15 @@ end.
Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q.
induction p;destruct q;simpl;clean.
intro h;generalize (pos_eq_refl _ _ h);congruence.
-caseq (form_eq p1 q1);clean.
+case_eq (form_eq p1 q1);clean.
intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
-caseq (form_eq p1 q1);clean.
+case_eq (form_eq p1 q1);clean.
intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
-caseq (form_eq p1 q1);clean.
+case_eq (form_eq p1 q1);clean.
intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
Qed.
-Implicit Arguments form_eq_refl [p q].
+Arguments form_eq_refl [p q] _.
Section with_env.
@@ -165,7 +161,7 @@ intros hyps F p g e; apply project_In.
apply get_In with p;assumption.
Qed.
-Implicit Arguments project [hyps p g].
+Arguments project [hyps] F [p g] _.
Inductive proof:Set :=
Ax : positive -> proof
@@ -263,7 +259,7 @@ induction p;intros hyps F gl.
(* cas Axiom *)
Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
intros f nth_f e;rewrite <- (form_eq_refl e).
apply project with p;trivial.
@@ -276,10 +272,10 @@ apply IHp;try constructor;trivial.
(* Cas Arrow_Elim *)
Focus 1.
-simpl check_proof;caseq (get p hyps);clean.
-intros f ef;caseq (get p0 hyps);clean.
+simpl check_proof;case_eq (get p hyps);clean.
+intros f ef;case_eq (get p0 hyps);clean.
intros f0 ef0;destruct f0;clean.
-caseq (form_eq f f0_1);clean.
+case_eq (form_eq f f0_1);clean.
simpl;intros e check_p1.
generalize (project F ef) (project F ef0)
(IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1);
@@ -291,10 +287,10 @@ auto.
(* cas Arrow_Destruct *)
Focus 1.
-simpl;caseq (get p1 hyps);clean.
+simpl;case_eq (get p1 hyps);clean.
intros f ef;destruct f;clean.
destruct f1;clean.
-caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean.
+case_eq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean.
intros check_p1 check_p2.
generalize (project F ef)
(IHp1 (hyps \ f1_2 =>> f2 \ f1_1)
@@ -305,7 +301,7 @@ simpl;apply compose3;auto.
(* Cas False_Elim *)
Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
intros f ef;destruct f;clean.
intros _; generalize (project F ef).
apply compose1;apply False_ind.
@@ -313,13 +309,13 @@ apply compose1;apply False_ind.
(* Cas And_Intro *)
Focus 1.
simpl;destruct gl;clean.
-caseq (check_proof hyps gl1 p1);clean.
+case_eq (check_proof hyps gl1 p1);clean.
intros Hp1 Hp2;generalize (IHp1 hyps F gl1 Hp1) (IHp2 hyps F gl2 Hp2).
apply compose2 ;simpl;auto.
(* cas And_Elim *)
Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
intros f ef;destruct f;clean.
intro check_p;generalize (project F ef)
(IHp (hyps \ f1 \ f2) (F_push f2 (hyps \ f1) (F_push f1 hyps F)) gl check_p).
@@ -327,7 +323,7 @@ simpl;apply compose2;intros [h1 h2];auto.
(* cas And_Destruct *)
Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
intros f ef;destruct f;clean.
destruct f1;clean.
intro H;generalize (project F ef)
@@ -349,9 +345,9 @@ apply compose1;simpl;auto.
(* cas Or_elim *)
Focus 1.
-simpl;caseq (get p1 hyps);clean.
+simpl;case_eq (get p1 hyps);clean.
intros f ef;destruct f;clean.
-caseq (check_proof (hyps \ f1) gl p2);clean.
+case_eq (check_proof (hyps \ f1) gl p2);clean.
intros check_p1 check_p2;generalize (project F ef)
(IHp1 (hyps \ f1) (F_push f1 hyps F) gl check_p1)
(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2);
@@ -359,7 +355,7 @@ simpl;apply compose3;simpl;intro h;destruct h;auto.
(* cas Or_Destruct *)
Focus 1.
-simpl;caseq (get p hyps);clean.
+simpl;case_eq (get p hyps);clean.
intros f ef;destruct f;clean.
destruct f1;clean.
intro check_p0;generalize (project F ef)
@@ -370,7 +366,7 @@ apply compose2;auto.
(* cas Cut *)
Focus 1.
-simpl;caseq (check_proof hyps f p1);clean.
+simpl;case_eq (check_proof hyps f p1);clean.
intros check_p1 check_p2;
generalize (IHp1 hyps F f check_p1)
(IHp2 (hyps\f) (F_push f hyps F) gl check_p2);
@@ -378,7 +374,7 @@ simpl; apply compose2;auto.
Qed.
Theorem Reflect: forall gl prf, if check_proof empty gl prf then [[gl]] else True.
-intros gl prf;caseq (check_proof empty gl prf);intro check_prf.
+intros gl prf;case_eq (check_proof empty gl prf);intro check_prf.
change (interp_ctx empty F_empty [[gl]]) ;
apply interp_proof with prf;assumption.
trivial.
diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
index 552f23f6..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: g_rtauto.ml4 14641 2011-11-06 11:59:10Z herbelin $*)
-
(*i camlp4deps: "parsing/grammar.cma" i*)
TACTIC EXTEND rtauto
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 500138cf..d773b153 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: proof_search.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Term
open Util
open Goptions
@@ -49,6 +47,7 @@ let pruning = ref true
let opt_pruning=
{optsync=true;
+ optdepr=false;
optname="Rtauto Pruning";
optkey=["Rtauto";"Pruning"];
optread=(fun () -> !pruning);
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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: proof_search.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
type form=
Atom of int
| Arrow of form * form
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 20b4c8f6..4a9a0e47 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -1,18 +1,15 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: refl_tauto.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
module Search = Explore.Make(Proof_search)
open Util
open Term
-open Termops
open Names
open Evd
open Tacmach
@@ -39,7 +36,7 @@ let l_true_equals_true =
[|data_constant "bool";data_constant "true"|]))
let pos_constant =
- Coqlib.gen_constant "refl_tauto" ["NArith";"BinPos"]
+ Coqlib.gen_constant "refl_tauto" ["Numbers";"BinNums"]
let l_xI = lazy (pos_constant "xI")
let l_xO = lazy (pos_constant "xO")
@@ -104,7 +101,7 @@ let rec make_form atom_env gls term =
let cciterm=special_whd gls term in
match kind_of_term cciterm with
Prod(_,a,b) ->
- if not (dependent (mkRel 1) b) &&
+ if not (Termops.dependent (mkRel 1) b) &&
Retyping.get_sort_family_of
(pf_env gls) (Tacmach.project gls) a = InProp
then
@@ -144,7 +141,7 @@ let rec make_hyps atom_env gls lenv = function
| (id,None,typ)::rest ->
let hrec=
make_hyps atom_env gls (typ::lenv) rest in
- if List.exists (dependent (mkVar id)) lenv ||
+ if List.exists (Termops.dependent (mkVar id)) lenv ||
(Retyping.get_sort_family_of
(pf_env gls) (Tacmach.project gls) typ <> InProp)
then
@@ -244,6 +241,7 @@ let verbose = ref false
let opt_verbose=
{optsync=true;
+ optdepr=false;
optname="Rtauto Verbose";
optkey=["Rtauto";"Verbose"];
optread=(fun () -> !verbose);
@@ -255,6 +253,7 @@ let check = ref false
let opt_check=
{optsync=true;
+ optdepr=false;
optname="Rtauto Check";
optkey=["Rtauto";"Check"];
optread=(fun () -> !check);
@@ -267,14 +266,13 @@ open Pp
let rtauto_tac gls=
Coqlib.check_required_library ["Coq";"rtauto";"Rtauto"];
let gamma={next=1;env=[]} in
- let gl=gls.it.evar_concl in
+ let gl=pf_concl gls in
let _=
if Retyping.get_sort_family_of
(pf_env gls) (Tacmach.project gls) gl <> InProp
then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in
let glf=make_form gamma gls gl in
- let hyps=make_hyps gamma gls [gl]
- (Environ.named_context_of_val gls.it.evar_hyps) in
+ let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in
let formula=
List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in
let search_fun =
diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
index 085a45a5..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: refl_tauto.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* raises Not_found if no proof is found *)
type atom_env=
diff --git a/plugins/setoid_ring/Algebra_syntax.v b/plugins/setoid_ring/Algebra_syntax.v
new file mode 100644
index 00000000..e896554e
--- /dev/null
+++ b/plugins/setoid_ring/Algebra_syntax.v
@@ -0,0 +1,25 @@
+
+Class Zero (A : Type) := zero : A.
+Notation "0" := zero.
+Class One (A : Type) := one : A.
+Notation "1" := one.
+Class Addition (A : Type) := addition : A -> A -> A.
+Notation "_+_" := addition.
+Notation "x + y" := (addition x y).
+Class Multiplication {A B : Type} := multiplication : A -> B -> B.
+Notation "_*_" := multiplication.
+Notation "x * y" := (multiplication x y).
+Class Subtraction (A : Type) := subtraction : A -> A -> A.
+Notation "_-_" := subtraction.
+Notation "x - y" := (subtraction x y).
+Class Opposite (A : Type) := opposite : A -> A.
+Notation "-_" := opposite.
+Notation "- x" := (opposite(x)).
+Class Equality {A : Type}:= equality : A -> A -> Prop.
+Notation "_==_" := equality.
+Notation "x == y" := (equality x y) (at level 70, no associativity).
+Class Bracket (A B: Type):= bracket : A -> B.
+Notation "[ x ]" := (bracket(x)).
+Class Power {A B: Type} := power : A -> B -> A.
+Notation "x ^ y" := (power x y).
+
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index 6998b656..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -21,12 +21,12 @@ Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat).
Lemma nat_morph_N :
semi_morph 0 1 plus mult (eq (A:=nat))
- 0%N 1%N Nplus Nmult Neq_bool nat_of_N.
+ 0%N 1%N N.add N.mul N.eqb nat_of_N.
Proof.
constructor;trivial.
exact nat_of_Nplus.
exact nat_of_Nmult.
- intros x y H;rewrite (Neq_bool_ok _ _ H);trivial.
+ intros x y H. apply N.eqb_eq in H. now subst.
Qed.
Ltac natcst t :=
diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v
index 905625cc..7128280a 100644
--- a/plugins/setoid_ring/BinList.v
+++ b/plugins/setoid_ring/BinList.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Cring.v b/plugins/setoid_ring/Cring.v
new file mode 100644
index 00000000..3d6e53fc
--- /dev/null
+++ b/plugins/setoid_ring/Cring.v
@@ -0,0 +1,272 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Export List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Export Morphisms Setoid Bool.
+Require Import ZArith_base.
+Require Export Algebra_syntax.
+Require Export Ncring.
+Require Export Ncring_initial.
+Require Export Ncring_tac.
+
+Class Cring {R:Type}`{Rr:Ring R} :=
+ cring_mul_comm: forall x y:R, x * y == y * x.
+
+Ltac reify_goal lvar lexpr lterm:=
+ (*idtac lvar; idtac lexpr; idtac lterm;*)
+ match lexpr with
+ nil => idtac
+ | ?e1::?e2::_ =>
+ match goal with
+ |- (?op ?u1 ?u2) =>
+ change (op
+ (@Ring_polynom.PEeval
+ _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
+ (@Ring_theory.pow_N _ 1 multiplication) lvar e1)
+ (@Ring_polynom.PEeval
+ _ zero _+_ _*_ _-_ -_ Z Ncring_initial.gen_phiZ N (fun n:N => n)
+ (@Ring_theory.pow_N _ 1 multiplication) lvar e2))
+ end
+ end.
+
+Section cring.
+Context {R:Type}`{Rr:Cring R}.
+
+Lemma cring_eq_ext: ring_eq_ext _+_ _*_ -_ _==_.
+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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v
index eee89e61..da42bbd9 100644
--- a/plugins/setoid_ring/Field_tac.v
+++ b/plugins/setoid_ring/Field_tac.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v
index ccdec656..40138526 100644
--- a/plugins/setoid_ring/Field_theory.v
+++ b/plugins/setoid_ring/Field_theory.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -96,7 +96,7 @@ Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth)
(ARsub_def ARth) .
(* Power coefficients *)
- Variable Cpow : Set.
+ Variable Cpow : Type.
Variable Cp_phi : N -> Cpow.
Variable rpow : R -> Cpow -> R.
Variable pow_th : power_theory rI rmul req Cp_phi rpow.
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -13,7 +13,6 @@ Require Import BinNat.
Require Import Setoid.
Require Import Ring_theory.
Require Import Ring_polynom.
-Require Import ZOdiv_def.
Import List.
Set Implicit Arguments.
@@ -170,48 +169,28 @@ Section ZMORPHISM.
rewrite H1;rrefl.
Qed.
- Lemma gen_phiZ1_add_pos_neg : forall x y,
- gen_phiZ1
- match (x ?= y)%positive Eq with
- | Eq => Z0
- | Lt => Zneg (y - x)
- | Gt => Zpos (x - y)
- end
- == gen_phiPOS1 x + -gen_phiPOS1 y.
+ Lemma gen_phiZ1_pos_sub : forall x y,
+ gen_phiZ1 (Z.pos_sub x y) == gen_phiPOS1 x + -gen_phiPOS1 y.
Proof.
intros x y.
- assert (H:= (Pcompare_Eq_eq x y)); assert (H0 := Pminus_mask_Gt x y).
- generalize (Pminus_mask_Gt y x).
- replace Eq with (CompOpp Eq);[intro H1;simpl|trivial].
- rewrite <- Pcompare_antisym in H1.
- destruct ((x ?= y)%positive Eq).
- rewrite H;trivial. rewrite (Ropp_def Rth);rrefl.
- destruct H1 as [h [Heq1 [Heq2 Hor]]];trivial.
- unfold Pminus; rewrite Heq1;rewrite <- Heq2.
+ rewrite Z.pos_sub_spec.
+ case Pos.compare_spec; intros H; simpl.
+ rewrite H. rewrite (Ropp_def Rth);rrefl.
+ rewrite <- (Pos.sub_add y x H) at 2. rewrite Pos.add_comm.
rewrite (ARgen_phiPOS_add ARth);simpl;norm.
rewrite (Ropp_def Rth);norm.
- destruct H0 as [h [Heq1 [Heq2 Hor]]];trivial.
- unfold Pminus; rewrite Heq1;rewrite <- Heq2.
+ rewrite <- (Pos.sub_add x y H) at 2.
rewrite (ARgen_phiPOS_add ARth);simpl;norm.
- add_push (gen_phiPOS1 h);rewrite (Ropp_def Rth); norm.
+ add_push (gen_phiPOS1 (x-y));rewrite (Ropp_def Rth); norm.
Qed.
- Lemma match_compOpp : forall x (B:Type) (be bl bg:B),
- match CompOpp x with Eq => be | Lt => bl | Gt => bg end
- = match x with Eq => be | Lt => bg | Gt => bl end.
- Proof. destruct x;simpl;intros;trivial. Qed.
-
Lemma gen_phiZ_add : forall x y, [x + y] == [x] + [y].
Proof.
intros x y; repeat rewrite same_genZ; generalize x y;clear x y.
- induction x;destruct y;simpl;norm.
+ destruct x, y; simpl; norm.
apply (ARgen_phiPOS_add ARth).
- apply gen_phiZ1_add_pos_neg.
- replace Eq with (CompOpp Eq);trivial.
- rewrite <- Pcompare_antisym;simpl.
- rewrite match_compOpp.
- rewrite (Radd_comm Rth).
- apply gen_phiZ1_add_pos_neg.
+ apply gen_phiZ1_pos_sub.
+ rewrite gen_phiZ1_pos_sub. apply (Radd_comm Rth).
rewrite (ARgen_phiPOS_add ARth); norm.
Qed.
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -18,4 +18,4 @@ Ltac Ncst t :=
| _ => constr:NotConstant
end.
-Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]).
+Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]).
diff --git a/plugins/setoid_ring/Ncring.v b/plugins/setoid_ring/Ncring.v
new file mode 100644
index 00000000..9a30fa47
--- /dev/null
+++ b/plugins/setoid_ring/Ncring.v
@@ -0,0 +1,305 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* non commutative rings *)
+
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinNat.
+Require Export Morphisms Setoid Bool.
+Require Export ZArith_base.
+Require Export Algebra_syntax.
+
+Set Implicit Arguments.
+
+Class Ring_ops(T:Type)
+ {ring0:T}
+ {ring1:T}
+ {add:T->T->T}
+ {mul:T->T->T}
+ {sub:T->T->T}
+ {opp:T->T}
+ {ring_eq:T->T->Prop}.
+
+Instance zero_notation(T:Type)`{Ring_ops T}:Zero T:= ring0.
+Instance one_notation(T:Type)`{Ring_ops T}:One T:= ring1.
+Instance add_notation(T:Type)`{Ring_ops T}:Addition T:= add.
+Instance mul_notation(T:Type)`{Ring_ops T}:@Multiplication T T:= mul.
+Instance sub_notation(T:Type)`{Ring_ops T}:Subtraction T:= sub.
+Instance opp_notation(T:Type)`{Ring_ops T}:Opposite T:= opp.
+Instance eq_notation(T:Type)`{Ring_ops T}:@Equality T:= ring_eq.
+
+Class Ring `{Ro:Ring_ops}:={
+ ring_setoid: Equivalence _==_;
+ ring_plus_comp: Proper (_==_ ==> _==_ ==>_==_) _+_;
+ ring_mult_comp: Proper (_==_ ==> _==_ ==>_==_) _*_;
+ ring_sub_comp: Proper (_==_ ==> _==_ ==>_==_) _-_;
+ ring_opp_comp: Proper (_==_==>_==_) -_;
+ ring_add_0_l : forall x, 0 + x == x;
+ ring_add_comm : forall x y, x + y == y + x;
+ ring_add_assoc : forall x y z, x + (y + z) == (x + y) + z;
+ ring_mul_1_l : forall x, 1 * x == x;
+ ring_mul_1_r : forall x, x * 1 == x;
+ ring_mul_assoc : forall x y z, x * (y * z) == (x * y) * z;
+ ring_distr_l : forall x y z, (x + y) * z == x * z + y * z;
+ ring_distr_r : forall x y z, z * ( x + y) == z * x + z * y;
+ ring_sub_def : forall x y, x - y == x + -y;
+ ring_opp_def : forall x, x + -x == 0
+}.
+(* inutile! je sais plus pourquoi j'ai mis ca...
+Instance ring_Ring_ops(R:Type)`{Ring R}
+ :@Ring_ops R 0 1 addition multiplication subtraction opposite equality.
+*)
+Existing Instance ring_setoid.
+Existing Instance ring_plus_comp.
+Existing Instance ring_mult_comp.
+Existing Instance ring_sub_comp.
+Existing Instance ring_opp_comp.
+
+Section Ring_power.
+
+Context {R:Type}`{Ring R}.
+
+ Fixpoint pow_pos (x:R) (i:positive) {struct i}: R :=
+ match i with
+ | xH => x
+ | xO i => let p := pow_pos x i in p * p
+ | xI i => let p := pow_pos x i in x * (p * p)
+ end.
+
+ Definition pow_N (x:R) (p:N) :=
+ match p with
+ | N0 => 1
+ | Npos p => pow_pos x p
+ end.
+
+End Ring_power.
+
+Definition ZN(x:Z):=
+ match x with
+ Z0 => N0
+ |Zpos p | Zneg p => Npos p
+end.
+
+Instance power_ring {R:Type}`{Ring R} : Power:=
+ {power x y := pow_N x (ZN y)}.
+
+(** Interpretation morphisms definition*)
+
+Class Ring_morphism (C R:Type)`{Cr:Ring C} `{Rr:Ring R}`{Rh:Bracket C R}:= {
+ ring_morphism0 : [0] == 0;
+ ring_morphism1 : [1] == 1;
+ ring_morphism_add : forall x y, [x + y] == [x] + [y];
+ ring_morphism_sub : forall x y, [x - y] == [x] - [y];
+ ring_morphism_mul : forall x y, [x * y] == [x] * [y];
+ ring_morphism_opp : forall x, [-x] == -[x];
+ ring_morphism_eq : forall x y, x == y -> [x] == [y]}.
+
+Section Ring.
+
+Context {R:Type}`{Rr:Ring R}.
+
+(* Powers *)
+
+ Lemma pow_pos_comm : forall x j, x * pow_pos x j == pow_pos x j * x.
+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 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Import ZArith_base.
+Require Import Zpow_def.
+Require Import BinInt.
+Require Import BinNat.
+Require Import Setoid.
+Require Import BinList.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Import Setoid.
+Require Export Ncring.
+Require Export Ncring_polynom.
+Import List.
+
+Set Implicit Arguments.
+
+(* An object to return when an expression is not recognized as a constant *)
+Definition NotConstant := false.
+
+(** Z is a ring and a setoid*)
+
+Lemma Zsth : Setoid_Theory Z (@eq Z).
+constructor;red;intros;subst;trivial.
+Qed.
+
+Instance Zops:@Ring_ops Z 0%Z 1%Z Zplus Zmult Zminus Zopp (@eq Z).
+
+Instance Zr: (@Ring _ _ _ _ _ _ _ _ Zops).
+constructor;
+try (try apply Zsth;
+ try (unfold respectful, Proper; unfold equality; unfold eq_notation in *;
+ intros; try rewrite H; try rewrite H0; reflexivity)).
+ exact Zplus_comm. exact Zplus_assoc.
+ exact Zmult_1_l. exact Zmult_1_r. exact Zmult_assoc.
+ exact Zmult_plus_distr_l. intros; apply Zmult_plus_distr_r. exact Zminus_diag.
+Defined.
+
+(*Instance ZEquality: @Equality Z:= (@eq Z).*)
+
+(** Two generic morphisms from Z to (abrbitrary) rings, *)
+(**second one is more convenient for proofs but they are ext. equal*)
+Section ZMORPHISM.
+Context {R:Type}`{Ring R}.
+
+ Ltac rrefl := reflexivity.
+
+ Fixpoint gen_phiPOS1 (p:positive) : R :=
+ match p with
+ | xH => 1
+ | xO p => (1 + 1) * (gen_phiPOS1 p)
+ | xI p => 1 + ((1 + 1) * (gen_phiPOS1 p))
+ end.
+
+ Fixpoint gen_phiPOS (p:positive) : R :=
+ match p with
+ | xH => 1
+ | xO xH => (1 + 1)
+ | xO p => (1 + 1) * (gen_phiPOS p)
+ | xI xH => 1 + (1 +1)
+ | xI p => 1 + ((1 + 1) * (gen_phiPOS p))
+ end.
+
+ Definition gen_phiZ1 z :=
+ match z with
+ | Zpos p => gen_phiPOS1 p
+ | Z0 => 0
+ | Zneg p => -(gen_phiPOS1 p)
+ end.
+
+ Definition gen_phiZ z :=
+ match z with
+ | Zpos p => gen_phiPOS p
+ | Z0 => 0
+ | Zneg p => -(gen_phiPOS p)
+ end.
+ Notation "[ x ]" := (gen_phiZ x).
+
+ Definition get_signZ z :=
+ match z with
+ | Zneg p => Some (Zpos p)
+ | _ => None
+ end.
+
+ Ltac norm := gen_rewrite.
+ Ltac add_push := Ncring.gen_add_push.
+Ltac rsimpl := simpl.
+
+ Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x.
+ Proof.
+ induction x;rsimpl.
+ rewrite IHx. destruct x;simpl;norm.
+ rewrite IHx;destruct x;simpl;norm.
+ reflexivity.
+ Qed.
+
+ Lemma ARgen_phiPOS_Psucc : forall x,
+ gen_phiPOS1 (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 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* A <X1,...,Xn>: non commutative polynomials on a commutative ring A *)
+
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinList.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Export Ring_polynom. (* n'utilise que PExpr *)
+Require Export Ncring.
+
+Section MakeRingPol.
+
+Context (C R:Type) `{Rh:Ring_morphism C R}.
+
+Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x.
+
+ Ltac rsimpl := repeat (gen_rewrite || rewrite phiCR_comm).
+ Ltac add_push := gen_add_push .
+
+(* Definition of non commutative multivariable polynomials
+ with coefficients in C :
+ *)
+
+ Inductive Pol : Type :=
+ | Pc : C -> Pol
+ | PX : Pol -> positive -> positive -> Pol -> Pol.
+ (* PX P i n Q represents P * X_i^n + Q *)
+Definition cO:C . exact ring0. Defined.
+Definition cI:C . exact ring1. Defined.
+
+ Definition P0 := Pc 0.
+ Definition P1 := Pc 1.
+
+Variable Ceqb:C->C->bool.
+Class Equalityb (A : Type):= {equalityb : A -> A -> bool}.
+Notation "x =? y" := (equalityb x y) (at level 70, no associativity).
+Variable Ceqb_eq: forall x y:C, Ceqb x y = true -> (x == y).
+
+Instance equalityb_coef : Equalityb C :=
+ {equalityb x y := Ceqb x y}.
+
+ Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
+ match P, P' with
+ | Pc c, Pc c' => c =? c'
+ | PX P i n Q, PX P' i' n' Q' =>
+ match 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 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Import List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Export Morphisms Setoid Bool.
+Require Import ZArith.
+Require Import Algebra_syntax.
+Require Export Ncring.
+Require Import Ncring_polynom.
+Require Import Ncring_initial.
+
+
+Set Implicit Arguments.
+
+Class nth (R:Type) (t:R) (l:list R) (i:nat).
+
+Instance Ifind0 (R:Type) (t:R) l
+ : nth t(t::l) 0.
+
+Instance IfindS (R:Type) (t2 t1:R) l i
+ {_:nth t1 l i}
+ : nth t1 (t2::l) (S i) | 1.
+
+Class closed (T:Type) (l:list T).
+
+Instance Iclosed_nil T
+ : closed (T:=T) nil.
+
+Instance Iclosed_cons T t (l:list T)
+ {_:closed l}
+ : closed (t::l).
+
+Class reify (R:Type)`{Rr:Ring (T:=R)} (e:PExpr Z) (lvar:list R) (t:R).
+
+Instance reify_zero (R:Type) lvar op
+ `{Ring (T:=R)(ring0:=op)}
+ : reify (ring0:=op)(PEc 0%Z) lvar op.
+
+Instance reify_one (R:Type) lvar op
+ `{Ring (T:=R)(ring1:=op)}
+ : reify (ring1:=op) (PEc 1%Z) lvar op.
+
+Instance reifyZ0 (R:Type) lvar
+ `{Ring (T:=R)}
+ : reify (PEc Z0) lvar Z0|11.
+
+Instance reifyZpos (R:Type) lvar (p:positive)
+ `{Ring (T:=R)}
+ : reify (PEc (Zpos p)) lvar (Zpos p)|11.
+
+Instance reifyZneg (R:Type) lvar (p:positive)
+ `{Ring (T:=R)}
+ : reify (PEc (Zneg p)) lvar (Zneg p)|11.
+
+Instance reify_add (R:Type)
+ e1 lvar t1 e2 t2 op
+ `{Ring (T:=R)(add:=op)}
+ {_:reify (add:=op) e1 lvar t1}
+ {_:reify (add:=op) e2 lvar t2}
+ : reify (add:=op) (PEadd e1 e2) lvar (op t1 t2).
+
+Instance reify_mul (R:Type)
+ e1 lvar t1 e2 t2 op
+ `{Ring (T:=R)(mul:=op)}
+ {_:reify (mul:=op) e1 lvar t1}
+ {_:reify (mul:=op) e2 lvar t2}
+ : reify (mul:=op) (PEmul e1 e2) lvar (op t1 t2)|10.
+
+Instance reify_mul_ext (R:Type) `{Ring R}
+ lvar z e2 t2
+ `{Ring (T:=R)}
+ {_:reify e2 lvar t2}
+ : reify (PEmul (PEc z) e2) lvar
+ (@multiplication Z _ _ z t2)|9.
+
+Instance reify_sub (R:Type)
+ e1 lvar t1 e2 t2 op
+ `{Ring (T:=R)(sub:=op)}
+ {_:reify (sub:=op) e1 lvar t1}
+ {_:reify (sub:=op) e2 lvar t2}
+ : reify (sub:=op) (PEsub e1 e2) lvar (op t1 t2).
+
+Instance reify_opp (R:Type)
+ e1 lvar t1 op
+ `{Ring (T:=R)(opp:=op)}
+ {_:reify (opp:=op) e1 lvar t1}
+ : reify (opp:=op) (PEopp e1) lvar (op t1).
+
+Instance reify_pow (R:Type) `{Ring R}
+ e1 lvar t1 n
+ `{Ring (T:=R)}
+ {_:reify e1 lvar t1}
+ : reify (PEpow e1 n) lvar (pow_N t1 n)|1.
+
+Instance reify_var (R:Type) t lvar i
+ `{nth R t lvar i}
+ `{Rr: Ring (T:=R)}
+ : reify (Rr:= Rr) (PEX Z (P_of_succ_nat i))lvar t
+ | 100.
+
+Class reifylist (R:Type)`{Rr:Ring (T:=R)} (lexpr:list (PExpr Z)) (lvar:list R)
+ (lterm:list R).
+
+Instance reify_nil (R:Type) lvar
+ `{Rr: Ring (T:=R)}
+ : reifylist (Rr:= Rr) nil lvar (@nil R).
+
+Instance reify_cons (R:Type) e1 lvar t1 lexpr2 lterm2
+ `{Rr: Ring (T:=R)}
+ {_:reify (Rr:= Rr) e1 lvar t1}
+ {_:reifylist (Rr:= Rr) lexpr2 lvar lterm2}
+ : reifylist (Rr:= Rr) (e1::lexpr2) lvar (t1::lterm2).
+
+Definition list_reifyl (R:Type) lexpr lvar lterm
+ `{Rr: Ring (T:=R)}
+ {_:reifylist (Rr:= Rr) lexpr lvar lterm}
+ `{closed (T:=R) lvar} := (lvar,lexpr).
+
+Unset Implicit Arguments.
+
+
+Ltac lterm_goal g :=
+ match g with
+ | ?t1 == ?t2 => constr:(t1::t2::nil)
+ | ?t1 = ?t2 => constr:(t1::t2::nil)
+ | (_ ?t1 ?t2) => constr:(t1::t2::nil)
+ end.
+
+Lemma Zeqb_ok: forall x y : Z, Zeq_bool x y = true -> x == y.
+ intros x y H. rewrite (Zeq_bool_eq x y H). reflexivity. Qed.
+
+Ltac reify_goal lvar lexpr lterm:=
+ (*idtac lvar; idtac lexpr; idtac lterm;*)
+ match lexpr with
+ nil => idtac
+ | ?e1::?e2::_ =>
+ match goal with
+ |- (?op ?u1 ?u2) =>
+ change (op
+ (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N
+ (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _)
+ lvar e1)
+ (@PEeval Z _ _ _ _ _ _ _ _ _ (@gen_phiZ _ _ _ _ _ _ _ _ _) N
+ (fun n:N => n) (@pow_N _ _ _ _ _ _ _ _ _)
+ lvar e2))
+ end
+ end.
+
+Lemma comm: forall (R:Type)`{Ring R}(c : Z) (x : R),
+ x * (gen_phiZ c) == (gen_phiZ c) * x.
+induction c. intros. simpl. gen_rewrite. simpl. intros.
+rewrite <- same_gen.
+induction p. simpl. gen_rewrite. rewrite IHp. reflexivity.
+simpl. gen_rewrite. rewrite IHp. reflexivity.
+simpl. gen_rewrite.
+simpl. intros. rewrite <- same_gen.
+induction p. simpl. generalize IHp. clear IHp.
+gen_rewrite. intro IHp. rewrite IHp. reflexivity.
+simpl. generalize IHp. clear IHp.
+gen_rewrite. intro IHp. rewrite IHp. reflexivity.
+simpl. gen_rewrite. Qed.
+
+Ltac ring_gen :=
+ match goal with
+ |- ?g => let lterm := lterm_goal g in
+ match eval red in (list_reifyl (lterm:=lterm)) with
+ | (?fv, ?lexpr) =>
+ (*idtac "variables:";idtac fv;
+ idtac "terms:"; idtac lterm;
+ idtac "reifications:"; idtac lexpr; *)
+ reify_goal fv lexpr lterm;
+ match goal with
+ |- ?g =>
+ apply (@ring_correct Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
+ (@gen_phiZ _ _ _ _ _ _ _ _ _) _
+ (@comm _ _ _ _ _ _ _ _ _ _) Zeq_bool Zeqb_ok N (fun n:N => n)
+ (@pow_N _ _ _ _ _ _ _ _ _));
+ [apply mkpow_th; reflexivity
+ |vm_compute; reflexivity]
+ end
+ end
+ end.
+
+Ltac non_commutative_ring:=
+ intros;
+ ring_gen.
+
+(* simplification *)
+
+Ltac ring_simplify_aux lterm fv lexpr hyp :=
+ match lterm with
+ | ?t0::?lterm =>
+ match lexpr with
+ | ?e::?le => (* e:PExpr Z est la réification de t0:R *)
+ let t := constr:(@Ncring_polynom.norm_subst
+ Z 0%Z 1%Z 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v
index 9bc95a7f..6d4360d6 100644
--- a/plugins/setoid_ring/Ring_base.v
+++ b/plugins/setoid_ring/Ring_base.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
index d33a095f..b722a31b 100644
--- a/plugins/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -38,7 +38,7 @@ Section MakeRingPol.
cO cI cadd cmul csub copp ceqb phi.
(* Power coefficients *)
- Variable Cpow : Set.
+ Variable Cpow : Type.
Variable Cp_phi : N -> Cpow.
Variable rpow : R -> Cpow -> R.
Variable pow_th : power_theory rI rmul req Cp_phi rpow.
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -229,7 +229,7 @@ Section DEFINITIONS.
(** Specification of the power function *)
Section POWER.
- Variable Cpow : Set.
+ Variable Cpow : Type.
Variable Cp_phi : N -> 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -27,11 +27,7 @@ Ltac isZpow_coef t :=
| _ => constr:false
end.
-Definition N_of_Z x :=
- match x with
- | Zpos p => Npos p
- | _ => N0
- end.
+Notation N_of_Z := Z.to_N (only parsing).
Ltac Zpow_tac t :=
match isZpow_coef t with
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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -8,8 +8,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(*i $Id: newring.ml4 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Pp
open Util
open Names
@@ -18,8 +16,7 @@ open Closure
open Environ
open Libnames
open Tactics
-open Rawterm
-open Termops
+open Glob_term
open Tacticals
open Tacexpr
open Pcoq
@@ -87,7 +84,7 @@ let interp_map l c =
with Not_found -> None
let interp_map l t =
- try Some(List.assoc t l) with Not_found -> None
+ try Some(list_assoc_f eq_constr t l) with Not_found -> None
let protect_maps = ref Stringmap.empty
let add_map s m = protect_maps := Stringmap.add s m !protect_maps
@@ -98,13 +95,13 @@ let lookup_map map =
let protect_red map env sigma c =
kl (create_clos_infos betadeltaiota env)
- (mk_clos_but (lookup_map map c) (Esubst.ESID 0) c);;
+ (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);;
let protect_tac map =
Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
let protect_tac_in map id =
- Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id,InHyp));;
+ Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Termops.InHyp));;
TACTIC EXTEND protect_fv
@@ -144,7 +141,7 @@ let closed_term_ast l =
let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in
TacFun([Some(id_of_string"t")],
TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
- [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None);
+ [Genarg.in_gen Genarg.globwit_constr (GVar(dummy_loc,id_of_string"t"),None);
Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l])))
(*
let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term"
@@ -161,18 +158,18 @@ let ty c = Typing.type_of (Global.env()) Evd.empty c
let decl_constant na c =
mkConst(declare_constant (id_of_string na) (DefinitionEntry
{ const_entry_body = c;
+ const_entry_secctx = None;
const_entry_type = None;
- const_entry_opaque = true;
- const_entry_boxed = true},
+ const_entry_opaque = true },
IsProof Lemma))
(* Calling a global tactic *)
let ltac_call tac (args:glob_tactic_arg list) =
- TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args))
+ TacArg(dummy_loc,TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force tac),args))
(* Calling a locally bound tactic *)
let ltac_lcall tac args =
- TacArg(TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args))
+ TacArg(dummy_loc,TacCall(dummy_loc, ArgVar(dummy_loc, id_of_string tac),args))
let ltac_letin (x, e1) e2 =
TacLetIn(false,[(dummy_loc,id_of_string x),e1],e2)
@@ -188,8 +185,10 @@ let ltac_record flds =
let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
let dummy_goal env =
- {Evd.it = Evd.make_evar (named_context_val env) mkProp;
- Evd.sigma = Evd.empty}
+ let (gl,_,sigma) =
+ Goal.V82.mk_goal Evd.empty (named_context_val env) mkProp Store.empty in
+ {Evd.it = gl;
+ Evd.sigma = sigma}
let exec_tactic env n f args =
let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in
@@ -344,7 +343,7 @@ type ring_info =
ring_pre_tac : glob_tactic_expr;
ring_post_tac : glob_tactic_expr }
-module Cmap = Map.Make(struct type t = constr let compare = compare end)
+module Cmap = Map.Make(struct type t = constr let compare = constr_ord end)
let from_carrier = ref Cmap.empty
let from_relation = ref Cmap.empty
@@ -415,7 +414,7 @@ let subst_th (subst,th) =
let posttac'= subst_tactic subst th.ring_post_tac in
if c' == th.ring_carrier &&
eq' == th.ring_req &&
- set' = th.ring_setoid &&
+ eq_constr set' th.ring_setoid &&
ext' == th.ring_ext &&
morph' == th.ring_morph &&
th' == th.ring_th &&
@@ -440,7 +439,7 @@ let subst_th (subst,th) =
ring_post_tac = posttac' }
-let (theory_to_obj, obj_to_theory) =
+let theory_to_obj : ring_info -> obj =
let cache_th (name,th) = add_entry name th in
declare_object
{(default_object "tactic-new-ring-theory") with
@@ -576,13 +575,13 @@ let dest_ring env sigma th_spec =
let th_typ = Retyping.get_type_of env sigma th_spec in
match kind_of_term th_typ with
App(f,[|r;zero;one;add;mul;sub;opp;req|])
- when f = Lazy.force coq_almost_ring_theory ->
+ when eq_constr f (Lazy.force coq_almost_ring_theory) ->
(None,r,zero,one,add,mul,Some sub,Some opp,req)
| App(f,[|r;zero;one;add;mul;req|])
- when f = Lazy.force coq_semi_ring_theory ->
+ when eq_constr f (Lazy.force coq_semi_ring_theory) ->
(Some true,r,zero,one,add,mul,None,None,req)
| App(f,[|r;zero;one;add;mul;sub;opp;req|])
- when f = Lazy.force coq_ring_theory ->
+ when eq_constr f (Lazy.force coq_ring_theory) ->
(Some false,r,zero,one,add,mul,Some sub,Some opp,req)
| _ -> error "bad ring structure"
@@ -592,10 +591,10 @@ let dest_morph env sigma m_spec =
match kind_of_term m_typ with
App(f,[|r;zero;one;add;mul;sub;opp;req;
c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|])
- when f = Lazy.force coq_ring_morph ->
+ when eq_constr f (Lazy.force coq_ring_morph) ->
(c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi)
| App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|])
- when f = Lazy.force coq_semi_morph ->
+ when eq_constr f (Lazy.force coq_semi_morph) ->
(c,czero,cone,cadd,cmul,None,None,ceqb,phi)
| _ -> error "bad morphism structure"
@@ -626,23 +625,23 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
(match rk, opp, kind with
Abstract, None, _ ->
let t = ArgArg(dummy_loc,Lazy.force ltac_inv_morphN) in
- TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul]))
+ TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul]))
| Abstract, Some opp, Some _ ->
let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphZ) in
- TacArg(TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
+ TacArg(dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
| Abstract, Some opp, None ->
let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morphNword) in
TacArg
- (TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
+ (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;add;mul;opp]))
| Computational _,_,_ ->
let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
TacArg
- (TacCall(dummy_loc,t,List.map carg [zero;one;zero;one]))
+ (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;zero;one]))
| Morphism mth,_,_ ->
let (_,czero,cone,_,_,_,_,_,_) = dest_morph env sigma mth in
let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_gen) in
TacArg
- (TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone])))
+ (dummy_loc,TacCall(dummy_loc,t,List.map carg [zero;one;czero;cone])))
let make_hyp env c =
let t = Retyping.get_type_of env Evd.empty c in
@@ -659,7 +658,7 @@ let interp_power env pow =
match pow with
| None ->
let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in
- (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
+ (TacArg(dummy_loc,TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|])
| Some (tac, spec) ->
let tac =
match tac with
@@ -832,7 +831,7 @@ let ring_lookup (f:glob_tactic_expr) lH rl t gl =
TACTIC EXTEND ring_lookup
| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
- [ let (t,lr) = list_sep_last lrt in ring_lookup (fst f) lH lr t]
+ [ let (t,lr) = list_sep_last lrt in ring_lookup f lH lr t]
END
@@ -893,18 +892,18 @@ let dest_field env sigma th_spec =
let th_typ = Retyping.get_type_of env sigma th_spec in
match kind_of_term th_typ with
| App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
- when f = Lazy.force afield_theory ->
+ when eq_constr f (Lazy.force afield_theory) ->
let rth = lapp af_ar
[|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
(None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
| App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
- when f = Lazy.force field_theory ->
+ when eq_constr f (Lazy.force field_theory) ->
let rth =
lapp f_r
[|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
(Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
| App(f,[|r;zero;one;add;mul;div;inv;req|])
- when f = Lazy.force sfield_theory ->
+ when eq_constr f (Lazy.force sfield_theory) ->
let rth = lapp sf_sr
[|r;zero;one;add;mul;div;inv;req;th_spec|] in
(Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
@@ -1016,7 +1015,7 @@ let subst_th (subst,th) =
field_pre_tac = pretac';
field_post_tac = posttac' }
-let (ftheory_to_obj, obj_to_ftheory) =
+let ftheory_to_obj : field_info -> obj =
let cache_th (name,th) = add_field_entry name th in
declare_object
{(default_object "tactic-new-field-theory") with
@@ -1160,5 +1159,5 @@ let field_lookup (f:glob_tactic_expr) lH rl t gl =
TACTIC EXTEND field_lookup
| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
- [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ]
+ [ let (t,l) = list_sep_last lt in field_lookup f lH l t ]
END
diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget
index 6934375b..580df9b5 100644
--- a/plugins/setoid_ring/vo.itarget
+++ b/plugins/setoid_ring/vo.itarget
@@ -13,3 +13,13 @@ Ring_tac.vo
Ring_theory.vo
Ring.vo
ZArithRing.vo
+Algebra_syntax.vo
+Cring.vo
+Ncring.vo
+Ncring_polynom.vo
+Ncring_initial.vo
+Ncring_tac.vo
+Rings_Z.vo
+Rings_R.vo
+Rings_Q.vo
+Integral_domain.vo \ No newline at end of file
diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml
index 3fb6824b..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: eterm.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
open Environ
open Tacmach
open Term
diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4
index ce6d12be..ca1240e5 100644
--- a/plugins/subtac/g_subtac.ml4
+++ b/plugins/subtac/g_subtac.ml4
@@ -1,21 +1,17 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
(*i camlp4deps: "parsing/grammar.cma" i*)
-(*i camlp4use: "pa_extend.cmo" i*)
-
(*
Syntax for the subtac terms and types.
Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
-(* $Id: g_subtac.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Flags
open Util
@@ -37,14 +33,14 @@ module Tactic = Pcoq.Tactic
module SubtacGram =
struct
- let gec s = Gram.Entry.create ("Subtac."^s)
+ let gec s = Gram.entry_create ("Subtac."^s)
(* types *)
- let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.Entry.e = gec "subtac_gallina_loc"
+ let subtac_gallina_loc : Vernacexpr.vernac_expr located Gram.entry = gec "subtac_gallina_loc"
- let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.Entry.e = gec "subtac_withtac"
+ let subtac_withtac : Tacexpr.raw_tactic_expr option Gram.entry = gec "subtac_withtac"
end
-open Rawterm
+open Glob_term
open SubtacGram
open Util
open Pcoq
@@ -94,7 +90,7 @@ VERNAC COMMAND EXTEND Subtac
let try_catch_exn f e =
try f e
- with exn -> 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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: subtac.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
+open Compat
open Global
open Pp
open Util
@@ -27,7 +26,7 @@ open List
open Recordops
open Evarutil
open Pretype_errors
-open Rawterm
+open Glob_term
open Evarconv
open Pattern
open Vernacexpr
@@ -50,7 +49,7 @@ open Tacinterp
open Tacexpr
let solve_tccs_in_type env id isevars evm c typ =
- if not (evm = Evd.empty) then
+ if not (Evd.is_empty evm) then
let stmt_id = Nameops.add_suffix id "_stmt" in
let obls, _, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in
match Subtac_obligations.add_definition stmt_id ~term:c' typ obls with
@@ -89,7 +88,7 @@ let start_proof_and_print env isevars idopt k t hook =
start_proof_com env isevars idopt k t hook;
print_subgoals ()
-let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
+let _ = Detyping.set_detype_anonymous (fun loc n -> GVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
let assumption_message id =
Flags.if_verbose message ((string_of_id id) ^ " is assumed")
@@ -142,12 +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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: subtac_cases.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Cases
open Util
open Names
@@ -23,7 +20,7 @@ open Sign
open Reductionops
open Typeops
open Type_errors
-open Rawterm
+open Glob_term
open Retyping
open Pretype_errors
open Evarutil
@@ -89,7 +86,7 @@ let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
type rhs =
{ rhs_env : env;
avoid_ids : identifier list;
- it : rawconstr;
+ it : glob_constr;
}
type equation =
@@ -158,22 +155,22 @@ let feed_history arg = function
(* This is for non exhaustive error message *)
-let rec rawpattern_of_partial_history args2 = function
+let rec glob_pattern_of_partial_history args2 = function
| Continuation (n, args1, h) ->
let args3 = make_anonymous_patvars (n - (List.length args2)) in
- build_rawpattern (List.rev_append args1 (args2@args3)) h
+ build_glob_pattern (List.rev_append args1 (args2@args3)) h
| Result pl -> pl
-and build_rawpattern args = function
+and build_glob_pattern args = function
| Top -> args
| MakeAlias (AliasLeaf, rh) ->
assert (args = []);
- rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
+ glob_pattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
| MakeAlias (AliasConstructor pci, rh) ->
- rawpattern_of_partial_history
+ glob_pattern_of_partial_history
[PatCstr (dummy_loc, pci, args, Anonymous)] rh
-let complete_history = rawpattern_of_partial_history []
+let complete_history = glob_pattern_of_partial_history []
(* This is to build glued pattern-matching history and alias bodies *)
@@ -237,7 +234,7 @@ type pattern_matching_problem =
mat : matrix;
caseloc : loc;
casestyle: case_style;
- typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
+ typing_function: type_constraint -> env -> glob_constr -> unsafe_judgment }
(*--------------------------------------------------------------------------*
* A few functions to infer the inductive type from the patterns instead of *
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: subtac_cases.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(*i*)
open Util
open Names
@@ -15,7 +13,7 @@ open Term
open Evd
open Environ
open Inductiveops
-open Rawterm
+open Glob_term
open Evarutil
(*i*)
diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml
index 960bf162..c08dd16d 100644
--- a/plugins/subtac/subtac_classes.ml
+++ b/plugins/subtac/subtac_classes.ml
@@ -1,19 +1,16 @@
-(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: subtac_classes.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Pretyping
open Evd
open Environ
open Term
-open Rawterm
+open Glob_term
open Topconstr
open Names
open Libnames
@@ -23,24 +20,28 @@ open Constrintern
open Subtac_command
open Typeclasses
open Typeclasses_errors
-open Termops
open Decl_kinds
open Entries
open Util
module SPretyping = Subtac_pretyping.Pretyping
-let interp_constr_evars_gen evdref env ?(impls=[]) kind c =
+let interp_constr_evars_gen evdref env ?(impls=Constrintern.empty_internalization_env) kind c =
SPretyping.understand_tcc_evars evdref env kind
- (intern_gen (kind=IsType) ~impls ( !evdref) env c)
+ (intern_gen (kind=IsType) ~impls !evdref env c)
-let interp_casted_constr_evars evdref env ?(impls=[]) c typ =
+let interp_casted_constr_evars evdref env ?(impls=Constrintern.empty_internalization_env) c typ =
interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
let interp_context_evars evdref env params =
- Constrintern.interp_context_gen
+ let impls_env, bl = Constrintern.interp_context_gen
(fun env t -> SPretyping.understand_tcc_evars evdref env IsType t)
- (SPretyping.understand_judgment_tcc evdref) !evdref env params
+ (SPretyping.understand_judgment_tcc evdref) !evdref env params in bl
+
+let interp_type_evars_impls ~evdref ?(impls=empty_internalization_env) env c =
+ let c = intern_gen true ~impls !evdref env c in
+ let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in
+ SPretyping.understand_tcc_evars ~fail_evar:false evdref env IsType c, imps
let type_ctx_instance evars env ctx inst subst =
let rec aux (subst, instctx) l = function
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: subtac_classes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(*i*)
open Names
open Decl_kinds
@@ -35,7 +33,7 @@ val new_instance :
?global:bool ->
local_binder list ->
typeclass_constraint ->
- constr_expr ->
+ constr_expr option ->
?generalize:bool ->
int option ->
identifier * Subtac_obligations.progress
diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml
index bdebdf85..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: subtac_coercion.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util
open Names
open Term
@@ -144,7 +141,7 @@ module Coercion = struct
let restargs = lift_args 1
(List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i)))))
in
- let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in
+ let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in
let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in
let eq = mkApp (delayed_force eq_ind, [| eqT; hdx; hdy |]) in
let evar = make_existential loc env isevars eq in
@@ -205,7 +202,7 @@ module Coercion = struct
| Lambda (n, t, t') -> c, t'
(*| Prod (n, t, t') -> t'*)
| Evar (k, args) ->
- let (evs, t) = Evarutil.define_evar_as_lambda !isevars (k,args) in
+ let (evs, t) = Evarutil.define_evar_as_lambda env !isevars (k,args) in
isevars := evs;
let (n, dom, rng) = destLambda t in
let (domk, args) = destEvar dom in
@@ -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<n then Rawterm.PatVar (loc, Anonymous) else pat in
- Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
+ let f i = if i<n then Glob_term.PatVar (loc, Anonymous) else pat in
+ Glob_term.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
pat p
(* raise Not_found if no coercion found *)
@@ -411,10 +408,10 @@ module Coercion = struct
else
let v', t' =
try
- let t2,t1,p = lookup_path_between env ( evd) (t,c1) in
+ let t2,t1,p = lookup_path_between env evd (t,c1) in
match v with
Some v ->
- let j = apply_coercion env ( evd) p
+ let j = apply_coercion env evd p
{uj_val = v; uj_type = t} t2 in
Some j.uj_val, j.uj_type
| None -> None, t
@@ -430,8 +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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: subtac_pretyping.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Global
open Pp
open Util
@@ -26,7 +24,7 @@ open List
open Recordops
open Evarutil
open Pretype_errors
-open Rawterm
+open Glob_term
open Evarconv
open Pattern
@@ -60,13 +58,10 @@ let my_print_rec_info env t =
str "Wf proof: " ++ my_print_constr env t.wf_proof ++ spc () ++
str "Abbreviated Type: " ++ my_print_constr env t.f_type ++ spc () ++
str "Full type: " ++ my_print_constr env t.f_fulltype
-(* trace (str "pretype for " ++ (my_print_rawconstr env c) ++ *)
+(* trace (str "pretype for " ++ (my_print_glob_constr env c) ++ *)
(* str " and tycon "++ my_print_tycon env tycon ++ *)
(* str " in environment: " ++ my_print_env env); *)
-let merge_evms x y =
- Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y
-
let interp env isevars c tycon =
let j = pretype tycon env isevars ([],[]) c in
let _ = isevars := Evarutil.nf_evar_map !isevars in
@@ -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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: subtac_pretyping_F.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Pp
+open Compat
open Util
open Names
open Sign
open Evd
open Term
-open Termops
open Reductionops
open Environ
open Type_errors
@@ -27,7 +24,7 @@ open List
open Recordops
open Evarutil
open Pretype_errors
-open Rawterm
+open Glob_term
open Evarconv
open Pattern
open Pretyping
@@ -78,15 +75,15 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
for i = 0 to lt-1 do
if not (e_cumul env evdref (vdefj.(i)).uj_type
(lift lt lar.(i))) then
- error_ill_typed_rec_body_loc loc env ( !evdref)
+ error_ill_typed_rec_body_loc loc env !evdref
i lna vdefj lar
done
- let check_branches_message loc env evdref c (explft,lft) =
+ let check_branches_message loc env evdref ind c (explft,lft) =
for i = 0 to Array.length explft - 1 do
if not (e_cumul env evdref lft.(i) explft.(i)) then
let sigma = !evdref in
- error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
+ error_ill_formed_branch_loc loc env sigma c (ind,i) lft.(i) explft.(i)
done
(* coerce to tycon if any *)
@@ -99,7 +96,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
(*
let evar_type_case evdref env ct pt lft p c =
let (mind,bty,rslty) = type_case_branches env ( evdref) ct pt p c
- in check_branches_message evdref env (c,ct) (bty,lft); (mind,rslty)
+ in check_branches_message evdref env mind (c,ct) (bty,lft); (mind,rslty)
*)
let strip_meta id = (* For Grammar v7 compatibility *)
@@ -108,7 +105,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
else id
let invert_ltac_bound_name env id0 id =
- try mkRel (pi1 (lookup_rel_id id (rel_context env)))
+ try mkRel (pi1 (Termops.lookup_rel_id id (rel_context env)))
with Not_found ->
errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++
str " depends on pattern variable name " ++ pr_id id ++
@@ -117,7 +114,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let pretype_id loc env sigma (lvar,unbndltacvars) id =
let id = strip_meta id in (* May happen in tactics defined by Grammar *)
try
- let (n,_,typ) = lookup_rel_id id (rel_context env) in
+ let (n,_,typ) = Termops.lookup_rel_id id (rel_context env) in
{ uj_val = mkRel n; uj_type = lift n typ }
with Not_found ->
try
@@ -153,7 +150,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let s' = mkProd (Anonymous, ind, s) in
let ccl = lift 1 (decomp n pj.uj_val) in
let ccl' = mkLambda (Anonymous, ind, ccl) in
- {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign}
+ {uj_val=Termops.it_mkLambda ccl' sign; uj_type=Termops.it_mkProd s' sign}
(*************************************************************************)
(* Main pretyping function *)
@@ -162,9 +159,9 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let c = constr_of_global ref in
make_judge c (Retyping.get_type_of env Evd.empty c)
- let pretype_sort = function
- | RProp c -> judge_of_prop_contents c
- | RType _ -> judge_of_new_Type ()
+ let pretype_sort evdref = function
+ | GProp c -> judge_of_prop_contents c
+ | GType _ -> evd_comb0 judge_of_new_Type evdref
let split_tycon_lam loc env evd tycon =
let rec real_split evd c =
@@ -192,44 +189,44 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
(* in environment [env], with existential variables [( evdref)] and *)
(* the type constraint tycon *)
let rec pretype (tycon : type_constraint) env evdref lvar c =
-(* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *)
+(* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_glob_constr env c ++ *)
(* str " with tycon " ++ Evarutil.pr_tycon env tycon) *)
(* with _ -> () *)
(* in *)
match c with
- | RRef (loc,ref) ->
+ | GRef (loc,ref) ->
inh_conv_coerce_to_tycon loc env evdref
(pretype_ref evdref env ref)
tycon
- | RVar (loc, id) ->
+ | GVar (loc, id) ->
inh_conv_coerce_to_tycon loc env evdref
(pretype_id loc env !evdref lvar id)
tycon
- | REvar (loc, ev, instopt) ->
+ | GEvar (loc, ev, instopt) ->
(* Ne faudrait-il pas s'assurer que hyps est bien un
sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
- let hyps = evar_context (Evd.find ( !evdref) ev) in
+ let hyps = evar_context (Evd.find !evdref ev) in
let args = match instopt with
| None -> instance_from_named_context hyps
| Some inst -> failwith "Evar subtitutions not implemented" in
let c = mkEvar (ev, args) in
- let j = (Retyping.get_judgment_of env ( !evdref) c) in
+ let j = (Retyping.get_judgment_of env !evdref c) in
inh_conv_coerce_to_tycon loc env evdref j tycon
- | RPatVar (loc,(someta,n)) ->
- anomaly "Found a pattern variable in a rawterm to type"
+ | GPatVar (loc,(someta,n)) ->
+ anomaly "Found a pattern variable in a glob_constr to type"
- | RHole (loc,k) ->
+ | GHole (loc,k) ->
let ty =
match tycon with
| Some (None, ty) -> ty
| None | Some _ ->
- e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in
+ e_new_evar evdref env ~src:(loc, InternalHole) (Termops.new_Type ()) in
{ uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
- | RRec (loc,fixkind,names,bl,lar,vdef) ->
+ | GRec (loc,fixkind,names,bl,lar,vdef) ->
let rec type_bl env ctxt = function
[] -> ctxt
| (na,k,None,ty)::bl ->
@@ -260,7 +257,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
in
push_rec_types (names,marked_ftys,[||]) env
in
- let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in
+ let fixi = match fixkind with GFix (vn, i) -> i | GCoFix i -> i in
let vdefj =
array_map2_i
(fun i ctxt def ->
@@ -284,10 +281,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
ctxtv vdef in
evar_type_fixpoint loc env evdref names ftys vdefj;
- let ftys = Array.map (nf_evar ( !evdref)) ftys in
- let fdefs = Array.map (fun x -> nf_evar ( !evdref) (j_val x)) vdefj in
+ let ftys = Array.map (nf_evar !evdref) ftys in
+ let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in
let fixj = match fixkind with
- | RFix (vn,i) ->
+ | GFix (vn,i) ->
(* First, let's find the guard indexes. *)
(* If recursive argument was not given by user, we try all args.
An earlier approach was to look only for inductive arguments,
@@ -303,16 +300,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: nat_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
(* This file defines the printer for natural numbers in [nat] *)
(*i*)
@@ -16,7 +14,7 @@ open Pp
open Util
open Names
open Coqlib
-open Rawterm
+open Glob_term
open Libnames
open Bigint
open Coqlib
@@ -38,11 +36,11 @@ let nat_of_int dloc n =
strbrk "working with large numbers in nat (observed threshold " ++
strbrk "may vary from 5000 to 70000 depending on your system " ++
strbrk "limits and on the command executed).");
- let ref_O = RRef (dloc, glob_O) in
- let ref_S = RRef (dloc, glob_S) in
+ let ref_O = GRef (dloc, glob_O) in
+ let ref_S = GRef (dloc, glob_S) in
let rec mk_nat acc n =
if n <> zero then
- mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n)
+ mk_nat (GApp (dloc,ref_S, [acc])) (sub_1 n)
else
acc
in
@@ -58,8 +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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: numbers_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(* digit-based syntax for int31, bigN bigZ and bigQ *)
open Bigint
open Libnames
-open Rawterm
+open Glob_term
(*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***)
@@ -48,7 +46,7 @@ let zn2z_WW = ConstructRef ((zn2z_id "zn2z",0),2)
let bigN_module = ["Coq"; "Numbers"; "Natural"; "BigN"; "BigN" ]
let bigN_path = make_path (bigN_module@["BigN"]) "t"
-let bigN_t = make_mind_mpdot bigN_module "BigN" "t_"
+let bigN_t = make_mind_mpdot bigN_module "BigN" "t'"
let bigN_scope = "bigN_scope"
(* number of inlined level of bigN (actually the level 0 to n_inlined-1 are inlined) *)
@@ -100,9 +98,9 @@ exception Non_closed
(* parses a *non-negative* integer (from bigint.ml) into an int31
wraps modulo 2^31 *)
let int31_of_pos_bigint dloc n =
- let ref_construct = RRef (dloc, int31_construct) in
- let ref_0 = RRef (dloc, int31_0) in
- let ref_1 = RRef (dloc, int31_1) in
+ let ref_construct = GRef (dloc, int31_construct) in
+ let ref_0 = GRef (dloc, int31_0) in
+ let ref_1 = GRef (dloc, int31_1) in
let rec args counter n =
if counter <= 0 then
[]
@@ -110,7 +108,7 @@ let int31_of_pos_bigint dloc n =
let (q,r) = div2_with_rest n in
(if r then ref_1 else ref_0)::(args (counter-1) q)
in
- RApp (dloc, ref_construct, List.rev (args 31 n))
+ GApp (dloc, ref_construct, List.rev (args 31 n))
let error_negative dloc =
Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
@@ -127,12 +125,12 @@ let bigint_of_int31 =
let rec args_parsing args cur =
match args with
| [] -> cur
- | (RRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur)
- | (RRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur))
+ | (GRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur)
+ | (GRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur))
| _ -> raise Non_closed
in
function
- | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero
+ | GApp (_, GRef (_, c), args) when c=int31_construct -> args_parsing args zero
| _ -> raise Non_closed
let uninterp_int31 i =
@@ -145,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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: r_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Pp
open Util
open Names
@@ -22,7 +20,7 @@ exception Non_closed_number
(**********************************************************************)
open Libnames
-open Rawterm
+open Glob_term
open Bigint
let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
@@ -48,24 +46,24 @@ let four = mult_2 two
(* Unary representation of strictly positive numbers *)
let rec small_r dloc n =
- if equal one n then RRef (dloc, glob_R1)
- else RApp(dloc,RRef (dloc,glob_Rplus),
- [RRef (dloc, glob_R1);small_r dloc (sub_1 n)])
+ if equal one n then GRef (dloc, glob_R1)
+ else GApp(dloc,GRef (dloc,glob_Rplus),
+ [GRef (dloc, glob_R1);small_r dloc (sub_1 n)])
let r_of_posint dloc n =
- let r1 = RRef (dloc, glob_R1) in
+ let r1 = GRef (dloc, glob_R1) in
let r2 = small_r dloc two in
let rec r_of_pos n =
if less_than n four then small_r dloc n
else
let (q,r) = div2_with_rest n in
- let b = RApp(dloc,RRef(dloc,glob_Rmult),[r2;r_of_pos q]) in
- if r then RApp(dloc,RRef(dloc,glob_Rplus),[r1;b]) else b in
- if n <> zero then r_of_pos n else RRef(dloc,glob_R0)
+ let b = GApp(dloc,GRef(dloc,glob_Rmult),[r2;r_of_pos q]) in
+ if r then GApp(dloc,GRef(dloc,glob_Rplus),[r1;b]) else b in
+ if n <> zero then r_of_pos n else GRef(dloc,glob_R0)
let r_of_int dloc z =
if is_strictly_neg z then
- RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)])
+ GApp (dloc, GRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)])
else
r_of_posint dloc z
@@ -77,33 +75,33 @@ let bignat_of_r =
(* for numbers > 1 *)
let rec bignat_of_pos = function
(* 1+1 *)
- | RApp (_,RRef (_,p), [RRef (_,o1); RRef (_,o2)])
+ | GApp (_,GRef (_,p), [GRef (_,o1); GRef (_,o2)])
when p = glob_Rplus & o1 = glob_R1 & o2 = glob_R1 -> two
(* 1+(1+1) *)
- | RApp (_,RRef (_,p1), [RRef (_,o1);
- RApp(_,RRef (_,p2),[RRef(_,o2);RRef(_,o3)])])
+ | GApp (_,GRef (_,p1), [GRef (_,o1);
+ GApp(_,GRef (_,p2),[GRef(_,o2);GRef(_,o3)])])
when p1 = glob_Rplus & p2 = glob_Rplus &
o1 = glob_R1 & o2 = glob_R1 & o3 = glob_R1 -> three
(* (1+1)*b *)
- | RApp (_,RRef (_,p), [a; b]) when p = glob_Rmult ->
+ | GApp (_,GRef (_,p), [a; b]) when p = glob_Rmult ->
if bignat_of_pos a <> two then raise Non_closed_number;
mult_2 (bignat_of_pos b)
(* 1+(1+1)*b *)
- | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])])
+ | GApp (_,GRef (_,p1), [GRef (_,o); GApp (_,GRef (_,p2),[a;b])])
when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 ->
if bignat_of_pos a <> two then raise Non_closed_number;
add_1 (mult_2 (bignat_of_pos b))
| _ -> raise Non_closed_number
in
let bignat_of_r = function
- | RRef (_,a) when a = glob_R0 -> zero
- | RRef (_,a) when a = glob_R1 -> one
+ | GRef (_,a) when a = glob_R0 -> zero
+ | GRef (_,a) when a = glob_R1 -> one
| r -> bignat_of_pos r
in
bignat_of_r
let bigint_of_r = function
- | RApp (_,RRef (_,o), [a]) when o = glob_Ropp ->
+ | GApp (_,GRef (_,o), [a]) when o = glob_Ropp ->
let n = bignat_of_r a in
if n = zero then raise Non_closed_number;
neg n
@@ -118,8 +116,8 @@ let uninterp_r p =
let _ = Notation.declare_numeral_interpreter "R_scope"
(r_path,["Coq";"Reals";"Rdefinitions"])
r_of_int
- ([RRef(dummy_loc,glob_Ropp);RRef(dummy_loc,glob_R0);
- RRef(dummy_loc,glob_Rplus);RRef(dummy_loc,glob_Rmult);
- RRef(dummy_loc,glob_R1)],
+ ([GRef(dummy_loc,glob_Ropp);GRef(dummy_loc,glob_R0);
+ GRef(dummy_loc,glob_Rplus);GRef(dummy_loc,glob_Rmult);
+ GRef(dummy_loc,glob_R1)],
uninterp_r,
false)
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
index 534605c8..d670f602 100644
--- a/plugins/syntax/string_syntax.ml
+++ b/plugins/syntax/string_syntax.ml
@@ -6,8 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(*i $Id: string_syntax.ml 12337 2009-09-17 15:58:14Z glondu $ i*)
-
open Pp
open Util
open Names
@@ -15,7 +13,7 @@ open Pcoq
open Libnames
open Topconstr
open Ascii_syntax
-open Rawterm
+open Glob_term
open Coqlib
exception Non_closed_string
@@ -39,8 +37,8 @@ open Lazy
let interp_string dloc s =
let le = String.length s in
let rec aux n =
- if n = le then RRef (dloc, force glob_EmptyString) else
- RApp (dloc,RRef (dloc, force glob_String),
+ if n = le then GRef (dloc, force glob_EmptyString) else
+ GApp (dloc,GRef (dloc, force glob_String),
[interp_ascii dloc (int_of_char s.[n]); aux (n+1)])
in aux 0
@@ -48,11 +46,11 @@ let uninterp_string r =
try
let b = Buffer.create 16 in
let rec aux = function
- | RApp (_,RRef (_,k),[a;s]) when k = force glob_String ->
+ | GApp (_,GRef (_,k),[a;s]) when k = force glob_String ->
(match uninterp_ascii a with
| Some c -> Buffer.add_char b (Char.chr c); aux s
| _ -> raise Non_closed_string)
- | RRef (_,z) when z = force glob_EmptyString ->
+ | GRef (_,z) when z = force glob_EmptyString ->
Some (Buffer.contents b)
| _ ->
raise Non_closed_string
@@ -64,6 +62,6 @@ let _ =
Notation.declare_string_interpreter "string_scope"
(string_path,["Coq";"Strings";"String"])
interp_string
- ([RRef (dummy_loc,static_glob_String);
- RRef (dummy_loc,static_glob_EmptyString)],
+ ([GRef (dummy_loc,static_glob_String);
+ GRef (dummy_loc,static_glob_EmptyString)],
uninterp_string, true)
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
index e6dcc35e..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 *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: z_syntax.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Pcoq
open Pp
open Util
@@ -23,18 +21,19 @@ exception Non_closed_number
(**********************************************************************)
open Libnames
-open Rawterm
+open Glob_term
+
+let binnums = ["Coq";"Numbers";"BinNums"]
+
let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
-let positive_module = ["Coq";"NArith";"BinPos"]
let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
-let positive_path = make_path positive_module "positive"
+let positive_path = make_path binnums "positive"
(* TODO: temporary hack *)
let make_kn dir id = Libnames.encode_mind dir id
-let positive_kn =
- make_kn (make_dir positive_module) (id_of_string "positive")
+let positive_kn = make_kn (make_dir binnums) (id_of_string "positive")
let glob_positive = IndRef (positive_kn,0)
let path_of_xI = ((positive_kn,0),1)
let path_of_xO = ((positive_kn,0),2)
@@ -44,13 +43,13 @@ let glob_xO = ConstructRef path_of_xO
let glob_xH = ConstructRef path_of_xH
let pos_of_bignat dloc x =
- let ref_xI = RRef (dloc, glob_xI) in
- let ref_xH = RRef (dloc, glob_xH) in
- let ref_xO = RRef (dloc, glob_xO) in
+ let ref_xI = GRef (dloc, glob_xI) in
+ let ref_xH = GRef (dloc, glob_xH) in
+ let ref_xO = GRef (dloc, glob_xO) in
let rec pos_of x =
match div2_with_rest x with
- | (q,false) -> RApp (dloc, ref_xO,[pos_of q])
- | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q])
+ | (q,false) -> GApp (dloc, ref_xO,[pos_of q])
+ | (q,true) when q <> zero -> GApp (dloc,ref_xI,[pos_of q])
| (q,true) -> ref_xH
in
pos_of x
@@ -68,9 +67,9 @@ let interp_positive dloc n =
(**********************************************************************)
let rec bignat_of_pos = function
- | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a)
- | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a))
- | RRef (_, a) when a = glob_xH -> Bigint.one
+ | GApp (_, GRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a)
+ | GApp (_, GRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a))
+ | GRef (_, a) when a = glob_xH -> Bigint.one
| _ -> raise Non_closed_number
let uninterp_positive p =
@@ -84,11 +83,11 @@ let uninterp_positive p =
(************************************************************************)
let _ = Notation.declare_numeral_interpreter "positive_scope"
- (positive_path,positive_module)
+ (positive_path,binnums)
interp_positive
- ([RRef (dummy_loc, glob_xI);
- RRef (dummy_loc, glob_xO);
- RRef (dummy_loc, glob_xH)],
+ ([GRef (dummy_loc, glob_xI);
+ GRef (dummy_loc, glob_xO);
+ GRef (dummy_loc, glob_xH)],
uninterp_positive,
true)
@@ -96,21 +95,20 @@ let _ = Notation.declare_numeral_interpreter "positive_scope"
(* Parsing N via scopes *)
(**********************************************************************)
-let binnat_module = ["Coq";"NArith";"BinNat"]
-let n_kn = make_kn (make_dir binnat_module) (id_of_string "N")
+let n_kn = make_kn (make_dir binnums) (id_of_string "N")
let glob_n = IndRef (n_kn,0)
let path_of_N0 = ((n_kn,0),1)
let path_of_Npos = ((n_kn,0),2)
let glob_N0 = ConstructRef path_of_N0
let glob_Npos = ConstructRef path_of_Npos
-let n_path = make_path binnat_module "N"
+let n_path = make_path binnums "N"
let n_of_binnat dloc pos_or_neg n =
if n <> zero then
- RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n])
+ GApp(dloc, GRef (dloc,glob_Npos), [pos_of_bignat dloc n])
else
- RRef (dloc, glob_N0)
+ GRef (dloc, glob_N0)
let error_negative dloc =
user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".")
@@ -124,8 +122,8 @@ let n_of_int dloc n =
(**********************************************************************)
let bignat_of_n = function
- | RApp (_, RRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a
- | RRef (_, a) when a = glob_N0 -> Bigint.zero
+ | GApp (_, GRef (_,b),[a]) when b = glob_Npos -> bignat_of_pos a
+ | GRef (_, a) when a = glob_N0 -> Bigint.zero
| _ -> raise Non_closed_number
let uninterp_n p =
@@ -136,10 +134,10 @@ let uninterp_n p =
(* Declaring interpreters and uninterpreters for N *)
let _ = Notation.declare_numeral_interpreter "N_scope"
- (n_path,binnat_module)
+ (n_path,binnums)
n_of_int
- ([RRef (dummy_loc, glob_N0);
- RRef (dummy_loc, glob_Npos)],
+ ([GRef (dummy_loc, glob_N0);
+ GRef (dummy_loc, glob_Npos)],
uninterp_n,
true)
@@ -147,9 +145,8 @@ let _ = Notation.declare_numeral_interpreter "N_scope"
(* Parsing Z via scopes *)
(**********************************************************************)
-let binint_module = ["Coq";"ZArith";"BinInt"]
-let z_path = make_path binint_module "Z"
-let z_kn = make_kn (make_dir binint_module) (id_of_string "Z")
+let z_path = make_path binnums "Z"
+let z_kn = make_kn (make_dir binnums) (id_of_string "Z")
let glob_z = IndRef (z_kn,0)
let path_of_ZERO = ((z_kn,0),1)
let path_of_POS = ((z_kn,0),2)
@@ -162,18 +159,18 @@ let z_of_int dloc n =
if n <> zero then
let sgn, n =
if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in
- RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n])
+ GApp(dloc, GRef (dloc,sgn), [pos_of_bignat dloc n])
else
- RRef (dloc, glob_ZERO)
+ GRef (dloc, glob_ZERO)
(**********************************************************************)
(* Printing Z via scopes *)
(**********************************************************************)
let bigint_of_z = function
- | RApp (_, RRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a
- | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a)
- | RRef (_, a) when a = glob_ZERO -> Bigint.zero
+ | GApp (_, GRef (_,b),[a]) when b = glob_POS -> bignat_of_pos a
+ | GApp (_, GRef (_,b),[a]) when b = glob_NEG -> Bigint.neg (bignat_of_pos a)
+ | GRef (_, a) when a = glob_ZERO -> Bigint.zero
| _ -> raise Non_closed_number
let uninterp_z p =
@@ -185,10 +182,10 @@ let uninterp_z p =
(* Declaring interpreters and uninterpreters for Z *)
let _ = Notation.declare_numeral_interpreter "Z_scope"
- (z_path,binint_module)
+ (z_path,binnums)
z_of_int
- ([RRef (dummy_loc, glob_ZERO);
- RRef (dummy_loc, glob_POS);
- RRef (dummy_loc, glob_NEG)],
+ ([GRef (dummy_loc, glob_ZERO);
+ GRef (dummy_loc, glob_POS);
+ GRef (dummy_loc, glob_NEG)],
uninterp_z,
true)
diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml
index 97287d18..653c2b7b 100644
--- a/plugins/xml/acic.ml
+++ b/plugins/xml/acic.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
diff --git a/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4
index 631af9f0..97f7e2bd 100644
--- a/plugins/xml/acic2Xml.ml4
+++ b/plugins/xml/acic2Xml.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml
index 0b98acd2..da0a65ff 100644
--- a/plugins/xml/cic2acic.ml
+++ b/plugins/xml/cic2acic.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml
index d67c114e..a21a919a 100644
--- a/plugins/xml/doubleTypeInference.ml
+++ b/plugins/xml/doubleTypeInference.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
@@ -27,7 +27,7 @@ let cprop =
;;
let whd_betadeltaiotacprop env _evar_map ty =
- let module R = Rawterm in
+ let module R = Glob_term in
let module C = Closure in
let module CR = C.RedFlags in
(*** CProp is made Opaque ***)
diff --git a/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli
index 3858b906..5c00bdc6 100644
--- a/plugins/xml/doubleTypeInference.mli
+++ b/plugins/xml/doubleTypeInference.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4
index 3cfc52b7..3c3e54fa 100644
--- a/plugins/xml/dumptree.ml4
+++ b/plugins/xml/dumptree.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -42,7 +42,7 @@ let thin_sign osign sign =
;;
let pr_tactic_xml = function
- | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>"
+ | TacArg (_,Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>"
| t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) t) ++ str "\"/>"
;;
@@ -56,13 +56,11 @@ let pr_rule_xml pr = function
hov 2 (str "<cmpdrule>" ++ fnl () ++
begin match cmpd with
Tactic (texp, _) -> pr_tactic_xml texp
- | Proof_instr (_,instr) -> pr_proof_instr_xml instr
end ++ fnl ()
++ pr subtree
) ++ fnl () ++ str "</cmpdrule>"
| Daimon -> str "<daimon/>"
| Decl_proof _ -> str "<proof/>"
-(* | Change_evars -> str "<chgevars/>"*)
;;
let pr_var_decl_xml env (id,c,typ) =
@@ -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 "<goal>" ++ fnl () ++ str "<concl type=\"" ++
- xmlstream (pr_ltype_env_at_top env g.evar_concl) ++
+ xmlstream (pr_ltype_env_at_top env (Goal.V82.concl sigma g)) ++
str "\"/>" ++
(pr_context_xml env)) ++
fnl () ++ str "</goal>")
@@ -129,23 +127,9 @@ let pr_goal_xml g =
fnl () ++ str "</goal>")
;;
-let rec print_proof_xml sigma osign pf =
- let hyps = Environ.named_context_of_val pf.goal.evar_hyps in
- let hyps' = thin_sign osign hyps in
- match pf.ref with
- | None -> hov 2 (str "<tree>" ++ fnl () ++ (pr_goal_xml {pf.goal with evar_hyps=hyps'})) ++ fnl () ++ str "</tree>"
- | Some(r,spfl) ->
- hov 2 (str "<tree>" ++ fnl () ++
- (pr_goal_xml {pf.goal with evar_hyps=hyps'}) ++ fnl () ++ (pr_rule_xml (print_proof_xml sigma osign) r) ++
- (List.fold_left (fun x y -> x ++ fnl () ++ y) (mt ()) (List.map (print_proof_xml sigma hyps) spfl))) ++ fnl () ++ str "</tree>"
-;;
-
let print_proof_xml () =
- let pp = print_proof_xml Evd.empty Sign.empty_named_context
- (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ())))
- in
- msgnl pp
-;;
+ Util.anomaly "Dump Tree command not supported in this version."
+
VERNAC COMMAND EXTEND DumpTree
[ "Dump" "Tree" ] -> [ print_proof_xml () ]
diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml
index d871935b..2d16190b 100644
--- a/plugins/xml/proof2aproof.ml
+++ b/plugins/xml/proof2aproof.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
@@ -59,30 +59,6 @@ let nf_evar sigma ~preserve =
aux
;;
-(* Unshares a proof-tree. *)
-(* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *)
-let rec unshare_proof_tree =
- let module PT = Proof_type in
- function {PT.open_subgoals = status ;
- PT.goal = goal ;
- PT.ref = ref} ->
- let unshared_ref =
- match ref with
- None -> None
- | Some (rule,pfs) ->
- let unshared_rule =
- match rule with
- PT.Nested (cmpd, pf) ->
- PT.Nested (cmpd, unshare_proof_tree pf)
- | other -> other
- in
- Some (unshared_rule, List.map unshare_proof_tree pfs)
- in
- {PT.open_subgoals = status ;
- PT.goal = goal ;
- PT.ref = unshared_ref}
-;;
-
module ProofTreeHash =
Hashtbl.Make
(struct
@@ -94,83 +70,9 @@ module ProofTreeHash =
let extract_open_proof sigma pf =
- let module PT = Proof_type in
- let module L = Logic in
- let evd = ref (Evd.create_evar_defs sigma) in
- let proof_tree_to_constr = ProofTreeHash.create 503 in
- let proof_tree_to_flattened_proof_tree = ProofTreeHash.create 503 in
- let unshared_constrs = ref S.empty in
- let rec proof_extractor vl node =
- let constr =
- match node with
- {PT.ref=Some(PT.Prim _,_)} as pf ->
- L.prim_extractor proof_extractor vl pf
-
- | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} ->
- let sgl,v = Refiner.frontier hidden_proof in
- let flat_proof = v spfl in
- ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ;
- proof_extractor vl flat_proof
-
- | {PT.ref=None;PT.goal=goal} ->
- let visible_rels =
- Util.map_succeed
- (fun id ->
- (* Section variables are in the [id] list but are not *)
- (* lambda abstracted in the term [vl] *)
- try let n = Logic.proof_variable_index id vl in (n,id)
- with Not_found -> failwith "caught")
-(*CSC: the above function must be modified such that when it is found *)
-(*CSC: it becomes a Rel; otherwise a Var. Then it can be already used *)
-(*CSC: as the evar_instance. Ordering the instance becomes useless (it *)
-(*CSC: will already be ordered. *)
- (Termops.ids_of_named_context
- (Environ.named_context_of_val goal.Evd.evar_hyps)) in
- let sorted_rels =
- Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in
- let context =
- let l =
- List.map
- (fun (_,id) -> Sign.lookup_named id
- (Environ.named_context_of_val goal.Evd.evar_hyps))
- sorted_rels in
- Environ.val_of_named_context l
- in
-(*CSC: the section variables in the right order must be added too *)
- let evar_instance = List.map (fun (n,_) -> Term.mkRel n) sorted_rels in
- (* let env = Global.env_of_context context in *)
- let evd',evar =
- Evarutil.new_evar_instance context !evd goal.Evd.evar_concl
- evar_instance in
- evd := evd' ;
- evar
-
- | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor"
- in
- let unsharedconstr =
- let evar_nf_constr =
- nf_evar ( !evd)
- ~preserve:(function e -> S.mem e !unshared_constrs) constr
- in
- Unshare.unshare
- ~already_unshared:(function e -> S.mem e !unshared_constrs)
- evar_nf_constr
- in
-(*CSC: debugging stuff to be removed *)
-if ProofTreeHash.mem proof_tree_to_constr node then
- Pp.ppnl (Pp.(++) (Pp.str "#DUPLICATE INSERTION: ")
- (Tactic_printer.print_proof ( !evd) [] node)) ;
- ProofTreeHash.add proof_tree_to_constr node unsharedconstr ;
- unshared_constrs := S.add unsharedconstr !unshared_constrs ;
- unsharedconstr
- in
- let unshared_pf = unshare_proof_tree pf in
- let pfterm = proof_extractor [] unshared_pf in
- (pfterm, !evd, proof_tree_to_constr, proof_tree_to_flattened_proof_tree,
- unshared_pf)
-;;
+ (* Deactivated and candidate for removal. (Apr. 2010) *)
+ ()
let extract_open_pftreestate pts =
- extract_open_proof (Refiner.evc_of_pftreestate pts)
- (Tacmach.proof_of_pftreestate pts)
-;;
+ (* Deactivated and candidate for removal. (Apr. 2010) *)
+ ()
diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4
index 21c86c79..2f5eb6ac 100644
--- a/plugins/xml/proofTree2Xml.ml4
+++ b/plugins/xml/proofTree2Xml.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
@@ -14,11 +14,6 @@
let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";;
-let std_ppcmds_to_string s =
- Pp.msg_with Format.str_formatter s;
- Format.flush_str_formatter ()
-;;
-
let idref_of_id id = "v" ^ id;;
(* Transform a constr to an Xml.token Stream.t *)
@@ -149,22 +144,24 @@ Pp.ppnl (Pp.(++) (Pp.str
Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node
in begin
match tactic_expr with
- | T.TacArg (T.Tacexp _) ->
+ | T.TacArg (_,T.Tacexp _) ->
(* We don't need to keep the level of abstraction introduced at *)
(* user-level invocation of tactic... (see Tacinterp.hide_interp)*)
aux flat_proof old_hyps
| _ ->
(****** la tactique employee *)
let prtac = Pptactic.pr_tactic (Global.env()) in
- let tac = std_ppcmds_to_string (prtac tactic_expr) in
+ let tac = Pp.string_of_ppcmds (prtac tactic_expr) in
let tacname= first_word tac in
let of_attribute = ("name",tacname)::("script",tac)::of_attribute in
(****** le but *)
- let {Evd.evar_concl=concl;
- Evd.evar_hyps=hyps}=goal in
+
+ let concl = Goal.V82.concl sigma goal in
+ let hyps = Goal.V82.hyps sigma goal in
let env = Global.env_of_context hyps in
+
let xgoal =
X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in
@@ -188,14 +185,12 @@ Pp.ppnl (Pp.(++) (Pp.str
[<(build_hyps new_hyps) ; (aux flat_proof nhyps)>]
end
- | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} ->
- Util.anomaly "Not Implemented"
-
| {PT.ref=Some(PT.Daimon,_)} ->
X.xml_empty "Hidden_open_goal" of_attribute
| {PT.ref=None;PT.goal=goal} ->
X.xml_empty "Open_goal" of_attribute
+ | {PT.ref=Some(PT.Decl_proof _, _)} -> failwith "TODO: xml and decl_proof"
in
[< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n");
diff --git a/plugins/xml/unshare.ml b/plugins/xml/unshare.ml
index 344a1581..c854427d 100644
--- a/plugins/xml/unshare.ml
+++ b/plugins/xml/unshare.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
diff --git a/plugins/xml/unshare.mli b/plugins/xml/unshare.mli
index 4b96b22e..cace2de6 100644
--- a/plugins/xml/unshare.mli
+++ b/plugins/xml/unshare.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
diff --git a/plugins/xml/xml.ml4 b/plugins/xml/xml.ml4
index 2d73074b..8a4eb39a 100644
--- a/plugins/xml/xml.ml4
+++ b/plugins/xml/xml.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
diff --git a/plugins/xml/xml.mli b/plugins/xml/xml.mli
index ffaad957..0b6d5198 100644
--- a/plugins/xml/xml.mli
+++ b/plugins/xml/xml.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
@@ -12,8 +12,6 @@
(* http://helm.cs.unibo.it *)
(************************************************************************)
-(*i $Id: xml.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(* Tokens for XML cdata, empty elements and not-empty elements *)
(* Usage: *)
(* Str cdata *)
diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml
index 7e7f890f..1037bbf0 100644
--- a/plugins/xml/xmlcommand.ml
+++ b/plugins/xml/xmlcommand.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
@@ -527,8 +527,10 @@ let print internal glob_ref kind xml_library_root =
Cic2acic.Variable kn,mk_variable_obj id body typ
| Ln.ConstRef kn ->
let id = N.id_of_label (N.con_label kn) in
- let {D.const_body=val0 ; D.const_type = typ ; D.const_hyps = hyps} =
- G.lookup_constant kn in
+ let cb = G.lookup_constant kn in
+ let val0 = D.body_of_constant cb in
+ let typ = cb.D.const_type in
+ let hyps = cb.D.const_hyps in
let typ = Typeops.type_of_constant_type (Global.env()) typ in
Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps
| Ln.IndRef (kn,_) ->
@@ -557,43 +559,13 @@ let print_ref qid fn =
(* where dest is either None (for stdout) or (Some filename) *)
(* pretty prints via Xml.pp the proof in progress on dest *)
let show_pftreestate internal fn (kind,pftst) id =
- let pf = Tacmach.proof_of_pftreestate pftst in
- let typ = (Proof_trees.goal_of_proof pf).Evd.evar_concl in
- let val0,evar_map,proof_tree_to_constr,proof_tree_to_flattened_proof_tree,
- unshared_pf
- =
- Proof2aproof.extract_open_pftreestate pftst in
- let env = Global.env () in
- let obj =
- mk_current_proof_obj (fst kind = Decl_kinds.Local) id val0 typ evar_map env in
- let uri =
- match kind with
- Decl_kinds.Local, _ ->
- let uri =
- "cic:/" ^ String.concat "/"
- (Cic2acic.token_list_of_path (Lib.cwd ()) id Cic2acic.TVariable)
- in
- let kind_of_var = "VARIABLE","LocalFact" in
- (match internal with
- | Declare.KernelSilent -> ()
- | _ -> print_object_kind uri kind_of_var
- ); uri
- | Decl_kinds.Global, _ ->
- let uri = Cic2acic.uri_of_declaration id Cic2acic.TConstant in
- (match internal with
- | Declare.KernelSilent -> ()
- | _ -> print_object_kind uri (kind_of_global_goal kind)
- ); uri
- in
- print_object uri obj evar_map
- (Some (Tacmach.evc_of_pftreestate pftst,unshared_pf,proof_tree_to_constr,
- proof_tree_to_flattened_proof_tree)) fn
-;;
+ if true then
+ Util.anomaly "Xmlcommand.show_pftreestate is not supported in this version."
let show fn =
let pftst = Pfedit.get_pftreestate () in
let (id,kind,_,_) = Pfedit.current_proof_statement () in
- show_pftreestate Declare.KernelVerbose fn (kind,pftst) id
+ show_pftreestate false fn (kind,pftst) id
;;
@@ -680,7 +652,7 @@ let _ =
end ;
Option.iter
(fun fn ->
- let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in
+ let coqdoc = Filename.concat Envars.coqbin ("coqdoc" ^ Coq_config.exec_extension) in
let options = " --html -s --body-only --no-index --latin1 --raw-comments" in
let command cmd =
if Sys.command cmd <> 0 then
diff --git a/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli
index eadf3cfd..ec50d623 100644
--- a/plugins/xml/xmlcommand.mli
+++ b/plugins/xml/xmlcommand.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
@@ -12,8 +12,6 @@
(* http://helm.cs.unibo.it *)
(************************************************************************)
-(*i $Id: xmlcommand.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(* print_global qid fn *)
(* where qid is a long name denoting a definition/theorem or *)
(* an inductive definition *)
diff --git a/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4
index f9d5bac0..d65a1bd3 100644
--- a/plugins/xml/xmlentries.ml4
+++ b/plugins/xml/xmlentries.ml4
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * The HELM Project / The EU MoWGLI Project *)
(* * University of Bologna *)
@@ -14,8 +14,6 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: xmlentries.ml4 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util;;
open Vernacinterp;;