summaryrefslogtreecommitdiff
path: root/plugins
diff options
context:
space:
mode:
Diffstat (limited to 'plugins')
-rw-r--r--plugins/cc/README20
-rw-r--r--plugins/cc/cc_plugin.mllib5
-rw-r--r--plugins/cc/ccalgo.ml884
-rw-r--r--plugins/cc/ccalgo.mli222
-rw-r--r--plugins/cc/ccproof.ml153
-rw-r--r--plugins/cc/ccproof.mli31
-rw-r--r--plugins/cc/cctac.ml465
-rw-r--r--plugins/cc/cctac.mli22
-rw-r--r--plugins/cc/g_congruence.ml429
-rw-r--r--plugins/dp/Dp.v120
-rw-r--r--plugins/dp/TODO24
-rw-r--r--plugins/dp/dp.ml1134
-rw-r--r--plugins/dp/dp.mli20
-rw-r--r--plugins/dp/dp_plugin.mllib5
-rw-r--r--plugins/dp/dp_why.ml186
-rw-r--r--plugins/dp/dp_why.mli17
-rw-r--r--plugins/dp/dp_zenon.mli7
-rw-r--r--plugins/dp/dp_zenon.mll189
-rw-r--r--plugins/dp/fol.mli58
-rw-r--r--plugins/dp/g_dp.ml479
-rw-r--r--plugins/dp/test2.v80
-rw-r--r--plugins/dp/tests.v300
-rw-r--r--plugins/dp/vo.itarget1
-rw-r--r--plugins/dp/zenon.v94
-rw-r--r--plugins/extraction/CHANGES414
-rw-r--r--plugins/extraction/ExtrOcamlBasic.v33
-rw-r--r--plugins/extraction/ExtrOcamlBigIntConv.v108
-rw-r--r--plugins/extraction/ExtrOcamlIntConv.v97
-rw-r--r--plugins/extraction/ExtrOcamlNatBigInt.v69
-rw-r--r--plugins/extraction/ExtrOcamlNatInt.v75
-rw-r--r--plugins/extraction/ExtrOcamlString.v38
-rw-r--r--plugins/extraction/ExtrOcamlZBigInt.v85
-rw-r--r--plugins/extraction/ExtrOcamlZInt.v78
-rw-r--r--plugins/extraction/README147
-rw-r--r--plugins/extraction/big.ml154
-rw-r--r--plugins/extraction/common.ml535
-rw-r--r--plugins/extraction/common.mli59
-rw-r--r--plugins/extraction/extract_env.ml540
-rw-r--r--plugins/extraction/extract_env.mli23
-rw-r--r--plugins/extraction/extraction.ml982
-rw-r--r--plugins/extraction/extraction.mli34
-rw-r--r--plugins/extraction/extraction_plugin.mllib11
-rw-r--r--plugins/extraction/g_extraction.ml4142
-rw-r--r--plugins/extraction/haskell.ml357
-rw-r--r--plugins/extraction/haskell.mli12
-rw-r--r--plugins/extraction/miniml.mli201
-rw-r--r--plugins/extraction/mlutil.ml1293
-rw-r--r--plugins/extraction/mlutil.mli131
-rw-r--r--plugins/extraction/modutil.ml375
-rw-r--r--plugins/extraction/modutil.mli41
-rw-r--r--plugins/extraction/ocaml.ml759
-rw-r--r--plugins/extraction/ocaml.mli12
-rw-r--r--plugins/extraction/scheme.ml215
-rw-r--r--plugins/extraction/scheme.mli11
-rw-r--r--plugins/extraction/table.ml767
-rw-r--r--plugins/extraction/table.mli167
-rw-r--r--plugins/extraction/vo.itarget8
-rw-r--r--plugins/field/LegacyField.v16
-rw-r--r--plugins/field/LegacyField_Compl.v38
-rw-r--r--plugins/field/LegacyField_Tactic.v433
-rw-r--r--plugins/field/LegacyField_Theory.v650
-rw-r--r--plugins/field/field.ml4191
-rw-r--r--plugins/field/field_plugin.mllib2
-rw-r--r--plugins/field/vo.itarget4
-rw-r--r--plugins/firstorder/formula.ml270
-rw-r--r--plugins/firstorder/formula.mli77
-rw-r--r--plugins/firstorder/g_ground.ml4148
-rw-r--r--plugins/firstorder/ground.ml152
-rw-r--r--plugins/firstorder/ground.mli13
-rw-r--r--plugins/firstorder/ground_plugin.mllib8
-rw-r--r--plugins/firstorder/instances.ml206
-rw-r--r--plugins/firstorder/instances.mli26
-rw-r--r--plugins/firstorder/rules.ml215
-rw-r--r--plugins/firstorder/rules.mli54
-rw-r--r--plugins/firstorder/sequent.ml312
-rw-r--r--plugins/firstorder/sequent.mli66
-rw-r--r--plugins/firstorder/unify.ml143
-rw-r--r--plugins/firstorder/unify.mli23
-rw-r--r--plugins/fourier/Fourier.v21
-rw-r--r--plugins/fourier/Fourier_util.v222
-rw-r--r--plugins/fourier/fourier.ml205
-rw-r--r--plugins/fourier/fourierR.ml629
-rw-r--r--plugins/fourier/fourier_plugin.mllib4
-rw-r--r--plugins/fourier/g_fourier.ml417
-rw-r--r--plugins/fourier/vo.itarget2
-rw-r--r--plugins/funind/Recdef.v48
-rw-r--r--plugins/funind/functional_principles_proofs.ml1710
-rw-r--r--plugins/funind/functional_principles_proofs.mli19
-rw-r--r--plugins/funind/functional_principles_types.ml737
-rw-r--r--plugins/funind/functional_principles_types.mli34
-rw-r--r--plugins/funind/g_indfun.ml4524
-rw-r--r--plugins/funind/indfun.ml776
-rw-r--r--plugins/funind/indfun_common.ml558
-rw-r--r--plugins/funind/indfun_common.mli121
-rw-r--r--plugins/funind/invfun.ml1020
-rw-r--r--plugins/funind/merge.ml1032
-rw-r--r--plugins/funind/rawterm_to_relation.ml1419
-rw-r--r--plugins/funind/rawterm_to_relation.mli16
-rw-r--r--plugins/funind/rawtermops.ml718
-rw-r--r--plugins/funind/rawtermops.mli126
-rw-r--r--plugins/funind/recdef.ml1473
-rw-r--r--plugins/funind/recdef_plugin.mllib11
-rw-r--r--plugins/funind/vo.itarget1
-rw-r--r--plugins/micromega/CheckerMaker.v129
-rw-r--r--plugins/micromega/Env.v182
-rw-r--r--plugins/micromega/EnvRing.v1403
-rw-r--r--plugins/micromega/LICENSE.sos29
-rw-r--r--plugins/micromega/MExtraction.v48
-rw-r--r--plugins/micromega/OrderedRing.v458
-rw-r--r--plugins/micromega/Psatz.v86
-rw-r--r--plugins/micromega/QMicromega.v197
-rw-r--r--plugins/micromega/RMicromega.v182
-rw-r--r--plugins/micromega/Refl.v130
-rw-r--r--plugins/micromega/RingMicromega.v884
-rw-r--r--plugins/micromega/Tauto.v327
-rw-r--r--plugins/micromega/VarMap.v259
-rw-r--r--plugins/micromega/ZCoeff.v173
-rw-r--r--plugins/micromega/ZMicromega.v1023
-rw-r--r--plugins/micromega/certificate.ml813
-rw-r--r--plugins/micromega/coq_micromega.ml1710
-rw-r--r--plugins/micromega/csdpcert.ml214
-rw-r--r--plugins/micromega/g_micromega.ml476
-rw-r--r--plugins/micromega/mfourier.ml1012
-rw-r--r--plugins/micromega/micromega.ml1703
-rw-r--r--plugins/micromega/micromega.mli442
-rw-r--r--plugins/micromega/micromega_plugin.mllib9
-rw-r--r--plugins/micromega/mutils.ml402
-rw-r--r--plugins/micromega/persistent_cache.ml180
-rw-r--r--plugins/micromega/sos.ml1859
-rw-r--r--plugins/micromega/sos.mli36
-rw-r--r--plugins/micromega/sos_lib.ml621
-rw-r--r--plugins/micromega/sos_types.ml68
-rw-r--r--plugins/micromega/vo.itarget13
-rw-r--r--plugins/nsatz/NsatzR.v407
-rw-r--r--plugins/nsatz/NsatzZ.v73
-rw-r--r--plugins/nsatz/Nsatz_domain.v558
-rw-r--r--plugins/nsatz/ideal.ml1057
-rw-r--r--plugins/nsatz/nsatz.ml4608
-rw-r--r--plugins/nsatz/nsatz_plugin.mllib5
-rw-r--r--plugins/nsatz/polynom.ml679
-rw-r--r--plugins/nsatz/polynom.mli97
-rw-r--r--plugins/nsatz/utile.ml130
-rw-r--r--plugins/nsatz/utile.mli22
-rw-r--r--plugins/nsatz/vo.itarget3
-rw-r--r--plugins/omega/Omega.v59
-rw-r--r--plugins/omega/OmegaLemmas.v302
-rw-r--r--plugins/omega/OmegaPlugin.v11
-rw-r--r--plugins/omega/PreOmega.v445
-rw-r--r--plugins/omega/coq_omega.ml1823
-rw-r--r--plugins/omega/g_omega.ml447
-rw-r--r--plugins/omega/omega.ml716
-rw-r--r--plugins/omega/omega_plugin.mllib4
-rw-r--r--plugins/omega/vo.itarget4
-rw-r--r--plugins/plugins.itarget3
-rw-r--r--plugins/pluginsbyte.itarget23
-rw-r--r--plugins/pluginsdyn.itarget23
-rw-r--r--plugins/pluginsopt.itarget23
-rw-r--r--plugins/pluginsvo.itarget13
-rw-r--r--plugins/quote/Quote.v87
-rw-r--r--plugins/quote/g_quote.ml431
-rw-r--r--plugins/quote/quote.ml504
-rw-r--r--plugins/quote/quote_plugin.mllib3
-rw-r--r--plugins/quote/vo.itarget1
-rw-r--r--plugins/ring/LegacyArithRing.v90
-rw-r--r--plugins/ring/LegacyNArithRing.v46
-rw-r--r--plugins/ring/LegacyRing.v37
-rw-r--r--plugins/ring/LegacyRing_theory.v376
-rw-r--r--plugins/ring/LegacyZArithRing.v37
-rw-r--r--plugins/ring/Ring_abstract.v706
-rw-r--r--plugins/ring/Ring_normalize.v902
-rw-r--r--plugins/ring/Setoid_ring.v14
-rw-r--r--plugins/ring/Setoid_ring_normalize.v1165
-rw-r--r--plugins/ring/Setoid_ring_theory.v427
-rw-r--r--plugins/ring/g_ring.ml4136
-rw-r--r--plugins/ring/ring.ml924
-rw-r--r--plugins/ring/ring_plugin.mllib3
-rw-r--r--plugins/ring/vo.itarget10
-rw-r--r--plugins/romega/README6
-rw-r--r--plugins/romega/ROmega.v14
-rw-r--r--plugins/romega/ReflOmegaCore.v3216
-rw-r--r--plugins/romega/const_omega.ml352
-rw-r--r--plugins/romega/const_omega.mli176
-rw-r--r--plugins/romega/g_romega.ml442
-rw-r--r--plugins/romega/refl_omega.ml1299
-rw-r--r--plugins/romega/romega_plugin.mllib4
-rw-r--r--plugins/romega/vo.itarget2
-rw-r--r--plugins/rtauto/Bintree.v489
-rw-r--r--plugins/rtauto/Rtauto.v400
-rw-r--r--plugins/rtauto/g_rtauto.ml416
-rw-r--r--plugins/rtauto/proof_search.ml546
-rw-r--r--plugins/rtauto/proof_search.mli49
-rw-r--r--plugins/rtauto/refl_tauto.ml337
-rw-r--r--plugins/rtauto/refl_tauto.mli26
-rw-r--r--plugins/rtauto/rtauto_plugin.mllib4
-rw-r--r--plugins/rtauto/vo.itarget2
-rw-r--r--plugins/setoid_ring/ArithRing.v60
-rw-r--r--plugins/setoid_ring/BinList.v93
-rw-r--r--plugins/setoid_ring/Field.v10
-rw-r--r--plugins/setoid_ring/Field_tac.v571
-rw-r--r--plugins/setoid_ring/Field_theory.v1946
-rw-r--r--plugins/setoid_ring/InitialRing.v908
-rw-r--r--plugins/setoid_ring/NArithRing.v21
-rw-r--r--plugins/setoid_ring/RealField.v134
-rw-r--r--plugins/setoid_ring/Ring.v44
-rw-r--r--plugins/setoid_ring/Ring_base.v17
-rw-r--r--plugins/setoid_ring/Ring_equiv.v74
-rw-r--r--plugins/setoid_ring/Ring_polynom.v1781
-rw-r--r--plugins/setoid_ring/Ring_tac.v434
-rw-r--r--plugins/setoid_ring/Ring_theory.v608
-rw-r--r--plugins/setoid_ring/ZArithRing.v60
-rw-r--r--plugins/setoid_ring/newring.ml41164
-rw-r--r--plugins/setoid_ring/newring_plugin.mllib2
-rw-r--r--plugins/setoid_ring/vo.itarget15
-rw-r--r--plugins/subtac/eterm.ml233
-rw-r--r--plugins/subtac/eterm.mli34
-rw-r--r--plugins/subtac/g_subtac.ml4177
-rw-r--r--plugins/subtac/subtac.ml250
-rw-r--r--plugins/subtac/subtac.mli2
-rw-r--r--plugins/subtac/subtac_cases.ml2027
-rw-r--r--plugins/subtac/subtac_cases.mli23
-rw-r--r--plugins/subtac/subtac_classes.ml182
-rw-r--r--plugins/subtac/subtac_classes.mli41
-rw-r--r--plugins/subtac/subtac_coercion.ml503
-rw-r--r--plugins/subtac/subtac_coercion.mli4
-rw-r--r--plugins/subtac/subtac_command.ml534
-rw-r--r--plugins/subtac/subtac_command.mli60
-rw-r--r--plugins/subtac/subtac_errors.ml24
-rw-r--r--plugins/subtac/subtac_errors.mli15
-rw-r--r--plugins/subtac/subtac_obligations.ml652
-rw-r--r--plugins/subtac/subtac_obligations.mli69
-rw-r--r--plugins/subtac/subtac_plugin.mllib13
-rw-r--r--plugins/subtac/subtac_pretyping.ml137
-rw-r--r--plugins/subtac/subtac_pretyping.mli23
-rw-r--r--plugins/subtac/subtac_pretyping_F.ml645
-rw-r--r--plugins/subtac/subtac_utils.ml484
-rw-r--r--plugins/subtac/subtac_utils.mli136
-rw-r--r--plugins/subtac/test/ListDep.v49
-rw-r--r--plugins/subtac/test/ListsTest.v99
-rw-r--r--plugins/subtac/test/Mutind.v20
-rw-r--r--plugins/subtac/test/Test1.v16
-rw-r--r--plugins/subtac/test/euclid.v24
-rw-r--r--plugins/subtac/test/id.v46
-rw-r--r--plugins/subtac/test/measure.v20
-rw-r--r--plugins/subtac/test/rec.v65
-rw-r--r--plugins/subtac/test/take.v34
-rw-r--r--plugins/subtac/test/wf.v48
-rw-r--r--plugins/syntax/ascii_syntax.ml83
-rw-r--r--plugins/syntax/ascii_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/nat_syntax.ml78
-rw-r--r--plugins/syntax/nat_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/numbers_syntax.ml330
-rw-r--r--plugins/syntax/numbers_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/r_syntax.ml125
-rw-r--r--plugins/syntax/r_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/string_syntax.ml69
-rw-r--r--plugins/syntax/string_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/z_syntax.ml194
-rw-r--r--plugins/syntax/z_syntax_plugin.mllib2
-rw-r--r--plugins/xml/COPYRIGHT25
-rw-r--r--plugins/xml/README254
-rw-r--r--plugins/xml/acic.ml108
-rw-r--r--plugins/xml/acic2Xml.ml4363
-rw-r--r--plugins/xml/cic.dtd259
-rw-r--r--plugins/xml/cic2Xml.ml17
-rw-r--r--plugins/xml/cic2acic.ml942
-rw-r--r--plugins/xml/doubleTypeInference.ml272
-rw-r--r--plugins/xml/doubleTypeInference.mli24
-rw-r--r--plugins/xml/dumptree.ml4152
-rw-r--r--plugins/xml/proof2aproof.ml176
-rw-r--r--plugins/xml/proofTree2Xml.ml4210
-rw-r--r--plugins/xml/theoryobject.dtd62
-rw-r--r--plugins/xml/unshare.ml52
-rw-r--r--plugins/xml/unshare.mli21
-rw-r--r--plugins/xml/xml.ml478
-rw-r--r--plugins/xml/xml.mli40
-rw-r--r--plugins/xml/xml_plugin.mllib13
-rw-r--r--plugins/xml/xmlcommand.ml719
-rw-r--r--plugins/xml/xmlcommand.mli41
-rw-r--r--plugins/xml/xmlentries.ml440
279 files changed, 80280 insertions, 0 deletions
diff --git a/plugins/cc/README b/plugins/cc/README
new file mode 100644
index 00000000..073b140e
--- /dev/null
+++ b/plugins/cc/README
@@ -0,0 +1,20 @@
+
+cctac: congruence-closure for coq
+
+author: Pierre Corbineau,
+ Stage de DEA au LSV, ENS Cachan
+ Thèse au LRI, Université Paris Sud XI
+
+Files :
+
+- ccalgo.ml : congruence closure algorithm
+- ccproof.ml : proof generation code
+- cctac.ml4 : the tactic itself
+- CCSolve.v : a small Ltac tactic based on congruence
+
+Known Bugs : the congruence tactic can fail due to type dependencies.
+
+Related documents:
+ Peter J. Downey, Ravi Sethi, and Robert E. Tarjan.
+ Variations on the common subexpression problem.
+ JACM, 27(4):758-771, October 1980.
diff --git a/plugins/cc/cc_plugin.mllib b/plugins/cc/cc_plugin.mllib
new file mode 100644
index 00000000..1bcfc537
--- /dev/null
+++ b/plugins/cc/cc_plugin.mllib
@@ -0,0 +1,5 @@
+Ccalgo
+Ccproof
+Cctac
+G_congruence
+Cc_plugin_mod
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
new file mode 100644
index 00000000..9cc6f9de
--- /dev/null
+++ b/plugins/cc/ccalgo.ml
@@ -0,0 +1,884 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* This file implements the basic congruence-closure algorithm by *)
+(* Downey,Sethi and Tarjan. *)
+
+open Util
+open Pp
+open Goptions
+open Names
+open Term
+open Tacmach
+open Evd
+open Proof_type
+
+let init_size=5
+
+let cc_verbose=ref false
+
+let debug f x =
+ if !cc_verbose then f x
+
+let _=
+ let gdopt=
+ { optsync=true;
+ optname="Congruence Verbose";
+ optkey=["Congruence";"Verbose"];
+ optread=(fun ()-> !cc_verbose);
+ optwrite=(fun b -> cc_verbose := b)}
+ in
+ declare_bool_option gdopt
+
+(* Signature table *)
+
+module ST=struct
+
+ (* l: sign -> term r: term -> sign *)
+
+ type t = {toterm:(int*int,int) Hashtbl.t;
+ tosign:(int,int*int) Hashtbl.t}
+
+ let empty ()=
+ {toterm=Hashtbl.create init_size;
+ tosign=Hashtbl.create init_size}
+
+ let enter t sign st=
+ if Hashtbl.mem st.toterm sign then
+ anomaly "enter: signature already entered"
+ else
+ Hashtbl.replace st.toterm sign t;
+ Hashtbl.replace st.tosign t sign
+
+ let query sign st=Hashtbl.find st.toterm sign
+
+ let rev_query term st=Hashtbl.find st.tosign term
+
+ let delete st t=
+ try let sign=Hashtbl.find st.tosign t in
+ Hashtbl.remove st.toterm sign;
+ Hashtbl.remove st.tosign t
+ with
+ Not_found -> ()
+
+ let rec delete_set st s = Intset.iter (delete st) s
+
+end
+
+type pa_constructor=
+ { cnode : int;
+ arity : int;
+ args : int list}
+
+type pa_fun=
+ {fsym:int;
+ fnargs:int}
+
+type pa_mark=
+ Fmark of pa_fun
+ | Cmark of pa_constructor
+
+module PacMap=Map.Make(struct
+ type t=pa_constructor
+ let compare=Pervasives.compare end)
+
+module PafMap=Map.Make(struct
+ type t=pa_fun
+ let compare=Pervasives.compare end)
+
+type cinfo=
+ {ci_constr: constructor; (* inductive type *)
+ ci_arity: int; (* # args *)
+ ci_nhyps: int} (* # projectable args *)
+
+type term=
+ Symb of constr
+ | Product of sorts_family * sorts_family
+ | Eps of identifier
+ | Appli of term*term
+ | Constructor of cinfo (* constructor arity + nhyps *)
+
+type ccpattern =
+ PApp of term * ccpattern list (* arguments are reversed *)
+ | PVar of int
+
+type rule=
+ Congruence
+ | Axiom of constr * bool
+ | Injection of int * pa_constructor * int * pa_constructor * int
+
+type from=
+ Goal
+ | Hyp of constr
+ | HeqG of constr
+ | HeqnH of constr * constr
+
+type 'a eq = {lhs:int;rhs:int;rule:'a}
+
+type equality = rule eq
+
+type disequality = from eq
+
+type patt_kind =
+ Normal
+ | Trivial of types
+ | Creates_variables
+
+type quant_eq =
+ {qe_hyp_id: identifier;
+ qe_pol: bool;
+ qe_nvars:int;
+ qe_lhs: ccpattern;
+ qe_lhs_valid:patt_kind;
+ qe_rhs: ccpattern;
+ qe_rhs_valid:patt_kind}
+
+let swap eq : equality =
+ let swap_rule=match eq.rule with
+ Congruence -> Congruence
+ | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k)
+ | Axiom (id,reversed) -> Axiom (id,not reversed)
+ in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule}
+
+type inductive_status =
+ Unknown
+ | Partial of pa_constructor
+ | Partial_applied
+ | Total of (int * pa_constructor)
+
+type representative=
+ {mutable weight:int;
+ mutable lfathers:Intset.t;
+ mutable fathers:Intset.t;
+ mutable inductive_status: inductive_status;
+ class_type : Term.types;
+ mutable functions: Intset.t PafMap.t;
+ mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *)
+
+type cl = Rep of representative| Eqto of int*equality
+
+type vertex = Leaf| Node of (int*int)
+
+type node =
+ {mutable clas:cl;
+ mutable cpath: int;
+ vertex:vertex;
+ term:term}
+
+type forest=
+ {mutable max_size:int;
+ mutable size:int;
+ mutable map: node array;
+ axioms: (constr,term*term) Hashtbl.t;
+ mutable epsilons: pa_constructor list;
+ syms:(term,int) Hashtbl.t}
+
+type state =
+ {uf: forest;
+ sigtable:ST.t;
+ mutable terms: Intset.t;
+ combine: equality Queue.t;
+ marks: (int * pa_mark) Queue.t;
+ mutable diseq: disequality list;
+ mutable quant: quant_eq list;
+ mutable pa_classes: Intset.t;
+ q_history: (identifier,int array) Hashtbl.t;
+ mutable rew_depth:int;
+ mutable changed:bool;
+ by_type: (types,Intset.t) Hashtbl.t;
+ mutable gls:Proof_type.goal Tacmach.sigma}
+
+let dummy_node =
+ {clas=Eqto(min_int,{lhs=min_int;rhs=min_int;rule=Congruence});
+ cpath=min_int;
+ vertex=Leaf;
+ term=Symb (mkRel min_int)}
+
+let empty depth gls:state =
+ {uf=
+ {max_size=init_size;
+ size=0;
+ map=Array.create init_size dummy_node;
+ epsilons=[];
+ axioms=Hashtbl.create init_size;
+ syms=Hashtbl.create init_size};
+ terms=Intset.empty;
+ combine=Queue.create ();
+ marks=Queue.create ();
+ sigtable=ST.empty ();
+ diseq=[];
+ quant=[];
+ pa_classes=Intset.empty;
+ q_history=Hashtbl.create init_size;
+ rew_depth=depth;
+ by_type=Hashtbl.create init_size;
+ changed=false;
+ gls=gls}
+
+let forest state = state.uf
+
+let compress_path uf i j = uf.map.(j).cpath<-i
+
+let rec find_aux uf visited i=
+ let j = uf.map.(i).cpath in
+ if j<0 then let _ = List.iter (compress_path uf i) visited in i else
+ find_aux uf (i::visited) j
+
+let find uf i= find_aux uf [] i
+
+let get_representative uf i=
+ match uf.map.(i).clas with
+ Rep r -> r
+ | _ -> anomaly "get_representative: not a representative"
+
+let find_pac uf i pac =
+ PacMap.find pac (get_representative uf i).constructors
+
+let get_constructor_info uf i=
+ match uf.map.(i).term with
+ Constructor cinfo->cinfo
+ | _ -> anomaly "get_constructor: not a constructor"
+
+let size uf i=
+ (get_representative uf i).weight
+
+let axioms uf = uf.axioms
+
+let epsilons uf = uf.epsilons
+
+let add_lfather uf i t=
+ let r=get_representative uf i in
+ r.weight<-r.weight+1;
+ r.lfathers<-Intset.add t r.lfathers;
+ r.fathers <-Intset.add t r.fathers
+
+let add_rfather uf i t=
+ let r=get_representative uf i in
+ r.weight<-r.weight+1;
+ r.fathers <-Intset.add t r.fathers
+
+exception Discriminable of int * pa_constructor * int * pa_constructor
+
+let append_pac t p =
+ {p with arity=pred p.arity;args=t::p.args}
+
+let tail_pac p=
+ {p with arity=succ p.arity;args=List.tl p.args}
+
+let fsucc paf =
+ {paf with fnargs=succ paf.fnargs}
+
+let add_pac rep pac t =
+ if not (PacMap.mem pac rep.constructors) then
+ rep.constructors<-PacMap.add pac t rep.constructors
+
+let add_paf rep paf t =
+ let already =
+ try PafMap.find paf rep.functions with Not_found -> Intset.empty in
+ rep.functions<- PafMap.add paf (Intset.add t already) rep.functions
+
+let term uf i=uf.map.(i).term
+
+let subterms uf i=
+ match uf.map.(i).vertex with
+ Node(j,k) -> (j,k)
+ | _ -> anomaly "subterms: not a node"
+
+let signature uf i=
+ let j,k=subterms uf i in (find uf j,find uf k)
+
+let next uf=
+ let size=uf.size in
+ let nsize= succ size in
+ if nsize=uf.max_size then
+ let newmax=uf.max_size * 3 / 2 + 1 in
+ let newmap=Array.create newmax dummy_node in
+ begin
+ uf.max_size<-newmax;
+ Array.blit uf.map 0 newmap 0 size;
+ uf.map<-newmap
+ end
+ else ();
+ uf.size<-nsize;
+ size
+
+let new_representative typ =
+ {weight=0;
+ lfathers=Intset.empty;
+ fathers=Intset.empty;
+ inductive_status=Unknown;
+ class_type=typ;
+ functions=PafMap.empty;
+ constructors=PacMap.empty}
+
+(* rebuild a constr from an applicative term *)
+
+let _A_ = Name (id_of_string "A")
+let _B_ = Name (id_of_string "A")
+let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2)
+
+let cc_product s1 s2 =
+ mkLambda(_A_,mkSort(Termops.new_sort_in_family s1),
+ mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_))
+
+let rec constr_of_term = function
+ Symb s->s
+ | Product(s1,s2) -> cc_product s1 s2
+ | Eps id -> mkVar id
+ | Constructor cinfo -> mkConstruct cinfo.ci_constr
+ | Appli (s1,s2)->
+ make_app [(constr_of_term s2)] s1
+and make_app l=function
+ Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1
+ | other -> applistc (constr_of_term other) l
+
+(* rebuild a term from a pattern and a substitution *)
+
+let build_subst uf subst =
+ Array.map (fun i ->
+ try term uf i
+ with _ -> anomaly "incomplete matching") subst
+
+let rec inst_pattern subst = function
+ PVar i ->
+ subst.(pred i)
+ | PApp (t, args) ->
+ List.fold_right
+ (fun spat f -> Appli (f,inst_pattern subst spat))
+ args t
+
+let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++
+ Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]"
+
+let pr_term t = str "[" ++
+ Termops.print_constr (constr_of_term t) ++ str "]"
+
+let rec add_term state t=
+ let uf=state.uf in
+ try Hashtbl.find uf.syms t with
+ Not_found ->
+ let b=next uf in
+ let typ = pf_type_of state.gls (constr_of_term t) in
+ let new_node=
+ match t with
+ Symb _ | Product (_,_) ->
+ let paf =
+ {fsym=b;
+ fnargs=0} in
+ Queue.add (b,Fmark paf) state.marks;
+ {clas= Rep (new_representative typ);
+ cpath= -1;
+ vertex= Leaf;
+ term= t}
+ | Eps id ->
+ {clas= Rep (new_representative typ);
+ cpath= -1;
+ vertex= Leaf;
+ term= t}
+ | Appli (t1,t2) ->
+ let i1=add_term state t1 and i2=add_term state t2 in
+ add_lfather uf (find uf i1) b;
+ add_rfather uf (find uf i2) b;
+ state.terms<-Intset.add b state.terms;
+ {clas= Rep (new_representative typ);
+ cpath= -1;
+ vertex= Node(i1,i2);
+ term= t}
+ | Constructor cinfo ->
+ let paf =
+ {fsym=b;
+ fnargs=0} in
+ Queue.add (b,Fmark paf) state.marks;
+ let pac =
+ {cnode= b;
+ arity= cinfo.ci_arity;
+ args=[]} in
+ Queue.add (b,Cmark pac) state.marks;
+ {clas=Rep (new_representative typ);
+ cpath= -1;
+ vertex=Leaf;
+ term=t}
+ in
+ uf.map.(b)<-new_node;
+ Hashtbl.add uf.syms t b;
+ Hashtbl.replace state.by_type typ
+ (Intset.add b
+ (try Hashtbl.find state.by_type typ with
+ Not_found -> Intset.empty));
+ b
+
+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)
+
+let add_disequality state from s t =
+ let i = add_term state s in
+ let j = add_term state t in
+ state.diseq<-{lhs=i;rhs=j;rule=from}::state.diseq
+
+let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) =
+ state.quant<-
+ {qe_hyp_id= id;
+ qe_pol= pol;
+ qe_nvars=nvars;
+ qe_lhs= patt1;
+ qe_lhs_valid=valid1;
+ qe_rhs= patt2;
+ qe_rhs_valid=valid2}::state.quant
+
+let 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
+ List.exists
+ (fun old_args ->
+ Util.array_for_all2 (fun i j -> i = find state.uf j)
+ norm_args old_args)
+ prev_args
+ with Not_found -> false
+
+let add_inst state (inst,int_subst) =
+ check_for_interrupt ();
+ if state.rew_depth > 0 then
+ if is_redundant state inst.qe_hyp_id int_subst then
+ debug msgnl (str "discarding redundant (dis)equality")
+ else
+ begin
+ Hashtbl.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
+ let _ = array_rev args in (* highest deBruijn index first *)
+ let prf= mkApp(prfhead,args) in
+ let s = inst_pattern subst inst.qe_lhs
+ and t = inst_pattern subst inst.qe_rhs in
+ state.changed<-true;
+ state.rew_depth<-pred state.rew_depth;
+ if inst.qe_pol then
+ begin
+ debug (fun () ->
+ msgnl
+ (str "Adding new equality, depth="++ int state.rew_depth);
+ msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++
+ pr_term s ++ str " == " ++ pr_term t ++ str "]")) ();
+ add_equality state prf s t
+ end
+ else
+ begin
+ debug (fun () ->
+ msgnl
+ (str "Adding new disequality, depth="++ int state.rew_depth);
+ msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++
+ pr_term s ++ str " <> " ++ pr_term t ++ str "]")) ();
+ add_disequality state (Hyp prf) s t
+ end
+ end
+
+let link uf i j eq = (* links i -> j *)
+ let node=uf.map.(i) in
+ node.clas<-Eqto (j,eq);
+ node.cpath<-j
+
+let rec down_path uf i l=
+ match uf.map.(i).clas with
+ Eqto(j,t)->down_path uf j (((i,j),t)::l)
+ | Rep _ ->l
+
+let rec min_path=function
+ ([],l2)->([],l2)
+ | (l1,[])->(l1,[])
+ | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2)
+ | cpl -> cpl
+
+let join_path uf i j=
+ assert (find uf i=find uf j);
+ min_path (down_path uf i [],down_path uf j [])
+
+let union state i1 i2 eq=
+ debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++
+ str " and " ++ pr_idx_term state i2 ++ str ".")) ();
+ 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
+ (Intset.remove i1
+ (try Hashtbl.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;
+ r2.fathers<-f;
+ r2.lfathers<-Intset.union r1.lfathers r2.lfathers;
+ ST.delete_set state.sigtable r1.fathers;
+ state.terms<-Intset.union state.terms r1.fathers;
+ PacMap.iter
+ (fun pac b -> Queue.add (b,Cmark pac) state.marks)
+ r1.constructors;
+ PafMap.iter
+ (fun paf -> Intset.iter
+ (fun b -> Queue.add (b,Fmark paf) state.marks))
+ r1.functions;
+ match r1.inductive_status,r2.inductive_status with
+ Unknown,_ -> ()
+ | Partial pac,Unknown ->
+ r2.inductive_status<-Partial pac;
+ state.pa_classes<-Intset.remove i1 state.pa_classes;
+ state.pa_classes<-Intset.add i2 state.pa_classes
+ | Partial _ ,(Partial _ |Partial_applied) ->
+ state.pa_classes<-Intset.remove i1 state.pa_classes
+ | Partial_applied,Unknown ->
+ r2.inductive_status<-Partial_applied
+ | Partial_applied,Partial _ ->
+ state.pa_classes<-Intset.remove i2 state.pa_classes;
+ r2.inductive_status<-Partial_applied
+ | Total cpl,Unknown -> r2.inductive_status<-Total cpl;
+ | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks
+ | _,_ -> ()
+
+let merge eq state = (* merge and no-merge *)
+ debug (fun () -> msgnl
+ (str "Merging " ++ pr_idx_term state eq.lhs ++
+ str " and " ++ pr_idx_term state eq.rhs ++ str ".")) ();
+ let uf=state.uf in
+ let i=find uf eq.lhs
+ and j=find uf eq.rhs in
+ if i<>j then
+ if (size uf i)<(size uf j) then
+ union state i j eq
+ else
+ union state j i (swap eq)
+
+let update t state = (* update 1 and 2 *)
+ debug (fun () -> msgnl
+ (str "Updating term " ++ pr_idx_term state t ++ str ".")) ();
+ let (i,j) as sign = signature state.uf t in
+ let (u,v) = subterms state.uf t in
+ let rep = get_representative state.uf i in
+ begin
+ match rep.inductive_status with
+ Partial _ ->
+ rep.inductive_status <- Partial_applied;
+ state.pa_classes <- Intset.remove i state.pa_classes
+ | _ -> ()
+ end;
+ PacMap.iter
+ (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks)
+ rep.constructors;
+ PafMap.iter
+ (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks)
+ rep.functions;
+ try
+ let s = ST.query sign state.sigtable in
+ Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine
+ with
+ Not_found -> ST.enter t sign state.sigtable
+
+let process_function_mark t rep paf state =
+ add_paf rep paf t;
+ state.terms<-Intset.union rep.lfathers state.terms
+
+let process_constructor_mark t i rep pac state =
+ match rep.inductive_status with
+ Total (s,opac) ->
+ if pac.cnode <> opac.cnode then (* Conflict *)
+ raise (Discriminable (s,opac,t,pac))
+ else (* Match *)
+ let cinfo = get_constructor_info state.uf pac.cnode in
+ let rec f n oargs args=
+ if n > 0 then
+ match (oargs,args) with
+ s1::q1,s2::q2->
+ Queue.add
+ {lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)}
+ state.combine;
+ f (n-1) q1 q2
+ | _-> anomaly
+ "add_pacs : weird error in injection subterms merge"
+ in f cinfo.ci_nhyps opac.args pac.args
+ | Partial_applied | Partial _ ->
+ add_pac rep pac t;
+ state.terms<-Intset.union rep.lfathers state.terms
+ | Unknown ->
+ if pac.arity = 0 then
+ rep.inductive_status <- Total (t,pac)
+ else
+ begin
+ add_pac rep pac t;
+ state.terms<-Intset.union rep.lfathers state.terms;
+ rep.inductive_status <- Partial pac;
+ state.pa_classes<- Intset.add i state.pa_classes
+ end
+
+let process_mark t m state =
+ debug (fun () -> msgnl
+ (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) ();
+ let i=find state.uf t in
+ let rep=get_representative state.uf i in
+ match m with
+ Fmark paf -> process_function_mark t rep paf state
+ | Cmark pac -> process_constructor_mark t i rep pac state
+
+type explanation =
+ Discrimination of (int*pa_constructor*int*pa_constructor)
+ | Contradiction of disequality
+ | Incomplete
+
+let check_disequalities state =
+ let uf=state.uf in
+ let rec check_aux = function
+ dis::q ->
+ debug (fun () -> msg
+ (str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++
+ pr_idx_term state dis.rhs ++ str " ... ")) ();
+ if find uf dis.lhs=find uf dis.rhs then
+ begin debug msgnl (str "Yes");Some dis end
+ else
+ begin debug msgnl (str "No");check_aux q end
+ | [] -> None
+ in
+ check_aux state.diseq
+
+let one_step state =
+ try
+ let eq = Queue.take state.combine in
+ merge eq state;
+ true
+ with Queue.Empty ->
+ try
+ let (t,m) = Queue.take state.marks in
+ process_mark t m state;
+ true
+ with Queue.Empty ->
+ try
+ let t = Intset.choose state.terms in
+ state.terms<-Intset.remove t state.terms;
+ update t state;
+ true
+ with Not_found -> false
+
+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}};
+ id
+
+let complete_one_class state i=
+ match (get_representative state.uf i).inductive_status with
+ Partial pac ->
+ let rec app t typ n =
+ if n<=0 then t else
+ let _,etyp,rest= destProd typ in
+ let id = new_state_var etyp state in
+ app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in
+ let _c = pf_type_of state.gls
+ (constr_of_term (term state.uf pac.cnode)) in
+ let _args =
+ List.map (fun i -> constr_of_term (term state.uf i))
+ pac.args in
+ let typ = prod_applist _c (List.rev _args) in
+ let ct = app (term state.uf i) typ pac.arity in
+ state.uf.epsilons <- pac :: state.uf.epsilons;
+ ignore (add_term state ct)
+ | _ -> anomaly "wrong incomplete class"
+
+let complete state =
+ Intset.iter (complete_one_class state) state.pa_classes
+
+type matching_problem =
+{mp_subst : int array;
+ mp_inst : quant_eq;
+ mp_stack : (ccpattern*int) list }
+
+let make_fun_table state =
+ let uf= state.uf in
+ let funtab=ref PafMap.empty in
+ Array.iteri
+ (fun i inode -> if i < uf.size then
+ match inode.clas with
+ Rep rep ->
+ PafMap.iter
+ (fun paf _ ->
+ let elem =
+ try PafMap.find paf !funtab
+ with Not_found -> Intset.empty in
+ funtab:= PafMap.add paf (Intset.add i elem) !funtab)
+ rep.functions
+ | _ -> ()) state.uf.map;
+ !funtab
+
+
+let rec do_match state res pb_stack =
+ let mp=Stack.pop pb_stack in
+ match mp.mp_stack with
+ [] ->
+ res:= (mp.mp_inst,mp.mp_subst) :: !res
+ | (patt,cl)::remains ->
+ let uf=state.uf in
+ match patt with
+ PVar i ->
+ if mp.mp_subst.(pred i)<0 then
+ begin
+ mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *)
+ Stack.push {mp with mp_stack=remains} pb_stack
+ end
+ else
+ if mp.mp_subst.(pred i) = cl then
+ Stack.push {mp with mp_stack=remains} pb_stack
+ else (* mismatch for non-linear variable in pattern *) ()
+ | PApp (f,[]) ->
+ begin
+ try let j=Hashtbl.find uf.syms f in
+ if find uf j =cl then
+ Stack.push {mp with mp_stack=remains} pb_stack
+ with Not_found -> ()
+ end
+ | PApp(f, ((last_arg::rem_args) as args)) ->
+ try
+ let j=Hashtbl.find uf.syms f in
+ let paf={fsym=j;fnargs=List.length args} in
+ let rep=get_representative uf cl in
+ let good_terms = PafMap.find paf rep.functions in
+ let aux i =
+ let (s,t) = signature state.uf i in
+ Stack.push
+ {mp with
+ mp_subst=Array.copy mp.mp_subst;
+ mp_stack=
+ (PApp(f,rem_args),s) ::
+ (last_arg,t) :: remains} pb_stack in
+ Intset.iter aux good_terms
+ with Not_found -> ()
+
+let paf_of_patt syms = function
+ PVar _ -> invalid_arg "paf_of_patt: pattern is trivial"
+ | PApp (f,args) ->
+ {fsym=Hashtbl.find syms f;
+ fnargs=List.length args}
+
+let init_pb_stack state =
+ let syms= state.uf.syms in
+ let pb_stack = Stack.create () in
+ let funtab = make_fun_table state in
+ let aux inst =
+ begin
+ let good_classes =
+ match inst.qe_lhs_valid with
+ Creates_variables -> Intset.empty
+ | Normal ->
+ begin
+ try
+ let paf= paf_of_patt syms inst.qe_lhs in
+ PafMap.find paf funtab
+ with Not_found -> Intset.empty
+ end
+ | Trivial typ ->
+ begin
+ try
+ Hashtbl.find state.by_type typ
+ with Not_found -> Intset.empty
+ end in
+ Intset.iter (fun i ->
+ Stack.push
+ {mp_subst = Array.make inst.qe_nvars (-1);
+ mp_inst=inst;
+ mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes
+ end;
+ begin
+ let good_classes =
+ match inst.qe_rhs_valid with
+ Creates_variables -> Intset.empty
+ | Normal ->
+ begin
+ try
+ let paf= paf_of_patt syms inst.qe_rhs in
+ PafMap.find paf funtab
+ with Not_found -> Intset.empty
+ end
+ | Trivial typ ->
+ begin
+ try
+ Hashtbl.find state.by_type typ
+ with Not_found -> Intset.empty
+ end in
+ Intset.iter (fun i ->
+ Stack.push
+ {mp_subst = Array.make inst.qe_nvars (-1);
+ mp_inst=inst;
+ mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes
+ end in
+ List.iter aux state.quant;
+ pb_stack
+
+let find_instances state =
+ let pb_stack= init_pb_stack state in
+ let res =ref [] in
+ let _ =
+ debug msgnl (str "Running E-matching algorithm ... ");
+ try
+ while true do
+ check_for_interrupt ();
+ do_match state res pb_stack
+ done;
+ anomaly "get out of here !"
+ with Stack.Empty -> () in
+ !res
+
+let rec execute first_run state =
+ debug msgnl (str "Executing ... ");
+ try
+ while
+ check_for_interrupt ();
+ one_step state do ()
+ done;
+ match check_disequalities state with
+ None ->
+ if not(Intset.is_empty state.pa_classes) then
+ begin
+ debug msgnl (str "First run was incomplete, completing ... ");
+ complete state;
+ execute false state
+ end
+ else
+ if state.rew_depth>0 then
+ let l=find_instances state in
+ List.iter (add_inst state) l;
+ if state.changed then
+ begin
+ state.changed <- false;
+ execute true state
+ end
+ else
+ begin
+ debug msgnl (str "Out of instances ... ");
+ None
+ end
+ else
+ begin
+ debug msgnl (str "Out of depth ... ");
+ None
+ end
+ | Some dis -> Some
+ begin
+ if first_run then Contradiction dis
+ else Incomplete
+ end
+ with Discriminable(s,spac,t,tpac) -> Some
+ begin
+ if first_run then Discrimination (s,spac,t,tpac)
+ else Incomplete
+ end
+
+
diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
new file mode 100644
index 00000000..5f56c7e6
--- /dev/null
+++ b/plugins/cc/ccalgo.mli
@@ -0,0 +1,222 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Util
+open Term
+open Names
+
+type cinfo =
+ {ci_constr: constructor; (* inductive type *)
+ ci_arity: int; (* # args *)
+ ci_nhyps: int} (* # projectable args *)
+
+type term =
+ Symb of constr
+ | Product of sorts_family * sorts_family
+ | Eps of identifier
+ | Appli of term*term
+ | Constructor of cinfo (* constructor arity + nhyps *)
+
+type patt_kind =
+ Normal
+ | Trivial of types
+ | Creates_variables
+
+type ccpattern =
+ PApp of term * ccpattern list
+ | PVar of int
+
+type pa_constructor =
+ { cnode : int;
+ arity : int;
+ args : int list}
+
+module PacMap : Map.S with type key = pa_constructor
+
+type forest
+
+type state
+
+type rule=
+ Congruence
+ | Axiom of constr * bool
+ | Injection of int * pa_constructor * int * pa_constructor * int
+
+type from=
+ Goal
+ | Hyp of constr
+ | HeqG of constr
+ | HeqnH of constr*constr
+
+type 'a eq = {lhs:int;rhs:int;rule:'a}
+
+type equality = rule eq
+
+type disequality = from eq
+
+type explanation =
+ Discrimination of (int*pa_constructor*int*pa_constructor)
+ | Contradiction of disequality
+ | Incomplete
+
+val constr_of_term : term -> constr
+
+val debug : (Pp.std_ppcmds -> unit) -> Pp.std_ppcmds -> unit
+
+val forest : state -> forest
+
+val axioms : forest -> (constr, term * term) Hashtbl.t
+
+val epsilons : forest -> pa_constructor list
+
+val empty : int -> Proof_type.goal Tacmach.sigma -> state
+
+val add_term : state -> term -> int
+
+val add_equality : state -> constr -> term -> term -> unit
+
+val add_disequality : state -> from -> term -> term -> unit
+
+val add_quant : state -> identifier -> bool ->
+ int * patt_kind * ccpattern * patt_kind * ccpattern -> unit
+
+val tail_pac : pa_constructor -> pa_constructor
+
+val find : forest -> int -> int
+
+val find_pac : forest -> int -> pa_constructor -> int
+
+val term : forest -> int -> term
+
+val get_constructor_info : forest -> int -> cinfo
+
+val subterms : forest -> int -> int * int
+
+val join_path : forest -> int -> int ->
+ ((int * int) * equality) list * ((int * int) * equality) list
+
+type quant_eq=
+ {qe_hyp_id: identifier;
+ qe_pol: bool;
+ qe_nvars:int;
+ qe_lhs: ccpattern;
+ qe_lhs_valid:patt_kind;
+ qe_rhs: ccpattern;
+ qe_rhs_valid:patt_kind}
+
+
+type pa_fun=
+ {fsym:int;
+ fnargs:int}
+
+type matching_problem
+
+module PafMap: Map.S with type key = pa_fun
+
+val make_fun_table : state -> Intset.t PafMap.t
+
+val do_match : state ->
+ (quant_eq * int array) list ref -> matching_problem Stack.t -> unit
+
+val init_pb_stack : state -> matching_problem Stack.t
+
+val paf_of_patt : (term, int) Hashtbl.t -> ccpattern -> pa_fun
+
+val find_instances : state -> (quant_eq * int array) list
+
+val execute : bool -> state -> explanation option
+
+
+
+
+
+
+
+
+
+
+
+
+
+(*type pa_constructor
+
+
+module PacMap:Map.S with type key=pa_constructor
+
+type term =
+ Symb of Term.constr
+ | Eps
+ | Appli of term * term
+ | Constructor of Names.constructor*int*int
+
+type rule =
+ Congruence
+ | Axiom of Names.identifier
+ | Injection of int*int*int*int
+
+type equality =
+ {lhs : int;
+ rhs : int;
+ rule : rule}
+
+module ST :
+sig
+ type t
+ val empty : unit -> t
+ val enter : int -> int * int -> t -> unit
+ val query : int * int -> t -> int
+ val delete : int -> t -> unit
+ val delete_list : int list -> t -> unit
+end
+
+module UF :
+sig
+ type t
+ exception Discriminable of int * int * int * int * t
+ val empty : unit -> t
+ val find : t -> int -> int
+ val size : t -> int -> int
+ val get_constructor : t -> int -> Names.constructor
+ val pac_arity : t -> int -> int * int -> int
+ val mem_node_pac : t -> int -> int * int -> int
+ val add_pacs : t -> int -> pa_constructor PacMap.t ->
+ int list * equality list
+ val term : t -> int -> term
+ val subterms : t -> int -> int * int
+ val add : t -> term -> int
+ val union : t -> int -> int -> equality -> int list * equality list
+ val join_path : t -> int -> int ->
+ ((int*int)*equality) list*
+ ((int*int)*equality) list
+end
+
+
+val combine_rec : UF.t -> int list -> equality list
+val process_rec : UF.t -> equality list -> int list
+
+val cc : UF.t -> unit
+
+val make_uf :
+ (Names.identifier * (term * term)) list -> UF.t
+
+val add_one_diseq : UF.t -> (term * term) -> int * int
+
+val add_disaxioms :
+ UF.t -> (Names.identifier * (term * term)) list ->
+ (Names.identifier * (int * int)) list
+
+val check_equal : UF.t -> int * int -> bool
+
+val find_contradiction : UF.t ->
+ (Names.identifier * (int * int)) list ->
+ (Names.identifier * (int * int))
+*)
+
+
diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml
new file mode 100644
index 00000000..2a019ebf
--- /dev/null
+++ b/plugins/cc/ccproof.ml
@@ -0,0 +1,153 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* This file uses the (non-compressed) union-find structure to generate *)
+(* proof-trees that will be transformed into proof-terms in cctac.ml4 *)
+
+open Util
+open Names
+open Term
+open Ccalgo
+
+type rule=
+ Ax of constr
+ | SymAx of constr
+ | Refl of term
+ | Trans of proof*proof
+ | Congr of proof*proof
+ | Inject of proof*constructor*int*int
+and proof =
+ {p_lhs:term;p_rhs:term;p_rule:rule}
+
+let prefl t = {p_lhs=t;p_rhs=t;p_rule=Refl t}
+
+let pcongr p1 p2 =
+ match p1.p_rule,p2.p_rule with
+ Refl t1, Refl t2 -> prefl (Appli (t1,t2))
+ | _, _ ->
+ {p_lhs=Appli (p1.p_lhs,p2.p_lhs);
+ p_rhs=Appli (p1.p_rhs,p2.p_rhs);
+ p_rule=Congr (p1,p2)}
+
+let rec ptrans p1 p3=
+ match p1.p_rule,p3.p_rule with
+ Refl _, _ ->p3
+ | _, Refl _ ->p1
+ | Trans(p1,p2), _ ->ptrans p1 (ptrans p2 p3)
+ | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4)
+ | 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
+ {p_lhs=p1.p_lhs;
+ p_rhs=p3.p_rhs;
+ p_rule=Trans (p1,p3)}
+ else anomaly "invalid cc transitivity"
+
+let rec psym p =
+ match p.p_rule with
+ Refl _ -> p
+ | SymAx s ->
+ {p_lhs=p.p_rhs;
+ p_rhs=p.p_lhs;
+ p_rule=Ax s}
+ | Ax s->
+ {p_lhs=p.p_rhs;
+ p_rhs=p.p_lhs;
+ p_rule=SymAx s}
+ | Inject (p0,c,n,a)->
+ {p_lhs=p.p_rhs;
+ p_rhs=p.p_lhs;
+ p_rule=Inject (psym p0,c,n,a)}
+ | Trans (p1,p2)-> ptrans (psym p2) (psym p1)
+ | Congr (p1,p2)-> pcongr (psym p1) (psym p2)
+
+let pax axioms s =
+ let l,r = Hashtbl.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
+ {p_lhs=r;
+ p_rhs=l;
+ p_rule=SymAx s}
+
+let rec nth_arg t n=
+ match t with
+ Appli (t1,t2)->
+ if n>0 then
+ nth_arg t1 (n-1)
+ else t2
+ | _ -> anomaly "nth_arg: not enough args"
+
+let pinject p c n a =
+ {p_lhs=nth_arg p.p_lhs (n-a);
+ p_rhs=nth_arg p.p_rhs (n-a);
+ p_rule=Inject(p,c,n,a)}
+
+let build_proof uf=
+
+ let axioms = axioms uf in
+
+ let rec equal_proof i j=
+ if i=j then prefl (term uf i) else
+ let (li,lj)=join_path uf i j in
+ ptrans (path_proof i li) (psym (path_proof j lj))
+
+ and edge_proof ((i,j),eq)=
+ let pi=equal_proof i eq.lhs in
+ let pj=psym (equal_proof j eq.rhs) in
+ let pij=
+ match eq.rule with
+ Axiom (s,reversed)->
+ if reversed then psymax axioms s
+ else pax axioms s
+ | Congruence ->congr_proof eq.lhs eq.rhs
+ | Injection (ti,ipac,tj,jpac,k) ->
+ let p=ind_proof ti ipac tj jpac in
+ let cinfo= get_constructor_info uf ipac.cnode in
+ pinject p cinfo.ci_constr cinfo.ci_nhyps k
+ in ptrans (ptrans pi pij) pj
+
+ and constr_proof i t ipac=
+ if ipac.args=[] then
+ equal_proof i t
+ else
+ let npac=tail_pac ipac in
+ let (j,arg)=subterms uf t in
+ let targ=term uf arg in
+ let rj=find uf j in
+ let u=find_pac uf rj npac in
+ let p=constr_proof j u npac in
+ ptrans (equal_proof i t) (pcongr p (prefl targ))
+
+ and path_proof i=function
+ [] -> prefl (term uf i)
+ | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x)
+
+ and congr_proof i j=
+ let (i1,i2) = subterms uf i
+ and (j1,j2) = subterms uf j in
+ pcongr (equal_proof i1 j1) (equal_proof i2 j2)
+
+ and ind_proof i ipac j jpac=
+ let p=equal_proof i j
+ and p1=constr_proof i i ipac
+ and p2=constr_proof j j jpac in
+ ptrans (psym p1) (ptrans p p2)
+ in
+ function
+ `Prove (i,j) -> equal_proof i j
+ | `Discr (i,ci,j,cj)-> ind_proof i ci j cj
+
+
+
diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli
new file mode 100644
index 00000000..2a0ca688
--- /dev/null
+++ b/plugins/cc/ccproof.mli
@@ -0,0 +1,31 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Ccalgo
+open Names
+open Term
+
+type rule=
+ Ax of constr
+ | SymAx of constr
+ | Refl of term
+ | Trans of proof*proof
+ | Congr of proof*proof
+ | Inject of proof*constructor*int*int
+and proof =
+ private {p_lhs:term;p_rhs:term;p_rule:rule}
+
+val build_proof :
+ forest ->
+ [ `Discr of int * pa_constructor * int * pa_constructor
+ | `Prove of int * int ] -> proof
+
+
+
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
new file mode 100644
index 00000000..4e6ea802
--- /dev/null
+++ b/plugins/cc/cctac.ml
@@ -0,0 +1,465 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+(* This file is the interface between the c-c algorithm and Coq *)
+
+open Evd
+open Proof_type
+open Names
+open Libnames
+open Nameops
+open Inductiveops
+open Declarations
+open Term
+open Termops
+open Tacmach
+open Tactics
+open Tacticals
+open Typing
+open Ccalgo
+open Tacinterp
+open Ccproof
+open Pp
+open Util
+open Format
+
+let constant dir s = lazy (Coqlib.gen_constant "CC" dir s)
+
+let _f_equal = constant ["Init";"Logic"] "f_equal"
+
+let _eq_rect = constant ["Init";"Logic"] "eq_rect"
+
+let _refl_equal = constant ["Init";"Logic"] "refl_equal"
+
+let _sym_eq = constant ["Init";"Logic"] "sym_eq"
+
+let _trans_eq = constant ["Init";"Logic"] "trans_eq"
+
+let _eq = constant ["Init";"Logic"] "eq"
+
+let _False = constant ["Init";"Logic"] "False"
+
+let whd env=
+ let infos=Closure.create_clos_infos Closure.betaiotazeta env in
+ (fun t -> Closure.whd_val infos (Closure.inject t))
+
+let whd_delta env=
+ let infos=Closure.create_clos_infos Closure.betadeltaiota env in
+ (fun t -> Closure.whd_val infos (Closure.inject t))
+
+(* decompose member of equality in an applicative format *)
+
+let sf_of env sigma c = family_of_sort (sort_of env sigma c)
+
+let rec decompose_term env sigma t=
+ match kind_of_term (whd env t) with
+ App (f,args)->
+ 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
+ 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) ,
+ decompose_term env sigma a),
+ decompose_term env sigma b)
+ | Construct c->
+ let (oib,_)=Global.lookup_inductive (fst c) in
+ let nargs=mis_constructor_nargs_env env c in
+ Constructor {ci_constr=c;
+ ci_arity=nargs;
+ ci_nhyps=nargs-oib.mind_nparams}
+ | _ ->if closed0 t then (Symb t) else raise Not_found
+
+(* decompose equality in members and type *)
+
+let atom_of_constr env sigma term =
+ let wh = (whd_delta env term) in
+ let kot = kind_of_term wh in
+ match kot with
+ App (f,args)->
+ if eq_constr f (Lazy.force _eq) && (Array.length args)=3
+ then `Eq (args.(0),
+ decompose_term env sigma args.(1),
+ decompose_term env sigma args.(2))
+ else `Other (decompose_term env sigma term)
+ | _ -> `Other (decompose_term env sigma term)
+
+let rec pattern_of_constr env sigma c =
+ match kind_of_term (whd env c) with
+ App (f,args)->
+ let pf = decompose_term env sigma f in
+ let pargs,lrels = List.split
+ (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
+ let pa,sa = pattern_of_constr env sigma a in
+ let pb,sb = pattern_of_constr env sigma (pop b) in
+ let sort_b = sf_of env sigma b in
+ let sort_a = sf_of env sigma a in
+ PApp(Product (sort_a,sort_b),
+ [pa;pb]),(Intset.union sa sb)
+ | Rel i -> PVar i,Intset.singleton i
+ | _ ->
+ let pf = decompose_term env sigma c in
+ PApp (pf,[]),Intset.empty
+
+let non_trivial = function
+ PVar _ -> false
+ | _ -> true
+
+let patterns_of_constr env sigma nrels term=
+ let f,args=
+ try destApp (whd_delta env term) with _ -> raise Not_found in
+ if eq_constr f (Lazy.force _eq) && (Array.length args)=3
+ then
+ let patt1,rels1 = pattern_of_constr env sigma args.(1)
+ and patt2,rels2 = pattern_of_constr env sigma args.(2) in
+ let valid1 =
+ if Intset.cardinal rels1 <> nrels then Creates_variables
+ else if non_trivial patt1 then Normal
+ else Trivial args.(0)
+ and valid2 =
+ if Intset.cardinal rels2 <> nrels then Creates_variables
+ else if non_trivial patt2 then Normal
+ else Trivial args.(0) in
+ if valid1 <> Creates_variables
+ || valid2 <> Creates_variables then
+ nrels,valid1,patt1,valid2,patt2
+ else raise Not_found
+ else raise Not_found
+
+let rec quantified_atom_of_constr env sigma nrels term =
+ match kind_of_term (whd_delta env term) with
+ Prod (_,atom,ff) ->
+ if eq_constr ff (Lazy.force _False) then
+ let patts=patterns_of_constr env sigma nrels atom in
+ `Nrule patts
+ else
+ quantified_atom_of_constr env sigma (succ nrels) ff
+ | _ ->
+ let patts=patterns_of_constr env sigma nrels term in
+ `Rule patts
+
+let litteral_of_constr env sigma term=
+ match kind_of_term (whd_delta env term) with
+ | Prod (_,atom,ff) ->
+ if eq_constr ff (Lazy.force _False) then
+ match (atom_of_constr env sigma atom) with
+ `Eq(t,a,b) -> `Neq(t,a,b)
+ | `Other(p) -> `Nother(p)
+ else
+ begin
+ try
+ quantified_atom_of_constr env sigma 1 ff
+ with Not_found ->
+ `Other (decompose_term env sigma term)
+ end
+ | _ ->
+ atom_of_constr env sigma term
+
+
+(* store all equalities from the context *)
+
+let rec make_prb gls depth additionnal_terms =
+ let env=pf_env gls in
+ let sigma=sig_sig gls in
+ let state = empty depth gls in
+ let pos_hyps = ref [] in
+ let neg_hyps =ref [] in
+ List.iter
+ (fun c ->
+ let t = decompose_term env sigma c in
+ ignore (add_term state t)) additionnal_terms;
+ List.iter
+ (fun (id,_,e) ->
+ begin
+ let cid=mkVar id in
+ match litteral_of_constr env sigma e with
+ `Eq (t,a,b) -> add_equality state cid a b
+ | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b
+ | `Other ph ->
+ List.iter
+ (fun (cidn,nh) ->
+ add_disequality state (HeqnH (cid,cidn)) ph nh)
+ !neg_hyps;
+ pos_hyps:=(cid,ph):: !pos_hyps
+ | `Nother nh ->
+ List.iter
+ (fun (cidp,ph) ->
+ add_disequality state (HeqnH (cidp,cid)) ph nh)
+ !pos_hyps;
+ neg_hyps:=(cid,nh):: !neg_hyps
+ | `Rule patts -> add_quant state id true patts
+ | `Nrule patts -> add_quant state id false patts
+ end) (Environ.named_context_of_val gls.it.evar_hyps);
+ begin
+ match atom_of_constr env sigma gls.it.evar_concl with
+ `Eq (t,a,b) -> add_disequality state Goal a b
+ | `Other g ->
+ List.iter
+ (fun (idp,ph) ->
+ add_disequality state (HeqG idp) ph g) !pos_hyps
+ end;
+ state
+
+(* indhyps builds the array of arrays of constructor hyps for (ind largs) *)
+
+let build_projection intype outtype (cstr:constructor) special default gls=
+ let env=pf_env gls in
+ let (h,argv) =
+ try destApp intype with
+ Invalid_argument _ -> (intype,[||]) in
+ let ind=destInd h in
+ let types=Inductiveops.arities_of_constructors env ind in
+ let lp=Array.length types in
+ let ci=pred (snd cstr) in
+ let branch i=
+ let ti=Term.prod_appvect types.(i) argv in
+ let rc=fst (decompose_prod_assum ti) in
+ let head=
+ if i=ci then special else default in
+ it_mkLambda_or_LetIn head rc in
+ let branches=Array.init lp branch in
+ let casee=mkRel 1 in
+ let pred=mkLambda(Anonymous,intype,outtype) in
+ let case_info=make_case_info (pf_env gls) ind RegularStyle in
+ let body= mkCase(case_info, pred, casee, branches) in
+ let id=pf_get_new_id (id_of_string "t") gls in
+ mkLambda(Name id,intype,body)
+
+(* generate an adhoc tactic following the proof tree *)
+
+let _M =mkMeta
+
+let rec proof_tac p gls =
+ match p.p_rule with
+ Ax c -> exact_check c 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
+ 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
+ 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 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
+ | Congr (p1,p2)->
+ let tf1=constr_of_term p1.p_lhs
+ 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 id = pf_get_new_id (id_of_string "f") gls in
+ let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in
+ let lemma1 =
+ mkApp(Lazy.force _f_equal,
+ [|typf;typfx;appx1;tf1;tf2;_M 1|]) in
+ let lemma2=
+ mkApp(Lazy.force _f_equal,
+ [|typx;typfx;tf2;tx1;tx2;_M 1|]) in
+ let prf =
+ mkApp(Lazy.force _trans_eq,
+ [|typfx;
+ mkApp(tf1,[|tx1|]);
+ mkApp(tf2,[|tx1|]);
+ mkApp(tf2,[|tx2|]);_M 2;_M 3|]) in
+ tclTHENS (refine prf)
+ [tclTHEN (refine lemma1) (proof_tac p1);
+ tclFIRST
+ [tclTHEN (refine lemma2) (proof_tac p2);
+ reflexivity;
+ fun gls ->
+ errorlabstrm "Congruence"
+ (Pp.str
+ "I don't know how to handle dependent equality")]] gls
+ | Inject (prf,cstr,nargs,argind) ->
+ 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 special=mkRel (1+nargs-argind) in
+ let proj=build_projection intype outtype cstr special default gls in
+ let injt=
+ mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in
+ tclTHEN (refine injt) (proof_tac prf) 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 neweq=
+ mkApp(Lazy.force _eq,
+ [|intype;tt1;tt2|]) in
+ let hid=pf_get_new_id (id_of_string "Heq") gls in
+ let false_t=mkApp (c,[|mkVar hid|]) in
+ tclTHENS (assert_tac (Name hid) neweq)
+ [proof_tac p; simplest_elim false_t] 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 neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in
+ let e=pf_get_new_id (id_of_string "e") gls in
+ let x=pf_get_new_id (id_of_string "X") gls in
+ let identity=mkLambda (Name x,sort,mkRel 1) in
+ let endt=mkApp (Lazy.force _eq_rect,
+ [|sort;tt1;identity;c;tt2;mkVar e|]) in
+ tclTHENS (assert_tac (Name e) neweq)
+ [proof_tac p;exact_check endt] gls
+
+let convert_to_hyp_tac c1 t1 c2 t2 p gls =
+ let tt2=constr_of_term t2 in
+ let h=pf_get_new_id (id_of_string "H") gls in
+ let false_t=mkApp (c2,[|mkVar h|]) in
+ tclTHENS (assert_tac (Name h) tt2)
+ [convert_to_goal_tac c1 t1 t2 p;
+ simplest_elim false_t] 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 concl=pf_concl gls in
+ let outsort=mkType (new_univ ()) in
+ let xid=pf_get_new_id (id_of_string "X") gls in
+ let tid=pf_get_new_id (id_of_string "t") gls in
+ let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in
+ let trivial=pf_type_of gls identity in
+ let outtype=mkType (new_univ ()) in
+ let pred=mkLambda(Name xid,outtype,mkRel 1) in
+ let hid=pf_get_new_id (id_of_string "Heq") gls in
+ let proj=build_projection intype outtype cstr trivial concl gls in
+ let injt=mkApp (Lazy.force _f_equal,
+ [|intype;outtype;proj;t1;t2;mkVar hid|]) in
+ let endt=mkApp (Lazy.force _eq_rect,
+ [|outtype;trivial;pred;identity;concl;injt|]) in
+ let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in
+ tclTHENS (assert_tac (Name hid) neweq)
+ [proof_tac p;exact_check endt] gls
+
+(* wrap everything *)
+
+let build_term_to_complete uf meta pac =
+ let cinfo = get_constructor_info uf pac.cnode in
+ let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in
+ let dummy_args = List.rev (list_tabulate meta pac.arity) in
+ let all_args = List.rev_append real_args dummy_args in
+ applistc (mkConstruct cinfo.ci_constr) all_args
+
+let cc_tactic depth additionnal_terms gls=
+ Coqlib.check_required_library ["Coq";"Init";"Logic"];
+ let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in
+ let state = make_prb gls depth additionnal_terms in
+ let _ = debug Pp.msgnl (Pp.str "Problem built, solving ...") in
+ let sol = execute true state in
+ let _ = debug Pp.msgnl (Pp.str "Computation completed.") in
+ let uf=forest state in
+ match sol with
+ None -> tclFAIL 0 (str "congruence failed") gls
+ | Some reason ->
+ debug Pp.msgnl (Pp.str "Goal solved, generating proof ...");
+ match reason with
+ Discrimination (i,ipac,j,jpac) ->
+ let p=build_proof uf (`Discr (i,ipac,j,jpac)) in
+ let cstr=(get_constructor_info uf ipac.cnode).ci_constr in
+ discriminate_tac cstr p gls
+ | Incomplete ->
+ let metacnt = ref 0 in
+ let newmeta _ = incr metacnt; _M !metacnt in
+ let terms_to_complete =
+ List.map
+ (build_term_to_complete uf newmeta)
+ (epsilons uf) in
+ Pp.msgnl
+ (Pp.str "Goal is solvable by congruence but \
+ some arguments are missing.");
+ Pp.msgnl
+ (Pp.str " Try " ++
+ hov 8
+ begin
+ str "\"congruence with (" ++
+ prlist_with_sep
+ (fun () -> str ")" ++ pr_spc () ++ str "(")
+ (print_constr_env (pf_env gls))
+ terms_to_complete ++
+ str ")\","
+ end);
+ Pp.msgnl
+ (Pp.str " replacing metavariables by arbitrary terms.");
+ tclFAIL 0 (str "Incomplete") gls
+ | Contradiction dis ->
+ let p=build_proof uf (`Prove (dis.lhs,dis.rhs)) in
+ let ta=term uf dis.lhs and tb=term uf dis.rhs in
+ match dis.rule with
+ Goal -> proof_tac p gls
+ | Hyp id -> refute_tac id ta tb p gls
+ | HeqG id ->
+ convert_to_goal_tac id ta tb p gls
+ | HeqnH (ida,idb) ->
+ convert_to_hyp_tac ida ta idb tb p gls
+
+
+let cc_fail gls =
+ errorlabstrm "Congruence" (Pp.str "congruence failed.")
+
+let congruence_tac depth l =
+ tclORELSE
+ (tclTHEN (tclREPEAT introf) (cc_tactic depth l))
+ cc_fail
+
+(* Beware: reflexivity = constructor 1 = apply refl_equal
+ might be slow now, let's rather do something equivalent
+ to a "simple apply refl_equal" *)
+
+let simple_reflexivity () = apply (Lazy.force _refl_equal)
+
+(* The [f_equal] tactic.
+
+ It mimics the use of lemmas [f_equal], [f_equal2], etc.
+ This isn't particularly related with congruence, apart from
+ the fact that congruence is called internally.
+*)
+
+let f_equal gl =
+ let cut_eq c1 c2 =
+ let ty = refresh_universes (pf_type_of gl c1) in
+ tclTHENTRY
+ (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|])))
+ (simple_reflexivity ())
+ in
+ try match kind_of_term (pf_concl gl) with
+ | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) ->
+ begin match kind_of_term t, kind_of_term t' with
+ | App (f,v), App (f',v') when Array.length v = Array.length v' ->
+ let rec cuts i =
+ if i < 0 then tclTRY (congruence_tac 1000 [])
+ else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1))
+ in cuts (Array.length v - 1) gl
+ | _ -> tclIDTAC gl
+ end
+ | _ -> tclIDTAC gl
+ with Type_errors.TypeError _ -> tclIDTAC gl
diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli
new file mode 100644
index 00000000..7ed077bd
--- /dev/null
+++ b/plugins/cc/cctac.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Term
+open Proof_type
+
+val proof_tac: Ccproof.proof -> Proof_type.tactic
+
+val cc_tactic : int -> constr list -> tactic
+
+val cc_fail : tactic
+
+val congruence_tac : int -> constr list -> tactic
+
+val f_equal : tactic
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
new file mode 100644
index 00000000..d9db927a
--- /dev/null
+++ b/plugins/cc/g_congruence.ml4
@@ -0,0 +1,29 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Cctac
+open Tactics
+open Tacticals
+
+(* Tactic registration *)
+
+TACTIC EXTEND cc
+ [ "congruence" ] -> [ congruence_tac 1000 [] ]
+ |[ "congruence" integer(n) ] -> [ congruence_tac n [] ]
+ |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ]
+ |[ "congruence" integer(n) "with" ne_constr_list(l) ] ->
+ [ congruence_tac n l ]
+END
+
+TACTIC EXTEND f_equal
+ [ "f_equal" ] -> [ f_equal ]
+END
diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v
new file mode 100644
index 00000000..bc7d73f6
--- /dev/null
+++ b/plugins/dp/Dp.v
@@ -0,0 +1,120 @@
+(* Calls to external decision procedures *)
+
+Require Export ZArith.
+Require Export Classical.
+
+(* Zenon *)
+
+(* Copyright 2004 INRIA *)
+(* $Id$ *)
+
+Lemma zenon_nottrue :
+ (~True -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_noteq : forall (T : Type) (t : T),
+ ((t <> t) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_and : forall P Q : Prop,
+ (P -> Q -> False) -> (P /\ Q -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_or : forall P Q : Prop,
+ (P -> False) -> (Q -> False) -> (P \/ Q -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_imply : forall P Q : Prop,
+ (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_equiv : forall P Q : Prop,
+ (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notand : forall P Q : Prop,
+ (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notor : forall P Q : Prop,
+ (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notimply : forall P Q : Prop,
+ (P -> ~Q -> False) -> (~(P -> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notequiv : forall P Q : Prop,
+ (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
+ (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
+ ((P t) -> False) -> ((forall x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
+ (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
+ (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
+Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.
+
+Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
+Proof. auto. Qed.
+
+Lemma zenon_equal_step :
+ forall (S T : Type) (fa fb : S -> T) (a b : S),
+ (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
+Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.
+
+Lemma zenon_pnotp : forall P Q : Prop,
+ (P = Q) -> (P -> ~Q -> False).
+Proof. intros P Q Ha. rewrite Ha. auto. Qed.
+
+Lemma zenon_notequal : forall (T : Type) (a b : T),
+ (a = b) -> (a <> b -> False).
+Proof. auto. Qed.
+
+Ltac zenon_intro id :=
+ intro id || let nid := fresh in (intro nid; clear nid)
+.
+
+Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
+Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
+Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
+Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
+Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
+Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
+Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
+Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
+Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
+Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.
+
+Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
+Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.
+
+(* Ergo *)
+
+Set Implicit Arguments.
+Section congr.
+ Variable t:Type.
+Lemma ergo_eq_concat_1 :
+ forall (P:t -> Prop) (x y:t),
+ P x -> x = y -> P y.
+Proof.
+ intros; subst; auto.
+Qed.
+
+Lemma ergo_eq_concat_2 :
+ forall (P:t -> t -> Prop) (x1 x2 y1 y2:t),
+ P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2.
+Proof.
+ intros; subst; auto.
+Qed.
+
+End congr.
diff --git a/plugins/dp/TODO b/plugins/dp/TODO
new file mode 100644
index 00000000..44349e21
--- /dev/null
+++ b/plugins/dp/TODO
@@ -0,0 +1,24 @@
+
+TODO
+----
+
+- axiomes pour les prédicats récursifs comme
+
+ Fixpoint even (n:nat) : Prop :=
+ match n with
+ O => True
+ | S O => False
+ | S (S p) => even p
+ end.
+
+ ou encore In sur les listes du module Coq List.
+
+- discriminate
+
+- inversion (Set et Prop)
+
+
+BUGS
+----
+
+
diff --git a/plugins/dp/dp.ml b/plugins/dp/dp.ml
new file mode 100644
index 00000000..34b32c0a
--- /dev/null
+++ b/plugins/dp/dp.ml
@@ -0,0 +1,1134 @@
+(* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *)
+(* Tactics to call decision procedures *)
+
+(* Works in two steps:
+
+ - first the Coq context and the current goal are translated in
+ Polymorphic First-Order Logic (see fol.mli in this directory)
+
+ - then the resulting query is passed to the Why tool that translates
+ it to the syntax of the selected prover (Simplify, CVC Lite, haRVey,
+ Zenon)
+*)
+
+open Util
+open Pp
+open Libobject
+open Summary
+open Term
+open Tacmach
+open Tactics
+open Tacticals
+open Fol
+open Names
+open Nameops
+open Namegen
+open Termops
+open Coqlib
+open Hipattern
+open Libnames
+open Declarations
+open Dp_why
+
+let debug = ref false
+let set_debug b = debug := b
+let trace = ref false
+let set_trace b = trace := b
+let timeout = ref 10
+let set_timeout n = timeout := n
+
+let (dp_timeout_obj,_) =
+ declare_object
+ {(default_object "Dp_timeout") with
+ cache_function = (fun (_,x) -> set_timeout x);
+ load_function = (fun _ (_,x) -> set_timeout x)}
+
+let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x)
+
+let (dp_debug_obj,_) =
+ declare_object
+ {(default_object "Dp_debug") with
+ cache_function = (fun (_,x) -> set_debug x);
+ load_function = (fun _ (_,x) -> set_debug x)}
+
+let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x)
+
+let (dp_trace_obj,_) =
+ declare_object
+ {(default_object "Dp_trace") with
+ cache_function = (fun (_,x) -> set_trace x);
+ load_function = (fun _ (_,x) -> set_trace x)}
+
+let dp_trace x = Lib.add_anonymous_leaf (dp_trace_obj x)
+
+let logic_dir = ["Coq";"Logic";"Decidable"]
+let coq_modules =
+ init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules
+ @ [["Coq"; "ZArith"; "BinInt"];
+ ["Coq"; "Reals"; "Rdefinitions"];
+ ["Coq"; "Reals"; "Raxioms";];
+ ["Coq"; "Reals"; "Rbasic_fun";];
+ ["Coq"; "Reals"; "R_sqrt";];
+ ["Coq"; "Reals"; "Rfunctions";]]
+ @ [["Coq"; "omega"; "OmegaLemmas"]]
+
+let constant = gen_constant_in_modules "dp" coq_modules
+
+(* integers constants and operations *)
+let coq_Z = lazy (constant "Z")
+let coq_Zplus = lazy (constant "Zplus")
+let coq_Zmult = lazy (constant "Zmult")
+let coq_Zopp = lazy (constant "Zopp")
+let coq_Zminus = lazy (constant "Zminus")
+let coq_Zdiv = lazy (constant "Zdiv")
+let coq_Zs = lazy (constant "Zs")
+let coq_Zgt = lazy (constant "Zgt")
+let coq_Zle = lazy (constant "Zle")
+let coq_Zge = lazy (constant "Zge")
+let coq_Zlt = lazy (constant "Zlt")
+let coq_Z0 = lazy (constant "Z0")
+let coq_Zpos = lazy (constant "Zpos")
+let coq_Zneg = lazy (constant "Zneg")
+let coq_xH = lazy (constant "xH")
+let coq_xI = lazy (constant "xI")
+let coq_xO = lazy (constant "xO")
+let coq_iff = lazy (constant "iff")
+
+(* real constants and operations *)
+let coq_R = lazy (constant "R")
+let coq_R0 = lazy (constant "R0")
+let coq_R1 = lazy (constant "R1")
+let coq_Rgt = lazy (constant "Rgt")
+let coq_Rle = lazy (constant "Rle")
+let coq_Rge = lazy (constant "Rge")
+let coq_Rlt = lazy (constant "Rlt")
+let coq_Rplus = lazy (constant "Rplus")
+let coq_Rmult = lazy (constant "Rmult")
+let coq_Ropp = lazy (constant "Ropp")
+let coq_Rminus = lazy (constant "Rminus")
+let coq_Rdiv = lazy (constant "Rdiv")
+let coq_powerRZ = lazy (constant "powerRZ")
+
+(* not Prop typed expressions *)
+exception NotProp
+
+(* not first-order expressions *)
+exception NotFO
+
+(* Renaming of Coq globals *)
+
+let global_names = Hashtbl.create 97
+let used_names = Hashtbl.create 97
+
+let rename_global r =
+ try
+ Hashtbl.find global_names r
+ with Not_found ->
+ let rec loop id =
+ if Hashtbl.mem used_names id then
+ loop (lift_subscript id)
+ else begin
+ Hashtbl.add used_names id ();
+ let s = string_of_id id in
+ Hashtbl.add global_names r s;
+ s
+ end
+ in
+ loop (Nametab.basename_of_global r)
+
+let foralls =
+ List.fold_right
+ (fun (x,t) p -> Forall (x, t, p))
+
+let fresh_var = function
+ | Anonymous -> rename_global (VarRef (id_of_string "x"))
+ | Name x -> rename_global (VarRef x)
+
+(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of
+ env names, and returns the new variables together with the new
+ environment *)
+let coq_rename_vars env vars =
+ let avoid = ref (ids_of_named_context (Environ.named_context env)) in
+ List.fold_right
+ (fun (na,t) (newvars, newenv) ->
+ let id = next_name_away na !avoid in
+ avoid := id :: !avoid;
+ id :: newvars, Environ.push_named (id, None, t) newenv)
+ vars ([],env)
+
+(* extract the prenex type quantifications i.e.
+ type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *)
+let decomp_type_quantifiers env t =
+ let rec loop vars t = match kind_of_term t with
+ | Prod (n, a, t) when is_Set a || is_Type a ->
+ loop ((n,a) :: vars) t
+ | _ ->
+ let vars, env = coq_rename_vars env vars in
+ let t = substl (List.map mkVar vars) t in
+ List.rev vars, env, t
+ in
+ loop [] t
+
+(* same thing with lambda binders (for axiomatize body) *)
+let decomp_type_lambdas env t =
+ let rec loop vars t = match kind_of_term t with
+ | Lambda (n, a, t) when is_Set a || is_Type a ->
+ loop ((n,a) :: vars) t
+ | _ ->
+ let vars, env = coq_rename_vars env vars in
+ let t = substl (List.map mkVar vars) t in
+ List.rev vars, env, t
+ in
+ loop [] t
+
+let decompose_arrows =
+ let rec arrows_rec l c = match kind_of_term c with
+ | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c
+ | Cast (c,_,_) -> arrows_rec l c
+ | _ -> List.rev l, c
+ in
+ arrows_rec []
+
+let rec eta_expanse t vars env i =
+ assert (i >= 0);
+ if i = 0 then
+ t, vars, env
+ else
+ match kind_of_term (Typing.type_of env Evd.empty t) with
+ | Prod (n, a, b) when not (dependent (mkRel 1) b) ->
+ let avoid = ids_of_named_context (Environ.named_context env) in
+ let id = next_name_away n avoid in
+ let env' = Environ.push_named (id, None, a) env in
+ let t' = mkApp (t, [| mkVar id |]) in
+ eta_expanse t' (id :: vars) env' (pred i)
+ | _ ->
+ assert false
+
+let rec skip_k_args k cl = match k, cl with
+ | 0, _ -> cl
+ | _, _ :: cl -> skip_k_args (k-1) cl
+ | _, [] -> raise NotFO
+
+(* Coq global references *)
+
+type global = Gnot_fo | Gfo of Fol.decl
+
+let globals = ref Refmap.empty
+let globals_stack = ref []
+
+(* synchronization *)
+let () =
+ Summary.declare_summary "Dp globals"
+ { Summary.freeze_function = (fun () -> !globals, !globals_stack);
+ Summary.unfreeze_function =
+ (fun (g,s) -> globals := g; globals_stack := s);
+ Summary.init_function = (fun () -> ()) }
+
+let add_global r d = globals := Refmap.add r d !globals
+let mem_global r = Refmap.mem r !globals
+let lookup_global r = match Refmap.find r !globals with
+ | Gnot_fo -> raise NotFO
+ | Gfo d -> d
+
+let locals = Hashtbl.create 97
+
+let lookup_local r = match Hashtbl.find locals r with
+ | Gnot_fo -> raise NotFO
+ | Gfo d -> d
+
+let iter_all_constructors i f =
+ let _, oib = Global.lookup_inductive i in
+ Array.iteri
+ (fun j tj -> f j (mkConstruct (i, j+1)))
+ oib.mind_nf_lc
+
+
+(* injection c [t1,...,tn] adds the injection axiom
+ forall x1:t1,...,xn:tn,y1:t1,...,yn:tn.
+ c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *)
+
+let injection c l =
+ let i = ref 0 in
+ let var s = incr i; id_of_string (s ^ string_of_int !i) in
+ let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in
+ i := 0;
+ let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in
+ let f =
+ List.fold_right2
+ (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p))
+ xl yl True
+ in
+ let vars = List.map (fun (x,_) -> App(x,[])) in
+ let f = Imp (Fatom (Eq (App (c, vars xl), App (c, vars yl))), f) in
+ let foralls = List.fold_right (fun (x,t) p -> Forall (x, t, p)) in
+ let f = foralls xl (foralls yl f) in
+ let ax = Axiom ("injection_" ^ c, f) in
+ globals_stack := ax :: !globals_stack
+
+(* rec_names_for c [|n1;...;nk|] builds the list of constant names for
+ identifiers n1...nk with the same path as c, if they exist; otherwise
+ raises Not_found *)
+let rec_names_for c =
+ let mp,dp,_ = Names.repr_con c in
+ array_map_to_list
+ (function
+ | Name id ->
+ let c' = Names.make_con mp dp (label_of_id id) in
+ ignore (Global.lookup_constant c');
+ msgnl (Printer.pr_constr (mkConst c'));
+ c'
+ | Anonymous ->
+ raise Not_found)
+
+(* abstraction tables *)
+
+let term_abstractions = Hashtbl.create 97
+
+let new_abstraction =
+ let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r
+
+(* Arithmetic constants *)
+
+exception NotArithConstant
+
+(* translates a closed Coq term p:positive into a FOL term of type int *)
+
+let big_two = Big_int.succ_big_int Big_int.unit_big_int
+
+let rec tr_positive p = match kind_of_term p with
+ | Term.Construct _ when p = Lazy.force coq_xH ->
+ Big_int.unit_big_int
+ | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
+(*
+ Plus (Mult (Cst 2, tr_positive a), Cst 1)
+*)
+ Big_int.succ_big_int (Big_int.mult_big_int big_two (tr_positive a))
+ | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
+(*
+ Mult (Cst 2, tr_positive a)
+*)
+ Big_int.mult_big_int big_two (tr_positive a)
+ | Term.Cast (p, _, _) ->
+ tr_positive p
+ | _ ->
+ raise NotArithConstant
+
+(* translates a closed Coq term t:Z or R into a FOL term of type int or real *)
+let rec tr_arith_constant t = match kind_of_term t with
+ | Term.Construct _ when t = Lazy.force coq_Z0 ->
+ Cst Big_int.zero_big_int
+ | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos ->
+ Cst (tr_positive a)
+ | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg ->
+ Cst (Big_int.minus_big_int (tr_positive a))
+ | Term.Const _ when t = Lazy.force coq_R0 ->
+ RCst Big_int.zero_big_int
+ | Term.Const _ when t = Lazy.force coq_R1 ->
+ RCst Big_int.unit_big_int
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus ->
+ let ta = tr_arith_constant a in
+ let tb = tr_arith_constant b in
+ begin match ta,tb with
+ | RCst na, RCst nb -> RCst (Big_int.add_big_int na nb)
+ | _ -> raise NotArithConstant
+ end
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult ->
+ let ta = tr_arith_constant a in
+ let tb = tr_arith_constant b in
+ begin match ta,tb with
+ | RCst na, RCst nb -> RCst (Big_int.mult_big_int na nb)
+ | _ -> raise NotArithConstant
+ end
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_powerRZ ->
+ tr_powerRZ a b
+ | Term.Cast (t, _, _) ->
+ tr_arith_constant t
+ | _ ->
+ raise NotArithConstant
+
+(* translates a constant of the form (powerRZ 2 int_constant) *)
+and tr_powerRZ a b =
+ (* checking first that a is (R1 + R1) *)
+ match kind_of_term a with
+ | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus ->
+ begin
+ match kind_of_term c,kind_of_term d with
+ | Term.Const _, Term.Const _
+ when c = Lazy.force coq_R1 && d = Lazy.force coq_R1 ->
+ begin
+ match tr_arith_constant b with
+ | Cst n -> Power2 n
+ | _ -> raise NotArithConstant
+ end
+ | _ -> raise NotArithConstant
+ end
+ | _ -> raise NotArithConstant
+
+
+(* translate a Coq term t:Set into a FOL type expression;
+ tv = list of type variables *)
+and tr_type tv env t =
+ let t = Reductionops.nf_betadeltaiota env Evd.empty t in
+ if t = Lazy.force coq_Z then
+ Tid ("int", [])
+ else if t = Lazy.force coq_R then
+ Tid ("real", [])
+ else match kind_of_term t with
+ | Var x when List.mem x tv ->
+ Tvar (string_of_id x)
+ | _ ->
+ let f, cl = decompose_app t in
+ begin try
+ let r = global_of_constr f in
+ match tr_global env r with
+ | DeclType (id, k) ->
+ assert (k = List.length cl); (* since t:Set *)
+ Tid (id, List.map (tr_type tv env) cl)
+ | _ ->
+ raise NotFO
+ with
+ | Not_found ->
+ raise NotFO
+ | NotFO ->
+ (* we need to abstract some part of (f cl) *)
+ (*TODO*)
+ raise NotFO
+ end
+
+and make_term_abstraction tv env c =
+ let ty = Typing.type_of env Evd.empty c in
+ let id = new_abstraction () in
+ match tr_decl env id ty with
+ | DeclFun (id,_,_,_) as _d ->
+ raise NotFO
+ (* [CM 07/09/2009] deactivated because it generates
+ unbound identifiers 'abstraction_<number>'
+ begin try
+ Hashtbl.find term_abstractions c
+ with Not_found ->
+ Hashtbl.add term_abstractions c id;
+ globals_stack := d :: !globals_stack;
+ id
+ end
+ *)
+ | _ ->
+ raise NotFO
+
+(* translate a Coq declaration id:ty in a FOL declaration, that is either
+ - a type declaration : DeclType (id, n) where n:int is the type arity
+ - a function declaration : DeclFun (id, tl, t) ; that includes constants
+ - a predicate declaration : DeclPred (id, tl)
+ - an axiom : Axiom (id, p)
+ *)
+and tr_decl env id ty =
+ let tv, env, t = decomp_type_quantifiers env ty in
+ if is_Set t || is_Type t then
+ DeclType (id, List.length tv)
+ else if is_Prop t then
+ DeclPred (id, List.length tv, [])
+ else
+ let s = Typing.type_of env Evd.empty t in
+ if is_Prop s then
+ Axiom (id, tr_formula tv [] env t)
+ else
+ let l, t = decompose_arrows t in
+ let l = List.map (tr_type tv env) l in
+ if is_Prop t then
+ DeclPred(id, List.length tv, l)
+ else
+ let s = Typing.type_of env Evd.empty t in
+ if is_Set s || is_Type s then
+ DeclFun (id, List.length tv, l, tr_type tv env t)
+ else
+ raise NotFO
+
+(* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *)
+and tr_global env r = match r with
+ | VarRef id ->
+ lookup_local id
+ | r ->
+ try
+ lookup_global r
+ with Not_found ->
+ try
+ let ty = Global.type_of_global r in
+ let id = rename_global r in
+ let d = tr_decl env id ty in
+ (* r can be already declared if it is a constructor *)
+ if not (mem_global r) then begin
+ add_global r (Gfo d);
+ globals_stack := d :: !globals_stack
+ end;
+ begin try axiomatize_body env r id d with NotFO -> () end;
+ d
+ with NotFO ->
+ add_global r Gnot_fo;
+ raise NotFO
+
+and axiomatize_body env r id d = match r with
+ | VarRef _ ->
+ assert false
+ | ConstRef c ->
+ begin match (Global.lookup_constant c).const_body with
+ | Some b ->
+ let b = force b in
+ let axioms =
+ (match d with
+ | DeclPred (id, _, []) ->
+ let tv, env, b = decomp_type_lambdas env b in
+ let value = tr_formula tv [] env b in
+ [id, Iff (Fatom (Pred (id, [])), value)]
+ | DeclFun (id, _, [], _) ->
+ let tv, env, b = decomp_type_lambdas env b in
+ let value = tr_term tv [] env b in
+ [id, Fatom (Eq (Fol.App (id, []), value))]
+ | DeclFun (id, _, l, _) | DeclPred (id, _, l) ->
+ (*Format.eprintf "axiomatize_body %S@." id;*)
+ let b = match kind_of_term b with
+ (* a single recursive function *)
+ | Fix (_, (_,_,[|b|])) ->
+ subst1 (mkConst c) b
+ (* mutually recursive functions *)
+ | Fix ((_,i), (names,_,bodies)) ->
+ (* we only deal with named functions *)
+ begin try
+ let l = rec_names_for c names in
+ substl (List.rev_map mkConst l) bodies.(i)
+ with Not_found ->
+ b
+ end
+ | _ ->
+ b
+ in
+ let tv, env, b = decomp_type_lambdas env b in
+ let vars, t = decompose_lam b in
+ let n = List.length l in
+ let k = List.length vars in
+ assert (k <= n);
+ let vars, env = coq_rename_vars env vars in
+ let t = substl (List.map mkVar vars) t in
+ let t, vars, env = eta_expanse t vars env (n-k) in
+ let vars = List.rev vars in
+ let bv = vars in
+ let vars = List.map (fun x -> string_of_id x) vars in
+ let fol_var x = Fol.App (x, []) in
+ let fol_vars = List.map fol_var vars in
+ let vars = List.combine vars l in
+ begin match d with
+ | DeclFun (_, _, _, ty) ->
+ begin match kind_of_term t with
+ | Case (ci, _, e, br) ->
+ equations_for_case env id vars tv bv ci e br
+ | _ ->
+ let t = tr_term tv bv env t in
+ let ax =
+ add_proof (Fun_def (id, vars, ty, t))
+ in
+ let p = Fatom (Eq (App (id, fol_vars), t)) in
+ [ax, foralls vars p]
+ end
+ | DeclPred _ ->
+ let value = tr_formula tv bv env t in
+ let p = Iff (Fatom (Pred (id, fol_vars)), value) in
+ [id, foralls vars p]
+ | _ ->
+ assert false
+ end
+ | DeclType _ ->
+ raise NotFO
+ | Axiom _ -> assert false)
+ in
+ let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in
+ globals_stack := axioms @ !globals_stack
+ | None ->
+ () (* Coq axiom *)
+ end
+ | IndRef i ->
+ iter_all_constructors i
+ (fun _ c ->
+ let rc = global_of_constr c in
+ try
+ begin match tr_global env rc with
+ | DeclFun (_, _, [], _) -> ()
+ | DeclFun (idc, _, al, _) -> injection idc al
+ | _ -> ()
+ end
+ with NotFO ->
+ ())
+ | _ -> ()
+
+and equations_for_case env id vars tv bv ci e br = match kind_of_term e with
+ | Var x when List.exists (fun (y, _) -> string_of_id x = y) vars ->
+ let eqs = ref [] in
+ iter_all_constructors ci.ci_ind
+ (fun j cj ->
+ try
+ let cjr = global_of_constr cj in
+ begin match tr_global env cjr with
+ | DeclFun (idc, _, l, _) ->
+ let b = br.(j) in
+ let rec_vars, b = decompose_lam b in
+ let rec_vars, env = coq_rename_vars env rec_vars in
+ let coq_rec_vars = List.map mkVar rec_vars in
+ let b = substl coq_rec_vars b in
+ let rec_vars = List.rev rec_vars in
+ let coq_rec_term = applist (cj, List.rev coq_rec_vars) in
+ let b = replace_vars [x, coq_rec_term] b in
+ let bv = bv @ rec_vars in
+ let rec_vars = List.map string_of_id rec_vars in
+ let fol_var x = Fol.App (x, []) in
+ let fol_rec_vars = List.map fol_var rec_vars in
+ let fol_rec_term = App (idc, fol_rec_vars) in
+ let rec_vars = List.combine rec_vars l in
+ let fol_vars = List.map fst vars in
+ let fol_vars = List.map fol_var fol_vars in
+ let fol_vars = List.map (fun y -> match y with
+ | App (id, _) ->
+ if id = string_of_id x
+ then fol_rec_term
+ else y
+ | _ -> y)
+ fol_vars in
+ let vars = vars @ rec_vars in
+ let rec remove l e = match l with
+ | [] -> []
+ | (y, t)::l' -> if y = string_of_id e then l'
+ else (y, t)::(remove l' e) in
+ let vars = remove vars x in
+ let p =
+ Fatom (Eq (App (id, fol_vars),
+ tr_term tv bv env b))
+ in
+ eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs
+ | _ ->
+ assert false end
+ with NotFO ->
+ ());
+ !eqs
+ | _ ->
+ raise NotFO
+
+(* assumption: t:T:Set *)
+and tr_term tv bv env t =
+ try
+ tr_arith_constant t
+ with NotArithConstant ->
+ match kind_of_term t with
+ (* binary operations on integers *)
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus ->
+ Plus (tr_term tv bv env a, tr_term tv bv env b)
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus ->
+ Moins (tr_term tv bv env a, tr_term tv bv env b)
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult ->
+ Mult (tr_term tv bv env a, tr_term tv bv env b)
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv ->
+ Div (tr_term tv bv env a, tr_term tv bv env b)
+ | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp ->
+ Opp (tr_term tv bv env a)
+ (* binary operations on reals *)
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus ->
+ Plus (tr_term tv bv env a, tr_term tv bv env b)
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus ->
+ Moins (tr_term tv bv env a, tr_term tv bv env b)
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult ->
+ Mult (tr_term tv bv env a, tr_term tv bv env b)
+ | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv ->
+ Div (tr_term tv bv env a, tr_term tv bv env b)
+ | Term.Var id when List.mem id bv ->
+ App (string_of_id id, [])
+ | _ ->
+ let f, cl = decompose_app t in
+ begin try
+ let r = global_of_constr f in
+ match tr_global env r with
+ | DeclFun (s, k, _, _) ->
+ let cl = skip_k_args k cl in
+ Fol.App (s, List.map (tr_term tv bv env) cl)
+ | _ ->
+ raise NotFO
+ with
+ | Not_found ->
+ raise NotFO
+ | NotFO -> (* we need to abstract some part of (f cl) *)
+ let rec abstract app = function
+ | [] ->
+ Fol.App (make_term_abstraction tv env app, [])
+ | x :: l as args ->
+ begin try
+ let s = make_term_abstraction tv env app in
+ Fol.App (s, List.map (tr_term tv bv env) args)
+ with NotFO ->
+ abstract (applist (app, [x])) l
+ end
+ in
+ let app,l = match cl with
+ | x :: l -> applist (f, [x]), l | [] -> raise NotFO
+ in
+ abstract app l
+ end
+
+and quantifiers n a b tv bv env =
+ let vars, env = coq_rename_vars env [n,a] in
+ let id = match vars with [x] -> x | _ -> assert false in
+ let b = subst1 (mkVar id) b in
+ let t = tr_type tv env a in
+ let bv = id :: bv in
+ id, t, bv, env, b
+
+(* assumption: f is of type Prop *)
+and tr_formula tv bv env f =
+ let c, args = decompose_app f in
+ match kind_of_term c, args with
+ | Var id, [] ->
+ Fatom (Pred (rename_global (VarRef id), []))
+ | _, [t;a;b] when c = build_coq_eq () ->
+ let ty = Typing.type_of env Evd.empty t in
+ if is_Set ty || is_Type ty then
+ let _ = tr_type tv env t in
+ Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b))
+ else
+ raise NotFO
+ (* comparisons on integers *)
+ | _, [a;b] when c = Lazy.force coq_Zle ->
+ Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
+ | _, [a;b] when c = Lazy.force coq_Zlt ->
+ Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
+ | _, [a;b] when c = Lazy.force coq_Zge ->
+ Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
+ | _, [a;b] when c = Lazy.force coq_Zgt ->
+ Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
+ (* comparisons on reals *)
+ | _, [a;b] when c = Lazy.force coq_Rle ->
+ Fatom (Le (tr_term tv bv env a, tr_term tv bv env b))
+ | _, [a;b] when c = Lazy.force coq_Rlt ->
+ Fatom (Lt (tr_term tv bv env a, tr_term tv bv env b))
+ | _, [a;b] when c = Lazy.force coq_Rge ->
+ Fatom (Ge (tr_term tv bv env a, tr_term tv bv env b))
+ | _, [a;b] when c = Lazy.force coq_Rgt ->
+ Fatom (Gt (tr_term tv bv env a, tr_term tv bv env b))
+ | _, [] when c = build_coq_False () ->
+ False
+ | _, [] when c = build_coq_True () ->
+ True
+ | _, [a] when c = build_coq_not () ->
+ Not (tr_formula tv bv env a)
+ | _, [a;b] when c = build_coq_and () ->
+ And (tr_formula tv bv env a, tr_formula tv bv env b)
+ | _, [a;b] when c = build_coq_or () ->
+ Or (tr_formula tv bv env a, tr_formula tv bv env b)
+ | _, [a;b] when c = Lazy.force coq_iff ->
+ Iff (tr_formula tv bv env a, tr_formula tv bv env b)
+ | Prod (n, a, b), _ ->
+ if is_imp_term f then
+ Imp (tr_formula tv bv env a, tr_formula tv bv env b)
+ else
+ let id, t, bv, env, b = quantifiers n a b tv bv env in
+ Forall (string_of_id id, t, tr_formula tv bv env b)
+ | _, [_; a] when c = build_coq_ex () ->
+ begin match kind_of_term a with
+ | Lambda(n, a, b) ->
+ let id, t, bv, env, b = quantifiers n a b tv bv env in
+ Exists (string_of_id id, t, tr_formula tv bv env b)
+ | _ ->
+ (* unusual case of the shape (ex p) *)
+ raise NotFO (* TODO: we could eta-expanse *)
+ end
+ | _ ->
+ begin try
+ let r = global_of_constr c in
+ match tr_global env r with
+ | DeclPred (s, k, _) ->
+ let args = skip_k_args k args in
+ Fatom (Pred (s, List.map (tr_term tv bv env) args))
+ | _ ->
+ raise NotFO
+ with Not_found ->
+ raise NotFO
+ end
+
+
+let tr_goal gl =
+ Hashtbl.clear locals;
+ let tr_one_hyp (id, ty) =
+ try
+ let s = rename_global (VarRef id) in
+ let d = tr_decl (pf_env gl) s ty in
+ Hashtbl.add locals id (Gfo d);
+ d
+ with NotFO ->
+ Hashtbl.add locals id Gnot_fo;
+ raise NotFO
+ in
+ let hyps =
+ List.fold_right
+ (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc)
+ (pf_hyps_types gl) []
+ in
+ let c = tr_formula [] [] (pf_env gl) (pf_concl gl) in
+ let hyps = List.rev_append !globals_stack (List.rev hyps) in
+ hyps, c
+
+
+type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy | CVC3 | Z3
+
+let remove_files = List.iter (fun f -> try Sys.remove f with _ -> ())
+
+let sprintf = Format.sprintf
+
+let file_contents f =
+ let buf = Buffer.create 1024 in
+ try
+ let c = open_in f in
+ begin try
+ while true do
+ let s = input_line c in Buffer.add_string buf s;
+ Buffer.add_char buf '\n'
+ done;
+ assert false
+ with End_of_file ->
+ close_in c;
+ Buffer.contents buf
+ end
+ with _ ->
+ sprintf "(cannot open %s)" f
+
+let timeout_sys_command cmd =
+ if !debug then Format.eprintf "command line: %s@." cmd;
+ let out = Filename.temp_file "out" "" in
+ let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in
+ let ret = Sys.command cmd in
+ if !debug then
+ Format.eprintf "Output file %s:@.%s@." out (file_contents out);
+ ret, out
+
+let timeout_or_failure c cmd out =
+ if c = 152 then
+ Timeout
+ else
+ Failure
+ (sprintf "command %s failed with output:\n%s " cmd (file_contents out))
+
+let call_prover ?(opt="") file =
+ if !debug then Format.eprintf "calling prover on %s@." file;
+ let out = Filename.temp_file "out" "" in
+ let cmd =
+ sprintf "why-dp -timeout %d -batch %s > %s 2>&1" !timeout file out in
+ match Sys.command cmd with
+ 0 -> Valid None
+ | 1 -> Failure (sprintf "could not run why-dp\n%s" (file_contents out))
+ | 2 -> Invalid
+ | 3 -> DontKnow
+ | 4 -> Timeout
+ | 5 -> Failure (sprintf "prover failed:\n%s" (file_contents out))
+ | n -> Failure (sprintf "Unknown exit status of why-dp: %d" n)
+
+let prelude_files = ref ([] : string list)
+
+let set_prelude l = prelude_files := l
+
+let (dp_prelude_obj,_) =
+ declare_object
+ {(default_object "Dp_prelude") with
+ cache_function = (fun (_,x) -> set_prelude x);
+ load_function = (fun _ (_,x) -> set_prelude x)}
+
+let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x)
+
+let why_files f = String.concat " " (!prelude_files @ [f])
+
+let call_simplify fwhy =
+ let cmd =
+ sprintf "why --simplify %s" (why_files fwhy)
+ in
+ if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+ let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in
+(*
+ let cmd =
+ sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out"
+ !timeout fsx
+ in
+ let out = Sys.command cmd in
+ let r =
+ if out = 0 then Valid None else if out = 1 then Invalid else Timeout
+ in
+*)
+ let r = call_prover fsx in
+ if not !debug then remove_files [fwhy; fsx];
+ r
+
+let call_ergo fwhy =
+ let cmd = sprintf "why --alt-ergo %s" (why_files fwhy) in
+ if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+ let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in
+ (*let ftrace = Filename.temp_file "ergo_trace" "" in*)
+ (*NB: why-dp can't handle -cctrace
+ let cmd =
+ if !trace then
+ sprintf "alt-ergo -cctrace %s %s" ftrace fwhy
+
+ else
+ sprintf "alt-ergo %s" fwhy
+ in*)
+ let r = call_prover fwhy in
+ if not !debug then remove_files [fwhy; (*out*)];
+ r
+
+
+let call_zenon fwhy =
+ let cmd =
+ sprintf "why --no-zenon-prelude --zenon %s" (why_files fwhy)
+ in
+ if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+ let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in
+(* why-dp won't let us having coqterm...
+ let out = Filename.temp_file "dp_out" "" in
+ let cmd =
+ sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out
+ in
+ let c = Sys.command cmd in
+ if not !debug then remove_files [fwhy; fznn];
+ if c = 137 then
+ Timeout
+ else begin
+ if c <> 0 then anomaly ("command failed: " ^ cmd);
+ if Sys.command (sprintf "grep -q -w Error %s" out) = 0 then
+ error "Zenon failed";
+ let c = Sys.command (sprintf "grep -q PROOF-FOUND %s" out) in
+ if c = 0 then Valid (Some out) else Invalid
+ end
+ *)
+ let r = call_prover fznn in
+ if not !debug then remove_files [fwhy; fznn];
+ r
+
+let call_smt ~smt fwhy =
+ let cmd =
+ sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
+ in
+ if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+ let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
+ let opt = "-smt-solver " ^ smt in
+ let r = call_prover ~opt fsmt in
+ if not !debug then remove_files [fwhy; fsmt];
+ r
+
+(*
+let call_yices fwhy =
+ let cmd =
+ sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
+ in
+ if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+ let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
+ let cmd =
+ sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out"
+ !timeout fsmt
+ in
+ let out = Sys.command cmd in
+ let r =
+ if out = 0 then Valid None else if out = 1 then Invalid else Timeout
+ in
+ if not !debug then remove_files [fwhy; fsmt];
+ r
+
+let call_cvc3 fwhy =
+ let cmd =
+ sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy)
+ in
+ if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+ let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in
+ let cmd =
+ sprintf "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out"
+ !timeout fsmt
+ in
+ let out = Sys.command cmd in
+ let r =
+ if out = 0 then Valid None else if out = 1 then Invalid else Timeout
+ in
+ if not !debug then remove_files [fwhy; fsmt];
+ r
+*)
+
+let call_cvcl fwhy =
+ let cmd =
+ sprintf "why --cvcl --encoding sstrat %s" (why_files fwhy)
+ in
+ if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+ let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in
+(*
+ let cmd =
+ sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out"
+ !timeout fcvc
+ in
+ let out = Sys.command cmd in
+ let r =
+ if out = 0 then Valid None else if out = 1 then Invalid else Timeout
+ in
+*)
+ let r = call_prover fcvc in
+ if not !debug then remove_files [fwhy; fcvc];
+ r
+
+let call_harvey fwhy =
+ let cmd =
+ sprintf "why --harvey --encoding strat %s" (why_files fwhy)
+ in
+ if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed");
+ let frv = Filename.chop_suffix fwhy ".why" ^ "_why.rv" in
+(*
+ let out = Sys.command (sprintf "rvc -e -t %s > /dev/null 2>&1" frv) in
+ if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed");
+ let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in
+ let outf = Filename.temp_file "rv" ".out" in
+ let out =
+ Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1"
+ !timeout f outf)
+ in
+ let r =
+ if out <> 0 then
+ Timeout
+ else
+ let cmd =
+ sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf
+ in
+ if Sys.command cmd = 0 then Valid None else Invalid
+ in
+ if not !debug then remove_files [fwhy; frv; outf];
+*)
+ let r = call_prover frv in
+ if not !debug then remove_files [fwhy; frv];
+ r
+
+let call_gwhy fwhy =
+ let cmd = sprintf "gwhy %s" (why_files fwhy) in
+ if Sys.command cmd <> 0 then ignore (Sys.command (sprintf "emacs %s" fwhy));
+ NoAnswer
+
+let ergo_proof_from_file f gl =
+ let s =
+ let buf = Buffer.create 1024 in
+ let c = open_in f in
+ try
+ while true do Buffer.add_string buf (input_line c) done; assert false
+ with End_of_file ->
+ close_in c;
+ Buffer.contents buf
+ in
+ let parsed_constr = Pcoq.parse_string Pcoq.Constr.constr s in
+ let t = Constrintern.interp_constr (project gl) (pf_env gl) parsed_constr in
+ exact_check t gl
+
+let call_prover prover q =
+ let fwhy = Filename.temp_file "coq_dp" ".why" in
+ Dp_why.output_file fwhy q;
+ match prover with
+ | Simplify -> call_simplify fwhy
+ | Ergo -> call_ergo fwhy
+ | CVC3 -> call_smt ~smt:"cvc3" fwhy
+ | Yices -> call_smt ~smt:"yices" fwhy
+ | Z3 -> call_smt ~smt:"z3" fwhy
+ | Zenon -> call_zenon fwhy
+ | CVCLite -> call_cvcl fwhy
+ | Harvey -> call_harvey fwhy
+ | Gwhy -> call_gwhy fwhy
+
+let dp prover gl =
+ Coqlib.check_required_library ["Coq";"ZArith";"ZArith"];
+ let concl_type = pf_type_of gl (pf_concl gl) in
+ if not (is_Prop concl_type) then error "Conclusion is not a Prop";
+ try
+ let q = tr_goal gl in
+ begin match call_prover prover q with
+ | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl
+ | Valid (Some f) when prover = Ergo -> ergo_proof_from_file f gl
+ | Valid _ -> Tactics.admit_as_an_axiom gl
+ | Invalid -> error "Invalid"
+ | DontKnow -> error "Don't know"
+ | Timeout -> error "Timeout"
+ | Failure s -> error s
+ | NoAnswer -> Tacticals.tclIDTAC gl
+ end
+ with NotFO ->
+ error "Not a first order goal"
+
+
+let simplify = tclTHEN intros (dp Simplify)
+let ergo = tclTHEN intros (dp Ergo)
+let cvc3 = tclTHEN intros (dp CVC3)
+let yices = tclTHEN intros (dp Yices)
+let z3 = tclTHEN intros (dp Z3)
+let cvc_lite = tclTHEN intros (dp CVCLite)
+let harvey = dp Harvey
+let zenon = tclTHEN intros (dp Zenon)
+let gwhy = tclTHEN intros (dp Gwhy)
+
+let dp_hint l =
+ let env = Global.env () in
+ let one_hint (qid,r) =
+ if not (mem_global r) then begin
+ let ty = Global.type_of_global r in
+ let s = Typing.type_of env Evd.empty ty in
+ if is_Prop s then
+ try
+ let id = rename_global r in
+ let tv, env, ty = decomp_type_quantifiers env ty in
+ let d = Axiom (id, tr_formula tv [] env ty) in
+ add_global r (Gfo d);
+ globals_stack := d :: !globals_stack
+ with NotFO ->
+ add_global r Gnot_fo;
+ msg_warning
+ (pr_reference qid ++
+ str " ignored (not a first order proposition)")
+ else begin
+ add_global r Gnot_fo;
+ msg_warning
+ (pr_reference qid ++ str " ignored (not a proposition)")
+ end
+ end
+ in
+ List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l)
+
+let (dp_hint_obj,_) =
+ declare_object
+ {(default_object "Dp_hint") with
+ cache_function = (fun (_,l) -> dp_hint l);
+ load_function = (fun _ (_,l) -> dp_hint l)}
+
+let dp_hint l = Lib.add_anonymous_leaf (dp_hint_obj l)
+
+let dp_predefined qid s =
+ let r = Nametab.global qid in
+ let ty = Global.type_of_global r in
+ let env = Global.env () in
+ let id = rename_global r in
+ try
+ let d = match tr_decl env id ty with
+ | DeclType (_, n) -> DeclType (s, n)
+ | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty)
+ | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl)
+ | Axiom _ as d -> d
+ in
+ match d with
+ | Axiom _ -> msg_warning (str " ignored (axiom)")
+ | d -> add_global r (Gfo d)
+ with NotFO ->
+ msg_warning (str " ignored (not a first order declaration)")
+
+let (dp_predefined_obj,_) =
+ declare_object
+ {(default_object "Dp_predefined") with
+ cache_function = (fun (_,(id,s)) -> dp_predefined id s);
+ load_function = (fun _ (_,(id,s)) -> dp_predefined id s)}
+
+let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s))
+
+let _ = declare_summary "Dp options"
+ { freeze_function =
+ (fun () -> !debug, !trace, !timeout, !prelude_files);
+ unfreeze_function =
+ (fun (d,tr,tm,pr) ->
+ debug := d; trace := tr; timeout := tm; prelude_files := pr);
+ init_function =
+ (fun () ->
+ debug := false; trace := false; timeout := 10;
+ prelude_files := []) }
diff --git a/plugins/dp/dp.mli b/plugins/dp/dp.mli
new file mode 100644
index 00000000..f40f8688
--- /dev/null
+++ b/plugins/dp/dp.mli
@@ -0,0 +1,20 @@
+
+open Libnames
+open Proof_type
+
+val simplify : tactic
+val ergo : tactic
+val cvc3 : tactic
+val yices : tactic
+val cvc_lite : tactic
+val harvey : tactic
+val zenon : tactic
+val gwhy : tactic
+val z3: tactic
+
+val dp_hint : reference list -> unit
+val dp_timeout : int -> unit
+val dp_debug : bool -> unit
+val dp_trace : bool -> unit
+val dp_prelude : string list -> unit
+val dp_predefined : reference -> string -> unit
diff --git a/plugins/dp/dp_plugin.mllib b/plugins/dp/dp_plugin.mllib
new file mode 100644
index 00000000..63252d6a
--- /dev/null
+++ b/plugins/dp/dp_plugin.mllib
@@ -0,0 +1,5 @@
+Dp_why
+Dp_zenon
+Dp
+G_dp
+Dp_plugin_mod
diff --git a/plugins/dp/dp_why.ml b/plugins/dp/dp_why.ml
new file mode 100644
index 00000000..9a62f39d
--- /dev/null
+++ b/plugins/dp/dp_why.ml
@@ -0,0 +1,186 @@
+
+(* Pretty-print PFOL (see fol.mli) in Why syntax *)
+
+open Format
+open Fol
+
+type proof =
+ | Immediate of Term.constr
+ | Fun_def of string * (string * typ) list * typ * term
+
+let proofs = Hashtbl.create 97
+let proof_name =
+ let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r
+
+let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n
+
+let find_proof = Hashtbl.find proofs
+
+let rec print_list sep print fmt = function
+ | [] -> ()
+ | [x] -> print fmt x
+ | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
+
+let space fmt () = fprintf fmt "@ "
+let comma fmt () = fprintf fmt ",@ "
+
+let is_why_keyword =
+ let h = Hashtbl.create 17 in
+ List.iter
+ (fun s -> Hashtbl.add h s ())
+ ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin";
+ "bool"; "do"; "done"; "else"; "end"; "exception"; "exists";
+ "external"; "false"; "for"; "forall"; "fun"; "function"; "goal";
+ "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not";
+ "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises";
+ "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try";
+ "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ];
+ Hashtbl.mem h
+
+let ident fmt s =
+ if is_why_keyword s then fprintf fmt "coq__%s" s else fprintf fmt "%s" s
+
+let rec print_typ fmt = function
+ | Tvar x -> fprintf fmt "'%a" ident x
+ | Tid ("int", []) -> fprintf fmt "int"
+ | Tid ("real", []) -> fprintf fmt "real"
+ | Tid (x, []) -> fprintf fmt "%a" ident x
+ | Tid (x, [t]) -> fprintf fmt "%a %a" print_typ t ident x
+ | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x
+
+let print_arg fmt (id,typ) = fprintf fmt "%a: %a" ident id print_typ typ
+
+let rec print_term fmt = function
+ | Cst n ->
+ fprintf fmt "%s" (Big_int.string_of_big_int n)
+ | RCst s ->
+ fprintf fmt "%s.0" (Big_int.string_of_big_int s)
+ | Power2 n ->
+ fprintf fmt "0x1p%s" (Big_int.string_of_big_int n)
+ | Plus (a, b) ->
+ fprintf fmt "@[(%a +@ %a)@]" print_term a print_term b
+ | Moins (a, b) ->
+ fprintf fmt "@[(%a -@ %a)@]" print_term a print_term b
+ | Mult (a, b) ->
+ fprintf fmt "@[(%a *@ %a)@]" print_term a print_term b
+ | Div (a, b) ->
+ fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b
+ | Opp (a) ->
+ fprintf fmt "@[(-@ %a)@]" print_term a
+ | App (id, []) ->
+ fprintf fmt "%a" ident id
+ | App (id, tl) ->
+ fprintf fmt "@[%a(%a)@]" ident id print_terms tl
+
+and print_terms fmt tl =
+ print_list comma print_term fmt tl
+
+let rec print_predicate fmt p =
+ let pp = print_predicate in
+ match p with
+ | True ->
+ fprintf fmt "true"
+ | False ->
+ fprintf fmt "false"
+ | Fatom (Eq (a, b)) ->
+ fprintf fmt "@[(%a =@ %a)@]" print_term a print_term b
+ | Fatom (Le (a, b)) ->
+ fprintf fmt "@[(%a <=@ %a)@]" print_term a print_term b
+ | Fatom (Lt (a, b))->
+ fprintf fmt "@[(%a <@ %a)@]" print_term a print_term b
+ | Fatom (Ge (a, b)) ->
+ fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b
+ | Fatom (Gt (a, b)) ->
+ fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b
+ | Fatom (Pred (id, [])) ->
+ fprintf fmt "%a" ident id
+ | Fatom (Pred (id, tl)) ->
+ fprintf fmt "@[%a(%a)@]" ident id print_terms tl
+ | Imp (a, b) ->
+ fprintf fmt "@[(%a ->@ %a)@]" pp a pp b
+ | Iff (a, b) ->
+ fprintf fmt "@[(%a <->@ %a)@]" pp a pp b
+ | And (a, b) ->
+ fprintf fmt "@[(%a and@ %a)@]" pp a pp b
+ | Or (a, b) ->
+ fprintf fmt "@[(%a or@ %a)@]" pp a pp b
+ | Not a ->
+ fprintf fmt "@[(not@ %a)@]" pp a
+ | Forall (id, t, p) ->
+ fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p
+ | Exists (id, t, p) ->
+ fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p
+
+let rec remove_iff args = function
+ Forall (id,t,p) -> remove_iff ((id,t)::args) p
+ | Iff(_,b) -> List.rev args, b
+ | _ -> raise Not_found
+
+let print_query fmt (decls,concl) =
+ let find_declared_preds l =
+ function
+ DeclPred (id,_,args) -> (id,args) :: l
+ | _ -> l
+ in
+ let find_defined_preds declared l = function
+ Axiom(id,f) ->
+ (try
+ let _decl = List.assoc id declared in
+ (id,remove_iff [] f)::l
+ with Not_found -> l)
+ | _ -> l
+ in
+ let declared_preds =
+ List.fold_left find_declared_preds [] decls in
+ let defined_preds =
+ List.fold_left (find_defined_preds declared_preds) [] decls
+ in
+ let print_dtype = function
+ | DeclType (id, 0) ->
+ fprintf fmt "@[type %a@]@\n@\n" ident id
+ | DeclType (id, 1) ->
+ fprintf fmt "@[type 'a %a@]@\n@\n" ident id
+ | DeclType (id, n) ->
+ fprintf fmt "@[type (";
+ for i = 1 to n do
+ fprintf fmt "'a%d" i; if i < n then fprintf fmt ", "
+ done;
+ fprintf fmt ") %a@]@\n@\n" ident id
+ | DeclFun _ | DeclPred _ | Axiom _ ->
+ ()
+ in
+ let print_dvar_dpred = function
+ | DeclFun (id, _, [], t) ->
+ fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t
+ | DeclFun (id, _, l, t) ->
+ fprintf fmt "@[logic %a : %a -> %a@]@\n@\n"
+ ident id (print_list comma print_typ) l print_typ t
+ | DeclPred (id, _, []) when not (List.mem_assoc id defined_preds) ->
+ fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id
+ | DeclPred (id, _, l) when not (List.mem_assoc id defined_preds) ->
+ fprintf fmt "@[logic %a : %a -> prop@]@\n@\n"
+ ident id (print_list comma print_typ) l
+ | DeclType _ | Axiom _ | DeclPred _ ->
+ ()
+ in
+ let print_assert = function
+ | Axiom(id,_) when List.mem_assoc id defined_preds ->
+ let args, def = List.assoc id defined_preds in
+ fprintf fmt "@[predicate %a(%a) =@\n%a@]@\n" ident id
+ (print_list comma print_arg) args print_predicate def
+ | Axiom (id, f) ->
+ fprintf fmt "@[<hov 2>axiom %a:@ %a@]@\n@\n" ident id print_predicate f
+ | DeclType _ | DeclFun _ | DeclPred _ ->
+ ()
+ in
+ List.iter print_dtype decls;
+ List.iter print_dvar_dpred decls;
+ List.iter print_assert decls;
+ fprintf fmt "@[<hov 2>goal coq___goal: %a@]" print_predicate concl
+
+let output_file f q =
+ let c = open_out f in
+ let fmt = formatter_of_out_channel c in
+ fprintf fmt "include \"real.why\"@.";
+ fprintf fmt "@[%a@]@." print_query q;
+ close_out c
diff --git a/plugins/dp/dp_why.mli b/plugins/dp/dp_why.mli
new file mode 100644
index 00000000..0efa24a2
--- /dev/null
+++ b/plugins/dp/dp_why.mli
@@ -0,0 +1,17 @@
+
+open Fol
+
+(* generation of the Why file *)
+
+val output_file : string -> query -> unit
+
+(* table to translate the proofs back to Coq (used in dp_zenon) *)
+
+type proof =
+ | Immediate of Term.constr
+ | Fun_def of string * (string * typ) list * typ * term
+
+val add_proof : proof -> string
+val find_proof : string -> proof
+
+
diff --git a/plugins/dp/dp_zenon.mli b/plugins/dp/dp_zenon.mli
new file mode 100644
index 00000000..0a727d1f
--- /dev/null
+++ b/plugins/dp/dp_zenon.mli
@@ -0,0 +1,7 @@
+
+open Fol
+
+val set_debug : bool -> unit
+
+val proof_from_file : string -> Proof_type.tactic
+
diff --git a/plugins/dp/dp_zenon.mll b/plugins/dp/dp_zenon.mll
new file mode 100644
index 00000000..949e91e3
--- /dev/null
+++ b/plugins/dp/dp_zenon.mll
@@ -0,0 +1,189 @@
+
+{
+
+ open Lexing
+ open Pp
+ open Util
+ open Names
+ open Tacmach
+ open Dp_why
+ open Tactics
+ open Tacticals
+
+ let debug = ref false
+ let set_debug b = debug := b
+
+ let buf = Buffer.create 1024
+
+ let string_of_global env ref =
+ Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref)
+
+ let axioms = ref []
+
+ (* we cannot interpret the terms as we read them (since some lemmas
+ may need other lemmas to be already interpreted) *)
+ type lemma = { l_id : string; l_type : string; l_proof : string }
+ type zenon_proof = lemma list * string
+
+}
+
+let ident = ['a'-'z' 'A'-'Z' '_' '0'-'9' '\'']+
+let space = [' ' '\t' '\r']
+
+rule start = parse
+| "(* BEGIN-PROOF *)" "\n" { scan lexbuf }
+| _ { start lexbuf }
+| eof { anomaly "malformed Zenon proof term" }
+
+(* here we read the lemmas and the main proof term;
+ meanwhile we maintain the set of axioms that were used *)
+
+and scan = parse
+| "Let" space (ident as id) space* ":"
+ { let t = read_coq_term lexbuf in
+ let p = read_lemma_proof lexbuf in
+ let l,pr = scan lexbuf in
+ { l_id = id; l_type = t; l_proof = p } :: l, pr }
+| "Definition theorem:"
+ { let t = read_main_proof lexbuf in [], t }
+| _ | eof
+ { anomaly "malformed Zenon proof term" }
+
+and read_coq_term = parse
+| "." "\n"
+ { let s = Buffer.contents buf in Buffer.clear buf; s }
+| "coq__" (ident as id) (* a Why keyword renamed *)
+ { Buffer.add_string buf id; read_coq_term lexbuf }
+| ("dp_axiom__" ['0'-'9']+) as id
+ { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf }
+| _ as c
+ { Buffer.add_char buf c; read_coq_term lexbuf }
+| eof
+ { anomaly "malformed Zenon proof term" }
+
+and read_lemma_proof = parse
+| "Proof" space
+ { read_coq_term lexbuf }
+| _ | eof
+ { anomaly "malformed Zenon proof term" }
+
+(* skip the main proof statement and then read its term *)
+and read_main_proof = parse
+| ":=" "\n"
+ { read_coq_term lexbuf }
+| _
+ { read_main_proof lexbuf }
+| eof
+ { anomaly "malformed Zenon proof term" }
+
+
+{
+
+ let read_zenon_proof f =
+ Buffer.clear buf;
+ let c = open_in f in
+ let lb = from_channel c in
+ let p = start lb in
+ close_in c;
+ if not !debug then begin try Sys.remove f with _ -> () end;
+ p
+
+ let constr_of_string gl s =
+ let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in
+ Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s)
+
+ (* we are lazy here: we build strings containing Coq terms using a *)
+ (* pretty-printer Fol -> Coq *)
+ module Coq = struct
+ open Format
+ open Fol
+
+ let rec print_list sep print fmt = function
+ | [] -> ()
+ | [x] -> print fmt x
+ | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r
+
+ let space fmt () = fprintf fmt "@ "
+ let comma fmt () = fprintf fmt ",@ "
+
+ let rec print_typ fmt = function
+ | Tvar x -> fprintf fmt "%s" x
+ | Tid ("int", []) -> fprintf fmt "Z"
+ | Tid (x, []) -> fprintf fmt "%s" x
+ | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t
+ | Tid (x,tl) ->
+ fprintf fmt "(%s %a)" x (print_list comma print_typ) tl
+
+ let rec print_term fmt = function
+ | Cst n ->
+ fprintf fmt "%s" (Big_int.string_of_big_int n)
+ | RCst s ->
+ fprintf fmt "%s" (Big_int.string_of_big_int s)
+ | Power2 n ->
+ fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n)
+
+ (* TODO: bug, it might be operations on reals *)
+ | Plus (a, b) ->
+ fprintf fmt "@[(Zplus %a %a)@]" print_term a print_term b
+ | Moins (a, b) ->
+ fprintf fmt "@[(Zminus %a %a)@]" print_term a print_term b
+ | Mult (a, b) ->
+ fprintf fmt "@[(Zmult %a %a)@]" print_term a print_term b
+ | Div (a, b) ->
+ fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b
+ | Opp (a) ->
+ fprintf fmt "@[(Zopp %a)@]" print_term a
+ | App (id, []) ->
+ fprintf fmt "%s" id
+ | App (id, tl) ->
+ fprintf fmt "@[(%s %a)@]" id print_terms tl
+
+ and print_terms fmt tl =
+ print_list space print_term fmt tl
+
+ (* builds the text for "forall vars, f vars = t" *)
+ let fun_def_axiom f vars t =
+ let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in
+ fprintf str_formatter
+ "@[(forall %a, %s %a = %a)@]@."
+ (print_list space binder) vars f
+ (print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars
+ print_term t;
+ flush_str_formatter ()
+
+ end
+
+ let prove_axiom id = match Dp_why.find_proof id with
+ | Immediate t ->
+ exact_check t
+ | Fun_def (f, vars, ty, t) ->
+ tclTHENS
+ (fun gl ->
+ let s = Coq.fun_def_axiom f vars t in
+ if !debug then Format.eprintf "axiom fun def = %s@." s;
+ let c = constr_of_string gl s in
+ assert_tac (Name (id_of_string id)) c gl)
+ [tclTHEN intros reflexivity; tclIDTAC]
+
+ let exact_string s gl =
+ let c = constr_of_string gl s in
+ exact_check c gl
+
+ let interp_zenon_proof (ll,p) =
+ let interp_lemma l gl =
+ let ty = constr_of_string gl l.l_type in
+ tclTHENS
+ (assert_tac (Name (id_of_string l.l_id)) ty)
+ [exact_string l.l_proof; tclIDTAC]
+ gl
+ in
+ tclTHEN (tclMAP interp_lemma ll) (exact_string p)
+
+ let proof_from_file f =
+ axioms := [];
+ msgnl (str "proof_from_file " ++ str f);
+ let zp = read_zenon_proof f in
+ msgnl (str "proof term is " ++ str (snd zp));
+ tclTHEN (tclMAP prove_axiom !axioms) (interp_zenon_proof zp)
+
+}
diff --git a/plugins/dp/fol.mli b/plugins/dp/fol.mli
new file mode 100644
index 00000000..4fb763a6
--- /dev/null
+++ b/plugins/dp/fol.mli
@@ -0,0 +1,58 @@
+
+(* Polymorphic First-Order Logic (that is Why's input logic) *)
+
+type typ =
+ | Tvar of string
+ | Tid of string * typ list
+
+type term =
+ | Cst of Big_int.big_int
+ | RCst of Big_int.big_int
+ | Power2 of Big_int.big_int
+ | Plus of term * term
+ | Moins of term * term
+ | Mult of term * term
+ | Div of term * term
+ | Opp of term
+ | App of string * term list
+
+and atom =
+ | Eq of term * term
+ | Le of term * term
+ | Lt of term * term
+ | Ge of term * term
+ | Gt of term * term
+ | Pred of string * term list
+
+and form =
+ | Fatom of atom
+ | Imp of form * form
+ | Iff of form * form
+ | And of form * form
+ | Or of form * form
+ | Not of form
+ | Forall of string * typ * form
+ | Exists of string * typ * form
+ | True
+ | False
+
+(* the integer indicates the number of type variables *)
+type decl =
+ | DeclType of string * int
+ | DeclFun of string * int * typ list * typ
+ | DeclPred of string * int * typ list
+ | Axiom of string * form
+
+type query = decl list * form
+
+
+(* prover result *)
+
+type prover_answer =
+ | Valid of string option
+ | Invalid
+ | DontKnow
+ | Timeout
+ | NoAnswer
+ | Failure of string
+
diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4
new file mode 100644
index 00000000..82f86cd8
--- /dev/null
+++ b/plugins/dp/g_dp.ml4
@@ -0,0 +1,79 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Dp
+
+TACTIC EXTEND Simplify
+ [ "simplify" ] -> [ simplify ]
+END
+
+TACTIC EXTEND Ergo
+ [ "ergo" ] -> [ ergo ]
+END
+
+TACTIC EXTEND Yices
+ [ "yices" ] -> [ yices ]
+END
+
+TACTIC EXTEND CVC3
+ [ "cvc3" ] -> [ cvc3 ]
+END
+
+TACTIC EXTEND Z3
+ [ "z3" ] -> [ z3 ]
+END
+
+TACTIC EXTEND CVCLite
+ [ "cvcl" ] -> [ cvc_lite ]
+END
+
+TACTIC EXTEND Harvey
+ [ "harvey" ] -> [ harvey ]
+END
+
+TACTIC EXTEND Zenon
+ [ "zenon" ] -> [ zenon ]
+END
+
+TACTIC EXTEND Gwhy
+ [ "gwhy" ] -> [ gwhy ]
+END
+
+(* should be part of basic tactics syntax *)
+TACTIC EXTEND admit
+ [ "admit" ] -> [ Tactics.admit_as_an_axiom ]
+END
+
+VERNAC COMMAND EXTEND Dp_hint
+ [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ]
+END
+
+VERNAC COMMAND EXTEND Dp_timeout
+| [ "Dp_timeout" natural(n) ] -> [ dp_timeout n ]
+END
+
+VERNAC COMMAND EXTEND Dp_prelude
+| [ "Dp_prelude" string_list(l) ] -> [ dp_prelude l ]
+END
+
+VERNAC COMMAND EXTEND Dp_predefined
+| [ "Dp_predefined" global(g) "=>" string(s) ] -> [ dp_predefined g s ]
+END
+
+VERNAC COMMAND EXTEND Dp_debug
+| [ "Dp_debug" ] -> [ dp_debug true; Dp_zenon.set_debug true ]
+END
+
+VERNAC COMMAND EXTEND Dp_trace
+| [ "Dp_trace" ] -> [ dp_trace true ]
+END
+
diff --git a/plugins/dp/test2.v b/plugins/dp/test2.v
new file mode 100644
index 00000000..0940b135
--- /dev/null
+++ b/plugins/dp/test2.v
@@ -0,0 +1,80 @@
+Require Import ZArith.
+Require Import Classical.
+Require Import List.
+
+Open Scope list_scope.
+Open Scope Z_scope.
+
+Dp_debug.
+Dp_timeout 3.
+Require Export zenon.
+
+Definition neg (z:Z) : Z := match z with
+ | Z0 => Z0
+ | Zpos p => Zneg p
+ | Zneg p => Zpos p
+ end.
+
+Goal forall z, neg (neg z) = z.
+ Admitted.
+
+Open Scope nat_scope.
+Print plus.
+
+Goal forall x, x+0=x.
+ induction x; ergo.
+ (* simplify resoud le premier, pas le second *)
+ Admitted.
+
+Goal 1::2::3::nil = 1::2::(1+2)::nil.
+ zenon.
+ Admitted.
+
+Definition T := nat.
+Parameter fct : T -> nat.
+Goal fct O = O.
+ Admitted.
+
+Fixpoint even (n:nat) : Prop :=
+ match n with
+ O => True
+ | S O => False
+ | S (S p) => even p
+ end.
+
+Goal even 4%nat.
+ try zenon.
+ Admitted.
+
+Definition p (A B:Set) (a:A) (b:B) : list (A*B) := cons (a,b) nil.
+
+Definition head :=
+fun (A : Set) (l : list A) =>
+match l with
+| nil => None (A:=A)
+| x :: _ => Some x
+end.
+
+Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
+
+Admitted.
+
+(*
+BUG avec head prédéfini : manque eta-expansion sur A:Set
+
+Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1.
+
+Print value.
+Print Some.
+
+zenon.
+*)
+
+Inductive IN (A:Set) : A -> list A -> Prop :=
+ | IN1 : forall x l, IN A x (x::l)
+ | IN2: forall x l, IN A x l -> forall y, IN A x (y::l).
+Implicit Arguments IN [A].
+
+Goal forall x, forall (l:list nat), IN x l -> IN x (1%nat::l).
+ zenon.
+Print In.
diff --git a/plugins/dp/tests.v b/plugins/dp/tests.v
new file mode 100644
index 00000000..dc85d2ee
--- /dev/null
+++ b/plugins/dp/tests.v
@@ -0,0 +1,300 @@
+
+Require Import ZArith.
+Require Import Classical.
+Require Export Reals.
+
+
+(* real numbers *)
+
+Lemma real_expr: (0 <= 9 * 4)%R.
+ergo.
+Qed.
+
+Lemma powerRZ_translation: (powerRZ 2 15 < powerRZ 2 17)%R.
+ergo.
+Qed.
+
+Dp_debug.
+Dp_timeout 3.
+
+(* module renamings *)
+
+Module M.
+ Parameter t : Set.
+End M.
+
+Lemma test_module_0 : forall x:M.t, x=x.
+ergo.
+Qed.
+
+Module N := M.
+
+Lemma test_module_renaming_0 : forall x:N.t, x=x.
+ergo.
+Qed.
+
+Dp_predefined M.t => "int".
+
+Lemma test_module_renaming_1 : forall x:N.t, x=x.
+ergo.
+Qed.
+
+(* Coq lists *)
+
+Require Export List.
+
+Lemma test_pol_0 : forall l:list nat, l=l.
+ergo.
+Qed.
+
+Parameter nlist: list nat -> Prop.
+
+Lemma poly_1 : forall l, nlist l -> True.
+intros.
+simplify.
+Qed.
+
+(* user lists *)
+
+Inductive list (A:Set) : Set :=
+| nil : list A
+| cons: forall a:A, list A -> list A.
+
+Fixpoint app (A:Set) (l m:list A) {struct l} : list A :=
+match l with
+| nil => m
+| cons a l1 => cons A a (app A l1 m)
+end.
+
+Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True.
+intros; ergo.
+Qed.
+
+(* polymorphism *)
+Require Import List.
+
+Inductive mylist (A:Set) : Set :=
+ mynil : mylist A
+| mycons : forall a:A, mylist A -> mylist A.
+
+Parameter my_nlist: mylist nat -> Prop.
+
+ Goal forall l, my_nlist l -> True.
+ intros.
+ simplify.
+Qed.
+
+(* First example with the 0 and the equality translated *)
+
+Goal 0 = 0.
+simplify.
+Qed.
+
+(* Examples in the Propositional Calculus
+ and theory of equality *)
+
+Parameter A C : Prop.
+
+Goal A -> A.
+simplify.
+Qed.
+
+
+Goal A -> (A \/ C).
+
+simplify.
+Qed.
+
+
+Parameter x y z : Z.
+
+Goal x = y -> y = z -> x = z.
+ergo.
+Qed.
+
+
+Goal ((((A -> C) -> A) -> A) -> C) -> C.
+
+ergo.
+Qed.
+
+(* Arithmetic *)
+Open Scope Z_scope.
+
+Goal 1 + 1 = 2.
+yices.
+Qed.
+
+
+Goal 2*x + 10 = 18 -> x = 4.
+
+simplify.
+Qed.
+
+
+(* Universal quantifier *)
+
+Goal (forall (x y : Z), x = y) -> 0=1.
+try zenon.
+ergo.
+Qed.
+
+Goal forall (x: nat), (x + 0 = x)%nat.
+
+induction x0; ergo.
+Qed.
+
+
+(* No decision procedure can solve this problem
+ Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a.
+*)
+
+
+(* Functions definitions *)
+
+Definition fst (x y : Z) : Z := x.
+
+Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x.
+
+simplify.
+Qed.
+
+
+(* Eta-expansion example *)
+
+Definition snd_of_3 (x y z : Z) : Z := y.
+
+Definition f : Z -> Z -> Z := snd_of_3 0.
+
+Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1.
+
+simplify.
+Qed.
+
+
+(* Inductive types definitions - call to dp/injection function *)
+
+Inductive even : Z -> Prop :=
+| even_0 : even 0
+| even_plus2 : forall z : Z, even z -> even (z + 2).
+
+
+(* Simplify and Zenon can't prove this goal before the timeout
+ unlike CVC Lite *)
+
+Goal even 4.
+ergo.
+Qed.
+
+
+Definition skip_z (z : Z) (n : nat) := n.
+
+Definition skip_z1 := skip_z.
+
+Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n.
+yices.
+Qed.
+
+
+(* Axioms definitions and dp_hint *)
+
+Parameter add : nat -> nat -> nat.
+Axiom add_0 : forall (n : nat), add 0%nat n = n.
+Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2).
+
+Dp_hint add_0.
+Dp_hint add_S.
+
+(* Simplify can't prove this goal before the timeout
+ unlike zenon *)
+
+Goal forall n : nat, add n 0 = n.
+induction n ; yices.
+Qed.
+
+
+Definition pred (n : nat) : nat := match n with
+ | 0%nat => 0%nat
+ | S n' => n'
+end.
+
+Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat.
+yices.
+(*zenon.*)
+Qed.
+
+
+Fixpoint plus (n m : nat) {struct n} : nat :=
+ match n with
+ | 0%nat => m
+ | S n' => S (plus n' m)
+end.
+
+Goal forall n : nat, plus n 0%nat = n.
+
+induction n; ergo.
+Qed.
+
+
+(* Mutually recursive functions *)
+
+Fixpoint even_b (n : nat) : bool := match n with
+ | O => true
+ | S m => odd_b m
+end
+with odd_b (n : nat) : bool := match n with
+ | O => false
+ | S m => even_b m
+end.
+
+Goal even_b (S (S O)) = true.
+ergo.
+(*
+simplify.
+zenon.
+*)
+Qed.
+
+
+(* sorts issues *)
+
+Parameter foo : Set.
+Parameter ff : nat -> foo -> foo -> nat.
+Parameter g : foo -> foo.
+Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O.
+yices.
+(*zenon.*)
+Qed.
+
+
+
+(* abstractions *)
+
+Parameter poly_f : forall A:Set, A->A.
+
+Goal forall x:nat, poly_f nat x = poly_f nat x.
+ergo.
+(*zenon.*)
+Qed.
+
+
+
+(* Anonymous mutually recursive functions : no equations are produced
+
+Definition mrf :=
+ fix even2 (n : nat) : bool := match n with
+ | O => true
+ | S m => odd2 m
+ end
+ with odd2 (n : nat) : bool := match n with
+ | O => false
+ | S m => even2 m
+ end for even.
+
+ Thus this goal is unsolvable
+
+Goal mrf (S (S O)) = true.
+
+zenon.
+
+*)
diff --git a/plugins/dp/vo.itarget b/plugins/dp/vo.itarget
new file mode 100644
index 00000000..4d282709
--- /dev/null
+++ b/plugins/dp/vo.itarget
@@ -0,0 +1 @@
+Dp.vo
diff --git a/plugins/dp/zenon.v b/plugins/dp/zenon.v
new file mode 100644
index 00000000..502465c6
--- /dev/null
+++ b/plugins/dp/zenon.v
@@ -0,0 +1,94 @@
+(* Copyright 2004 INRIA *)
+(* $Id$ *)
+
+Require Export Classical.
+
+Lemma zenon_nottrue :
+ (~True -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_noteq : forall (T : Type) (t : T),
+ ((t <> t) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_and : forall P Q : Prop,
+ (P -> Q -> False) -> (P /\ Q -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_or : forall P Q : Prop,
+ (P -> False) -> (Q -> False) -> (P \/ Q -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_imply : forall P Q : Prop,
+ (~P -> False) -> (Q -> False) -> ((P -> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_equiv : forall P Q : Prop,
+ (~P -> ~Q -> False) -> (P -> Q -> False) -> ((P <-> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notand : forall P Q : Prop,
+ (~P -> False) -> (~Q -> False) -> (~(P /\ Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notor : forall P Q : Prop,
+ (~P -> ~Q -> False) -> (~(P \/ Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notimply : forall P Q : Prop,
+ (P -> ~Q -> False) -> (~(P -> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_notequiv : forall P Q : Prop,
+ (~P -> Q -> False) -> (P -> ~Q -> False) -> (~(P <-> Q) -> False).
+Proof. tauto. Qed.
+
+Lemma zenon_ex : forall (T : Type) (P : T -> Prop),
+ (forall z : T, ((P z) -> False)) -> ((exists x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_all : forall (T : Type) (P : T -> Prop) (t : T),
+ ((P t) -> False) -> ((forall x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_notex : forall (T : Type) (P : T -> Prop) (t : T),
+ (~(P t) -> False) -> (~(exists x : T, (P x)) -> False).
+Proof. firstorder. Qed.
+
+Lemma zenon_notall : forall (T : Type) (P : T -> Prop),
+ (forall z : T, (~(P z) -> False)) -> (~(forall x : T, (P x)) -> False).
+Proof. intros T P Ha Hb. apply Hb. intro. apply NNPP. exact (Ha x). Qed.
+
+Lemma zenon_equal_base : forall (T : Type) (f : T), f = f.
+Proof. auto. Qed.
+
+Lemma zenon_equal_step :
+ forall (S T : Type) (fa fb : S -> T) (a b : S),
+ (fa = fb) -> (a <> b -> False) -> ((fa a) = (fb b)).
+Proof. intros. rewrite (NNPP (a = b)). congruence. auto. Qed.
+
+Lemma zenon_pnotp : forall P Q : Prop,
+ (P = Q) -> (P -> ~Q -> False).
+Proof. intros P Q Ha. rewrite Ha. auto. Qed.
+
+Lemma zenon_notequal : forall (T : Type) (a b : T),
+ (a = b) -> (a <> b -> False).
+Proof. auto. Qed.
+
+Ltac zenon_intro id :=
+ intro id || let nid := fresh in (intro nid; clear nid)
+.
+
+Definition zenon_and_s := fun P Q a b => zenon_and P Q b a.
+Definition zenon_or_s := fun P Q a b c => zenon_or P Q b c a.
+Definition zenon_imply_s := fun P Q a b c => zenon_imply P Q b c a.
+Definition zenon_equiv_s := fun P Q a b c => zenon_equiv P Q b c a.
+Definition zenon_notand_s := fun P Q a b c => zenon_notand P Q b c a.
+Definition zenon_notor_s := fun P Q a b => zenon_notor P Q b a.
+Definition zenon_notimply_s := fun P Q a b => zenon_notimply P Q b a.
+Definition zenon_notequiv_s := fun P Q a b c => zenon_notequiv P Q b c a.
+Definition zenon_ex_s := fun T P a b => zenon_ex T P b a.
+Definition zenon_notall_s := fun T P a b => zenon_notall T P b a.
+
+Definition zenon_pnotp_s := fun P Q a b c => zenon_pnotp P Q c a b.
+Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x.
diff --git a/plugins/extraction/CHANGES b/plugins/extraction/CHANGES
new file mode 100644
index 00000000..fbcd01a1
--- /dev/null
+++ b/plugins/extraction/CHANGES
@@ -0,0 +1,414 @@
+8.0 -> today
+
+See the main CHANGES file in the archive
+
+
+7.4 -> 8.0
+
+No revolution this time. Mostly "behind-the-scene" clean-up and bug-fixes,
+but also a few steps toward a more user-friendly extraction:
+
+* syntax of extraction:
+- The old (Recursive) Extraction Module M.
+ is now (Recursive) Extraction Library M.
+ The old name was misleading since this command only works with M being a
+ library M.v, and not a module produced by interactive command Module M.
+- The other commands
+ Extraction foo.
+ Recursive Extraction foo bar.
+ Extraction "myfile.ml" foo bar.
+ now accept that foo can be a module name instead of just a constant name.
+
+* Support of type scheme axioms (i.e. axiom whose type is an arity
+ (x1:X1)...(xn:Xn)s with s a sort). For example:
+
+ Axiom myprod : Set -> Set -> Set.
+ Extract Constant myprod "'a" "'b" => "'a * 'b".
+ Recursive Extraction myprod.
+ -------> type ('a,'b) myprod = 'a * 'b
+
+* More flexible support of axioms. When an axiom isn't realized via Extract
+ Constant before extraction, a warning is produced (instead of an error),
+ and the extracted code must be completed later by hand. To find what
+ needs to be completed, search for the following string: AXIOM TO BE REALIZED
+
+* Cosmetics: When extraction produces a file, it tells it.
+
+* (Experimental) It is allowed to extract under a opened interactive module
+ (but still outside sections). Feature to be used with caution.
+
+* A problem has been identified concerning .v files used as normal interactive
+ modules, like in
+
+ <file A.v>
+ Definition foo :=O.
+ <End file A.v>
+
+ <at toplevel>
+ Require A.
+ Module M:=A
+ Extraction M.
+
+ I might try to support that in the future. In the meanwhile, the
+ current behaviour of extraction is to forbid this.
+
+* bug fixes:
+- many concerning Records.
+- a Stack Overflow with mutual inductive (PR#320)
+- some optimizations have been removed since they were not type-safe:
+ For example if e has type: type 'x a = A
+ Then: match e with A -> A -----X----> e
+ To be investigated further.
+
+
+7.3 -> 7.4
+
+* The two main new features:
+ - Automatic generation of Obj.magic when the extracted code
+ in Ocaml is not directly typable.
+ - An experimental extraction of Coq's new modules to Ocaml modules.
+
+* Concerning those Obj.magic:
+ - The extraction now computes the expected type of any terms. Then
+ it compares it with the actual type of the produced code. And when
+ a mismatch is found, a Obj.magic is inserted.
+
+ - As a rule, any extracted development that was compiling out of the box
+ should not contain any Obj.magic. At the other hand, generation of
+ Obj.magic is not optimized yet: there might be several of them at a place
+ were one would have been enough.
+
+ - Examples of code needing those Obj.magic:
+ * plugins/extraction/test_extraction.v in the Coq source
+ * in the users' contributions:
+ Lannion
+ Lyon/CIRCUITS
+ Rocq/HIGMAN
+
+ - As a side-effect of this Obj.magic feature, we now print the types
+ of the extracted terms, both in .ml files as commented documentation
+ and in interfaces .mli files
+
+ - This feature hasn't been ported yet to Haskell. We are aware of
+ some unsafe casting functions like "unsafeCoerce" on some Haskell implems.
+ So it will eventually be done.
+
+* Concerning the extraction of Coq's new modules:
+ - Taking in account the new Coq's modules system has implied a *huge*
+ rewrite of most of the extraction code.
+
+ - The extraction core (translation from Coq to an abstract mini-ML)
+ is now complete and fairly stable, and supports modules, modules type
+ and functors and all that stuff.
+
+ - The ocaml pretty-print part, especially the renaming issue, is
+ clearly weaker, and certainly still contains bugs.
+
+ - Nothing done for translating these Coq Modules to Haskell.
+
+ - A temporary drawback of this module extraction implementation is that
+ efficiency (especially extraction speed) has been somehow neglected.
+ To improve ...
+
+ - As an interesting side-effect, definitions are now printed according to
+ the user's original order. No more of this "dependency-correct but weird"
+ order. In particular realized axioms via Extract Constant are now at their
+ right place, and not at the beginning.
+
+* Other news:
+
+ - Records are now printed using the Ocaml record syntax
+
+ - Syntax output toward Scheme. Quite funny, but quite experimental and
+ not documented. I recommend using the bigloo compiler since it contains
+ natively some pattern matching.
+
+ - the dummy constant "__" have changed. see README
+
+ - a few bug-fixes (#191 and others)
+
+7.2 -> 7.3
+
+* Improved documentation in the Reference Manual.
+
+* Theoretical bad news:
+- a naughty example (see the end of test_extraction.v)
+forced me to stop eliminating lambdas and arguments corresponding to
+so-called "arity" in the general case.
+
+- The dummy constant used in extraction ( let prop = () in ocaml )
+may in some cases be applied to arguments. This problem is dealt by
+generating sufficient abstraction before the ().
+
+
+* Theoretical good news:
+- there is now a mechanism that remove useless prop/arity lambdas at the
+top of function declarations. If your function had signature
+nat -> prop -> nat in the previous extraction, it will now be nat -> nat.
+So the extractions of common terms should look very much like the old
+V6.2 one, except in some particular cases (functions as parameters, partial
+applications, etc). In particular the bad news above have nearly no
+impact...
+
+
+* By the way there is no more "let prop = ()" in ocaml. Those () are
+directly inlined. And in Haskell the dummy constant is now __ (two
+underscore) and is defined by
+__ = Prelude.error "Logical or arity value used"
+This dummy constant should never be evaluated when computing an
+informative value, thanks to the lazy strategy. Hence the error message.
+
+
+* Syntax changes, see Documentation for details:
+
+Extraction Language Ocaml.
+Extraction Language Haskell.
+Extraction Language Toplevel.
+
+That fixes the target language of extraction. Default is Ocaml, even in the
+coq toplevel: you can now do copy-paste from the coq toplevel without
+renaming problems. Toplevel language is the ocaml pseudo-language used
+previously used inside the coq toplevel: coq names are printed with the coq
+way, i.e. with no renaming.
+
+So there is no more particular commands for Haskell, like
+Haskell Extraction "file" id. Just set your favourite language and go...
+
+
+* Haskell extraction has been tested at last (and corrected...).
+See specificities in Documentation.
+
+
+* Extraction of CoInductive in Ocaml language is now correct: it uses the
+Lazy.force and lazy features of Ocaml.
+
+
+* Modular extraction in Ocaml is now far more readable:
+instead of qualifying everywhere (A.foo), there are now some "open" at the
+beginning of files. Possible clashes are dealt with.
+
+
+* By default, any recursive function associated with an inductive type
+(foo_rec and foo_rect when foo is inductive type) will now be inlined
+in extracted code.
+
+
+* A few constants are explicitely declared to be inlined in extracted code.
+For the moment there are:
+ Wf.Acc_rec
+ Wf.Acc_rect
+ Wf.well_founded_induction
+ Wf.well_founded_induction_type
+Those constants does not match the auto-inlining criterion based on strictness.
+Of course, you can still overide this behaviour via some Extraction NoInline.
+
+* There is now a web page showing the extraction of all standard theories:
+http://www.lri.fr/~letouzey/extraction
+
+
+7.1 -> 7.2 :
+
+* Syntax changes, see Documentation for more details:
+
+Set/Unset Extraction Optimize.
+
+Default is Set. This control all optimizations made on the ML terms
+(mostly reduction of dummy beta/iota redexes, but also simplications on
+Cases, etc). Put this option to Unset if you what a ML term as close as
+possible to the Coq term.
+
+Set/Unset Extraction AutoInline.
+
+Default in Set, so by default, the extraction mechanism feels free to
+inline the bodies of some defined constants, according to some heuristics
+like size of bodies, useness of some arguments, etc. Those heuristics are
+not always perfect, you may want to disable this feature, do it by Unset.
+
+Extraction Inline toto foo.
+Extraction NoInline titi faa bor.
+
+In addition to the automatic inline feature, you can now tell precisely to
+inline some more constants by the Extraction Inline command. Conversely,
+you can forbid the inlining of some specific constants by automatic inlining.
+Those two commands enable a precise control of what is inlined and what is not.
+
+Print Extraction Inline.
+
+Sum up the current state of the table recording the custom inlings
+(Extraction (No)Inline).
+
+Reset Extraction Inline.
+
+Put the table recording the custom inlings back to empty.
+
+As a consequence, there is no more need for options inside the commands of
+extraction:
+
+Extraction foo.
+Recursive Extraction foo bar.
+Extraction "file" foo bar.
+Extraction Module Mymodule.
+Recursive Extraction Module Mymodule.
+
+New: The last syntax extracts the module Mymodule and all the modules
+it depends on.
+
+You can also try the Haskell versions (not tested yet):
+
+Haskell Extraction foo.
+Haskell Recursive Extraction foo bar.
+Haskell Extraction "file" foo bar.
+Haskell Extraction Module Mymodule.
+Haskell Recursive Extraction Module Mymodule.
+
+And there's still the realization syntax:
+
+Extract Constant coq_bla => "caml_bla".
+Extract Inlined Constant coq_bla => "caml_bla".
+Extract Inductive myinductive => mycamlind [my_caml_constr1 ... ].
+
+Note that now, the Extract Inlined Constant command is sugar for an Extract
+Constant followed by a Extraction Inline. So be careful with
+Reset Extraction Inline.
+
+
+
+* Lot of works around optimization of produced code. Should make code more
+readable.
+
+- fixpoint definitions : there should be no more stupid printings like
+
+let foo x =
+ let rec f x =
+ .... (f y) ....
+ in f x
+
+but rather
+
+let rec foo x =
+ .... (foo y) ....
+
+- generalized iota (in particular iota and permutation cases/cases):
+
+A generalized iota redex is a "Cases e of ...." where e is ok.
+And the recursive predicate "ok" is given by:
+e is ok if e is a Constructor or a Cases where all branches are ok.
+In the case of generalized iota redex, it might be good idea to reduce it,
+so we do it.
+Example:
+
+match (match t with
+ O -> Left
+ | S n -> match n with
+ O -> Right
+ | S m -> Left) with
+ Left -> blabla
+| Right -> bloblo
+
+After simplification, that gives:
+
+match t with
+ O -> blabla
+| S n -> match n with
+ O -> bloblo
+ | S n -> blabla
+
+As shown on the example, code duplication can occur. In practice
+it seems not to happen frequently.
+
+- "constant" case:
+In V7.1 we used to simplify cases where all branches are the same.
+In V7.2 we can simplify in addition terms like
+ cases e of
+ C1 x y -> f (C x y)
+ | C2 z -> f (C2 z)
+If x y z don't occur in f, we can produce (f e).
+
+- permutation cases/fun:
+extracted code has frequenty functions in branches of cases:
+
+let foo x = match x with
+ O -> fun _ -> ....
+ | S y -> fun _ -> ....
+
+the optimization consist in lifting the common "fun _ ->", and that gives
+
+let foo x _ = match x with
+ O -> .....
+ | S y -> ....
+
+
+* Some bug corrections (many thanks in particular to Michel Levy).
+
+* Testing in coq contributions:
+If you are interested in extraction, you can look at the extraction tests
+I'have put in the following coq contributions
+
+Bordeaux/Additions computation of fibonacci(2000)
+Bordeaux/EXCEPTIONS multiplication using exception.
+Bordeaux/SearchTrees list -> binary tree. maximum.
+Dyade/BDDS boolean tautology checker.
+Lyon/CIRCUITS multiplication via a modelization of a circuit.
+Lyon/FIRING-SQUAD print the states of the firing squad.
+Marseille/CIRCUITS compares integers via a modelization of a circuit.
+Nancy/FOUnify unification of two first-order terms.
+Rocq/ARITH/Chinese computation of the chinese remainder.
+Rocq/COC small coc typechecker. (test by B. Barras, not by me)
+Rocq/HIGMAN run the proof on one example.
+Rocq/GRAPHS linear constraints checker in Z.
+Sophia-Antipolis/Stalmarck boolean tautology checker.
+Suresnes/BDD boolean tautology checker.
+
+Just do "make" in those contributions, the extraction test is integrated.
+More tests will follow on more contributions.
+
+
+
+7.0 -> 7.1 : mostly bug corrections. No theoretical problems dealed with.
+
+* The semantics of Extract Constant changed: If you provide a extraction
+for p by Extract Constant p => "0", your generated ML file will begin by
+a let p = 0. The old semantics, which was to replace p everywhere by the
+provided terms, is still available via the Extract Inlined Constant p =>
+"0" syntax.
+
+
+* There are more optimizations applied to the generated code:
+- identity cases: match e with P x y -> P x y | Q z -> Q z | ...
+is simplified into e. Especially interesting with the sumbool terms:
+there will be no more match ... with Left -> Left | Right -> Right
+
+- constant cases: match e with P x y -> c | Q z -> c | ...
+is simplified into c as soon as x, y, z do not occur in c.
+So no more match ... with Left -> Left | Right -> Left.
+
+
+* the extraction at Toplevel (Extraction foo and Recursive Extraction foo),
+which was only a development tool at the beginning, is now closer to
+the real extraction to a file. In particular optimizations are done,
+and constants like recursors ( ..._rec ) are expanded.
+
+
+* the singleton optimization is now protected against circular type.
+( Remind : this optimization is the one that simplify
+type 'a sig = Exists of 'a into type 'a sig = 'a and
+match e with (Exists c) -> d into let c = e in d )
+
+
+* Fixed one bug concerning casted code
+
+
+* The inductives generated should now have always correct type-var list
+('a,'b,'c...)
+
+
+* Code cleanup until three days before release. Messing-up code
+in the last three days before release.
+
+
+
+
+
+
+
+6.x -> 7.0 : Everything changed. See README
diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v
new file mode 100644
index 00000000..f0135221
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlBasic.v
@@ -0,0 +1,33 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Extraction to Ocaml : use of basic Ocaml types *)
+
+Extract Inductive bool => bool [ true false ].
+Extract Inductive option => option [ Some None ].
+Extract Inductive unit => unit [ "()" ].
+Extract Inductive list => list [ "[]" "( :: )" ].
+Extract Inductive prod => "( * )" [ "" ].
+
+(** NB: The "" above is a hack, but produce nicer code than "(,)" *)
+
+(** Mapping sumbool to bool and sumor to option is not always nicer,
+ but it helps when realizing stuff like [lt_eq_lt_dec] *)
+
+Extract Inductive sumbool => bool [ true false ].
+Extract Inductive sumor => option [ Some None ].
+
+(** Restore lazyness of andb, orb.
+ NB: without these Extract Constant, andb/orb would be inlined
+ by extraction in order to have lazyness, producing inelegant
+ (if ... then ... else false) and (if ... then true else ...).
+*)
+
+Extract Inlined Constant andb => "(&&)".
+Extract Inlined Constant orb => "(||)".
+
diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v
new file mode 100644
index 00000000..b4490545
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlBigIntConv.v
@@ -0,0 +1,108 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Extraction to Ocaml: conversion from/to [big_int] *)
+
+(** NB: The extracted code should be linked with [nums.cm(x)a]
+ from ocaml's stdlib and with the wrapper [big.ml] that
+ simlifies the use of [Big_int] (it could be found in the sources
+ of Coq). *)
+
+Require Import Arith ZArith.
+
+Parameter bigint : Type.
+Parameter bigint_zero : bigint.
+Parameter bigint_succ : bigint -> bigint.
+Parameter bigint_opp : bigint -> bigint.
+Parameter bigint_twice : bigint -> bigint.
+
+Extract Inlined Constant bigint => "Big.big_int".
+Extract Inlined Constant bigint_zero => "Big.zero".
+Extract Inlined Constant bigint_succ => "Big.succ".
+Extract Inlined Constant bigint_opp => "Big.opp".
+Extract Inlined Constant bigint_twice => "Big.double".
+
+Definition bigint_of_nat : nat -> bigint :=
+ (fix loop acc n :=
+ match n with
+ | O => acc
+ | S n => loop (bigint_succ acc) n
+ end) bigint_zero.
+
+Fixpoint bigint_of_pos p :=
+ match p with
+ | xH => bigint_succ bigint_zero
+ | xO p => bigint_twice (bigint_of_pos p)
+ | xI p => bigint_succ (bigint_twice (bigint_of_pos p))
+ end.
+
+Fixpoint bigint_of_z z :=
+ match z with
+ | Z0 => bigint_zero
+ | Zpos p => bigint_of_pos p
+ | Zneg p => bigint_opp (bigint_of_pos p)
+ end.
+
+Fixpoint bigint_of_n n :=
+ match n with
+ | N0 => bigint_zero
+ | Npos p => bigint_of_pos p
+ end.
+
+(** NB: as for [pred] or [minus], [nat_of_bigint], [n_of_bigint] and
+ [pos_of_bigint] are total and return zero (resp. one) for
+ non-positive inputs. *)
+
+Parameter bigint_natlike_rec : forall A, A -> (A->A) -> bigint -> A.
+Extract Constant bigint_natlike_rec => "Big.nat_rec".
+
+Definition nat_of_bigint : bigint -> nat := bigint_natlike_rec _ O S.
+
+Parameter bigint_poslike_rec : forall A, (A->A) -> (A->A) -> A -> bigint -> A.
+Extract Constant bigint_poslike_rec => "Big.positive_rec".
+
+Definition pos_of_bigint : bigint -> positive := bigint_poslike_rec _ xI xO xH.
+
+Parameter bigint_zlike_case :
+ forall A, A -> (bigint->A) -> (bigint->A) -> bigint -> A.
+Extract Constant bigint_zlike_case => "Big.z_rec".
+
+Definition z_of_bigint : bigint -> Z :=
+ bigint_zlike_case _ Z0 (fun i => Zpos (pos_of_bigint i))
+ (fun i => Zneg (pos_of_bigint i)).
+
+Definition n_of_bigint : bigint -> N :=
+ bigint_zlike_case _ N0 (fun i => Npos (pos_of_bigint i)) (fun _ => N0).
+
+(* Tests:
+
+Definition small := 1234%nat.
+Definition big := 12345678901234567890%positive.
+
+Definition nat_0 := nat_of_bigint (bigint_of_nat 0).
+Definition nat_1 := nat_of_bigint (bigint_of_nat small).
+Definition pos_1 := pos_of_bigint (bigint_of_pos 1).
+Definition pos_2 := pos_of_bigint (bigint_of_pos big).
+Definition n_0 := n_of_bigint (bigint_of_n 0).
+Definition n_1 := n_of_bigint (bigint_of_n 1).
+Definition n_2 := n_of_bigint (bigint_of_n (Npos big)).
+Definition z_0 := z_of_bigint (bigint_of_z 0).
+Definition z_1 := z_of_bigint (bigint_of_z 1).
+Definition z_2 := z_of_bigint (bigint_of_z (Zpos big)).
+Definition z_m1 := z_of_bigint (bigint_of_z (-1)).
+Definition z_m2 := z_of_bigint (bigint_of_z (Zneg big)).
+
+Definition test :=
+ (nat_0, nat_1, pos_1, pos_2, n_0, n_1, n_2, z_0, z_1, z_2, z_m1, z_m2).
+Definition check :=
+ (O, small, xH, big, 0%N, 1%N, Npos big, 0%Z, 1%Z, Zpos big, (-1)%Z, Zneg big).
+
+Extraction "/tmp/test.ml" check test.
+
+... and we check that test=check
+*) \ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v
new file mode 100644
index 00000000..e729d9ca
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlIntConv.v
@@ -0,0 +1,97 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Extraction to Ocaml: conversion from/to [int]
+
+ Nota: no check that [int] values aren't generating overflows *)
+
+Require Import Arith ZArith.
+
+Parameter int : Type.
+Parameter int_zero : int.
+Parameter int_succ : int -> int.
+Parameter int_opp : int -> int.
+Parameter int_twice : int -> int.
+
+Extract Inlined Constant int => int.
+Extract Inlined Constant int_zero => "0".
+Extract Inlined Constant int_succ => "succ".
+Extract Inlined Constant int_opp => "-".
+Extract Inlined Constant int_twice => "2 *".
+
+Definition int_of_nat : nat -> int :=
+ (fix loop acc n :=
+ match n with
+ | O => acc
+ | S n => loop (int_succ acc) n
+ end) int_zero.
+
+Fixpoint int_of_pos p :=
+ match p with
+ | xH => int_succ int_zero
+ | xO p => int_twice (int_of_pos p)
+ | xI p => int_succ (int_twice (int_of_pos p))
+ end.
+
+Fixpoint int_of_z z :=
+ match z with
+ | Z0 => int_zero
+ | Zpos p => int_of_pos p
+ | Zneg p => int_opp (int_of_pos p)
+ end.
+
+Fixpoint int_of_n n :=
+ match n with
+ | N0 => int_zero
+ | Npos p => int_of_pos p
+ end.
+
+(** NB: as for [pred] or [minus], [nat_of_int], [n_of_int] and
+ [pos_of_int] are total and return zero (resp. one) for
+ non-positive inputs. *)
+
+Parameter int_natlike_rec : forall A, A -> (A->A) -> int -> A.
+Extract Constant int_natlike_rec =>
+"fun fO fS ->
+ let rec loop acc i = if i <= 0 then acc else loop (fS acc) (i-1)
+ in loop fO".
+
+Definition nat_of_int : int -> nat := int_natlike_rec _ O S.
+
+Parameter int_poslike_rec : forall A, A -> (A->A) -> (A->A) -> int -> A.
+Extract Constant int_poslike_rec =>
+"fun f1 f2x f2x1 ->
+ let rec loop i = if i <= 1 then f1 else
+ if i land 1 = 0 then f2x (loop (i lsr 1)) else f2x1 (loop (i lsr 1))
+ in loop".
+
+Definition pos_of_int : int -> positive := int_poslike_rec _ xH xO xI.
+
+Parameter int_zlike_case : forall A, A -> (int->A) -> (int->A) -> int -> A.
+Extract Constant int_zlike_case =>
+"fun f0 fpos fneg i ->
+ if i = 0 then f0 else if i>0 then fpos i else fneg (-i)".
+
+Definition z_of_int : int -> Z :=
+ int_zlike_case _ Z0 (fun i => Zpos (pos_of_int i))
+ (fun i => Zneg (pos_of_int i)).
+
+Definition n_of_int : int -> N :=
+ int_zlike_case _ N0 (fun i => Npos (pos_of_int i)) (fun _ => N0).
+
+(** Warning: [z_of_int] is currently wrong for Ocaml's [min_int],
+ since [min_int] has no positive opposite ([-min_int = min_int]).
+*)
+
+(*
+Extraction "/tmp/test.ml"
+ nat_of_int int_of_nat
+ pos_of_int int_of_pos
+ z_of_int int_of_z
+ n_of_int int_of_n.
+*) \ No newline at end of file
diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v
new file mode 100644
index 00000000..491e0258
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlNatBigInt.v
@@ -0,0 +1,69 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Extraction of [nat] into Ocaml's [big_int] *)
+
+Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import ExtrOcamlBasic.
+
+(** NB: The extracted code should be linked with [nums.cm(x)a]
+ from ocaml's stdlib and with the wrapper [big.ml] that
+ simlifies the use of [Big_int] (it could be found in the sources
+ of Coq). *)
+
+(** Disclaimer: trying to obtain efficient certified programs
+ by extracting [nat] into [big_int] isn't necessarily a good idea.
+ See comments in [ExtrOcamlNatInt.v].
+*)
+
+
+(** Mapping of [nat] into [big_int]. The last string corresponds to
+ a [nat_case], see documentation of [Extract Inductive]. *)
+
+Extract Inductive nat => "Big.big_int" [ "Big.zero" "Big.succ" ]
+ "Big.nat_case".
+
+(** Efficient (but uncertified) versions for usual [nat] functions *)
+
+Extract Constant plus => "Big.add".
+Extract Constant mult => "Big.mult".
+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 EqNat.beq_nat => "Big.eq".
+Extract Constant EqNat.eq_nat_decide => "Big.eq".
+
+Extract Constant Peano_dec.eq_nat_dec => "Big.eq".
+
+Extract Constant Compare_dec.nat_compare =>
+ "Big.compare_case Eq Lt Gt".
+
+Extract Constant Compare_dec.leb => "Big.le".
+Extract Constant Compare_dec.le_lt_dec => "Big.le".
+Extract Constant Compare_dec.lt_eq_lt_dec =>
+ "Big.compare_case (Some false) (Some true) None".
+
+Extract Constant Even.even_odd_dec =>
+ "fun n -> Big.sign (Big.mod n Big.two) = 0".
+Extract Constant Div2.div2 => "fun n -> Big.div n Big.two".
+
+Extract Inductive Euclid.diveucl => "(Big.big_int * Big.big_int)" [""].
+Extract Constant Euclid.eucl_dev => "fun n m -> Big.quomod m n".
+Extract Constant Euclid.quotient => "fun n m -> Big.div m n".
+Extract Constant Euclid.modulo => "fun n m -> Big.modulo m n".
+
+(*
+Require Import Euclid.
+Definition test n m (H:m>0) :=
+ let (q,r,_,_) := eucl_dev m H n in
+ nat_compare n (q*m+r).
+
+Extraction "/tmp/test.ml" test fact pred minus max min Div2.div2.
+*)
diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v
new file mode 100644
index 00000000..fe03bc60
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlNatInt.v
@@ -0,0 +1,75 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Extraction of [nat] into Ocaml's [int] *)
+
+Require Import Arith Even Div2 EqNat MinMax Euclid.
+Require Import ExtrOcamlBasic.
+
+(** Disclaimer: trying to obtain efficient certified programs
+ by extracting [nat] into [int] is definitively *not* a good idea:
+
+ - Since [int] is bounded while [nat] is (theoretically) infinite,
+ you have to make sure by yourself that your program will not
+ manipulate numbers greater than [max_int]. Otherwise you should
+ consider the translation of [nat] into [big_int].
+
+ - Moreover, the mere translation of [nat] into [int] does not
+ change the complexity of functions. For instance, [mult] stays
+ quadratic. To mitigate this, we propose here a few efficient (but
+ uncertified) realizers for some common functions over [nat].
+
+ This file is hence provided mainly for testing / prototyping
+ purpose. For serious use of numbers in extracted programs,
+ you are advised to use either coq advanced representations
+ (positive, Z, N, BigN, BigZ) or modular/axiomatic representation.
+*)
+
+
+(** Mapping of [nat] into [int]. The last string corresponds to
+ a [nat_case], see documentation of [Extract Inductive]. *)
+
+Extract Inductive nat => int [ "0" "succ" ]
+ "(fun fO fS n -> if n=0 then fO () else fS (n-1))".
+
+(** Efficient (but uncertified) versions for usual [nat] functions *)
+
+Extract Constant plus => "(+)".
+Extract Constant pred => "fun n -> max 0 (n-1)".
+Extract Constant minus => "fun n m -> max 0 (n-m)".
+Extract Constant mult => "( * )".
+Extract Inlined Constant max => max.
+Extract Inlined Constant min => min.
+Extract Inlined Constant nat_beq => "(=)".
+Extract Inlined Constant EqNat.beq_nat => "(=)".
+Extract Inlined Constant EqNat.eq_nat_decide => "(=)".
+
+Extract Inlined Constant Peano_dec.eq_nat_dec => "(=)".
+
+Extract Constant Compare_dec.nat_compare =>
+ "fun n m -> if n=m then Eq else if n<m then Lt else Gt".
+Extract Inlined Constant Compare_dec.leb => "(<=)".
+Extract Inlined Constant Compare_dec.le_lt_dec => "(<=)".
+Extract Constant Compare_dec.lt_eq_lt_dec =>
+ "fun n m -> if n>m then None else Some (n<m)".
+
+Extract Constant Even.even_odd_dec => "fun n -> n mod 2 = 0".
+Extract Constant Div2.div2 => "fun n -> n/2".
+
+Extract Inductive Euclid.diveucl => "(int * int)" [ "" ].
+Extract Constant Euclid.eucl_dev => "fun n m -> (m/n, m mod n)".
+Extract Constant Euclid.quotient => "fun n m -> m/n".
+Extract Constant Euclid.modulo => "fun n m -> m mod n".
+
+(*
+Definition test n m (H:m>0) :=
+ let (q,r,_,_) := eucl_dev m H n in
+ 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
new file mode 100644
index 00000000..3fcd01b0
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlString.v
@@ -0,0 +1,38 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Extraction to Ocaml : special handling of ascii and strings *)
+
+Require Import Ascii String.
+
+Extract Inductive ascii => char
+[
+"(* If this appears, you're using Ascii internals. Please don't *)
+ (fun (b0,b1,b2,b3,b4,b5,b6,b7) ->
+ let f b i = if b then 1 lsl i else 0 in
+ Char.chr (f b0 0 + f b1 1 + f b2 2 + f b3 3 + f b4 4 + f b5 5 + f b6 6 + f b7 7))"
+]
+"(* If this appears, you're using Ascii internals. Please don't *)
+ (fun f c ->
+ let n = Char.code c in
+ let h i = (n land (1 lsl i)) <> 0 in
+ f (h 0) (h 1) (h 2) (h 3) (h 4) (h 5) (h 6) (h 7))".
+
+Extract Constant zero => "'\000'".
+Extract Constant one => "'\001'".
+Extract Constant shift =>
+ "fun b c -> Char.chr (((Char.code c) lsl 1) land 255 + if b then 1 else 0)".
+
+Extract Inlined Constant ascii_dec => "(=)".
+
+Extract Inductive string => "char list" [ "[]" "(::)" ].
+
+(*
+Definition test := "ceci est un test"%string.
+Recursive Extraction test Ascii.zero Ascii.one.
+*)
diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v
new file mode 100644
index 00000000..08f43d3f
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlZBigInt.v
@@ -0,0 +1,85 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *)
+
+Require Import ZArith NArith ZOdiv_def.
+Require Import ExtrOcamlBasic.
+
+(** NB: The extracted code should be linked with [nums.cm(x)a]
+ from ocaml's stdlib and with the wrapper [big.ml] that
+ simlifies the use of [Big_int] (it could be found in the sources
+ of Coq). *)
+
+(** Disclaimer: trying to obtain efficient certified programs
+ by extracting [Z] into [big_int] isn't necessarily a good idea.
+ See the Disclaimer in [ExtrOcamlNatInt]. *)
+
+(** Mapping of [positive], [Z], [N] into [big_int]. The last strings
+ emulate the matching, see documentation of [Extract Inductive]. *)
+
+Extract Inductive positive => "Big.big_int"
+ [ "Big.doubleplusone" "Big.double" "Big.one" ] "Big.positive_case".
+
+Extract Inductive Z => "Big.big_int"
+ [ "Big.zero" "" "Big.opp" ] "Big.z_case".
+
+Extract Inductive N => "Big.big_int"
+ [ "Big.zero" "" ] "Big.n_case".
+
+(** Nota: the "" above is used as an identity function "(fun p->p)" *)
+
+(** 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 =>
+ "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 =>
+ "fun a b -> if Big.eq b Big.zero then Big.zero else Big.div a b".
+Extract Constant Nmod =>
+ "fun a b -> if Big.eq b Big.zero then Big.zero else Big.modulo a b".
+Extract Constant Ncompare => "Big.compare_case Eq Lt Gt".
+
+Extract Constant Zplus => "Big.add".
+Extract Constant Zsucc => "Big.succ".
+Extract Constant Zpred => "Big.pred".
+Extract Constant Zminus => "Big.sub".
+Extract Constant Zmult => "Big.mult".
+Extract Constant Zopp => "Big.opp".
+Extract Constant Zabs => "Big.abs".
+Extract Constant Zmin => "Big.min".
+Extract Constant Zmax => "Big.max".
+Extract Constant Zcompare => "Big.compare_case Eq Lt Gt".
+
+Extract Constant Z_of_N => "fun p -> p".
+Extract Constant Zabs_N => "Big.abs".
+
+(** Zdiv and Zmod are quite complex to define in terms of (/) and (mod).
+ For the moment we don't even try *)
+
+(** Test:
+Require Import ZArith NArith.
+
+Extraction "/tmp/test.ml"
+ Pplus Ppred Pminus Pmult Pcompare Npred Nminus Ndiv Nmod Ncompare
+ Zplus Zmult BinInt.Zcompare Z_of_N Zabs_N Zdiv.Zdiv Zmod.
+*)
diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v
new file mode 100644
index 00000000..d3ea7372
--- /dev/null
+++ b/plugins/extraction/ExtrOcamlZInt.v
@@ -0,0 +1,78 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** Extraction of [positive], [N] and [Z] into Ocaml's [int] *)
+
+Require Import ZArith NArith ZOdiv_def.
+Require Import ExtrOcamlBasic.
+
+(** Disclaimer: trying to obtain efficient certified programs
+ by extracting [Z] into [int] is definitively *not* a good idea.
+ See the Disclaimer in [ExtrOcamlNatInt]. *)
+
+(** Mapping of [positive], [Z], [N] into [int]. The last strings
+ emulate the matching, see documentation of [Extract Inductive]. *)
+
+Extract Inductive positive => int
+[ "(fun p->1+2*p)" "(fun p->2*p)" "1" ]
+"(fun f2p1 f2p f1 p ->
+ if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))".
+
+Extract Inductive Z => int [ "0" "" "(~-)" ]
+"(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))".
+
+Extract Inductive N => int [ "0" "" ]
+"(fun f0 fp n -> if n=0 then f0 () else fp n)".
+
+(** Nota: the "" above is used as an identity function "(fun p->p)" *)
+
+(** 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 =>
+ "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 =>
+ "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 =>
+ "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".
+
+(** 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/README b/plugins/extraction/README
new file mode 100644
index 00000000..64c871fd
--- /dev/null
+++ b/plugins/extraction/README
@@ -0,0 +1,147 @@
+
+ Coq Extraction
+ ==============
+
+
+What is it ?
+------------
+
+The extraction is a mechanism allowing to produce functional code
+(Ocaml/Haskell/Scheme) out of any Coq terms (either programs or
+proofs).
+
+Who did it ?
+------------
+
+The current implementation (from version 7.0 up to now) has been done
+by P. Letouzey during his PhD, helped by J.C. Filliâtre and supervised
+by C. Paulin.
+
+An earlier implementation (versions 6.x) was due to B. Werner and
+C. Paulin.
+
+
+Where can we find more information ?
+------------------------------------
+
+- Coq Reference Manual includes a full chapter about extraction
+- P. Letouzey's PhD thesis [3] forms a complete document about
+ both theory and implementation and test-cases of Coq-extraction
+- A more recent article [4] proposes a short overview of extraction
+- earlier documents [1] [2] may also be useful.
+
+
+Why a complete re-implementation ?
+----------------------------------
+
+Extraction code has been completely rewritten since version V6.3.
+
+1) Principles
+
+The main goal of the new extraction is to handle any Coq term, even
+those upon sort Type, and to produce code that always compiles.
+Thus it will never answer something like "Not an ML type", but rather
+a dummy term like the ML unit.
+
+Translation between Coq and ML is based upon the following principles:
+
+- Terms of sort Prop don't have any computational meaning, so they are
+merged into one ML term "__". This part is done according to P. Letouzey's
+works [1] and [2].
+
+This dummy constant "__" used to be implemented by the unit (), but
+we recently found that this constant might be applied in some cases.
+So "__" is now in Ocaml a fixpoint that forgets its arguments:
+
+ let __ = let rec f _ = Obj.repr f in Obj.repr f
+
+
+- Terms that are type schemes (i.e. something of type ( : )( : )...s with
+s a sort ) don't have any ML counterpart at the term level, since they
+are types transformers. In fact they do not have any computational
+meaning either. So we also merge them into that dummy term "__".
+
+- A Coq term gives a ML term or a ML type depending of its type:
+type schemes will (try to) give ML types, and all other terms give ML terms.
+
+And the rest of the translation is (almost) straightforward: an inductive
+gives an inductive, etc...
+
+This gives ML code that have no special reason to typecheck, due
+to the incompatibilities between Coq and ML typing systems. In fact
+most of the time everything goes right.
+
+We now verify during extraction that the produced code is typecheckable,
+and if it is not we insert unsafe type casting at critical points in the
+code, with either "Obj.magic" in Ocaml or "unsafeCoerce" in Haskell.
+
+
+2) Differences with previous extraction (V6.3 and before)
+
+2.a) The pros
+
+The ability to extract every Coq term, as explain in the previous
+paragraph.
+
+The ability to extract from a file an ML module (cf Extraction Library in the
+documentation)
+
+You can have a taste of extraction directly at the toplevel by
+using the "Extraction <ident>" or the "Recursive Extraction <ident>".
+This toplevel extraction was already there in V6.3, but was printing
+Fw terms. It now prints in the language of your choice:
+Ocaml, Haskell or Scheme.
+
+The optimization done on extracted code has been ported between
+V6.3 and V7 and enhanced, and in particular the mechanism of automatic
+expansion.
+
+2.b) The cons
+
+The presence of some parasite "__" as dummy arguments
+in functions. This denotes the rests of a proof part. The previous
+extraction was able to remove them totally. The current implementation
+removes a good deal of them, but not all.
+
+This problem is due to extraction upon Type.
+For example, let's take this pathological term:
+ (if b then Set else Prop) : Type
+The only way to know if this is an Set (to keep) or a Prop (to remove)
+is to compute the boolean b, and we do not want to do that during
+extraction.
+
+There is no more "ML import" feature. You can compensate by using
+Axioms, and then "Extract Constant ..."
+
+
+
+
+
+[1]:
+Exécution de termes de preuves: une nouvelle méthode d'extraction
+pour le Calcul des Constructions Inductives, Pierre Letouzey,
+DEA thesis, 2000,
+http://www.pps.jussieu.fr/~letouzey/download/rapport_dea.ps.gz
+
+[2]:
+A New Extraction for Coq, Pierre Letouzey,
+Types 2002 Post-Workshop Proceedings.
+http://www.pps.jussieu.fr/~letouzey/download/extraction2002.ps.gz
+
+[3]:
+Programmation fonctionnelle certifiée: l'extraction de programmes
+dans l'assistant Coq. Pierre Letouzey, PhD thesis, 2004.
+http://www.pps.jussieu.fr/~letouzey/download/these_letouzey.ps.gz
+http://www.pps.jussieu.fr/~letouzey/download/these_letouzey_English.ps.gz
+
+[4]:
+Coq Extraction, An overview. Pierre Letouzey. CiE2008.
+http://www.pps.jussieu.fr/~letouzey/download/letouzey_extr_cie08.pdf
+
+
+
+
+
+
+
+
diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml
new file mode 100644
index 00000000..9a5bf56b
--- /dev/null
+++ b/plugins/extraction/big.ml
@@ -0,0 +1,154 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** [Big] : a wrapper around ocaml [Big_int] with nicer names,
+ and a few extraction-specific constructions *)
+
+(** To be linked with [nums.(cma|cmxa)] *)
+
+open Big_int
+
+type big_int = Big_int.big_int
+ (** The type of big integers. *)
+
+let zero = zero_big_int
+ (** The big integer [0]. *)
+let one = unit_big_int
+ (** The big integer [1]. *)
+let two = big_int_of_int 2
+ (** The big integer [2]. *)
+
+(** {6 Arithmetic operations} *)
+
+let opp = minus_big_int
+ (** Unary negation. *)
+let abs = abs_big_int
+ (** Absolute value. *)
+let add = add_big_int
+ (** Addition. *)
+let succ = succ_big_int
+ (** Successor (add 1). *)
+let add_int = add_int_big_int
+ (** Addition of a small integer to a big integer. *)
+let sub = sub_big_int
+ (** Subtraction. *)
+let pred = pred_big_int
+ (** Predecessor (subtract 1). *)
+let mult = mult_big_int
+ (** Multiplication of two big integers. *)
+let mult_int = mult_int_big_int
+ (** Multiplication of a big integer by a small integer *)
+let square = square_big_int
+ (** Return the square of the given big integer *)
+let sqrt = sqrt_big_int
+ (** [sqrt_big_int a] returns the integer square root of [a],
+ that is, the largest big integer [r] such that [r * r <= a].
+ Raise [Invalid_argument] if [a] is negative. *)
+let quomod = quomod_big_int
+ (** Euclidean division of two big integers.
+ The first part of the result is the quotient,
+ the second part is the remainder.
+ Writing [(q,r) = quomod_big_int a b], we have
+ [a = q * b + r] and [0 <= r < |b|].
+ Raise [Division_by_zero] if the divisor is zero. *)
+let div = div_big_int
+ (** Euclidean quotient of two big integers.
+ This is the first result [q] of [quomod_big_int] (see above). *)
+let modulo = mod_big_int
+ (** Euclidean modulus of two big integers.
+ This is the second result [r] of [quomod_big_int] (see above). *)
+let gcd = gcd_big_int
+ (** Greatest common divisor of two big integers. *)
+let power = power_big_int_positive_big_int
+ (** Exponentiation functions. Return the big integer
+ representing the first argument [a] raised to the power [b]
+ (the second argument). Depending
+ on the function, [a] and [b] can be either small integers
+ or big integers. Raise [Invalid_argument] if [b] is negative. *)
+
+(** {6 Comparisons and tests} *)
+
+let sign = sign_big_int
+ (** Return [0] if the given big integer is zero,
+ [1] if it is positive, and [-1] if it is negative. *)
+let compare = compare_big_int
+ (** [compare_big_int a b] returns [0] if [a] and [b] are equal,
+ [1] if [a] is greater than [b], and [-1] if [a] is smaller
+ than [b]. *)
+let eq = eq_big_int
+let le = le_big_int
+let ge = ge_big_int
+let lt = lt_big_int
+let gt = gt_big_int
+ (** Usual boolean comparisons between two big integers. *)
+let max = max_big_int
+ (** Return the greater of its two arguments. *)
+let min = min_big_int
+ (** Return the smaller of its two arguments. *)
+
+(** {6 Conversions to and from strings} *)
+
+let to_string = string_of_big_int
+ (** Return the string representation of the given big integer,
+ in decimal (base 10). *)
+let of_string = big_int_of_string
+ (** Convert a string to a big integer, in decimal.
+ The string consists of an optional [-] or [+] sign,
+ followed by one or several decimal digits. *)
+
+(** {6 Conversions to and from other numerical types} *)
+
+let of_int = big_int_of_int
+ (** Convert a small integer to a big integer. *)
+let is_int = is_int_big_int
+ (** Test whether the given big integer is small enough to
+ be representable as a small integer (type [int])
+ without loss of precision. On a 32-bit platform,
+ [is_int_big_int a] returns [true] if and only if
+ [a] is between 2{^30} and 2{^30}-1. On a 64-bit platform,
+ [is_int_big_int a] returns [true] if and only if
+ [a] is between -2{^62} and 2{^62}-1. *)
+let to_int = int_of_big_int
+ (** Convert a big integer to a small integer (type [int]).
+ Raises [Failure "int_of_big_int"] if the big integer
+ is not representable as a small integer. *)
+
+(** Functions used by extraction *)
+
+let double x = mult_int 2 x
+let doubleplusone x = succ (double x)
+
+let nat_case fO fS n = if sign n <= 0 then fO () else fS (pred n)
+
+let positive_case f2p1 f2p f1 p =
+ if le p one then f1 () else
+ let (q,r) = quomod p two in if eq r zero then f2p q else f2p1 q
+
+let n_case fO fp n = if sign n <= 0 then fO () else fp n
+
+let z_case fO fp fn z =
+ let s = sign z in
+ if s = 0 then fO () else if s > 0 then fp z else fn (opp z)
+
+let compare_case e l g x y =
+ let s = compare x y in if s = 0 then e else if s<0 then l else g
+
+let nat_rec fO fS =
+ let rec loop acc n =
+ if sign n <= 0 then acc else loop (fS acc) (pred n)
+ in loop fO
+
+let positive_rec f2p1 f2p f1 =
+ let rec loop n =
+ if le n one then f1
+ else
+ let (q,r) = quomod n two in
+ if eq r zero then f2p (loop q) else f2p1 (loop q)
+ in loop
+
+let z_rec fO fp fn = z_case (fun _ -> fO) fp fn
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
new file mode 100644
index 00000000..1db1c786
--- /dev/null
+++ b/plugins/extraction/common.ml
@@ -0,0 +1,535 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Declarations
+open Namegen
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Mlutil
+open Modutil
+open Mod_subst
+
+let string_of_id id =
+ let s = Names.string_of_id id in
+ for i = 0 to String.length s - 2 do
+ if s.[i] = '_' && s.[i+1] = '_' then warning_id s
+ done;
+ ascii_of_ident s
+
+let is_mp_bound = function MPbound _ -> true | _ -> false
+
+(*s Some pretty-print utility functions. *)
+
+let pp_par par st = if par then str "(" ++ st ++ str ")" else st
+
+let pp_apply st par args = match args with
+ | [] -> st
+ | _ -> hov 2 (pp_par par (st ++ spc () ++ prlist_with_sep spc identity args))
+
+let pr_binding = function
+ | [] -> mt ()
+ | l -> str " " ++ prlist_with_sep (fun () -> str " ") pr_id l
+
+let 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
+
+let begins_with_CoqXX s =
+ let n = String.length s in
+ n >= 4 && s.[0] = 'C' && s.[1] = 'o' && s.[2] = 'q' &&
+ let i = ref 3 in
+ try while !i < n do
+ if s.[!i] = '_' then i:=n (*Stop*)
+ else if is_digit s.[!i] then incr i
+ else raise Not_found
+ done; true
+ with Not_found -> false
+
+let unquote s =
+ if lang () <> Scheme then s
+ else
+ let s = String.copy s in
+ for i=0 to String.length s - 1 do if s.[i] = '\'' then s.[i] <- '~' done;
+ s
+
+let rec qualify delim = function
+ | [] -> assert false
+ | [s] -> s
+ | ""::l -> qualify delim l
+ | s::l -> s^delim^(qualify delim l)
+
+let dottify = qualify "."
+let pseudo_qualify = qualify "__"
+
+(*s Uppercase/lowercase renamings. *)
+
+let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false
+let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false
+
+let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id))
+let uppercase_id id =
+ let s = string_of_id id in
+ assert (s<>"");
+ if s.[0] = '_' then id_of_string ("Coq_"^s)
+ else id_of_string (String.capitalize s)
+
+type kind = Term | Type | Cons | Mod
+
+let upperkind = function
+ | Type -> lang () = Haskell
+ | Term -> false
+ | Cons | Mod -> true
+
+let kindcase_id k id =
+ if upperkind k then uppercase_id id else lowercase_id id
+
+(*s de Bruijn environments for programs *)
+
+type env = identifier list * Idset.t
+
+(*s Generic renaming issues for local variable names. *)
+
+let rec rename_id id avoid =
+ if Idset.mem id avoid then rename_id (lift_subscript id) avoid else id
+
+let rec rename_vars avoid = function
+ | [] ->
+ [], avoid
+ | id :: idl when id == dummy_name ->
+ (* we don't rename dummy binders *)
+ let (idl', avoid') = rename_vars avoid idl in
+ (id :: idl', avoid')
+ | id :: idl ->
+ let (idl, avoid) = rename_vars avoid idl in
+ let id = rename_id (lowercase_id id) avoid in
+ (id :: idl, Idset.add id avoid)
+
+let rename_tvars avoid l =
+ let rec rename avoid = function
+ | [] -> [],avoid
+ | id :: idl ->
+ let id = rename_id (lowercase_id id) avoid in
+ let idl, avoid = rename (Idset.add id avoid) idl in
+ (id :: idl, avoid) in
+ fst (rename avoid l)
+
+let push_vars ids (db,avoid) =
+ let ids',avoid' = rename_vars avoid ids in
+ ids', (ids' @ db, avoid')
+
+let get_db_name n (db,_) =
+ let id = List.nth db (pred n) in
+ if id = dummy_name then id_of_string "__" else id
+
+
+(*S Renamings of global objects. *)
+
+(*s Tables of global renamings *)
+
+let register_cleanup, do_cleanup =
+ let funs = ref [] in
+ (fun f -> funs:=f::!funs), (fun () -> List.iter (fun f -> f ()) !funs)
+
+type phase = Pre | Impl | Intf
+
+let set_phase, get_phase =
+ let ph = ref Impl in ((:=) ph), (fun () -> !ph)
+
+let set_keywords, get_keywords =
+ let k = ref Idset.empty in
+ ((:=) k), (fun () -> !k)
+
+let add_global_ids, get_global_ids =
+ let ids = ref Idset.empty in
+ register_cleanup (fun () -> ids := get_keywords ());
+ let add s = ids := Idset.add s !ids
+ and get () = !ids
+ in (add,get)
+
+let empty_env () = [], get_global_ids ()
+
+let mktable autoclean =
+ let h = Hashtbl.create 97 in
+ if autoclean then register_cleanup (fun () -> Hashtbl.clear h);
+ (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h)
+
+(* A table recording objects in the first level of all MPfile *)
+
+let add_mpfiles_content,get_mpfiles_content,clear_mpfiles_content =
+ mktable false
+
+(*s The list of external modules that will be opened initially *)
+
+let mpfiles_add, mpfiles_mem, mpfiles_list, mpfiles_clear =
+ let m = ref MPset.empty in
+ let add mp = m:=MPset.add mp !m
+ and mem mp = MPset.mem mp !m
+ and list () = MPset.elements !m
+ and clear () = m:=MPset.empty
+ in
+ register_cleanup clear;
+ (add,mem,list,clear)
+
+(*s List of module parameters that we should alpha-rename *)
+
+let params_ren_add, params_ren_mem =
+ let m = ref MPset.empty in
+ let add mp = m:=MPset.add mp !m
+ and mem mp = MPset.mem mp !m
+ and clear () = m:=MPset.empty
+ in
+ register_cleanup clear;
+ (add,mem)
+
+(*s table indicating the visible horizon at a precise moment,
+ i.e. the stack of structures we are inside.
+
+ - The sequence of [mp] parts should have the following form:
+ a [MPfile] at the beginning, and then more and more [MPdot]
+ over this [MPfile], or [MPbound] when inside the type of a
+ module parameter.
+
+ - the [params] are the [MPbound] when [mp] is a functor,
+ the innermost [MPbound] coming first in the list.
+
+ - The [content] part is used to record all the names already
+ seen at this level.
+*)
+
+type visible_layer = { mp : module_path;
+ params : module_path list;
+ content : ((kind*string),label) Hashtbl.t }
+
+let pop_visible, push_visible, get_visible =
+ let vis = ref [] in
+ register_cleanup (fun () -> vis := []);
+ let pop () =
+ let v = List.hd !vis in
+ (* we save the 1st-level-content of MPfile for later use *)
+ if get_phase () = Impl && modular () && is_modfile v.mp
+ then add_mpfiles_content v.mp v.content;
+ vis := List.tl !vis
+ and push mp mps =
+ vis := { mp = mp; params = mps; content = Hashtbl.create 97 } :: !vis
+ and get () = !vis
+ in (pop,push,get)
+
+let get_visible_mps () = List.map (function v -> v.mp) (get_visible ())
+let top_visible () = match get_visible () with [] -> assert false | v::_ -> v
+let top_visible_mp () = (top_visible ()).mp
+let add_visible ks l = Hashtbl.add (top_visible ()).content ks l
+
+(* table of local module wrappers used to provide non-ambiguous names *)
+
+let add_duplicate, check_duplicate =
+ let index = ref 0 and dups = ref Gmap.empty in
+ register_cleanup (fun () -> index := 0; dups := Gmap.empty);
+ let add mp l =
+ incr index;
+ let ren = "Coq__" ^ string_of_int (!index) in
+ dups := Gmap.add (mp,l) ren !dups
+ and check mp l = Gmap.find (mp, l) !dups
+ in (add,check)
+
+type reset_kind = AllButExternal | Everything
+
+let reset_renaming_tables flag =
+ do_cleanup ();
+ if flag = Everything then clear_mpfiles_content ()
+
+(*S Renaming functions *)
+
+(* This function creates from [id] a correct uppercase/lowercase identifier.
+ This is done by adding a [Coq_] or [coq_] prefix. To avoid potential clashes
+ with previous [Coq_id] variable, these prefixes are duplicated if already
+ existing. *)
+
+let modular_rename k id =
+ let s = string_of_id id in
+ let prefix,is_ok =
+ if upperkind k then "Coq_",is_upper else "coq_",is_lower
+ in
+ if not (is_ok s) ||
+ (Idset.mem id (get_keywords ())) ||
+ (String.length s >= 4 && String.sub s 0 4 = prefix)
+ then prefix ^ s
+ else s
+
+(*s For monolithic extraction, first-level modules might have to be renamed
+ with unique numbers *)
+
+let modfstlev_rename =
+ let add_prefixes,get_prefixes,_ = mktable true in
+ fun l ->
+ let coqid = id_of_string "Coq" in
+ let id = id_of_label l in
+ try
+ let coqset = get_prefixes id in
+ let nextcoq = next_ident_away coqid coqset in
+ add_prefixes id (nextcoq::coqset);
+ (string_of_id nextcoq)^"_"^(string_of_id id)
+ with Not_found ->
+ let s = string_of_id id in
+ if is_lower s || begins_with_CoqXX s then
+ (add_prefixes id [coqid]; "Coq_"^s)
+ else
+ (add_prefixes id []; s)
+
+(*s Creating renaming for a [module_path] : first, the real function ... *)
+
+let rec mp_renaming_fun mp = match mp with
+ | _ when not (modular ()) && at_toplevel mp -> [""]
+ | MPdot (mp,l) ->
+ let lmp = mp_renaming mp in
+ if lmp = [""] then (modfstlev_rename l)::lmp
+ else (modular_rename Mod (id_of_label l))::lmp
+ | MPbound mbid ->
+ let s = modular_rename Mod (id_of_mbid mbid) in
+ if not (params_ren_mem mp) then [s]
+ else let i,_,_ = repr_mbid mbid in [s^"__"^string_of_int i]
+ | MPfile _ when not (modular ()) -> assert false (* see [at_toplevel] above *)
+ | MPfile _ ->
+ assert (get_phase () = Pre);
+ let current_mpfile = (list_last (get_visible ())).mp in
+ if mp <> current_mpfile then mpfiles_add mp;
+ [string_of_modfile mp]
+
+(* ... and its version using a cache *)
+
+and mp_renaming =
+ let add,get,_ = mktable true in
+ fun x ->
+ try if is_mp_bound (base_mp x) then raise Not_found; get x
+ with Not_found -> let y = mp_renaming_fun x in add x y; y
+
+(*s Renamings creation for a [global_reference]: we build its fully-qualified
+ name in a [string list] form (head is the short name). *)
+
+let ref_renaming_fun (k,r) =
+ let mp = modpath_of_r r in
+ let l = mp_renaming mp in
+ let l = if lang () <> Ocaml && not (modular ()) then [""] else l in
+ let s =
+ 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
+ string_of_id id
+ else modular_rename k (safe_basename_of_global r)
+ in
+ add_global_ids (id_of_string s);
+ s::l
+
+(* Cached version of the last function *)
+
+let ref_renaming =
+ let add,get,_ = mktable true in
+ fun x ->
+ try if is_mp_bound (base_mp (modpath_of_r (snd x))) then raise Not_found; get x
+ with Not_found -> let y = ref_renaming_fun x in add x y; y
+
+(* [visible_clash mp0 (k,s)] checks if [mp0-s] of kind [k]
+ can be printed as [s] in the current context of visible
+ modules. More precisely, we check if there exists a
+ visible [mp] that contains [s].
+ The verification stops if we encounter [mp=mp0]. *)
+
+let rec clash mem mp0 ks = function
+ | [] -> false
+ | mp :: _ when mp = mp0 -> false
+ | mp :: _ when mem mp ks -> true
+ | _ :: mpl -> clash mem mp0 ks mpl
+
+let mpfiles_clash mp0 ks =
+ clash (fun mp -> Hashtbl.mem (get_mpfiles_content mp)) mp0 ks
+ (List.rev (mpfiles_list ()))
+
+let rec params_lookup mp0 ks = function
+ | [] -> false
+ | param :: _ when mp0 = param -> true
+ | param :: params ->
+ if ks = (Mod, List.hd (mp_renaming param)) then params_ren_add param;
+ params_lookup mp0 ks params
+
+let visible_clash mp0 ks =
+ let rec clash = function
+ | [] -> false
+ | v :: _ when v.mp = mp0 -> false
+ | v :: vis ->
+ let b = Hashtbl.mem v.content ks in
+ if b && not (is_mp_bound mp0) then true
+ else begin
+ if b then params_ren_add mp0;
+ if params_lookup mp0 ks v.params then false
+ else clash vis
+ end
+ in clash (get_visible ())
+
+(* Same, but with verbose output (and mp0 shouldn't be a MPbound) *)
+
+let visible_clash_dbg mp0 ks =
+ let rec clash = function
+ | [] -> None
+ | v :: _ when v.mp = mp0 -> None
+ | v :: vis ->
+ try Some (v.mp,Hashtbl.find v.content ks)
+ with Not_found ->
+ if params_lookup mp0 ks v.params then None
+ else clash vis
+ in clash (get_visible ())
+
+(* After the 1st pass, we can decide which modules will be opened initially *)
+
+let opened_libraries () =
+ if not (modular ()) then []
+ else
+ let used = mpfiles_list () in
+ let rec check_elsewhere avoid = function
+ | [] -> []
+ | mp :: mpl ->
+ let clash s = Hashtbl.mem (get_mpfiles_content mp) (Mod,s) in
+ if List.exists clash avoid
+ then check_elsewhere avoid mpl
+ else mp :: check_elsewhere (string_of_modfile mp :: avoid) mpl
+ in
+ let opened = check_elsewhere [] used in
+ mpfiles_clear ();
+ List.iter mpfiles_add opened;
+ opened
+
+(*s On-the-fly qualification issues for both monolithic or modular extraction. *)
+
+(* First, a function that factorize the printing of both [global_reference]
+ and module names for ocaml. When [k=Mod] then [olab=None], otherwise it
+ contains the label of the reference to print.
+ [rls] is the string list giving the qualified name, short name at the end.
+ Invariant: [List.length rls >= 2], simpler situations are handled elsewhere. *)
+
+(* In Coq, we can qualify [M.t] even if we are inside [M], but in Ocaml we
+ cannot do that. So, if [t] gets hidden and we need a long name for it,
+ we duplicate the _definition_ of t in a Coq__XXX module, and similarly
+ for a sub-module [M.N] *)
+
+let pp_duplicate k' prefix mp rls olab =
+ let rls', lbl =
+ if k'<>Mod then
+ (* Here rls=[s], the ref to print is <prefix>.<s>, and olab<>None *)
+ rls, Option.get olab
+ else
+ (* Here rls=s::rls', we search the label for s inside mp *)
+ List.tl rls, get_nth_label_mp (mp_length mp - mp_length prefix) mp
+ in
+ try dottify (check_duplicate prefix lbl :: rls')
+ with Not_found ->
+ assert (get_phase () = Pre); (* otherwise it's too late *)
+ add_duplicate prefix lbl; dottify rls
+
+let fstlev_ks k = function
+ | [] -> assert false
+ | [s] -> k,s
+ | s::_ -> Mod,s
+
+(* [pp_ocaml_local] : [mp] has something in common with [top_visible ()]
+ but isn't equal to it *)
+
+let pp_ocaml_local k prefix mp rls olab =
+ (* what is the largest prefix of [mp] that belongs to [visible]? *)
+ assert (k <> Mod || mp <> prefix); (* mp as whole module isn't in itself *)
+ let rls' = list_skipn (mp_length prefix) rls in
+ let k's = fstlev_ks k rls' in
+ (* Reference r / module path mp is of the form [<prefix>.s.<...>]. *)
+ if not (visible_clash prefix k's) then dottify rls'
+ else pp_duplicate (fst k's) prefix mp rls' olab
+
+(* [pp_ocaml_bound] : [mp] starts with a [MPbound], and we are not inside
+ (i.e. we are not printing the type of the module parameter) *)
+
+let pp_ocaml_bound base rls =
+ (* clash with a MPbound will be detected and fixed by renaming this MPbound *)
+ if get_phase () = Pre then ignore (visible_clash base (Mod,List.hd rls));
+ dottify rls
+
+(* [pp_ocaml_extern] : [mp] isn't local, it is defined in another [MPfile]. *)
+
+let pp_ocaml_extern k base rls = match rls with
+ | [] | [_] -> assert false
+ | base_s :: rls' ->
+ let k's = fstlev_ks k rls' in
+ if modular () && (mpfiles_mem base) &&
+ (not (mpfiles_clash base k's)) &&
+ (not (visible_clash base k's))
+ then (* Standard situation of an object in another file: *)
+ (* Thanks to the "open" of this file we remove its name *)
+ dottify rls'
+ else match visible_clash_dbg base (Mod,base_s) with
+ | None -> dottify rls
+ | Some (mp,l) -> error_module_clash base (MPdot (mp,l))
+
+(* [pp_ocaml_gen] : choosing between [pp_ocaml_extern] or [pp_ocaml_extern] *)
+
+let pp_ocaml_gen k mp rls olab =
+ match common_prefix_from_list mp (get_visible_mps ()) with
+ | Some prefix -> pp_ocaml_local k prefix mp rls olab
+ | None ->
+ let base = base_mp mp in
+ if is_mp_bound base then pp_ocaml_bound base rls
+ else pp_ocaml_extern k base rls
+
+(* For Haskell, things are simplier: we have removed (almost) all structures *)
+
+let pp_haskell_gen k mp rls = match rls with
+ | [] -> assert false
+ | s::rls' ->
+ (if base_mp mp <> top_visible_mp () then s ^ "." else "") ^
+ (if upperkind k then "" else "_") ^ pseudo_qualify rls'
+
+(* Main name printing function for a reference *)
+
+let pp_global k r =
+ let ls = ref_renaming (k,r) in
+ assert (List.length ls > 1);
+ let s = List.hd ls in
+ let mp,_,l = repr_of_r r in
+ if mp = top_visible_mp () then
+ (* simpliest situation: definition of r (or use in the same context) *)
+ (* we update the visible environment *)
+ (add_visible (k,s) l; unquote s)
+ else
+ let rls = List.rev ls in (* for what come next it's easier this way *)
+ match lang () with
+ | Scheme -> unquote s (* no modular Scheme extraction... *)
+ | Haskell -> if modular () then pp_haskell_gen k mp rls else s
+ | Ocaml -> pp_ocaml_gen k mp rls (Some l)
+
+(* The next function is used only in Ocaml extraction...*)
+
+let pp_module mp =
+ let ls = mp_renaming mp in
+ match mp with
+ | MPdot (mp0,l) when mp0 = top_visible_mp () ->
+ (* simpliest situation: definition of mp (or use in the same context) *)
+ (* we update the visible environment *)
+ let s = List.hd ls in
+ add_visible (Mod,s) l; s
+ | _ -> pp_ocaml_gen Mod mp (List.rev ls) None
+
+
diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli
new file mode 100644
index 00000000..93be15d1
--- /dev/null
+++ b/plugins/extraction/common.mli
@@ -0,0 +1,59 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Names
+open Libnames
+open Miniml
+open Mlutil
+open Pp
+
+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
+val pp_apply : std_ppcmds -> bool -> std_ppcmds list -> std_ppcmds
+val pr_binding : identifier list -> std_ppcmds
+
+val rename_id : identifier -> Idset.t -> identifier
+
+type env = identifier list * Idset.t
+val empty_env : unit -> env
+
+val rename_vars: Idset.t -> identifier list -> env
+val rename_tvars: Idset.t -> identifier list -> identifier list
+val push_vars : identifier list -> env -> identifier list * env
+val get_db_name : int -> env -> identifier
+
+type phase = Pre | Impl | Intf
+
+val set_phase : phase -> unit
+val get_phase : unit -> phase
+
+val opened_libraries : unit -> module_path list
+
+type kind = Term | Type | Cons | Mod
+
+val pp_global : kind -> global_reference -> string
+val pp_module : module_path -> string
+
+val top_visible_mp : unit -> module_path
+(* In [push_visible], the [module_path list] corresponds to
+ module parameters, the innermost one coming first in the list *)
+val push_visible : module_path -> module_path list -> unit
+val pop_visible : unit -> unit
+
+val check_duplicate : module_path -> label -> string
+
+type reset_kind = AllButExternal | Everything
+
+val reset_renaming_tables : reset_kind -> unit
+
+val set_keywords : Idset.t -> unit
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
new file mode 100644
index 00000000..ab9c242a
--- /dev/null
+++ b/plugins/extraction/extract_env.ml
@@ -0,0 +1,540 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Term
+open Declarations
+open Names
+open Libnames
+open Pp
+open Util
+open Miniml
+open Table
+open Extraction
+open Modutil
+open Common
+open Mod_subst
+
+(***************************************)
+(*S Part I: computing Coq environment. *)
+(***************************************)
+
+let toplevel_env () =
+ let seg = Lib.contents_after None in
+ let get_reference = function
+ | (_,kn), Lib.Leaf o ->
+ let mp,_,l = repr_kn kn in
+ let seb = match Libobject.object_tag o with
+ | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn))
+ | "INDUCTIVE" -> SFBmind (Global.lookup_mind (mind_of_kn kn))
+ | "MODULE" -> SFBmodule (Global.lookup_module (MPdot (mp,l)))
+ | "MODULE TYPE" ->
+ SFBmodtype (Global.lookup_modtype (MPdot (mp,l)))
+ | _ -> failwith "caught"
+ in l,seb
+ | _ -> failwith "caught"
+ in
+ match current_toplevel () with
+ | _ -> 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 ->
+ 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 ())
+
+
+(*s Visit:
+ a structure recording the needed dependencies for the current extraction *)
+
+module type VISIT = sig
+ (* Reset the dependencies by emptying the visit lists *)
+ val reset : unit -> unit
+
+ (* Add the module_path and all its prefixes to the mp visit list *)
+ val add_mp : 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_kn : mutual_inductive -> unit
+ val add_con : constant -> unit
+ val add_ref : global_reference -> unit
+ val add_decl_deps : ml_decl -> unit
+ val add_spec_deps : ml_spec -> unit
+
+ (* Test functions:
+ is a particular object a needed dependency for the current extraction ? *)
+ val needed_kn : mutual_inductive -> bool
+ val needed_con : constant -> bool
+ val needed_mp : module_path -> bool
+end
+
+module Visit : VISIT = struct
+ (* What used to be in a single KNset should now be split into a KNset
+ (for inductives and modules names) and a Cset for constants
+ (and still the remaining MPset) *)
+ type must_visit =
+ { mutable kn : Mindset.t; mutable con : Cset.t; mutable mp : MPset.t }
+ (* the imperative internal visit lists *)
+ let v = { kn = Mindset.empty ; con = Cset.empty ; mp = MPset.empty }
+ (* the accessor functions *)
+ let reset () = v.kn <- Mindset.empty; v.con <- Cset.empty; v.mp <- MPset.empty
+ let needed_kn kn = Mindset.mem kn v.kn
+ let needed_con c = Cset.mem c v.con
+ let needed_mp mp = MPset.mem mp v.mp
+ let add_mp mp =
+ check_loaded_modfile mp; v.mp <- MPset.union (prefixes_mp mp) v.mp
+ let add_kn kn = v.kn <- Mindset.add kn v.kn; add_mp (mind_modpath kn)
+ let add_con c = v.con <- Cset.add c v.con; add_mp (con_modpath c)
+ let add_ref = function
+ | ConstRef c -> add_con c
+ | IndRef (kn,_) | ConstructRef ((kn,_),_) -> add_kn kn
+ | VarRef _ -> assert false
+ let add_decl_deps = decl_iter_references add_ref add_ref add_ref
+ let add_spec_deps = spec_iter_references add_ref add_ref add_ref
+end
+
+exception Impossible
+
+let check_arity env cb =
+ let t = Typeops.type_of_constant_type env cb.const_type in
+ if Reduction.is_arity env t then raise Impossible
+
+let check_fix env cb i =
+ match cb.const_body with
+ | None -> raise Impossible
+ | Some lbody ->
+ match kind_of_term (Declarations.force lbody) with
+ | Fix ((_,j),recd) when i=j -> check_arity env cb; (true,recd)
+ | CoFix (j,recd) when i=j -> check_arity env cb; (false,recd)
+ | _ -> raise Impossible
+
+let factor_fix env l cb msb =
+ let _,recd as check = check_fix env cb 0 in
+ let n = Array.length (let fi,_,_ = recd in fi) in
+ if n = 1 then [|l|], recd, msb
+ else begin
+ if List.length msb < n-1 then raise Impossible;
+ let msb', msb'' = list_chop (n-1) msb in
+ let labels = Array.make n l in
+ list_iter_i
+ (fun j ->
+ function
+ | (l,SFBconst cb') ->
+ if check <> check_fix env cb' (j+1) then raise Impossible;
+ labels.(j+1) <- l;
+ | _ -> raise Impossible) msb';
+ labels, recd, msb''
+ end
+
+(** Expanding a [struct_expr_body] into a version without abbreviations
+ or functor applications. This is done via a detour to entries
+ (hack proposed by Elie)
+*)
+
+let rec seb2mse = function
+ | SEBapply (s,s',_) -> Entries.MSEapply(seb2mse s, seb2mse s')
+ | SEBident mp -> Entries.MSEident mp
+ | _ -> failwith "seb2mse: received a non-atomic seb"
+
+let expand_seb env mp seb =
+ let seb,_,_,_ =
+ Mod_typing.translate_struct_module_entry env mp true (seb2mse seb)
+ in seb
+
+(** When possible, we use the nicer, shorter, algebraic type structures
+ instead of the expanded ones. *)
+
+let my_type_of_mb mb =
+ let m0 = mb.mod_type in
+ match mb.mod_type_alg with Some m -> m0,m | None -> m0,m0
+
+let my_type_of_mtb mtb =
+ let m0 = mtb.typ_expr in
+ match mtb.typ_expr_alg with Some m -> m0,m | None -> m0,m0
+
+(** Ad-hoc update of environment, inspired by [Mod_type.check_with_aux_def].
+ To check with Elie. *)
+
+let rec msid_of_seb = function
+ | SEBident mp -> mp
+ | SEBwith (seb,_) -> msid_of_seb seb
+ | _ -> assert false
+
+let env_for_mtb_with env mp seb idl =
+ let sig_b = match seb with
+ | SEBstruct(sig_b) -> sig_b
+ | _ -> assert false
+ in
+ let l = label_of_id (List.hd idl) in
+ let before = fst (list_split_when (fun (l',_) -> l=l') sig_b) in
+ Modops.add_signature mp before empty_delta_resolver env
+
+(* From a [structure_body] (i.e. a list of [structure_field_body])
+ to specifications. *)
+
+let rec extract_sfb_spec env mp = function
+ | [] -> []
+ | (l,SFBconst cb) :: msig ->
+ let kn = make_con mp empty_dirpath l in
+ let s = extract_constant_spec env kn cb 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
+ | (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 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
+ | (l,SFBmodule mb) :: msig ->
+ let specs = extract_sfb_spec env mp msig in
+ let spec = extract_seb_spec env mb.mod_mp (my_type_of_mb mb) in
+ (l,Smodule spec) :: specs
+ | (l,SFBmodtype mtb) :: msig ->
+ let specs = extract_sfb_spec env mp msig in
+ let spec = extract_seb_spec env mtb.typ_mp (my_type_of_mtb mtb) in
+ (l,Smodtype spec) :: specs
+
+(* From [struct_expr_body] to specifications *)
+
+(* Invariant: the [seb] given to [extract_seb_spec] should either come
+ from a [mod_type] or [type_expr] field, or their [_alg] counterparts.
+ This way, any encountered [SEBident] should be a true module type.
+*)
+
+and extract_seb_spec env mp1 (seb,seb_alg) = match seb_alg with
+ | SEBident mp -> Visit.add_mp 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
+ (match extract_with_type env' cb with (* cb peut contenir des kn *)
+ | None -> mt
+ | Some (vl,typ) -> MTwith(mt,ML_With_type(idl,vl,typ)))
+ | SEBwith(seb',With_module_body(idl,mp))->
+ Visit.add_mp mp;
+ MTwith(extract_seb_spec env mp1 (seb,seb'),
+ ML_With_module(idl,mp))
+ | SEBfunctor (mbid, mtb, seb_alg') ->
+ let seb' = match seb with
+ | SEBfunctor (mbid',_,seb') when mbid' = mbid -> seb'
+ | _ -> assert false
+ in
+ let mp = MPbound mbid in
+ let env' = Modops.add_module (Modops.module_body_of_type mp mtb) env in
+ MTfunsig (mbid, extract_seb_spec env mp (my_type_of_mtb mtb),
+ extract_seb_spec env' mp1 (seb',seb_alg'))
+ | SEBstruct (msig) ->
+ let env' = Modops.add_signature mp1 msig empty_delta_resolver env in
+ MTsig (mp1, extract_sfb_spec env' mp1 msig)
+ | SEBapply _ ->
+ if seb <> seb_alg then extract_seb_spec env mp1 (seb,seb)
+ else assert false
+
+
+
+(* From a [structure_body] (i.e. a list of [structure_field_body])
+ to implementations.
+
+ NB: when [all=false], the evaluation order of the list is
+ important: last to first ensures correct dependencies.
+*)
+
+let rec extract_sfb env mp all = function
+ | [] -> []
+ | (l,SFBconst cb) :: msb ->
+ (try
+ let vl,recd,msb = factor_fix env l cb msb in
+ let vc = Array.map (make_con mp empty_dirpath) vl in
+ let ms = extract_sfb env mp all msb in
+ let b = array_exists Visit.needed_con vc in
+ if all || b then
+ let d = extract_fixpoint env vc recd in
+ if (not b) && (logical_decl d) then ms
+ else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
+ else ms
+ with Impossible ->
+ let ms = extract_sfb env mp all msb in
+ let c = make_con mp empty_dirpath l in
+ let b = Visit.needed_con c in
+ if all || b then
+ let d = extract_constant env c cb in
+ if (not b) && (logical_decl d) then ms
+ else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
+ 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 b = Visit.needed_kn mind in
+ if all || b then
+ let d = Dind (kn, 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
+ | (l,SFBmodule mb) :: msb ->
+ let ms = extract_sfb env mp all msb in
+ let mp = MPdot (mp,l) in
+ if all || Visit.needed_mp mp then
+ (l,SEmodule (extract_module env mp true mb)) :: ms
+ else ms
+ | (l,SFBmodtype mtb) :: msb ->
+ let ms = extract_sfb env mp all msb in
+ let mp = MPdot (mp,l) in
+ if all || Visit.needed_mp mp then
+ (l,SEmodtype (extract_seb_spec env mp (my_type_of_mtb mtb))) :: ms
+ else ms
+
+(* From [struct_expr_body] to implementations *)
+
+and extract_seb env mp all = function
+ | (SEBident _ | SEBapply _) as seb when lang () <> Ocaml ->
+ (* in Haskell/Scheme, we expand everything *)
+ 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
+ | SEBapply (meb, meb',_) ->
+ MEapply (extract_seb env mp true meb,
+ extract_seb env mp true meb')
+ | SEBfunctor (mbid, mtb, meb) ->
+ let mp1 = MPbound mbid in
+ let env' = Modops.add_module (Modops.module_body_of_type mp1 mtb)
+ env in
+ MEfunctor (mbid, extract_seb_spec env mp1 (my_type_of_mtb mtb),
+ extract_seb env' mp true meb)
+ | SEBstruct (msb) ->
+ let env' = Modops.add_signature mp msb empty_delta_resolver env in
+ MEstruct (mp,extract_sfb env' mp all msb)
+ | SEBwith (_,_) -> anomaly "Not available yet"
+
+and extract_module env mp all mb =
+ (* [mb.mod_expr <> None ], since we look at modules from outside. *)
+ (* Example of module with empty [mod_expr] is X inside a Module F [X:SIG]. *)
+ { ml_mod_expr = extract_seb env mp all (Option.get mb.mod_expr);
+ ml_mod_type = extract_seb_spec env mp (my_type_of_mb mb) }
+
+
+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;
+ 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
+
+(**************************************)
+(*S Part II : Input/Output primitives *)
+(**************************************)
+
+let descr () = match lang () with
+ | Ocaml -> Ocaml.ocaml_descr
+ | Haskell -> Haskell.haskell_descr
+ | Scheme -> Scheme.scheme_descr
+
+(* From a filename string "foo.ml" or "foo", builds "foo.ml" and "foo.mli"
+ Works similarly for the other languages. *)
+
+let default_id = id_of_string "Main"
+
+let mono_filename f =
+ let d = descr () in
+ match f with
+ | None -> None, None, default_id
+ | Some f ->
+ let f =
+ if Filename.check_suffix f d.file_suffix then
+ Filename.chop_suffix f d.file_suffix
+ else f
+ in
+ let id =
+ if lang () <> Haskell then default_id
+ else try id_of_string (Filename.basename f)
+ with _ -> error "Extraction: provided filename is not a valid identifier"
+ in
+ Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id
+
+(* Builds a suitable filename from a module id *)
+
+let module_filename mp =
+ let f = file_of_modfile mp in
+ let d = descr () in
+ Some (f^d.file_suffix), Option.map ((^) f) d.sig_suffix, id_of_string f
+
+(*s Extraction of one decl to stdout. *)
+
+let print_one_decl struc mp decl =
+ let d = descr () in
+ reset_renaming_tables AllButExternal;
+ set_phase Pre;
+ ignore (d.pp_struct struc);
+ set_phase Impl;
+ push_visible mp [];
+ msgnl (d.pp_decl decl);
+ pop_visible ()
+
+(*s Extraction of a ml struct to a file. *)
+
+let formatter dry file =
+ if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ())
+ else match file with
+ | None -> !Pp_control.std_ft
+ | Some cout ->
+ let ft = Pp_control.with_output_to cout in
+ Option.iter (Format.pp_set_margin ft) (Pp_control.get_margin ());
+ ft
+
+let print_structure_to_file (fn,si,mo) dry struc =
+ let d = descr () in
+ reset_renaming_tables AllButExternal;
+ let unsafe_needs = {
+ mldummy = struct_ast_search ((=) MLdummy) struc;
+ tdummy = struct_type_search Mlutil.isDummy struc;
+ tunknown = struct_type_search ((=) Tunknown) struc;
+ magic =
+ if lang () <> Haskell then false
+ else struct_ast_search (function MLmagic _ -> true | _ -> false) struc }
+ in
+ (* First, a dry run, for computing objects to rename or duplicate *)
+ set_phase Pre;
+ let devnull = formatter true None in
+ msg_with devnull (d.pp_struct struc);
+ let opened = opened_libraries () in
+ (* Print the implementation *)
+ let cout = if dry then None else Option.map open_out fn in
+ let ft = formatter dry cout in
+ begin try
+ (* The real printing of the implementation *)
+ set_phase Impl;
+ msg_with ft (d.preamble mo opened unsafe_needs);
+ msg_with ft (d.pp_struct struc);
+ Option.iter close_out cout;
+ with e ->
+ Option.iter close_out cout; raise e
+ end;
+ if not dry then Option.iter info_file fn;
+ (* Now, let's print the signature *)
+ Option.iter
+ (fun si ->
+ let cout = open_out si in
+ let ft = formatter false (Some cout) in
+ begin try
+ set_phase Intf;
+ msg_with ft (d.sig_preamble mo opened unsafe_needs);
+ msg_with ft (d.pp_sig (signature_of_structure struc));
+ close_out cout;
+ with e ->
+ close_out cout; raise e
+ end;
+ info_file si)
+ (if dry then None else si)
+
+
+(*********************************************)
+(*s Part III: the actual extraction commands *)
+(*********************************************)
+
+
+let reset () =
+ Visit.reset (); reset_tables (); reset_renaming_tables Everything
+
+let init modular =
+ check_inside_section (); check_inside_module ();
+ set_keywords (descr ()).keywords;
+ set_modular modular;
+ reset ();
+ if modular && lang () = Scheme then error_scheme ()
+
+(* From a list of [reference], let's retrieve whether they correspond
+ to modules or [global_reference]. Warn the user if both is possible. *)
+
+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
+ 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
+ | Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps
+ | Some mp, Some r ->
+ warning_both_mod_and_cst q mp r;
+ let refs,mps = locate_ref l in refs,mp::mps
+
+(*s Recursive extraction in the Coq toplevel. The vernacular command is
+ \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when
+ extracting to a file with the command:
+ \verb!Extraction "file"! [qualid1] ... [qualidn]. *)
+
+let full_extr f (refs,mps) =
+ init 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 ();
+ print_structure_to_file (mono_filename f) false struc;
+ reset ()
+
+let full_extraction f lr = full_extr f (locate_ref lr)
+
+(*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
+ let d = get_decl_in_structure r struc in
+ warning_axioms ();
+ if is_custom r then msgnl (str "(** User defined extraction *)");
+ print_one_decl struc (modpath_of_r r) d;
+ reset ()
+ | _ -> assert false
+
+
+(*s (Recursive) Extraction of a library. The vernacular command is
+ \verb!(Recursive) Extraction Library! [M]. *)
+
+let extraction_library is_rec m =
+ init 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);
+ let env = Global.env () in
+ let l = List.rev (environment_until (Some dir_m)) in
+ let select l (mp,meb) =
+ if Visit.needed_mp mp
+ then (mp, unpack (extract_seb env mp true meb)) :: l
+ else l
+ in
+ let struc = List.fold_left select [] l in
+ let struc = optimize_struct [] struc in
+ warning_axioms ();
+ let print = function
+ | (MPfile dir as mp, sel) as e ->
+ let dry = not is_rec && dir <> dir_m in
+ print_structure_to_file (module_filename mp) dry [e]
+ | _ -> assert false
+ in
+ List.iter print struc;
+ reset ()
diff --git a/plugins/extraction/extract_env.mli b/plugins/extraction/extract_env.mli
new file mode 100644
index 00000000..dcb4601e
--- /dev/null
+++ b/plugins/extraction/extract_env.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*s This module declares the extraction commands. *)
+
+open Names
+open Libnames
+
+val simple_extraction : reference -> unit
+val full_extraction : string option -> 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
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
new file mode 100644
index 00000000..99682ae6
--- /dev/null
+++ b/plugins/extraction/extraction.ml
@@ -0,0 +1,982 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Declarations
+open Environ
+open Reduction
+open Reductionops
+open Inductive
+open Termops
+open Inductiveops
+open Recordops
+open Namegen
+open Summary
+open Libnames
+open Nametab
+open Miniml
+open Table
+open Mlutil
+(*i*)
+
+exception I of inductive_info
+
+(* A set of all fixpoint functions currently being extracted *)
+let current_fixpoints = ref ([] : constant list)
+
+let none = Evd.empty
+
+let type_of env c = Retyping.get_type_of env none (strip_outer_cast c)
+
+let sort_of env c = Retyping.get_sort_family_of env none (strip_outer_cast c)
+
+let is_axiom env kn = (Environ.lookup_constant kn env).const_body = None
+
+(*S Generation of flags and signatures. *)
+
+(* The type [flag] gives us information about any Coq term:
+ \begin{itemize}
+ \item [TypeScheme] denotes a type scheme, that is
+ something that will become a type after enough applications.
+ More formally, a type scheme has type $(x_1:X_1)\ldots(x_n:X_n)s$ with
+ [s = Set], [Prop] or [Type]
+ \item [Default] denotes the other cases. It may be inexact after
+ instanciation. For example [(X:Type)X] is [Default] and may give [Set]
+ after instanciation, which is rather [TypeScheme]
+ \item [Logic] denotes a term of sort [Prop], or a type scheme on sort [Prop]
+ \item [Info] is the opposite. The same example [(X:Type)X] shows
+ that an [Info] term might in fact be [Logic] later on.
+ \end{itemize} *)
+
+type info = Logic | Info
+
+type scheme = TypeScheme | Default
+
+type flag = info * scheme
+
+(*s [flag_of_type] transforms a type [t] into a [flag].
+ Really important function. *)
+
+let rec flag_of_type env t =
+ let t = whd_betadeltaiota env none t in
+ match kind_of_term t with
+ | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c
+ | Sort (Prop Null) -> (Logic,TypeScheme)
+ | Sort _ -> (Info,TypeScheme)
+ | _ -> if (sort_of env t) = InProp then (Logic,Default) else (Info,Default)
+
+(*s Two particular cases of [flag_of_type]. *)
+
+let is_default env t = (flag_of_type env t = (Info, Default))
+
+exception NotDefault of kill_reason
+
+let check_default env t =
+ match flag_of_type env t with
+ | _,TypeScheme -> raise (NotDefault Ktype)
+ | Logic,_ -> raise (NotDefault Kother)
+ | _ -> ()
+
+let is_info_scheme env t = (flag_of_type env t = (Info, TypeScheme))
+
+(*s [type_sign] gernerates a signature aimed at treating a type application. *)
+
+let rec type_sign env c =
+ match kind_of_term (whd_betadeltaiota env none c) with
+ | Prod (n,t,d) ->
+ (if is_info_scheme env t then Keep else Kill Kother)
+ :: (type_sign (push_rel_assum (n,t) env) d)
+ | _ -> []
+
+let rec type_scheme_nb_args env c =
+ match kind_of_term (whd_betadeltaiota env none c) with
+ | Prod (n,t,d) ->
+ let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in
+ if is_info_scheme env t then n+1 else n
+ | _ -> 0
+
+let _ = register_type_scheme_nb_args type_scheme_nb_args
+
+(*s [type_sign_vl] does the same, plus a type var list. *)
+
+let rec type_sign_vl env c =
+ match kind_of_term (whd_betadeltaiota env none c) with
+ | Prod (n,t,d) ->
+ let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in
+ if not (is_info_scheme env t) then Kill Kother::s, vl
+ else Keep::s, (next_ident_away (id_of_name n) vl) :: vl
+ | _ -> [],[]
+
+let rec nb_default_params env c =
+ match kind_of_term (whd_betadeltaiota env none c) with
+ | Prod (n,t,d) ->
+ let n = nb_default_params (push_rel_assum (n,t) env) d in
+ if is_default env t then n+1 else n
+ | _ -> 0
+
+(* Enriching a signature with implicit information *)
+
+let sign_with_implicits r s =
+ let implicits = implicits_of_global r in
+ let rec add_impl i = function
+ | [] -> []
+ | sign::s ->
+ let sign' =
+ if sign = Keep && List.mem i implicits then Kill Kother else sign
+ in sign' :: add_impl (succ i) s
+ in
+ add_impl 1 s
+
+(* Enriching a exception message *)
+
+let rec handle_exn r n fn_name = function
+ | MLexn s ->
+ (try Scanf.sscanf s "UNBOUND %d"
+ (fun i ->
+ assert ((0 < i) && (i <= n));
+ MLexn ("IMPLICIT "^ msg_non_implicit r (n+1-i) (fn_name i)))
+ with _ -> MLexn s)
+ | a -> ast_map (handle_exn r n fn_name) a
+
+(*S Management of type variable contexts. *)
+
+(* A De Bruijn variable context (db) is a context for translating Coq [Rel]
+ into ML type [Tvar]. *)
+
+(*s From a type signature toward a type variable context (db). *)
+
+let db_from_sign s =
+ let rec make i acc = function
+ | [] -> acc
+ | Keep :: l -> make (i+1) (i::acc) l
+ | Kill _ :: l -> make i (0::acc) l
+ in make 1 [] s
+
+(*s Create a type variable context from indications taken from
+ an inductive type (see just below). *)
+
+let rec db_from_ind dbmap i =
+ if i = 0 then []
+ else (try Intmap.find i dbmap with Not_found -> 0)::(db_from_ind dbmap (i-1))
+
+(*s [parse_ind_args] builds a map: [i->j] iff the i-th Coq argument
+ of a constructor corresponds to the j-th type var of the ML inductive. *)
+
+(* \begin{itemize}
+ \item [si] : signature of the inductive
+ \item [i] : counter of Coq args for [(I args)]
+ \item [j] : counter of ML type vars
+ \item [relmax] : total args number of the constructor
+ \end{itemize} *)
+
+let parse_ind_args si args relmax =
+ let rec parse i j = function
+ | [] -> Intmap.empty
+ | Kill _ :: s -> parse (i+1) j s
+ | Keep :: s ->
+ (match kind_of_term args.(i-1) with
+ | Rel k -> Intmap.add (relmax+1-k) j (parse (i+1) (j+1) s)
+ | _ -> parse (i+1) (j+1) s)
+ in parse 1 1 si
+
+(*S Extraction of a type. *)
+
+(* [extract_type env db c args] is used to produce an ML type from the
+ coq term [(c args)], which is supposed to be a Coq type. *)
+
+(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
+
+(* [j] stands for the next ML type var. [j=0] means we do not
+ generate ML type var anymore (in subterms for example). *)
+
+
+let rec extract_type env db j c args =
+ match kind_of_term (whd_betaiotazeta Evd.empty c) with
+ | App (d, args') ->
+ (* We just accumulate the arguments. *)
+ extract_type env db j d (Array.to_list args' @ args)
+ | Lambda (_,_,d) ->
+ (match args with
+ | [] -> assert false (* otherwise the lambda would be reductible. *)
+ | a :: args -> extract_type env db j (subst1 a d) args)
+ | Prod (n,t,d) ->
+ assert (args = []);
+ let env' = push_rel_assum (n,t) env in
+ (match flag_of_type env t with
+ | (Info, Default) ->
+ (* Standard case: two [extract_type] ... *)
+ let mld = extract_type env' (0::db) j d [] in
+ (match expand env mld with
+ | Tdummy d -> Tdummy d
+ | _ -> Tarr (extract_type env db 0 t [], mld))
+ | (Info, TypeScheme) when j > 0 ->
+ (* A new type var. *)
+ let mld = extract_type env' (j::db) (j+1) d [] in
+ (match expand env mld with
+ | Tdummy d -> Tdummy d
+ | _ -> Tarr (Tdummy Ktype, mld))
+ | _,lvl ->
+ let mld = extract_type env' (0::db) j d [] in
+ (match expand env mld with
+ | Tdummy d -> Tdummy d
+ | _ ->
+ let reason = if lvl=TypeScheme then Ktype else Kother in
+ Tarr (Tdummy reason, mld)))
+ | Sort _ -> Tdummy Ktype (* The two logical cases. *)
+ | _ when sort_of env (applist (c, args)) = InProp -> Tdummy Kother
+ | Rel n ->
+ (match lookup_rel n env with
+ | (_,Some t,_) -> extract_type env db j (lift n t) args
+ | _ ->
+ (* Asks [db] a translation for [n]. *)
+ if n > List.length db then Tunknown
+ else let n' = List.nth db (n-1) in
+ if n' = 0 then Tunknown else Tvar n')
+ | Const kn ->
+ let r = ConstRef kn in
+ let cb = lookup_constant kn env in
+ let typ = Typeops.type_of_constant_type env cb.const_type in
+ (match flag_of_type env typ with
+ | (Info, TypeScheme) ->
+ let mlt = extract_type_app env db (r, type_sign env typ) args in
+ (match cb.const_body with
+ | None -> mlt
+ | Some _ when is_custom r -> mlt
+ | Some lbody ->
+ let newc = applist (Declarations.force lbody, args) in
+ let mlt' = extract_type env db j newc [] in
+ (* ML type abbreviations interact badly with Coq *)
+ (* reduction, so [mlt] and [mlt'] might be different: *)
+ (* The more precise is [mlt'], extracted after reduction *)
+ (* The shortest is [mlt], which use abbreviations *)
+ (* If possible, we take [mlt], otherwise [mlt']. *)
+ if expand env mlt = expand env mlt' then mlt else mlt')
+ | _ -> (* only other case here: Info, Default, i.e. not an ML type *)
+ (match cb.const_body with
+ | None -> Tunknown (* Brutal approximation ... *)
+ | Some lbody ->
+ (* We try to reduce. *)
+ let newc = applist (Declarations.force lbody, args) in
+ extract_type env db j newc []))
+ | Ind (kn,i) ->
+ let s = (extract_ind env kn).ind_packets.(i).ip_sign in
+ extract_type_app env db (IndRef (kn,i),s) args
+ | Case _ | Fix _ | CoFix _ -> Tunknown
+ | _ -> assert false
+
+(* [extract_maybe_type] calls [extract_type] when used on a Coq type,
+ and otherwise returns [Tdummy] or [Tunknown] *)
+
+and extract_maybe_type env db c =
+ let t = whd_betadeltaiota env none (type_of env c) in
+ if isSort t then extract_type env db 0 c []
+ else if sort_of env t = InProp then Tdummy 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]. *)
+
+and extract_type_app env db (r,s) args =
+ let ml_args =
+ List.fold_right
+ (fun (b,c) a -> if b=Keep then
+ let p = List.length (fst (splay_prod env none (type_of env c))) in
+ let db = iterate (fun l -> 0 :: l) p db in
+ (extract_type_scheme env db c p) :: a
+ else a)
+ (List.combine s args) []
+ in Tglob (r, ml_args)
+
+(*S Extraction of a type scheme. *)
+
+(* [extract_type_scheme env db c p] works on a Coq term [c] which is
+ an informative type scheme. It means that [c] is not a Coq type, but will
+ be when applied to sufficiently many arguments ([p] in fact).
+ This function decomposes p lambdas, with eta-expansion if needed. *)
+
+(* [db] is a context for translating Coq [Rel] into ML type [Tvar]. *)
+
+and extract_type_scheme env db c p =
+ if p=0 then extract_type env db 0 c []
+ else
+ let c = whd_betaiotazeta Evd.empty c in
+ match kind_of_term c with
+ | Lambda (n,t,d) ->
+ extract_type_scheme (push_rel_assum (n,t) env) db d (p-1)
+ | _ ->
+ let rels = fst (splay_prod env none (type_of env c)) in
+ let env = push_rels_assum rels env in
+ let eta_args = List.rev_map mkRel (interval 1 p) in
+ extract_type env db 0 (lift p c) eta_args
+
+
+(*S Extraction of an inductive type. *)
+
+and extract_ind env kn = (* kn is supposed to be in long form *)
+ let mib = Environ.lookup_mind kn env in
+ try
+ (* For a same kn, we can get various bodies due to module substitutions.
+ 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;
+ 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
+ NoEquiv
+ else
+ begin
+ ignore (extract_ind env (mind_of_kn (canonical_mind kn)));
+ Equiv (canonical_mind kn)
+ end
+ in
+ (* Everything concerning parameters. *)
+ (* We do that first, since they are common to all the [mib]. *)
+ let mip0 = mib.mind_packets.(0) in
+ let npar = mib.mind_nparams in
+ let epar = push_rel_context mib.mind_params_ctxt env in
+ (* First pass: we store inductive signatures together with *)
+ (* their type var list. *)
+ let packets =
+ Array.map
+ (fun mip ->
+ let b = snd (mind_arity mip) <> InProp in
+ let ar = Inductive.type_of_inductive env (mib,mip) in
+ let s,v = if b then type_sign_vl env ar else [],[] in
+ let t = Array.make (Array.length mip.mind_nf_lc) [] in
+ { ip_typename = mip.mind_typename;
+ ip_consnames = mip.mind_consnames;
+ ip_logical = (not b);
+ ip_sign = s;
+ ip_vars = v;
+ ip_types = t;
+ ip_optim_id_ok = None })
+ mib.mind_packets
+ in
+
+ add_ind kn mib
+ {ind_info = Standard;
+ ind_nparams = npar;
+ ind_packets = packets;
+ ind_equiv = equiv
+ };
+ (* Second pass: we extract constructors *)
+ for i = 0 to mib.mind_ntypes - 1 do
+ let p = packets.(i) in
+ if not p.ip_logical then
+ let types = arities_of_constructors env (kn,i) in
+ for j = 0 to Array.length types - 1 do
+ let t = snd (decompose_prod_n npar types.(j)) in
+ let prods,head = dest_prod epar t in
+ let nprods = List.length prods in
+ let args = match kind_of_term head with
+ | App (f,args) -> args (* [kind_of_term f = Ind ip] *)
+ | _ -> [||]
+ in
+ let dbmap = parse_ind_args p.ip_sign args (nprods + npar) in
+ let db = db_from_ind dbmap npar in
+ p.ip_types.(j) <- extract_type_cons epar db dbmap t (npar+1)
+ done
+ done;
+ (* Third pass: we determine special cases. *)
+ let ind_info =
+ try
+ if not mib.mind_finite then raise (I Coinductive);
+ if mib.mind_ntypes <> 1 then raise (I Standard);
+ let p = packets.(0) in
+ if p.ip_logical then raise (I Standard);
+ if Array.length p.ip_types <> 1 then raise (I Standard);
+ let typ = p.ip_types.(0) in
+ let l = List.filter (fun t -> not (isDummy (expand env t))) typ in
+ if List.length l = 1 && not (type_mem_kn kn (List.hd l))
+ then raise (I Singleton);
+ if l = [] then raise (I Standard);
+ if not mib.mind_record then raise (I Standard);
+ let ip = (kn, 0) in
+ let r = IndRef ip in
+ if is_custom r then raise (I Standard);
+ (* Now we're sure it's a record. *)
+ (* First, we find its field names. *)
+ let rec names_prod t = match kind_of_term t with
+ | Prod(n,_,t) -> n::(names_prod t)
+ | LetIn(_,_,_,t) -> names_prod t
+ | Cast(t,_,_) -> names_prod t
+ | _ -> []
+ in
+ let field_names =
+ list_skipn mib.mind_nparams (names_prod mip0.mind_user_lc.(0)) in
+ assert (List.length field_names = List.length typ);
+ let projs = ref Cset.empty in
+ let mp,d,_ = repr_mind kn in
+ let rec select_fields l typs = match l,typs with
+ | [],[] -> []
+ | (Name id)::l, typ::typs ->
+ if isDummy (expand env typ) then select_fields l typs
+ else
+ let knp = make_con mp d (label_of_id id) in
+ if List.for_all ((=) Keep) (type2signature env typ)
+ then
+ projs := Cset.add knp !projs;
+ (ConstRef knp) :: (select_fields l typs)
+ | Anonymous::l, typ::typs ->
+ if isDummy (expand env typ) then select_fields l typs
+ else error_record r
+ | _ -> assert false
+ in
+ let field_glob = select_fields field_names typ
+ in
+ (* Is this record officially declared with its projections ? *)
+ (* If so, we use this information. *)
+ begin try
+ let n = nb_default_params env
+ (Inductive.type_of_inductive env (mib,mip0))
+ in
+ List.iter
+ (Option.iter
+ (fun kn -> if Cset.mem kn !projs then add_projection n kn))
+ (lookup_projections ip)
+ with Not_found -> ()
+ end;
+ Record field_glob
+ with (I info) -> info
+ in
+ let i = {ind_info = ind_info;
+ ind_nparams = npar;
+ ind_packets = packets;
+ ind_equiv = equiv }
+ in
+ add_ind kn mib i;
+ i
+
+(*s [extract_type_cons] extracts the type of an inductive
+ constructor toward the corresponding list of ML types.
+
+ - [db] is a context for translating Coq [Rel] into ML type [Tvar]
+ - [dbmap] is a translation map (produced by a call to [parse_in_args])
+ - [i] is the rank of the current product (initially [params_nb+1])
+*)
+
+and extract_type_cons env db dbmap c i =
+ match kind_of_term (whd_betadeltaiota env none c) with
+ | Prod (n,t,d) ->
+ let env' = push_rel_assum (n,t) env in
+ let db' = (try Intmap.find i dbmap with Not_found -> 0) :: db in
+ let l = extract_type_cons env' db' dbmap d (i+1) in
+ (extract_type env db 0 t []) :: l
+ | _ -> []
+
+(*s Recording the ML type abbreviation of a Coq type scheme constant. *)
+
+and mlt_env env r = match r with
+ | ConstRef kn ->
+ (try
+ if not (visible_con kn) then raise Not_found;
+ match lookup_term kn with
+ | Dtype (_,vl,mlt) -> Some mlt
+ | _ -> None
+ with Not_found ->
+ let cb = Environ.lookup_constant kn env in
+ let typ = Typeops.type_of_constant_type env cb.const_type in
+ match cb.const_body with
+ | None -> None
+ | Some l_body ->
+ (match flag_of_type env typ with
+ | Info,TypeScheme ->
+ let body = Declarations.force l_body in
+ let s,vl = type_sign_vl env typ in
+ let db = db_from_sign s in
+ let t = extract_type_scheme env db body (List.length s)
+ in add_term kn (Dtype (r, vl, t)); Some t
+ | _ -> None))
+ | _ -> None
+
+and expand env = type_expand (mlt_env env)
+and type2signature env = type_to_signature (mlt_env env)
+let type2sign env = type_to_sign (mlt_env env)
+let type_expunge env = type_expunge (mlt_env env)
+let type_expunge_from_sign env = type_expunge_from_sign (mlt_env env)
+
+(*s Extraction of the type of a constant. *)
+
+let record_constant_type env kn opt_typ =
+ try
+ if not (visible_con kn) then raise Not_found;
+ lookup_type kn
+ with Not_found ->
+ let typ = match opt_typ with
+ | None -> Typeops.type_of_constant env kn
+ | Some typ -> typ
+ in let mlt = extract_type env [] 1 typ []
+ in let schema = (type_maxvar mlt, mlt)
+ in add_type kn schema; schema
+
+(*S Extraction of a term. *)
+
+(* Precondition: [(c args)] is not a type scheme, and is informative. *)
+
+(* [mle] is a ML environment [Mlenv.t]. *)
+(* [mlt] is the ML type we want our extraction of [(c args)] to have. *)
+
+let rec extract_term env mle mlt c args =
+ match kind_of_term c with
+ | App (f,a) ->
+ extract_term env mle mlt f (Array.to_list a @ args)
+ | Lambda (n, t, d) ->
+ let id = id_of_name n in
+ (match args with
+ | a :: l ->
+ (* We make as many [LetIn] as possible. *)
+ let d' = mkLetIn (Name id,a,t,applistc d (List.map (lift 1) l))
+ in extract_term env mle mlt d' []
+ | [] ->
+ let env' = push_rel_assum (Name id, t) env in
+ let id, a =
+ try check_default env t; Id id, new_meta()
+ with NotDefault d -> Dummy, Tdummy d
+ in
+ let b = new_meta () in
+ (* If [mlt] cannot be unified with an arrow type, then magic! *)
+ let magic = needs_magic (mlt, Tarr (a, b)) in
+ let d' = extract_term env' (Mlenv.push_type mle a) b d [] in
+ put_magic_if magic (MLlam (id, d')))
+ | LetIn (n, c1, t1, c2) ->
+ let id = id_of_name n in
+ let env' = push_rel (Name id, Some c1, t1) env in
+ let args' = List.map (lift 1) args in
+ (try
+ check_default env t1;
+ let a = new_meta () in
+ let c1' = extract_term env mle a c1 [] in
+ (* The type of [c1'] is generalized and stored in [mle]. *)
+ let mle' = Mlenv.push_gen mle a in
+ MLletin (Id id, c1', extract_term env' mle' mlt c2 args')
+ with NotDefault d ->
+ let mle' = Mlenv.push_std_type mle (Tdummy d) in
+ ast_pop (extract_term env' mle' mlt c2 args'))
+ | Const kn ->
+ extract_cst_app env mle mlt kn args
+ | Construct cp ->
+ extract_cons_app env mle mlt cp args
+ | Rel n ->
+ (* As soon as the expected [mlt] for the head is known, *)
+ (* we unify it with an fresh copy of the stored type of [Rel n]. *)
+ let extract_rel mlt = put_magic (mlt, Mlenv.get mle n) (MLrel n)
+ in extract_app env mle mlt extract_rel args
+ | Case ({ci_ind=ip},_,c0,br) ->
+ extract_app env mle mlt (extract_case env mle (ip,c0,br)) args
+ | Fix ((_,i),recd) ->
+ extract_app env mle mlt (extract_fix env mle i recd) args
+ | CoFix (i,recd) ->
+ extract_app env mle mlt (extract_fix env mle i recd) args
+ | Cast (c,_,_) -> extract_term env mle mlt c args
+ | Ind _ | Prod _ | Sort _ | Meta _ | Evar _ | Var _ -> assert false
+
+(*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *)
+
+and extract_maybe_term env mle mlt c =
+ try check_default env (type_of env c);
+ extract_term env mle mlt c []
+ with NotDefault d ->
+ put_magic (mlt, Tdummy d) MLdummy
+
+(*s Generic way to deal with an application. *)
+
+(* We first type all arguments starting with unknown meta types.
+ This gives us the expected type of the head. Then we use the
+ [mk_head] to produce the ML head from this type. *)
+
+and extract_app env mle mlt mk_head args =
+ let metas = List.map new_meta args in
+ let type_head = type_recomp (metas, mlt) in
+ let mlargs = List.map2 (extract_maybe_term env mle) metas args in
+ mlapp (mk_head type_head) mlargs
+
+(*s Auxiliary function used to extract arguments of constant or constructor. *)
+
+and make_mlargs env e s args typs =
+ let rec f = function
+ | [], [], _ -> []
+ | a::la, t::lt, [] -> extract_maybe_term env e t a :: (f (la,lt,[]))
+ | a::la, t::lt, Keep::s -> extract_maybe_term env e t a :: (f (la,lt,s))
+ | _::la, _::lt, _::s -> f (la,lt,s)
+ | _ -> assert false
+ in f (args,typs,s)
+
+(*s Extraction of a constant applied to arguments. *)
+
+and extract_cst_app env mle mlt kn args =
+ (* First, the [ml_schema] of the constant, in expanded version. *)
+ let nb,t = record_constant_type env kn None in
+ let schema = nb, expand env t in
+ (* Can we instantiate types variables for this constant ? *)
+ (* In Ocaml, inside the definition of this constant, the answer is no. *)
+ let instantiated =
+ if lang () = Ocaml && List.mem kn !current_fixpoints then var2var' (snd schema)
+ else instantiation schema
+ in
+ (* Then the expected type of this constant. *)
+ let a = new_meta () in
+ (* We compare stored and expected types in two steps. *)
+ (* First, can [kn] be applied to all args ? *)
+ let metas = List.map new_meta args in
+ let magic1 = needs_magic (type_recomp (metas, a), instantiated) in
+ (* Second, is the resulting type compatible with the expected type [mlt] ? *)
+ let magic2 = needs_magic (a, mlt) in
+ (* The internal head receives a magic if [magic1] *)
+ let head = put_magic_if magic1 (MLglob (ConstRef kn)) in
+ (* Now, the extraction of the arguments. *)
+ let s_full = type2signature env (snd schema) in
+ let s_full = sign_with_implicits (ConstRef kn) s_full in
+ let s = sign_no_final_keeps s_full in
+ let ls = List.length s in
+ let la = List.length args in
+ (* The ml arguments, already expunged from known logical ones *)
+ let mla = make_mlargs env mle s args metas in
+ let mla =
+ if not magic1 then
+ try
+ let l,l' = list_chop (projection_arity (ConstRef kn)) mla in
+ if l' <> [] then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
+ else mla
+ with _ -> mla
+ else mla
+ in
+ (* For strict languages, purely logical signatures with at least
+ one [Kill Kother] lead to a dummy lam. So a [MLdummy] is left
+ accordingly. *)
+ let optdummy = match sign_kind s_full with
+ | UnsafeLogicalSig when lang () <> Haskell -> [MLdummy]
+ | _ -> []
+ in
+ (* Different situations depending of the number of arguments: *)
+ if la >= ls
+ then
+ (* Enough args, cleanup already done in [mla], we only add the
+ additionnal dummy if needed. *)
+ put_magic_if (magic2 && not magic1) (mlapp head (optdummy @ mla))
+ else
+ (* Partially applied function with some logical arg missing.
+ We complete via eta and expunge logical args. *)
+ let ls' = ls-la in
+ let s' = list_skipn la s in
+ let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
+ let e = anonym_or_dummy_lams (mlapp head mla) s' in
+ put_magic_if magic2 (remove_n_lams (List.length optdummy) e)
+
+(*s Extraction of an inductive constructor applied to arguments. *)
+
+(* \begin{itemize}
+ \item In ML, contructor arguments are uncurryfied.
+ \item We managed to suppress logical parts inside inductive definitions,
+ but they must appears outside (for partial applications for instance)
+ \item We also suppressed all Coq parameters to the inductives, since
+ they are fixed, and thus are not used for the computation.
+ \end{itemize} *)
+
+and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
+ (* First, we build the type of the constructor, stored in small pieces. *)
+ let mi = extract_ind env kn in
+ let params_nb = mi.ind_nparams in
+ let oi = mi.ind_packets.(i) in
+ let nb_tvars = List.length oi.ip_vars
+ and types = List.map (expand env) oi.ip_types.(j-1) in
+ let list_tvar = List.map (fun i -> Tvar i) (interval 1 nb_tvars) in
+ let type_cons = type_recomp (types, Tglob (IndRef ip, list_tvar)) in
+ let type_cons = instantiation (nb_tvars, type_cons) in
+ (* Then, the usual variables [s], [ls], [la], ... *)
+ let s = List.map (type2sign env) types in
+ let s = sign_with_implicits (ConstructRef cp) s in
+ let ls = List.length s in
+ let la = List.length args in
+ assert (la <= ls + params_nb);
+ let la' = max 0 (la - params_nb) in
+ let args' = list_lastn la' args in
+ (* Now, we build the expected type of the constructor *)
+ let metas = List.map new_meta args' in
+ (* If stored and expected types differ, then magic! *)
+ let a = new_meta () in
+ let magic1 = needs_magic (type_cons, type_recomp (metas, a)) in
+ let magic2 = needs_magic (a, mlt) in
+ let head mla =
+ if mi.ind_info = Singleton then
+ put_magic_if magic1 (List.hd mla) (* assert (List.length mla = 1) *)
+ else put_magic_if magic1 (MLcons (mi.ind_info, ConstructRef cp, mla))
+ in
+ (* Different situations depending of the number of arguments: *)
+ if la < params_nb then
+ let head' = head (eta_args_sign ls s) in
+ put_magic_if magic2
+ (dummy_lams (anonym_or_dummy_lams head' s) (params_nb - la))
+ else
+ let mla = make_mlargs env mle s args' metas in
+ if la = ls + params_nb
+ then put_magic_if (magic2 && not magic1) (head mla)
+ else (* [ params_nb <= la <= ls + params_nb ] *)
+ let ls' = params_nb + ls - la in
+ let s' = list_lastn ls' s in
+ let mla = (List.map (ast_lift ls') mla) @ (eta_args_sign ls' s') in
+ put_magic_if magic2 (anonym_or_dummy_lams (head mla) s')
+
+(*S Extraction of a case. *)
+
+and extract_case env mle ((kn,i) as ip,c,br) mlt =
+ (* [br]: bodies of each branch (in functional form) *)
+ (* [ni]: number of arguments without parameters in each branch *)
+ let ni = mis_constr_nargs_env env ip in
+ let br_size = Array.length br in
+ assert (Array.length ni = br_size);
+ if br_size = 0 then begin
+ add_recursors env kn; (* May have passed unseen if logical ... *)
+ MLexn "absurd case"
+ end else
+ (* [c] has an inductive type, and is not a type scheme type. *)
+ let t = type_of env c in
+ (* The only non-informative case: [c] is of sort [Prop] *)
+ if (sort_of env t) = InProp then
+ begin
+ add_recursors env kn; (* May have passed unseen if logical ... *)
+ (* Logical singleton case: *)
+ (* [match c with C i j k -> t] becomes [t'] *)
+ assert (br_size = 1);
+ let s = iterate (fun l -> Kill Kother :: l) ni.(0) [] in
+ let mlt = iterate (fun t -> Tarr (Tdummy Kother, t)) ni.(0) mlt in
+ let e = extract_maybe_term env mle mlt br.(0) in
+ snd (case_expunge s e)
+ end
+ else
+ let mi = extract_ind env kn in
+ let oi = mi.ind_packets.(i) in
+ let metas = Array.init (List.length oi.ip_vars) new_meta in
+ (* The extraction of the head. *)
+ let type_head = Tglob (IndRef ip, Array.to_list metas) in
+ let a = extract_term env mle type_head c [] in
+ (* The extraction of each branch. *)
+ let extract_branch i =
+ let r = ConstructRef (ip,i+1) in
+ (* The types of the arguments of the corresponding constructor. *)
+ let f t = type_subst_vect metas (expand env t) in
+ let l = List.map f oi.ip_types.(i) in
+ (* the corresponding signature *)
+ let s = List.map (type2sign env) oi.ip_types.(i) in
+ let s = sign_with_implicits r s in
+ (* Extraction of the branch (in functional form). *)
+ let e = extract_maybe_term env mle (type_recomp (l,mlt)) br.(i) in
+ (* We suppress dummy arguments according to signature. *)
+ let ids,e = case_expunge s e in
+ let e' = handle_exn r (List.length s) (fun _ -> Anonymous) e in
+ (r, List.rev ids, e')
+ in
+ if mi.ind_info = Singleton then
+ begin
+ (* Informative singleton case: *)
+ (* [match c with C i -> t] becomes [let i = c' in t'] *)
+ assert (br_size = 1);
+ let (_,ids,e') = extract_branch 0 in
+ assert (List.length ids = 1);
+ MLletin (tmp_id (List.hd ids),a,e')
+ end
+ else
+ (* Standard case: we apply [extract_branch]. *)
+ MLcase ((mi.ind_info,BranchNone), a, Array.init br_size extract_branch)
+
+(*s Extraction of a (co)-fixpoint. *)
+
+and extract_fix env mle i (fi,ti,ci as recd) mlt =
+ let env = push_rec_types recd env in
+ let metas = Array.map new_meta fi in
+ metas.(i) <- mlt;
+ let mle = Array.fold_left Mlenv.push_type mle metas in
+ let ei = array_map2 (extract_maybe_term env mle) metas ci in
+ MLfix (i, Array.map id_of_name fi, ei)
+
+(*S ML declarations. *)
+
+(* [decomp_lams_eta env c t] finds the number [n] of products in the type [t],
+ and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *)
+
+let rec decomp_lams_eta_n n m env c t =
+ let rels = fst (splay_prod_n env none n t) in
+ let rels = List.map (fun (id,_,c) -> (id,c)) rels in
+ let rels',c = decompose_lam c in
+ let d = n - m in
+ (* we'd better keep rels' as long as possible. *)
+ let rels = (list_firstn d rels) @ rels' in
+ let eta_args = List.rev_map mkRel (interval 1 d) in
+ rels, applist (lift d c,eta_args)
+
+(*s From a constant to a ML declaration. *)
+
+let extract_std_constant env kn body typ =
+ reset_meta_count ();
+ (* The short type [t] (i.e. possibly with abbreviations). *)
+ let t = snd (record_constant_type env kn (Some typ)) in
+ (* The real type [t']: without head products, expanded, *)
+ (* and with [Tvar] translated to [Tvar'] (not instantiable). *)
+ let l,t' = type_decomp (expand env (var2var' t)) in
+ let s = List.map (type2sign env) l in
+ (* Check for user-declared implicit information *)
+ let s = sign_with_implicits (ConstRef kn) s in
+ (* Decomposing the top level lambdas of [body].
+ If there isn't enough, it's ok, as long as remaining args
+ aren't to be pruned (and initial lambdas aren't to be all
+ removed if the target language is strict). In other situations,
+ eta-expansions create artificially enough lams (but that may
+ break user's clever let-ins and partial applications). *)
+ let rels, c =
+ let n = List.length s
+ 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
+ if List.for_all ((=) Keep) s' &&
+ (lang () = Haskell || sign_kind s <> UnsafeLogicalSig)
+ then decompose_lam_n m body
+ else decomp_lams_eta_n n m env 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 t' = type_recomp (l',t') in
+ (* The initial ML environment. *)
+ let mle = List.fold_left Mlenv.push_std_type Mlenv.empty l in
+ (* The lambdas names. *)
+ let ids = List.map (fun (n,_) -> Id (id_of_name n)) rels in
+ (* The according Coq environment. *)
+ let env = push_rels_assum rels env in
+ (* The real extraction: *)
+ let e = extract_term env mle t' c [] in
+ (* Expunging term and type from dummy lambdas. *)
+ let trm = term_expunge s (ids,e) in
+ let trm = handle_exn (ConstRef kn) n (fun i -> fst (List.nth rels (i-1))) trm
+ in
+ trm, type_expunge_from_sign env s t
+
+let extract_fixpoint env vkn (fi,ti,ci) =
+ let n = Array.length vkn in
+ let types = Array.make n (Tdummy Kother)
+ and terms = Array.make n MLdummy in
+ let kns = Array.to_list vkn in
+ current_fixpoints := kns;
+ (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *)
+ let sub = List.rev_map mkConst kns in
+ for i = 0 to n-1 do
+ if sort_of env ti.(i) <> InProp then begin
+ let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
+ terms.(i) <- e;
+ types.(i) <- t;
+ end
+ done;
+ current_fixpoints := [];
+ Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types)
+
+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 extract_constant_spec env kn cb =
+ let r = ConstRef kn in
+ let typ = Typeops.type_of_constant_type env cb.const_type in
+ match flag_of_type env typ with
+ | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype))
+ | (Logic, Default) -> Sval (r, Tdummy Kother)
+ | (Info, TypeScheme) ->
+ let s,vl = type_sign_vl env typ in
+ (match cb.const_body with
+ | None -> Stype (r, vl, None)
+ | Some body ->
+ let db = db_from_sign s in
+ let t = extract_type_scheme env db (force body) (List.length s)
+ in Stype (r, vl, Some t))
+ | (Info, Default) ->
+ let t = snd (record_constant_type env kn (Some typ)) in
+ Sval (r, type_expunge env t)
+
+let extract_with_type env cb =
+ let typ = Typeops.type_of_constant_type env cb.const_type in
+ 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
+ Some (vl, t)
+ | _ -> None
+
+
+let extract_inductive env kn =
+ let ind = extract_ind env kn in
+ add_recursors env kn;
+ let f i j l =
+ let implicits = implicits_of_global (ConstructRef ((kn,i),j+1)) in
+ let rec filter i = function
+ | [] -> []
+ | t::l ->
+ 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
+ let packets =
+ Array.mapi (fun i p -> { p with ip_types = Array.mapi (f i) p.ip_types })
+ ind.ind_packets
+ in { ind with ind_packets = packets }
+
+(*s Is a [ml_decl] logical ? *)
+
+let logical_decl = function
+ | Dterm (_,MLdummy,Tdummy _) -> true
+ | Dtype (_,[],Tdummy _) -> true
+ | Dfix (_,av,tv) ->
+ (array_for_all ((=) MLdummy) av) &&
+ (array_for_all isDummy tv)
+ | Dind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
+ | _ -> false
+
+(*s Is a [ml_spec] logical ? *)
+
+let logical_spec = function
+ | Stype (_, [], Some (Tdummy _)) -> true
+ | Sval (_,Tdummy _) -> true
+ | Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
+ | _ -> false
diff --git a/plugins/extraction/extraction.mli b/plugins/extraction/extraction.mli
new file mode 100644
index 00000000..6bcd2476
--- /dev/null
+++ b/plugins/extraction/extraction.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*s Extraction from Coq terms to Miniml. *)
+
+open Names
+open Term
+open Declarations
+open Environ
+open Libnames
+open Miniml
+
+val extract_constant : env -> constant -> constant_body -> ml_decl
+
+val extract_constant_spec : env -> constant -> constant_body -> ml_spec
+
+val extract_with_type : env -> constant_body -> ( identifier list * ml_type ) option
+
+val extract_fixpoint :
+ env -> constant array -> (constr, types) prec_declaration -> ml_decl
+
+val extract_inductive : env -> mutual_inductive -> ml_ind
+
+(*s Is a [ml_decl] or a [ml_spec] logical ? *)
+
+val logical_decl : ml_decl -> bool
+val logical_spec : ml_spec -> bool
diff --git a/plugins/extraction/extraction_plugin.mllib b/plugins/extraction/extraction_plugin.mllib
new file mode 100644
index 00000000..b7f45861
--- /dev/null
+++ b/plugins/extraction/extraction_plugin.mllib
@@ -0,0 +1,11 @@
+Table
+Mlutil
+Modutil
+Extraction
+Common
+Ocaml
+Haskell
+Scheme
+Extract_env
+G_extraction
+Extraction_plugin_mod
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
new file mode 100644
index 00000000..18828241
--- /dev/null
+++ b/plugins/extraction/g_extraction.ml4
@@ -0,0 +1,142 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* ML names *)
+
+open Vernacexpr
+open Pcoq
+open Genarg
+open Pp
+open Names
+open Nameops
+open Table
+open Extract_env
+
+let pr_mlname _ _ _ s = spc () ++ qs s
+
+ARGUMENT EXTEND mlname
+ TYPED AS string
+ PRINTED BY pr_mlname
+| [ preident(id) ] -> [ id ]
+| [ string(s) ] -> [ s ]
+END
+
+let pr_int_or_id _ _ _ = function
+ | ArgInt i -> int i
+ | ArgId id -> pr_id id
+
+ARGUMENT EXTEND int_or_id
+ TYPED AS int_or_id
+ PRINTED BY pr_int_or_id
+| [ preident(id) ] -> [ ArgId (id_of_string id) ]
+| [ integer(i) ] -> [ ArgInt i ]
+END
+
+let pr_language = function
+ | Ocaml -> str "Ocaml"
+ | Haskell -> str "Haskell"
+ | Scheme -> str "Scheme"
+
+VERNAC ARGUMENT EXTEND language
+PRINTED BY pr_language
+| [ "Ocaml" ] -> [ Ocaml ]
+| [ "Haskell" ] -> [ Haskell ]
+| [ "Scheme" ] -> [ Scheme ]
+END
+
+(* Extraction commands *)
+
+VERNAC COMMAND EXTEND Extraction
+(* Extraction in the Coq toplevel *)
+| [ "Extraction" global(x) ] -> [ simple_extraction x ]
+| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ]
+
+(* Monolithic extraction to a file *)
+| [ "Extraction" string(f) ne_global_list(l) ]
+ -> [ full_extraction (Some f) l ]
+END
+
+(* Modular extraction (one Coq library = one ML module) *)
+VERNAC COMMAND EXTEND ExtractionLibrary
+| [ "Extraction" "Library" ident(m) ]
+ -> [ extraction_library false m ]
+END
+
+VERNAC COMMAND EXTEND RecursiveExtractionLibrary
+| [ "Recursive" "Extraction" "Library" ident(m) ]
+ -> [ extraction_library true m ]
+END
+
+(* Target Language *)
+VERNAC COMMAND EXTEND ExtractionLanguage
+| [ "Extraction" "Language" language(l) ]
+ -> [ extraction_language l ]
+END
+
+VERNAC COMMAND EXTEND ExtractionInline
+(* Custom inlining directives *)
+| [ "Extraction" "Inline" ne_global_list(l) ]
+ -> [ extraction_inline true l ]
+END
+
+VERNAC COMMAND EXTEND ExtractionNoInline
+| [ "Extraction" "NoInline" ne_global_list(l) ]
+ -> [ extraction_inline false l ]
+END
+
+VERNAC COMMAND EXTEND PrintExtractionInline
+| [ "Print" "Extraction" "Inline" ]
+ -> [ print_extraction_inline () ]
+END
+
+VERNAC COMMAND EXTEND ResetExtractionInline
+| [ "Reset" "Extraction" "Inline" ]
+ -> [ reset_extraction_inline () ]
+END
+
+VERNAC COMMAND EXTEND ExtractionImplicit
+(* Custom implicit arguments of some csts/inds/constructors *)
+| [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ]
+ -> [ extraction_implicit r l ]
+END
+
+VERNAC COMMAND EXTEND ExtractionBlacklist
+(* Force Extraction to not use some filenames *)
+| [ "Extraction" "Blacklist" ne_ident_list(l) ]
+ -> [ extraction_blacklist l ]
+END
+
+VERNAC COMMAND EXTEND PrintExtractionBlacklist
+| [ "Print" "Extraction" "Blacklist" ]
+ -> [ print_extraction_blacklist () ]
+END
+
+VERNAC COMMAND EXTEND ResetExtractionBlacklist
+| [ "Reset" "Extraction" "Blacklist" ]
+ -> [ reset_extraction_blacklist () ]
+END
+
+
+(* Overriding of a Coq object by an ML one *)
+VERNAC COMMAND EXTEND ExtractionConstant
+| [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ]
+ -> [ extract_constant_inline false x idl y ]
+END
+
+VERNAC COMMAND EXTEND ExtractionInlinedConstant
+| [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ]
+ -> [ extract_constant_inline true x [] y ]
+END
+
+VERNAC COMMAND EXTEND ExtractionInductive
+| [ "Extract" "Inductive" global(x) "=>"
+ mlname(id) "[" mlname_list(idl) "]" string_opt(o) ]
+ -> [ extract_inductive x id idl o ]
+END
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
new file mode 100644
index 00000000..bb1dbd48
--- /dev/null
+++ b/plugins/extraction/haskell.ml
@@ -0,0 +1,357 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*s Production of Haskell syntax. *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Mlutil
+open Common
+
+(*s Haskell renaming issues. *)
+
+let pr_lower_id id = str (String.uncapitalize (string_of_id id))
+let pr_upper_id id = str (String.capitalize (string_of_id id))
+
+let keywords =
+ List.fold_right (fun s -> Idset.add (id_of_string s))
+ [ "case"; "class"; "data"; "default"; "deriving"; "do"; "else";
+ "if"; "import"; "in"; "infix"; "infixl"; "infixr"; "instance";
+ "let"; "module"; "newtype"; "of"; "then"; "type"; "where"; "_"; "__";
+ "as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ]
+ Idset.empty
+
+let preamble mod_name used_modules usf =
+ let pp_import mp = str ("import qualified "^ string_of_modfile mp ^"\n")
+ in
+ (if not usf.magic then mt ()
+ else
+ str "{-# OPTIONS_GHC -cpp -fglasgow-exts #-}\n" ++
+ str "{- For Hugs, use the option -F\"cpp -P -traditional\" -}\n\n")
+ ++
+ str "module " ++ pr_upper_id mod_name ++ str " where" ++ fnl2 () ++
+ str "import qualified Prelude" ++ fnl () ++
+ prlist pp_import used_modules ++ fnl () ++
+ (if used_modules = [] then mt () else fnl ()) ++
+ (if not usf.magic then mt ()
+ else str "\
+#ifdef __GLASGOW_HASKELL__
+import qualified GHC.Base
+unsafeCoerce = GHC.Base.unsafeCoerce#
+#else
+-- HUGS
+import qualified IOExts
+unsafeCoerce = IOExts.unsafeCoerce
+#endif" ++ fnl2 ())
+ ++
+ (if not usf.mldummy then mt ()
+ else str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ())
+
+let pp_abst = function
+ | [] -> (mt ())
+ | l -> (str "\\" ++
+ prlist_with_sep (fun () -> (str " ")) pr_id l ++
+ str " ->" ++ spc ())
+
+(*s The pretty-printer for haskell syntax *)
+
+let pp_global k r =
+ if is_inline_custom r then str (find_custom r)
+ else str (Common.pp_global k r)
+
+(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
+ are needed or not. *)
+
+let kn_sig =
+ let specif = MPfile (dirpath_of_string "Coq.Init.Specif") in
+ make_kn 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
+ pp_type true vl (List.hd l)
+ else
+ pp_par par
+ (pp_global Type r ++ spc () ++
+ prlist_with_sep spc (pp_type true vl) l)
+ | Tarr (t1,t2) ->
+ pp_par par
+ (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
+ | Tdummy _ -> str "()"
+ | Tunknown -> str "()"
+ | Taxiom -> str "() -- AXIOM TO BE REALIZED\n"
+ in
+ hov 0 (pp_rec par t)
+
+(*s Pretty-printing of expressions. [par] indicates whether
+ parentheses are needed or not. [env] is the list of names for the
+ de Bruijn variables. [args] is the list of collected arguments
+ (already pretty-printed). *)
+
+let expr_needs_par = function
+ | MLlam _ -> true
+ | MLcase _ -> true
+ | _ -> false
+
+
+let rec pp_expr par env args =
+ let par' = args <> [] || par
+ and apply st = pp_apply st par args in
+ function
+ | MLrel n ->
+ let id = get_db_name n env in apply (pr_id id)
+ | MLapp (f,args') ->
+ let stl = List.map (pp_expr true env []) args' in
+ pp_expr par env (stl @ args) f
+ | MLlam _ as a ->
+ let fl,a' = collect_lams a in
+ let fl,env' = push_vars (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)
+ | 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 5
+ (str "let" ++ spc () ++ pp_id ++ str " = " ++ pp_a1) ++
+ spc () ++ str "in") ++
+ spc () ++ hov 0 pp_a2)))
+ | MLglob r ->
+ apply (pp_global Term r)
+ | 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')
+ | 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
+ 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 ((_,factors),t, pv) ->
+ apply (pp_par par'
+ (v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++
+ fnl () ++ str " " ++ pp_pat env factors pv)))
+ | MLfix (i,ids,defs) ->
+ let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
+ pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
+ | MLexn s ->
+ (* An [MLexn] may be applied, but I don't really care. *)
+ pp_par par (str "Prelude.error" ++ spc () ++ qs s)
+ | MLdummy ->
+ str "__" (* An [MLdummy] may be applied, but I don't really care. *)
+ | MLmagic a ->
+ pp_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 factors 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 (pp_global Cons name ++
+ (match ids with
+ | [] -> mt ()
+ | _ -> (str " " ++
+ prlist_with_sep
+ (fun () -> (spc ())) pr_id (List.rev ids))) ++
+ str " ->" ++ spc () ++ pp_expr par env' [] t)
+ in
+ let factor_br, factor_l = try match factors with
+ | BranchFun (i::_ as l) -> check_function_branch pv.(i), l
+ | BranchCst (i::_ as l) -> ast_pop (check_constant_branch pv.(i)), l
+ | _ -> MLdummy, []
+ with Impossible -> MLdummy, []
+ in
+ let par = expr_needs_par factor_br in
+ let last = Array.length pv - 1 in
+ prvecti
+ (fun i x -> if List.mem i factor_l then mt () else
+ (pp_one_pat pv.(i) ++
+ if i = last && factor_l = [] then mt () else
+ fnl () ++ str " ")) pv
+ ++
+ if factor_l = [] then mt () else match factors with
+ | BranchFun _ ->
+ let ids, env' = push_vars [anonymous_name] env in
+ pr_id (List.hd ids) ++ str " ->" ++ spc () ++
+ pp_expr par env' [] factor_br
+ | BranchCst _ ->
+ str "_ ->" ++ spc () ++ pp_expr par env [] factor_br
+ | BranchNone -> mt ()
+
+(*s names of the functions ([ids]) are already pushed in [env],
+ and passed here just for convenience. *)
+
+and pp_fix par env i (ids,bl) args =
+ pp_par par
+ (v 0
+ (v 2 (str "let" ++ fnl () ++
+ prvect_with_sep fnl
+ (fun (fi,ti) -> pp_function env (pr_id fi) ti)
+ (array_map2 (fun a b -> a,b) ids bl)) ++
+ fnl () ++
+ hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
+
+and pp_function env f t =
+ let bl,t' = collect_lams t in
+ let bl,env' = push_vars (List.map id_of_mlid bl) env in
+ (f ++ pr_binding (List.rev bl) ++
+ str " =" ++ fnl () ++ str " " ++
+ hov 2 (pp_expr false env' [] t'))
+
+(*s Pretty-printing of inductive types declaration. *)
+
+let pp_comment s = str "-- " ++ s ++ fnl ()
+
+let pp_logical_ind packet =
+ pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++
+ pp_comment (str "with constructors : " ++
+ prvect_with_sep spc pr_id packet.ip_consnames)
+
+let pp_singleton kn packet =
+ let l = rename_tvars keywords packet.ip_vars in
+ let l' = List.rev l in
+ hov 2 (str "type " ++ pp_global Type (IndRef (kn,0)) ++ spc () ++
+ prlist_with_sep spc pr_id l ++
+ (if l <> [] then str " " else mt ()) ++ str "=" ++ spc () ++
+ pp_type false l' (List.hd packet.ip_types.(0)) ++ fnl () ++
+ pp_comment (str "singleton inductive, whose constructor was " ++
+ pr_id packet.ip_consnames.(0)))
+
+let pp_one_ind ip pl cv =
+ let pl = rename_tvars keywords pl in
+ let pp_constructor (r,l) =
+ (pp_global Cons r ++
+ match l with
+ | [] -> (mt ())
+ | _ -> (str " " ++
+ prlist_with_sep
+ (fun () -> (str " ")) (pp_type true pl) l))
+ in
+ str (if Array.length cv = 0 then "type " else "data ") ++
+ pp_global Type (IndRef ip) ++ str " " ++
+ prlist_with_sep (fun () -> str " ") pr_lower_id pl ++
+ (if pl = [] then mt () else str " ") ++
+ if Array.length cv = 0 then str "= () -- empty inductive"
+ else
+ (v 0 (str "= " ++
+ prvect_with_sep (fun () -> fnl () ++ str "| ") pp_constructor
+ (Array.mapi (fun i c -> ConstructRef (ip,i+1),c) cv)))
+
+let rec pp_ind first kn i ind =
+ if i >= Array.length ind.ind_packets then
+ if first then mt () else fnl ()
+ else
+ let ip = (kn,i) in
+ let p = ind.ind_packets.(i) in
+ if is_custom (IndRef (kn,i)) then pp_ind first kn (i+1) ind
+ else
+ if p.ip_logical then
+ pp_logical_ind p ++ pp_ind first kn (i+1) ind
+ else
+ pp_one_ind ip p.ip_vars p.ip_types ++ fnl () ++
+ pp_ind false kn (i+1) ind
+
+
+(*s Pretty-printing of a declaration. *)
+
+let pp_string_parameters ids = prlist (fun id -> str id ++ str " ")
+
+let pp_decl = function
+ | Dind (kn,i) when i.ind_info = 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)
+ | Dtype (r, l, t) ->
+ if is_inline_custom r then mt ()
+ else
+ let l = rename_tvars keywords l in
+ let st =
+ try
+ let ids,s = find_type_custom r in
+ prlist (fun id -> str (id^" ")) ids ++ str "=" ++ spc () ++ str s
+ with not_found ->
+ prlist (fun id -> pr_id id ++ str " ") l ++
+ if t = Taxiom then str "= () -- AXIOM TO BE REALIZED\n"
+ else str "=" ++ spc () ++ pp_type false l t
+ in
+ hov 2 (str "type " ++ pp_global Type r ++ spc () ++ st) ++ fnl2 ()
+ | Dfix (rv, defs, typs) ->
+ let max = Array.length rv in
+ let rec iter i =
+ if i = max then mt ()
+ else
+ let e = pp_global Term rv.(i) in
+ e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl ()
+ ++ pp_function (empty_env ()) e defs.(i) ++ fnl2 ()
+ ++ iter (i+1)
+ in iter 0
+ | Dterm (r, a, t) ->
+ if is_inline_custom r then mt ()
+ else
+ let e = pp_global Term r in
+ e ++ str " :: " ++ pp_type false [] t ++ fnl () ++
+ if is_custom r then
+ hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ())
+ else
+ hov 0 (pp_function (empty_env ()) e a ++ fnl2 ())
+
+let rec pp_structure_elem = function
+ | (l,SEdecl d) -> pp_decl d
+ | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr
+ | (l,SEmodtype m) -> mt ()
+ (* for the moment we simply discard module type *)
+
+and pp_module_expr = function
+ | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel
+ | MEfunctor _ -> mt ()
+ (* for the moment we simply discard unapplied functors *)
+ | MEident _ | MEapply _ -> assert false
+ (* should be expansed in extract_env *)
+
+let pp_struct =
+ let pp_sel (mp,sel) =
+ push_visible mp [];
+ let p = prlist_strict pp_structure_elem sel in
+ pop_visible (); p
+ in
+ prlist_strict pp_sel
+
+
+let haskell_descr = {
+ keywords = keywords;
+ file_suffix = ".hs";
+ preamble = preamble;
+ pp_struct = pp_struct;
+ sig_suffix = None;
+ sig_preamble = (fun _ _ _ -> mt ());
+ pp_sig = (fun _ -> mt ());
+ pp_decl = pp_decl;
+}
diff --git a/plugins/extraction/haskell.mli b/plugins/extraction/haskell.mli
new file mode 100644
index 00000000..1b5dbc71
--- /dev/null
+++ b/plugins/extraction/haskell.mli
@@ -0,0 +1,12 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+val haskell_descr : Miniml.language_descr
+
diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli
new file mode 100644
index 00000000..61b3fc13
--- /dev/null
+++ b/plugins/extraction/miniml.mli
@@ -0,0 +1,201 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*s Target language for extraction: a core ML called MiniML. *)
+
+open Pp
+open Util
+open Names
+open Libnames
+
+(* The [signature] type is used to know how many arguments a CIC
+ object expects, and what these arguments will become in the ML
+ object. *)
+
+(* We eliminate from terms: 1) types 2) logical parts.
+ [Kother] stands both for logical or other reasons
+ (for instance user-declared implicit arguments w.r.t. extraction). *)
+
+type kill_reason = Ktype | Kother
+
+type sign = Keep | Kill of kill_reason
+
+
+(* Convention: outmost lambda/product gives the head of the list. *)
+
+type signature = sign list
+
+(*s ML type expressions. *)
+
+type ml_type =
+ | Tarr of ml_type * ml_type
+ | Tglob of global_reference * ml_type list
+ | Tvar of int
+ | Tvar' of int (* same as Tvar, used to avoid clash *)
+ | Tmeta of ml_meta (* used during ML type reconstruction *)
+ | Tdummy of kill_reason
+ | Tunknown
+ | Taxiom
+
+and ml_meta = { id : int; mutable contents : ml_type option }
+
+(* ML type schema.
+ The integer is the number of variable in the schema. *)
+
+type ml_schema = int * ml_type
+
+(*s ML inductive types. *)
+
+type inductive_info =
+ | Singleton
+ | Coinductive
+ | Standard
+ | Record of global_reference list
+
+(* A [ml_ind_packet] is the miniml counterpart of a [one_inductive_body].
+ If the inductive is logical ([ip_logical = false]), then all other fields
+ are unused. Otherwise,
+ [ip_sign] is a signature concerning the arguments of the inductive,
+ [ip_vars] contains the names of the type variables surviving in ML,
+ [ip_types] contains the ML types of all constructors.
+*)
+
+type ml_ind_packet = {
+ ip_typename : identifier;
+ ip_consnames : identifier array;
+ ip_logical : bool;
+ ip_sign : signature;
+ ip_vars : identifier list;
+ ip_types : (ml_type list) array;
+ mutable ip_optim_id_ok : bool option
+}
+
+(* [ip_nparams] contains the number of parameters. *)
+
+type equiv =
+ | NoEquiv
+ | Equiv of kernel_name
+ | RenEquiv of string
+
+type ml_ind = {
+ ind_info : inductive_info;
+ ind_nparams : int;
+ ind_packets : ml_ind_packet array;
+ ind_equiv : equiv
+}
+
+(*s ML terms. *)
+
+type ml_ident =
+ | Dummy
+ | Id of identifier
+ | Tmp of identifier
+
+(* list of branches to merge in a common pattern *)
+
+type case_info =
+ | BranchNone
+ | BranchFun of int list
+ | BranchCst of int list
+
+type ml_branch = global_reference * ml_ident list * ml_ast
+
+and ml_ast =
+ | MLrel of int
+ | MLapp of ml_ast * ml_ast list
+ | MLlam of ml_ident * ml_ast
+ | MLletin of ml_ident * ml_ast * ml_ast
+ | MLglob of global_reference
+ | MLcons of inductive_info * global_reference * ml_ast list
+ | MLcase of (inductive_info*case_info) * ml_ast * ml_branch array
+ | MLfix of int * identifier array * ml_ast array
+ | MLexn of string
+ | MLdummy
+ | MLaxiom
+ | MLmagic of ml_ast
+
+(*s ML declarations. *)
+
+type ml_decl =
+ | Dind of kernel_name * ml_ind
+ | Dtype of global_reference * identifier list * ml_type
+ | Dterm of global_reference * ml_ast * ml_type
+ | Dfix of global_reference array * ml_ast array * ml_type array
+
+type ml_spec =
+ | Sind of kernel_name * ml_ind
+ | Stype of global_reference * identifier list * ml_type option
+ | Sval of global_reference * ml_type
+
+type ml_specif =
+ | Spec of ml_spec
+ | Smodule of ml_module_type
+ | Smodtype of ml_module_type
+
+and ml_module_type =
+ | MTident of module_path
+ | MTfunsig of mod_bound_id * ml_module_type * ml_module_type
+ | MTsig of module_path * ml_module_sig
+ | MTwith of ml_module_type * ml_with_declaration
+
+and ml_with_declaration =
+ | ML_With_type of identifier list * identifier list * ml_type
+ | ML_With_module of identifier list * module_path
+
+and ml_module_sig = (label * ml_specif) list
+
+type ml_structure_elem =
+ | SEdecl of ml_decl
+ | SEmodule of ml_module
+ | SEmodtype of ml_module_type
+
+and ml_module_expr =
+ | MEident of module_path
+ | MEfunctor of mod_bound_id * ml_module_type * ml_module_expr
+ | MEstruct of module_path * ml_module_structure
+ | MEapply of ml_module_expr * ml_module_expr
+
+and ml_module_structure = (label * ml_structure_elem) list
+
+and ml_module =
+ { ml_mod_expr : ml_module_expr;
+ ml_mod_type : ml_module_type }
+
+(* NB: we do not translate the [mod_equiv] field, since [mod_equiv = mp]
+ implies that [mod_expr = MEBident mp]. Same with [msb_equiv]. *)
+
+type ml_structure = (module_path * ml_module_structure) list
+
+type ml_signature = (module_path * ml_module_sig) list
+
+type unsafe_needs = {
+ mldummy : bool;
+ tdummy : bool;
+ tunknown : bool;
+ magic : bool
+}
+
+type language_descr = {
+ keywords : Idset.t;
+
+ (* Concerning the source file *)
+ file_suffix : string;
+ preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds;
+ pp_struct : ml_structure -> std_ppcmds;
+
+ (* Concerning a possible interface file *)
+ sig_suffix : string option;
+ sig_preamble : identifier -> module_path list -> unsafe_needs -> std_ppcmds;
+ pp_sig : ml_signature -> std_ppcmds;
+
+ (* for an isolated declaration print *)
+ pp_decl : ml_decl -> std_ppcmds;
+
+}
diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml
new file mode 100644
index 00000000..6dd43c44
--- /dev/null
+++ b/plugins/extraction/mlutil.ml
@@ -0,0 +1,1293 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*i*)
+open Pp
+open Util
+open Names
+open Libnames
+open Nametab
+open Table
+open Miniml
+(*i*)
+
+(*s Exceptions. *)
+
+exception Found
+exception Impossible
+
+(*S Names operations. *)
+
+let anonymous_name = id_of_string "x"
+let dummy_name = id_of_string "_"
+
+let anonymous = Id anonymous_name
+
+let id_of_name = function
+ | Anonymous -> anonymous_name
+ | Name id when id = dummy_name -> anonymous_name
+ | Name id -> id
+
+let id_of_mlid = function
+ | Dummy -> dummy_name
+ | Id id -> id
+ | Tmp id -> id
+
+let tmp_id = function
+ | Id id -> Tmp id
+ | a -> a
+
+let is_tmp = function Tmp _ -> true | _ -> false
+
+(*S Operations upon ML types (with meta). *)
+
+let meta_count = ref 0
+
+let reset_meta_count () = meta_count := 0
+
+let new_meta _ =
+ incr meta_count;
+ Tmeta {id = !meta_count; contents = None}
+
+(*s Sustitution of [Tvar i] by [t] in a ML type. *)
+
+let type_subst i t0 t =
+ let rec subst t = match t with
+ | Tvar j when i = j -> t0
+ | Tmeta {contents=None} -> t
+ | Tmeta {contents=Some u} -> subst u
+ | Tarr (a,b) -> Tarr (subst a, subst b)
+ | Tglob (r, l) -> Tglob (r, List.map subst l)
+ | a -> a
+ in subst t
+
+(* Simultaneous substitution of [[Tvar 1; ... ; Tvar n]] by [l] in a ML type. *)
+
+let type_subst_list l t =
+ let rec subst t = match t with
+ | Tvar j -> List.nth l (j-1)
+ | Tmeta {contents=None} -> t
+ | Tmeta {contents=Some u} -> subst u
+ | Tarr (a,b) -> Tarr (subst a, subst b)
+ | Tglob (r, l) -> Tglob (r, List.map subst l)
+ | a -> a
+ in subst t
+
+(* Simultaneous substitution of [[|Tvar 1; ... ; Tvar n|]] by [v] in a ML type. *)
+
+let type_subst_vect v t =
+ let rec subst t = match t with
+ | Tvar j -> v.(j-1)
+ | Tmeta {contents=None} -> t
+ | Tmeta {contents=Some u} -> subst u
+ | Tarr (a,b) -> Tarr (subst a, subst b)
+ | Tglob (r, l) -> Tglob (r, List.map subst l)
+ | a -> a
+ in subst t
+
+(*s From a type schema to a type. All [Tvar] become fresh [Tmeta]. *)
+
+let instantiation (nb,t) = type_subst_vect (Array.init nb new_meta) t
+
+(*s Occur-check of a free meta in a type *)
+
+let rec type_occurs alpha t =
+ match t with
+ | Tmeta {id=beta; contents=None} -> alpha = beta
+ | Tmeta {contents=Some u} -> type_occurs alpha u
+ | Tarr (t1, t2) -> type_occurs alpha t1 || type_occurs alpha t2
+ | Tglob (r,l) -> List.exists (type_occurs alpha) l
+ | _ -> false
+
+(*s Most General Unificator *)
+
+let rec mgu = function
+ | Tmeta m, Tmeta m' when m.id = m'.id -> ()
+ | Tmeta m, t when m.contents=None ->
+ if type_occurs m.id t then raise Impossible
+ else m.contents <- Some t
+ | t, Tmeta m when m.contents=None ->
+ if type_occurs m.id t then raise Impossible
+ else m.contents <- Some t
+ | Tmeta {contents=Some u}, t -> mgu (u, t)
+ | t, Tmeta {contents=Some u} -> mgu (t, u)
+ | Tarr(a, b), Tarr(a', b') ->
+ mgu (a, a'); mgu (b, b')
+ | Tglob (r,l), Tglob (r',l') when r = r' ->
+ List.iter mgu (List.combine l l')
+ | Tvar i, Tvar j when i = j -> ()
+ | Tvar' i, Tvar' j when i = j -> ()
+ | Tdummy _, Tdummy _ -> ()
+ | Tunknown, Tunknown -> ()
+ | _ -> raise Impossible
+
+let needs_magic p = try mgu p; false with Impossible -> true
+
+let put_magic_if b a = if b && lang () <> Scheme then MLmagic a else a
+
+let put_magic p a = if needs_magic p && lang () <> Scheme then MLmagic a else a
+
+
+(*S ML type env. *)
+
+module Mlenv = struct
+
+ let meta_cmp m m' = compare m.id m'.id
+ module Metaset = Set.Make(struct type t = ml_meta let compare = meta_cmp end)
+
+ (* Main MLenv type. [env] is the real environment, whereas [free]
+ (tries to) record the free meta variables occurring in [env]. *)
+
+ type t = { env : ml_schema list; mutable free : Metaset.t}
+
+ (* Empty environment. *)
+
+ let empty = { env = []; free = Metaset.empty }
+
+ (* [get] returns a instantiated copy of the n-th most recently added
+ type in the environment. *)
+
+ let get mle n =
+ assert (List.length mle.env >= n);
+ instantiation (List.nth mle.env (n-1))
+
+ (* [find_free] finds the free meta in a type. *)
+
+ let rec find_free set = function
+ | Tmeta m when m.contents = None -> Metaset.add m set
+ | Tmeta {contents = Some t} -> find_free set t
+ | Tarr (a,b) -> find_free (find_free set a) b
+ | Tglob (_,l) -> List.fold_left find_free set l
+ | _ -> set
+
+ (* The [free] set of an environment can be outdate after
+ some unifications. [clean_free] takes care of that. *)
+
+ let clean_free mle =
+ let rem = ref Metaset.empty
+ and add = ref Metaset.empty in
+ let clean m = match m.contents with
+ | None -> ()
+ | Some u -> rem := Metaset.add m !rem; add := find_free !add u
+ in
+ Metaset.iter clean mle.free;
+ mle.free <- Metaset.union (Metaset.diff mle.free !rem) !add
+
+ (* From a type to a type schema. If a [Tmeta] is still uninstantiated
+ and does appears in the [mle], then it becomes a [Tvar]. *)
+
+ let generalization mle t =
+ let c = ref 0 in
+ let map = ref (Intmap.empty : int Intmap.t) in
+ let add_new i = incr c; map := Intmap.add i !c !map; !c in
+ let rec meta2var t = match t with
+ | Tmeta {contents=Some u} -> meta2var u
+ | Tmeta ({id=i} as m) ->
+ (try Tvar (Intmap.find i !map)
+ with Not_found ->
+ if Metaset.mem m mle.free then t
+ else Tvar (add_new i))
+ | Tarr (t1,t2) -> Tarr (meta2var t1, meta2var t2)
+ | Tglob (r,l) -> Tglob (r, List.map meta2var l)
+ | t -> t
+ in !c, meta2var t
+
+ (* Adding a type in an environment, after generalizing. *)
+
+ let push_gen mle t =
+ clean_free mle;
+ { env = generalization mle t :: mle.env; free = mle.free }
+
+ (* Adding a type with no [Tvar], hence no generalization needed. *)
+
+ let push_type {env=e;free=f} t =
+ { env = (0,t) :: e; free = find_free f t}
+
+ (* Adding a type with no [Tvar] nor [Tmeta]. *)
+
+ let push_std_type {env=e;free=f} t =
+ { env = (0,t) :: e; free = f}
+
+end
+
+(*S Operations upon ML types (without meta). *)
+
+(*s Does a section path occur in a ML type ? *)
+
+let rec type_mem_kn kn = function
+ | Tmeta {contents = Some t} -> type_mem_kn kn t
+ | Tglob (r,l) -> occur_kn_in_ref kn r || List.exists (type_mem_kn kn) l
+ | Tarr (a,b) -> (type_mem_kn kn a) || (type_mem_kn kn b)
+ | _ -> false
+
+(*s Greatest variable occurring in [t]. *)
+
+let type_maxvar t =
+ let rec parse n = function
+ | Tmeta {contents = Some t} -> parse n t
+ | Tvar i -> max i n
+ | Tarr (a,b) -> parse (parse n a) b
+ | Tglob (_,l) -> List.fold_left parse n l
+ | _ -> n
+ in parse 0 t
+
+(*s What are the type variables occurring in [t]. *)
+
+let intset_union_map_list f l =
+ List.fold_left (fun s t -> Intset.union s (f t)) Intset.empty l
+
+let intset_union_map_array f a =
+ Array.fold_left (fun s t -> Intset.union s (f t)) Intset.empty a
+
+let rec type_listvar = function
+ | Tmeta {contents = Some t} -> type_listvar t
+ | Tvar i | Tvar' i -> Intset.singleton i
+ | Tarr (a,b) -> Intset.union (type_listvar a) (type_listvar b)
+ | Tglob (_,l) -> intset_union_map_list type_listvar l
+ | _ -> Intset.empty
+
+(*s From [a -> b -> c] to [[a;b],c]. *)
+
+let rec type_decomp = function
+ | Tmeta {contents = Some t} -> type_decomp t
+ | Tarr (a,b) -> let l,h = type_decomp b in a::l, h
+ | a -> [],a
+
+(*s The converse: From [[a;b],c] to [a -> b -> c]. *)
+
+let rec type_recomp (l,t) = match l with
+ | [] -> t
+ | a::l -> Tarr (a, type_recomp (l,t))
+
+(*s Translating [Tvar] to [Tvar'] to avoid clash. *)
+
+let rec var2var' = function
+ | Tmeta {contents = Some t} -> var2var' t
+ | Tvar i -> Tvar' i
+ | Tarr (a,b) -> Tarr (var2var' a, var2var' b)
+ | Tglob (r,l) -> Tglob (r, List.map var2var' l)
+ | a -> a
+
+type abbrev_map = global_reference -> ml_type option
+
+(*s Delta-reduction of type constants everywhere in a ML type [t].
+ [env] is a function of type [ml_type_env]. *)
+
+let type_expand env t =
+ let rec expand = function
+ | Tmeta {contents = Some t} -> expand t
+ | Tglob (r,l) ->
+ (match env r with
+ | Some mlt -> expand (type_subst_list l mlt)
+ | None -> Tglob (r, List.map expand l))
+ | Tarr (a,b) -> Tarr (expand a, expand b)
+ | a -> a
+ in if Table.type_expand () then expand t else t
+
+(*s Generating a signature from a ML type. *)
+
+let type_to_sign env t = match type_expand env t with
+ | Tdummy d -> Kill d
+ | _ -> Keep
+
+let type_to_signature env t =
+ let rec f = function
+ | Tmeta {contents = Some t} -> f t
+ | Tarr (Tdummy d, b) -> Kill d :: f b
+ | Tarr (_, b) -> Keep :: f b
+ | _ -> []
+ in f (type_expand env t)
+
+let isKill = function Kill _ -> true | _ -> false
+
+let isDummy = function Tdummy _ -> true | _ -> false
+
+let sign_of_id = function
+ | Dummy -> Kill Kother
+ | _ -> Keep
+
+(* Classification of signatures *)
+
+type sign_kind =
+ | EmptySig
+ | NonLogicalSig (* at least a [Keep] *)
+ | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *)
+ | SafeLogicalSig (* only [Kill Ktype] *)
+
+let rec sign_kind = function
+ | [] -> EmptySig
+ | Keep :: _ -> NonLogicalSig
+ | Kill k :: s ->
+ match sign_kind s with
+ | NonLogicalSig -> NonLogicalSig
+ | UnsafeLogicalSig -> UnsafeLogicalSig
+ | SafeLogicalSig | EmptySig ->
+ if k = Kother then UnsafeLogicalSig else SafeLogicalSig
+
+(* Removing the final [Keep] in a signature *)
+
+let rec sign_no_final_keeps = function
+ | [] -> []
+ | k :: s ->
+ let s' = k :: sign_no_final_keeps s in
+ if s' = [Keep] then [] else s'
+
+(*s Removing [Tdummy] from the top level of a ML type. *)
+
+let type_expunge_from_sign env s t =
+ let rec expunge s t =
+ if s = [] then t else match t with
+ | Tmeta {contents = Some t} -> expunge s t
+ | Tarr (a,b) ->
+ let t = expunge (List.tl s) b in
+ if List.hd s = Keep then Tarr (a, t) else t
+ | Tglob (r,l) ->
+ (match env r with
+ | Some mlt -> expunge s (type_subst_list l mlt)
+ | None -> assert false)
+ | _ -> assert false
+ in
+ let t = expunge (sign_no_final_keeps s) t in
+ if lang () <> Haskell && sign_kind s = UnsafeLogicalSig then
+ Tarr (Tdummy Kother, t)
+ else t
+
+let type_expunge env t =
+ type_expunge_from_sign env (type_to_signature env t) t
+
+(*S Generic functions over ML ast terms. *)
+
+let mlapp f a = if a = [] then f else MLapp (f,a)
+
+(*s [ast_iter_rel f t] applies [f] on every [MLrel] in t. It takes care
+ of the number of bingings crossed before reaching the [MLrel]. *)
+
+let ast_iter_rel f =
+ let rec iter n = function
+ | MLrel i -> f (i-n)
+ | MLlam (_,a) -> iter (n+1) a
+ | MLletin (_,a,b) -> iter n a; iter (n+1) b
+ | MLcase (_,a,v) ->
+ iter n a; Array.iter (fun (_,l,t) -> iter (n + (List.length l)) t) v
+ | MLfix (_,ids,v) -> let k = Array.length ids in Array.iter (iter (n+k)) v
+ | MLapp (a,l) -> iter n a; List.iter (iter n) l
+ | MLcons (_,_,l) -> List.iter (iter n) l
+ | MLmagic a -> iter n a
+ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> ()
+ in iter 0
+
+(*s Map over asts. *)
+
+let ast_map_case f (c,ids,a) = (c,ids,f a)
+
+let ast_map f = function
+ | MLlam (i,a) -> MLlam (i, f a)
+ | MLletin (i,a,b) -> MLletin (i, f a, f b)
+ | MLcase (i,a,v) -> MLcase (i,f a, Array.map (ast_map_case f) v)
+ | MLfix (i,ids,v) -> MLfix (i, ids, Array.map f v)
+ | MLapp (a,l) -> MLapp (f a, List.map f l)
+ | MLcons (i,c,l) -> MLcons (i,c, List.map f l)
+ | MLmagic a -> MLmagic (f a)
+ | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
+
+(*s Map over asts, with binding depth as parameter. *)
+
+let ast_map_lift_case f n (c,ids,a) = (c,ids, f (n+(List.length ids)) a)
+
+let ast_map_lift f n = function
+ | MLlam (i,a) -> MLlam (i, f (n+1) a)
+ | MLletin (i,a,b) -> MLletin (i, f n a, f (n+1) b)
+ | MLcase (i,a,v) -> MLcase (i,f n a,Array.map (ast_map_lift_case f n) v)
+ | MLfix (i,ids,v) ->
+ let k = Array.length ids in MLfix (i,ids,Array.map (f (k+n)) v)
+ | MLapp (a,l) -> MLapp (f n a, List.map (f n) l)
+ | MLcons (i,c,l) -> MLcons (i,c, List.map (f n) l)
+ | MLmagic a -> MLmagic (f n a)
+ | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom as a -> a
+
+(*s Iter over asts. *)
+
+let ast_iter_case f (c,ids,a) = f a
+
+let ast_iter f = function
+ | MLlam (i,a) -> f a
+ | MLletin (i,a,b) -> f a; f b
+ | MLcase (_,a,v) -> f a; Array.iter (ast_iter_case f) v
+ | MLfix (i,ids,v) -> Array.iter f v
+ | MLapp (a,l) -> f a; List.iter f l
+ | MLcons (_,c,l) -> List.iter f l
+ | MLmagic a -> f a
+ | MLrel _ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> ()
+
+(*S Operations concerning De Bruijn indices. *)
+
+(*s [ast_occurs k t] returns [true] if [(Rel k)] occurs in [t]. *)
+
+let ast_occurs k t =
+ try
+ ast_iter_rel (fun i -> if i = k then raise Found) t; false
+ with Found -> true
+
+(*s [occurs_itvl k k' t] returns [true] if there is a [(Rel i)]
+ in [t] with [k<=i<=k'] *)
+
+let ast_occurs_itvl k k' t =
+ try
+ ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false
+ with Found -> true
+
+(*s Number of occurences of [Rel k] (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. *)
+
+let nb_occur_match =
+ let rec nb k = function
+ | MLrel i -> if i = k then 1 else 0
+ | MLcase(_,a,v) ->
+ (nb k a) +
+ Array.fold_left
+ (fun r (_,ids,a) -> max r (nb (k+(List.length ids)) a)) 0 v
+ | MLletin (_,a,b) -> (nb k a) + (nb (k+1) b)
+ | MLfix (_,ids,v) -> let k = k+(Array.length ids) in
+ Array.fold_left (fun r a -> r+(nb k a)) 0 v
+ | MLlam (_,a) -> nb (k+1) a
+ | MLapp (a,l) -> List.fold_left (fun r a -> r+(nb k a)) (nb k a) l
+ | MLcons (_,_,l) -> List.fold_left (fun r a -> r+(nb k a)) 0 l
+ | MLmagic a -> nb k a
+ | MLglob _ | MLexn _ | MLdummy | MLaxiom -> 0
+ in nb 1
+
+(*s Lifting on terms.
+ [ast_lift k t] lifts the binding depth of [t] across [k] bindings. *)
+
+let ast_lift k t =
+ let rec liftrec n = function
+ | MLrel i as a -> if i-n < 1 then a else MLrel (i+k)
+ | a -> ast_map_lift liftrec n a
+ in if k = 0 then t else liftrec 0 t
+
+let ast_pop t = ast_lift (-1) t
+
+(*s [permut_rels k k' c] translates [Rel 1 ... Rel k] to [Rel (k'+1) ...
+ Rel (k'+k)] and [Rel (k+1) ... Rel (k+k')] to [Rel 1 ... Rel k'] *)
+
+let permut_rels k k' =
+ let rec permut n = function
+ | MLrel i as a ->
+ let i' = i-n in
+ if i'<1 || i'>k+k' then a
+ else if i'<=k then MLrel (i+k')
+ else MLrel (i-k)
+ | a -> ast_map_lift permut n a
+ in permut 0
+
+(*s Substitution. [ml_subst e t] substitutes [e] for [Rel 1] in [t].
+ Lifting (of one binder) is done at the same time. *)
+
+let ast_subst e =
+ let rec subst n = function
+ | MLrel i as a ->
+ let i' = i-n in
+ if i'=1 then ast_lift n e
+ else if i'<1 then a
+ else MLrel (i-1)
+ | a -> ast_map_lift subst n a
+ in subst 0
+
+(*s Generalized substitution.
+ [gen_subst v d t] applies to [t] the substitution coded in the
+ [v] array: [(Rel i)] becomes [v.(i-1)]. [d] is the correction applies
+ to [Rel] greater than [Array.length v]. *)
+
+let gen_subst v d t =
+ let rec subst n = function
+ | MLrel i as a ->
+ let i'= i-n in
+ if i' < 1 then a
+ else if i' <= Array.length v then
+ match v.(i'-1) with
+ | None -> MLexn ("UNBOUND " ^ string_of_int i')
+ | Some u -> ast_lift n u
+ else MLrel (i+d)
+ | a -> ast_map_lift subst n a
+ in subst 0 t
+
+(*S Operations concerning lambdas. *)
+
+(*s [collect_lams MLlam(id1,...MLlam(idn,t)...)] returns
+ [[idn;...;id1]] and the term [t]. *)
+
+let collect_lams =
+ let rec collect acc = function
+ | MLlam(id,t) -> collect (id::acc) t
+ | x -> acc,x
+ in collect []
+
+(*s [collect_n_lams] does the same for a precise number of [MLlam]. *)
+
+let collect_n_lams =
+ let rec collect acc n t =
+ if n = 0 then acc,t
+ else match t with
+ | MLlam(id,t) -> collect (id::acc) (n-1) t
+ | _ -> assert false
+ in collect []
+
+(*s [remove_n_lams] just removes some [MLlam]. *)
+
+let rec remove_n_lams n t =
+ if n = 0 then t
+ else match t with
+ | MLlam(_,t) -> remove_n_lams (n-1) t
+ | _ -> assert false
+
+(*s [nb_lams] gives the number of head [MLlam]. *)
+
+let rec nb_lams = function
+ | MLlam(_,t) -> succ (nb_lams t)
+ | _ -> 0
+
+(*s [named_lams] does the converse of [collect_lams]. *)
+
+let rec named_lams ids a = match ids with
+ | [] -> a
+ | id :: ids -> named_lams ids (MLlam (id,a))
+
+(*s The same for a specific identifier (resp. anonymous, dummy) *)
+
+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
+
+(*s mixed according to a signature. *)
+
+let rec anonym_or_dummy_lams a = function
+ | [] -> a
+ | Keep :: s -> MLlam(anonymous, anonym_or_dummy_lams a s)
+ | Kill _ :: s -> MLlam(Dummy, anonym_or_dummy_lams a s)
+
+(*S Operations concerning eta. *)
+
+(*s The following function creates [MLrel n;...;MLrel 1] *)
+
+let rec eta_args n =
+ if n = 0 then [] else (MLrel n)::(eta_args (pred n))
+
+(*s Same, but filtered by a signature. *)
+
+let rec eta_args_sign n = function
+ | [] -> []
+ | Keep :: s -> (MLrel n) :: (eta_args_sign (n-1) s)
+ | Kill _ :: s -> eta_args_sign (n-1) s
+
+(*s This one tests [MLrel (n+k); ... ;MLrel (1+k)] *)
+
+let rec test_eta_args_lift k n = function
+ | [] -> n=0
+ | a :: q -> (a = (MLrel (k+n))) && (test_eta_args_lift k (pred n) q)
+
+(*s Computes an eta-reduction. *)
+
+let eta_red e =
+ let ids,t = collect_lams e in
+ let n = List.length ids in
+ if n = 0 then e
+ else match t with
+ | MLapp (f,a) ->
+ let m = List.length a in
+ let ids,body,args =
+ if m = n then
+ [], f, a
+ else if m < n then
+ list_skipn m ids, f, a
+ else (* m > n *)
+ let a1,a2 = list_chop (m-n) a in
+ [], MLapp (f,a1), a2
+ in
+ let p = List.length args in
+ if test_eta_args_lift 0 p args && not (ast_occurs_itvl 1 p body)
+ then named_lams ids (ast_lift (-p) body)
+ else e
+ | _ -> e
+
+(*s Computes all head linear beta-reductions possible in [(t a)].
+ Non-linear head beta-redex become let-in. *)
+
+let rec linear_beta_red a t = match a,t with
+ | [], _ -> t
+ | a0::a, MLlam (id,t) ->
+ (match nb_occur_match t with
+ | 0 -> linear_beta_red a (ast_pop t)
+ | 1 -> linear_beta_red a (ast_subst a0 t)
+ | _ ->
+ let a = List.map (ast_lift 1) a in
+ MLletin (id, a0, linear_beta_red a t))
+ | _ -> MLapp (t, a)
+
+let rec tmp_head_lams = function
+ | MLlam (id, t) -> MLlam (tmp_id id, tmp_head_lams t)
+ | e -> e
+
+(*s Applies a substitution [s] of constants by their body, plus
+ linear beta reductions at modified positions.
+ Moreover, we mark some lambdas as suitable for later linear
+ reduction (this helps the inlining of recursors).
+*)
+
+let rec ast_glob_subst s t = match t with
+ | MLapp ((MLglob ((ConstRef kn) as refe)) as f, a) ->
+ let a = List.map (fun e -> tmp_head_lams (ast_glob_subst s e)) a in
+ (try linear_beta_red a (Refmap.find refe s)
+ with Not_found -> MLapp (f, a))
+ | MLglob ((ConstRef kn) as refe) ->
+ (try Refmap.find refe s with Not_found -> t)
+ | _ -> ast_map (ast_glob_subst s) t
+
+
+(*S Auxiliary functions used in simplification of ML cases. *)
+
+(*s [check_function_branch (r,l,c)] checks if branch [c] can be seen
+ 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 check_function_branch (r,l,c) =
+ let nargs = List.length l in
+ let rec genrec n = function
+ | MLrel i as c ->
+ let i' = i-n in
+ if i'<1 then c
+ else if i'>nargs then MLrel (i-nargs+1)
+ else raise Impossible
+ | MLcons(_,r',args) when r=r' && (test_eta_args_lift n nargs args) ->
+ MLrel (n+1)
+ | a -> ast_map_lift genrec n a
+ in genrec 0 c
+
+(*s [check_constant_branch (r,l,c)] checks if branch [c] is 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 the
+ branch-as-function optimization) *)
+
+let check_constant_branch (_,l,c) =
+ let n = List.length l in
+ if ast_occurs_itvl 1 n c then raise Impossible;
+ ast_lift (1-n) c
+
+(* The following structure allows to record which element occurred
+ at what position, and then finally return the most frequent
+ element and its positions. *)
+
+let census_add, census_max, census_clean =
+ let h = Hashtbl.create 13 in
+ let clear () = Hashtbl.clear h in
+ let add e i =
+ let l = try Hashtbl.find h e with Not_found -> [] in
+ Hashtbl.replace h e (i::l)
+ in
+ let max e0 =
+ let len = ref 0 and lst = ref [] and elm = ref e0 in
+ Hashtbl.iter
+ (fun e l ->
+ let n = List.length l in
+ if n > !len then begin len := n; lst := l; elm := e end)
+ h;
+ (!elm,!lst)
+ in
+ (add,max,clear)
+
+(* Given an abstraction function [abstr] (one of [check_*_branch]),
+ return the longest possible list of branches that have the
+ same abstraction, along with this abstraction. *)
+
+let factor_branches abstr br =
+ census_clean ();
+ for i = 0 to Array.length br - 1 do
+ try census_add (abstr br.(i)) i with Impossible -> ()
+ done;
+ let br_factor, br_list = census_max MLdummy in
+ if br_list = [] then None
+ else if Array.length br >= 2 && List.length br_list < 2 then None
+ else Some (br_factor, br_list)
+
+(*s [check_generalizable_case] checks if all branches can be seen as the
+ same function [f] applied to the term matched. It is a generalized version
+ of both the identity case optimization and the constant case optimisation
+ ([f] can be a constant function) *)
+
+(* The optimisation [factor_branches check_function_branch] breaks types
+ in some special case. Example: [type 'x a = A].
+ Then [let f = function A -> A] has type ['x a -> 'y a],
+ which is incompatible with the type of [let f x = x].
+ We check first that there isn't such phantom variable in the inductive type
+ we're considering. *)
+
+let check_optim_id br =
+ let (kn,i) =
+ match br.(0) with (ConstructRef (c,_),_,_) -> c | _ -> assert false
+ in
+ let ip = (snd (lookup_ind kn)).ind_packets.(i) in
+ match ip.ip_optim_id_ok with
+ | Some ok -> ok
+ | None ->
+ let tvars =
+ intset_union_map_array (intset_union_map_list type_listvar)
+ ip.ip_types
+ in
+ let ok = (Intset.cardinal tvars = List.length ip.ip_vars) in
+ ip.ip_optim_id_ok <- Some ok;
+ ok
+
+(*s If all branches are functions, try to permut the case and the functions. *)
+
+let rec merge_ids ids ids' = match ids,ids' with
+ | [],l -> l
+ | l,[] -> l
+ | i::ids, i'::ids' ->
+ (if i = Dummy then i' else i) :: (merge_ids ids ids')
+
+let is_exn = function MLexn _ -> true | _ -> false
+
+let rec permut_case_fun br acc =
+ let nb = ref max_int in
+ Array.iter (fun (_,_,t) ->
+ let ids, c = collect_lams t in
+ let n = List.length ids in
+ if (n < !nb) && (not (is_exn c)) then nb := n) br;
+ if !nb = max_int || !nb = 0 then ([],br)
+ else begin
+ let br = Array.copy br in
+ let ids = ref [] in
+ for i = 0 to Array.length br - 1 do
+ let (r,l,t) = br.(i) in
+ let local_nb = nb_lams t in
+ if local_nb < !nb then (* t = MLexn ... *)
+ br.(i) <- (r,l,remove_n_lams local_nb t)
+ else begin
+ let local_ids,t = collect_n_lams !nb t in
+ ids := merge_ids !ids local_ids;
+ br.(i) <- (r,l,permut_rels !nb (List.length l) t)
+ end
+ done;
+ (!ids,br)
+ end
+
+(*S Generalized iota-reduction. *)
+
+(* Definition of a generalized iota-redex: it's a [MLcase(e,_)]
+ with [(is_iota_gen e)=true]. Any generalized iota-redex is
+ transformed into beta-redexes. *)
+
+let rec is_iota_gen = function
+ | MLcons _ -> true
+ | MLcase(_,_,br)-> array_for_all (fun (_,_,t)->is_iota_gen t) br
+ | _ -> false
+
+let constructor_index = function
+ | ConstructRef (_,j) -> pred j
+ | _ -> assert false
+
+let iota_gen br =
+ let rec iota k = function
+ | MLcons (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') ->
+ 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
+
+let is_atomic = function
+ | MLrel _ | MLglob _ | MLexn _ | MLdummy -> true
+ | _ -> false
+
+let is_imm_apply = function MLapp (MLrel 1, _) -> true | _ -> false
+
+(*S The main simplification function. *)
+
+(* Some beta-iota reductions + simplifications. *)
+
+let rec simpl o = function
+ | MLapp (f, []) -> simpl o f
+ | MLapp (f, a) -> simpl_app o (List.map (simpl o) a) (simpl o f)
+ | MLcase (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)
+ | MLletin(Dummy,_,e) -> simpl o (ast_pop e)
+ | MLletin(id,c,e) ->
+ let e = simpl o e in
+ if
+ (is_atomic c) || (is_atomic e) ||
+ (let n = nb_occur_match e in
+ (n = 0 || (n=1 && (is_tmp id || is_imm_apply e || o.opt_lin_let))))
+ then
+ simpl o (ast_subst c e)
+ else
+ MLletin(id, simpl o c, e)
+ | MLfix(i,ids,c) ->
+ let n = Array.length ids in
+ if ast_occurs_itvl 1 n c.(i) then
+ MLfix (i, ids, Array.map (simpl o) c)
+ else simpl o (ast_lift (-n) c.(i)) (* Dummy fixpoint *)
+ | a -> ast_map (simpl o) a
+
+(* invariant : list [a] of arguments is non-empty *)
+
+and simpl_app o a = function
+ | MLapp (f',a') -> simpl_app o (a'@a) f'
+ | MLlam (Dummy,t) ->
+ simpl o (MLapp (ast_pop t, List.tl a))
+ | MLlam (id,t) -> (* Beta redex *)
+ (match nb_occur_match t with
+ | 0 -> simpl o (MLapp (ast_pop t, List.tl a))
+ | 1 when (is_tmp id || o.opt_lin_beta) ->
+ simpl o (MLapp (ast_subst (List.hd a) t, List.tl a))
+ | _ ->
+ let a' = List.map (ast_lift 1) (List.tl a) in
+ simpl o (MLletin (id, List.hd a, MLapp (t, a'))))
+ | MLletin (id,e1,e2) when o.opt_let_app ->
+ (* Application of a letin: we push arguments inside *)
+ MLletin (id, e1, simpl o (MLapp (e2, List.map (ast_lift 1) a)))
+ | MLcase (i,e,br) when o.opt_case_app ->
+ (* Application of a case: we push arguments inside *)
+ let br' =
+ Array.map
+ (fun (n,l,t) ->
+ let k = List.length l in
+ let a' = List.map (ast_lift k) a in
+ (n, l, simpl o (MLapp (t,a')))) br
+ in simpl o (MLcase (i,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 *)
+ simpl o (iota_gen br e)
+ else
+ (* 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)))
+ else
+ (* Does a term [f] exist such that many branches are [(f e)] ? *)
+ let opt1 =
+ if o.opt_case_idr && (o.opt_case_idg || check_optim_id br) then
+ factor_branches check_function_branch br
+ else None
+ in
+ (* Detect common constant branches. Often a particular case of
+ branch-as-function optim, but not always (e.g. A->A|B->A) *)
+ let opt2 =
+ if opt1 = None && o.opt_case_cst then
+ factor_branches check_constant_branch br
+ else opt1
+ in
+ match opt2 with
+ | Some (f,ints) when List.length ints = Array.length br ->
+ (* if all branches have been factorized, we remove the match *)
+ simpl o (MLletin (Tmp anonymous_name, e, f))
+ | Some (f,ints) ->
+ let ci = if ast_occurs 1 f then BranchFun ints else BranchCst ints
+ in MLcase ((fst i,ci), e, br)
+ | None -> MLcase (i, e, br)
+
+(*S Local prop elimination. *)
+(* We try to eliminate as many [prop] as possible inside an [ml_ast]. *)
+
+(*s In a list, it selects only the elements corresponding to a [Keep]
+ in the boolean list [l]. *)
+
+let rec select_via_bl l args = match l,args with
+ | [],_ -> args
+ | Keep::l,a::args -> a :: (select_via_bl l args)
+ | Kill _::l,a::args -> select_via_bl l args
+ | _ -> assert false
+
+(*s [kill_some_lams] removes some head lambdas according to the signature [bl].
+ This list is build on the identifier list model: outermost lambda
+ is on the right.
+ [Rels] corresponding to removed lambdas are supposed not to occur, and
+ the other [Rels] are made correct via a [gen_subst].
+ Output is not directly a [ml_ast], compose with [named_lams] if needed. *)
+
+let kill_some_lams bl (ids,c) =
+ let n = List.length bl in
+ let n' = List.fold_left (fun n b -> if b=Keep then (n+1) else n) 0 bl in
+ if n = n' then ids,c
+ else if n' = 0 then [],ast_lift (-n) c
+ else begin
+ let v = Array.make n None in
+ let rec parse_ids i j = function
+ | [] -> ()
+ | Keep :: l -> v.(i) <- Some (MLrel j); parse_ids (i+1) (j+1) l
+ | Kill _ :: l -> parse_ids (i+1) j l
+ in parse_ids 0 1 bl;
+ select_via_bl bl ids, gen_subst v (n'-n) c
+ end
+
+(*s [kill_dummy_lams] uses the last function to kill the lambdas corresponding
+ to a [dummy_name]. It can raise [Impossible] if there is nothing to do, or
+ if there is no lambda left at all. *)
+
+let kill_dummy_lams c =
+ let ids,c = collect_lams c in
+ let bl = List.map sign_of_id ids in
+ if (List.mem Keep bl) && (List.exists isKill bl) then
+ let ids',c = kill_some_lams bl (ids,c) in
+ ids, named_lams ids' c
+ else raise Impossible
+
+(*s [eta_expansion_sign] takes a function [fun idn ... id1 -> c]
+ and a signature [s] and builds a eta-long version. *)
+
+(* For example, if [s = [Keep;Keep;Kill Prop;Keep]] then the output is :
+ [fun idn ... id1 x x _ x -> (c' 4 3 __ 1)] with [c' = lift 4 c] *)
+
+let eta_expansion_sign s (ids,c) =
+ let rec abs ids rels i = function
+ | [] ->
+ let a = List.rev_map (function MLrel x -> MLrel (i-x) | a -> a) rels
+ in ids, MLapp (ast_lift (i-1) c, a)
+ | Keep :: l -> abs (anonymous :: ids) (MLrel i :: rels) (i+1) l
+ | Kill _ :: l -> abs (Dummy :: ids) (MLdummy :: rels) (i+1) l
+ in abs ids [] 1 s
+
+(*s If [s = [b1; ... ; bn]] then [case_expunge] decomposes [e]
+ in [n] lambdas (with eta-expansion if needed) and removes all dummy lambdas
+ corresponding to [Del] in [s]. *)
+
+let case_expunge s e =
+ let m = List.length s in
+ let n = nb_lams e in
+ let p = if m <= n then collect_n_lams m e
+ else eta_expansion_sign (list_skipn n s) (collect_lams e) in
+ kill_some_lams (List.rev s) p
+
+(*s [term_expunge] takes a function [fun idn ... id1 -> c]
+ and a signature [s] and remove dummy lams. The difference
+ with [case_expunge] is that we here leave one dummy lambda
+ if all lambdas are logical dummy and the target language is strict. *)
+
+let term_expunge s (ids,c) =
+ if s = [] then c
+ else
+ let ids,c = kill_some_lams (List.rev s) (ids,c) in
+ if ids = [] && lang () <> Haskell && List.mem (Kill Kother) s then
+ MLlam (Dummy, ast_lift 1 c)
+ else named_lams ids c
+
+(*s [kill_dummy_args ids t0 t] looks for occurences of [t0] in [t] and
+ purge the args of [t0] corresponding to a [dummy_name].
+ It makes eta-expansion if needed. *)
+
+let kill_dummy_args ids t0 t =
+ let m = List.length ids in
+ let bl = List.rev_map sign_of_id ids in
+ let rec killrec n = function
+ | MLapp(e, a) when e = ast_lift n t0 ->
+ let k = max 0 (m - (List.length a)) in
+ let a = List.map (killrec n) a in
+ let a = List.map (ast_lift k) a in
+ let a = select_via_bl bl (a @ (eta_args k)) in
+ named_lams (list_firstn k ids) (MLapp (ast_lift k e, a))
+ | e when e = ast_lift n t0 ->
+ let a = select_via_bl bl (eta_args m) in
+ named_lams ids (MLapp (ast_lift m e, a))
+ | e -> ast_map_lift killrec n e
+ in killrec 0 t
+
+(*s The main function for local [dummy] elimination. *)
+
+let rec kill_dummy = function
+ | MLfix(i,fi,c) ->
+ (try
+ let ids,c = kill_dummy_fix i c in
+ ast_subst (MLfix (i,fi,c)) (kill_dummy_args ids (MLrel 1) (MLrel 1))
+ with Impossible -> MLfix (i,fi,Array.map kill_dummy c))
+ | MLapp (MLfix (i,fi,c),a) ->
+ let a = List.map kill_dummy a in
+ (try
+ let ids,c = kill_dummy_fix i c in
+ let fake = MLapp (MLrel 1, List.map (ast_lift 1) a) in
+ let fake' = kill_dummy_args ids (MLrel 1) fake in
+ ast_subst (MLfix (i,fi,c)) fake'
+ with Impossible -> MLapp(MLfix(i,fi,Array.map kill_dummy c),a))
+ | MLletin(id, MLfix (i,fi,c),e) ->
+ (try
+ let ids,c = kill_dummy_fix i c in
+ let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in
+ MLletin(id, MLfix(i,fi,c),e)
+ with Impossible ->
+ MLletin(id, MLfix(i,fi,Array.map kill_dummy c),kill_dummy e))
+ | MLletin(id,c,e) ->
+ (try
+ let ids,c = kill_dummy_lams (kill_dummy_hd c) in
+ let e = kill_dummy (kill_dummy_args ids (MLrel 1) e) in
+ let c = eta_red (kill_dummy c) in
+ if is_atomic c then ast_subst c e else MLletin (id, c, e)
+ with Impossible -> MLletin(id,kill_dummy c,kill_dummy e))
+ | a -> ast_map kill_dummy a
+
+(* Similar function, but acting only on head lambdas and let-ins *)
+
+and kill_dummy_hd = function
+ | MLlam(id,e) -> MLlam(id, kill_dummy_hd e)
+ | MLletin(id,c,e) ->
+ (try
+ let ids,c = kill_dummy_lams (kill_dummy_hd c) in
+ let e = kill_dummy_hd (kill_dummy_args ids (MLrel 1) e) in
+ let c = eta_red (kill_dummy c) in
+ if is_atomic c then ast_subst c e else MLletin (id, c, e)
+ with Impossible -> MLletin(id,kill_dummy c,kill_dummy_hd e))
+ | a -> a
+
+and kill_dummy_fix i c =
+ let n = Array.length c in
+ let ids,ci = kill_dummy_lams (kill_dummy_hd c.(i)) in
+ let c = Array.copy c in c.(i) <- ci;
+ for j = 0 to (n-1) do
+ c.(j) <- kill_dummy (kill_dummy_args ids (MLrel (n-i)) c.(j))
+ done;
+ ids,c
+
+(*s Putting things together. *)
+
+let normalize a =
+ let o = optims () in
+ let rec norm a =
+ let a' = if o.opt_kill_dum then kill_dummy (simpl o a) else simpl o a in
+ if a = a' then a else norm a'
+ in norm a
+
+(*S Special treatment of fixpoint for pretty-printing purpose. *)
+
+let general_optimize_fix f ids n args m c =
+ let v = Array.make n 0 in
+ for i=0 to (n-1) do v.(i)<-i done;
+ let aux i = function
+ | MLrel j when v.(j-1)>=0 ->
+ if ast_occurs (j+1) c then raise Impossible else v.(j-1)<-(-i-1)
+ | _ -> raise Impossible
+ in list_iter_i aux args;
+ let args_f = List.rev_map (fun i -> MLrel (i+m+1)) (Array.to_list v) in
+ let new_f = anonym_tmp_lams (MLapp (MLrel (n+m+1),args_f)) m in
+ let new_c = named_lams ids (normalize (MLapp ((ast_subst new_f c),args))) in
+ MLfix(0,[|f|],[|new_c|])
+
+let optimize_fix a =
+ if not (optims()).opt_fix_fun then a
+ else
+ let ids,a' = collect_lams a in
+ let n = List.length ids in
+ if n = 0 then a
+ else match a' with
+ | MLfix(_,[|f|],[|c|]) ->
+ let new_f = MLapp (MLrel (n+1),eta_args n) in
+ let new_c = named_lams ids (normalize (ast_subst new_f c))
+ in MLfix(0,[|f|],[|new_c|])
+ | MLapp(a',args) ->
+ let m = List.length args in
+ (match a' with
+ | MLfix(_,_,_) when
+ (test_eta_args_lift 0 n args) && not (ast_occurs_itvl 1 m a')
+ -> a'
+ | MLfix(_,[|f|],[|c|]) ->
+ (try general_optimize_fix f ids n args m c
+ with Impossible -> a)
+ | _ -> a)
+ | _ -> a
+
+(*S Inlining. *)
+
+(* Utility functions used in the decision of inlining. *)
+
+let rec ml_size = function
+ | MLapp(t,l) -> List.length l + ml_size t + ml_size_list l
+ | MLlam(_,t) -> 1 + ml_size t
+ | MLcons(_,_,l) -> ml_size_list l
+ | MLcase(_,t,pv) ->
+ 1 + ml_size t + (Array.fold_right (fun (_,_,t) a -> a + ml_size t) pv 0)
+ | MLfix(_,_,f) -> ml_size_array f
+ | MLletin (_,_,t) -> ml_size t
+ | MLmagic t -> ml_size t
+ | _ -> 0
+
+and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l
+
+and ml_size_array l = Array.fold_left (fun a t -> a + ml_size t) 0 l
+
+let is_fix = function MLfix _ -> true | _ -> false
+
+let rec is_constr = function
+ | MLcons _ -> true
+ | MLlam(_,t) -> is_constr t
+ | _ -> false
+
+(*s Strictness *)
+
+(* A variable is strict if the evaluation of the whole term implies
+ the evaluation of this variable. Non-strict variables can be found
+ behind Match, for example. Expanding a term [t] is a good idea when
+ it begins by at least one non-strict lambda, since the corresponding
+ argument to [t] might be unevaluated in the expanded code. *)
+
+exception Toplevel
+
+let lift n l = List.map ((+) n) l
+
+let pop n l = List.map (fun x -> if x<=n then raise Toplevel else x-n) l
+
+(* This function returns a list of de Bruijn indices of non-strict variables,
+ or raises [Toplevel] if it has an internal non-strict variable.
+ In fact, not all variables are checked for strictness, only the ones which
+ de Bruijn index is in the candidates list [cand]. The flag [add] controls
+ the behaviour when going through a lambda: should we add the corresponding
+ variable to the candidates? We use this flag to check only the external
+ lambdas, those that will correspond to arguments. *)
+
+let rec non_stricts add cand = function
+ | MLlam (id,t) ->
+ let cand = lift 1 cand in
+ let cand = if add then 1::cand else cand in
+ pop 1 (non_stricts add cand t)
+ | MLrel n ->
+ List.filter ((<>) n) cand
+ | MLapp (t,l)->
+ let cand = non_stricts false cand t in
+ List.fold_left (non_stricts false) cand l
+ | MLcons (_,_,l) ->
+ List.fold_left (non_stricts false) cand l
+ | MLletin (_,t1,t2) ->
+ let cand = non_stricts false cand t1 in
+ pop 1 (non_stricts add (lift 1 cand) t2)
+ | MLfix (_,i,f)->
+ let n = Array.length i in
+ let cand = lift n cand in
+ let cand = Array.fold_left (non_stricts false) cand f in
+ pop n cand
+ | MLcase (_,t,v) ->
+ (* The only interesting case: for a variable to be non-strict, *)
+ (* it is sufficient that it appears non-strict in at least one branch, *)
+ (* so we make an union (in fact a merge). *)
+ let cand = non_stricts false cand t in
+ Array.fold_left
+ (fun c (_,i,t)->
+ let n = List.length i in
+ let cand = lift n cand in
+ let cand = pop n (non_stricts add cand t) in
+ Sort.merge (<=) cand c) [] v
+ (* [merge] may duplicates some indices, but I don't mind. *)
+ | MLmagic t ->
+ non_stricts add cand t
+ | _ ->
+ cand
+
+(* The real test: we are looking for internal non-strict variables, so we start
+ with no candidates, and the only positive answer is via the [Toplevel]
+ exception. *)
+
+let is_not_strict t =
+ try let _ = non_stricts true [] t in false
+ with Toplevel -> true
+
+(*s Inlining decision *)
+
+(* [inline_test] answers the following question:
+ If we could inline [t] (the user said nothing special),
+ should we inline ?
+
+ We expand small terms with at least one non-strict
+ variable (i.e. a variable that may not be evaluated).
+
+ Futhermore we don't expand fixpoints.
+
+ Moreover, as mentionned by X. Leroy (bug #2241),
+ inling a constant from inside an opaque module might
+ break types. To avoid that, we require below that
+ both [r] and its body are globally visible. This isn't
+ fully satisfactory, since [r] might not be visible (functor),
+ and anyway it might be interesting to inline [r] at least
+ inside its own structure. But to be safe, we adopt this
+ restriction for the moment.
+*)
+
+open Declarations
+
+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 con_of_string s =
+ let null = empty_dirpath in
+ match repr_dirpath (dirpath_of_string s) with
+ | id :: d -> make_con (MPfile (make_dirpath d)) null (label_of_id id)
+ | [] -> assert false
+
+let manual_inline_set =
+ List.fold_right (fun x -> Cset.add (con_of_string x))
+ [ "Coq.Init.Wf.well_founded_induction_type";
+ "Coq.Init.Wf.well_founded_induction";
+ "Coq.Init.Wf.Acc_iter";
+ "Coq.Init.Wf.Fix_F";
+ "Coq.Init.Wf.Fix";
+ "Coq.Init.Datatypes.andb";
+ "Coq.Init.Datatypes.orb";
+ "Coq.Init.Logic.eq_rec_r";
+ "Coq.Init.Logic.eq_rect_r";
+ "Coq.Init.Specif.proj1_sig";
+ ]
+ Cset.empty
+
+let manual_inline = function
+ | ConstRef c -> Cset.mem c manual_inline_set
+ | _ -> false
+
+(* If the user doesn't say he wants to keep [t], we inline in two cases:
+ \begin{itemize}
+ \item the user explicitly requests it
+ \item [expansion_test] answers that the inlining is a good idea, and
+ we are free to act (AutoInline is set)
+ \end{itemize} *)
+
+let inline r t =
+ not (to_keep r) (* The user DOES want to keep it *)
+ && not (is_inline_custom r)
+ && (to_inline r (* The user DOES want to inline it *)
+ || (lang () <> Haskell && not (is_projection r) &&
+ (is_recursor r || manual_inline r || inline_test r t)))
+
diff --git a/plugins/extraction/mlutil.mli b/plugins/extraction/mlutil.mli
new file mode 100644
index 00000000..deaacc3f
--- /dev/null
+++ b/plugins/extraction/mlutil.mli
@@ -0,0 +1,131 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Util
+open Names
+open Term
+open Libnames
+open Miniml
+
+(*s Utility functions over ML types with meta. *)
+
+val reset_meta_count : unit -> unit
+val new_meta : 'a -> ml_type
+
+val type_subst : int -> ml_type -> ml_type -> ml_type
+val type_subst_list : ml_type list -> ml_type -> ml_type
+val type_subst_vect : ml_type array -> ml_type -> ml_type
+
+val instantiation : ml_schema -> ml_type
+
+val needs_magic : ml_type * ml_type -> bool
+val put_magic_if : bool -> ml_ast -> ml_ast
+val put_magic : ml_type * ml_type -> ml_ast -> ml_ast
+
+(*s ML type environment. *)
+
+module Mlenv : sig
+ type t
+ val empty : t
+
+ (* get the n-th more recently entered schema and instantiate it. *)
+ val get : t -> int -> ml_type
+
+ (* Adding a type in an environment, after generalizing free meta *)
+ val push_gen : t -> ml_type -> t
+
+ (* Adding a type with no [Tvar] *)
+ val push_type : t -> ml_type -> t
+
+ (* Adding a type with no [Tvar] nor [Tmeta] *)
+ val push_std_type : t -> ml_type -> t
+end
+
+(*s Utility functions over ML types without meta *)
+
+val type_mem_kn : mutual_inductive -> ml_type -> bool
+
+val type_maxvar : ml_type -> int
+
+val type_decomp : ml_type -> ml_type list * ml_type
+val type_recomp : ml_type list * ml_type -> ml_type
+
+val var2var' : ml_type -> ml_type
+
+type abbrev_map = global_reference -> ml_type option
+
+val type_expand : abbrev_map -> ml_type -> ml_type
+val type_to_sign : abbrev_map -> ml_type -> sign
+val type_to_signature : abbrev_map -> ml_type -> signature
+val type_expunge : abbrev_map -> ml_type -> ml_type
+val type_expunge_from_sign : abbrev_map -> signature -> ml_type -> ml_type
+
+val isDummy : ml_type -> bool
+val isKill : sign -> bool
+
+val case_expunge : signature -> ml_ast -> ml_ident list * ml_ast
+val term_expunge : signature -> ml_ident list * ml_ast -> ml_ast
+
+
+(*s Special identifiers. [dummy_name] is to be used for dead code
+ and will be printed as [_] in concrete (Caml) code. *)
+
+val anonymous_name : identifier
+val dummy_name : identifier
+val id_of_name : name -> identifier
+val id_of_mlid : ml_ident -> identifier
+val tmp_id : ml_ident -> ml_ident
+
+(*s [collect_lambda MLlam(id1,...MLlam(idn,t)...)] returns
+ the list [idn;...;id1] and the term [t]. *)
+
+val collect_lams : ml_ast -> ml_ident list * ml_ast
+val collect_n_lams : int -> ml_ast -> ml_ident list * ml_ast
+val remove_n_lams : int -> ml_ast -> ml_ast
+val nb_lams : ml_ast -> int
+val named_lams : ml_ident list -> ml_ast -> ml_ast
+val dummy_lams : ml_ast -> int -> ml_ast
+val anonym_or_dummy_lams : ml_ast -> signature -> ml_ast
+
+val eta_args_sign : int -> signature -> ml_ast list
+
+(*s Utility functions over ML terms. *)
+
+val mlapp : ml_ast -> ml_ast list -> ml_ast
+val ast_map : (ml_ast -> ml_ast) -> ml_ast -> ml_ast
+val ast_map_lift : (int -> ml_ast -> ml_ast) -> int -> ml_ast -> ml_ast
+val ast_iter : (ml_ast -> unit) -> ml_ast -> unit
+val ast_occurs : int -> ml_ast -> bool
+val ast_occurs_itvl : int -> int -> ml_ast -> bool
+val ast_lift : int -> ml_ast -> ml_ast
+val ast_pop : ml_ast -> ml_ast
+val ast_subst : ml_ast -> ml_ast -> ml_ast
+
+val ast_glob_subst : ml_ast Refmap.t -> ml_ast -> ml_ast
+
+val normalize : ml_ast -> ml_ast
+val optimize_fix : ml_ast -> ml_ast
+val inline : global_reference -> ml_ast -> bool
+
+exception Impossible
+val check_function_branch : ml_branch -> ml_ast
+val check_constant_branch : ml_branch -> ml_ast
+
+(* Classification of signatures *)
+
+type sign_kind =
+ | EmptySig
+ | NonLogicalSig (* at least a [Keep] *)
+ | UnsafeLogicalSig (* No [Keep], at least a [Kill Kother] *)
+ | SafeLogicalSig (* only [Kill Ktype] *)
+
+val sign_kind : signature -> sign_kind
+
+val sign_no_final_keeps : signature -> signature
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
new file mode 100644
index 00000000..a7f0c017
--- /dev/null
+++ b/plugins/extraction/modutil.ml
@@ -0,0 +1,375 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Names
+open Declarations
+open Environ
+open Libnames
+open Util
+open Miniml
+open Table
+open Mlutil
+open Mod_subst
+
+(*S Functions upon ML modules. *)
+
+let rec msid_of_mt = function
+ | MTident mp -> mp
+ | MTwith(mt,_)-> msid_of_mt mt
+ | _ -> anomaly "Extraction:the With operator isn't applied to a name"
+
+(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a
+ [ml_structure]. *)
+
+let struct_iter do_decl do_spec s =
+ let rec mt_iter = function
+ | MTident _ -> ()
+ | MTfunsig (_,mt,mt') -> mt_iter mt; mt_iter mt'
+ | MTwith (mt,ML_With_type(idl,l,t))->
+ let mp_mt = msid_of_mt mt in
+ let l',idl' = list_sep_last idl in
+ let mp_w =
+ List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl'
+ in
+ let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l')) in
+ mt_iter mt; do_decl (Dtype(r,l,t))
+ | MTwith (mt,_)->mt_iter mt
+ | MTsig (_, sign) -> List.iter spec_iter sign
+ and spec_iter = function
+ | (_,Spec s) -> do_spec s
+ | (_,Smodule mt) -> mt_iter mt
+ | (_,Smodtype mt) -> mt_iter mt
+ in
+ let rec se_iter = function
+ | (_,SEdecl d) -> do_decl d
+ | (_,SEmodule m) ->
+ me_iter m.ml_mod_expr; mt_iter m.ml_mod_type
+ | (_,SEmodtype m) -> mt_iter m
+ and me_iter = function
+ | MEident _ -> ()
+ | MEfunctor (_,mt,me) -> me_iter me; mt_iter mt
+ | MEapply (me,me') -> me_iter me; me_iter me'
+ | MEstruct (msid, sel) -> List.iter se_iter sel
+ in
+ List.iter (function (_,sel) -> List.iter se_iter sel) s
+
+(*s Apply some fonctions upon all references in [ml_type], [ml_ast],
+ [ml_decl], [ml_spec] and [ml_structure]. *)
+
+type do_ref = global_reference -> unit
+
+let record_iter_references do_term = function
+ | Record l -> List.iter do_term l
+ | _ -> ()
+
+let type_iter_references do_type t =
+ let rec iter = function
+ | Tglob (r,l) -> do_type r; List.iter iter l
+ | Tarr (a,b) -> iter a; iter b
+ | _ -> ()
+ in iter t
+
+let ast_iter_references do_term do_cons do_type a =
+ let rec iter a =
+ ast_iter iter a;
+ match a with
+ | MLglob r -> do_term r
+ | MLcons (i,r,_) ->
+ if lang () = Ocaml then record_iter_references do_term i;
+ do_cons r
+ | MLcase (i,_,v) ->
+ if lang () = Ocaml then record_iter_references do_term (fst i);
+ Array.iter (fun (r,_,_) -> do_cons r) v
+ | _ -> ()
+ in iter a
+
+let ind_iter_references do_term do_cons do_type kn ind =
+ let type_iter = type_iter_references do_type in
+ let cons_iter cp l = do_cons (ConstructRef cp); List.iter type_iter l in
+ let packet_iter ip p =
+ do_type (IndRef ip);
+ if lang () = Ocaml then
+ (match ind.ind_equiv with
+ | Miniml.Equiv kne -> do_type (IndRef (mind_of_kn kne, snd ip));
+ | _ -> ());
+ Array.iteri (fun j -> cons_iter (ip,j+1)) p.ip_types
+ in
+ if lang () = Ocaml then record_iter_references do_term ind.ind_info;
+ Array.iteri (fun i -> packet_iter (kn,i)) ind.ind_packets
+
+let decl_iter_references do_term do_cons do_type =
+ let type_iter = type_iter_references do_type
+ and ast_iter = ast_iter_references do_term do_cons do_type in
+ function
+ | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type
+ (mind_of_kn 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
+ | 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
+
+(*s Searching occurrences of a particular term (no lifting done). *)
+
+exception Found
+
+let rec ast_search f a =
+ if f a then raise Found else ast_iter (ast_search f) a
+
+let decl_ast_search f = function
+ | Dterm (_,a,_) -> ast_search f a
+ | Dfix (_,c,_) -> Array.iter (ast_search f) c
+ | _ -> ()
+
+let struct_ast_search f s =
+ try struct_iter (decl_ast_search f) (fun _ -> ()) s; false
+ with Found -> true
+
+let rec type_search f = function
+ | Tarr (a,b) -> type_search f a; type_search f b
+ | Tglob (r,l) -> List.iter (type_search f) l
+ | u -> if f u then raise Found
+
+let decl_type_search f = function
+ | Dind (_,{ind_packets=p}) ->
+ Array.iter
+ (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p
+ | Dterm (_,_,u) -> type_search f u
+ | Dfix (_,_,v) -> Array.iter (type_search f) v
+ | Dtype (_,_,u) -> type_search f u
+
+let spec_type_search f = function
+ | Sind (_,{ind_packets=p}) ->
+ Array.iter
+ (fun {ip_types=v} -> Array.iter (List.iter (type_search f)) v) p
+ | Stype (_,_,ot) -> Option.iter (type_search f) ot
+ | Sval (_,u) -> type_search f u
+
+let struct_type_search f s =
+ try struct_iter (decl_type_search f) (spec_type_search f) s; false
+ with Found -> true
+
+
+(*s Generating the signature. *)
+
+let rec msig_of_ms = function
+ | [] -> []
+ | (l,SEdecl (Dind (kn,i))) :: ms ->
+ (l,Spec (Sind (kn,i))) :: (msig_of_ms ms)
+ | (l,SEdecl (Dterm (r,_,t))) :: ms ->
+ (l,Spec (Sval (r,t))) :: (msig_of_ms ms)
+ | (l,SEdecl (Dtype (r,v,t))) :: ms ->
+ (l,Spec (Stype (r,v,Some t))) :: (msig_of_ms ms)
+ | (l,SEdecl (Dfix (rv,_,tv))) :: ms ->
+ let msig = ref (msig_of_ms ms) in
+ for i = Array.length rv - 1 downto 0 do
+ msig := (l,Spec (Sval (rv.(i),tv.(i))))::!msig
+ done;
+ !msig
+ | (l,SEmodule m) :: ms -> (l,Smodule m.ml_mod_type) :: (msig_of_ms ms)
+ | (l,SEmodtype m) :: ms -> (l,Smodtype m) :: (msig_of_ms ms)
+
+let signature_of_structure s =
+ List.map (fun (mp,ms) -> mp,msig_of_ms ms) s
+
+
+(*s Searching one [ml_decl] in a [ml_structure] by its [global_reference] *)
+
+let get_decl_in_structure r struc =
+ try
+ let base_mp,ll = labels_of_ref r in
+ if not (at_toplevel base_mp) then error_not_visible r;
+ let sel = List.assoc base_mp struc in
+ let rec go ll sel = match ll with
+ | [] -> assert false
+ | l :: ll ->
+ match List.assoc l sel with
+ | SEdecl d -> d
+ | SEmodtype m -> assert false
+ | SEmodule m ->
+ match m.ml_mod_expr with
+ | MEstruct (_,sel) -> go ll sel
+ | _ -> error_not_visible r
+ in go ll sel
+ with Not_found ->
+ anomaly "reference not found in extracted structure"
+
+
+(*s Optimization of a [ml_structure]. *)
+
+(* Some transformations of ML terms. [optimize_struct] simplify
+ all beta redexes (when the argument does not occur, it is just
+ thrown away; when it occurs exactly once it is substituted; otherwise
+ a let-in redex is created for clarity) and iota redexes, plus some other
+ optimizations. *)
+
+let dfix_to_mlfix rv av i =
+ let rec make_subst n s =
+ if n < 0 then s
+ else make_subst (n-1) (Refmap.add rv.(n) (n+1) s)
+ in
+ let s = make_subst (Array.length rv - 1) Refmap.empty
+ in
+ let rec subst n t = match t with
+ | MLglob ((ConstRef kn) as refe) ->
+ (try MLrel (n + (Refmap.find refe s)) with Not_found -> t)
+ | _ -> ast_map_lift subst n t
+ in
+ let ids = Array.map (fun r -> id_of_label (label_of_r r)) rv in
+ let c = Array.map (subst 0) av
+ in MLfix(i, ids, c)
+
+let rec optim to_appear s = function
+ | [] -> []
+ | (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l ->
+ if List.mem r to_appear
+ then d :: (optim to_appear s l)
+ else optim to_appear s l
+ | Dterm (r,t,typ) :: l ->
+ let t = normalize (ast_glob_subst !s t) in
+ let i = inline r t in
+ if i then s := Refmap.add r t !s;
+ if not i || modular () || List.mem r to_appear
+ then
+ let d = match optimize_fix t with
+ | MLfix (0, _, [|c|]) ->
+ Dfix ([|r|], [|ast_subst (MLglob r) c|], [|typ|])
+ | t -> Dterm (r, t, typ)
+ in d :: (optim to_appear s l)
+ else optim to_appear s l
+ | d :: l -> d :: (optim to_appear s l)
+
+let rec optim_se top to_appear s = function
+ | [] -> []
+ | (l,SEdecl (Dterm (r,a,t))) :: lse ->
+ let a = normalize (ast_glob_subst !s a) in
+ let i = inline r a in
+ if i then s := Refmap.add r a !s;
+ if top && i && not (modular ()) && not (List.mem r to_appear)
+ then optim_se top to_appear s lse
+ else
+ let d = match optimize_fix a with
+ | MLfix (0, _, [|c|]) ->
+ Dfix ([|r|], [|ast_subst (MLglob r) c|], [|t|])
+ | a -> Dterm (r, a, t)
+ in (l,SEdecl d) :: (optim_se top to_appear s lse)
+ | (l,SEdecl (Dfix (rv,av,tv))) :: lse ->
+ let av = Array.map (fun a -> normalize (ast_glob_subst !s a)) av in
+ let all = ref true in
+ (* This fake body ensures that no fixpoint will be auto-inlined. *)
+ let fake_body = MLfix (0,[||],[||]) in
+ for i = 0 to Array.length rv - 1 do
+ if inline rv.(i) fake_body
+ then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s
+ else all := false
+ done;
+ if !all && top && not (modular ())
+ && (array_for_all (fun r -> not (List.mem r to_appear)) rv)
+ then optim_se top to_appear s lse
+ else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top to_appear s lse)
+ | (l,SEmodule m) :: lse ->
+ let m = { m with ml_mod_expr = optim_me to_appear s m.ml_mod_expr}
+ in (l,SEmodule m) :: (optim_se top to_appear s lse)
+ | se :: lse -> se :: (optim_se top to_appear s lse)
+
+and optim_me to_appear s = function
+ | MEstruct (msid, lse) -> MEstruct (msid, optim_se false to_appear s lse)
+ | MEident mp as me -> me
+ | MEapply (me, me') ->
+ MEapply (optim_me to_appear s me, optim_me to_appear s me')
+ | 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. *)
+
+exception NoDepCheck
+
+let base_r = function
+ | ConstRef c as r -> r
+ | IndRef (kn,_) -> IndRef (kn,0)
+ | 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),
+ (fun r -> needed := Refset.add (base_r r) !needed),
+ (fun r -> needed := Refset.remove (base_r r) !needed),
+ (fun r -> Refset.mem (base_r r) !needed))
+
+let declared_refs = function
+ | Dind (kn,_) -> [|IndRef (mind_of_kn kn,0)|]
+ | Dtype (r,_,_) -> [|r|]
+ | Dterm (r,_,_) -> [|r|]
+ | Dfix (rv,_,_) -> rv
+
+(* Computes the dependencies of a declaration, except in case
+ of custom extraction. *)
+
+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
+ | Dtype (r,ids,t) ->
+ if not (is_custom r) then type_iter_references add_needed t
+ | Dterm (r,u,t) ->
+ type_iter_references add_needed t;
+ if not (is_custom r) then
+ ast_iter_references add_needed add_needed add_needed u
+ | Dfix _ as d ->
+ (* Todo Later : avoid dependencies when Extract Constant *)
+ decl_iter_references add_needed add_needed add_needed d
+
+let rec depcheck_se = function
+ | [] -> []
+ | ((l,SEdecl d) as t)::se ->
+ let se' = depcheck_se se in
+ let rv = declared_refs d in
+ if not (array_exists is_needed rv) then
+ (Array.iter remove_info_axiom rv; se')
+ else
+ (Array.iter found_needed rv; compute_deps_decl d; t::se')
+ | _ -> raise NoDepCheck
+
+let rec depcheck_struct = function
+ | [] -> []
+ | (mp,lse)::struc ->
+ let struc' = depcheck_struct struc in
+ let lse' = depcheck_se lse in
+ (mp,lse')::struc'
+
+let check_implicits = function
+ | MLexn s ->
+ if String.length s > 8 && (s.[0] = 'U' || s.[0] = 'I') then
+ begin
+ if String.sub s 0 7 = "UNBOUND" then assert false;
+ if String.sub s 0 8 = "IMPLICIT" then
+ error_non_implicit (String.sub s 9 (String.length s - 9));
+ end;
+ false
+ | _ -> false
+
+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
+ 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;
+ reset_needed ();
+ List.iter add_needed to_appear;
+ depcheck_struct opt_struc
+ with NoDepCheck -> opt_struc
diff --git a/plugins/extraction/modutil.mli b/plugins/extraction/modutil.mli
new file mode 100644
index 00000000..8e04a368
--- /dev/null
+++ b/plugins/extraction/modutil.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Names
+open Declarations
+open Environ
+open Libnames
+open Miniml
+open Mod_subst
+
+(*s Functions upon ML modules. *)
+
+val struct_ast_search : (ml_ast -> bool) -> ml_structure -> bool
+val struct_type_search : (ml_type -> bool) -> ml_structure -> bool
+
+type do_ref = global_reference -> unit
+
+val decl_iter_references : do_ref -> do_ref -> do_ref -> ml_decl -> unit
+val spec_iter_references : do_ref -> do_ref -> do_ref -> ml_spec -> unit
+
+val signature_of_structure : ml_structure -> ml_signature
+
+val msid_of_mt : ml_module_type -> module_path
+
+val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
+
+(* Some transformations of ML terms. [optimize_struct] simplify
+ all beta redexes (when the argument does not occur, it is just
+ thrown away; when it occurs exactly once it is substituted; otherwise
+ a let-in redex is created for clarity) and iota redexes, plus some other
+ optimizations. The first argument is the list of objects we want to appear.
+*)
+
+val optimize_struct : global_reference list -> ml_structure -> ml_structure
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
new file mode 100644
index 00000000..30004677
--- /dev/null
+++ b/plugins/extraction/ocaml.ml
@@ -0,0 +1,759 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*s Production of Ocaml syntax. *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Table
+open Miniml
+open Mlutil
+open Modutil
+open Common
+open Declarations
+
+
+(*s Some utility functions. *)
+
+let pp_tvar id =
+ let s = string_of_id id in
+ if String.length s < 2 || s.[1]<>'\''
+ then str ("'"^s)
+ else str ("' "^s)
+
+let pp_tuple_light f = function
+ | [] -> mt ()
+ | [x] -> f true x
+ | l ->
+ pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) (f false) l)
+
+let pp_tuple f = function
+ | [] -> mt ()
+ | [x] -> f x
+ | l -> pp_par true (prlist_with_sep (fun () -> str "," ++ spc ()) f l)
+
+let pp_boxed_tuple f = function
+ | [] -> mt ()
+ | [x] -> f x
+ | l -> pp_par true (hov 0 (prlist_with_sep (fun () -> str "," ++ spc ()) f l))
+
+let pp_abst = function
+ | [] -> mt ()
+ | l ->
+ str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++
+ str " ->" ++ spc ()
+
+let pp_parameters l =
+ (pp_boxed_tuple pp_tvar l ++ space_if (l<>[]))
+
+let pp_string_parameters l =
+ (pp_boxed_tuple str l ++ space_if (l<>[]))
+
+(*s Ocaml renaming issues. *)
+
+let keywords =
+ List.fold_right (fun s -> Idset.add (id_of_string s))
+ [ "and"; "as"; "assert"; "begin"; "class"; "constraint"; "do";
+ "done"; "downto"; "else"; "end"; "exception"; "external"; "false";
+ "for"; "fun"; "function"; "functor"; "if"; "in"; "include";
+ "inherit"; "initializer"; "lazy"; "let"; "match"; "method";
+ "module"; "mutable"; "new"; "object"; "of"; "open"; "or";
+ "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true";
+ "try"; "type"; "val"; "virtual"; "when"; "while"; "with"; "mod";
+ "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ]
+ Idset.empty
+
+let pp_open mp = str ("open "^ string_of_modfile mp ^"\n")
+
+let preamble _ used_modules usf =
+ prlist pp_open used_modules ++
+ (if used_modules = [] then mt () else fnl ()) ++
+ (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n" else mt()) ++
+ (if usf.mldummy then
+ str "let __ = let rec f _ = Obj.repr f in Obj.repr f\n"
+ else mt ()) ++
+ (if usf.tdummy || usf.tunknown || usf.mldummy then fnl () else mt ())
+
+let sig_preamble _ used_modules usf =
+ prlist pp_open used_modules ++
+ (if used_modules = [] then mt () else fnl ()) ++
+ (if usf.tdummy || usf.tunknown then str "type __ = Obj.t\n\n" else mt())
+
+(*s The pretty-printer for Ocaml syntax*)
+
+(* Beware of the side-effects of [pp_global] and [pp_modname].
+ They are used to update table of content for modules. Many [let]
+ below should not be altered since they force evaluation order.
+*)
+
+let str_global k r =
+ if is_inline_custom r then find_custom r else Common.pp_global k r
+
+let pp_global k r = str (str_global k r)
+
+let pp_modname mp = str (Common.pp_module mp)
+
+let is_infix r =
+ is_inline_custom r &&
+ (let s = find_custom r in
+ let l = String.length s in
+ l >= 2 && s.[0] = '(' && s.[l-1] = ')')
+
+let get_infix r =
+ let s = find_custom r in
+ String.sub s 1 (String.length s - 2)
+
+exception NoRecord
+
+let find_projections = function Record l -> l | _ -> raise NoRecord
+
+(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
+ are needed or not. *)
+
+let mk_ind path s =
+ make_mind (MPfile (dirpath_of_string path)) empty_dirpath (mk_label s)
+
+let rec pp_type par vl t =
+ let rec pp_rec par = function
+ | Tmeta _ | Tvar' _ | Taxiom -> assert false
+ | Tvar i -> (try pp_tvar (List.nth vl (pred i))
+ with _ -> (str "'a" ++ int i))
+ | Tglob (r,[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" ->
+ pp_tuple_light pp_rec l
+ | Tglob (r,l) ->
+ pp_tuple_light pp_rec l ++ spc () ++ pp_global Type r
+ | Tarr (t1,t2) ->
+ pp_par par
+ (pp_rec true t1 ++ spc () ++ str "->" ++ spc () ++ pp_rec false t2)
+ | Tdummy _ -> str "__"
+ | Tunknown -> str "__"
+ in
+ hov 0 (pp_rec par t)
+
+(*s Pretty-printing of expressions. [par] indicates whether
+ parentheses are needed or not. [env] is the list of names for the
+ de Bruijn variables. [args] is the list of collected arguments
+ (already pretty-printed). *)
+
+let is_ifthenelse = function
+ | [|(r1,[],_);(r2,[],_)|] ->
+ (try (find_custom r1 = "true") && (find_custom r2 = "false")
+ with Not_found -> false)
+ | _ -> false
+
+let expr_needs_par = function
+ | MLlam _ -> true
+ | MLcase (_,_,[|_|]) -> false
+ | MLcase (_,_,pv) -> not (is_ifthenelse pv)
+ | _ -> false
+
+
+(** Special hack for constants of type Ascii.ascii : if an
+ [Extract Inductive ascii => char] has been declared, then
+ the constants are directly turned into chars *)
+
+let ind_ascii = mk_ind "Coq.Strings.Ascii" "ascii"
+
+let check_extract_ascii () =
+ try find_custom (IndRef (ind_ascii,0)) = "char" with Not_found -> false
+
+let is_list_cons l =
+ List.for_all (function MLcons (_,ConstructRef(_,_),[]) -> true | _ -> false) l
+
+let pp_char l =
+ let rec cumul = function
+ | [] -> 0
+ | MLcons(_,ConstructRef(_,j),[])::l -> (2-j) + 2 * (cumul l)
+ | _ -> assert false
+ in str ("'"^Char.escaped (Char.chr (cumul l))^"'")
+
+let rec pp_expr par env args =
+ let par' = args <> [] || par
+ and apply st = pp_apply st par args in
+ function
+ | MLrel n ->
+ let id = get_db_name n env in apply (pr_id id)
+ | MLapp (f,args') ->
+ let stl = List.map (pp_expr true env []) args' in
+ pp_expr par env (stl @ args) f
+ | MLlam _ as a ->
+ let fl,a' = collect_lams a in
+ let fl = 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)
+ | 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)))
+ | 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(_,ConstructRef ((kn,0),1),l)
+ when kn = ind_ascii && check_extract_ascii () & is_list_cons l ->
+ assert (args=[]);
+ pp_char l
+ | MLcons (Coinductive,r,[]) ->
+ assert (args=[]);
+ pp_par par (str "lazy " ++ pp_global Cons r)
+ | MLcons (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 (Record projs, r, args') ->
+ assert (args=[]);
+ pp_record_pat (projs, 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
+ 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 ((i,factors), t, pv) ->
+ let expr = if i = Coinductive then
+ (str "Lazy.force" ++ spc () ++ pp_expr true env [] t)
+ else
+ (pp_expr false env [] t)
+ in
+ (try
+ let projs = find_projections i in
+ let (_, ids, c) = pv.(0) in
+ let n = List.length ids in
+ match c with
+ | MLrel i when i <= n ->
+ apply (pp_par par' (pp_expr true env [] t ++ str "." ++
+ pp_global Term (List.nth projs (n-i))))
+ | MLapp (MLrel i, a) when i <= n ->
+ if List.exists (ast_occurs_itvl 1 n) a
+ then raise NoRecord
+ else
+ let ids,env' = push_vars (List.rev_map id_of_mlid ids) env
+ in
+ (pp_apply
+ (pp_expr true env [] t ++ str "." ++
+ pp_global Term (List.nth projs (n-i)))
+ par ((List.map (pp_expr true env' []) a) @ args))
+ | _ -> raise NoRecord
+ with NoRecord ->
+ if Array.length pv = 1 then
+ let s1,s2 = pp_one_pat env i pv.(0) in
+ apply
+ (hv 0
+ (pp_par par'
+ (hv 0
+ (hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr)
+ ++ spc () ++ str "in") ++
+ spc () ++ hov 0 s2)))
+ else
+ apply
+ (pp_par par'
+ (try pp_ifthenelse par' env expr pv
+ with Not_found ->
+ v 0 (str "match " ++ expr ++ str " with" ++ fnl () ++
+ str " | " ++ pp_pat env (i,factors) pv))))
+ | MLfix (i,ids,defs) ->
+ let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
+ pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
+ | MLexn s ->
+ (* An [MLexn] may be applied, but I don't really care. *)
+ pp_par par (str "assert false" ++ spc () ++ str ("(* "^s^" *)"))
+ | MLdummy ->
+ str "__" (* An [MLdummy] may be applied, but I don't really care. *)
+ | MLmagic a ->
+ pp_apply (str "Obj.magic") par (pp_expr true env [] a :: args)
+ | MLaxiom ->
+ pp_par par (str "failwith \"AXIOM TO BE REALIZED\"")
+
+
+and pp_record_pat (projs, args) =
+ str "{ " ++
+ prlist_with_sep (fun () -> str ";" ++ spc ())
+ (fun (r,a) -> pp_global Term r ++ str " =" ++ spc () ++ a)
+ (List.combine projs 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")
+ ->
+ hv 0 (hov 2 (str "if " ++ expr) ++ spc () ++
+ hov 2 (str "then " ++
+ hov 2 (pp_expr (expr_needs_par the) env [] the)) ++ spc () ++
+ hov 2 (str "else " ++
+ hov 2 (pp_expr (expr_needs_par els) env [] els)))
+ | _ -> raise Not_found
+
+and pp_one_pat env i (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
+ try
+ let projs = find_projections i in
+ pp_record_pat (projs, List.rev_map pr_id ids), expr
+ with NoRecord ->
+ (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),
+ expr
+
+and pp_pat env (info,factors) pv =
+ let factor_br, factor_l = try match factors with
+ | BranchFun (i::_ as l) -> check_function_branch pv.(i), l
+ | BranchCst (i::_ as l) -> ast_pop (check_constant_branch pv.(i)), l
+ | _ -> MLdummy, []
+ with Impossible -> MLdummy, []
+ in
+ let par = expr_needs_par factor_br in
+ let last = Array.length pv - 1 in
+ prvecti
+ (fun i x -> if List.mem i factor_l then mt () else
+ let s1,s2 = pp_one_pat env info x in
+ hov 2 (s1 ++ str " ->" ++ spc () ++ s2) ++
+ if i = last && factor_l = [] then mt () else
+ fnl () ++ str " | ") pv
+ ++
+ if factor_l = [] then mt () else match factors with
+ | BranchFun _ ->
+ let ids, env' = push_vars [anonymous_name] env in
+ hov 2 (pr_id (List.hd ids) ++ str " ->" ++ spc () ++
+ pp_expr par env' [] factor_br)
+ | BranchCst _ ->
+ hov 2 (str "_ ->" ++ spc () ++ 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 fst i=Standard && not (is_custom_match pv) ->
+ if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then
+ pr_binding (List.rev (List.tl bl)) ++
+ str " = function" ++ fnl () ++
+ v 0 (str " | " ++ pp_pat env' i pv)
+ else
+ pr_binding (List.rev bl) ++
+ str " = match " ++ pr_id (List.hd bl) ++ str " with" ++ fnl () ++
+ v 0 (str " | " ++ pp_pat env' i pv)
+ | _ ->
+ pr_binding (List.rev bl) ++
+ str " =" ++ fnl () ++ str " " ++
+ hov 2 (pp_expr false env' [] t')
+
+(*s names of the functions ([ids]) are already pushed in [env],
+ and passed here just for convenience. *)
+
+and pp_fix par env i (ids,bl) args =
+ pp_par par
+ (v 0 (str "let rec " ++
+ prvect_with_sep
+ (fun () -> fnl () ++ str "and ")
+ (fun (fi,ti) -> pr_id fi ++ pp_function env ti)
+ (array_map2 (fun id b -> (id,b)) ids bl) ++
+ fnl () ++
+ hov 2 (str "in " ++ pp_apply (pr_id ids.(i)) false args)))
+
+let pp_val e typ =
+ hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++
+ str " **)") ++ fnl2 ()
+
+(*s Pretty-printing of [Dfix] *)
+
+let pp_Dfix (rv,c,t) =
+ let names = Array.map
+ (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv
+ in
+ let rec pp sep letand i =
+ if i >= Array.length rv then mt ()
+ else if is_inline_custom rv.(i) then pp sep letand (i+1)
+ else
+ let def =
+ if is_custom rv.(i) then str " = " ++ str (find_custom rv.(i))
+ else pp_function (empty_env ()) c.(i)
+ in
+ sep () ++ pp_val names.(i) t.(i) ++
+ str letand ++ names.(i) ++ def ++ pp fnl2 "and " (i+1)
+ in pp mt "let rec " 0
+
+(*s Pretty-printing of inductive types declaration. *)
+
+let pp_equiv param_list name = function
+ | NoEquiv, _ -> mt ()
+ | Equiv kn, i ->
+ str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (mind_of_kn kn,i))
+ | RenEquiv ren, _ ->
+ str " = " ++ pp_parameters param_list ++ str (ren^".") ++ name
+
+let pp_comment s = str "(* " ++ s ++ str " *)"
+
+let pp_one_ind prefix ip_equiv pl name cnames ctyps =
+ let pl = rename_tvars keywords pl in
+ let pp_constructor i typs =
+ (if i=0 then mt () else fnl ()) ++
+ hov 5 (str " | " ++ cnames.(i) ++
+ (if typs = [] then mt () else str " of ") ++
+ prlist_with_sep
+ (fun () -> spc () ++ str "* ") (pp_type true pl) typs)
+ in
+ pp_parameters pl ++ str prefix ++ name ++
+ pp_equiv pl name ip_equiv ++ str " =" ++
+ if Array.length ctyps = 0 then str " unit (* empty inductive *)"
+ else fnl () ++ v 0 (prvecti pp_constructor ctyps)
+
+let pp_logical_ind packet =
+ pp_comment (pr_id packet.ip_typename ++ str " : logical inductive") ++
+ fnl () ++
+ pp_comment (str "with constructors : " ++
+ prvect_with_sep spc pr_id packet.ip_consnames) ++
+ fnl ()
+
+let pp_singleton kn packet =
+ let name = pp_global Type (IndRef (mind_of_kn 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 () ++
+ pp_comment (str "singleton inductive, whose constructor was " ++
+ pr_id packet.ip_consnames.(0)))
+
+let pp_record kn projs ip_equiv packet =
+ let name = pp_global Type (IndRef (mind_of_kn kn,0)) in
+ let projnames = List.map (pp_global Term) projs in
+ let l = List.combine projnames packet.ip_types.(0) in
+ let pl = rename_tvars keywords packet.ip_vars in
+ str "type " ++ pp_parameters pl ++ name ++
+ pp_equiv pl name ip_equiv ++ str " = { "++
+ hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ())
+ (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l)
+ ++ str " }"
+
+let pp_coind pl name =
+ let pl = rename_tvars keywords pl in
+ pp_parameters pl ++ name ++ str " = " ++
+ pp_parameters pl ++ str "__" ++ name ++ str " Lazy.t" ++
+ fnl() ++ str "and "
+
+let pp_ind co kn ind =
+ let prefix = if co then "__" else "" in
+ let some = ref false in
+ 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)))
+ 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)))
+ 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_equiv = ind.ind_equiv, i in
+ let p = ind.ind_packets.(i) in
+ if is_custom (IndRef ip) then pp (i+1)
+ else begin
+ some := true;
+ if p.ip_logical then pp_logical_ind p ++ pp (i+1)
+ else
+ let s = !init in
+ begin
+ init := (fnl () ++ str "and ");
+ s ++
+ (if co then pp_coind p.ip_vars names.(i) else mt ()) ++
+ pp_one_ind
+ prefix ip_equiv p.ip_vars names.(i) cnames.(i) p.ip_types ++
+ pp (i+1)
+ end
+ end
+ in
+ let st = pp 0 in if !some then st else failwith "empty phrase"
+
+
+(*s Pretty-printing of a declaration. *)
+
+let pp_mind kn i =
+ match i.ind_info with
+ | Singleton -> pp_singleton kn i.ind_packets.(0)
+ | Coinductive -> pp_ind true kn i
+ | Record projs ->
+ pp_record kn projs (i.ind_equiv,0) i.ind_packets.(0)
+ | Standard -> pp_ind false kn i
+
+let pp_decl = function
+ | Dtype (r,_,_) when is_inline_custom r -> failwith "empty phrase"
+ | Dterm (r,_,_) when is_inline_custom r -> failwith "empty phrase"
+ | Dind (kn,i) -> pp_mind kn i
+ | Dtype (r, l, t) ->
+ let name = pp_global Type r in
+ let l = rename_tvars keywords l in
+ let ids, def =
+ try
+ let ids,s = find_type_custom r in
+ pp_string_parameters ids, str "=" ++ spc () ++ str s
+ with Not_found ->
+ pp_parameters l,
+ if t = Taxiom then str "(* AXIOM TO BE REALIZED *)"
+ else str "=" ++ spc () ++ pp_type false l t
+ in
+ hov 2 (str "type " ++ ids ++ name ++ spc () ++ def)
+ | Dterm (r, a, t) ->
+ let def =
+ if is_custom r then str (" = " ^ find_custom r)
+ else if is_projection r then
+ (prvect str (Array.make (projection_arity r) " _")) ++
+ str " x = x."
+ else pp_function (empty_env ()) a
+ in
+ let name = pp_global Term r in
+ let postdef = if is_projection r then name else mt () in
+ pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef)
+ | Dfix (rv,defs,typs) ->
+ pp_Dfix (rv,defs,typs)
+
+let pp_alias_decl ren = function
+ | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren }
+ | Dtype (r, l, _) ->
+ let name = pp_global Type r in
+ let l = rename_tvars keywords l in
+ let ids = pp_parameters l in
+ hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++
+ str (ren^".") ++ name)
+ | Dterm (r, a, t) ->
+ let name = pp_global Term r in
+ hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name)
+ | Dfix (rv, _, _) ->
+ prvecti (fun i r -> if is_inline_custom r then mt () else
+ let name = pp_global Term r in
+ hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++
+ fnl ())
+ rv
+
+let pp_spec = function
+ | Sval (r,_) when is_inline_custom r -> failwith "empty phrase"
+ | Stype (r,_,_) when is_inline_custom r -> failwith "empty phrase"
+ | Sind (kn,i) -> pp_mind kn i
+ | Sval (r,t) ->
+ let def = pp_type false [] t in
+ let name = pp_global Term r in
+ hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def)
+ | Stype (r,vl,ot) ->
+ let name = pp_global Type r in
+ let l = rename_tvars keywords vl in
+ let ids, def =
+ try
+ let ids, s = find_type_custom r in
+ pp_string_parameters ids, str "= " ++ str s
+ with Not_found ->
+ let ids = pp_parameters l in
+ match ot with
+ | None -> ids, mt ()
+ | Some Taxiom -> ids, str "(* AXIOM TO BE REALIZED *)"
+ | Some t -> ids, str "=" ++ spc () ++ pp_type false l t
+ in
+ hov 2 (str "type " ++ ids ++ name ++ spc () ++ def)
+
+let pp_alias_spec ren = function
+ | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren }
+ | Stype (r,l,_) ->
+ let name = pp_global Type r in
+ let l = rename_tvars keywords l in
+ let ids = pp_parameters l in
+ hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++
+ str (ren^".") ++ name)
+ | Sval _ -> assert false
+
+let rec pp_specif = function
+ | (_,Spec (Sval _ as s)) -> pp_spec s
+ | (l,Spec s) ->
+ (try
+ let ren = Common.check_duplicate (top_visible_mp ()) l in
+ hov 1 (str ("module "^ren^" : sig ") ++ fnl () ++ pp_spec s) ++
+ fnl () ++ str "end" ++ fnl () ++
+ pp_alias_spec ren s
+ with Not_found -> pp_spec s)
+ | (l,Smodule mt) ->
+ let def = pp_module_type [] mt in
+ let def' = pp_module_type [] mt in
+ let name = pp_modname (MPdot (top_visible_mp (), l)) in
+ hov 1 (str "module " ++ name ++ str " : " ++ fnl () ++ def) ++
+ (try
+ let ren = Common.check_duplicate (top_visible_mp ()) l in
+ fnl () ++ hov 1 (str ("module "^ren^" : ") ++ fnl () ++ def')
+ with Not_found -> Pp.mt ())
+ | (l,Smodtype mt) ->
+ let def = pp_module_type [] mt in
+ let name = pp_modname (MPdot (top_visible_mp (), l)) in
+ hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++
+ (try
+ let ren = Common.check_duplicate (top_visible_mp ()) l in
+ fnl () ++ str ("module type "^ren^" = ") ++ name
+ with Not_found -> Pp.mt ())
+
+and pp_module_type params = function
+ | MTident kn ->
+ pp_modname kn
+ | MTfunsig (mbid, mt, mt') ->
+ let typ = pp_module_type [] mt in
+ let name = pp_modname (MPbound mbid) in
+ let def = pp_module_type (MPbound mbid :: params) mt' in
+ str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
+ | MTsig (mp, sign) ->
+ push_visible mp params;
+ let l = map_succeed pp_specif sign in
+ pop_visible ();
+ str "sig " ++ fnl () ++
+ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
+ fnl () ++ str "end"
+ | MTwith(mt,ML_With_type(idl,vl,typ)) ->
+ let ids = pp_parameters (rename_tvars keywords vl) in
+ let mp_mt = msid_of_mt mt in
+ let l,idl' = list_sep_last idl in
+ let mp_w =
+ List.fold_left (fun mp l -> MPdot(mp,label_of_id l)) mp_mt idl'
+ in
+ let r = ConstRef (make_con mp_w empty_dirpath (label_of_id l)) in
+ push_visible mp_mt [];
+ let pp_w = str " with type " ++ ids ++ pp_global Type r in
+ pop_visible();
+ pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_type false vl typ
+ | MTwith(mt,ML_With_module(idl,mp)) ->
+ let mp_mt = msid_of_mt mt in
+ let mp_w =
+ List.fold_left (fun mp id -> MPdot(mp,label_of_id id)) mp_mt idl
+ in
+ push_visible mp_mt [];
+ let pp_w = str " with module " ++ pp_modname mp_w in
+ pop_visible ();
+ pp_module_type [] mt ++ pp_w ++ str " = " ++ pp_modname mp
+
+let is_short = function MEident _ | MEapply _ -> true | _ -> false
+
+let rec pp_structure_elem = function
+ | (l,SEdecl d) ->
+ (try
+ let ren = Common.check_duplicate (top_visible_mp ()) l in
+ hov 1 (str ("module "^ren^" = struct ") ++ fnl () ++ pp_decl d) ++
+ fnl () ++ str "end" ++ fnl () ++
+ pp_alias_decl ren d
+ with Not_found -> pp_decl d)
+ | (l,SEmodule m) ->
+ let typ =
+ (* virtual printing of the type, in order to have a correct mli later*)
+ if Common.get_phase () = Pre then
+ str ": " ++ pp_module_type [] m.ml_mod_type
+ else mt ()
+ in
+ let def = pp_module_expr [] m.ml_mod_expr in
+ let name = pp_modname (MPdot (top_visible_mp (), l)) in
+ hov 1
+ (str "module " ++ name ++ typ ++ str " = " ++
+ (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++ def) ++
+ (try
+ let ren = Common.check_duplicate (top_visible_mp ()) l in
+ fnl () ++ str ("module "^ren^" = ") ++ name
+ with Not_found -> mt ())
+ | (l,SEmodtype m) ->
+ let def = pp_module_type [] m in
+ let name = pp_modname (MPdot (top_visible_mp (), l)) in
+ hov 1 (str "module type " ++ name ++ str " = " ++ fnl () ++ def) ++
+ (try
+ let ren = Common.check_duplicate (top_visible_mp ()) l in
+ fnl () ++ str ("module type "^ren^" = ") ++ name
+ with Not_found -> mt ())
+
+and pp_module_expr params = function
+ | MEident mp -> pp_modname mp
+ | MEapply (me, me') ->
+ pp_module_expr [] me ++ str "(" ++ pp_module_expr [] me' ++ str ")"
+ | MEfunctor (mbid, mt, me) ->
+ let name = pp_modname (MPbound mbid) in
+ let typ = pp_module_type [] mt in
+ let def = pp_module_expr (MPbound mbid :: params) me in
+ str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
+ | MEstruct (mp, sel) ->
+ push_visible mp params;
+ let l = map_succeed pp_structure_elem sel in
+ pop_visible ();
+ str "struct " ++ fnl () ++
+ v 1 (str " " ++ prlist_with_sep fnl2 identity l) ++
+ fnl () ++ str "end"
+
+let do_struct f s =
+ let pp s = try f s ++ fnl2 () with Failure "empty phrase" -> mt ()
+ in
+ let ppl (mp,sel) =
+ push_visible mp [];
+ let p = prlist_strict pp sel in
+ (* for monolithic extraction, we try to simulate the unavailability
+ of [MPfile] in names by artificially nesting these [MPfile] *)
+ (if modular () then pop_visible ()); p
+ in
+ let p = prlist_strict ppl s in
+ (if not (modular ()) then repeat (List.length s) pop_visible ());
+ p
+
+let pp_struct s = do_struct pp_structure_elem s
+
+let pp_signature s = do_struct pp_specif s
+
+let pp_decl d = try pp_decl d with Failure "empty phrase" -> mt ()
+
+let ocaml_descr = {
+ keywords = keywords;
+ file_suffix = ".ml";
+ preamble = preamble;
+ pp_struct = pp_struct;
+ sig_suffix = Some ".mli";
+ sig_preamble = sig_preamble;
+ pp_sig = pp_signature;
+ pp_decl = pp_decl;
+}
+
+
diff --git a/plugins/extraction/ocaml.mli b/plugins/extraction/ocaml.mli
new file mode 100644
index 00000000..4a1c1778
--- /dev/null
+++ b/plugins/extraction/ocaml.mli
@@ -0,0 +1,12 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+val ocaml_descr : Miniml.language_descr
+
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
new file mode 100644
index 00000000..108d3685
--- /dev/null
+++ b/plugins/extraction/scheme.ml
@@ -0,0 +1,215 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*s Production of Scheme syntax. *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Libnames
+open Miniml
+open Mlutil
+open Table
+open Common
+
+(*s Scheme renaming issues. *)
+
+let keywords =
+ List.fold_right (fun s -> Idset.add (id_of_string s))
+ [ "define"; "let"; "lambda"; "lambdas"; "match";
+ "apply"; "car"; "cdr";
+ "error"; "delay"; "force"; "_"; "__"]
+ Idset.empty
+
+let preamble _ _ usf =
+ str ";; This extracted scheme code relies on some additional macros\n" ++
+ str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme\n" ++
+ str "(load \"macros_extr.scm\")\n\n" ++
+ (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ())
+
+let pr_id id =
+ let s = string_of_id id in
+ for i = 0 to String.length s - 1 do
+ if s.[i] = '\'' then s.[i] <- '~'
+ done;
+ str s
+
+let paren = pp_par true
+
+let pp_abst st = function
+ | [] -> assert false
+ | [id] -> paren (str "lambda " ++ paren (pr_id id) ++ spc () ++ st)
+ | l -> paren
+ (str "lambdas " ++ paren (prlist_with_sep spc pr_id l) ++ spc () ++ st)
+
+let pp_apply st _ = function
+ | [] -> st
+ | [a] -> hov 2 (paren (st ++ spc () ++ a))
+ | args -> hov 2 (paren (str "@ " ++ st ++
+ (prlist_strict (fun x -> spc () ++ x) args)))
+
+(*s The pretty-printer for Scheme syntax *)
+
+let pp_global k r = str (Common.pp_global k r)
+
+(*s Pretty-printing of expressions. *)
+
+let rec pp_expr env args =
+ let apply st = pp_apply st true args in
+ function
+ | MLrel n ->
+ let id = get_db_name n env in apply (pr_id id)
+ | MLapp (f,args') ->
+ let stl = List.map (pp_expr env []) args' in
+ pp_expr env (stl @ args) f
+ | MLlam _ as a ->
+ let fl,a' = collect_lams a in
+ let fl,env' = push_vars (List.map id_of_mlid fl) env in
+ apply (pp_abst (pp_expr env' [] a') (List.rev fl))
+ | MLletin (id,a1,a2) ->
+ let i,env' = push_vars [id_of_mlid id] env in
+ apply
+ (hv 0
+ (hov 2
+ (paren
+ (str "let " ++
+ paren
+ (paren
+ (pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1))
+ ++ spc () ++ hov 0 (pp_expr env' [] a2)))))
+ | MLglob r ->
+ apply (pp_global Term r)
+ | MLcons (i,r,args') ->
+ assert (args=[]);
+ let st =
+ str "`" ++
+ paren (pp_global Cons r ++
+ (if args' = [] then mt () else spc ()) ++
+ prlist_with_sep spc (pp_cons_args env) args')
+ in
+ if i = Coinductive then paren (str "delay " ++ st) else st
+ | 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
+ hov 2 (str (find_custom_match pv) ++ fnl () ++
+ prvect (fun tr -> pp_expr env [] (mkfun tr) ++ fnl ()) pv
+ ++ pp_expr env [] t)
+ | MLcase ((i,_),t, pv) ->
+ let e =
+ if i <> Coinductive 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)))
+ | MLfix (i,ids,defs) ->
+ let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
+ pp_fix env' i (Array.of_list (List.rev ids'),defs) args
+ | MLexn s ->
+ (* An [MLexn] may be applied, but I don't really care. *)
+ paren (str "error" ++ spc () ++ qs s)
+ | MLdummy ->
+ str "__" (* An [MLdummy] may be applied, but I don't really care. *)
+ | MLmagic a ->
+ pp_expr env args a
+ | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"")
+
+and pp_cons_args env = function
+ | MLcons (i,r,args) when i<>Coinductive ->
+ 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) =
+ let ids,env' = push_vars (List.rev_map id_of_mlid ids) env in
+ let args =
+ if ids = [] then mt ()
+ else (str " " ++ prlist_with_sep spc pr_id (List.rev ids))
+ in
+ (pp_global Cons r ++ args), (pp_expr env' [] t)
+
+and pp_pat env pv =
+ prvect_with_sep fnl
+ (fun x -> let s1,s2 = pp_one_pat env x in
+ hov 2 (str "((" ++ s1 ++ str ")" ++ spc () ++ s2 ++ str ")")) pv
+
+(*s names of the functions ([ids]) are already pushed in [env],
+ and passed here just for convenience. *)
+
+and pp_fix env j (ids,bl) args =
+ paren
+ (str "letrec " ++
+ (v 0 (paren
+ (prvect_with_sep fnl
+ (fun (fi,ti) ->
+ paren ((pr_id fi) ++ spc () ++ (pp_expr env [] ti)))
+ (array_map2 (fun id b -> (id,b)) ids bl)) ++
+ fnl () ++
+ hov 2 (pp_apply (pr_id (ids.(j))) true args))))
+
+(*s Pretty-printing of a declaration. *)
+
+let pp_decl = function
+ | Dind _ -> mt ()
+ | Dtype _ -> mt ()
+ | Dfix (rv, defs,_) ->
+ let ppv = Array.map (pp_global Term) rv in
+ prvect_with_sep fnl
+ (fun (pi,ti) ->
+ hov 2
+ (paren (str "define " ++ pi ++ spc () ++
+ (pp_expr (empty_env ()) [] ti))
+ ++ fnl ()))
+ (array_map2 (fun p b -> (p,b)) ppv defs) ++
+ fnl ()
+ | Dterm (r, a, _) ->
+ if is_inline_custom r then mt ()
+ else
+ if is_custom r then
+ hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++
+ str (find_custom r))) ++ fnl () ++ fnl ()
+ else
+ hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++
+ pp_expr (empty_env ()) [] a)) ++ fnl () ++ fnl ()
+
+let rec pp_structure_elem = function
+ | (l,SEdecl d) -> pp_decl d
+ | (l,SEmodule m) -> pp_module_expr m.ml_mod_expr
+ | (l,SEmodtype m) -> mt ()
+ (* for the moment we simply discard module type *)
+
+and pp_module_expr = function
+ | MEstruct (mp,sel) -> prlist_strict pp_structure_elem sel
+ | MEfunctor _ -> mt ()
+ (* for the moment we simply discard unapplied functors *)
+ | MEident _ | MEapply _ -> assert false
+ (* should be expansed in extract_env *)
+
+let pp_struct =
+ let pp_sel (mp,sel) =
+ push_visible mp [];
+ let p = prlist_strict pp_structure_elem sel in
+ pop_visible (); p
+ in
+ prlist_strict pp_sel
+
+let scheme_descr = {
+ keywords = keywords;
+ file_suffix = ".scm";
+ preamble = preamble;
+ pp_struct = pp_struct;
+ sig_suffix = None;
+ sig_preamble = (fun _ _ _ -> mt ());
+ pp_sig = (fun _ -> mt ());
+ pp_decl = pp_decl;
+}
diff --git a/plugins/extraction/scheme.mli b/plugins/extraction/scheme.mli
new file mode 100644
index 00000000..b0fa395c
--- /dev/null
+++ b/plugins/extraction/scheme.mli
@@ -0,0 +1,11 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+val scheme_descr : Miniml.language_descr
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
new file mode 100644
index 00000000..685b84fc
--- /dev/null
+++ b/plugins/extraction/table.ml
@@ -0,0 +1,767 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Names
+open Term
+open Declarations
+open Nameops
+open Namegen
+open Summary
+open Libobject
+open Goptions
+open Libnames
+open Util
+open Pp
+open Miniml
+
+(*S Utilities about [module_path] and [kernel_names] and [global_reference] *)
+
+let occur_kn_in_ref kn = function
+ | IndRef (kn',_)
+ | ConstructRef ((kn',_),_) -> kn = kn'
+ | ConstRef _ -> false
+ | VarRef _ -> assert false
+
+let repr_of_r = function
+ | ConstRef kn -> repr_con kn
+ | IndRef (kn,_)
+ | ConstructRef ((kn,_),_) -> repr_mind kn
+ | VarRef _ -> assert false
+
+let modpath_of_r r =
+ let mp,_,_ = repr_of_r r in mp
+
+let label_of_r r =
+ let _,_,l = repr_of_r r in l
+
+let rec base_mp = function
+ | MPdot (mp,l) -> base_mp mp
+ | mp -> mp
+
+let is_modfile = function
+ | MPfile _ -> true
+ | _ -> false
+
+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 =
+ mp = initial_path || mp = current_toplevel ()
+
+let at_toplevel mp =
+ is_modfile mp || is_toplevel mp
+
+let rec mp_length mp =
+ let mp0 = current_toplevel () in
+ let rec len = function
+ | mp when mp = mp0 -> 1
+ | MPdot (mp,_) -> 1 + len mp
+ | _ -> 1
+ in len mp
+
+let visible_con kn = at_toplevel (base_mp (con_modpath kn))
+
+let rec prefixes_mp mp = match mp with
+ | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp')
+ | _ -> MPset.singleton mp
+
+let rec get_nth_label_mp n = function
+ | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp
+ | _ -> failwith "get_nth_label: not enough MPdot"
+
+let common_prefix_from_list mp0 mpl =
+ let prefixes = prefixes_mp mp0 in
+ let rec f = function
+ | [] -> None
+ | 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
+ | mp -> mp,ll
+
+let labels_of_ref r =
+ let mp_top = current_toplevel () in
+ 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, ... *)
+
+(* Theses tables are not registered within coq save/undo mechanism
+ since we reset their contents at each run of Extraction *)
+
+(*s Constants tables. *)
+
+let terms = ref (Cmap.empty : ml_decl Cmap.t)
+let init_terms () = terms := Cmap.empty
+let add_term kn d = terms := Cmap.add kn d !terms
+let lookup_term kn = Cmap.find kn !terms
+
+let types = ref (Cmap.empty : ml_schema Cmap.t)
+let init_types () = types := Cmap.empty
+let add_type kn s = types := Cmap.add kn s !types
+let lookup_type kn = Cmap.find kn !types
+
+(*s Inductives table. *)
+
+let inductives = ref (Mindmap.empty : (mutual_inductive_body * ml_ind) Mindmap.t)
+let init_inductives () = inductives := Mindmap.empty
+let add_ind kn mib ml_ind = inductives := Mindmap.add kn (mib,ml_ind) !inductives
+let lookup_ind kn = Mindmap.find kn !inductives
+
+(*s Recursors table. *)
+
+let recursors = ref Cset.empty
+let init_recursors () = recursors := Cset.empty
+
+let add_recursors env kn =
+ let make_kn id = make_con (mind_modpath kn) empty_dirpath (label_of_id id) in
+ let mib = Environ.lookup_mind kn env in
+ Array.iter
+ (fun mip ->
+ let id = mip.mind_typename in
+ let kn_rec = make_kn (Nameops.add_suffix id "_rec")
+ and kn_rect = make_kn (Nameops.add_suffix id "_rect") in
+ recursors := Cset.add kn_rec (Cset.add kn_rect !recursors))
+ mib.mind_packets
+
+let is_recursor = function
+ | ConstRef kn -> Cset.mem kn !recursors
+ | _ -> false
+
+(*s Record tables. *)
+
+let projs = ref (Refmap.empty : int Refmap.t)
+let init_projs () = projs := Refmap.empty
+let add_projection n kn = projs := Refmap.add (ConstRef kn) n !projs
+let is_projection r = Refmap.mem r !projs
+let projection_arity r = Refmap.find r !projs
+
+(*s Table of used axioms *)
+
+let info_axioms = ref Refset.empty
+let log_axioms = ref Refset.empty
+let init_axioms () = info_axioms := Refset.empty; log_axioms := Refset.empty
+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 modular_ref = ref false
+
+let set_modular b = modular_ref := b
+let modular () = !modular_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
+
+let string_of_global r =
+ try string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty r)
+ with _ -> string_of_id (safe_basename_of_global r)
+
+let safe_pr_global r = str (string_of_global r)
+
+(* idem, but with qualification, and only for constants. *)
+
+let safe_pr_long_global r =
+ try Printer.pr_global r
+ with _ -> match r with
+ | ConstRef kn ->
+ let mp,_,l = repr_con kn in
+ str ((string_of_mp mp)^"."^(string_of_label l))
+ | _ -> assert false
+
+let pr_long_mp mp =
+ let lid = repr_dirpath (Nametab.dirpath_of_module mp) in
+ str (String.concat "." (List.map string_of_id (List.rev lid)))
+
+let pr_long_global ref = pr_path (Nametab.path_of_global ref)
+
+(*S Warning and Error messages. *)
+
+let err s = errorlabstrm "Extraction" s
+
+let warning_axioms () =
+ let info_axioms = Refset.elements !info_axioms in
+ if info_axioms = [] then ()
+ else begin
+ let s = if List.length info_axioms = 1 then "axiom" else "axioms" in
+ msg_warning
+ (str ("The following "^s^" must be realized in the extracted code:")
+ ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms)
+ ++ str "." ++ fnl ())
+ end;
+ let log_axioms = Refset.elements !log_axioms in
+ if log_axioms = [] then ()
+ else begin
+ let s = if List.length log_axioms = 1 then "axiom was" else "axioms were"
+ in
+ msg_warning
+ (str ("The following logical "^s^" encountered:") ++
+ hov 1
+ (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n")
+ ++
+ str "Having invalid logical axiom in the environment when extracting" ++
+ spc () ++ str "may lead to incorrect or non-terminating ML terms." ++
+ fnl ())
+ end
+
+let warning_both_mod_and_cst q mp r =
+ msg_warning
+ (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++
+ str "do you mean module " ++
+ pr_long_mp mp ++
+ str " or object " ++
+ pr_long_global r ++ str " ?" ++ fnl () ++
+ str "First choice is assumed, for the second one please use " ++
+ str "fully qualified name." ++ fnl ())
+
+let error_axiom_scheme r i =
+ err (str "The type scheme axiom " ++ spc () ++
+ safe_pr_global r ++ spc () ++ str "needs " ++ pr_int i ++
+ str " type variable(s).")
+
+let check_inside_module () =
+ if Lib.is_modtype () then
+ err (str "You can't do that within a Module Type." ++ fnl () ++
+ str "Close it and try again.")
+ else if Lib.is_module () then
+ msg_warning
+ (str "Extraction inside an opened module is experimental.\n" ++
+ str "In case of problem, close it first.\n")
+
+let check_inside_section () =
+ if Lib.sections_are_opened () then
+ err (str "You can't do that within a section." ++ fnl () ++
+ str "Close it and try again.")
+
+let warning_id s =
+ msg_warning (str ("The identifier "^s^
+ " contains __ which is reserved for the extraction"))
+
+let error_constant r =
+ err (safe_pr_global r ++ str " is not a constant.")
+
+let error_inductive r =
+ err (safe_pr_global r ++ spc () ++ str "is not an inductive type.")
+
+let error_nb_cons () =
+ err (str "Not the right number of constructors.")
+
+let error_module_clash mp1 mp2 =
+ err (str "The Coq modules " ++ pr_long_mp mp1 ++ str " and " ++
+ pr_long_mp mp2 ++ str " have the same ML name.\n" ++
+ str "This is not supported yet. Please do some renaming first.")
+
+let error_unknown_module m =
+ err (str "Module" ++ spc () ++ pr_qualid m ++ spc () ++ str "not found.")
+
+let error_scheme () =
+ err (str "No Scheme modular extraction available yet.")
+
+let error_not_visible r =
+ err (safe_pr_global r ++ str " is not directly visible.\n" ++
+ str "For example, it may be inside an applied functor.\n" ++
+ str "Use Recursive Extraction to get the whole environment.")
+
+let error_MPfile_as_mod mp b =
+ let s1 = if b then "asked" else "required" in
+ let s2 = if b then "extract some objects of this module or\n" else "" in
+ err (str ("Extraction of file "^(raw_string_of_modfile mp)^
+ ".v as a module is "^s1^".\n"^
+ "Monolithic Extraction cannot deal with this situation.\n"^
+ "Please "^s2^"use (Recursive) Extraction Library instead.\n"))
+
+let error_record r =
+ err (str "Record " ++ safe_pr_global r ++ str " has an anonymous field." ++
+ fnl () ++ str "To help extraction, please use an explicit name.")
+
+let msg_non_implicit r n id =
+ let name = match id with
+ | Anonymous -> ""
+ | Name id -> "(" ^ string_of_id id ^ ") "
+ in
+ "The " ^ (ordinal n) ^ " argument " ^ name ^ "of " ^ (string_of_global r)
+
+let error_non_implicit msg =
+ err (str (msg ^ " still occurs after extraction.") ++
+ fnl () ++ str "Please check the Extraction Implicit declarations.")
+
+let check_loaded_modfile mp = match base_mp mp with
+ | MPfile dp ->
+ if not (Library.library_is_loaded dp) then begin
+ match base_mp (current_toplevel ()) with
+ | MPfile dp' when dp<>dp' ->
+ err (str ("Please load library "^(string_of_dirpath dp^" first.")))
+ | _ -> ()
+ end
+ | _ -> ()
+
+let info_file f =
+ Flags.if_verbose message
+ ("The file "^f^" has been created by extraction.")
+
+
+(*S The Extraction auxiliary commands *)
+
+(* The objects defined below should survive an arbitrary time,
+ so we register them to coq save/undo mechanism. *)
+
+(*s Extraction AutoInline *)
+
+let auto_inline_ref = ref false
+
+let auto_inline () = !auto_inline_ref
+
+let _ = declare_bool_option
+ {optsync = true;
+ optname = "Extraction AutoInline";
+ optkey = ["Extraction"; "AutoInline"];
+ optread = auto_inline;
+ optwrite = (:=) auto_inline_ref}
+
+(*s Extraction TypeExpand *)
+
+let type_expand_ref = ref true
+
+let type_expand () = !type_expand_ref
+
+let _ = declare_bool_option
+ {optsync = true;
+ optname = "Extraction TypeExpand";
+ optkey = ["Extraction"; "TypeExpand"];
+ optread = type_expand;
+ optwrite = (:=) type_expand_ref}
+
+(*s Extraction Optimize *)
+
+type opt_flag =
+ { opt_kill_dum : bool; (* 1 *)
+ opt_fix_fun : bool; (* 2 *)
+ opt_case_iot : bool; (* 4 *)
+ opt_case_idr : bool; (* 8 *)
+ opt_case_idg : bool; (* 16 *)
+ opt_case_cst : bool; (* 32 *)
+ opt_case_fun : bool; (* 64 *)
+ opt_case_app : bool; (* 128 *)
+ opt_let_app : bool; (* 256 *)
+ opt_lin_let : bool; (* 512 *)
+ opt_lin_beta : bool } (* 1024 *)
+
+let kth_digit n k = (n land (1 lsl k) <> 0)
+
+let flag_of_int n =
+ { opt_kill_dum = kth_digit n 0;
+ opt_fix_fun = kth_digit n 1;
+ opt_case_iot = kth_digit n 2;
+ opt_case_idr = kth_digit n 3;
+ opt_case_idg = kth_digit n 4;
+ opt_case_cst = kth_digit n 5;
+ opt_case_fun = kth_digit n 6;
+ opt_case_app = kth_digit n 7;
+ opt_let_app = kth_digit n 8;
+ opt_lin_let = kth_digit n 9;
+ opt_lin_beta = kth_digit n 10 }
+
+(* For the moment, we allow by default everything except :
+ - the type-unsafe optimization [opt_case_idg]
+ - the linear let and beta reduction [opt_lin_let] and [opt_lin_beta]
+ (may lead to complexity blow-up, subsumed by finer reductions
+ when inlining recursors).
+*)
+
+let int_flag_init = 1 + 2 + 4 + 8 (*+ 16*) + 32 + 64 + 128 + 256 (*+ 512 + 1024*)
+
+let int_flag_ref = ref int_flag_init
+let opt_flag_ref = ref (flag_of_int int_flag_init)
+
+let chg_flag n = int_flag_ref := n; opt_flag_ref := flag_of_int n
+
+let optims () = !opt_flag_ref
+
+let _ = declare_bool_option
+ {optsync = true;
+ optname = "Extraction Optimize";
+ optkey = ["Extraction"; "Optimize"];
+ optread = (fun () -> !int_flag_ref <> 0);
+ optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))}
+
+let _ = declare_int_option
+ { optsync = true;
+ optname = "Extraction Flag";
+ optkey = ["Extraction";"Flag"];
+ optread = (fun _ -> Some !int_flag_ref);
+ optwrite = (function
+ | None -> chg_flag 0
+ | Some i -> chg_flag (max i 0))}
+
+
+(*s Extraction Lang *)
+
+type lang = Ocaml | Haskell | Scheme
+
+let lang_ref = ref Ocaml
+
+let lang () = !lang_ref
+
+let (extr_lang,_) =
+ declare_object
+ {(default_object "Extraction Lang") with
+ cache_function = (fun (_,l) -> lang_ref := l);
+ load_function = (fun _ (_,l) -> lang_ref := l)}
+
+let _ = declare_summary "Extraction Lang"
+ { freeze_function = (fun () -> !lang_ref);
+ unfreeze_function = ((:=) lang_ref);
+ init_function = (fun () -> lang_ref := Ocaml) }
+
+let extraction_language x = Lib.add_anonymous_leaf (extr_lang x)
+
+(*s Extraction Inline/NoInline *)
+
+let empty_inline_table = (Refset.empty,Refset.empty)
+
+let inline_table = ref empty_inline_table
+
+let to_inline r = Refset.mem r (fst !inline_table)
+
+let to_keep r = Refset.mem r (snd !inline_table)
+
+let add_inline_entries b l =
+ let f b = if b then Refset.add else Refset.remove in
+ let i,k = !inline_table in
+ inline_table :=
+ (List.fold_right (f b) l i),
+ (List.fold_right (f (not b)) l k)
+
+(* Registration of operations for rollback. *)
+
+let (inline_extraction,_) =
+ declare_object
+ {(default_object "Extraction Inline") with
+ cache_function = (fun (_,(b,l)) -> add_inline_entries b l);
+ load_function = (fun _ (_,(b,l)) -> add_inline_entries b l);
+ classify_function = (fun o -> Substitute o);
+ subst_function =
+ (fun (s,(b,l)) -> (b,(List.map (fun x -> fst (subst_global s x)) l)))
+ }
+
+let _ = declare_summary "Extraction Inline"
+ { freeze_function = (fun () -> !inline_table);
+ unfreeze_function = ((:=) inline_table);
+ init_function = (fun () -> inline_table := empty_inline_table) }
+
+(* Grammar entries. *)
+
+let extraction_inline b l =
+ check_inside_section ();
+ let refs = List.map Nametab.global l in
+ List.iter
+ (fun r -> match r with
+ | ConstRef _ -> ()
+ | _ -> error_constant r) refs;
+ Lib.add_anonymous_leaf (inline_extraction (b,refs))
+
+(* Printing part *)
+
+let print_extraction_inline () =
+ let (i,n)= !inline_table in
+ let i'= Refset.filter (function ConstRef _ -> true | _ -> false) i in
+ msg
+ (str "Extraction Inline:" ++ fnl () ++
+ Refset.fold
+ (fun r p ->
+ (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) i' (mt ()) ++
+ str "Extraction NoInline:" ++ fnl () ++
+ Refset.fold
+ (fun r p ->
+ (p ++ str " " ++ safe_pr_long_global r ++ fnl ())) n (mt ()))
+
+(* Reset part *)
+
+let (reset_inline,_) =
+ declare_object
+ {(default_object "Reset Extraction Inline") with
+ cache_function = (fun (_,_)-> inline_table := empty_inline_table);
+ load_function = (fun _ (_,_)-> inline_table := empty_inline_table)}
+
+let reset_extraction_inline () = Lib.add_anonymous_leaf (reset_inline ())
+
+(*s Extraction Implicit *)
+
+type int_or_id = ArgInt of int | ArgId of identifier
+
+let implicits_table = ref Refmap.empty
+
+let implicits_of_global r =
+ try Refmap.find r !implicits_table with Not_found -> []
+
+let add_implicits r l =
+ let typ = Global.type_of_global r in
+ let rels,_ =
+ decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in
+ let names = List.rev_map fst rels in
+ let n = List.length names in
+ let check = function
+ | ArgInt i ->
+ if 1 <= i && i <= n then i
+ else err (int i ++ str " is not a valid argument number for " ++
+ safe_pr_global r)
+ | ArgId id ->
+ (try list_index (Name id) names
+ with Not_found ->
+ err (str "No argument " ++ pr_id id ++ str " for " ++
+ safe_pr_global r))
+ in
+ let l' = List.map check l in
+ implicits_table := Refmap.add r l' !implicits_table
+
+(* Registration of operations for rollback. *)
+
+let (implicit_extraction,_) =
+ declare_object
+ {(default_object "Extraction Implicit") with
+ cache_function = (fun (_,(r,l)) -> add_implicits r l);
+ load_function = (fun _ (_,(r,l)) -> add_implicits r l);
+ classify_function = (fun o -> Substitute o);
+ subst_function = (fun (s,(r,l)) -> (fst (subst_global s r), l))
+ }
+
+let _ = declare_summary "Extraction Implicit"
+ { freeze_function = (fun () -> !implicits_table);
+ unfreeze_function = ((:=) implicits_table);
+ init_function = (fun () -> implicits_table := Refmap.empty) }
+
+(* Grammar entries. *)
+
+let extraction_implicit r l =
+ check_inside_section ();
+ Lib.add_anonymous_leaf (implicit_extraction (Nametab.global r,l))
+
+
+(*s Extraction Blacklist of filenames not to use while extracting *)
+
+let blacklist_table = ref Idset.empty
+
+let modfile_ids = ref []
+let modfile_mps = ref MPmap.empty
+
+let reset_modfile () =
+ modfile_ids := Idset.elements !blacklist_table;
+ modfile_mps := MPmap.empty
+
+let string_of_modfile mp =
+ try MPmap.find mp !modfile_mps
+ with Not_found ->
+ let id = id_of_string (raw_string_of_modfile mp) in
+ let id' = next_ident_away id !modfile_ids in
+ let s' = string_of_id id' in
+ modfile_ids := id' :: !modfile_ids;
+ modfile_mps := MPmap.add mp s' !modfile_mps;
+ s'
+
+(* same as [string_of_modfile], but preserves the capital/uncapital 1st char *)
+
+let file_of_modfile mp =
+ let s0 = match mp with
+ | MPfile f -> string_of_id (List.hd (repr_dirpath f))
+ | _ -> assert false
+ in
+ let s = String.copy (string_of_modfile mp) in
+ if s.[0] <> s0.[0] then s.[0] <- s0.[0];
+ s
+
+let add_blacklist_entries l =
+ blacklist_table :=
+ List.fold_right (fun s -> Idset.add (id_of_string (String.capitalize s)))
+ l !blacklist_table
+
+(* Registration of operations for rollback. *)
+
+let (blacklist_extraction,_) =
+ 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)
+ }
+
+let _ = declare_summary "Extraction Blacklist"
+ { freeze_function = (fun () -> !blacklist_table);
+ unfreeze_function = ((:=) blacklist_table);
+ init_function = (fun () -> blacklist_table := Idset.empty) }
+
+(* Grammar entries. *)
+
+let extraction_blacklist l =
+ let l = List.rev_map string_of_id l in
+ Lib.add_anonymous_leaf (blacklist_extraction l)
+
+(* Printing part *)
+
+let print_extraction_blacklist () =
+ msgnl
+ (prlist_with_sep fnl pr_id (Idset.elements !blacklist_table))
+
+(* Reset part *)
+
+let (reset_blacklist,_) =
+ declare_object
+ {(default_object "Reset Extraction Blacklist") with
+ cache_function = (fun (_,_)-> blacklist_table := Idset.empty);
+ load_function = (fun _ (_,_)-> blacklist_table := Idset.empty)}
+
+let reset_extraction_blacklist () = Lib.add_anonymous_leaf (reset_blacklist ())
+
+(*s Extract Constant/Inductive. *)
+
+(* UGLY HACK: to be defined in [extraction.ml] *)
+let use_type_scheme_nb_args, register_type_scheme_nb_args =
+ let r = ref (fun _ _ -> 0) in (fun x y -> !r x y), (:=) r
+
+let customs = ref Refmap.empty
+
+let add_custom r ids s = customs := Refmap.add r (ids,s) !customs
+
+let is_custom r = Refmap.mem r !customs
+
+let is_inline_custom r = (is_custom r) && (to_inline r)
+
+let find_custom r = snd (Refmap.find r !customs)
+
+let find_type_custom r = Refmap.find r !customs
+
+let custom_matchs = ref Refmap.empty
+
+let add_custom_match r s =
+ custom_matchs := Refmap.add r s !custom_matchs
+
+let indref_of_match pv =
+ if Array.length pv = 0 then raise Not_found;
+ match pv.(0) with
+ | (ConstructRef (ip,_), _, _) -> IndRef ip
+ | _ -> raise Not_found
+
+let is_custom_match pv =
+ try Refmap.mem (indref_of_match pv) !custom_matchs
+ with Not_found -> false
+
+let find_custom_match pv =
+ Refmap.find (indref_of_match pv) !custom_matchs
+
+(* Registration of operations for rollback. *)
+
+let (in_customs,_) =
+ declare_object
+ {(default_object "ML extractions") with
+ cache_function = (fun (_,(r,ids,s)) -> add_custom r ids s);
+ load_function = (fun _ (_,(r,ids,s)) -> add_custom r ids s);
+ classify_function = (fun o -> Substitute o);
+ subst_function =
+ (fun (s,(r,ids,str)) -> (fst (subst_global s r), ids, str))
+ }
+
+let _ = declare_summary "ML extractions"
+ { freeze_function = (fun () -> !customs);
+ unfreeze_function = ((:=) customs);
+ init_function = (fun () -> customs := Refmap.empty) }
+
+let (in_custom_matchs,_) =
+ declare_object
+ {(default_object "ML extractions custom matchs") with
+ cache_function = (fun (_,(r,s)) -> add_custom_match r s);
+ load_function = (fun _ (_,(r,s)) -> add_custom_match r s);
+ classify_function = (fun o -> Substitute o);
+ subst_function = (fun (subs,(r,s)) -> (fst (subst_global subs r), s))
+ }
+
+let _ = declare_summary "ML extractions custom match"
+ { freeze_function = (fun () -> !custom_matchs);
+ unfreeze_function = ((:=) custom_matchs);
+ init_function = (fun () -> custom_matchs := Refmap.empty) }
+
+(* Grammar entries. *)
+
+let extract_constant_inline inline r ids s =
+ check_inside_section ();
+ let g = Nametab.global r in
+ match g with
+ | ConstRef kn ->
+ let env = Global.env () in
+ let typ = Typeops.type_of_constant env kn in
+ let typ = Reduction.whd_betadeltaiota env typ in
+ if Reduction.is_arity env typ
+ then begin
+ let nargs = use_type_scheme_nb_args env typ in
+ if List.length ids <> nargs then error_axiom_scheme g nargs
+ end;
+ Lib.add_anonymous_leaf (inline_extraction (inline,[g]));
+ Lib.add_anonymous_leaf (in_customs (g,ids,s))
+ | _ -> error_constant g
+
+
+let extract_inductive r s l optstr =
+ check_inside_section ();
+ let g = Nametab.global r in
+ match g with
+ | IndRef ((kn,i) as ip) ->
+ let mib = Global.lookup_mind kn in
+ let n = Array.length mib.mind_packets.(i).mind_consnames in
+ if n <> List.length l then error_nb_cons ();
+ Lib.add_anonymous_leaf (inline_extraction (true,[g]));
+ Lib.add_anonymous_leaf (in_customs (g,[],s));
+ Option.iter (fun s -> Lib.add_anonymous_leaf (in_custom_matchs (g,s)))
+ optstr;
+ list_iter_i
+ (fun j s ->
+ let g = ConstructRef (ip,succ j) in
+ Lib.add_anonymous_leaf (inline_extraction (true,[g]));
+ Lib.add_anonymous_leaf (in_customs (g,[],s))) l
+ | _ -> error_inductive g
+
+
+
+(*s Tables synchronization. *)
+
+let reset_tables () =
+ init_terms (); init_types (); init_inductives (); init_recursors ();
+ init_projs (); init_axioms (); reset_modfile ()
diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli
new file mode 100644
index 00000000..ae46233d
--- /dev/null
+++ b/plugins/extraction/table.mli
@@ -0,0 +1,167 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Names
+open Libnames
+open Miniml
+open Declarations
+
+val safe_basename_of_global : global_reference -> identifier
+
+(*s Warning and Error messages. *)
+
+val warning_axioms : unit -> unit
+val warning_both_mod_and_cst :
+ qualid -> module_path -> global_reference -> unit
+val warning_id : string -> unit
+val error_axiom_scheme : global_reference -> int -> 'a
+val error_constant : global_reference -> 'a
+val error_inductive : global_reference -> 'a
+val error_nb_cons : unit -> 'a
+val error_module_clash : module_path -> module_path -> 'a
+val error_unknown_module : qualid -> 'a
+val error_scheme : unit -> 'a
+val error_not_visible : global_reference -> 'a
+val error_MPfile_as_mod : module_path -> bool -> 'a
+val error_record : global_reference -> 'a
+val check_inside_module : unit -> unit
+val check_inside_section : unit -> unit
+val check_loaded_modfile : module_path -> unit
+val msg_non_implicit : global_reference -> int -> name -> string
+val error_non_implicit : string -> 'a
+
+val info_file : string -> unit
+
+(*s utilities about [module_path] and [kernel_names] and [global_reference] *)
+
+val occur_kn_in_ref : mutual_inductive -> global_reference -> bool
+val repr_of_r : global_reference -> module_path * dir_path * label
+val modpath_of_r : global_reference -> module_path
+val label_of_r : global_reference -> label
+val current_toplevel : unit -> module_path
+val base_mp : module_path -> module_path
+val is_modfile : module_path -> bool
+val string_of_modfile : module_path -> string
+val file_of_modfile : module_path -> string
+val is_toplevel : module_path -> bool
+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
+
+(*s Some table-related operations *)
+
+val add_term : constant -> ml_decl -> unit
+val lookup_term : constant -> ml_decl
+
+val add_type : constant -> ml_schema -> unit
+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_recursors : Environ.env -> mutual_inductive -> unit
+val is_recursor : global_reference -> bool
+
+val add_projection : int -> constant -> unit
+val is_projection : global_reference -> bool
+val projection_arity : global_reference -> int
+
+val add_info_axiom : global_reference -> unit
+val remove_info_axiom : global_reference -> unit
+val add_log_axiom : global_reference -> unit
+
+val reset_tables : unit -> unit
+
+(*s AutoInline parameter *)
+
+val auto_inline : unit -> bool
+
+(*s TypeExpand parameter *)
+
+val type_expand : unit -> bool
+
+(*s Optimize parameter *)
+
+type opt_flag =
+ { opt_kill_dum : bool; (* 1 *)
+ opt_fix_fun : bool; (* 2 *)
+ opt_case_iot : bool; (* 4 *)
+ opt_case_idr : bool; (* 8 *)
+ opt_case_idg : bool; (* 16 *)
+ opt_case_cst : bool; (* 32 *)
+ opt_case_fun : bool; (* 64 *)
+ opt_case_app : bool; (* 128 *)
+ opt_let_app : bool; (* 256 *)
+ opt_lin_let : bool; (* 512 *)
+ opt_lin_beta : bool } (* 1024 *)
+
+val optims : unit -> opt_flag
+
+(*s Target language. *)
+
+type lang = Ocaml | Haskell | Scheme
+val lang : unit -> lang
+
+(*s Extraction mode: modular or monolithic *)
+
+val set_modular : bool -> unit
+val modular : unit -> bool
+
+(*s Table for custom inlining *)
+
+val to_inline : global_reference -> bool
+val to_keep : global_reference -> bool
+
+(*s Table for implicits arguments *)
+
+val implicits_of_global : global_reference -> int list
+
+(*s Table for user-given custom ML extractions. *)
+
+(* UGLY HACK: registration of a function defined in [extraction.ml] *)
+val register_type_scheme_nb_args : (Environ.env -> Term.constr -> int) -> unit
+
+val is_custom : global_reference -> bool
+val is_inline_custom : global_reference -> bool
+val find_custom : global_reference -> string
+val find_type_custom : global_reference -> string list * string
+
+val is_custom_match : ml_branch array -> bool
+val find_custom_match : ml_branch array -> string
+
+(*s Extraction commands. *)
+
+val extraction_language : lang -> unit
+val extraction_inline : bool -> reference list -> unit
+val print_extraction_inline : unit -> unit
+val reset_extraction_inline : unit -> unit
+val extract_constant_inline :
+ bool -> reference -> string list -> string -> unit
+val extract_inductive :
+ reference -> string -> string list -> string option -> unit
+
+type int_or_id = ArgInt of int | ArgId of identifier
+val extraction_implicit : reference -> int_or_id list -> unit
+
+(*s Table of blacklisted filenames *)
+
+val extraction_blacklist : identifier list -> unit
+val reset_extraction_blacklist : unit -> unit
+val print_extraction_blacklist : unit -> unit
+
+
+
diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget
new file mode 100644
index 00000000..1fe09f6f
--- /dev/null
+++ b/plugins/extraction/vo.itarget
@@ -0,0 +1,8 @@
+ExtrOcamlBasic.vo
+ExtrOcamlIntConv.vo
+ExtrOcamlBigIntConv.vo
+ExtrOcamlNatInt.vo
+ExtrOcamlNatBigInt.vo
+ExtrOcamlZInt.vo
+ExtrOcamlZBigInt.vo
+ExtrOcamlString.vo \ No newline at end of file
diff --git a/plugins/field/LegacyField.v b/plugins/field/LegacyField.v
new file mode 100644
index 00000000..efa53b4e
--- /dev/null
+++ b/plugins/field/LegacyField.v
@@ -0,0 +1,16 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Export LegacyField_Compl.
+Require Export LegacyField_Theory.
+Require Export LegacyField_Tactic.
+Declare ML Module "field_plugin".
+
+(* Command declarations are moved to the ML side *)
diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v
new file mode 100644
index 00000000..d4a39296
--- /dev/null
+++ b/plugins/field/LegacyField_Compl.v
@@ -0,0 +1,38 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Import List.
+
+Definition assoc_2nd :=
+ (fix assoc_2nd_rec (A:Type) (B:Set)
+ (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
+ (lst:list (prod A B)) {struct lst} :
+ B -> A -> A :=
+ fun (key:B) (default:A) =>
+ match lst with
+ | nil => default
+ | (v,e) :: l =>
+ match eq_dec e key with
+ | left _ => v
+ | right _ => assoc_2nd_rec A B eq_dec l key default
+ end
+ end).
+
+Definition mem :=
+ (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2})
+ (a:A) (l:list A) {struct l} : bool :=
+ match l with
+ | nil => false
+ | a1 :: l1 =>
+ match eq_dec a a1 with
+ | left _ => true
+ | right _ => mem A eq_dec a l1
+ end
+ end).
diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v
new file mode 100644
index 00000000..5c1f228a
--- /dev/null
+++ b/plugins/field/LegacyField_Tactic.v
@@ -0,0 +1,433 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Import List.
+Require Import LegacyRing.
+Require Export LegacyField_Compl.
+Require Export LegacyField_Theory.
+
+(**** Interpretation A --> ExprA ****)
+
+Ltac get_component a s := eval cbv beta iota delta [a] in (a s).
+
+Ltac body_of s := eval cbv beta iota delta [s] in s.
+
+Ltac mem_assoc var lvar :=
+ match constr:lvar with
+ | nil => constr:false
+ | ?X1 :: ?X2 =>
+ match constr:(X1 = var) with
+ | (?X1 = ?X1) => constr:true
+ | _ => mem_assoc var X2
+ end
+ end.
+
+Ltac number lvar :=
+ let rec number_aux lvar cpt :=
+ match constr:lvar with
+ | (@nil ?X1) => constr:(@nil (prod X1 nat))
+ | ?X2 :: ?X3 =>
+ let l2 := number_aux X3 (S cpt) in
+ constr:((X2,cpt) :: l2)
+ end
+ in number_aux lvar 0.
+
+Ltac build_varlist FT trm :=
+ let rec seek_var lvar trm :=
+ let AT := get_component A FT
+ with AzeroT := get_component Azero FT
+ with AoneT := get_component Aone FT
+ with AplusT := get_component Aplus FT
+ with AmultT := get_component Amult FT
+ with AoppT := get_component Aopp FT
+ with AinvT := get_component Ainv FT in
+ match constr:trm with
+ | AzeroT => lvar
+ | AoneT => lvar
+ | (AplusT ?X1 ?X2) =>
+ let l1 := seek_var lvar X1 in
+ seek_var l1 X2
+ | (AmultT ?X1 ?X2) =>
+ let l1 := seek_var lvar X1 in
+ seek_var l1 X2
+ | (AoppT ?X1) => seek_var lvar X1
+ | (AinvT ?X1) => seek_var lvar X1
+ | ?X1 =>
+ let res := mem_assoc X1 lvar in
+ match constr:res with
+ | true => lvar
+ | false => constr:(X1 :: lvar)
+ end
+ end in
+ let AT := get_component A FT in
+ let lvar := seek_var (@nil AT) trm in
+ number lvar.
+
+Ltac assoc elt lst :=
+ match constr:lst with
+ | nil => fail
+ | (?X1,?X2) :: ?X3 =>
+ match constr:(elt = X1) with
+ | (?X1 = ?X1) => constr:X2
+ | _ => assoc elt X3
+ end
+ end.
+
+Ltac interp_A FT lvar trm :=
+ let AT := get_component A FT
+ with AzeroT := get_component Azero FT
+ with AoneT := get_component Aone FT
+ with AplusT := get_component Aplus FT
+ with AmultT := get_component Amult FT
+ with AoppT := get_component Aopp FT
+ with AinvT := get_component Ainv FT in
+ match constr:trm with
+ | AzeroT => constr:EAzero
+ | AoneT => constr:EAone
+ | (AplusT ?X1 ?X2) =>
+ let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
+ constr:(EAplus e1 e2)
+ | (AmultT ?X1 ?X2) =>
+ let e1 := interp_A FT lvar X1 with e2 := interp_A FT lvar X2 in
+ constr:(EAmult e1 e2)
+ | (AoppT ?X1) =>
+ let e := interp_A FT lvar X1 in
+ constr:(EAopp e)
+ | (AinvT ?X1) => let e := interp_A FT lvar X1 in
+ constr:(EAinv e)
+ | ?X1 => let idx := assoc X1 lvar in
+ constr:(EAvar idx)
+ end.
+
+(************************)
+(* Simplification *)
+(************************)
+
+(**** Generation of the multiplier ****)
+
+Ltac remove e l :=
+ match constr:l with
+ | nil => l
+ | e :: ?X2 => constr:X2
+ | ?X2 :: ?X3 => let nl := remove e X3 in constr:(X2 :: nl)
+ end.
+
+Ltac union l1 l2 :=
+ match constr:l1 with
+ | nil => l2
+ | ?X2 :: ?X3 =>
+ let nl2 := remove X2 l2 in
+ let nl := union X3 nl2 in
+ constr:(X2 :: nl)
+ end.
+
+Ltac raw_give_mult trm :=
+ match constr:trm with
+ | (EAinv ?X1) => constr:(X1 :: nil)
+ | (EAopp ?X1) => raw_give_mult X1
+ | (EAplus ?X1 ?X2) =>
+ let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
+ union l1 l2
+ | (EAmult ?X1 ?X2) =>
+ let l1 := raw_give_mult X1 with l2 := raw_give_mult X2 in
+ eval compute in (app l1 l2)
+ | _ => constr:(@nil ExprA)
+ end.
+
+Ltac give_mult trm :=
+ let ltrm := raw_give_mult trm in
+ constr:(mult_of_list ltrm).
+
+(**** Associativity ****)
+
+Ltac apply_assoc FT lvar trm :=
+ let t := eval compute in (assoc trm) in
+ match constr:(t = trm) with
+ | (?X1 = ?X1) => idtac
+ | _ =>
+ rewrite <- (assoc_correct FT trm); change (assoc trm) with t in |- *
+ end.
+
+(**** Distribution *****)
+
+Ltac apply_distrib FT lvar trm :=
+ let t := eval compute in (distrib trm) in
+ match constr:(t = trm) with
+ | (?X1 = ?X1) => idtac
+ | _ =>
+ rewrite <- (distrib_correct FT trm);
+ change (distrib trm) with t in |- *
+ end.
+
+(**** Multiplication by the inverse product ****)
+
+Ltac grep_mult := match goal with
+ | id:(interp_ExprA _ _ _ <> _) |- _ => id
+ end.
+
+Ltac weak_reduce :=
+ match goal with
+ | |- context [(interp_ExprA ?X1 ?X2 _)] =>
+ cbv beta iota zeta
+ delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list X1 X2 A Azero
+ Aone Aplus Amult Aopp Ainv] in |- *
+ end.
+
+Ltac multiply mul :=
+ match goal with
+ | |- (interp_ExprA ?FT ?X2 ?X3 = interp_ExprA ?FT ?X2 ?X4) =>
+ let AzeroT := get_component Azero FT in
+ cut (interp_ExprA FT X2 mul <> AzeroT);
+ [ intro; (let id := grep_mult in apply (mult_eq FT X3 X4 mul X2 id))
+ | weak_reduce;
+ (let AoneT := get_component Aone ltac:(body_of FT)
+ with AmultT := get_component Amult ltac:(body_of FT) in
+ try
+ match goal with
+ | |- context [(AmultT _ AoneT)] => rewrite (AmultT_1r FT)
+ end; clear FT X2) ]
+ end.
+
+Ltac apply_multiply FT lvar trm :=
+ let t := eval compute in (multiply trm) in
+ match constr:(t = trm) with
+ | (?X1 = ?X1) => idtac
+ | _ =>
+ rewrite <- (multiply_correct FT trm);
+ change (multiply trm) with t in |- *
+ end.
+
+(**** Permutations and simplification ****)
+
+Ltac apply_inverse mul FT lvar trm :=
+ let t := eval compute in (inverse_simplif mul trm) in
+ match constr:(t = trm) with
+ | (?X1 = ?X1) => idtac
+ | _ =>
+ rewrite <- (inverse_correct FT trm mul);
+ [ change (inverse_simplif mul trm) with t in |- * | assumption ]
+ end.
+(**** Inverse test ****)
+
+Ltac strong_fail tac := first [ tac | fail 2 ].
+
+Ltac inverse_test_aux FT trm :=
+ let AplusT := get_component Aplus FT
+ with AmultT := get_component Amult FT
+ with AoppT := get_component Aopp FT
+ with AinvT := get_component Ainv FT in
+ match constr:trm with
+ | (AinvT _) => fail 1
+ | (AoppT ?X1) =>
+ strong_fail ltac:(inverse_test_aux FT X1; idtac)
+ | (AplusT ?X1 ?X2) =>
+ strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
+ | (AmultT ?X1 ?X2) =>
+ strong_fail ltac:(inverse_test_aux FT X1; inverse_test_aux FT X2)
+ | _ => idtac
+ end.
+
+Ltac inverse_test FT :=
+ let AplusT := get_component Aplus FT in
+ match goal with
+ | |- (?X1 = ?X2) => inverse_test_aux FT (AplusT X1 X2)
+ end.
+
+(**** Field itself ****)
+
+Ltac apply_simplif sfun :=
+ match goal with
+ | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) =>
+ sfun X1 X2 X3
+ end;
+ match goal with
+ | |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) =>
+ sfun X1 X2 X3
+ end.
+
+Ltac unfolds FT :=
+ match get_component Aminus FT with
+ | Some ?X1 => unfold X1 in |- *
+ | _ => idtac
+ end;
+ match get_component Adiv FT with
+ | Some ?X1 => unfold X1 in |- *
+ | _ => idtac
+ end.
+
+Ltac reduce FT :=
+ let AzeroT := get_component Azero FT
+ with AoneT := get_component Aone FT
+ with AplusT := get_component Aplus FT
+ with AmultT := get_component Amult FT
+ with AoppT := get_component Aopp FT
+ with AinvT := get_component Ainv FT in
+ (cbv beta iota zeta delta -[AzeroT AoneT AplusT AmultT AoppT AinvT] in |- * ||
+ compute in |- *).
+
+Ltac field_gen_aux FT :=
+ let AplusT := get_component Aplus FT in
+ match goal with
+ | |- (?X1 = ?X2) =>
+ let lvar := build_varlist FT (AplusT X1 X2) in
+ let trm1 := interp_A FT lvar X1 with trm2 := interp_A FT lvar X2 in
+ let mul := give_mult (EAplus trm1 trm2) in
+ cut
+ (let ft := FT in
+ let vm := lvar in interp_ExprA ft vm trm1 = interp_ExprA ft vm trm2);
+ [ compute in |- *; auto
+ | intros ft vm; apply_simplif apply_distrib;
+ apply_simplif apply_assoc; multiply mul;
+ [ apply_simplif apply_multiply;
+ apply_simplif ltac:(apply_inverse mul);
+ (let id := grep_mult in
+ clear id; weak_reduce; clear ft vm; first
+ [ inverse_test FT; legacy ring | field_gen_aux FT ])
+ | idtac ] ]
+ end.
+
+Ltac field_gen FT :=
+ unfolds FT; (inverse_test FT; legacy ring) || field_gen_aux FT.
+
+(*****************************)
+(* Term Simplification *)
+(*****************************)
+
+(**** Minus and division expansions ****)
+
+Ltac init_exp FT trm :=
+ let e :=
+ (match get_component Aminus FT with
+ | Some ?X1 => eval cbv beta delta [X1] in trm
+ | _ => trm
+ end) in
+ match get_component Adiv FT with
+ | Some ?X1 => eval cbv beta delta [X1] in e
+ | _ => e
+ end.
+
+(**** Inverses simplification ****)
+
+Ltac simpl_inv trm :=
+ match constr:trm with
+ | (EAplus ?X1 ?X2) =>
+ let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
+ constr:(EAplus e1 e2)
+ | (EAmult ?X1 ?X2) =>
+ let e1 := simpl_inv X1 with e2 := simpl_inv X2 in
+ constr:(EAmult e1 e2)
+ | (EAopp ?X1) => let e := simpl_inv X1 in
+ constr:(EAopp e)
+ | (EAinv ?X1) => SimplInvAux X1
+ | ?X1 => constr:X1
+ end
+ with SimplInvAux trm :=
+ match constr:trm with
+ | (EAinv ?X1) => simpl_inv X1
+ | (EAmult ?X1 ?X2) =>
+ let e1 := simpl_inv (EAinv X1) with e2 := simpl_inv (EAinv X2) in
+ constr:(EAmult e1 e2)
+ | ?X1 => let e := simpl_inv X1 in
+ constr:(EAinv e)
+ end.
+
+(**** Monom simplification ****)
+
+Ltac map_tactic fcn lst :=
+ match constr:lst with
+ | nil => lst
+ | ?X2 :: ?X3 =>
+ let r := fcn X2 with t := map_tactic fcn X3 in
+ constr:(r :: t)
+ end.
+
+Ltac build_monom_aux lst trm :=
+ match constr:lst with
+ | nil => eval compute in (assoc trm)
+ | ?X1 :: ?X2 => build_monom_aux X2 (EAmult trm X1)
+ end.
+
+Ltac build_monom lnum lden :=
+ let ildn := map_tactic ltac:(fun e => constr:(EAinv e)) lden in
+ let ltot := eval compute in (app lnum ildn) in
+ let trm := build_monom_aux ltot EAone in
+ match constr:trm with
+ | (EAmult _ ?X1) => constr:X1
+ | ?X1 => constr:X1
+ end.
+
+Ltac simpl_monom_aux lnum lden trm :=
+ match constr:trm with
+ | (EAmult (EAinv ?X1) ?X2) =>
+ let mma := mem_assoc X1 lnum in
+ match constr:mma with
+ | true =>
+ let newlnum := remove X1 lnum in
+ simpl_monom_aux newlnum lden X2
+ | false => simpl_monom_aux lnum (X1 :: lden) X2
+ end
+ | (EAmult ?X1 ?X2) =>
+ let mma := mem_assoc X1 lden in
+ match constr:mma with
+ | true =>
+ let newlden := remove X1 lden in
+ simpl_monom_aux lnum newlden X2
+ | false => simpl_monom_aux (X1 :: lnum) lden X2
+ end
+ | (EAinv ?X1) =>
+ let mma := mem_assoc X1 lnum in
+ match constr:mma with
+ | true =>
+ let newlnum := remove X1 lnum in
+ build_monom newlnum lden
+ | false => build_monom lnum (X1 :: lden)
+ end
+ | ?X1 =>
+ let mma := mem_assoc X1 lden in
+ match constr:mma with
+ | true =>
+ let newlden := remove X1 lden in
+ build_monom lnum newlden
+ | false => build_monom (X1 :: lnum) lden
+ end
+ end.
+
+Ltac simpl_monom trm := simpl_monom_aux (@nil ExprA) (@nil ExprA) trm.
+
+Ltac simpl_all_monomials trm :=
+ match constr:trm with
+ | (EAplus ?X1 ?X2) =>
+ let e1 := simpl_monom X1 with e2 := simpl_all_monomials X2 in
+ constr:(EAplus e1 e2)
+ | ?X1 => simpl_monom X1
+ end.
+
+(**** Associativity and distribution ****)
+
+Ltac assoc_distrib trm := eval compute in (assoc (distrib trm)).
+
+(**** The tactic Field_Term ****)
+
+Ltac eval_weak_reduce trm :=
+ eval
+ cbv beta iota zeta
+ delta [interp_ExprA assoc_2nd eq_nat_dec mult_of_list A Azero Aone Aplus
+ Amult Aopp Ainv] in trm.
+
+Ltac field_term FT exp :=
+ let newexp := init_exp FT exp in
+ let lvar := build_varlist FT newexp in
+ let trm := interp_A FT lvar newexp in
+ let tma := eval compute in (assoc trm) in
+ let tsmp :=
+ simpl_all_monomials
+ ltac:(assoc_distrib ltac:(simpl_all_monomials ltac:(simpl_inv tma))) in
+ let trep := eval_weak_reduce (interp_ExprA FT lvar tsmp) in
+ (replace exp with trep; [ legacy ring trep | field_gen FT ]).
diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v
new file mode 100644
index 00000000..cc8b043f
--- /dev/null
+++ b/plugins/field/LegacyField_Theory.v
@@ -0,0 +1,650 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Import List.
+Require Import Peano_dec.
+Require Import LegacyRing.
+Require Import LegacyField_Compl.
+
+Record Field_Theory : Type :=
+ {A : Type;
+ Aplus : A -> A -> A;
+ Amult : A -> A -> A;
+ Aone : A;
+ Azero : A;
+ Aopp : A -> A;
+ Aeq : A -> A -> bool;
+ Ainv : A -> A;
+ Aminus : option (A -> A -> A);
+ Adiv : option (A -> A -> A);
+ RT : Ring_Theory Aplus Amult Aone Azero Aopp Aeq;
+ Th_inv_def : forall n:A, n <> Azero -> Amult (Ainv n) n = Aone}.
+
+(* The reflexion structure *)
+Inductive ExprA : Set :=
+ | EAzero : ExprA
+ | EAone : ExprA
+ | EAplus : ExprA -> ExprA -> ExprA
+ | EAmult : ExprA -> ExprA -> ExprA
+ | EAopp : ExprA -> ExprA
+ | EAinv : ExprA -> ExprA
+ | EAvar : nat -> ExprA.
+
+(**** Decidability of equality ****)
+
+Lemma eqExprA_O : forall e1 e2:ExprA, {e1 = e2} + {e1 <> e2}.
+Proof.
+ double induction e1 e2; try intros;
+ try (left; reflexivity) || (try (right; discriminate)).
+ elim (H1 e0); intro y; elim (H2 e); intro y0;
+ try
+ (left; rewrite y; rewrite y0; auto) ||
+ (right; red in |- *; intro; inversion H3; auto).
+ elim (H1 e0); intro y; elim (H2 e); intro y0;
+ try
+ (left; rewrite y; rewrite y0; auto) ||
+ (right; red in |- *; intro; inversion H3; auto).
+ elim (H0 e); intro y.
+ left; rewrite y; auto.
+ right; red in |- *; intro; inversion H1; auto.
+ elim (H0 e); intro y.
+ left; rewrite y; auto.
+ right; red in |- *; intro; inversion H1; auto.
+ elim (eq_nat_dec n n0); intro y.
+ left; rewrite y; auto.
+ right; red in |- *; intro; inversion H; auto.
+Defined.
+
+Definition eq_nat_dec := Eval compute in eq_nat_dec.
+Definition eqExprA := Eval compute in eqExprA_O.
+
+(**** Generation of the multiplier ****)
+
+Fixpoint mult_of_list (e:list ExprA) : ExprA :=
+ match e with
+ | nil => EAone
+ | e1 :: l1 => EAmult e1 (mult_of_list l1)
+ end.
+
+Section Theory_of_fields.
+
+Variable T : Field_Theory.
+
+Let AT := A T.
+Let AplusT := Aplus T.
+Let AmultT := Amult T.
+Let AoneT := Aone T.
+Let AzeroT := Azero T.
+Let AoppT := Aopp T.
+Let AeqT := Aeq T.
+Let AinvT := Ainv T.
+Let RTT := RT T.
+Let Th_inv_defT := Th_inv_def T.
+
+Add Legacy Abstract Ring (A T) (Aplus T) (Amult T) (Aone T) (
+ Azero T) (Aopp T) (Aeq T) (RT T).
+
+Add Legacy Abstract Ring AT AplusT AmultT AoneT AzeroT AoppT AeqT RTT.
+
+(***************************)
+(* Lemmas to be used *)
+(***************************)
+
+Lemma AplusT_comm : forall r1 r2:AT, AplusT r1 r2 = AplusT r2 r1.
+Proof.
+ intros; legacy ring.
+Qed.
+
+Lemma AplusT_assoc :
+ forall r1 r2 r3:AT, AplusT (AplusT r1 r2) r3 = AplusT r1 (AplusT r2 r3).
+Proof.
+ intros; legacy ring.
+Qed.
+
+Lemma AmultT_comm : forall r1 r2:AT, AmultT r1 r2 = AmultT r2 r1.
+Proof.
+ intros; legacy ring.
+Qed.
+
+Lemma AmultT_assoc :
+ forall r1 r2 r3:AT, AmultT (AmultT r1 r2) r3 = AmultT r1 (AmultT r2 r3).
+Proof.
+ intros; legacy ring.
+Qed.
+
+Lemma AplusT_Ol : forall r:AT, AplusT AzeroT r = r.
+Proof.
+ intros; legacy ring.
+Qed.
+
+Lemma AmultT_1l : forall r:AT, AmultT AoneT r = r.
+Proof.
+ intros; legacy ring.
+Qed.
+
+Lemma AplusT_AoppT_r : forall r:AT, AplusT r (AoppT r) = AzeroT.
+Proof.
+ intros; legacy ring.
+Qed.
+
+Lemma AmultT_AplusT_distr :
+ forall r1 r2 r3:AT,
+ AmultT r1 (AplusT r2 r3) = AplusT (AmultT r1 r2) (AmultT r1 r3).
+Proof.
+ intros; legacy ring.
+Qed.
+
+Lemma r_AplusT_plus : forall r r1 r2:AT, AplusT r r1 = AplusT r r2 -> r1 = r2.
+Proof.
+ intros; transitivity (AplusT (AplusT (AoppT r) r) r1).
+ legacy ring.
+ transitivity (AplusT (AplusT (AoppT r) r) r2).
+ repeat rewrite AplusT_assoc; rewrite <- H; reflexivity.
+ legacy ring.
+Qed.
+
+Lemma r_AmultT_mult :
+ forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2.
+Proof.
+ intros; transitivity (AmultT (AmultT (AinvT r) r) r1).
+ rewrite Th_inv_defT; [ symmetry in |- *; apply AmultT_1l; auto | auto ].
+ transitivity (AmultT (AmultT (AinvT r) r) r2).
+ repeat rewrite AmultT_assoc; rewrite H; trivial.
+ rewrite Th_inv_defT; [ apply AmultT_1l; auto | auto ].
+Qed.
+
+Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT.
+Proof.
+ intro; legacy ring.
+Qed.
+
+Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT.
+Proof.
+ intro; legacy ring.
+Qed.
+
+Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r.
+Proof.
+ intro; legacy ring.
+Qed.
+
+Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT.
+Proof.
+ intros; rewrite AmultT_comm; apply Th_inv_defT; auto.
+Qed.
+
+Lemma Rmult_neq_0_reg :
+ forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT.
+Proof.
+ intros r1 r2 H; split; red in |- *; intro; apply H; rewrite H0; legacy ring.
+Qed.
+
+(************************)
+(* Interpretation *)
+(************************)
+
+(**** ExprA --> A ****)
+
+Fixpoint interp_ExprA (lvar:list (AT * nat)) (e:ExprA) {struct e} :
+ AT :=
+ match e with
+ | EAzero => AzeroT
+ | EAone => AoneT
+ | EAplus e1 e2 => AplusT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
+ | EAmult e1 e2 => AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2)
+ | EAopp e => Aopp T (interp_ExprA lvar e)
+ | EAinv e => Ainv T (interp_ExprA lvar e)
+ | EAvar n => assoc_2nd AT nat eq_nat_dec lvar n AzeroT
+ end.
+
+(************************)
+(* Simplification *)
+(************************)
+
+(**** Associativity ****)
+
+Definition merge_mult :=
+ (fix merge_mult (e1:ExprA) : ExprA -> ExprA :=
+ fun e2:ExprA =>
+ match e1 with
+ | EAmult t1 t2 =>
+ match t2 with
+ | EAmult t2 t3 => EAmult t1 (EAmult t2 (merge_mult t3 e2))
+ | _ => EAmult t1 (EAmult t2 e2)
+ end
+ | _ => EAmult e1 e2
+ end).
+
+Fixpoint assoc_mult (e:ExprA) : ExprA :=
+ match e with
+ | EAmult e1 e3 =>
+ match e1 with
+ | EAmult e1 e2 =>
+ merge_mult (merge_mult (assoc_mult e1) (assoc_mult e2))
+ (assoc_mult e3)
+ | _ => EAmult e1 (assoc_mult e3)
+ end
+ | _ => e
+ end.
+
+Definition merge_plus :=
+ (fix merge_plus (e1:ExprA) : ExprA -> ExprA :=
+ fun e2:ExprA =>
+ match e1 with
+ | EAplus t1 t2 =>
+ match t2 with
+ | EAplus t2 t3 => EAplus t1 (EAplus t2 (merge_plus t3 e2))
+ | _ => EAplus t1 (EAplus t2 e2)
+ end
+ | _ => EAplus e1 e2
+ end).
+
+Fixpoint assoc (e:ExprA) : ExprA :=
+ match e with
+ | EAplus e1 e3 =>
+ match e1 with
+ | EAplus e1 e2 =>
+ merge_plus (merge_plus (assoc e1) (assoc e2)) (assoc e3)
+ | _ => EAplus (assoc_mult e1) (assoc e3)
+ end
+ | _ => assoc_mult e
+ end.
+
+Lemma merge_mult_correct1 :
+ forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (merge_mult (EAmult e1 e2) e3) =
+ interp_ExprA lvar (EAmult e1 (merge_mult e2 e3)).
+Proof.
+intros e1 e2; generalize e1; generalize e2; clear e1 e2.
+simple induction e2; auto; intros.
+unfold merge_mult at 1 in |- *; fold merge_mult in |- *;
+ unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
+ rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
+ fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
+ fold interp_ExprA in |- *; auto.
+Qed.
+
+Lemma merge_mult_correct :
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (merge_mult e1 e2) = interp_ExprA lvar (EAmult e1 e2).
+Proof.
+simple induction e1; auto; intros.
+elim e0; try (intros; simpl in |- *; legacy ring).
+unfold interp_ExprA in H2; fold interp_ExprA in H2;
+ cut
+ (AmultT (interp_ExprA lvar e2)
+ (AmultT (interp_ExprA lvar e4)
+ (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
+ AmultT
+ (AmultT (AmultT (interp_ExprA lvar e) (interp_ExprA lvar e4))
+ (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
+intro H3; rewrite H3; rewrite <- H2; rewrite merge_mult_correct1;
+ simpl in |- *; legacy ring.
+legacy ring.
+Qed.
+
+Lemma assoc_mult_correct1 :
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
+ AmultT (interp_ExprA lvar (assoc_mult e1))
+ (interp_ExprA lvar (assoc_mult e2)) =
+ interp_ExprA lvar (assoc_mult (EAmult e1 e2)).
+Proof.
+simple induction e1; auto; intros.
+rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct;
+ simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
+ auto.
+Qed.
+
+Lemma assoc_mult_correct :
+ forall (e:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (assoc_mult e) = interp_ExprA lvar e.
+Proof.
+simple induction e; auto; intros.
+elim e0; intros.
+intros; simpl in |- *; legacy ring.
+simpl in |- *; rewrite (AmultT_1l (interp_ExprA lvar (assoc_mult e1)));
+ rewrite (AmultT_1l (interp_ExprA lvar e1)); apply H0.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite merge_mult_correct; simpl in |- *;
+ rewrite merge_mult_correct; simpl in |- *; rewrite AmultT_assoc;
+ rewrite assoc_mult_correct1; rewrite H2; simpl in |- *;
+ rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1;
+ fold interp_ExprA in H1; rewrite (H0 lvar) in H1;
+ rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1));
+ rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc;
+ legacy ring.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+Qed.
+
+Lemma merge_plus_correct1 :
+ forall (e1 e2 e3:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (merge_plus (EAplus e1 e2) e3) =
+ interp_ExprA lvar (EAplus e1 (merge_plus e2 e3)).
+Proof.
+intros e1 e2; generalize e1; generalize e2; clear e1 e2.
+simple induction e2; auto; intros.
+unfold merge_plus at 1 in |- *; fold merge_plus in |- *;
+ unfold interp_ExprA at 2 in |- *; fold interp_ExprA in |- *;
+ rewrite (H0 e e3 lvar); unfold interp_ExprA at 1 in |- *;
+ fold interp_ExprA in |- *; unfold interp_ExprA at 5 in |- *;
+ fold interp_ExprA in |- *; auto.
+Qed.
+
+Lemma merge_plus_correct :
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (merge_plus e1 e2) = interp_ExprA lvar (EAplus e1 e2).
+Proof.
+simple induction e1; auto; intros.
+elim e0; try intros; try (simpl in |- *; legacy ring).
+unfold interp_ExprA in H2; fold interp_ExprA in H2;
+ cut
+ (AplusT (interp_ExprA lvar e2)
+ (AplusT (interp_ExprA lvar e4)
+ (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e3))) =
+ AplusT
+ (AplusT (AplusT (interp_ExprA lvar e) (interp_ExprA lvar e4))
+ (interp_ExprA lvar e2)) (interp_ExprA lvar e3)).
+intro H3; rewrite H3; rewrite <- H2; rewrite merge_plus_correct1;
+ simpl in |- *; legacy ring.
+legacy ring.
+Qed.
+
+Lemma assoc_plus_correct :
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
+ AplusT (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)) =
+ interp_ExprA lvar (assoc (EAplus e1 e2)).
+Proof.
+simple induction e1; auto; intros.
+rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct;
+ simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
+ auto.
+Qed.
+
+Lemma assoc_correct :
+ forall (e:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (assoc e) = interp_ExprA lvar e.
+Proof.
+simple induction e; auto; intros.
+elim e0; intros.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite merge_plus_correct; simpl in |- *;
+ rewrite merge_plus_correct; simpl in |- *; rewrite AplusT_assoc;
+ rewrite assoc_plus_correct; rewrite H2; simpl in |- *;
+ apply
+ (r_AplusT_plus (interp_ExprA lvar (assoc e1))
+ (AplusT (interp_ExprA lvar (assoc e2))
+ (AplusT (interp_ExprA lvar e3) (interp_ExprA lvar e1)))
+ (AplusT (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e3))
+ (interp_ExprA lvar e1))); rewrite <- AplusT_assoc;
+ rewrite
+ (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2)))
+ ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *;
+ rewrite (H0 lvar);
+ rewrite <-
+ (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1))
+ (interp_ExprA lvar e3) (interp_ExprA lvar e1))
+ ;
+ rewrite
+ (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e1)
+ (interp_ExprA lvar e3));
+ rewrite (AplusT_comm (interp_ExprA lvar e1) (interp_ExprA lvar e3));
+ rewrite <-
+ (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3)
+ (interp_ExprA lvar e1)); apply AplusT_comm.
+unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
+ fold interp_ExprA in |- *; rewrite assoc_mult_correct;
+ rewrite (H0 lvar); simpl in |- *; auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+simpl in |- *; rewrite (H0 lvar); auto.
+unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *;
+ fold interp_ExprA in |- *; rewrite assoc_mult_correct;
+ simpl in |- *; auto.
+Qed.
+
+(**** Distribution *****)
+
+Fixpoint distrib_EAopp (e:ExprA) : ExprA :=
+ match e with
+ | EAplus e1 e2 => EAplus (distrib_EAopp e1) (distrib_EAopp e2)
+ | EAmult e1 e2 => EAmult (distrib_EAopp e1) (distrib_EAopp e2)
+ | EAopp e => EAmult (EAopp EAone) (distrib_EAopp e)
+ | e => e
+ end.
+
+Definition distrib_mult_right :=
+ (fix distrib_mult_right (e1:ExprA) : ExprA -> ExprA :=
+ fun e2:ExprA =>
+ match e1 with
+ | EAplus t1 t2 =>
+ EAplus (distrib_mult_right t1 e2) (distrib_mult_right t2 e2)
+ | _ => EAmult e1 e2
+ end).
+
+Fixpoint distrib_mult_left (e1 e2:ExprA) {struct e1} : ExprA :=
+ match e1 with
+ | EAplus t1 t2 =>
+ EAplus (distrib_mult_left t1 e2) (distrib_mult_left t2 e2)
+ | _ => distrib_mult_right e2 e1
+ end.
+
+Fixpoint distrib_main (e:ExprA) : ExprA :=
+ match e with
+ | EAmult e1 e2 => distrib_mult_left (distrib_main e1) (distrib_main e2)
+ | EAplus e1 e2 => EAplus (distrib_main e1) (distrib_main e2)
+ | EAopp e => EAopp (distrib_main e)
+ | _ => e
+ end.
+
+Definition distrib (e:ExprA) : ExprA := distrib_main (distrib_EAopp e).
+
+Lemma distrib_mult_right_correct :
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (distrib_mult_right e1 e2) =
+ AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
+Proof.
+simple induction e1; try intros; simpl in |- *; auto.
+rewrite AmultT_comm; rewrite AmultT_AplusT_distr; rewrite (H e2 lvar);
+ rewrite (H0 e2 lvar); legacy ring.
+Qed.
+
+Lemma distrib_mult_left_correct :
+ forall (e1 e2:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (distrib_mult_left e1 e2) =
+ AmultT (interp_ExprA lvar e1) (interp_ExprA lvar e2).
+Proof.
+simple induction e1; try intros; simpl in |- *.
+rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *;
+ apply AmultT_Or.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite AmultT_comm;
+ rewrite
+ (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e)
+ (interp_ExprA lvar e0));
+ rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e));
+ rewrite (AmultT_comm (interp_ExprA lvar e2) (interp_ExprA lvar e0));
+ rewrite (H e2 lvar); rewrite (H0 e2 lvar); auto.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm.
+Qed.
+
+Lemma distrib_correct :
+ forall (e:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (distrib e) = interp_ExprA lvar e.
+Proof.
+simple induction e; intros; auto.
+simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
+ unfold distrib in |- *; simpl in |- *; auto.
+simpl in |- *; rewrite <- (H lvar); rewrite <- (H0 lvar);
+ unfold distrib in |- *; simpl in |- *; apply distrib_mult_left_correct.
+simpl in |- *; fold AoppT in |- *; rewrite <- (H lvar);
+ unfold distrib in |- *; simpl in |- *; rewrite distrib_mult_right_correct;
+ simpl in |- *; fold AoppT in |- *; legacy ring.
+Qed.
+
+(**** Multiplication by the inverse product ****)
+
+Lemma mult_eq :
+ forall (e1 e2 a:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar a <> AzeroT ->
+ interp_ExprA lvar (EAmult a e1) = interp_ExprA lvar (EAmult a e2) ->
+ interp_ExprA lvar e1 = interp_ExprA lvar e2.
+Proof.
+ simpl in |- *; intros;
+ apply
+ (r_AmultT_mult (interp_ExprA lvar a) (interp_ExprA lvar e1)
+ (interp_ExprA lvar e2)); assumption.
+Qed.
+
+Fixpoint multiply_aux (a e:ExprA) {struct e} : ExprA :=
+ match e with
+ | EAplus e1 e2 => EAplus (EAmult a e1) (multiply_aux a e2)
+ | _ => EAmult a e
+ end.
+
+Definition multiply (e:ExprA) : ExprA :=
+ match e with
+ | EAmult a e1 => multiply_aux a e1
+ | _ => e
+ end.
+
+Lemma multiply_aux_correct :
+ forall (a e:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (multiply_aux a e) =
+ AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
+Proof.
+simple induction e; simpl in |- *; intros; try rewrite merge_mult_correct;
+ auto.
+ simpl in |- *; rewrite (H0 lvar); legacy ring.
+Qed.
+
+Lemma multiply_correct :
+ forall (e:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar (multiply e) = interp_ExprA lvar e.
+Proof.
+ simple induction e; simpl in |- *; auto.
+ intros; apply multiply_aux_correct.
+Qed.
+
+(**** Permutations and simplification ****)
+
+Fixpoint monom_remove (a m:ExprA) {struct m} : ExprA :=
+ match m with
+ | EAmult m0 m1 =>
+ match eqExprA m0 (EAinv a) with
+ | left _ => m1
+ | right _ => EAmult m0 (monom_remove a m1)
+ end
+ | _ =>
+ match eqExprA m (EAinv a) with
+ | left _ => EAone
+ | right _ => EAmult a m
+ end
+ end.
+
+Definition monom_simplif_rem :=
+ (fix monom_simplif_rem (a:ExprA) : ExprA -> ExprA :=
+ fun m:ExprA =>
+ match a with
+ | EAmult a0 a1 => monom_simplif_rem a1 (monom_remove a0 m)
+ | _ => monom_remove a m
+ end).
+
+Definition monom_simplif (a m:ExprA) : ExprA :=
+ match m with
+ | EAmult a' m' =>
+ match eqExprA a a' with
+ | left _ => monom_simplif_rem a m'
+ | right _ => m
+ end
+ | _ => m
+ end.
+
+Fixpoint inverse_simplif (a e:ExprA) {struct e} : ExprA :=
+ match e with
+ | EAplus e1 e2 => EAplus (monom_simplif a e1) (inverse_simplif a e2)
+ | _ => monom_simplif a e
+ end.
+
+Lemma monom_remove_correct :
+ forall (e a:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar a <> AzeroT ->
+ interp_ExprA lvar (monom_remove a e) =
+ AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
+Proof.
+simple induction e; intros.
+simpl in |- *; case (eqExprA EAzero (EAinv a)); intros;
+ [ inversion e0 | simpl in |- *; trivial ].
+simpl in |- *; case (eqExprA EAone (EAinv a)); intros;
+ [ inversion e0 | simpl in |- *; trivial ].
+simpl in |- *; case (eqExprA (EAplus e0 e1) (EAinv a)); intros;
+ [ inversion e2 | simpl in |- *; trivial ].
+simpl in |- *; case (eqExprA e0 (EAinv a)); intros.
+rewrite e2; simpl in |- *; fold AinvT in |- *.
+rewrite <-
+ (AmultT_assoc (interp_ExprA lvar a) (AinvT (interp_ExprA lvar a))
+ (interp_ExprA lvar e1)); rewrite AinvT_r; [ legacy ring | assumption ].
+simpl in |- *; rewrite H0; auto; legacy ring.
+simpl in |- *; fold AoppT in |- *; case (eqExprA (EAopp e0) (EAinv a));
+ intros; [ inversion e1 | simpl in |- *; trivial ].
+unfold monom_remove in |- *; case (eqExprA (EAinv e0) (EAinv a)); intros.
+case (eqExprA e0 a); intros.
+rewrite e2; simpl in |- *; fold AinvT in |- *; rewrite AinvT_r; auto.
+inversion e1; simpl in |- *; exfalso; auto.
+simpl in |- *; trivial.
+unfold monom_remove in |- *; case (eqExprA (EAvar n) (EAinv a)); intros;
+ [ inversion e0 | simpl in |- *; trivial ].
+Qed.
+
+Lemma monom_simplif_rem_correct :
+ forall (a e:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar a <> AzeroT ->
+ interp_ExprA lvar (monom_simplif_rem a e) =
+ AmultT (interp_ExprA lvar a) (interp_ExprA lvar e).
+Proof.
+simple induction a; simpl in |- *; intros; try rewrite monom_remove_correct;
+ auto.
+elim (Rmult_neq_0_reg (interp_ExprA lvar e) (interp_ExprA lvar e0) H1);
+ intros.
+rewrite (H0 (monom_remove e e1) lvar H3); rewrite monom_remove_correct; auto.
+legacy ring.
+Qed.
+
+Lemma monom_simplif_correct :
+ forall (e a:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar a <> AzeroT ->
+ interp_ExprA lvar (monom_simplif a e) = interp_ExprA lvar e.
+Proof.
+simple induction e; intros; auto.
+simpl in |- *; case (eqExprA a e0); intros.
+rewrite <- e2; apply monom_simplif_rem_correct; auto.
+simpl in |- *; trivial.
+Qed.
+
+Lemma inverse_correct :
+ forall (e a:ExprA) (lvar:list (AT * nat)),
+ interp_ExprA lvar a <> AzeroT ->
+ interp_ExprA lvar (inverse_simplif a e) = interp_ExprA lvar e.
+Proof.
+simple induction e; intros; auto.
+simpl in |- *; rewrite (H0 a lvar H1); rewrite monom_simplif_correct; auto.
+unfold inverse_simplif in |- *; rewrite monom_simplif_correct; auto.
+Qed.
+
+End Theory_of_fields.
+
+(* Compatibility *)
+Notation AplusT_sym := AplusT_comm (only parsing).
+Notation AmultT_sym := AmultT_comm (only parsing).
diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4
new file mode 100644
index 00000000..238b4c1e
--- /dev/null
+++ b/plugins/field/field.ml4
@@ -0,0 +1,191 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Names
+open Pp
+open Proof_type
+open Tacinterp
+open Tacmach
+open Term
+open Typing
+open Util
+open Vernacinterp
+open Vernacexpr
+open Tacexpr
+open Mod_subst
+open Coqlib
+
+(* Interpretation of constr's *)
+let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
+
+(* Construction of constants *)
+let constant dir s = gen_constant "Field" ("field"::dir) s
+let init_constant s = gen_constant_in_modules "Field" init_modules s
+
+(* To deal with the optional arguments *)
+let constr_of_opt a opt =
+ let ac = constr_of a in
+ let ac3 = mkArrow ac (mkArrow ac ac) in
+ match opt with
+ | None -> mkApp (init_constant "None",[|ac3|])
+ | Some f -> mkApp (init_constant "Some",[|ac3;constr_of f|])
+
+(* Table of theories *)
+let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t)
+
+let lookup env typ =
+ try Gmap.find typ !th_tab
+ with Not_found ->
+ errorlabstrm "field"
+ (str "No field is declared for type" ++ spc() ++
+ Printer.pr_lconstr_env env typ)
+
+let _ =
+ let init () = th_tab := Gmap.empty in
+ let freeze () = !th_tab in
+ let unfreeze fs = th_tab := fs in
+ Summary.declare_summary "field"
+ { Summary.freeze_function = freeze;
+ Summary.unfreeze_function = unfreeze;
+ Summary.init_function = init }
+
+let load_addfield _ = ()
+let cache_addfield (_,(typ,th)) = th_tab := Gmap.add typ th !th_tab
+let subst_addfield (subst,(typ,th as obj)) =
+ let typ' = subst_mps subst typ in
+ let th' = subst_mps subst th in
+ if typ' == typ && th' == th then obj else
+ (typ',th')
+
+(* Declaration of the Add Field library object *)
+let (in_addfield,out_addfield)=
+ Libobject.declare_object {(Libobject.default_object "ADD_FIELD") with
+ Libobject.open_function = (fun i o -> if i=1 then cache_addfield o);
+ Libobject.cache_function = cache_addfield;
+ Libobject.subst_function = subst_addfield;
+ Libobject.classify_function = (fun a -> Libobject.Substitute a)}
+
+(* Adds a theory to the table *)
+let add_field a aplus amult aone azero aopp aeq ainv aminus_o adiv_o rth
+ ainv_l =
+ begin
+ (try
+ Ring.add_theory true true false a None None None aplus amult aone azero
+ (Some aopp) aeq rth Quote.ConstrSet.empty
+ with | UserError("Add Semi Ring",_) -> ());
+ let th = mkApp ((constant ["LegacyField_Theory"] "Build_Field_Theory"),
+ [|a;aplus;amult;aone;azero;aopp;aeq;ainv;aminus_o;adiv_o;rth;ainv_l|]) in
+ begin
+ let _ = type_of (Global.env ()) Evd.empty th in ();
+ Lib.add_anonymous_leaf (in_addfield (a,th))
+ end
+ end
+
+(* Vernac command declaration *)
+open Extend
+open Pcoq
+open Genarg
+
+VERNAC ARGUMENT EXTEND divarg
+| [ "div" ":=" constr(adiv) ] -> [ adiv ]
+END
+
+VERNAC ARGUMENT EXTEND minusarg
+| [ "minus" ":=" constr(aminus) ] -> [ aminus ]
+END
+
+(*
+(* The v7->v8 translator needs printers, then temporary use ARGUMENT EXTEND...*)
+VERNAC ARGUMENT EXTEND minus_div_arg
+| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
+| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
+| [ ] -> [ None, None ]
+END
+*)
+
+(* For the translator, otherwise the code above is OK *)
+open Ppconstr
+let pp_minus_div_arg _prc _prlc _prt (omin,odiv) =
+ if omin=None && odiv=None then mt() else
+ spc() ++ str "with" ++
+ pr_opt (fun c -> str "minus := " ++ _prc c) omin ++
+ pr_opt (fun c -> str "div := " ++ _prc c) odiv
+(*
+let () =
+ Pptactic.declare_extra_genarg_pprule true
+ (rawwit_minus_div_arg,pp_minus_div_arg)
+ (globwit_minus_div_arg,pp_minus_div_arg)
+ (wit_minus_div_arg,pp_minus_div_arg)
+*)
+ARGUMENT EXTEND minus_div_arg
+ TYPED AS constr_opt * constr_opt
+ PRINTED BY pp_minus_div_arg
+| [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ]
+| [ "with" divarg(d) minusarg_opt(m) ] -> [ m, Some d ]
+| [ ] -> [ None, None ]
+END
+
+VERNAC COMMAND EXTEND Field
+ [ "Add" "Legacy" "Field"
+ constr(a) constr(aplus) constr(amult) constr(aone)
+ constr(azero) constr(aopp) constr(aeq)
+ constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ]
+ -> [ let (aminus_o, adiv_o) = md in
+ add_field
+ (constr_of a) (constr_of aplus) (constr_of amult)
+ (constr_of aone) (constr_of azero) (constr_of aopp)
+ (constr_of aeq) (constr_of ainv) (constr_of_opt a aminus_o)
+ (constr_of_opt a adiv_o) (constr_of rth) (constr_of ainv_l) ]
+END
+
+(* Guesses the type and calls field_gen with the right theory *)
+let field g =
+ Coqlib.check_required_library ["Coq";"field";"LegacyField"];
+ let typ =
+ try match Hipattern.match_with_equation (pf_concl g) with
+ | _,_,Hipattern.PolymorphicLeibnizEq (t,_,_) -> t
+ | _ -> raise Exit
+ with Hipattern.NoEquationFound | Exit ->
+ error "The statement is not built from Leibniz' equality" in
+ let th = VConstr ([],lookup (pf_env g) typ) in
+ (interp_tac_gen [(id_of_string "FT",th)] [] (get_debug ())
+ <:tactic< match goal with |- (@eq _ _ _) => field_gen FT end >>) g
+
+(* Verifies that all the terms have the same type and gives the right theory *)
+let guess_theory env evc = function
+ | c::tl ->
+ let t = type_of env evc c in
+ if List.exists (fun c1 ->
+ not (Reductionops.is_conv env evc t (type_of env evc c1))) tl then
+ errorlabstrm "Field:" (str" All the terms must have the same type")
+ else
+ lookup env t
+ | [] -> anomaly "Field: must have a non-empty constr list here"
+
+(* Guesses the type and calls Field_Term with the right theory *)
+let field_term l g =
+ Coqlib.check_required_library ["Coq";"field";"LegacyField"];
+ let env = (pf_env g)
+ and evc = (project g) in
+ let th = valueIn (VConstr ([],guess_theory env evc l))
+ and nl = List.map (fun x -> valueIn (VConstr ([],x))) (Quote.sort_subterm g l) in
+ (List.fold_right
+ (fun c a ->
+ let tac = (Tacinterp.interp <:tactic<(Field_Term $th $c)>>) in
+ Tacticals.tclTHENFIRSTn tac [|a|]) nl Tacticals.tclIDTAC) g
+
+(* Declaration of Field *)
+
+TACTIC EXTEND legacy_field
+| [ "legacy" "field" ] -> [ field ]
+| [ "legacy" "field" ne_constr_list(l) ] -> [ field_term l ]
+END
diff --git a/plugins/field/field_plugin.mllib b/plugins/field/field_plugin.mllib
new file mode 100644
index 00000000..3c3e87af
--- /dev/null
+++ b/plugins/field/field_plugin.mllib
@@ -0,0 +1,2 @@
+Field
+Field_plugin_mod
diff --git a/plugins/field/vo.itarget b/plugins/field/vo.itarget
new file mode 100644
index 00000000..22b56f33
--- /dev/null
+++ b/plugins/field/vo.itarget
@@ -0,0 +1,4 @@
+LegacyField_Compl.vo
+LegacyField_Tactic.vo
+LegacyField_Theory.vo
+LegacyField.vo
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
new file mode 100644
index 00000000..45365cb2
--- /dev/null
+++ b/plugins/firstorder/formula.ml
@@ -0,0 +1,270 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Hipattern
+open Names
+open Term
+open Termops
+open Reductionops
+open Tacmach
+open Util
+open Declarations
+open Libnames
+open Inductiveops
+
+let qflag=ref true
+
+let red_flags=ref Closure.betaiotazeta
+
+let (=?) f g i1 i2 j1 j2=
+ let c=f i1 i2 in
+ if c=0 then g j1 j2 else c
+
+let (==?) fg h i1 i2 j1 j2 k1 k2=
+ let c=fg i1 i2 j1 j2 in
+ if c=0 then h k1 k2 else c
+
+type ('a,'b) sum = Left of 'a | Right of 'b
+
+type counter = bool -> metavariable
+
+exception Is_atom of constr
+
+let meta_succ m = m+1
+
+let rec nb_prod_after n c=
+ match kind_of_term c with
+ | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else
+ 1+(nb_prod_after 0 b)
+ | _ -> 0
+
+let construct_nhyps ind gls =
+ let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in
+ let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in
+ let hyp = nb_prod_after nparams in
+ Array.map hyp constr_types
+
+(* indhyps builds the array of arrays of constructor hyps for (ind largs)*)
+let ind_hyps nevar ind largs gls=
+ let types= Inductiveops.arities_of_constructors (pf_env gls) ind in
+ let lp=Array.length types in
+ let myhyps i=
+ let t1=Term.prod_applist types.(i) largs in
+ let t2=snd (decompose_prod_n_assum nevar t1) in
+ fst (decompose_prod_assum t2) in
+ Array.init lp myhyps
+
+let special_nf gl=
+ let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
+ (fun t -> Closure.norm_val infos (Closure.inject t))
+
+let special_whd gl=
+ let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
+ (fun t -> Closure.whd_val infos (Closure.inject t))
+
+type kind_of_formula=
+ Arrow of constr*constr
+ | False of inductive*constr list
+ | And of inductive*constr list*bool
+ | Or of inductive*constr list*bool
+ | Exists of inductive*constr list
+ | Forall of constr*constr
+ | Atom of constr
+
+let rec kind_of_formula gl term =
+ let normalize=special_nf gl in
+ let cciterm=special_whd gl term in
+ match match_with_imp_term cciterm with
+ Some (a,b)-> Arrow(a,(pop b))
+ |_->
+ match match_with_forall_term cciterm with
+ Some (_,a,b)-> Forall(a,b)
+ |_->
+ match match_with_nodep_ind cciterm with
+ Some (i,l,n)->
+ let ind=destInd i in
+ let (mib,mip) = Global.lookup_inductive ind in
+ let nconstr=Array.length mip.mind_consnames in
+ if nconstr=0 then
+ False(ind,l)
+ else
+ let has_realargs=(n>0) in
+ let is_trivial=
+ let is_constant c =
+ nb_prod c = mib.mind_nparams in
+ array_exists is_constant mip.mind_nf_lc in
+ if Inductiveops.mis_is_recursive (ind,mib,mip) ||
+ (has_realargs && not is_trivial)
+ then
+ Atom cciterm
+ else
+ if nconstr=1 then
+ And(ind,l,is_trivial)
+ else
+ Or(ind,l,is_trivial)
+ | _ ->
+ match match_with_sigma_type cciterm with
+ Some (i,l)-> Exists((destInd i),l)
+ |_-> Atom (normalize cciterm)
+
+type atoms = {positive:constr list;negative:constr list}
+
+type side = Hyp | Concl | Hint
+
+let no_atoms = (false,{positive=[];negative=[]})
+
+let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *)
+
+let build_atoms gl metagen side cciterm =
+ let trivial =ref false
+ and positive=ref []
+ and negative=ref [] in
+ let normalize=special_nf gl in
+ let rec build_rec env polarity cciterm=
+ match kind_of_formula gl cciterm with
+ False(_,_)->if not polarity then trivial:=true
+ | Arrow (a,b)->
+ build_rec env (not polarity) a;
+ build_rec env polarity b
+ | And(i,l,b) | Or(i,l,b)->
+ if b then
+ begin
+ let unsigned=normalize (substnl env 0 cciterm) in
+ if polarity then
+ positive:= unsigned :: !positive
+ else
+ negative:= unsigned :: !negative
+ end;
+ let v = ind_hyps 0 i l gl in
+ let g i _ (_,_,t) =
+ build_rec env polarity (lift i t) in
+ let f l =
+ list_fold_left_i g (1-(List.length l)) () l in
+ if polarity && (* we have a constant constructor *)
+ array_exists (function []->true|_->false) v
+ then trivial:=true;
+ Array.iter f v
+ | Exists(i,l)->
+ let var=mkMeta (metagen true) in
+ let v =(ind_hyps 1 i l gl).(0) in
+ let g i _ (_,_,t) =
+ build_rec (var::env) polarity (lift i t) in
+ list_fold_left_i g (2-(List.length l)) () v
+ | Forall(_,b)->
+ let var=mkMeta (metagen true) in
+ build_rec (var::env) polarity b
+ | Atom t->
+ let unsigned=substnl env 0 t in
+ if not (isMeta unsigned) then (* discarding wildcard atoms *)
+ if polarity then
+ positive:= unsigned :: !positive
+ else
+ negative:= unsigned :: !negative in
+ begin
+ match side with
+ Concl -> build_rec [] true cciterm
+ | Hyp -> build_rec [] false cciterm
+ | Hint ->
+ let rels,head=decompose_prod cciterm in
+ let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in
+ build_rec env false head;trivial:=false (* special for hints *)
+ end;
+ (!trivial,
+ {positive= !positive;
+ negative= !negative})
+
+type right_pattern =
+ Rarrow
+ | Rand
+ | Ror
+ | Rfalse
+ | Rforall
+ | Rexists of metavariable*constr*bool
+
+type left_arrow_pattern=
+ LLatom
+ | LLfalse of inductive*constr list
+ | LLand of inductive*constr list
+ | LLor of inductive*constr list
+ | LLforall of constr
+ | LLexists of inductive*constr list
+ | LLarrow of constr*constr*constr
+
+type left_pattern=
+ Lfalse
+ | Land of inductive
+ | Lor of inductive
+ | Lforall of metavariable*constr*bool
+ | Lexists of inductive
+ | LA of constr*left_arrow_pattern
+
+type t={id:global_reference;
+ constr:constr;
+ pat:(left_pattern,right_pattern) sum;
+ atoms:atoms}
+
+let build_formula side nam typ gl metagen=
+ let normalize = special_nf gl in
+ try
+ let m=meta_succ(metagen false) in
+ let trivial,atoms=
+ if !qflag then
+ build_atoms gl metagen side typ
+ else no_atoms in
+ let pattern=
+ match side with
+ Concl ->
+ let pat=
+ match kind_of_formula gl typ with
+ False(_,_) -> Rfalse
+ | Atom a -> raise (Is_atom a)
+ | And(_,_,_) -> Rand
+ | Or(_,_,_) -> Ror
+ | Exists (i,l) ->
+ let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in
+ Rexists(m,d,trivial)
+ | Forall (_,a) -> Rforall
+ | Arrow (a,b) -> Rarrow in
+ Right pat
+ | _ ->
+ let pat=
+ match kind_of_formula gl typ with
+ False(i,_) -> Lfalse
+ | Atom a -> raise (Is_atom a)
+ | And(i,_,b) ->
+ if b then
+ let nftyp=normalize typ in raise (Is_atom nftyp)
+ else Land i
+ | Or(i,_,b) ->
+ if b then
+ let nftyp=normalize typ in raise (Is_atom nftyp)
+ else Lor i
+ | Exists (ind,_) -> Lexists ind
+ | Forall (d,_) ->
+ Lforall(m,d,trivial)
+ | Arrow (a,b) ->
+ let nfa=normalize a in
+ LA (nfa,
+ match kind_of_formula gl a with
+ False(i,l)-> LLfalse(i,l)
+ | Atom t-> LLatom
+ | And(i,l,_)-> LLand(i,l)
+ | Or(i,l,_)-> LLor(i,l)
+ | Arrow(a,c)-> LLarrow(a,c,b)
+ | Exists(i,l)->LLexists(i,l)
+ | Forall(_,_)->LLforall a) in
+ Left pat
+ in
+ Left {id=nam;
+ constr=normalize typ;
+ pat=pattern;
+ atoms=atoms}
+ with Is_atom a-> Right a (* already in nf *)
+
diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli
new file mode 100644
index 00000000..2e89ddb0
--- /dev/null
+++ b/plugins/firstorder/formula.mli
@@ -0,0 +1,77 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Term
+open Names
+open Libnames
+
+val qflag : bool ref
+
+val red_flags: Closure.RedFlags.reds ref
+
+val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) ->
+ 'a -> 'a -> 'b -> 'b -> int
+
+val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) ->
+ 'a -> 'a -> 'b -> 'b -> 'c ->'c -> int
+
+type ('a,'b) sum = Left of 'a | Right of 'b
+
+type counter = bool -> metavariable
+
+val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array
+
+val ind_hyps : int -> inductive -> constr list ->
+ Proof_type.goal Tacmach.sigma -> rel_context array
+
+type atoms = {positive:constr list;negative:constr list}
+
+type side = Hyp | Concl | Hint
+
+val dummy_id: global_reference
+
+val build_atoms : Proof_type.goal Tacmach.sigma -> counter ->
+ side -> constr -> bool * atoms
+
+type right_pattern =
+ Rarrow
+ | Rand
+ | Ror
+ | Rfalse
+ | Rforall
+ | Rexists of metavariable*constr*bool
+
+type left_arrow_pattern=
+ LLatom
+ | LLfalse of inductive*constr list
+ | LLand of inductive*constr list
+ | LLor of inductive*constr list
+ | LLforall of constr
+ | LLexists of inductive*constr list
+ | LLarrow of constr*constr*constr
+
+type left_pattern=
+ Lfalse
+ | Land of inductive
+ | Lor of inductive
+ | Lforall of metavariable*constr*bool
+ | Lexists of inductive
+ | LA of constr*left_arrow_pattern
+
+type t={id: global_reference;
+ constr: constr;
+ pat: (left_pattern,right_pattern) sum;
+ atoms: atoms}
+
+(*exception Is_atom of constr*)
+
+val build_formula : side -> global_reference -> types ->
+ Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum
+
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
new file mode 100644
index 00000000..9080e7db
--- /dev/null
+++ b/plugins/firstorder/g_ground.ml4
@@ -0,0 +1,148 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Formula
+open Sequent
+open Ground
+open Goptions
+open Tactics
+open Tacticals
+open Tacinterp
+open Term
+open Names
+open Util
+open Libnames
+
+(* declaring search depth as a global option *)
+
+let ground_depth=ref 3
+
+let _=
+ let gdopt=
+ { optsync=true;
+ optname="Firstorder Depth";
+ optkey=["Firstorder";"Depth"];
+ optread=(fun ()->Some !ground_depth);
+ optwrite=
+ (function
+ None->ground_depth:=3
+ | Some i->ground_depth:=(max i 0))}
+ in
+ declare_int_option gdopt
+
+let congruence_depth=ref 100
+
+let _=
+ let gdopt=
+ { optsync=true;
+ optname="Congruence Depth";
+ optkey=["Congruence";"Depth"];
+ optread=(fun ()->Some !congruence_depth);
+ optwrite=
+ (function
+ None->congruence_depth:=0
+ | Some i->congruence_depth:=(max i 0))}
+ in
+ declare_int_option gdopt
+
+let default_solver=(Tacinterp.interp <:tactic<auto with *>>)
+
+let fail_solver=tclFAIL 0 (Pp.str "GTauto failed")
+
+let gen_ground_tac flag taco ids bases gl=
+ let backup= !qflag in
+ try
+ qflag:=flag;
+ let solver=
+ match taco with
+ Some tac-> tac
+ | None-> default_solver in
+ let startseq gl=
+ let seq=empty_seq !ground_depth in
+ extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in
+ let result=ground_tac solver startseq gl in
+ qflag:=backup;result
+ with e ->qflag:=backup;raise e
+
+(* special for compatibility with Intuition
+
+let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
+
+let defined_connectives=lazy
+ [[],EvalConstRef (destConst (constant "not"));
+ [],EvalConstRef (destConst (constant "iff"))]
+
+let normalize_evaluables=
+ onAllHypsAndConcl
+ (function
+ None->unfold_in_concl (Lazy.force defined_connectives)
+ | Some id->
+ unfold_in_hyp (Lazy.force defined_connectives)
+ (Tacexpr.InHypType id)) *)
+
+open Genarg
+open Ppconstr
+open Printer
+let pr_firstorder_using_raw _ _ _ = prlist_with_sep pr_comma pr_reference
+let pr_firstorder_using_glob _ _ _ = prlist_with_sep pr_comma (pr_or_var (pr_located pr_global))
+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
+ GLOB_TYPED AS reference_list
+ GLOB_PRINTED BY pr_firstorder_using_glob
+| [ "using" reference(a) ] -> [ [a] ]
+| [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ]
+| [ "using" reference(a) reference(b) reference_list(l) ] -> [
+ Flags.if_verbose
+ Pp.msg_warning (Pp.str "Deprecated syntax; use \",\" as separator");
+ a::b::l
+ ]
+| [ ] -> [ [] ]
+END
+
+TACTIC EXTEND firstorder
+ [ "firstorder" tactic_opt(t) firstorder_using(l) ] ->
+ [ gen_ground_tac true (Option.map eval_tactic t) l [] ]
+| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] ->
+ [ gen_ground_tac true (Option.map eval_tactic t) [] l ]
+| [ "firstorder" tactic_opt(t) firstorder_using(l)
+ "with" ne_preident_list(l') ] ->
+ [ gen_ground_tac true (Option.map eval_tactic t) l l' ]
+| [ "firstorder" tactic_opt(t) ] ->
+ [ gen_ground_tac true (Option.map eval_tactic t) [] [] ]
+END
+
+TACTIC EXTEND gintuition
+ [ "gintuition" tactic_opt(t) ] ->
+ [ gen_ground_tac false (Option.map eval_tactic t) [] [] ]
+END
+
+
+let default_declarative_automation gls =
+ tclORELSE
+ (tclORELSE (Auto.h_trivial [] None)
+ (Cctac.congruence_tac !congruence_depth []))
+ (gen_ground_tac true
+ (Some (tclTHEN
+ default_solver
+ (Cctac.congruence_tac !congruence_depth [])))
+ [] []) gls
+
+
+
+let () =
+ Decl_proof_instr.register_automation_tac default_declarative_automation
+
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
new file mode 100644
index 00000000..8a0f02d2
--- /dev/null
+++ b/plugins/firstorder/ground.ml
@@ -0,0 +1,152 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Formula
+open Sequent
+open Rules
+open Instances
+open Term
+open Tacmach
+open Tactics
+open Tacticals
+open Libnames
+
+(*
+let old_search=ref !Auto.searchtable
+
+(* I use this solution as a means to know whether hints have changed,
+but this prevents the GC from collecting the previous table,
+resulting in some limited space wasting*)
+
+let update_flags ()=
+ if not ( !Auto.searchtable == !old_search ) then
+ begin
+ old_search:=!Auto.searchtable;
+ let predref=ref Names.KNpred.empty in
+ let f p_a_t =
+ match p_a_t.Auto.code with
+ Auto.Unfold_nth (ConstRef kn)->
+ predref:=Names.KNpred.add kn !predref
+ | _ ->() in
+ let g _ l=List.iter f l in
+ let h _ hdb=Auto.Hint_db.iter g hdb in
+ Util.Stringmap.iter h !Auto.searchtable;
+ red_flags:=
+ Closure.RedFlags.red_add_transparent
+ Closure.betaiotazeta (Names.Idpred.full,!predref)
+ end
+*)
+
+let update_flags ()=
+ let predref=ref Names.Cpred.empty in
+ let f coe=
+ try
+ let kn=destConst (Classops.get_coercion_value coe) in
+ predref:=Names.Cpred.add kn !predref
+ with Invalid_argument "destConst"-> () in
+ List.iter f (Classops.coercions ());
+ red_flags:=
+ Closure.RedFlags.red_add_transparent
+ Closure.betaiotazeta
+ (Names.Idpred.full,Names.Cpred.complement !predref)
+
+let ground_tac solver startseq gl=
+ update_flags ();
+ let rec toptac skipped seq gl=
+ if Tacinterp.get_debug()=Tactic_debug.DebugOn 0
+ then Pp.msgnl (Printer.pr_goal (sig_it gl));
+ tclORELSE (axiom_tac seq.gl seq)
+ begin
+ try
+ let (hd,seq1)=take_formula seq
+ and re_add s=re_add_formula_list skipped s in
+ let continue=toptac []
+ and backtrack gl=toptac (hd::skipped) seq1 gl in
+ match hd.pat with
+ Right rpat->
+ begin
+ match rpat with
+ Rand->
+ and_tac backtrack continue (re_add seq1)
+ | Rforall->
+ let backtrack1=
+ if !qflag then
+ tclFAIL 0 (Pp.str "reversible in 1st order mode")
+ else
+ backtrack in
+ forall_tac backtrack1 continue (re_add seq1)
+ | Rarrow->
+ arrow_tac backtrack continue (re_add seq1)
+ | Ror->
+ or_tac backtrack continue (re_add seq1)
+ | Rfalse->backtrack
+ | Rexists(i,dom,triv)->
+ let (lfp,seq2)=collect_quantified seq in
+ let backtrack2=toptac (lfp@skipped) seq2 in
+ if !qflag && seq.depth>0 then
+ quantified_tac lfp backtrack2
+ continue (re_add seq)
+ else
+ backtrack2 (* need special backtracking *)
+ end
+ | Left lpat->
+ begin
+ match lpat with
+ Lfalse->
+ left_false_tac hd.id
+ | Land ind->
+ left_and_tac ind backtrack
+ hd.id continue (re_add seq1)
+ | Lor ind->
+ left_or_tac ind backtrack
+ hd.id continue (re_add seq1)
+ | Lforall (_,_,_)->
+ let (lfp,seq2)=collect_quantified seq in
+ let backtrack2=toptac (lfp@skipped) seq2 in
+ if !qflag && seq.depth>0 then
+ quantified_tac lfp backtrack2
+ continue (re_add seq)
+ else
+ backtrack2 (* need special backtracking *)
+ | Lexists ind ->
+ if !qflag then
+ left_exists_tac ind backtrack hd.id
+ continue (re_add seq1)
+ else backtrack
+ | LA (typ,lap)->
+ let la_tac=
+ begin
+ match lap with
+ LLatom -> backtrack
+ | LLand (ind,largs) | LLor(ind,largs)
+ | LLfalse (ind,largs)->
+ (ll_ind_tac ind largs backtrack
+ hd.id continue (re_add seq1))
+ | LLforall p ->
+ if seq.depth>0 && !qflag then
+ (ll_forall_tac p backtrack
+ hd.id continue (re_add seq1))
+ else backtrack
+ | LLexists (ind,l) ->
+ if !qflag then
+ ll_ind_tac ind l backtrack
+ hd.id continue (re_add seq1)
+ else
+ backtrack
+ | LLarrow (a,b,c) ->
+ (ll_arrow_tac a b c backtrack
+ hd.id continue (re_add seq1))
+ end in
+ ll_atom_tac typ la_tac hd.id continue (re_add seq1)
+ end
+ with Heap.EmptyHeap->solver
+ end gl in
+ wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl
+
diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli
new file mode 100644
index 00000000..3c0e903f
--- /dev/null
+++ b/plugins/firstorder/ground.mli
@@ -0,0 +1,13 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+val ground_tac: Tacmach.tactic ->
+ (Proof_type.goal Tacmach.sigma -> Sequent.t) -> Tacmach.tactic
+
diff --git a/plugins/firstorder/ground_plugin.mllib b/plugins/firstorder/ground_plugin.mllib
new file mode 100644
index 00000000..447a1fb5
--- /dev/null
+++ b/plugins/firstorder/ground_plugin.mllib
@@ -0,0 +1,8 @@
+Formula
+Unify
+Sequent
+Rules
+Instances
+Ground
+G_ground
+Ground_plugin_mod
diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml
new file mode 100644
index 00000000..810262a6
--- /dev/null
+++ b/plugins/firstorder/instances.ml
@@ -0,0 +1,206 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Formula
+open Sequent
+open Unify
+open Rules
+open Util
+open Term
+open Rawterm
+open Tacmach
+open Tactics
+open Tacticals
+open Termops
+open Reductionops
+open Declarations
+open Formula
+open Sequent
+open Names
+open Libnames
+
+let compare_instance inst1 inst2=
+ match inst1,inst2 with
+ Phantom(d1),Phantom(d2)->
+ (OrderedConstr.compare d1 d2)
+ | Real((m1,c1),n1),Real((m2,c2),n2)->
+ ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2
+ | Phantom(_),Real((m,_),_)-> if m=0 then -1 else 1
+ | Real((m,_),_),Phantom(_)-> if m=0 then 1 else -1
+
+let compare_gr id1 id2=
+ if id1==id2 then 0 else
+ if id1==dummy_id then 1
+ else if id2==dummy_id then -1
+ else Pervasives.compare id1 id2
+
+module OrderedInstance=
+struct
+ type t=instance * Libnames.global_reference
+ let compare (inst1,id1) (inst2,id2)=
+ (compare_instance =? compare_gr) inst2 inst1 id2 id1
+ (* we want a __decreasing__ total order *)
+end
+
+module IS=Set.Make(OrderedInstance)
+
+let make_simple_atoms seq=
+ let ratoms=
+ match seq.glatom with
+ Some t->[t]
+ | None->[]
+ in {negative=seq.latoms;positive=ratoms}
+
+let do_sequent setref triv id seq i dom atoms=
+ let flag=ref true in
+ let phref=ref triv in
+ let do_atoms a1 a2 =
+ let do_pair t1 t2 =
+ match unif_atoms i dom t1 t2 with
+ None->()
+ | Some (Phantom _) ->phref:=true
+ | Some c ->flag:=false;setref:=IS.add (c,id) !setref in
+ List.iter (fun t->List.iter (do_pair t) a2.negative) a1.positive;
+ List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in
+ HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes;
+ do_atoms atoms (make_simple_atoms seq);
+ !flag && !phref
+
+let match_one_quantified_hyp setref seq lf=
+ match lf.pat with
+ Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))->
+ if do_sequent setref triv lf.id seq i dom lf.atoms then
+ setref:=IS.add ((Phantom dom),lf.id) !setref
+ | _ ->anomaly "can't happen"
+
+let give_instances lf seq=
+ let setref=ref IS.empty in
+ List.iter (match_one_quantified_hyp setref seq) lf;
+ IS.elements !setref
+
+(* collector for the engine *)
+
+let rec collect_quantified seq=
+ try
+ let hd,seq1=take_formula seq in
+ (match hd.pat with
+ Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) ->
+ let (q,seq2)=collect_quantified seq1 in
+ ((hd::q),seq2)
+ | _->[],seq)
+ with Heap.EmptyHeap -> [],seq
+
+(* open instances processor *)
+
+let dummy_constr=mkMeta (-1)
+
+let dummy_bvid=id_of_string "x"
+
+let mk_open_instance id gl m t=
+ let env=pf_env gl in
+ let evmap=Refiner.project gl in
+ let var_id=
+ if id==dummy_id then dummy_bvid else
+ let typ=pf_type_of gl (constr_of_global id) in
+ (* since we know we will get a product,
+ reduction is not too expensive *)
+ let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in
+ match nam with
+ Name id -> id
+ | Anonymous -> dummy_bvid in
+ let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in
+ let rec aux n avoid=
+ if n=0 then [] else
+ let nid=(fresh_id avoid var_id gl) in
+ (Name nid,None,dummy_constr)::(aux (n-1) (nid::avoid)) in
+ let nt=it_mkLambda_or_LetIn revt (aux m []) in
+ let rawt=Detyping.detype false [] [] nt in
+ let rec raux n t=
+ if n=0 then t else
+ match t with
+ RLambda(loc,name,k,_,t0)->
+ let t1=raux (n-1) t0 in
+ RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1)
+ | _-> anomaly "can't happen" in
+ let ntt=try
+ Pretyping.Default.understand evmap env (raux m rawt)
+ with _ ->
+ error "Untypable instance, maybe higher-order non-prenex quantification" in
+ decompose_lam_n_assum m ntt
+
+(* tactics *)
+
+let left_instance_tac (inst,id) continue seq=
+ match inst with
+ Phantom dom->
+ if lookup (id,None) seq then
+ tclFAIL 0 (Pp.str "already done")
+ else
+ tclTHENS (cut dom)
+ [tclTHENLIST
+ [introf;
+ (fun gls->generalize
+ [mkApp(constr_of_global id,
+ [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls);
+ introf;
+ tclSOLVE [wrap 1 false continue
+ (deepen (record (id,None) seq))]];
+ tclTRY assumption]
+ | Real((m,t) as c,_)->
+ if lookup (id,Some c) seq then
+ tclFAIL 0 (Pp.str "already done")
+ else
+ let special_generalize=
+ if m>0 then
+ fun gl->
+ let (rc,ot)= mk_open_instance id gl m t in
+ let gt=
+ it_mkLambda_or_LetIn
+ (mkApp(constr_of_global id,[|ot|])) rc in
+ generalize [gt] gl
+ else
+ generalize [mkApp(constr_of_global id,[|t|])]
+ in
+ tclTHENLIST
+ [special_generalize;
+ introf;
+ tclSOLVE
+ [wrap 1 false continue (deepen (record (id,Some c) seq))]]
+
+let right_instance_tac inst continue seq=
+ match inst with
+ Phantom dom ->
+ tclTHENS (cut dom)
+ [tclTHENLIST
+ [introf;
+ (fun gls->
+ split (Rawterm.ImplicitBindings
+ [mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls);
+ tclSOLVE [wrap 0 true continue (deepen seq)]];
+ tclTRY assumption]
+ | Real ((0,t),_) ->
+ (tclTHEN (split (Rawterm.ImplicitBindings [t]))
+ (tclSOLVE [wrap 0 true continue (deepen seq)]))
+ | Real ((m,t),_) ->
+ tclFAIL 0 (Pp.str "not implemented ... yet")
+
+let instance_tac inst=
+ if (snd inst)==dummy_id then
+ right_instance_tac (fst inst)
+ else
+ left_instance_tac inst
+
+let quantified_tac lf backtrack continue seq gl=
+ let insts=give_instances lf seq in
+ tclORELSE
+ (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts))
+ backtrack gl
+
+
diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli
new file mode 100644
index 00000000..95dd22ea
--- /dev/null
+++ b/plugins/firstorder/instances.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Term
+open Tacmach
+open Names
+open Libnames
+open Rules
+
+val collect_quantified : Sequent.t -> Formula.t list * Sequent.t
+
+val give_instances : Formula.t list -> Sequent.t ->
+ (Unify.instance * global_reference) list
+
+val quantified_tac : Formula.t list -> seqtac with_backtracking
+
+
+
+
diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml
new file mode 100644
index 00000000..515efea7
--- /dev/null
+++ b/plugins/firstorder/rules.ml
@@ -0,0 +1,215 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Util
+open Names
+open Term
+open Tacmach
+open Tactics
+open Tacticals
+open Termops
+open Declarations
+open Formula
+open Sequent
+open Libnames
+
+type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
+
+type lseqtac= global_reference -> seqtac
+
+type 'a with_backtracking = tactic -> 'a
+
+let wrap n b continue seq gls=
+ check_for_interrupt ();
+ let nc=pf_hyps gls in
+ let env=pf_env gls in
+ let rec aux i nc ctx=
+ if i<=0 then seq else
+ match nc with
+ []->anomaly "Not the expected number of hyps"
+ | ((id,_,typ) as nd)::q->
+ if occur_var env id (pf_concl gls) ||
+ List.exists (occur_var_in_decl env id) ctx then
+ (aux (i-1) q (nd::ctx))
+ else
+ add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in
+ let seq1=aux n nc [] in
+ let seq2=if b then
+ add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in
+ continue seq2 gls
+
+let basename_of_global=function
+ VarRef id->id
+ | _->assert false
+
+let clear_global=function
+ VarRef id->clear [id]
+ | _->tclIDTAC
+
+
+(* connection rules *)
+
+let axiom_tac t seq=
+ try exact_no_check (constr_of_global (find_left t seq))
+ with Not_found->tclFAIL 0 (Pp.str "No axiom link")
+
+let ll_atom_tac a backtrack id continue seq=
+ tclIFTHENELSE
+ (try
+ tclTHENLIST
+ [generalize [mkApp(constr_of_global id,
+ [|constr_of_global (find_left a seq)|])];
+ clear_global id;
+ intro]
+ with Not_found->tclFAIL 0 (Pp.str "No link"))
+ (wrap 1 false continue seq) backtrack
+
+(* right connectives rules *)
+
+let and_tac backtrack continue seq=
+ tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack
+
+let or_tac backtrack continue seq=
+ tclORELSE
+ (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq))))
+ backtrack
+
+let arrow_tac backtrack continue seq=
+ tclIFTHENELSE intro (wrap 1 true continue seq)
+ (tclORELSE
+ (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq)))
+ backtrack)
+(* left connectives rules *)
+
+let left_and_tac ind backtrack id continue seq gls=
+ let n=(construct_nhyps ind gls).(0) in
+ tclIFTHENELSE
+ (tclTHENLIST
+ [simplest_elim (constr_of_global id);
+ clear_global id;
+ tclDO n intro])
+ (wrap n false continue seq)
+ backtrack gls
+
+let left_or_tac ind backtrack id continue seq gls=
+ let v=construct_nhyps ind gls in
+ let f n=
+ tclTHENLIST
+ [clear_global id;
+ tclDO n intro;
+ wrap n false continue seq] in
+ tclIFTHENSVELSE
+ (simplest_elim (constr_of_global id))
+ (Array.map f v)
+ backtrack gls
+
+let left_false_tac id=
+ simplest_elim (constr_of_global id)
+
+(* left arrow connective rules *)
+
+(* We use this function for false, and, or, exists *)
+
+let ll_ind_tac ind largs backtrack id continue seq gl=
+ let rcs=ind_hyps 0 ind largs gl in
+ let vargs=Array.of_list largs in
+ (* construire le terme H->B, le generaliser etc *)
+ let myterm i=
+ let rc=rcs.(i) in
+ let p=List.length rc in
+ let cstr=mkApp ((mkConstruct (ind,(i+1))),vargs) in
+ let vars=Array.init p (fun j->mkRel (p-j)) in
+ let capply=mkApp ((lift p cstr),vars) in
+ let head=mkApp ((lift p (constr_of_global id)),[|capply|]) in
+ it_mkLambda_or_LetIn head rc in
+ let lp=Array.length rcs in
+ let newhyps=list_tabulate myterm lp in
+ tclIFTHENELSE
+ (tclTHENLIST
+ [generalize newhyps;
+ clear_global id;
+ tclDO lp intro])
+ (wrap lp false continue seq) backtrack gl
+
+let ll_arrow_tac a b c backtrack id continue seq=
+ let cc=mkProd(Anonymous,a,(lift 1 b)) in
+ let d=mkLambda (Anonymous,b,
+ mkApp ((constr_of_global id),
+ [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in
+ tclORELSE
+ (tclTHENS (cut c)
+ [tclTHENLIST
+ [introf;
+ clear_global id;
+ wrap 1 false continue seq];
+ tclTHENS (cut cc)
+ [exact_no_check (constr_of_global id);
+ tclTHENLIST
+ [generalize [d];
+ clear_global id;
+ introf;
+ introf;
+ tclCOMPLETE (wrap 2 true continue seq)]]])
+ backtrack
+
+(* quantifier rules (easy side) *)
+
+let forall_tac backtrack continue seq=
+ tclORELSE
+ (tclIFTHENELSE intro (wrap 0 true continue seq)
+ (tclORELSE
+ (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq)))
+ backtrack))
+ (if !qflag then
+ tclFAIL 0 (Pp.str "reversible in 1st order mode")
+ else
+ backtrack)
+
+let left_exists_tac ind backtrack id continue seq gls=
+ let n=(construct_nhyps ind gls).(0) in
+ tclIFTHENELSE
+ (simplest_elim (constr_of_global id))
+ (tclTHENLIST [clear_global id;
+ tclDO n intro;
+ (wrap (n-1) false continue seq)])
+ backtrack
+ gls
+
+let ll_forall_tac prod backtrack id continue seq=
+ tclORELSE
+ (tclTHENS (cut prod)
+ [tclTHENLIST
+ [intro;
+ (fun gls->
+ let id0=pf_nth_hyp_id gls 1 in
+ let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in
+ tclTHEN (generalize [term]) (clear [id0]) gls);
+ clear_global id;
+ intro;
+ tclCOMPLETE (wrap 1 false continue (deepen seq))];
+ tclCOMPLETE (wrap 0 true continue (deepen seq))])
+ backtrack
+
+(* rules for instantiation with unification moved to instances.ml *)
+
+(* special for compatibility with old Intuition *)
+
+let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
+
+let defined_connectives=lazy
+ [all_occurrences,EvalConstRef (destConst (constant "not"));
+ all_occurrences,EvalConstRef (destConst (constant "iff"))]
+
+let normalize_evaluables=
+ onAllHypsAndConcl
+ (function
+ None->unfold_in_concl (Lazy.force defined_connectives)
+ | Some id ->
+ unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly))
diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli
new file mode 100644
index 00000000..fc32621c
--- /dev/null
+++ b/plugins/firstorder/rules.mli
@@ -0,0 +1,54 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Term
+open Tacmach
+open Names
+open Libnames
+
+type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
+
+type lseqtac= global_reference -> seqtac
+
+type 'a with_backtracking = tactic -> 'a
+
+val wrap : int -> bool -> seqtac
+
+val basename_of_global: global_reference -> identifier
+
+val clear_global: global_reference -> tactic
+
+val axiom_tac : constr -> Sequent.t -> tactic
+
+val ll_atom_tac : constr -> lseqtac with_backtracking
+
+val and_tac : seqtac with_backtracking
+
+val or_tac : seqtac with_backtracking
+
+val arrow_tac : seqtac with_backtracking
+
+val left_and_tac : inductive -> lseqtac with_backtracking
+
+val left_or_tac : inductive -> lseqtac with_backtracking
+
+val left_false_tac : global_reference -> tactic
+
+val ll_ind_tac : inductive -> constr list -> lseqtac with_backtracking
+
+val ll_arrow_tac : constr -> constr -> constr -> lseqtac with_backtracking
+
+val forall_tac : seqtac with_backtracking
+
+val left_exists_tac : inductive -> lseqtac with_backtracking
+
+val ll_forall_tac : types -> lseqtac with_backtracking
+
+val normalize_evaluables : tactic
diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
new file mode 100644
index 00000000..685d44a8
--- /dev/null
+++ b/plugins/firstorder/sequent.ml
@@ -0,0 +1,312 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Term
+open Util
+open Formula
+open Unify
+open Tacmach
+open Names
+open Libnames
+open Pp
+
+let newcnt ()=
+ let cnt=ref (-1) in
+ fun b->if b then incr cnt;!cnt
+
+let priority = (* pure heuristics, <=0 for non reversible *)
+ function
+ Right rf->
+ begin
+ match rf with
+ Rarrow -> 100
+ | Rand -> 40
+ | Ror -> -15
+ | Rfalse -> -50
+ | Rforall -> 100
+ | Rexists (_,_,_) -> -29
+ end
+ | Left lf ->
+ match lf with
+ Lfalse -> 999
+ | Land _ -> 90
+ | Lor _ -> 40
+ | Lforall (_,_,_) -> -30
+ | Lexists _ -> 60
+ | LA(_,lap) ->
+ match lap with
+ LLatom -> 0
+ | LLfalse (_,_) -> 100
+ | LLand (_,_) -> 80
+ | LLor (_,_) -> 70
+ | LLforall _ -> -20
+ | LLexists (_,_) -> 50
+ | LLarrow (_,_,_) -> -10
+
+let left_reversible lpat=(priority lpat)>0
+
+module OrderedFormula=
+struct
+ type t=Formula.t
+ let compare e1 e2=
+ (priority e1.pat) - (priority e2.pat)
+end
+
+(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
+ the immediate subterms of [c1] of [c2] if needed; Cast's,
+ application associativity, binders name and Cases annotations are
+ not taken into account *)
+
+let rec compare_list f l1 l2=
+ match l1,l2 with
+ [],[]-> 0
+ | [],_ -> -1
+ | _,[] -> 1
+ | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2
+
+let compare_array f v1 v2=
+ let l=Array.length v1 in
+ let c=l - Array.length v2 in
+ if c=0 then
+ let rec comp_aux i=
+ if i<0 then 0
+ else
+ let ci=f v1.(i) v2.(i) in
+ if ci=0 then
+ comp_aux (i-1)
+ else ci
+ in comp_aux (l-1)
+ else c
+
+let compare_constr_int f t1 t2 =
+ match kind_of_term t1, kind_of_term t2 with
+ | Rel n1, Rel n2 -> n1 - n2
+ | Meta m1, Meta m2 -> m1 - m2
+ | Var id1, Var id2 -> Pervasives.compare id1 id2
+ | Sort s1, Sort s2 -> Pervasives.compare s1 s2
+ | Cast (c1,_,_), _ -> f c1 t2
+ | _, Cast (c2,_,_) -> f t1 c2
+ | Prod (_,t1,c1), Prod (_,t2,c2)
+ | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
+ (f =? f) t1 t2 c1 c2
+ | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
+ ((f =? f) ==? f) b1 b2 t1 t2 c1 c2
+ | App (_,_), App (_,_) ->
+ let c1,l1=decompose_app t1
+ and c2,l2=decompose_app t2 in
+ (f =? (compare_list f)) c1 c2 l1 l2
+ | Evar (e1,l1), Evar (e2,l2) ->
+ ((-) =? (compare_array f)) e1 e2 l1 l2
+ | Const c1, Const c2 -> Pervasives.compare c1 c2
+ | Ind c1, Ind c2 -> Pervasives.compare c1 c2
+ | Construct c1, Construct c2 -> Pervasives.compare c1 c2
+ | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+ ((f =? f) ==? (compare_array f)) p1 p2 c1 c2 bl1 bl2
+ | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+ ((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
+ ln1 ln2 tl1 tl2 bl1 bl2
+ | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+ ((Pervasives.compare =? (compare_array f)) ==? (compare_array f))
+ ln1 ln2 tl1 tl2 bl1 bl2
+ | _ -> Pervasives.compare t1 t2
+
+let rec compare_constr m n=
+ compare_constr_int compare_constr m n
+
+module OrderedConstr=
+struct
+ type t=constr
+ let compare=compare_constr
+end
+
+type h_item = global_reference * (int*constr) option
+
+module Hitem=
+struct
+ type t = h_item
+ let compare (id1,co1) (id2,co2)=
+ (Pervasives.compare
+ =? (fun oc1 oc2 ->
+ match oc1,oc2 with
+ Some (m1,c1),Some (m2,c2) ->
+ ((-) =? OrderedConstr.compare) m1 m2 c1 c2
+ | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2
+end
+
+module CM=Map.Make(OrderedConstr)
+
+module History=Set.Make(Hitem)
+
+let cm_add typ nam cm=
+ try
+ let l=CM.find typ cm in CM.add typ (nam::l) cm
+ with
+ Not_found->CM.add typ [nam] cm
+
+let cm_remove typ nam cm=
+ try
+ let l=CM.find typ cm in
+ let l0=List.filter (fun id->id<>nam) l in
+ match l0 with
+ []->CM.remove typ cm
+ | _ ->CM.add typ l0 cm
+ with Not_found ->cm
+
+module HP=Heap.Functional(OrderedFormula)
+
+type t=
+ {redexes:HP.t;
+ context:(global_reference list) CM.t;
+ latoms:constr list;
+ gl:types;
+ glatom:constr option;
+ cnt:counter;
+ history:History.t;
+ depth:int}
+
+let deepen seq={seq with depth=seq.depth-1}
+
+let record item seq={seq with history=History.add item seq.history}
+
+let lookup item seq=
+ History.mem item seq.history ||
+ match item with
+ (_,None)->false
+ | (id,Some ((m,t) as c))->
+ let p (id2,o)=
+ match o with
+ None -> false
+ | Some ((m2,t2) as c2)->id=id2 && m2>m && more_general c2 c in
+ History.exists p seq.history
+
+let rec add_formula side nam t seq gl=
+ match build_formula side nam t gl seq.cnt with
+ Left f->
+ begin
+ match side with
+ Concl ->
+ {seq with
+ redexes=HP.add f seq.redexes;
+ gl=f.constr;
+ glatom=None}
+ | _ ->
+ {seq with
+ redexes=HP.add f seq.redexes;
+ context=cm_add f.constr nam seq.context}
+ end
+ | Right t->
+ match side with
+ Concl ->
+ {seq with gl=t;glatom=Some t}
+ | _ ->
+ {seq with
+ context=cm_add t nam seq.context;
+ latoms=t::seq.latoms}
+
+let re_add_formula_list lf seq=
+ let do_one f cm=
+ if f.id == dummy_id then cm
+ else cm_add f.constr f.id cm in
+ {seq with
+ redexes=List.fold_right HP.add lf seq.redexes;
+ context=List.fold_right do_one lf seq.context}
+
+let find_left t seq=List.hd (CM.find t seq.context)
+
+(*let rev_left seq=
+ try
+ let lpat=(HP.maximum seq.redexes).pat in
+ left_reversible lpat
+ with Heap.EmptyHeap -> false
+*)
+let no_formula seq=
+ seq.redexes=HP.empty
+
+let rec take_formula seq=
+ let hd=HP.maximum seq.redexes
+ and hp=HP.remove seq.redexes in
+ if hd.id == dummy_id then
+ let nseq={seq with redexes=hp} in
+ if seq.gl==hd.constr then
+ hd,nseq
+ else
+ take_formula nseq (* discarding deprecated goal *)
+ else
+ hd,{seq with
+ redexes=hp;
+ context=cm_remove hd.constr hd.id seq.context}
+
+let empty_seq depth=
+ {redexes=HP.empty;
+ context=CM.empty;
+ latoms=[];
+ gl=(mkMeta 1);
+ glatom=None;
+ cnt=newcnt ();
+ history=History.empty;
+ depth=depth}
+
+let expand_constructor_hints =
+ list_map_append (function
+ | IndRef ind ->
+ list_tabulate (fun i -> ConstructRef (ind,i+1))
+ (Inductiveops.nconstructors ind)
+ | gr ->
+ [gr])
+
+let extend_with_ref_list l seq gl=
+ let l = expand_constructor_hints l in
+ let f gr seq=
+ let c=constr_of_global gr in
+ let typ=(pf_type_of gl c) in
+ add_formula Hyp gr typ seq gl in
+ List.fold_right f l seq
+
+open Auto
+
+let extend_with_auto_hints l seq gl=
+ let seqref=ref seq in
+ let f p_a_t =
+ match p_a_t.code with
+ Res_pf (c,_) | Give_exact c
+ | Res_pf_THEN_trivial_fail (c,_) ->
+ (try
+ let gr=global_of_constr c in
+ let typ=(pf_type_of gl c) in
+ seqref:=add_formula Hint gr typ !seqref gl
+ with Not_found->())
+ | _-> () in
+ let g _ l=List.iter f l in
+ let h dbname=
+ let hdb=
+ try
+ searchtable_map dbname
+ with Not_found->
+ error ("Firstorder: "^dbname^" : No such Hint database") in
+ Hint_db.iter g hdb in
+ List.iter h l;
+ !seqref
+
+let print_cmap map=
+ let print_entry c l s=
+ let xc=Constrextern.extern_constr false (Global.env ()) c in
+ str "| " ++
+ Util.prlist Printer.pr_global l ++
+ str " : " ++
+ Ppconstr.pr_constr_expr xc ++
+ cut () ++
+ s in
+ msgnl (v 0
+ (str "-----" ++
+ cut () ++
+ CM.fold print_entry map (mt ()) ++
+ str "-----"))
+
+
diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli
new file mode 100644
index 00000000..ce0eddcc
--- /dev/null
+++ b/plugins/firstorder/sequent.mli
@@ -0,0 +1,66 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Term
+open Util
+open Formula
+open Tacmach
+open Names
+open Libnames
+
+module OrderedConstr: Set.OrderedType with type t=constr
+
+module CM: Map.S with type key=constr
+
+type h_item = global_reference * (int*constr) option
+
+module History: Set.S with type elt = h_item
+
+val cm_add : constr -> global_reference -> global_reference list CM.t ->
+ global_reference list CM.t
+
+val cm_remove : constr -> global_reference -> global_reference list CM.t ->
+ global_reference list CM.t
+
+module HP: Heap.S with type elt=Formula.t
+
+type t = {redexes:HP.t;
+ context: global_reference list CM.t;
+ latoms:constr list;
+ gl:types;
+ glatom:constr option;
+ cnt:counter;
+ history:History.t;
+ depth:int}
+
+val deepen: t -> t
+
+val record: h_item -> t -> t
+
+val lookup: h_item -> t -> bool
+
+val add_formula : side -> global_reference -> constr -> t ->
+ Proof_type.goal sigma -> t
+
+val re_add_formula_list : Formula.t list -> t -> t
+
+val find_left : constr -> t -> global_reference
+
+val take_formula : t -> Formula.t * t
+
+val empty_seq : int -> t
+
+val extend_with_ref_list : global_reference list ->
+ t -> Proof_type.goal sigma -> t
+
+val extend_with_auto_hints : Auto.hint_db_name list ->
+ t -> Proof_type.goal sigma -> t
+
+val print_cmap: global_reference list CM.t -> unit
diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml
new file mode 100644
index 00000000..e3a4c6a5
--- /dev/null
+++ b/plugins/firstorder/unify.ml
@@ -0,0 +1,143 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Util
+open Formula
+open Tacmach
+open Term
+open Names
+open Termops
+open Reductionops
+
+exception UFAIL of constr*constr
+
+(*
+ RIGID-only Martelli-Montanari style unification for CLOSED terms
+ I repeat : t1 and t2 must NOT have ANY free deBruijn
+ sigma is kept normal with respect to itself but is lazily applied
+ to the equation set. Raises UFAIL with a pair of terms
+*)
+
+let unif t1 t2=
+ let bige=Queue.create ()
+ and sigma=ref [] in
+ let bind i t=
+ sigma:=(i,t)::
+ (List.map (function (n,tn)->(n,subst_meta [i,t] tn)) !sigma) in
+ let rec head_reduce t=
+ (* forbids non-sigma-normal meta in head position*)
+ match kind_of_term t with
+ Meta i->
+ (try
+ head_reduce (List.assoc i !sigma)
+ with Not_found->t)
+ | _->t in
+ Queue.add (t1,t2) bige;
+ try while true do
+ let t1,t2=Queue.take bige in
+ let nt1=head_reduce (whd_betaiotazeta Evd.empty t1)
+ and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in
+ match (kind_of_term nt1),(kind_of_term nt2) with
+ Meta i,Meta j->
+ if i<>j then
+ if i<j then bind j nt1
+ else bind i nt2
+ | Meta i,_ ->
+ let t=subst_meta !sigma nt2 in
+ if Intset.is_empty (free_rels t) &&
+ not (occur_term (mkMeta i) t) then
+ bind i t else raise (UFAIL(nt1,nt2))
+ | _,Meta i ->
+ let t=subst_meta !sigma nt1 in
+ if Intset.is_empty (free_rels t) &&
+ not (occur_term (mkMeta i) t) then
+ bind i t else raise (UFAIL(nt1,nt2))
+ | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige
+ | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige
+ | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))->
+ Queue.add (a,c) bige;Queue.add (pop b,pop d) bige
+ | Case (_,pa,ca,va),Case (_,pb,cb,vb)->
+ Queue.add (pa,pb) bige;
+ Queue.add (ca,cb) bige;
+ let l=Array.length va in
+ if l<>(Array.length vb) then
+ raise (UFAIL (nt1,nt2))
+ else
+ for i=0 to l-1 do
+ Queue.add (va.(i),vb.(i)) bige
+ done
+ | App(ha,va),App(hb,vb)->
+ Queue.add (ha,hb) bige;
+ let l=Array.length va in
+ if l<>(Array.length vb) then
+ raise (UFAIL (nt1,nt2))
+ else
+ for i=0 to l-1 do
+ Queue.add (va.(i),vb.(i)) bige
+ done
+ | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2))
+ done;
+ assert false
+ (* this place is unreachable but needed for the sake of typing *)
+ with Queue.Empty-> !sigma
+
+let value i t=
+ let add x y=
+ if x<0 then y else if y<0 then x else x+y in
+ let tref=mkMeta i in
+ let rec vaux term=
+ if term=tref then 0 else
+ let f v t=add v (vaux t) in
+ let vr=fold_constr f (-1) term in
+ if vr<0 then -1 else vr+1 in
+ vaux t
+
+type instance=
+ Real of (int*constr)*int
+ | Phantom of constr
+
+let mk_rel_inst t=
+ let new_rel=ref 1 in
+ let rel_env=ref [] in
+ let rec renum_rec d t=
+ match kind_of_term t with
+ Meta n->
+ (try
+ mkRel (d+(List.assoc n !rel_env))
+ with Not_found->
+ let m= !new_rel in
+ incr new_rel;
+ rel_env:=(n,m) :: !rel_env;
+ mkRel (m+d))
+ | _ -> map_constr_with_binders succ renum_rec d t
+ in
+ let nt=renum_rec 0 t in (!new_rel - 1,nt)
+
+let unif_atoms i dom t1 t2=
+ try
+ let t=List.assoc i (unif t1 t2) in
+ if isMeta t then Some (Phantom dom)
+ else Some (Real(mk_rel_inst t,value i t1))
+ with
+ UFAIL(_,_) ->None
+ | Not_found ->Some (Phantom dom)
+
+let renum_metas_from k n t= (* requires n = max (free_rels t) *)
+ let l=list_tabulate (fun i->mkMeta (k+i)) n in
+ substl l t
+
+let more_general (m1,t1) (m2,t2)=
+ let mt1=renum_metas_from 0 m1 t1
+ and mt2=renum_metas_from m1 m2 t2 in
+ try
+ let sigma=unif mt1 mt2 in
+ let p (n,t)= n<m1 || isMeta t in
+ List.for_all p sigma
+ with UFAIL(_,_)->false
diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli
new file mode 100644
index 00000000..d6cb3a08
--- /dev/null
+++ b/plugins/firstorder/unify.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Term
+
+exception UFAIL of constr*constr
+
+val unif : constr -> constr -> (int*constr) list
+
+type instance=
+ Real of (int*constr)*int (* nb trous*terme*valeur heuristique *)
+ | Phantom of constr (* domaine de quantification *)
+
+val unif_atoms : metavariable -> constr -> constr -> constr -> instance option
+
+val more_general : (int*constr) -> (int*constr) -> bool
diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v
new file mode 100644
index 00000000..07b2973a
--- /dev/null
+++ b/plugins/fourier/Fourier.v
@@ -0,0 +1,21 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* "Fourier's method to solve linear inequations/equations systems.".*)
+
+Require Export LegacyRing.
+Require Export LegacyField.
+Require Export DiscrR.
+Require Export Fourier_util.
+Declare ML Module "fourier_plugin".
+
+Ltac fourier := abstract (fourierz; field; discrR).
+
+Ltac fourier_eq := apply Rge_antisym; fourier.
diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v
new file mode 100644
index 00000000..0fd92d60
--- /dev/null
+++ b/plugins/fourier/Fourier_util.v
@@ -0,0 +1,222 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Export Rbase.
+Comments "Lemmas used by the tactic Fourier".
+
+Open Scope R_scope.
+
+Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1.
+intros; apply Rmult_lt_compat_l; assumption.
+Qed.
+
+Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1.
+red in |- *.
+intros.
+case H; auto with real.
+Qed.
+
+Lemma Rfourier_lt_lt :
+ forall x1 y1 x2 y2 a:R,
+ x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
+intros x1 y1 x2 y2 a H H0 H1; try assumption.
+apply Rplus_lt_compat.
+try exact H.
+apply Rfourier_lt.
+try exact H0.
+try exact H1.
+Qed.
+
+Lemma Rfourier_lt_le :
+ forall x1 y1 x2 y2 a:R,
+ x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
+intros x1 y1 x2 y2 a H H0 H1; try assumption.
+case H0; intros.
+apply Rplus_lt_compat.
+try exact H.
+apply Rfourier_lt; auto with real.
+rewrite H2.
+rewrite (Rplus_comm y1 (a * y2)).
+rewrite (Rplus_comm x1 (a * y2)).
+apply Rplus_lt_compat_l.
+try exact H.
+Qed.
+
+Lemma Rfourier_le_lt :
+ forall x1 y1 x2 y2 a:R,
+ x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
+intros x1 y1 x2 y2 a H H0 H1; try assumption.
+case H; intros.
+apply Rfourier_lt_le; auto with real.
+rewrite H2.
+apply Rplus_lt_compat_l.
+apply Rfourier_lt; auto with real.
+Qed.
+
+Lemma Rfourier_le_le :
+ forall x1 y1 x2 y2 a:R,
+ x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2.
+intros x1 y1 x2 y2 a H H0 H1; try assumption.
+case H0; intros.
+red in |- *.
+left; try assumption.
+apply Rfourier_le_lt; auto with real.
+rewrite H2.
+case H; intros.
+red in |- *.
+left; try assumption.
+rewrite (Rplus_comm x1 (a * y2)).
+rewrite (Rplus_comm y1 (a * y2)).
+apply Rplus_lt_compat_l.
+try exact H3.
+rewrite H3.
+red in |- *.
+right; try assumption.
+auto with real.
+Qed.
+
+Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x.
+intros x H; try assumption.
+rewrite Rplus_comm.
+apply Rle_lt_0_plus_1.
+red in |- *; auto with real.
+Qed.
+
+Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y.
+intros x y H H0; try assumption.
+replace 0 with (x * 0).
+apply Rmult_lt_compat_l; auto with real.
+ring.
+Qed.
+
+Lemma Rlt_zero_1 : 0 < 1.
+exact Rlt_0_1.
+Qed.
+
+Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x.
+intros x H; try assumption.
+case H; intros.
+red in |- *.
+left; try assumption.
+apply Rlt_zero_pos_plus1; auto with real.
+rewrite <- H0.
+replace (1 + 0) with 1.
+red in |- *; left.
+exact Rlt_zero_1.
+ring.
+Qed.
+
+Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y.
+intros x y H H0; try assumption.
+case H; intros.
+red in |- *; left.
+apply Rlt_mult_inv_pos; auto with real.
+rewrite <- H1.
+red in |- *; right; ring.
+Qed.
+
+Lemma Rle_zero_1 : 0 <= 1.
+red in |- *; left.
+exact Rlt_zero_1.
+Qed.
+
+Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d.
+intros n d H; red in |- *; intros H0; try exact H0.
+generalize (Rgt_not_le 0 (n * / d)).
+intros H1; elim H1; try assumption.
+replace (n * / d) with (- - (n * / d)).
+replace 0 with (- -0).
+replace (- (n * / d)) with (- n * / d).
+replace (-0) with 0.
+red in |- *.
+apply Ropp_gt_lt_contravar.
+red in |- *.
+exact H0.
+ring.
+ring.
+ring.
+ring.
+Qed.
+
+Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x.
+intros x; try assumption.
+replace (0 * x) with 0.
+apply Rlt_irrefl.
+ring.
+Qed.
+
+Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d.
+intros n d H; try assumption.
+apply Rgt_not_le.
+replace 0 with (-0).
+replace (- n * / d) with (- (n * / d)).
+apply Ropp_lt_gt_contravar.
+try exact H.
+ring.
+ring.
+Qed.
+
+Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y.
+unfold not in |- *; intros.
+apply H.
+apply Rplus_lt_reg_r with x.
+replace (x + 0) with x.
+replace (x + (y - x)) with y.
+try exact H0.
+ring.
+ring.
+Qed.
+
+Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y.
+unfold not in |- *; intros.
+apply H.
+case H0; intros.
+left.
+apply Rplus_lt_reg_r with x.
+replace (x + 0) with x.
+replace (x + (y - x)) with y.
+try exact H1.
+ring.
+ring.
+right.
+rewrite H1; ring.
+Qed.
+
+Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y.
+unfold Rgt in |- *; intros; assumption.
+Qed.
+
+Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y.
+intros x y; exact (Rge_le y x).
+Qed.
+
+Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y.
+exact Req_le.
+Qed.
+
+Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y.
+exact Req_le_sym.
+Qed.
+
+Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y.
+exact Rnot_ge_lt.
+Qed.
+
+Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y.
+exact Rnot_gt_le.
+Qed.
+
+Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y.
+exact Rnot_le_lt.
+Qed.
+
+Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y.
+exact Rnot_lt_ge.
+Qed.
diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml
new file mode 100644
index 00000000..73fb4929
--- /dev/null
+++ b/plugins/fourier/fourier.ml
@@ -0,0 +1,205 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* Méthode d'élimination de Fourier *)
+(* Référence:
+Auteur(s) : Fourier, Jean-Baptiste-Joseph
+
+Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
+
+Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
+
+Pages: 326-327
+
+http://gallica.bnf.fr/
+*)
+
+(* Un peu de calcul sur les rationnels...
+Les opérations rendent des rationnels normalisés,
+i.e. le numérateur et le dénominateur sont premiers entre eux.
+*)
+type rational = {num:int;
+ den:int}
+;;
+let print_rational x =
+ print_int x.num;
+ print_string "/";
+ print_int x.den
+;;
+
+let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);;
+
+
+let r0 = {num=0;den=1};;
+let r1 = {num=1;den=1};;
+
+let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
+ if x.num=0 then r0
+ else (let d=pgcd x.num x.den in
+ let d= (if d<0 then -d else d) in
+ {num=(x.num)/d;den=(x.den)/d});;
+
+let rop x = rnorm {num=(-x.num);den=x.den};;
+
+let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
+
+let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};;
+
+let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};;
+
+let rinv x = rnorm {num=x.den;den=x.num};;
+
+let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
+
+let rinf x y = x.num*y.den < y.num*x.den;;
+let rinfeq x y = x.num*y.den <= y.num*x.den;;
+
+(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
+c1x1+...+cnxn < d si strict=true, <= sinon,
+hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
+*)
+
+type ineq = {coef:rational list;
+ hist:rational list;
+ strict:bool};;
+
+let pop x l = l:=x::(!l);;
+
+(* sépare la liste d'inéquations s selon que leur premier coefficient est
+négatif, nul ou positif. *)
+let partitionne s =
+ let lpos=ref [] in
+ let lneg=ref [] in
+ let lnul=ref [] in
+ List.iter (fun ie -> match ie.coef with
+ [] -> raise (Failure "empty ineq")
+ |(c::r) -> if rinf c r0
+ then pop ie lneg
+ else if rinf r0 c then pop ie lpos
+ else pop ie lnul)
+ s;
+ [!lneg;!lnul;!lpos]
+;;
+(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
+(add_hist [(equation 1, s1);...;(équation n, sn)])
+=
+[{équation 1, [1;0;...;0], s1};
+ {équation 2, [0;1;...;0], s2};
+ ...
+ {équation n, [0;0;...;1], sn}]
+*)
+let add_hist le =
+ let n = List.length le in
+ let i=ref 0 in
+ List.map (fun (ie,s) ->
+ let h =ref [] in
+ for k=1 to (n-(!i)-1) do pop r0 h; done;
+ pop r1 h;
+ for k=1 to !i do pop r0 h; done;
+ i:=!i+1;
+ {coef=ie;hist=(!h);strict=s})
+ le
+;;
+(* additionne deux inéquations *)
+let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
+ hist=List.map2 rplus ie1.hist ie2.hist;
+ strict=ie1.strict || ie2.strict}
+;;
+(* multiplication d'une inéquation par un rationnel (positif) *)
+let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
+ hist=List.map (fun x -> rmult a x) ie.hist;
+ strict= ie.strict}
+;;
+(* on enlève le premier coefficient *)
+let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
+;;
+(* le premier coefficient: "tête" de l'inéquation *)
+let hd_coef ie = List.hd ie.coef
+;;
+
+(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
+*)
+let deduce_add lneg lpos =
+ let res=ref [] in
+ List.iter (fun i1 ->
+ List.iter (fun i2 ->
+ let a = rop (hd_coef i1) in
+ let b = hd_coef i2 in
+ pop (ie_tl (ie_add (ie_emult b i1)
+ (ie_emult a i2))) res)
+ lpos)
+ lneg;
+ !res
+;;
+(* élimination de la première variable à partir d'une liste d'inéquations:
+opération qu'on itère dans l'algorithme de Fourier.
+*)
+let deduce1 s =
+ match (partitionne s) with
+ [lneg;lnul;lpos] ->
+ let lnew = deduce_add lneg lpos in
+ (List.map ie_tl lnul)@lnew
+ |_->assert false
+;;
+(* algorithme de Fourier: on élimine successivement toutes les variables.
+*)
+let deduce lie =
+ let n = List.length (fst (List.hd lie)) in
+ let lie=ref (add_hist lie) in
+ for i=1 to n-1 do
+ lie:= deduce1 !lie;
+ done;
+ !lie
+;;
+
+(* donne [] si le système a des solutions,
+sinon donne [c,s,lc]
+où lc est la combinaison linéaire des inéquations de départ
+qui donne 0 < c si s=true
+ ou 0 <= c sinon
+cette inéquation étant absurde.
+*)
+let unsolvable lie =
+ let lr = deduce lie in
+ let res = ref [] in
+ (try (List.iter (fun e ->
+ match e with
+ {coef=[c];hist=lc;strict=s} ->
+ if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
+ then (res := [c,s,lc];
+ raise (Failure "contradiction found"))
+ |_->assert false)
+ lr)
+ with _ -> ());
+ !res
+;;
+
+(* Exemples:
+
+let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];;
+deduce test1;;
+unsolvable test1;;
+
+let test2=[
+[r1;r1;r0;r0;r0],false;
+[r0;r1;r1;r0;r0],false;
+[r0;r0;r1;r1;r0],false;
+[r0;r0;r0;r1;r1],false;
+[r1;r0;r0;r0;r1],false;
+[rop r1;rop r1;r0;r0;r0],false;
+[r0;rop r1;rop r1;r0;r0],false;
+[r0;r0;rop r1;rop r1;r0],false;
+[r0;r0;r0;rop r1;rop r1],false;
+[rop r1;r0;r0;r0;rop r1],false
+];;
+deduce test2;;
+unsolvable test2;;
+
+*)
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
new file mode 100644
index 00000000..3f490bab
--- /dev/null
+++ b/plugins/fourier/fourierR.ml
@@ -0,0 +1,629 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+
+
+(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
+des inéquations et équations sont entiers. En attendant la tactique Field.
+*)
+
+open Term
+open Tactics
+open Clenv
+open Names
+open Libnames
+open Tacticals
+open Tacmach
+open Fourier
+open Contradiction
+
+(******************************************************************************
+Opérations sur les combinaisons linéaires affines.
+La partie homogène d'une combinaison linéaire est en fait une table de hash
+qui donne le coefficient d'un terme du calcul des constructions,
+qui est zéro si le terme n'y est pas.
+*)
+
+type flin = {fhom:(constr , rational)Hashtbl.t;
+ fcste:rational};;
+
+let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};;
+
+let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;;
+
+let flin_add f x c =
+ let cx = flin_coef f x in
+ Hashtbl.remove f.fhom x;
+ Hashtbl.add f.fhom x (rplus cx c);
+ f
+;;
+let flin_add_cste f c =
+ {fhom=f.fhom;
+ fcste=rplus f.fcste c}
+;;
+
+let flin_one () = flin_add_cste (flin_zero()) r1;;
+
+let flin_plus f1 f2 =
+ let f3 = flin_zero() in
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom;
+ flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste;
+;;
+
+let flin_minus f1 f2 =
+ let f3 = flin_zero() in
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom;
+ flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste);
+;;
+let flin_emult a f =
+ let f2 = flin_zero() in
+ Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
+ flin_add_cste f2 (rmult a f.fcste);
+;;
+
+(*****************************************************************************)
+open Vernacexpr
+
+type ineq = Rlt | Rle | Rgt | Rge
+
+let string_of_R_constant kn =
+ match Names.repr_con kn with
+ | MPfile dir, sec_dir, id when
+ sec_dir = empty_dirpath &&
+ string_of_dirpath dir = "Coq.Reals.Rdefinitions"
+ -> string_of_label id
+ | _ -> "constant_not_of_R"
+
+let rec string_of_R_constr c =
+ match kind_of_term c with
+ Cast (c,_,_) -> string_of_R_constr c
+ |Const c -> string_of_R_constant c
+ | _ -> "not_of_constant"
+
+let rec rational_of_constr c =
+ match kind_of_term c with
+ | Cast (c,_,_) -> (rational_of_constr c)
+ | App (c,args) ->
+ (match (string_of_R_constr c) with
+ | "Ropp" ->
+ rop (rational_of_constr args.(0))
+ | "Rinv" ->
+ rinv (rational_of_constr args.(0))
+ | "Rmult" ->
+ rmult (rational_of_constr args.(0))
+ (rational_of_constr args.(1))
+ | "Rdiv" ->
+ rdiv (rational_of_constr args.(0))
+ (rational_of_constr args.(1))
+ | "Rplus" ->
+ rplus (rational_of_constr args.(0))
+ (rational_of_constr args.(1))
+ | "Rminus" ->
+ rminus (rational_of_constr args.(0))
+ (rational_of_constr args.(1))
+ | _ -> failwith "not a rational")
+ | Const kn ->
+ (match (string_of_R_constant kn) with
+ "R1" -> r1
+ |"R0" -> r0
+ | _ -> failwith "not a rational")
+ | _ -> failwith "not a rational"
+;;
+
+let rec flin_of_constr c =
+ try(
+ match kind_of_term c with
+ | Cast (c,_,_) -> (flin_of_constr c)
+ | App (c,args) ->
+ (match (string_of_R_constr c) with
+ "Ropp" ->
+ flin_emult (rop r1) (flin_of_constr args.(0))
+ | "Rplus"->
+ flin_plus (flin_of_constr args.(0))
+ (flin_of_constr args.(1))
+ | "Rminus"->
+ flin_minus (flin_of_constr args.(0))
+ (flin_of_constr args.(1))
+ | "Rmult"->
+ (try (let a=(rational_of_constr args.(0)) in
+ try (let b = (rational_of_constr args.(1)) in
+ (flin_add_cste (flin_zero()) (rmult a b)))
+ with _-> (flin_add (flin_zero())
+ args.(1)
+ a))
+ with _-> (flin_add (flin_zero())
+ args.(0)
+ (rational_of_constr args.(1))))
+ | "Rinv"->
+ let a=(rational_of_constr args.(0)) in
+ flin_add_cste (flin_zero()) (rinv a)
+ | "Rdiv"->
+ (let b=(rational_of_constr args.(1)) in
+ try (let a = (rational_of_constr args.(0)) in
+ (flin_add_cste (flin_zero()) (rdiv a b)))
+ with _-> (flin_add (flin_zero())
+ args.(0)
+ (rinv b)))
+ |_->assert false)
+ | Const c ->
+ (match (string_of_R_constant c) with
+ "R1" -> flin_one ()
+ |"R0" -> flin_zero ()
+ |_-> assert false)
+ |_-> assert false)
+ with _ -> flin_add (flin_zero())
+ c
+ r1
+;;
+
+let flin_to_alist f =
+ let res=ref [] in
+ Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f;
+ !res
+;;
+
+(* Représentation des hypothèses qui sont des inéquations ou des équations.
+*)
+type hineq={hname:constr; (* le nom de l'hypothèse *)
+ htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *)
+ hleft:constr;
+ hright:constr;
+ hflin:flin;
+ hstrict:bool}
+;;
+
+(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
+*)
+let ineq1_of_constr (h,t) =
+ match (kind_of_term t) with
+ App (f,args) ->
+ (match kind_of_term f with
+ Const c when Array.length args = 2 ->
+ let t1= args.(0) in
+ let t2= args.(1) in
+ (match (string_of_R_constant c) with
+ "Rlt" -> [{hname=h;
+ htype="Rlt";
+ hleft=t1;
+ hright=t2;
+ hflin= flin_minus (flin_of_constr t1)
+ (flin_of_constr t2);
+ hstrict=true}]
+ |"Rgt" -> [{hname=h;
+ htype="Rgt";
+ hleft=t2;
+ hright=t1;
+ hflin= flin_minus (flin_of_constr t2)
+ (flin_of_constr t1);
+ hstrict=true}]
+ |"Rle" -> [{hname=h;
+ htype="Rle";
+ hleft=t1;
+ hright=t2;
+ hflin= flin_minus (flin_of_constr t1)
+ (flin_of_constr t2);
+ hstrict=false}]
+ |"Rge" -> [{hname=h;
+ htype="Rge";
+ hleft=t2;
+ hright=t1;
+ hflin= flin_minus (flin_of_constr t2)
+ (flin_of_constr t1);
+ hstrict=false}]
+ |_->assert false)
+ | Ind (kn,i) ->
+ if IndRef(kn,i) = Coqlib.glob_eq then
+ let t0= args.(0) in
+ let t1= args.(1) in
+ let t2= args.(2) in
+ (match (kind_of_term t0) with
+ Const c ->
+ (match (string_of_R_constant c) with
+ "R"->
+ [{hname=h;
+ htype="eqTLR";
+ hleft=t1;
+ hright=t2;
+ hflin= flin_minus (flin_of_constr t1)
+ (flin_of_constr t2);
+ hstrict=false};
+ {hname=h;
+ htype="eqTRL";
+ hleft=t2;
+ hright=t1;
+ hflin= flin_minus (flin_of_constr t2)
+ (flin_of_constr t1);
+ hstrict=false}]
+ |_-> assert false)
+ |_-> assert false)
+ else
+ assert false
+ |_-> assert false)
+ |_-> assert false
+;;
+
+(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
+*)
+
+let fourier_lineq lineq1 =
+ let nvar=ref (-1) in
+ let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *)
+ List.iter (fun f ->
+ Hashtbl.iter (fun x _ -> if not (Hashtbl.mem hvar x) then begin
+ nvar:=(!nvar)+1;
+ Hashtbl.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)
+ h.hflin.fhom;
+ ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
+ lineq1 in
+ unsolvable sys
+;;
+
+(*********************************************************************)
+(* Defined constants *)
+
+let get = Lazy.force
+let constant = Coqlib.gen_constant "Fourier"
+
+(* Standard library *)
+open Coqlib
+let coq_sym_eqT = lazy (build_coq_eq_sym ())
+let coq_False = lazy (build_coq_False ())
+let coq_not = lazy (build_coq_not ())
+let coq_eq = lazy (build_coq_eq ())
+
+(* Rdefinitions *)
+let constant_real = constant ["Reals";"Rdefinitions"]
+
+let coq_Rlt = lazy (constant_real "Rlt")
+let coq_Rgt = lazy (constant_real "Rgt")
+let coq_Rle = lazy (constant_real "Rle")
+let coq_Rge = lazy (constant_real "Rge")
+let coq_R = lazy (constant_real "R")
+let coq_Rminus = lazy (constant_real "Rminus")
+let coq_Rmult = lazy (constant_real "Rmult")
+let coq_Rplus = lazy (constant_real "Rplus")
+let coq_Ropp = lazy (constant_real "Ropp")
+let coq_Rinv = lazy (constant_real "Rinv")
+let coq_R0 = lazy (constant_real "R0")
+let coq_R1 = lazy (constant_real "R1")
+
+(* RIneq *)
+let coq_Rinv_1 = lazy (constant ["Reals";"RIneq"] "Rinv_1")
+
+(* Fourier_util *)
+let constant_fourier = constant ["fourier";"Fourier_util"]
+
+let coq_Rlt_zero_1 = lazy (constant_fourier "Rlt_zero_1")
+let coq_Rlt_zero_pos_plus1 = lazy (constant_fourier "Rlt_zero_pos_plus1")
+let coq_Rle_zero_pos_plus1 = lazy (constant_fourier "Rle_zero_pos_plus1")
+let coq_Rlt_mult_inv_pos = lazy (constant_fourier "Rlt_mult_inv_pos")
+let coq_Rle_zero_zero = lazy (constant_fourier "Rle_zero_zero")
+let coq_Rle_zero_1 = lazy (constant_fourier "Rle_zero_1")
+let coq_Rle_mult_inv_pos = lazy (constant_fourier "Rle_mult_inv_pos")
+let coq_Rnot_lt0 = lazy (constant_fourier "Rnot_lt0")
+let coq_Rle_not_lt = lazy (constant_fourier "Rle_not_lt")
+let coq_Rfourier_gt_to_lt = lazy (constant_fourier "Rfourier_gt_to_lt")
+let coq_Rfourier_ge_to_le = lazy (constant_fourier "Rfourier_ge_to_le")
+let coq_Rfourier_eqLR_to_le = lazy (constant_fourier "Rfourier_eqLR_to_le")
+let coq_Rfourier_eqRL_to_le = lazy (constant_fourier "Rfourier_eqRL_to_le")
+
+let coq_Rfourier_not_ge_lt = lazy (constant_fourier "Rfourier_not_ge_lt")
+let coq_Rfourier_not_gt_le = lazy (constant_fourier "Rfourier_not_gt_le")
+let coq_Rfourier_not_le_gt = lazy (constant_fourier "Rfourier_not_le_gt")
+let coq_Rfourier_not_lt_ge = lazy (constant_fourier "Rfourier_not_lt_ge")
+let coq_Rfourier_lt = lazy (constant_fourier "Rfourier_lt")
+let coq_Rfourier_le = lazy (constant_fourier "Rfourier_le")
+let coq_Rfourier_lt_lt = lazy (constant_fourier "Rfourier_lt_lt")
+let coq_Rfourier_lt_le = lazy (constant_fourier "Rfourier_lt_le")
+let coq_Rfourier_le_lt = lazy (constant_fourier "Rfourier_le_lt")
+let coq_Rfourier_le_le = lazy (constant_fourier "Rfourier_le_le")
+let coq_Rnot_lt_lt = lazy (constant_fourier "Rnot_lt_lt")
+let coq_Rnot_le_le = lazy (constant_fourier "Rnot_le_le")
+let coq_Rlt_not_le_frac_opp = lazy (constant_fourier "Rlt_not_le_frac_opp")
+
+(******************************************************************************
+Construction de la preuve en cas de succès de la méthode de Fourier,
+i.e. on obtient une contradiction.
+*)
+let is_int x = (x.den)=1
+;;
+
+(* fraction = couple (num,den) *)
+let rec rational_to_fraction x= (x.num,x.den)
+;;
+
+(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
+*)
+let int_to_real n =
+ let nn=abs n in
+ if nn=0
+ then get coq_R0
+ else
+ (let s=ref (get coq_R1) in
+ for i=1 to (nn-1) do s:=mkApp (get coq_Rplus,[|get coq_R1;!s|]) done;
+ if n<0 then mkApp (get coq_Ropp, [|!s|]) else !s)
+;;
+(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1)))
+*)
+let rational_to_real x =
+ let (n,d)=rational_to_fraction x in
+ mkApp (get coq_Rmult,
+ [|int_to_real n;mkApp(get coq_Rinv,[|int_to_real d|])|])
+;;
+
+(* preuve que 0<n*1/d
+*)
+let tac_zero_inf_pos gl (n,d) =
+ let tacn=ref (apply (get coq_Rlt_zero_1)) in
+ let tacd=ref (apply (get coq_Rlt_zero_1)) in
+ for i=1 to n-1 do
+ tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done;
+ for i=1 to d-1 do
+ tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
+ (tclTHENS (apply (get coq_Rlt_mult_inv_pos)) [!tacn;!tacd])
+;;
+
+(* preuve que 0<=n*1/d
+*)
+let tac_zero_infeq_pos gl (n,d)=
+ let tacn=ref (if n=0
+ then (apply (get coq_Rle_zero_zero))
+ else (apply (get coq_Rle_zero_1))) in
+ let tacd=ref (apply (get coq_Rlt_zero_1)) in
+ for i=1 to n-1 do
+ tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done;
+ for i=1 to d-1 do
+ tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done;
+ (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd])
+;;
+
+(* preuve que 0<(-n)*(1/d) => False
+*)
+let tac_zero_inf_false gl (n,d) =
+ if n=0 then (apply (get coq_Rnot_lt0))
+ else
+ (tclTHEN (apply (get coq_Rle_not_lt))
+ (tac_zero_infeq_pos gl (-n,d)))
+;;
+
+(* preuve que 0<=(-n)*(1/d) => False
+*)
+let tac_zero_infeq_false gl (n,d) =
+ (tclTHEN (apply (get coq_Rlt_not_le_frac_opp))
+ (tac_zero_inf_pos gl (-n,d)))
+;;
+
+let create_meta () = mkMeta(Evarutil.new_meta());;
+
+let my_cut c gl=
+ let concl = pf_concl gl in
+ apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl
+;;
+
+let exact = exact_check;;
+
+let tac_use h = match h.htype with
+ "Rlt" -> exact h.hname
+ |"Rle" -> exact h.hname
+ |"Rgt" -> (tclTHEN (apply (get coq_Rfourier_gt_to_lt))
+ (exact h.hname))
+ |"Rge" -> (tclTHEN (apply (get coq_Rfourier_ge_to_le))
+ (exact h.hname))
+ |"eqTLR" -> (tclTHEN (apply (get coq_Rfourier_eqLR_to_le))
+ (exact h.hname))
+ |"eqTRL" -> (tclTHEN (apply (get coq_Rfourier_eqRL_to_le))
+ (exact h.hname))
+ |_->assert false
+;;
+
+(*
+let is_ineq (h,t) =
+ match (kind_of_term t) with
+ App (f,args) ->
+ (match (string_of_R_constr f) with
+ "Rlt" -> true
+ | "Rgt" -> true
+ | "Rle" -> true
+ | "Rge" -> true
+(* Wrong:not in Rdefinitions: *) | "eqT" ->
+ (match (string_of_R_constr args.(0)) with
+ "R" -> true
+ | _ -> false)
+ | _ ->false)
+ |_->false
+;;
+*)
+
+let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;;
+
+let mkAppL a =
+ let l = Array.to_list a in
+ mkApp(List.hd l, Array.of_list (List.tl l))
+;;
+
+(* Résolution d'inéquations linéaires dans R *)
+let rec fourier gl=
+ Coqlib.check_required_library ["Coq";"fourier";"Fourier"];
+ let goal = strip_outer_cast (pf_concl gl) in
+ let fhyp=id_of_string "new_hyp_for_fourier" in
+ (* si le but est une inéquation, on introduit son contraire,
+ et le but à prouver devient False *)
+ try (let tac =
+ match (kind_of_term goal) with
+ App (f,args) ->
+ (match (string_of_R_constr f) with
+ "Rlt" ->
+ (tclTHEN
+ (tclTHEN (apply (get coq_Rfourier_not_ge_lt))
+ (intro_using fhyp))
+ fourier)
+ |"Rle" ->
+ (tclTHEN
+ (tclTHEN (apply (get coq_Rfourier_not_gt_le))
+ (intro_using fhyp))
+ fourier)
+ |"Rgt" ->
+ (tclTHEN
+ (tclTHEN (apply (get coq_Rfourier_not_le_gt))
+ (intro_using fhyp))
+ fourier)
+ |"Rge" ->
+ (tclTHEN
+ (tclTHEN (apply (get coq_Rfourier_not_lt_ge))
+ (intro_using fhyp))
+ fourier)
+ |_->assert false)
+ |_->assert false
+ in tac gl)
+ with _ ->
+ (* les hypothèses *)
+ let hyps = List.map (fun (h,t)-> (mkVar h,t))
+ (list_of_sign (pf_hyps gl)) in
+ let lineq =ref [] in
+ List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq))
+ with _ -> ())
+ hyps;
+ (* lineq = les inéquations découlant des hypothèses *)
+ if !lineq=[] then Util.error "No inequalities";
+ let res=fourier_lineq (!lineq) in
+ let tac=ref tclIDTAC in
+ if res=[]
+ then Util.error "fourier failed"
+ (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *)
+ else (match res with
+ [(cres,sres,lc)]->
+ (* lc=coefficients multiplicateurs des inéquations
+ qui donnent 0<cres ou 0<=cres selon sres *)
+ (*print_string "Fourier's method can prove the goal...";flush stdout;*)
+ let lutil=ref [] in
+ List.iter
+ (fun (h,c) ->
+ if c<>r0
+ then (lutil:=(h,c)::(!lutil)(*;
+ print_rational(c);print_string " "*)))
+ (List.combine (!lineq) lc);
+ (* on construit la combinaison linéaire des inéquation *)
+ (match (!lutil) with
+ (h1,c1)::lutil ->
+ let s=ref (h1.hstrict) in
+ let t1=ref (mkAppL [|get coq_Rmult;
+ rational_to_real c1;
+ h1.hleft|]) in
+ let t2=ref (mkAppL [|get coq_Rmult;
+ rational_to_real c1;
+ h1.hright|]) in
+ List.iter (fun (h,c) ->
+ s:=(!s)||(h.hstrict);
+ t1:=(mkAppL [|get coq_Rplus;
+ !t1;
+ mkAppL [|get coq_Rmult;
+ rational_to_real c;
+ h.hleft|] |]);
+ t2:=(mkAppL [|get coq_Rplus;
+ !t2;
+ mkAppL [|get coq_Rmult;
+ rational_to_real c;
+ h.hright|] |]))
+ lutil;
+ let ineq=mkAppL [|if (!s) then get coq_Rlt else get coq_Rle;
+ !t1;
+ !t2 |] in
+ let tc=rational_to_real cres in
+ (* puis sa preuve *)
+ let tac1=ref (if h1.hstrict
+ then (tclTHENS (apply (get coq_Rfourier_lt))
+ [tac_use h1;
+ tac_zero_inf_pos gl
+ (rational_to_fraction c1)])
+ else (tclTHENS (apply (get coq_Rfourier_le))
+ [tac_use h1;
+ tac_zero_inf_pos gl
+ (rational_to_fraction c1)])) in
+ s:=h1.hstrict;
+ List.iter (fun (h,c)->
+ (if (!s)
+ then (if h.hstrict
+ then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt))
+ [!tac1;tac_use h;
+ tac_zero_inf_pos gl
+ (rational_to_fraction c)])
+ else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le))
+ [!tac1;tac_use h;
+ tac_zero_inf_pos gl
+ (rational_to_fraction c)]))
+ else (if h.hstrict
+ then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt))
+ [!tac1;tac_use h;
+ tac_zero_inf_pos gl
+ (rational_to_fraction c)])
+ else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le))
+ [!tac1;tac_use h;
+ tac_zero_inf_pos gl
+ (rational_to_fraction c)])));
+ s:=(!s)||(h.hstrict))
+ lutil;
+ let tac2= if sres
+ then tac_zero_inf_false gl (rational_to_fraction cres)
+ else tac_zero_infeq_false gl (rational_to_fraction cres)
+ in
+ tac:=(tclTHENS (my_cut ineq)
+ [tclTHEN (change_in_concl None
+ (mkAppL [| get coq_not; ineq|]
+ ))
+ (tclTHEN (apply (if sres then get coq_Rnot_lt_lt
+ else get coq_Rnot_le_le))
+ (tclTHENS (Equality.replace
+ (mkAppL [|get coq_Rminus;!t2;!t1|]
+ )
+ tc)
+ [tac2;
+ (tclTHENS
+ (Equality.replace
+ (mkApp (get coq_Rinv,
+ [|get coq_R1|]))
+ (get coq_R1))
+(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *)
+
+ [tclORELSE
+ (Ring.polynom [])
+ tclIDTAC;
+ (tclTHEN (apply (get coq_sym_eqT))
+ (apply (get coq_Rinv_1)))]
+
+ )
+ ]));
+ !tac1]);
+ tac:=(tclTHENS (cut (get coq_False))
+ [tclTHEN intro (contradiction None);
+ !tac])
+ |_-> assert false) |_-> assert false
+ );
+(* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *)
+ (!tac gl)
+(* ((tclABSTRACT None !tac) gl) *)
+
+;;
+
+(*
+let fourier_tac x gl =
+ fourier gl
+;;
+
+let v_fourier = add_tactic "Fourier" fourier_tac
+*)
+
diff --git a/plugins/fourier/fourier_plugin.mllib b/plugins/fourier/fourier_plugin.mllib
new file mode 100644
index 00000000..0383b1a8
--- /dev/null
+++ b/plugins/fourier/fourier_plugin.mllib
@@ -0,0 +1,4 @@
+Fourier
+FourierR
+G_fourier
+Fourier_plugin_mod
diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4
new file mode 100644
index 00000000..b952851f
--- /dev/null
+++ b/plugins/fourier/g_fourier.ml4
@@ -0,0 +1,17 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open FourierR
+
+TACTIC EXTEND fourier
+ [ "fourierz" ] -> [ fourier ]
+END
diff --git a/plugins/fourier/vo.itarget b/plugins/fourier/vo.itarget
new file mode 100644
index 00000000..87d82dac
--- /dev/null
+++ b/plugins/fourier/vo.itarget
@@ -0,0 +1,2 @@
+Fourier_util.vo
+Fourier.vo
diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v
new file mode 100644
index 00000000..00302a74
--- /dev/null
+++ b/plugins/funind/Recdef.v
@@ -0,0 +1,48 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+Require Compare_dec.
+Require Wf_nat.
+
+Section Iter.
+Variable A : Type.
+
+Fixpoint iter (n : nat) : (A -> A) -> A -> A :=
+ fun (fl : A -> A) (def : A) =>
+ match n with
+ | O => def
+ | S m => fl (iter m fl def)
+ end.
+End Iter.
+
+Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')).
+ intro p; intro p'; change (S p <= S (S (p + p')));
+ apply le_S; apply Gt.gt_le_S; change (p < S (p + p'));
+ apply Lt.le_lt_n_Sm; apply Plus.le_plus_l.
+Qed.
+
+
+Theorem Splus_lt : forall p p' : nat, p' < S (p + p').
+ intro p; intro p'; change (S p' <= S (p + p'));
+ apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm;
+ apply Plus.le_plus_r.
+Qed.
+
+Theorem le_lt_SS : forall x y, x <= y -> x < S (S y).
+intro x; intro y; intro H; change (S x <= S (S y));
+ apply le_S; apply Gt.gt_le_S; change (x < S y);
+ apply Lt.le_lt_n_Sm; exact H.
+Qed.
+
+Inductive max_type (m n:nat) : Set :=
+ cmt : forall v, m <= v -> n <= v -> max_type m n.
+
+Definition max : forall m n:nat, max_type m n.
+intros m n; case (Compare_dec.le_gt_dec m n).
+intros h; exists n; [exact h | apply le_n].
+intros h; exists m; [apply le_n | apply Lt.lt_le_weak; exact h].
+Defined.
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
new file mode 100644
index 00000000..e2cad944
--- /dev/null
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -0,0 +1,1710 @@
+open Printer
+open Util
+open Term
+open Termops
+open Namegen
+open Names
+open Declarations
+open Pp
+open Entries
+open Hiddentac
+open Evd
+open Tacmach
+open Proof_type
+open Tacticals
+open Tactics
+open Indfun_common
+open Libnames
+
+let msgnl = Pp.msgnl
+
+
+let observe strm =
+ if do_observe ()
+ then Pp.msgnl strm
+ else ()
+
+let observennl strm =
+ if do_observe ()
+ then begin Pp.msg strm;Pp.pp_flush () end
+ else ()
+
+
+
+
+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
+ msgnl (str "observation "++ s++str " raised exception " ++
+ Cerrors.explain_exn e ++ str " on goal " ++ goal );
+ raise e;;
+
+let observe_tac_stream s tac g =
+ if do_observe ()
+ then do_observe_tac s tac g
+ else tac g
+
+let observe_tac s tac g = observe_tac_stream (str s) tac g
+
+(* let tclTRYD tac = *)
+(* if !Flags.debug || do_observe () *)
+(* then (fun g -> try (\* do_observe_tac "" *\)tac g with _ -> tclIDTAC g) *)
+(* else tac *)
+
+
+let list_chop ?(msg="") n l =
+ try
+ list_chop n l
+ with Failure (msg') ->
+ failwith (msg ^ msg')
+
+
+let make_refl_eq constructor type_of_t t =
+(* let refl_equal_term = Lazy.force refl_equal in *)
+ mkApp(constructor,[|type_of_t;t|])
+
+
+type pte_info =
+ {
+ proving_tac : (identifier list -> Tacmach.tactic);
+ is_valid : constr -> bool
+ }
+
+type ptes_info = pte_info Idmap.t
+
+type 'a dynamic_info =
+ {
+ nb_rec_hyps : int;
+ rec_hyps : identifier list ;
+ eq_hyps : identifier list;
+ info : 'a
+ }
+
+type body_info = constr dynamic_info
+
+
+let finish_proof dynamic_infos g =
+ observe_tac "finish"
+ ( h_assumption)
+ g
+
+
+let refine c =
+ Tacmach.refine_no_check c
+
+let thin l =
+ Tacmach.thin_no_check l
+
+
+let cut_replacing id t tac :tactic=
+ tclTHENS (cut t)
+ [ tclTHEN (thin_no_check [id]) (introduction_no_check id);
+ tac
+ ]
+
+let intro_erasing id = tclTHEN (thin [id]) (introduction id)
+
+
+
+let rec_hyp_id = id_of_string "rec_hyp"
+
+let is_trivial_eq t =
+ let res = try
+ begin
+ match kind_of_term t with
+ | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
+ eq_constr t1 t2
+ | App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) ->
+ eq_constr t1 t2 && eq_constr a1 a2
+ | _ -> false
+ end
+ with _ -> false
+ in
+(* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *)
+ res
+
+let rec incompatible_constructor_terms t1 t2 =
+ let c1,arg1 = decompose_app t1
+ and c2,arg2 = decompose_app t2
+ in
+ (not (eq_constr t1 t2)) &&
+ isConstruct c1 && isConstruct c2 &&
+ (
+ not (eq_constr c1 c2) ||
+ List.exists2 incompatible_constructor_terms arg1 arg2
+ )
+
+let is_incompatible_eq t =
+ let res =
+ try
+ match kind_of_term t with
+ | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) ->
+ incompatible_constructor_terms t1 t2
+ | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) ->
+ (eq_constr u1 u2 &&
+ incompatible_constructor_terms t1 t2)
+ | _ -> false
+ with _ -> false
+ in
+ if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t);
+ res
+
+let change_hyp_with_using msg hyp_id t tac : tactic =
+ fun g ->
+ let prov_id = pf_get_new_id hyp_id g in
+ tclTHENS
+ ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac)))
+ [tclTHENLIST
+ [
+ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]);
+ (* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id])
+ ]] g
+
+exception TOREMOVE
+
+
+let prove_trivial_eq h_id context (constructor,type_of_term,term) =
+ let nb_intros = List.length context in
+ tclTHENLIST
+ [
+ tclDO nb_intros intro; (* introducing context *)
+ (fun g ->
+ let context_hyps =
+ fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g))
+ in
+ let context_hyps' =
+ (mkApp(constructor,[|type_of_term;term|]))::
+ (List.map mkVar context_hyps)
+ in
+ let to_refine = applist(mkVar h_id,List.rev context_hyps') in
+ refine to_refine g
+ )
+ ]
+
+
+
+let find_rectype env c =
+ let (t, l) = decompose_app (Reduction.whd_betadeltaiota env c) in
+ match kind_of_term t with
+ | Ind ind -> (t, l)
+ | Construct _ -> (t,l)
+ | _ -> raise Not_found
+
+
+let isAppConstruct ?(env=Global.env ()) t =
+ try
+ let t',l = find_rectype (Global.env ()) t in
+ observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l)));
+ true
+ with Not_found -> false
+
+let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_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 Environ.empty_env Evd.empty
+
+
+
+let change_eq env sigma hyp_id (context:rel_context) x t end_of_type =
+ let nochange ?t' msg =
+ begin
+ observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t );
+ failwith "NoChange";
+ end
+ in
+ let eq_constr = Reductionops.is_conv env sigma in
+ if not (noccurn 1 end_of_type)
+ then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *)
+ if not (isApp t) then nochange "not an equality";
+ let f_eq,args = destApp t in
+ let constructor,t1,t2,t1_typ =
+ try
+ if (eq_constr f_eq (Lazy.force eq))
+ then
+ let t1 = (args.(1),args.(0))
+ and t2 = (args.(2),args.(0))
+ and t1_typ = args.(0)
+ in
+ (Lazy.force refl_equal,t1,t2,t1_typ)
+ else
+ if (eq_constr f_eq (jmeq ()))
+ then
+ (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0))
+ else nochange "not an equality"
+ with _ -> nochange "not an equality"
+ in
+ if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs";
+ let rec compute_substitution sub t1 t2 =
+(* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *)
+ if isRel t2
+ then
+ let t2 = destRel t2 in
+ begin
+ try
+ let t1' = Intmap.find t2 sub in
+ if not (eq_constr t1 t1') then nochange "twice bound variable";
+ sub
+ with Not_found ->
+ assert (closed0 t1);
+ Intmap.add t2 t1 sub
+ end
+ else if isAppConstruct t1 && isAppConstruct t2
+ then
+ begin
+ let c1,args1 = find_rectype env t1
+ and c2,args2 = find_rectype env t2
+ in
+ if not (eq_constr c1 c2) then nochange "cannot solve (diff)";
+ List.fold_left2 compute_substitution sub args1 args2
+ end
+ else
+ if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2) "cannot solve (diff)"
+ 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 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
+ *)
+ let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in
+ let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in
+ List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type))
+ end_of_type_with_pop
+ sub''
+ in
+ let old_context_length = List.length context + 1 in
+ let witness_fun =
+ mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t,
+ mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i)))
+ )
+ in
+ let new_type_of_hyp,ctxt_size,witness_fun =
+ list_fold_left_i
+ (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) ->
+ 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))
+ with Not_found ->
+ (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
+ )
+ 1
+ (new_end_of_type,0,witness_fun)
+ context
+ in
+ let new_type_of_hyp =
+ Reductionops.nf_betaiota Evd.empty new_type_of_hyp in
+ let new_ctxt,new_end_of_type =
+ decompose_prod_n_assum ctxt_size new_type_of_hyp
+ in
+ let prove_new_hyp : tactic =
+ tclTHEN
+ (tclDO ctxt_size intro)
+ (fun g ->
+ let all_ids = pf_ids_of_hyps g in
+ let new_ids,_ = list_chop ctxt_size all_ids in
+ let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in
+ refine to_refine g
+ )
+ in
+ let simpl_eq_tac =
+ change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp
+ in
+(* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *)
+(* str "removing an equation " ++ fnl ()++ *)
+(* str "old_typ_of_hyp :=" ++ *)
+(* Printer.pr_lconstr_env *)
+(* env *)
+(* (it_mkProd_or_LetIn ~init:end_of_type ((x,None,t)::context)) *)
+(* ++ fnl () ++ *)
+(* str "new_typ_of_hyp := "++ *)
+(* Printer.pr_lconstr_env env new_type_of_hyp ++ fnl () *)
+(* ++ str "old context := " ++ pr_rel_context env context ++ fnl () *)
+(* ++ str "new context := " ++ pr_rel_context env new_ctxt ++ fnl () *)
+(* ++ str "old type := " ++ pr_lconstr end_of_type ++ fnl () *)
+(* ++ str "new type := " ++ pr_lconstr new_end_of_type ++ fnl () *)
+(* ); *)
+ new_ctxt,new_end_of_type,simpl_eq_tac
+
+
+let is_property ptes_info t_x full_type_of_hyp =
+ if isApp t_x
+ then
+ let pte,args = destApp t_x in
+ if isVar pte && array_for_all closed0 args
+ then
+ try
+ let info = Idmap.find (destVar pte) ptes_info in
+ info.is_valid full_type_of_hyp
+ with Not_found -> false
+ else false
+ else false
+
+let isLetIn t =
+ match kind_of_term t with
+ | LetIn _ -> true
+ | _ -> false
+
+
+let h_reduce_with_zeta =
+ h_reduce
+ (Rawterm.Cbv
+ {Rawterm.all_flags
+ with Rawterm.rDelta = false;
+ })
+
+
+
+let rewrite_until_var arg_num eq_ids : tactic =
+ (* tests if the declares recursive argument is neither a Constructor nor
+ an applied Constructor since such a form for the recursive argument
+ will break the Guard when trying to save the Lemma.
+ *)
+ let test_var g =
+ let _,args = destApp (pf_concl g) in
+ not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num))
+ in
+ let rec do_rewrite eq_ids g =
+ if test_var g
+ then tclIDTAC g
+ else
+ match eq_ids with
+ | [] -> anomaly "Cannot find a way to prove recursive property";
+ | eq_id::eq_ids ->
+ tclTHEN
+ (tclTRY (Equality.rewriteRL (mkVar eq_id)))
+ (do_rewrite eq_ids)
+ g
+ in
+ do_rewrite eq_ids
+
+
+let rec_pte_id = id_of_string "Hrec"
+let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
+ let coq_False = Coqlib.build_coq_False () in
+ let coq_True = Coqlib.build_coq_True () in
+ 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 reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in
+ (* length of context didn't change ? *)
+ let new_context,new_typ_of_hyp =
+ decompose_prod_n_assum (List.length context) reduced_type_of_hyp
+ in
+ tclTHENLIST
+ [
+ h_reduce_with_zeta
+ (Tacticals.onHyp hyp_id)
+ ;
+ scan_type new_context new_typ_of_hyp
+
+ ]
+ else if isProd type_of_hyp
+ 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
+ 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 prove_new_type_of_hyp =
+ let context_length = List.length context in
+ tclTHENLIST
+ [
+ tclDO context_length intro;
+ (fun g ->
+ let context_hyps_ids =
+ fst (list_chop ~msg:"rec hyp : context_hyps"
+ context_length (pf_ids_of_hyps g))
+ in
+ let rec_pte_id = pf_get_new_id rec_pte_id g in
+ let to_refine =
+ applist(mkVar hyp_id,
+ List.rev_map mkVar (rec_pte_id::context_hyps_ids)
+ )
+ in
+(* observe_tac "rec hyp " *)
+ (tclTHENS
+ (assert_tac (Name rec_pte_id) t_x)
+ [
+ (* observe_tac "prove rec hyp" *) (prove_rec_hyp eq_hyps);
+(* observe_tac "prove rec hyp" *)
+ (refine to_refine)
+ ])
+ g
+ )
+ ]
+ in
+ tclTHENLIST
+ [
+(* observe_tac "hyp rec" *)
+ (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp);
+ scan_type context popped_t'
+ ]
+ end
+ else if eq_constr t_x coq_False then
+ begin
+(* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *)
+(* str " since it has False in its preconds " *)
+(* ); *)
+ raise TOREMOVE; (* False -> .. useless *)
+ end
+ else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *)
+ else if eq_constr t_x coq_True (* Trivial => we remove this precons *)
+ then
+(* observe (str "In "++Ppconstr.pr_id hyp_id++ *)
+(* str " removing useless precond True" *)
+(* ); *)
+ let popped_t' = pop t' in
+ let real_type_of_hyp =
+ it_mkProd_or_LetIn ~init:popped_t' context
+ in
+ let prove_trivial =
+ let nb_intro = List.length context in
+ tclTHENLIST [
+ tclDO nb_intro intro;
+ (fun g ->
+ let context_hyps =
+ fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g))
+ in
+ let to_refine =
+ applist (mkVar hyp_id,
+ List.rev (coq_I::List.map mkVar context_hyps)
+ )
+ in
+ refine to_refine g
+ )
+ ]
+ in
+ tclTHENLIST[
+ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp
+ ((* observe_tac "prove_trivial" *) prove_trivial);
+ scan_type context popped_t'
+ ]
+ else if is_trivial_eq t_x
+ then (* t_x := t = t => we remove this precond *)
+ let popped_t' = pop t' in
+ let real_type_of_hyp =
+ it_mkProd_or_LetIn ~init:popped_t' context
+ in
+ let hd,args = destApp t_x in
+ let get_args hd args =
+ if eq_constr hd (Lazy.force eq)
+ then (Lazy.force refl_equal,args.(0),args.(1))
+ else (jmeq_refl (),args.(0),args.(1))
+ in
+ tclTHENLIST
+ [
+ change_hyp_with_using
+ "prove_trivial_eq"
+ hyp_id
+ real_type_of_hyp
+ ((* observe_tac "prove_trivial_eq" *)
+ (prove_trivial_eq hyp_id context (get_args hd args)));
+ scan_type context popped_t'
+ ]
+ else
+ begin
+ try
+ let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in
+ tclTHEN
+ tac
+ (scan_type new_context new_t')
+ with Failure "NoChange" ->
+ (* Last thing todo : push the rel in the context and continue *)
+ scan_type ((x,None,t_x)::context) t'
+ end
+ end
+ else
+ tclIDTAC
+ in
+ try
+ scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id]
+ with TOREMOVE ->
+ thin [hyp_id],[]
+
+
+let clean_goal_with_heq ptes_infos continue_tac dyn_infos =
+ fun g ->
+ let env = pf_env g
+ and sigma = project g
+ in
+ let tac,new_hyps =
+ List.fold_left (
+ fun (hyps_tac,new_hyps) hyp_id ->
+ let hyp_tac,new_hyp =
+ clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma
+ in
+ (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps
+ )
+ (tclIDTAC,[])
+ dyn_infos.rec_hyps
+ in
+ let new_infos =
+ { dyn_infos with
+ rec_hyps = new_hyps;
+ nb_rec_hyps = List.length new_hyps
+ }
+ in
+ tclTHENLIST
+ [
+ tac ;
+ (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos)
+ ]
+ g
+
+let heq_id = id_of_string "Heq"
+
+let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
+ fun g ->
+ let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in
+ tclTHENLIST
+ [
+ (* We first introduce the variables *)
+ tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps);
+ (* Then the equation itself *)
+ intro_using heq_id;
+ onLastHypId (fun heq_id -> tclTHENLIST [
+ (* Then the new hypothesis *)
+ tclMAP introduction_no_check dyn_infos.rec_hyps;
+ (* observe_tac "after_introduction" *)(fun g' ->
+ (* We get infos on the equations introduced*)
+ let new_term_value_eq = pf_type_of g' (mkVar heq_id) in
+ (* compute the new value of the body *)
+ let new_term_value =
+ match kind_of_term new_term_value_eq with
+ | App(f,[| _;_;args2 |]) -> args2
+ | _ ->
+ observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++
+ pr_lconstr_env (pf_env g') new_term_value_eq
+ );
+ anomaly "cannot compute new term value"
+ in
+ let fun_body =
+ mkLambda(Anonymous,
+ pf_type_of g' term,
+ replace_term term (mkRel 1) dyn_infos.info
+ )
+ in
+ let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in
+ let new_infos =
+ {dyn_infos with
+ info = new_body;
+ eq_hyps = heq_id::dyn_infos.eq_hyps
+ }
+ in
+ clean_goal_with_heq ptes_infos continue_tac new_infos g'
+ )])
+ ]
+ g
+
+
+let my_orelse tac1 tac2 g =
+ try
+ tac1 g
+ with e ->
+(* observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *)
+ tac2 g
+
+let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id =
+ let args = Array.of_list (List.map mkVar args_id) in
+ let instanciate_one_hyp hid =
+ my_orelse
+ ( (* we instanciate the hyp if possible *)
+ fun g ->
+ let prov_hid = pf_get_new_id hid g in
+ tclTHENLIST[
+ pose_proof (Name prov_hid) (mkApp(mkVar hid,args));
+ thin [hid];
+ h_rename [prov_hid,hid]
+ ] g
+ )
+ ( (*
+ if not then we are in a mutual function block
+ and this hyp is a recursive hyp on an other function.
+
+ We are not supposed to use it while proving this
+ principle so that we can trash it
+
+ *)
+ (fun g ->
+(* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *)
+ thin [hid] g
+ )
+ )
+ in
+ if args_id = []
+ then
+ tclTHENLIST [
+ tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
+ do_prove hyps
+ ]
+ else
+ tclTHENLIST
+ [
+ tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps;
+ tclMAP instanciate_one_hyp hyps;
+ (fun g ->
+ let all_g_hyps_id =
+ List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty
+ in
+ let remaining_hyps =
+ List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps
+ in
+ do_prove remaining_hyps g
+ )
+ ]
+
+let build_proof
+ (interactive_proof:bool)
+ (fnames:constant list)
+ ptes_infos
+ dyn_infos
+ : tactic =
+ let rec build_proof_aux do_finalize dyn_infos : tactic =
+ fun g ->
+(* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*)
+ match kind_of_term dyn_infos.info with
+ | Case(ci,ct,t,cb) ->
+ let do_finalize_t dyn_info' =
+ fun g ->
+ let t = dyn_info'.info in
+ let dyn_infos = {dyn_info' with info =
+ mkCase(ci,ct,t,cb)} in
+ let g_nb_prod = nb_prod (pf_concl g) in
+ let type_of_term = pf_type_of g t in
+ let term_eq =
+ make_refl_eq (Lazy.force refl_equal) type_of_term t
+ in
+ tclTHENSEQ
+ [
+ h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
+ thin dyn_infos.rec_hyps;
+ pattern_option [(false,[1]),t] None;
+ (fun g -> observe_tac "toto" (
+ tclTHENSEQ [h_simplest_case t;
+ (fun g' ->
+ let g'_nb_prod = nb_prod (pf_concl g') in
+ let nb_instanciate_partial = g'_nb_prod - g_nb_prod in
+ observe_tac "treat_new_case"
+ (treat_new_case
+ ptes_infos
+ nb_instanciate_partial
+ (build_proof do_finalize)
+ t
+ dyn_infos)
+ g'
+ )
+
+ ]) g
+ )
+ ]
+ g
+ in
+ build_proof do_finalize_t {dyn_infos with info = t} g
+ | Lambda(n,t,b) ->
+ begin
+ match kind_of_term( pf_concl g) with
+ | Prod _ ->
+ tclTHEN
+ intro
+ (fun g' ->
+ let (id,_,_) = pf_last_hyp g' in
+ let new_term =
+ pf_nf_betaiota g'
+ (mkApp(dyn_infos.info,[|mkVar id|]))
+ in
+ let new_infos = {dyn_infos with info = new_term} in
+ let do_prove new_hyps =
+ build_proof do_finalize
+ {new_infos with
+ rec_hyps = new_hyps;
+ nb_rec_hyps = List.length new_hyps
+ }
+ in
+(* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g'
+ (* build_proof do_finalize new_infos g' *)
+ ) g
+ | _ ->
+ do_finalize dyn_infos g
+ end
+ | Cast(t,_,_) ->
+ build_proof do_finalize {dyn_infos with info = t} g
+ | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ ->
+ do_finalize dyn_infos g
+ | App(_,_) ->
+ let f,args = decompose_app dyn_infos.info in
+ begin
+ match kind_of_term f with
+ | App _ -> assert false (* we have collected all the app in decompose_app *)
+ | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ ->
+ let new_infos =
+ { dyn_infos with
+ info = (f,args)
+ }
+ in
+ build_proof_args do_finalize new_infos g
+ | Const c when not (List.mem c fnames) ->
+ let new_infos =
+ { dyn_infos with
+ info = (f,args)
+ }
+ in
+(* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *)
+ build_proof_args do_finalize new_infos g
+ | Const _ ->
+ do_finalize dyn_infos g
+ | Lambda _ ->
+ let new_term =
+ Reductionops.nf_beta Evd.empty dyn_infos.info in
+ build_proof do_finalize {dyn_infos with info = new_term}
+ g
+ | LetIn _ ->
+ let new_infos =
+ { dyn_infos with info = nf_betaiotazeta dyn_infos.info }
+ in
+
+ tclTHENLIST
+ [tclMAP
+ (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
+ dyn_infos.rec_hyps;
+ h_reduce_with_zeta Tacticals.onConcl;
+ build_proof do_finalize new_infos
+ ]
+ g
+ | Cast(b,_,_) ->
+ build_proof do_finalize {dyn_infos with info = b } g
+ | Case _ | Fix _ | CoFix _ ->
+ let new_finalize dyn_infos =
+ let new_infos =
+ { dyn_infos with
+ info = dyn_infos.info,args
+ }
+ in
+ build_proof_args do_finalize new_infos
+ in
+ build_proof new_finalize {dyn_infos with info = f } g
+ end
+ | Fix _ | CoFix _ ->
+ error ( "Anonymous local (co)fixpoints are not handled yet")
+
+ | Prod _ -> error "Prod"
+ | LetIn _ ->
+ let new_infos =
+ { dyn_infos with
+ info = nf_betaiotazeta dyn_infos.info
+ }
+ in
+
+ tclTHENLIST
+ [tclMAP
+ (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id))
+ dyn_infos.rec_hyps;
+ h_reduce_with_zeta Tacticals.onConcl;
+ build_proof do_finalize new_infos
+ ] g
+ | Rel _ -> anomaly "Free var in goal conclusion !"
+ and build_proof do_finalize dyn_infos g =
+(* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *)
+ observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g
+ and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic =
+ fun g ->
+ let (f_args',args) = dyn_infos.info in
+ let tac : tactic =
+ fun g ->
+ match args with
+ | [] ->
+ do_finalize {dyn_infos with info = f_args'} g
+ | arg::args ->
+(* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *)
+(* fnl () ++ *)
+(* pr_goal (Tacmach.sig_it g) *)
+(* ); *)
+ let do_finalize dyn_infos =
+ let new_arg = dyn_infos.info in
+ (* tclTRYD *)
+ (build_proof_args
+ do_finalize
+ {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args}
+ )
+ in
+ build_proof do_finalize
+ {dyn_infos with info = arg }
+ g
+ in
+ (* observe_tac "build_proof_args" *) (tac ) g
+ in
+ let do_finish_proof dyn_infos =
+ (* tclTRYD *) (clean_goal_with_heq
+ ptes_infos
+ finish_proof dyn_infos)
+ in
+ (* observe_tac "build_proof" *)
+ (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos)
+
+
+
+
+
+
+
+
+
+
+
+
+(* Proof of principles from structural functions *)
+let is_pte_type t =
+ isSort ((strip_prod t))
+
+let is_pte (_,_,t) = is_pte_type t
+
+
+
+
+type static_fix_info =
+ {
+ idx : int;
+ name : identifier;
+ types : types;
+ offset : int;
+ nb_realargs : int;
+ body_with_param : constr;
+ num_in_block : int
+ }
+
+
+
+let prove_rec_hyp_for_struct fix_info =
+ (fun eq_hyps -> tclTHEN
+ (rewrite_until_var (fix_info.idx) eq_hyps)
+ (fun g ->
+ let _,pte_args = destApp (pf_concl g) in
+ let rec_hyp_proof =
+ mkApp(mkVar fix_info.name,array_get_start pte_args)
+ in
+ refine rec_hyp_proof g
+ ))
+
+let prove_rec_hyp fix_info =
+ { proving_tac = prove_rec_hyp_for_struct fix_info
+ ;
+ is_valid = fun _ -> true
+ }
+
+
+exception Not_Rec
+
+let generalize_non_dep hyp g =
+(* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *)
+ let hyps = [hyp] in
+ let env = Global.env () in
+ let hyp_typ = pf_type_of g (mkVar hyp) in
+ 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 Termops.is_section_variable hyp (* should be dangerous *)
+ then (clear,decl::keep)
+ else (hyp::clear,keep))
+ ~init:([],[]) (pf_env g)
+ in
+(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
+ tclTHEN
+ ((* observe_tac "h_generalize" *) (h_generalize (List.map mkVar to_revert) ))
+ ((* observe_tac "thin" *) (thin to_revert))
+ g
+
+let id_of_decl (na,_,_) = (Nameops.out_name na)
+let var_of_decl decl = mkVar (id_of_decl decl)
+let revert idl =
+ tclTHEN
+ (generalize (List.map mkVar idl))
+ (thin idl)
+
+let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
+(* observe (str "nb_args := " ++ str (string_of_int nb_args)); *)
+(* observe (str "nb_params := " ++ str (string_of_int nb_params)); *)
+(* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *)
+ 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)
+ in
+ let params,f_body_with_params = decompose_lam_n nb_params f_body in
+ let (_,num),(_,_,bodies) = destFix f_body_with_params in
+ let fnames_with_params =
+ let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in
+ let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in
+ fnames
+ in
+(* observe (str "fnames_with_params " ++ prlist_with_sep fnl pr_lconstr fnames_with_params); *)
+(* observe (str "body " ++ pr_lconstr bodies.(num)); *)
+ let f_body_with_params_and_other_fun = substl fnames_with_params bodies.(num) in
+(* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *)
+ let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in
+(* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *)
+ let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args)
+ (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in
+ let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in
+ let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in
+ let f_id = id_of_label (con_label (destConst f)) in
+ let prove_replacement =
+ tclTHENSEQ
+ [
+ tclDO (nb_params + rec_args_num + 1) intro;
+ (* observe_tac "" *) (fun g ->
+ 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));
+ intros_reflexivity] g
+ )
+ ]
+ in
+ Lemmas.start_proof
+ (*i The next call to mk_equation_id is valid since we are constructing the lemma
+ Ensures by: obvious
+ i*)
+ (mk_equation_id f_id)
+ (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
+ lemma_type
+ (fun _ _ -> ());
+ Pfedit.by (prove_replacement);
+ Lemmas.save_named false
+
+
+
+
+let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
+ let equation_lemma =
+ try
+ let finfos = find_Function_infos (destConst f) in
+ mkConst (Option.get finfos.equation_lemma)
+ with (Not_found | Option.IsNone as e) ->
+ let f_id = id_of_label (con_label (destConst f)) in
+ (*i The next call to mk_equation_id is valid since we will construct the lemma
+ Ensures by: obvious
+ i*)
+ let equation_lemma_id = (mk_equation_id f_id) in
+ generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num;
+ let _ =
+ match e with
+ | Option.IsNone ->
+ let finfos = find_Function_infos (destConst f) in
+ update_Function
+ {finfos with
+ equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with
+ ConstRef c -> c
+ | _ -> Util.anomaly "Not a constant"
+ )
+ }
+ | _ -> ()
+
+ in
+ Tacinterp.constr_of_id (pf_env g) equation_lemma_id
+ in
+ let nb_intro_to_do = nb_prod (pf_concl g) in
+ tclTHEN
+ (tclDO nb_intro_to_do intro)
+ (
+ fun g' ->
+ let just_introduced = nLastDecls nb_intro_to_do g' in
+ let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in
+ tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g'
+ )
+ g
+
+let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic =
+ fun g ->
+ let princ_type = pf_concl g in
+ let princ_info = compute_elim_sig princ_type in
+ let fresh_id =
+ let avoid = ref (pf_ids_of_hyps g) in
+ (fun na ->
+ let new_id =
+ match na with
+ Name id -> fresh_id !avoid (string_of_id id)
+ | Anonymous -> fresh_id !avoid "H"
+ in
+ avoid := new_id :: !avoid;
+ (Name new_id)
+ )
+ in
+ let fresh_decl =
+ (fun (na,b,t) ->
+ (fresh_id na,b,t)
+ )
+ in
+ let princ_info : elim_scheme =
+ { princ_info with
+ params = List.map fresh_decl princ_info.params;
+ predicates = List.map fresh_decl princ_info.predicates;
+ branches = List.map fresh_decl princ_info.branches;
+ args = List.map fresh_decl princ_info.args
+ }
+ in
+ let get_body const =
+ match (Global.lookup_constant const ).const_body with
+ | Some b ->
+ let body = force b in
+ Tacred.cbv_norm_flags
+ (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+ (Global.env ())
+ (Evd.empty)
+ body
+ | None -> error ( "Cannot define a principle over an axiom ")
+ in
+ let fbody = get_body fnames.(fun_num) in
+ let f_ctxt,f_body = decompose_lam fbody in
+ let f_ctxt_length = List.length f_ctxt in
+ let diff_params = princ_info.nparams - f_ctxt_length in
+ let full_params,princ_params,fbody_with_full_params =
+ if diff_params > 0
+ then
+ let princ_params,full_params =
+ list_chop diff_params princ_info.params
+ in
+ (full_params, (* real params *)
+ princ_params, (* the params of the principle which are not params of the function *)
+ substl (* function instanciated with real params *)
+ (List.map var_of_decl full_params)
+ f_body
+ )
+ else
+ let f_ctxt_other,f_ctxt_params =
+ list_chop (- diff_params) f_ctxt in
+ let f_body = compose_lam f_ctxt_other f_body in
+ (princ_info.params, (* real params *)
+ [],(* all params are full params *)
+ substl (* function instanciated with real params *)
+ (List.map var_of_decl princ_info.params)
+ f_body
+ )
+ in
+(* observe (str "full_params := " ++ *)
+(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *)
+(* full_params *)
+(* ); *)
+(* observe (str "princ_params := " ++ *)
+(* prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na)) *)
+(* princ_params *)
+(* ); *)
+(* observe (str "fbody_with_full_params := " ++ *)
+(* pr_lconstr fbody_with_full_params *)
+(* ); *)
+ let all_funs_with_full_params =
+ Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs
+ in
+ let fix_offset = List.length princ_params in
+ let ptes_to_fix,infos =
+ match kind_of_term fbody_with_full_params with
+ | Fix((idxs,i),(names,typess,bodies)) ->
+ let bodies_with_all_params =
+ Array.map
+ (fun body ->
+ Reductionops.nf_betaiota Evd.empty
+ (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body,
+ List.rev_map var_of_decl princ_params))
+ )
+ bodies
+ in
+ let info_array =
+ Array.mapi
+ (fun i types ->
+ let types = prod_applist types (List.rev_map var_of_decl princ_params) in
+ { idx = idxs.(i) - fix_offset;
+ name = Nameops.out_name (fresh_id names.(i));
+ types = types;
+ offset = fix_offset;
+ nb_realargs =
+ List.length
+ (fst (decompose_lam bodies.(i))) - fix_offset;
+ body_with_param = bodies_with_all_params.(i);
+ num_in_block = i
+ }
+ )
+ typess
+ in
+ let pte_to_fix,rev_info =
+ list_fold_left_i
+ (fun i (acc_map,acc_info) (pte,_,_) ->
+ let infos = info_array.(i) in
+ let type_args,_ = decompose_prod infos.types in
+ let nargs = List.length type_args in
+ let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in
+ let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in
+ let app_f = mkApp(f,first_args) in
+ let pte_args = (Array.to_list first_args)@[app_f] in
+ let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in
+ let body_with_param,num =
+ let body = get_body fnames.(i) in
+ let body_with_full_params =
+ Reductionops.nf_betaiota Evd.empty (
+ applist(body,List.rev_map var_of_decl full_params))
+ in
+ match kind_of_term body_with_full_params with
+ | Fix((_,num),(_,_,bs)) ->
+ Reductionops.nf_betaiota Evd.empty
+ (
+ (applist
+ (substl
+ (List.rev
+ (Array.to_list all_funs_with_full_params))
+ bs.(num),
+ List.rev_map var_of_decl princ_params))
+ ),num
+ | _ -> error "Not a mutual block"
+ in
+ let info =
+ {infos with
+ types = compose_prod type_args app_pte;
+ body_with_param = body_with_param;
+ num_in_block = num
+ }
+ in
+(* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *)
+(* str " to " ++ Ppconstr.pr_id info.name); *)
+ (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info)
+ )
+ 0
+ (Idmap.empty,[])
+ (List.rev princ_info.predicates)
+ in
+ pte_to_fix,List.rev rev_info
+ | _ -> Idmap.empty,[]
+ in
+ let mk_fixes : tactic =
+ let pre_info,infos = list_chop fun_num infos in
+ match pre_info,infos with
+ | [],[] -> tclIDTAC
+ | _, this_fix_info::others_infos ->
+ let other_fix_infos =
+ List.map
+ (fun fi -> fi.name,fi.idx + 1 ,fi.types)
+ (pre_info@others_infos)
+ in
+ if other_fix_infos = []
+ then
+ (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1))
+ else
+ h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1)
+ other_fix_infos
+ | _ -> anomaly "Not a valid information"
+ in
+ let first_tac : tactic = (* every operations until fix creations *)
+ tclTHENSEQ
+ [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params));
+ (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates));
+ (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches));
+ (* observe_tac "building fixes" *) mk_fixes;
+ ]
+ in
+ let intros_after_fixes : tactic =
+ fun gl ->
+ let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in
+ let pte,pte_args = (decompose_app pte_app) in
+ try
+ let pte = try destVar pte with _ -> anomaly "Property is not a variable" in
+ let fix_info = Idmap.find pte ptes_to_fix in
+ let nb_args = fix_info.nb_realargs in
+ tclTHENSEQ
+ [
+ (* observe_tac ("introducing args") *) (tclDO nb_args intro);
+ (fun g -> (* replacement of the function by its body *)
+ let args = nLastDecls nb_args g in
+ let fix_body = fix_info.body_with_param in
+(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *)
+ let args_id = List.map (fun (id,_,_) -> id) args in
+ let dyn_infos =
+ {
+ nb_rec_hyps = -100;
+ rec_hyps = [];
+ info =
+ Reductionops.nf_betaiota Evd.empty
+ (applist(fix_body,List.rev_map mkVar args_id));
+ eq_hyps = []
+ }
+ in
+ tclTHENSEQ
+ [
+(* observe_tac "do_replace" *)
+ (do_replace
+ full_params
+ (fix_info.idx + List.length princ_params)
+ (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params))
+ (all_funs.(fix_info.num_in_block))
+ fix_info.num_in_block
+ all_funs
+ );
+(* observe_tac "do_replace" *)
+(* (do_replace princ_info.params fix_info.idx args_id *)
+(* (List.hd (List.rev pte_args)) fix_body); *)
+ let do_prove =
+ build_proof
+ interactive_proof
+ (Array.to_list fnames)
+ (Idmap.map prove_rec_hyp ptes_to_fix)
+ in
+ let prove_tac branches =
+ let dyn_infos =
+ {dyn_infos with
+ rec_hyps = branches;
+ nb_rec_hyps = List.length branches
+ }
+ in
+ observe_tac "cleaning" (clean_goal_with_heq
+ (Idmap.map prove_rec_hyp ptes_to_fix)
+ do_prove
+ dyn_infos)
+ in
+(* observe (str "branches := " ++ *)
+(* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *)
+(* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *)
+
+(* ); *)
+ (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac
+ (List.rev_map id_of_decl princ_info.branches)
+ (List.rev args_id))
+ ]
+ g
+ );
+ ] gl
+ with Not_found ->
+ let nb_args = min (princ_info.nargs) (List.length ctxt) in
+ tclTHENSEQ
+ [
+ tclDO nb_args intro;
+ (fun g -> (* replacement of the function by its body *)
+ let args = nLastDecls nb_args g in
+ let args_id = List.map (fun (id,_,_) -> id) args in
+ let dyn_infos =
+ {
+ nb_rec_hyps = -100;
+ rec_hyps = [];
+ info =
+ Reductionops.nf_betaiota Evd.empty
+ (applist(fbody_with_full_params,
+ (List.rev_map var_of_decl princ_params)@
+ (List.rev_map mkVar args_id)
+ ));
+ eq_hyps = []
+ }
+ in
+ let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
+ tclTHENSEQ
+ [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)];
+ let do_prove =
+ build_proof
+ interactive_proof
+ (Array.to_list fnames)
+ (Idmap.map prove_rec_hyp ptes_to_fix)
+ in
+ let prove_tac branches =
+ let dyn_infos =
+ {dyn_infos with
+ rec_hyps = branches;
+ nb_rec_hyps = List.length branches
+ }
+ in
+ clean_goal_with_heq
+ (Idmap.map prove_rec_hyp ptes_to_fix)
+ do_prove
+ dyn_infos
+ in
+ instanciate_hyps_with_args prove_tac
+ (List.rev_map id_of_decl princ_info.branches)
+ (List.rev args_id)
+ ]
+ g
+ )
+ ]
+ gl
+ in
+ tclTHEN
+ first_tac
+ intros_after_fixes
+ g
+
+
+
+
+
+
+(* Proof of principles of general functions *)
+let h_id = Recdef.h_id
+and hrec_id = Recdef.hrec_id
+and acc_inv_id = Recdef.acc_inv_id
+and ltof_ref = Recdef.ltof_ref
+and acc_rel = Recdef.acc_rel
+and well_founded = Recdef.well_founded
+and delayed_force = Recdef.delayed_force
+and h_intros = Recdef.h_intros
+and list_rewrite = Recdef.list_rewrite
+and evaluable_of_global_reference = Recdef.evaluable_of_global_reference
+
+
+
+
+
+let prove_with_tcc tcc_lemma_constr eqs : tactic =
+ match !tcc_lemma_constr with
+ | None -> anomaly "No tcc proof !!"
+ | Some lemma ->
+ fun gls ->
+(* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *)
+(* let ids = hid::pf_ids_of_hyps gls in *)
+ tclTHENSEQ
+ [
+(* generalize [lemma]; *)
+(* h_intro hid; *)
+(* Elim.h_decompose_and (mkVar hid); *)
+ tclTRY(list_rewrite true eqs);
+(* (fun g -> *)
+(* let ids' = pf_ids_of_hyps g in *)
+(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *)
+(* rewrite *)
+(* ) *)
+ Eauto.gen_eauto false (false,5) [] (Some [])
+ ]
+ gls
+
+
+let backtrack_eqs_until_hrec hrec eqs : tactic =
+ fun gls ->
+ let eqs = List.map mkVar eqs in
+ let rewrite =
+ tclFIRST (List.map Equality.rewriteRL eqs )
+ in
+ let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in
+ let f_app = array_last (snd (destApp hrec_concl)) in
+ let f = (fst (destApp f_app)) in
+ let rec backtrack : tactic =
+ fun g ->
+ let f_app = array_last (snd (destApp (pf_concl g))) in
+ match kind_of_term f_app with
+ | App(f',_) when eq_constr f' f -> tclIDTAC g
+ | _ -> tclTHEN rewrite backtrack g
+ in
+ backtrack gls
+
+
+
+let build_clause eqs =
+ {
+ Tacexpr.onhyps =
+ Some (List.map
+ (fun id -> (Rawterm.all_occurrences_expr,id),InHyp)
+ eqs
+ );
+ Tacexpr.concl_occs = Rawterm.no_occurrences_expr
+ }
+
+let rec rewrite_eqs_in_eqs eqs =
+ match eqs with
+ | [] -> tclIDTAC
+ | eq::eqs ->
+
+ tclTHEN
+ (tclMAP
+ (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))
+ gl
+ )
+ eqs
+ )
+ (rewrite_eqs_in_eqs eqs)
+
+let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
+ fun gls ->
+ (tclTHENSEQ
+ [
+ backtrack_eqs_until_hrec hrec eqs;
+ (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *)
+ (tclTHENS (* We must have exactly ONE subgoal !*)
+ (apply (mkVar hrec))
+ [ tclTHENSEQ
+ [
+ keep (tcc_hyps@eqs);
+ apply (Lazy.force acc_inv);
+ (fun g ->
+ if is_mes
+ then
+ unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
+ else tclIDTAC g
+ );
+ observe_tac "rew_and_finish"
+ (tclTHENLIST
+ [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs));
+ observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs);
+ (observe_tac "finishing using"
+ (
+ tclCOMPLETE(
+ Eauto.eauto_with_bases
+ false
+ (true,5)
+ [Lazy.force refl_equal]
+ [Auto.Hint_db.empty empty_transparent_state false]
+ )
+ )
+ )
+ ]
+ )
+ ]
+ ])
+ ])
+ gls
+
+
+let is_valid_hypothesis predicates_name =
+ let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in
+ let is_pte typ =
+ if isApp typ
+ then
+ let pte,_ = destApp typ in
+ if isVar pte
+ then Idset.mem (destVar pte) predicates_name
+ else false
+ else false
+ in
+ let rec is_valid_hypothesis typ =
+ is_pte typ ||
+ match kind_of_term typ with
+ | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ'
+ | _ -> false
+ in
+ is_valid_hypothesis
+
+let prove_principle_for_gen
+ (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes
+ rec_arg_num rec_arg_type relation gl =
+ let princ_type = pf_concl gl in
+ let princ_info = compute_elim_sig princ_type in
+ let fresh_id =
+ let avoid = ref (pf_ids_of_hyps gl) in
+ fun na ->
+ let new_id =
+ match na with
+ | Name id -> fresh_id !avoid (string_of_id id)
+ | Anonymous -> fresh_id !avoid "H"
+ in
+ avoid := new_id :: !avoid;
+ Name new_id
+ in
+ let fresh_decl (na,b,t) = (fresh_id na,b,t) in
+ let princ_info : elim_scheme =
+ { princ_info with
+ params = List.map fresh_decl princ_info.params;
+ predicates = List.map fresh_decl princ_info.predicates;
+ branches = List.map fresh_decl princ_info.branches;
+ args = List.map fresh_decl princ_info.args
+ }
+ in
+ let wf_tac =
+ if is_mes
+ then
+ (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None)
+ else fun _ -> prove_with_tcc tcc_lemma_ref []
+ in
+ let real_rec_arg_num = rec_arg_num - princ_info.nparams in
+ let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in
+(* observe ( *)
+(* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *)
+(* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *)
+
+(* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *)
+(* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *)
+(* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *)
+(* str "npost_rec_arg := " ++ int npost_rec_arg ); *)
+ let (post_rec_arg,pre_rec_arg) =
+ Util.list_chop npost_rec_arg princ_info.args
+ in
+ let rec_arg_id =
+ match List.rev post_rec_arg with
+ | (Name id,_,_)::_ -> id
+ | _ -> assert false
+ in
+(* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *)
+ let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in
+ let relation = substl subst_constrs relation in
+ let input_type = substl subst_constrs rec_arg_type in
+ let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in
+ let acc_rec_arg_id =
+ Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id)))))
+ in
+ let revert l =
+ tclTHEN (h_generalize (List.map mkVar l)) (clear l)
+ in
+ let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in
+ let prove_rec_arg_acc g =
+ ((* observe_tac "prove_rec_arg_acc" *)
+ (tclCOMPLETE
+ (tclTHEN
+ (assert_by (Name wf_thm_id)
+ (mkApp (delayed_force well_founded,[|input_type;relation|]))
+ (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g))
+ (
+ (* observe_tac *)
+(* "apply wf_thm" *)
+ h_simplest_apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))
+ )
+ )
+ )
+ )
+ g
+ in
+ let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
+ let lemma =
+ match !tcc_lemma_ref with
+ | None -> anomaly ( "No tcc proof !!")
+ | Some lemma -> lemma
+ in
+(* let rec list_diff del_list check_list = *)
+(* match del_list with *)
+(* [] -> *)
+(* [] *)
+(* | f::r -> *)
+(* if List.mem f check_list then *)
+(* list_diff r check_list *)
+(* else *)
+(* f::(list_diff r check_list) *)
+(* in *)
+ let tcc_list = ref [] in
+ let start_tac gls =
+ let hyps = pf_ids_of_hyps gls in
+ let hid =
+ next_ident_away_in_goal
+ (id_of_string "prov")
+ hyps
+ in
+ tclTHENSEQ
+ [
+ generalize [lemma];
+ h_intro hid;
+ Elim.h_decompose_and (mkVar hid);
+ (fun g ->
+ let new_hyps = pf_ids_of_hyps g in
+ tcc_list := List.rev (list_subtract new_hyps (hid::hyps));
+ if !tcc_list = []
+ then
+ begin
+ tcc_list := [hid];
+ tclIDTAC g
+ end
+ else thin [hid] g
+ )
+ ]
+ gls
+ in
+ tclTHENSEQ
+ [
+ observe_tac "start_tac" start_tac;
+ h_intros
+ (List.rev_map (fun (na,_,_) -> Nameops.out_name na)
+ (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
+ );
+ (* observe_tac "" *) (assert_by
+ (Name acc_rec_arg_id)
+ (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))
+ (prove_rec_arg_acc)
+ );
+(* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids)));
+(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *)
+(* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *)
+ (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1));
+(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *)
+ h_intros (List.rev (acc_rec_arg_id::args_ids));
+ Equality.rewriteLR (mkConst eq_ref);
+ (* observe_tac "finish" *) (fun gl' ->
+ let body =
+ let _,args = destApp (pf_concl gl') in
+ array_last args
+ in
+ let body_info rec_hyps =
+ {
+ nb_rec_hyps = List.length rec_hyps;
+ rec_hyps = rec_hyps;
+ eq_hyps = [];
+ info = body
+ }
+ in
+ let acc_inv =
+ lazy (
+ mkApp (
+ delayed_force acc_inv_id,
+ [|input_type;relation;mkVar rec_arg_id|]
+ )
+ )
+ in
+ let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in
+ let predicates_names =
+ List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates
+ in
+ let pte_info =
+ { proving_tac =
+ (fun eqs ->
+(* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *)
+(* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *)
+(* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *)
+(* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *)
+(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *)
+
+ (* observe_tac "new_prove_with_tcc" *)
+ (new_prove_with_tcc
+ is_mes acc_inv fix_id
+
+ (!tcc_list@(List.map
+ (fun (na,_,_) -> (Nameops.out_name na))
+ (princ_info.args@princ_info.params)
+ )@ ([acc_rec_arg_id])) eqs
+ )
+
+ );
+ is_valid = is_valid_hypothesis predicates_names
+ }
+ in
+ let ptes_info : pte_info Idmap.t =
+ List.fold_left
+ (fun map pte_id ->
+ Idmap.add pte_id
+ pte_info
+ map
+ )
+ Idmap.empty
+ predicates_names
+ in
+ let make_proof rec_hyps =
+ build_proof
+ false
+ [f_ref]
+ ptes_info
+ (body_info rec_hyps)
+ in
+ (* observe_tac "instanciate_hyps_with_args" *)
+ (instanciate_hyps_with_args
+ make_proof
+ (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches)
+ (List.rev args_ids)
+ )
+ gl'
+ )
+
+ ]
+ gl
+
+
+
+
+
+
+
+
diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli
new file mode 100644
index 00000000..ff98f2b9
--- /dev/null
+++ b/plugins/funind/functional_principles_proofs.mli
@@ -0,0 +1,19 @@
+open Names
+open Term
+
+val prove_princ_for_struct :
+ bool ->
+ int -> constant array -> constr array -> int -> Tacmach.tactic
+
+
+val prove_principle_for_gen :
+ constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *)
+ constr option ref -> (* a pointer to the obligation proofs lemma *)
+ bool -> (* is that function uses measure *)
+ int -> (* the number of recursive argument *)
+ types -> (* the type of the recursive argument *)
+ constr -> (* the wf relation used to prove the function *)
+ Tacmach.tactic
+
+
+(* val is_pte : rel_declaration -> bool *)
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
new file mode 100644
index 00000000..b756492b
--- /dev/null
+++ b/plugins/funind/functional_principles_types.ml
@@ -0,0 +1,737 @@
+open Printer
+open Util
+open Term
+open Termops
+open Namegen
+open Names
+open Declarations
+open Pp
+open Entries
+open Hiddentac
+open Evd
+open Tacmach
+open Proof_type
+open Tacticals
+open Tactics
+open Indfun_common
+open Functional_principles_proofs
+
+exception Toberemoved_with_rel of int*constr
+exception Toberemoved
+
+
+let pr_elim_scheme el =
+ let env = Global.env () in
+ let msg = str "params := " ++ Printer.pr_rel_context env el.params in
+ let env = Environ.push_rel_context el.params env in
+ let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
+ let env = Environ.push_rel_context el.predicates env in
+ let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
+ let env = Environ.push_rel_context el.branches env in
+ let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
+ let env = Environ.push_rel_context el.args env in
+ msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
+
+
+let observe s =
+ if do_observe ()
+ then Pp.msgnl s
+
+
+let pr_elim_scheme el =
+ let env = Global.env () in
+ let msg = str "params := " ++ Printer.pr_rel_context env el.params in
+ let env = Environ.push_rel_context el.params env in
+ let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in
+ let env = Environ.push_rel_context el.predicates env in
+ let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in
+ let env = Environ.push_rel_context el.branches env in
+ let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in
+ let env = Environ.push_rel_context el.args env in
+ msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl
+
+
+let observe s =
+ if do_observe ()
+ then Pp.msgnl s
+
+(*
+ Transform an inductive induction principle into
+ a functional one
+*)
+let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
+ let princ_type_info = compute_elim_sig princ_type in
+ let env = Global.env () in
+ let env_with_params = Environ.push_rel_context princ_type_info.params env in
+ let tbl = Hashtbl.create 792 in
+ let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context =
+ match predicates with
+ | [] -> []
+ |(Name x,v,t)::predicates ->
+ let id = Namegen.next_ident_away x avoid in
+ Hashtbl.add tbl id x;
+ (Name id,v,t)::(change_predicates_names (id::avoid) predicates)
+ | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder "
+ in
+ let avoid = (Termops.ids_of_context env_with_params ) in
+ let princ_type_info =
+ { princ_type_info with
+ predicates = change_predicates_names avoid princ_type_info.predicates
+ }
+ in
+(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *)
+(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *)
+ let change_predicate_sort i (x,_,t) =
+ let new_sort = sorts.(i) in
+ let args,_ = decompose_prod t in
+ let real_args =
+ if princ_type_info.indarg_in_concl
+ then List.tl args
+ else args
+ in
+ Nameops.out_name x,None,compose_prod real_args (mkSort new_sort)
+ in
+ let new_predicates =
+ list_map_i
+ change_predicate_sort
+ 0
+ princ_type_info.predicates
+ in
+ let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in
+ let rel_as_kn =
+ fst (match princ_type_info.indref with
+ | Some (Libnames.IndRef ind) -> ind
+ | _ -> error "Not a valid predicate"
+ )
+ in
+ let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
+ let is_pte =
+ let set = List.fold_right Idset.add ptes_vars Idset.empty in
+ fun t ->
+ match kind_of_term t with
+ | Var id -> Idset.mem id set
+ | _ -> false
+ in
+ let pre_princ =
+ it_mkProd_or_LetIn
+ ~init:
+ (it_mkProd_or_LetIn
+ ~init:(Option.fold_right
+ mkProd_or_LetIn
+ princ_type_info.indarg
+ princ_type_info.concl
+ )
+ princ_type_info.args
+ )
+ princ_type_info.branches
+ in
+ let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in
+ let is_dom c =
+ match kind_of_term c with
+ | Ind((u,_)) -> u = rel_as_kn
+ | Construct((u,_),_) -> u = rel_as_kn
+ | _ -> false
+ in
+ let get_fun_num c =
+ match kind_of_term c with
+ | Ind(_,num) -> num
+ | Construct((_,num),_) -> num
+ | _ -> assert false
+ 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
+(* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *)
+ res
+ in
+ let rec has_dummy_var t =
+ fold_constr
+ (fun b t -> b || (eq_constr t dummy_var) || (has_dummy_var t))
+ false
+ t
+ in
+ let rec compute_new_princ_type remove env pre_princ : types*(constr list) =
+ let (new_princ_type,_) as res =
+ match kind_of_term pre_princ with
+ | Rel n ->
+ begin
+ try match Environ.lookup_rel n env with
+ | _,_,t when is_dom t -> raise Toberemoved
+ | _ -> pre_princ,[] with Not_found -> assert false
+ end
+ | Prod(x,t,b) ->
+ compute_new_princ_type_for_binder remove mkProd env x t b
+ | Lambda(x,t,b) ->
+ compute_new_princ_type_for_binder remove mkLambda env x t b
+ | Ind _ | Construct _ when is_dom pre_princ -> raise Toberemoved
+ | App(f,args) when is_dom f ->
+ let var_to_be_removed = destRel (array_last args) in
+ let num = get_fun_num f in
+ raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args))
+ | App(f,args) ->
+ let args =
+ if is_pte f && remove
+ then array_get_start args
+ else args
+ in
+ let new_args,binders_to_remove =
+ Array.fold_right (compute_new_princ_type_with_acc remove env)
+ args
+ ([],[])
+ in
+ let new_f,binders_to_remove_from_f = compute_new_princ_type remove env f in
+ applist(new_f, new_args),
+ list_union_eq eq_constr binders_to_remove_from_f binders_to_remove
+ | LetIn(x,v,t,b) ->
+ compute_new_princ_type_for_letin remove env x v t b
+ | _ -> pre_princ,[]
+ in
+(* let _ = match kind_of_term pre_princ with *)
+(* | Prod _ -> *)
+(* observe(str "compute_new_princ_type for "++ *)
+(* pr_lconstr_env env pre_princ ++ *)
+(* str" is "++ *)
+(* pr_lconstr_env env new_princ_type ++ fnl ()) *)
+(* | _ -> () in *)
+ res
+
+ and compute_new_princ_type_for_binder remove bind_fun env x t b =
+ 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_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
+ 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)
+ )
+
+ 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
+ | 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)
+ 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_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
+ 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)
+ )
+
+ 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
+ | 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)
+ 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
+ in
+ new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc
+ in
+(* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *)
+ let pre_res,_ =
+ compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ
+ in
+ let pre_res =
+ replace_vars
+ (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars)
+ (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)
+ )
+ princ_type_info.params
+
+
+
+let change_property_sort toSort princ princName =
+ let princ_info = compute_elim_sig princ in
+ let change_sort_in_predicate (x,v,t) =
+ (x,None,
+ let args,_ = decompose_prod t in
+ compose_prod args (mkSort toSort)
+ )
+ in
+ let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in
+ let init =
+ let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in
+ mkApp(princName_as_constr,
+ Array.init nargs
+ (fun i -> mkRel (nargs - i )))
+ in
+ it_mkLambda_or_LetIn
+ ~init:
+ (it_mkLambda_or_LetIn ~init
+ (List.map change_sort_in_predicate princ_info.predicates)
+ )
+ princ_info.params
+
+
+let pp_dur time time' =
+ str (string_of_float (System.time_difference time time'))
+
+(* let qed () = save_named true *)
+let defined () =
+ try
+ Lemmas.save_named false
+ with
+ | UserError("extract_proof",msg) ->
+ Util.errorlabstrm
+ "defined"
+ ((try
+ str "On goal : " ++ fnl () ++ pr_open_subgoals () ++ fnl ()
+ with _ -> mt ()
+ ) ++msg)
+ | e -> raise e
+
+
+
+let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook =
+ (* First we get the type of the old graph principle *)
+ let mutr_nparams = (compute_elim_sig old_princ_type).nparams in
+ (* let time1 = System.get_time () in *)
+ let new_principle_type =
+ compute_new_princ_type_from_rel
+ (Array.map mkConst funs)
+ sorts
+ old_princ_type
+ in
+ (* let time2 = System.get_time () in *)
+ (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *)
+ observe (str "new_principle_type : " ++ pr_lconstr new_principle_type);
+ let new_princ_name =
+ next_ident_away_in_goal (id_of_string "___________princ_________") []
+ in
+ begin
+ Lemmas.start_proof
+ new_princ_name
+ (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
+ new_principle_type
+ (hook new_principle_type)
+ ;
+ (* let _tim1 = System.get_time () in *)
+ Pfedit.by (proof_tac (Array.map mkConst funs) mutr_nparams);
+ (* let _tim2 = System.get_time () in *)
+ (* begin *)
+ (* let dur1 = System.time_difference tim1 tim2 in *)
+ (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
+ (* end; *)
+ get_proof_clean true
+ end
+
+
+
+let generate_functional_principle
+ interactive_proof
+ old_princ_type sorts new_princ_name funs i proof_tac
+ =
+ try
+
+ let f = funs.(i) in
+ let type_sort = Termops.new_sort_in_family InType in
+ let new_sorts =
+ match sorts with
+ | None -> Array.make (Array.length funs) (type_sort)
+ | Some a -> a
+ in
+ let base_new_princ_name,new_princ_name =
+ match new_princ_name with
+ | Some (id) -> id,id
+ | None ->
+ let id_of_f = id_of_label (con_label f) in
+ id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort)
+ in
+ let names = ref [new_princ_name] in
+ let hook new_principle_type _ _ =
+ if sorts = None
+ then
+ (* let id_of_f = id_of_label (con_label f) in *)
+ let register_with_sort fam_sort =
+ let s = Termops.new_sort_in_family fam_sort in
+ let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in
+ let value = change_property_sort s new_principle_type new_princ_name in
+ (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *)
+ let ce =
+ { const_entry_body = value;
+ const_entry_type = None;
+ const_entry_opaque = false;
+ const_entry_boxed = Flags.boxed_definitions()
+ }
+ in
+ ignore(
+ Declare.declare_constant
+ name
+ (Entries.DefinitionEntry ce,
+ Decl_kinds.IsDefinition (Decl_kinds.Scheme)
+ )
+ );
+ Flags.if_verbose
+ (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined"))
+ name;
+ names := name :: !names
+ in
+ register_with_sort InProp;
+ register_with_sort InSet
+ in
+ let (id,(entry,g_kind,hook)) =
+ build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook
+ in
+ (* Pr 1278 :
+ Don't forget to close the goal if an error is raised !!!!
+ *)
+ save false new_princ_name entry g_kind hook
+ with e ->
+ begin
+ begin
+ try
+ let id = Pfedit.get_current_proof_name () in
+ let s = string_of_id id in
+ let n = String.length "___________princ_________" in
+ if String.length s >= n
+ then if String.sub s 0 n = "___________princ_________"
+ then Pfedit.delete_current_proof ()
+ else ()
+ else ()
+ with _ -> ()
+ end;
+ raise (Defining_principle e)
+ end
+(* defined () *)
+
+
+exception Not_Rec
+
+let get_funs_constant mp dp =
+ let rec get_funs_constant const e : (Names.constant*int) array =
+ match kind_of_term ((strip_lam e)) with
+ | Fix((_,(na,_,_))) ->
+ Array.mapi
+ (fun i na ->
+ match na with
+ | Name id ->
+ let const = make_con mp dp (label_of_id id) in
+ const,i
+ | Anonymous ->
+ anomaly "Anonymous fix"
+ )
+ na
+ | _ -> [|const,0|]
+ in
+ function const ->
+ let find_constant_body const =
+ match (Global.lookup_constant const ).const_body with
+ | Some b ->
+ let body = force b in
+ let body = Tacred.cbv_norm_flags
+ (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+ (Global.env ())
+ (Evd.empty)
+ body
+ in
+ body
+ | None -> error ( "Cannot define a principle over an axiom ")
+ in
+ let f = find_constant_body const in
+ let l_const = get_funs_constant const f in
+ (*
+ We need to check that all the functions found are in the same block
+ to prevent Reset stange thing
+ *)
+ let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in
+ let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in
+ (* all the paremeter must be equal*)
+ let _check_params =
+ let first_params = List.hd l_params in
+ List.iter
+ (fun params ->
+ if not ((=) first_params params)
+ then error "Not a mutal recursive block"
+ )
+ l_params
+ in
+ (* The bodies has to be very similar *)
+ let _check_bodies =
+ try
+ let extract_info is_first body =
+ match kind_of_term body with
+ | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca)
+ | _ ->
+ if is_first && (List.length l_bodies = 1)
+ then raise Not_Rec
+ else error "Not a mutal recursive block"
+ 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))
+ then error "Not a mutal recursive block"
+ in
+ List.iter check l_bodies
+ with Not_Rec -> ()
+ in
+ l_const
+
+exception No_graph_found
+exception Found_type of int
+
+let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list =
+ let env = Global.env ()
+ and sigma = Evd.empty in
+ let funs = List.map fst fas in
+ let first_fun = List.hd funs in
+
+
+ let funs_mp,funs_dp,_ = Names.repr_con first_fun in
+ let first_fun_kn =
+ try
+ fst (find_Function_infos first_fun).graph_ind
+ with Not_found -> raise No_graph_found
+ in
+ let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
+ let this_block_funs = Array.map fst this_block_funs_indexes in
+ let prop_sort = InProp in
+ let funs_indexes =
+ let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
+ List.map
+ (function const -> List.assoc const this_block_funs_indexes)
+ funs
+ in
+ let ind_list =
+ List.map
+ (fun (idx) ->
+ let ind = first_fun_kn,idx in
+ ind,true,prop_sort
+ )
+ funs_indexes
+ in
+ let l_schemes =
+ List.map
+ (Typing.type_of env sigma)
+ (Indrec.build_mutual_induction_scheme env sigma ind_list)
+ in
+ let i = ref (-1) in
+ let sorts =
+ List.rev_map (fun (_,x) ->
+ Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
+ )
+ fas
+ in
+ (* We create the first priciple by tactic *)
+ let first_type,other_princ_types =
+ match l_schemes with
+ s::l_schemes -> s,l_schemes
+ | _ -> anomaly ""
+ in
+ let (_,(const,_,_)) =
+ try
+ build_functional_principle false
+ first_type
+ (Array.of_list sorts)
+ this_block_funs
+ 0
+ (prove_princ_for_struct false 0 (Array.of_list funs))
+ (fun _ _ _ -> ())
+ with e ->
+ begin
+ begin
+ try
+ let id = Pfedit.get_current_proof_name () in
+ let s = string_of_id id in
+ let n = String.length "___________princ_________" in
+ if String.length s >= n
+ then if String.sub s 0 n = "___________princ_________"
+ then Pfedit.delete_current_proof ()
+ else ()
+ else ()
+ with _ -> ()
+ end;
+ raise (Defining_principle e)
+ end
+
+ in
+ incr i;
+ let opacity =
+ 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
+ with Option.IsNone -> (* non recursive definition *)
+ false
+ in
+ let const = {const with const_entry_opaque = opacity } in
+ (* The others are just deduced *)
+ if other_princ_types = []
+ then
+ [const]
+ else
+ let other_fun_princ_types =
+ let funs = Array.map mkConst this_block_funs in
+ let sorts = Array.of_list sorts in
+ List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types
+ in
+ let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in
+ let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*)
+ let (idxs,_),(_,ta,_ as decl) = destFix fix in
+ let other_result =
+ List.map (* we can now compute the other principles *)
+ (fun scheme_type ->
+ incr i;
+ observe (Printer.pr_lconstr scheme_type);
+ let type_concl = (strip_prod_assum scheme_type) in
+ let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in
+ let f = fst (decompose_app applied_f) in
+ try (* we search the number of the function in the fix block (name of the function) *)
+ Array.iteri
+ (fun j t ->
+ let t = (strip_prod_assum t) in
+ let applied_g = List.hd (List.rev (snd (decompose_app t))) in
+ let g = fst (decompose_app applied_g) in
+ if eq_constr f g
+ then raise (Found_type j);
+ observe (Printer.pr_lconstr f ++ str " <> " ++
+ Printer.pr_lconstr g)
+
+ )
+ ta;
+ (* If we reach this point, the two principle are not mutually recursive
+ We fall back to the previous method
+ *)
+ let (_,(const,_,_)) =
+ build_functional_principle
+ false
+ (List.nth other_princ_types (!i - 1))
+ (Array.of_list sorts)
+ this_block_funs
+ !i
+ (prove_princ_for_struct false !i (Array.of_list funs))
+ (fun _ _ _ -> ())
+ in
+ const
+ with Found_type i ->
+ let princ_body =
+ Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt
+ in
+ {const with
+ Entries.const_entry_body = princ_body;
+ Entries.const_entry_type = Some scheme_type
+ }
+ )
+ other_fun_princ_types
+ in
+ const::other_result
+
+let build_scheme fas =
+ Dumpglob.pause ();
+ let bodies_types =
+ make_scheme
+ (List.map
+ (fun (_,f,sort) ->
+ let f_as_constant =
+ try
+ match Nametab.global f with
+ | Libnames.ConstRef c -> c
+ | _ -> Util.error "Functional Scheme can only be used with functions"
+ with Not_found ->
+ Util.error ("Cannot find "^ Libnames.string_of_reference f)
+ in
+ (f_as_constant,sort)
+ )
+ fas
+ )
+ in
+ List.iter2
+ (fun (princ_id,_,_) def_entry ->
+ ignore
+ (Declare.declare_constant
+ princ_id
+ (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem));
+ Flags.if_verbose
+ (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
+ )
+ fas
+ bodies_types;
+ Dumpglob.continue ()
+
+
+
+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 *)
+(* in *)
+ let funs = (fun (_,f,_) ->
+ try Libnames.constr_of_global (Nametab.global f)
+ with Not_found ->
+ Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in
+ let first_fun = destConst funs in
+
+ let funs_mp,funs_dp,_ = Names.repr_con first_fun in
+ let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in
+
+
+
+ let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in
+ let this_block_funs = Array.map fst this_block_funs_indexes in
+ let prop_sort = InProp in
+ let funs_indexes =
+ let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
+ List.assoc (destConst funs) this_block_funs_indexes
+ in
+ let ind_fun =
+ let ind = first_fun_kn,funs_indexes in
+ ind,prop_sort
+ in
+ let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun) in
+ let sorts =
+ (fun (_,_,x) ->
+ Termops.new_sort_in_family (Pretyping.interp_elimination_sort x)
+ )
+ fa
+ in
+ let princ_name = (fun (x,_,_) -> x) fa in
+ let _ =
+ (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++
+ pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs
+ );
+ *)
+ generate_functional_principle
+ false
+ scheme_type
+ (Some ([|sorts|]))
+ (Some princ_name)
+ this_block_funs
+ 0
+ (prove_princ_for_struct false 0 [|destConst funs|])
+ in
+ ()
diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli
new file mode 100644
index 00000000..fb04c6ec
--- /dev/null
+++ b/plugins/funind/functional_principles_types.mli
@@ -0,0 +1,34 @@
+open Names
+open Term
+
+
+val generate_functional_principle :
+ (* do we accept interactive proving *)
+ bool ->
+ (* induction principle on rel *)
+ types ->
+ (* *)
+ sorts array option ->
+ (* Name of the new principle *)
+ (identifier) option ->
+ (* the compute functions to use *)
+ constant array ->
+ (* We prove the nth- principle *)
+ int ->
+ (* The tactic to use to make the proof w.r
+ the number of params
+ *)
+ (constr array -> int -> Tacmach.tactic) ->
+ unit
+
+val compute_new_princ_type_from_rel : constr array -> sorts array ->
+ types -> types
+
+
+exception No_graph_found
+
+val make_scheme : (constant*Rawterm.rawsort) 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
+
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
new file mode 100644
index 00000000..bc400ae1
--- /dev/null
+++ b/plugins/funind/g_indfun.ml4
@@ -0,0 +1,524 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(*i camlp4deps: "parsing/grammar.cma" i*)
+open Util
+open Term
+open Names
+open Pp
+open Topconstr
+open Indfun_common
+open Indfun
+open Genarg
+open Pcoq
+open Tacticals
+
+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)
+
+let pr_bindings prc prlc = function
+ | Rawterm.ImplicitBindings l ->
+ brk (1,1) ++ str "with" ++ brk (1,1) ++
+ Util.prlist_with_sep spc prc l
+ | Rawterm.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 ()
+
+let pr_with_bindings prc prlc (c,bl) =
+ prc c ++ hv 0 (pr_bindings prc prlc bl)
+
+let pr_fun_ind_using prc prlc _ opt_c =
+ match opt_c with
+ | None -> mt ()
+ | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc b)
+
+(* Duplication of printing functions because "'a with_bindings" is
+ (internally) not uniform in 'a: indeed constr_with_bindings at the
+ "typed" level has type "open_constr with_bindings" instead of
+ "constr with_bindings"; hence, its printer cannot be polymorphic in
+ (prc,prlc)... *)
+
+let pr_with_bindings_typed prc prlc (c,bl) =
+ prc c ++
+ hv 0 (pr_bindings prc prlc bl)
+
+let pr_fun_ind_using_typed prc prlc _ opt_c =
+ match opt_c with
+ | None -> mt ()
+ | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it)
+
+
+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
+ GLOB_TYPED AS constr_with_bindings_opt
+ GLOB_PRINTED BY pr_fun_ind_using
+| [ "using" constr_with_bindings(c) ] -> [ Some c ]
+| [ ] -> [ None ]
+END
+
+
+TACTIC EXTEND newfuninv
+ [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] ->
+ [
+ Invfun.invfun hyp fname
+ ]
+END
+
+
+let pr_intro_as_pat prc _ _ pat =
+ match pat with
+ | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat
+ | None -> mt ()
+
+
+ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat
+| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ]
+| [] ->[ None ]
+END
+
+
+
+
+TACTIC EXTEND newfunind
+ ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
+ [
+ let c = match cl with
+ | [] -> assert false
+ | [c] -> c
+ | c::cl -> applist(c,cl)
+ in
+ Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ]
+END
+(***** debug only ***)
+TACTIC EXTEND snewfunind
+ ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] ->
+ [
+ let c = match cl with
+ | [] -> assert false
+ | [c] -> c
+ | c::cl -> applist(c,cl)
+ in
+ Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ]
+END
+
+
+let pr_constr_coma_sequence prc _ _ = Util.prlist_with_sep Util.pr_comma prc
+
+ARGUMENT EXTEND constr_coma_sequence'
+ TYPED AS constr_list
+ PRINTED BY pr_constr_coma_sequence
+| [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ]
+| [ constr(c) ] -> [ [c] ]
+END
+
+let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc
+
+ARGUMENT EXTEND auto_using'
+ TYPED AS constr_list
+ PRINTED BY pr_auto_using
+| [ "using" constr_coma_sequence'(l) ] -> [ l ]
+| [ ] -> [ [] ]
+END
+
+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 ")"
+
+VERNAC ARGUMENT EXTEND binder2
+PRINTED BY pr_binder2
+ [ "(" ne_ident_list(idl) ":" lconstr(c) ")"] -> [ (idl,c) ]
+END
+
+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
+
+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)
+
+
+VERNAC COMMAND EXTEND Function
+ ["Function" ne_rec_definition2_list_sep(recsl,"with")] ->
+ [
+ do_generate_principle false (List.map make_rec_definitions2 recsl);
+
+ ]
+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
+
+VERNAC ARGUMENT EXTEND fun_scheme_arg
+PRINTED BY pr_fun_scheme_arg
+| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ]
+END
+
+
+let warning_error names e =
+ 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 ())
+ | 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 ())
+ | _ -> anomaly ""
+
+
+VERNAC COMMAND EXTEND NewFunctionalScheme
+ ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] ->
+ [
+ begin
+ try
+ Functional_principles_types.build_scheme fas
+ with Functional_principles_types.No_graph_found ->
+ begin
+ match fas with
+ | (_,fun_name,_)::_ ->
+ begin
+ begin
+ make_graph (Nametab.global fun_name)
+ end
+ ;
+ try Functional_principles_types.build_scheme fas
+ with Functional_principles_types.No_graph_found ->
+ Util.error ("Cannot generate induction principle(s)")
+ | e ->
+ let names = List.map (fun (_,na,_) -> na) fas in
+ warning_error names e
+
+ end
+ | _ -> assert false (* we can only have non empty list *)
+ end
+ | e ->
+ let names = List.map (fun (_,na,_) -> na) fas in
+ warning_error names e
+
+ end
+ ]
+END
+(***** debug only ***)
+
+VERNAC COMMAND EXTEND NewFunctionalCase
+ ["Functional" "Case" fun_scheme_arg(fas) ] ->
+ [
+ Functional_principles_types.build_case_scheme fas
+ ]
+END
+
+(***** debug only ***)
+VERNAC COMMAND EXTEND GenerateGraph
+["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ]
+END
+
+
+
+
+
+(* FINDUCTION *)
+
+(* comment this line to see debug msgs *)
+let msg x = () ;; let pr_lconstr c = str ""
+ (* uncomment this to see debugging *)
+let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n")
+let prlistconstr lc = List.iter prconstr lc
+let prstr s = msg(str s)
+let prNamedConstr s c =
+ begin
+ msg(str "");
+ msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n");
+ msg(str "");
+ end
+
+
+
+(** Information about an occurrence of a function call (application)
+ inside a term. *)
+type fapp_info = {
+ fname: constr; (** The function applied *)
+ largs: constr list; (** List of arguments *)
+ free: bool; (** [true] if all arguments are debruijn free *)
+ max_rel: int; (** max debruijn index in the funcall *)
+ onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *)
+}
+
+
+(** [constr_head_match(a b c) a] returns true, false otherwise. *)
+let constr_head_match u t=
+ if isApp u
+ then
+ let uhd,args= destApp u in
+ uhd=t
+ else false
+
+(** [hdMatchSub inu t] returns the list of occurrences of [t] in
+ [inu]. DeBruijn are not pushed, so some of them may be unbound in
+ the result. *)
+let rec hdMatchSub inu (test: constr -> bool) : fapp_info list =
+ let subres =
+ match kind_of_term inu with
+ | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) ->
+ hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test
+ | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *)
+ Array.fold_left
+ (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test)
+ [] bl
+ | _ -> (* Cofix will be wrong *)
+ fold_constr
+ (fun l cstr ->
+ l @ hdMatchSub cstr test) [] inu in
+ if not (test inu) then subres
+ else
+ let f,args = decompose_app inu in
+ let freeset = Termops.free_rels inu in
+ let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in
+ {fname = f; largs = args; free = Util.Intset.is_empty freeset;
+ max_rel = max_rel; onlyvars = List.for_all isVar args }
+ ::subres
+
+let mkEq typ c1 c2 =
+ mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|])
+
+
+let poseq_unsafe idunsafe cstr gl =
+ let typ = Tacmach.pf_type_of gl cstr in
+ tclTHEN
+ (Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl)
+ (tclTHENFIRST
+ (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr))
+ Tactics.reflexivity)
+ gl
+
+
+let poseq id cstr gl =
+ let x = Tactics.fresh_id [] id gl in
+ poseq_unsafe x cstr gl
+
+(* dirty? *)
+
+let list_constr_largs = ref []
+
+let rec poseq_list_ids_rec lcstr gl =
+ match lcstr with
+ | [] -> tclIDTAC gl
+ | c::lcstr' ->
+ match kind_of_term c with
+ | Var _ ->
+ (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl)
+ | _ ->
+ let _ = prstr "c = " in
+ let _ = prconstr c in
+ let _ = prstr "\n" in
+ let typ = Tacmach.pf_type_of gl c in
+ let cname = Namegen.id_of_name_using_hdchar (Global.env()) typ Anonymous in
+ let x = Tactics.fresh_id [] cname gl in
+ let _ = list_constr_largs:=mkVar x :: !list_constr_largs in
+ let _ = prstr " list_constr_largs = " in
+ let _ = prlistconstr !list_constr_largs in
+ let _ = prstr "\n" in
+
+ tclTHEN
+ (poseq_unsafe x c)
+ (poseq_list_ids_rec lcstr')
+ gl
+
+let poseq_list_ids lcstr gl =
+ let _ = list_constr_largs := [] in
+ poseq_list_ids_rec lcstr gl
+
+(** [find_fapp test g] returns the list of [app_info] of all calls to
+ functions that satisfy [test] in the conclusion of goal g. Trivial
+ repetition (not modulo conversion) are deleted. *)
+let find_fapp (test:constr -> bool) g : fapp_info list =
+ let pre_res = hdMatchSub (Tacmach.pf_concl g) test in
+ let res =
+ List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in
+ (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res);
+ res)
+
+
+
+(** [finduction id filter g] tries to apply functional induction on
+ an occurence of function [id] in the conclusion of goal [g]. If
+ [id]=[None] then calls to any function are selected. In any case
+ [heuristic] is used to select the most pertinent occurrence. *)
+let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list)
+ (nexttac:Proof_type.tactic) g =
+ let test = match oid with
+ | Some id ->
+ let idconstr = mkConst (const_of_id id) in
+ (fun u -> constr_head_match u idconstr) (* select only id *)
+ | None -> (fun u -> isApp u) in (* select calls to any function *)
+ let info_list = find_fapp test g in
+ let ordered_info_list = heuristic info_list in
+ prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list);
+ if List.length ordered_info_list = 0 then Util.error "function not found in goal\n";
+ let taclist: Proof_type.tactic list =
+ List.map
+ (fun info ->
+ (tclTHEN
+ (tclTHEN (poseq_list_ids info.largs)
+ (
+ fun gl ->
+ (functional_induction
+ true (applist (info.fname, List.rev !list_constr_largs))
+ None None) gl))
+ nexttac)) ordered_info_list in
+ (* we try each (f t u v) until one does not fail *)
+ (* TODO: try also to mix functional schemes *)
+ tclFIRST taclist g
+
+
+
+
+(** [chose_heuristic oi x] returns the heuristic for reordering
+ (and/or forgetting some elts of) a list of occurrences of
+ function calls infos to chose first with functional induction. *)
+let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list =
+ match oi with
+ | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *)
+ | None ->
+ (* Default heuristic: put first occurrences where all arguments
+ are *bound* (meaning already introduced) variables *)
+ let ordering x y =
+ if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *)
+ else if x.free && x.onlyvars then -1
+ else if y.free && y.onlyvars then 1
+ else 0 (* both not pertinent *)
+ in
+ List.sort ordering
+
+
+
+TACTIC EXTEND finduction
+ ["finduction" ident(id) natural_opt(oi)] ->
+ [
+ match oi with
+ | Some(n) when n<=0 -> Util.error "numerical argument must be > 0"
+ | _ ->
+ let heuristic = chose_heuristic oi in
+ finduction (Some id) heuristic tclIDTAC
+ ]
+END
+
+
+
+TACTIC EXTEND fauto
+ [ "fauto" tactic(tac)] ->
+ [
+ let heuristic = chose_heuristic None in
+ finduction None heuristic (snd tac)
+ ]
+ |
+ [ "fauto" ] ->
+ [
+ let heuristic = chose_heuristic None in
+ finduction None heuristic tclIDTAC
+ ]
+
+END
+
+
+TACTIC EXTEND poseq
+ [ "poseq" ident(x) constr(c) ] ->
+ [ poseq x c ]
+END
+
+VERNAC COMMAND EXTEND Showindinfo
+ [ "showindinfo" ident(x) ] -> [ Merge.showind x ]
+END
+
+VERNAC COMMAND EXTEND MergeFunind
+ [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")"
+ "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] ->
+ [
+ let f1 = Constrintern.interp_constr Evd.empty (Global.env())
+ (CRef (Libnames.Ident (Util.dummy_loc,id1))) in
+ let f2 = Constrintern.interp_constr Evd.empty (Global.env())
+ (CRef (Libnames.Ident (Util.dummy_loc,id2))) in
+ let f1type = Typing.type_of (Global.env()) Evd.empty f1 in
+ let f2type = Typing.type_of (Global.env()) Evd.empty f2 in
+ let ar1 = List.length (fst (decompose_prod f1type)) in
+ let ar2 = List.length (fst (decompose_prod f2type)) in
+ let _ =
+ if ar1 <> List.length cl1 then
+ Util.error ("not the right number of arguments for " ^ string_of_id id1) in
+ let _ =
+ if ar2 <> List.length cl2 then
+ Util.error ("not the right number of arguments for " ^ string_of_id id2) in
+ Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id
+ ]
+END
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
new file mode 100644
index 00000000..38f42844
--- /dev/null
+++ b/plugins/funind/indfun.ml
@@ -0,0 +1,776 @@
+open Util
+open Names
+open Term
+open Pp
+open Indfun_common
+open Libnames
+open Rawterm
+open Declarations
+
+let is_rec_info scheme_info =
+ let test_branche min acc (_,_,br) =
+ acc || (
+ let new_branche =
+ it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in
+ let free_rels_in_br = Termops.free_rels new_branche in
+ let max = min + scheme_info.Tactics.npredicates in
+ Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br
+ )
+ 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
+ fun g ->
+ let princ,bindings, princ_type =
+ match princl with
+ | None -> (* No principle is given let's find the good one *)
+ begin
+ match kind_of_term f with
+ | Const c' ->
+ let princ_option =
+ let finfo = (* we first try to find out a graph on f *)
+ try find_Function_infos c'
+ with Not_found ->
+ errorlabstrm "" (str "Cannot find induction information on "++
+ Printer.pr_lconstr (mkConst c') )
+ in
+ match Tacticals.elimination_sort_of_goal g with
+ | InProp -> finfo.prop_lemma
+ | InSet -> finfo.rec_lemma
+ | InType -> finfo.rect_lemma
+ in
+ let princ = (* then we get the principle *)
+ try mkConst (Option.get princ_option )
+ with Option.IsNone ->
+ (*i If there is not default lemma defined then,
+ we cross our finger and try to find a lemma named f_ind
+ (or f_rec, f_rect) i*)
+ let princ_name =
+ Indrec.make_elimination_ident
+ (id_of_label (con_label c'))
+ (Tacticals.elimination_sort_of_goal g)
+ in
+ try
+ mkConst(const_of_id princ_name )
+ with Not_found -> (* This one is neither defined ! *)
+ errorlabstrm "" (str "Cannot find induction principle for "
+ ++Printer.pr_lconstr (mkConst c') )
+ in
+ (princ,Rawterm.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
+ in
+ let princ_infos = Tactics.compute_elim_sig princ_type in
+ let args_as_induction_constr =
+ let c_list =
+ if princ_infos.Tactics.farg_in_concl
+ then [c] else []
+ in
+ List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list)
+ in
+ let princ' = Some (princ,bindings) in
+ let princ_vars =
+ List.fold_right
+ (fun a acc ->
+ try Idset.add (destVar a) acc
+ with _ -> acc
+ )
+ args
+ Idset.empty
+ in
+ let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in
+ let old_idl = Idset.diff old_idl princ_vars in
+ let subst_and_reduce g =
+ if with_clean
+ then
+ let idl =
+ map_succeed
+ (fun id ->
+ if Idset.mem id old_idl then failwith "subst_and_reduce";
+ id
+ )
+ (Tacmach.pf_ids_of_hyps g)
+ in
+ let flag =
+ Rawterm.Cbv
+ {Rawterm.all_flags
+ with Rawterm.rDelta = false;
+ }
+ in
+ Tacticals.tclTHEN
+ (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl )
+ (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl)
+ g
+ else Tacticals.tclIDTAC g
+
+ in
+ Tacticals.tclTHEN
+ (choose_dest_or_ind
+ princ_infos
+ args_as_induction_constr
+ princ'
+ (None,pat)
+ None)
+ subst_and_reduce
+ g
+ in
+ 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
+ | [] -> c
+ | Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr 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)
+
+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
+ and not as a constr
+*)
+let build_newrecursive
+(lnameargsardef) =
+ let env0 = Global.env()
+ and sigma = Evd.empty
+ in
+ let (rec_sign,rec_impls) =
+ List.fold_left
+ (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
+ let rec_impls = Constrintern.set_internalization_env_params rec_impls [] 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
+ interp_casted_constr_with_implicits
+ sigma rec_sign rec_impls def
+ )
+ lnameargsardef
+ with e ->
+ States.unfreeze fs; raise e in
+ States.unfreeze fs; def
+ in
+ recdef,rec_impls
+
+
+let compute_annot (name,annot,args,types,body) =
+ let names = List.map snd (Topconstr.names_of_local_assums args) in
+ match annot with
+ | None ->
+ if List.length names > 1 then
+ user_err_loc
+ (dummy_loc,"Function",
+ Pp.str "the recursive argument needs to be specified");
+ let new_annot = (id_of_name (List.hd names)) in
+ (name,Struct new_annot,args,types,body)
+ | Some r -> (name,r,args,types,body)
+
+
+(* 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) ->
+ (lookup names b) || (lookup names lhs) || (lookup names rhs)
+ | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b) ->
+ lookup names t || lookup (Nameops.name_fold Idset.remove na names) b
+ | RLetTuple(_,nal,_,t,b) -> lookup names t ||
+ lookup
+ (List.fold_left
+ (fun acc na -> Nameops.name_fold Idset.remove na acc)
+ names
+ nal
+ )
+ b
+ | RApp(_,f,args) -> List.exists (lookup names) (f::args)
+ | RCases(_,_,_,el,brl) ->
+ List.exists (fun (e,_) -> lookup names e) el ||
+ List.exists (lookup_br names) brl
+ and lookup_br names (_,idl,_,rt) =
+ let new_names = List.fold_right Idset.remove idl names in
+ lookup new_names rt
+ in
+ lookup names
+
+let rec local_binders_length = function
+ (* Assume that no `{ ... } contexts occur *)
+ | [] -> 0
+ | 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 n = local_binders_length args in
+(* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *)
+ let fun_args,rt' = chop_rlambda_n n rt in
+ (fun_args,rt')
+
+
+let derive_inversion fix_names =
+ try
+ (* we first transform the fix_names identifier into their corresponding constant *)
+ let fix_names_as_constant =
+ List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names
+ in
+ (*
+ Then we check that the graphs have been defined
+ If one of the graphs haven't been defined
+ we do nothing
+ *)
+ List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ;
+ try
+ Invfun.derive_correctness
+ Functional_principles_types.make_scheme
+ functional_induction
+ fix_names_as_constant
+ (*i The next call to mk_rel_id is valid since we have just construct the graph
+ Ensures by : register_built
+ i*)
+ (List.map
+ (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id)))
+ fix_names
+ )
+ with e ->
+ msg_warning
+ (str "Cannot built inversion information" ++
+ if do_observe () then Cerrors.explain_exn e else mt ())
+ with _ -> ()
+
+let warning_error names e =
+ 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 ()
+ in
+ match e with
+ | Building_graph e ->
+ Pp.msg_warning
+ (str "Cannot define graph(s) for " ++
+ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+ e_explain e)
+ | Defining_principle e ->
+ Pp.msg_warning
+ (str "Cannot define principle(s) for "++
+ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+ e_explain e)
+ | _ -> anomaly ""
+
+let error_error names e =
+ 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 ()
+ in
+ match e with
+ | Building_graph e ->
+ errorlabstrm ""
+ (str "Cannot define graph(s) for " ++
+ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
+ e_explain e)
+ | _ -> anomaly ""
+
+let generate_principle on_error
+ is_general do_built fix_rec_l recdefs interactive_proof
+ (continue_proof : int -> Names.constant array -> Term.constr array -> int ->
+ Tacmach.tactic) : unit =
+ let names = List.map (function ((_, name),_,_,_,_) -> name) fix_rec_l in
+ let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in
+ let funs_args = List.map fst fun_bodies in
+ let funs_types = List.map (function (_,_,_,types,_) -> types) fix_rec_l in
+ try
+ (* We then register the Inductive graphs of the functions *)
+ Rawterm_to_relation.build_inductive names funs_args funs_types recdefs;
+ if do_built
+ then
+ begin
+ (*i The next call to mk_rel_id is valid since we have just construct the graph
+ Ensures by : do_built
+ i*)
+ let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in
+ let ind_kn =
+ fst (locate_with_msg
+ (pr_reference f_R_mut++str ": Not an inductive type!")
+ locate_ind
+ f_R_mut)
+ in
+ let fname_kn (fname,_,_,_,_) =
+ let f_ref = Ident fname in
+ locate_with_msg
+ (pr_reference f_ref++str ": Not an inductive type!")
+ locate_constant
+ f_ref
+ in
+ let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in
+ let _ =
+ list_map_i
+ (fun i x ->
+ let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in
+ let princ_type = Typeops.type_of_constant (Global.env()) princ
+ in
+ Functional_principles_types.generate_functional_principle
+ interactive_proof
+ princ_type
+ None
+ None
+ funs_kn
+ i
+ (continue_proof 0 [|funs_kn.(i)|])
+ )
+ 0
+ fix_rec_l
+ in
+ Array.iter (add_Function is_general) funs_kn;
+ ()
+ end
+ with e ->
+ on_error names e
+
+let register_struct is_rec fixpoint_exprl =
+ match fixpoint_exprl with
+ | [((_,fname),_,bl,ret_type,body),_] when not is_rec ->
+ let ce,imps =
+ Command.interp_definition
+ (Flags.boxed_definitions ()) 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())
+
+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
+ (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic =
+ Functional_principles_proofs.prove_principle_for_gen
+ (f_ref,functional_ref,eq_ref)
+ tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation
+
+
+let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body
+ pre_hook
+ =
+ let type_of_f = Topconstr.prod_constr_expr ret_type args in
+ let rec_arg_num =
+ let names =
+ List.map
+ snd
+ (Topconstr.names_of_local_assums args)
+ in
+ match wf_arg with
+ | None ->
+ if List.length names = 1 then 1
+ else error "Recursive argument must be specified"
+ | Some wf_arg ->
+ list_index (Name wf_arg) names
+ in
+ let unbounded_eq =
+ let f_app_args =
+ Topconstr.CAppExpl
+ (dummy_loc,
+ (None,(Ident (dummy_loc,fname))) ,
+ (List.map
+ (function
+ | _,Anonymous -> assert false
+ | _,Name e -> (Topconstr.mkIdentC e)
+ )
+ (Topconstr.names_of_local_assums args)
+ )
+ )
+ in
+ Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))),
+ [(f_app_args,None);(body,None)])
+ in
+ let eq = Topconstr.prod_constr_expr unbounded_eq args in
+ let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type
+ nb_args relation =
+ try
+ pre_hook
+ (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes
+ functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
+ );
+ derive_inversion [fname]
+ with e ->
+ (* No proof done *)
+ ()
+ in
+ Recdef.recursive_definition
+ is_mes fname rec_impls
+ type_of_f
+ wf_rel_expr
+ rec_arg_num
+ eq
+ hook
+ using_lemmas
+
+
+let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body =
+ let wf_arg_type,wf_arg =
+ match wf_arg with
+ | None ->
+ begin
+ match args with
+ | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
+ | _ -> error "Recursive argument must be specified"
+ end
+ | Some wf_args ->
+ try
+ match
+ List.find
+ (function
+ | Topconstr.LocalRawAssum(l,k,t) ->
+ List.exists
+ (function (_,Name id) -> id = wf_args | _ -> false)
+ l
+ | _ -> false
+ )
+ args
+ with
+ | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args
+ | _ -> 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)
+ using_lemmas args ret_type body
+
+
+let do_generate_principle on_error register_built interactive_proof fixpoint_exprl =
+ let recdefs,rec_impls = build_newrecursive fixpoint_exprl in
+ let _is_struct =
+ match fixpoint_exprl with
+ | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] ->
+ let pre_hook =
+ generate_principle
+ on_error
+ true
+ register_built
+ fixpoint_exprl
+ recdefs
+ true
+ in
+ if register_built
+ then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook;
+ false
+ | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] ->
+ let pre_hook =
+ generate_principle
+ on_error
+ true
+ register_built
+ fixpoint_exprl
+ recdefs
+ true
+ in
+ if register_built
+ then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook;
+ true
+ | _ ->
+ let fix_names =
+ List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl
+ 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
+ (* 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;
+ in
+ ()
+
+open Topconstr
+let rec add_args id new_args b =
+ match b with
+ | CRef r ->
+ begin match r with
+ | Libnames.Ident(loc,fname) when fname = id ->
+ CAppExpl(dummy_loc,(None,r),new_args)
+ | _ -> b
+ end
+ | CFix _ | CCoFix _ -> anomaly "add_args : todo"
+ | CArrow(loc,b1,b2) ->
+ CArrow(loc,add_args id new_args b1, add_args id new_args b2)
+ | CProdN(loc,nal,b1) ->
+ CProdN(loc,
+ List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
+ add_args id new_args b1)
+ | CLambdaN(loc,nal,b1) ->
+ CLambdaN(loc,
+ List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal,
+ add_args id new_args b1)
+ | CLetIn(loc,na,b1,b2) ->
+ CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2)
+ | CAppExpl(loc,(pf,r),exprl) ->
+ begin
+ match r with
+ | Libnames.Ident(loc,fname) when fname = id ->
+ CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl))
+ | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl)
+ end
+ | CApp(loc,(pf,b),bl) ->
+ CApp(loc,(pf,add_args id new_args b),
+ List.map (fun (e,o) -> add_args id new_args e,o) bl)
+ | CCases(loc,sty,b_option,cel,cal) ->
+ CCases(loc,sty,Option.map (add_args id new_args) b_option,
+ List.map (fun (b,(na,b_option)) ->
+ add_args id new_args b,
+ (na,Option.map (add_args id new_args) b_option)) cel,
+ List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal
+ )
+ | CLetTuple(loc,nal,(na,b_option),b1,b2) ->
+ CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option),
+ add_args id new_args b1,
+ add_args id new_args b2
+ )
+
+ | CIf(loc,b1,(na,b_option),b2,b3) ->
+ CIf(loc,add_args id new_args b1,
+ (na,Option.map (add_args id new_args) b_option),
+ add_args id new_args b2,
+ add_args id new_args b3
+ )
+ | CHole _ -> b
+ | CPatVar _ -> b
+ | CEvar _ -> b
+ | CSort _ -> b
+ | CCast(loc,b1,CastConv(ck,b2)) ->
+ CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2))
+ | CCast(loc,b1,CastCoerce) ->
+ CCast(loc,add_args id new_args b1,CastCoerce)
+ | CRecord (loc, w, pars) ->
+ CRecord (loc,
+ (match w with Some w -> Some (add_args id new_args w) | _ -> None),
+ List.map (fun (e,o) -> e, add_args id new_args o) pars)
+ | CNotation _ -> anomaly "add_args : CNotation"
+ | CGeneralization _ -> anomaly "add_args : CGeneralization"
+ | CPrim _ -> b
+ | CDelimiters _ -> anomaly "add_args : CDelimiters"
+ | CDynamic _ -> anomaly "add_args : CDynamic"
+exception Stop of Topconstr.constr_expr
+
+
+(* [chop_n_arrow n t] chops the [n] first arrows in [t]
+ Acts on Topconstr.constr_expr
+*)
+let rec chop_n_arrow n t =
+ if n <= 0
+ then t (* If we have already removed all the arrows then return the type *)
+ else (* If not we check the form of [t] *)
+ match t with
+ | Topconstr.CArrow(_,_,t) -> (* If we have an arrow, we discard it and recall [chop_n_arrow] *)
+ chop_n_arrow (n-1) t
+ | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible :
+ either we need to discard more than the number of arrows contained
+ in this product declaration then we just recall [chop_n_arrow] on
+ the remaining number of arrow to chop and [t'] we discard it and
+ recall [chop_n_arrow], either this product contains more arrows
+ than the number we need to chop and then we return the new type
+ *)
+ begin
+ try
+ let new_n =
+ let rec aux (n:int) = function
+ [] -> n
+ | (nal,k,t'')::nal_ta' ->
+ let nal_l = List.length nal in
+ if n >= nal_l
+ then
+ aux (n - nal_l) nal_ta'
+ else
+ let new_t' =
+ Topconstr.CProdN(dummy_loc,
+ ((snd (list_chop n nal)),k,t'')::nal_ta',t')
+ in
+ raise (Stop new_t')
+ in
+ aux n nal_ta'
+ in
+ chop_n_arrow new_n t'
+ with Stop t -> t
+ end
+ | _ -> anomaly "Not enough products"
+
+
+let rec get_args b t : Topconstr.local_binder list *
+ Topconstr.constr_expr * Topconstr.constr_expr =
+ match b with
+ | Topconstr.CLambdaN (loc, (nal_ta), b') ->
+ begin
+ let n =
+ (List.fold_left (fun n (nal,_,_) ->
+ n+List.length nal) 0 nal_ta )
+ in
+ let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in
+ (List.map (fun (nal,k,ta) ->
+ (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
+ end
+ | _ -> [],b,t
+
+
+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") )
+
+ 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.continue ()
+
+
+(* let make_graph _ = assert false *)
+
+let do_generate_principle = do_generate_principle warning_error true
+
+
diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
new file mode 100644
index 00000000..0f048f59
--- /dev/null
+++ b/plugins/funind/indfun_common.ml
@@ -0,0 +1,558 @@
+open Names
+open Pp
+
+open Libnames
+
+let mk_prefix pre id = id_of_string (pre^(string_of_id id))
+let mk_rel_id = mk_prefix "R_"
+let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct"
+let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete"
+let mk_equation_id id = Nameops.add_suffix id "_equation"
+
+let msgnl m =
+ ()
+
+let invalid_argument s = raise (Invalid_argument s)
+
+
+let fresh_id avoid s = Namegen.next_ident_away_in_goal (id_of_string s) avoid
+
+let fresh_name avoid s = Name (fresh_id avoid s)
+
+let get_name avoid ?(default="H") = function
+ | Anonymous -> fresh_name avoid default
+ | Name n -> Name n
+
+let array_get_start a =
+ try
+ Array.init
+ (Array.length a - 1)
+ (fun i -> a.(i))
+ with Invalid_argument "index out of bounds" ->
+ invalid_argument "array_get_start"
+
+let id_of_name = function
+ Name id -> id
+ | _ -> raise Not_found
+
+let locate ref =
+ let (loc,qid) = qualid_of_reference ref in
+ Nametab.locate qid
+
+let locate_ind ref =
+ match locate ref with
+ | IndRef x -> x
+ | _ -> raise Not_found
+
+let locate_constant ref =
+ match locate ref with
+ | ConstRef x -> x
+ | _ -> raise Not_found
+
+
+let locate_with_msg msg f x =
+ try
+ f x
+ with
+ | Not_found -> raise (Util.UserError("", msg))
+ | e -> raise e
+
+
+let filter_map filter f =
+ let rec it = function
+ | [] -> []
+ | e::l ->
+ if filter e
+ then
+ (f e) :: it l
+ else it l
+ in
+ it
+
+
+let chop_rlambda_n =
+ let rec chop_lambda_n acc n rt =
+ if n == 0
+ 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
+ | _ ->
+ raise (Util.UserError("chop_rlambda_n",
+ str "chop_rlambda_n: Not enough Lambdas"))
+ in
+ chop_lambda_n []
+
+let chop_rprod_n =
+ let rec chop_prod_n acc n rt =
+ if n == 0
+ then List.rev acc,rt
+ else
+ match rt with
+ | Rawterm.RProd(_,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 []
+
+
+
+let list_union_eq eq_fun l1 l2 =
+ let rec urec = function
+ | [] -> l2
+ | a::l -> if List.exists (eq_fun a) l2 then urec l else a::urec l
+ in
+ urec l1
+
+let list_add_set_eq eq_fun x l =
+ if List.exists (eq_fun x) l then l else x::l
+
+
+
+
+let const_of_id id =
+ let _,princ_ref =
+ qualid_of_reference (Libnames.Ident (Util.dummy_loc,id))
+ in
+ try Nametab.locate_constant princ_ref
+ with Not_found -> Util.error ("cannot find "^ string_of_id id)
+
+let def_of_const t =
+ match (Term.kind_of_term t) with
+ Term.Const sp ->
+ (try (match (Global.lookup_constant sp) with
+ {Declarations.const_body=Some c} -> Declarations.force c
+ |_ -> assert false)
+ with _ -> assert false)
+ |_ -> assert false
+
+let coq_constant s =
+ Coqlib.gen_constant_in_modules "RecursiveDefinition"
+ Coqlib.init_modules s;;
+
+let constant sl s =
+ constr_of_global
+ (Nametab.locate (make_qualid(Names.make_dirpath
+ (List.map id_of_string (List.rev sl)))
+ (id_of_string s)));;
+
+let find_reference sl s =
+ (Nametab.locate (make_qualid(Names.make_dirpath
+ (List.map id_of_string (List.rev sl)))
+ (id_of_string s)));;
+
+let eq = lazy(coq_constant "eq")
+let refl_equal = lazy(coq_constant "eq_refl")
+
+(*****************************************************************)
+(* Copy of the standart save mechanism but without the much too *)
+(* slow reduction function *)
+(*****************************************************************)
+open Declarations
+open Entries
+open Decl_kinds
+open Declare
+let definition_message id =
+ Flags.if_verbose message ((string_of_id id) ^ " is defined")
+
+
+let save with_clean id const (locality,kind) hook =
+ let {const_entry_body = pft;
+ const_entry_type = tpo;
+ const_entry_opaque = opacity } = const in
+ let l,r = match locality with
+ | Local when Lib.sections_are_opened () ->
+ let k = logical_kind_of_goal_kind kind in
+ let c = SectionLocalDef (pft, tpo, opacity) in
+ let _ = declare_variable id (Lib.cwd(), c, k) in
+ (Local, VarRef id)
+ | Local ->
+ let k = logical_kind_of_goal_kind kind in
+ let kn = declare_constant id (DefinitionEntry const, k) in
+ (Global, ConstRef kn)
+ | Global ->
+ let k = logical_kind_of_goal_kind kind in
+ let kn = declare_constant id (DefinitionEntry const, k) in
+ (Global, ConstRef kn) in
+ if with_clean then Pfedit.delete_current_proof ();
+ hook l r;
+ definition_message id
+
+
+
+
+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 new_save_named opacity =
+ let id,(const,persistence,hook) = cook_proof true in
+ let const = { const with const_entry_opaque = opacity } in
+ save true id const persistence hook
+
+let get_proof_clean do_reduce =
+ let result = cook_proof do_reduce in
+ Pfedit.delete_current_proof ();
+ result
+
+let with_full_print f a =
+ let old_implicit_args = Impargs.is_implicit_args ()
+ and old_strict_implicit_args = Impargs.is_strict_implicit_args ()
+ and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
+ let old_rawprint = !Flags.raw_print in
+ Flags.raw_print := true;
+ Impargs.make_implicit_args false;
+ Impargs.make_strict_implicit_args false;
+ Impargs.make_contextual_implicit_args false;
+ Impargs.make_contextual_implicit_args false;
+ Dumpglob.pause ();
+ try
+ let res = f a in
+ Impargs.make_implicit_args old_implicit_args;
+ Impargs.make_strict_implicit_args old_strict_implicit_args;
+ Impargs.make_contextual_implicit_args old_contextual_implicit_args;
+ Flags.raw_print := old_rawprint;
+ Dumpglob.continue ();
+ res
+ with
+ | e ->
+ Impargs.make_implicit_args old_implicit_args;
+ Impargs.make_strict_implicit_args old_strict_implicit_args;
+ Impargs.make_contextual_implicit_args old_contextual_implicit_args;
+ Flags.raw_print := old_rawprint;
+ Dumpglob.continue ();
+ raise e
+
+
+
+
+
+
+(**********************)
+
+type function_info =
+ {
+ function_constant : constant;
+ graph_ind : inductive;
+ equation_lemma : constant option;
+ correctness_lemma : constant option;
+ completeness_lemma : constant option;
+ rect_lemma : constant option;
+ rec_lemma : constant option;
+ prop_lemma : constant option;
+ is_general : bool; (* Has this function been defined using general recursive definition *)
+ }
+
+
+(* type function_db = function_info list *)
+
+(* let function_table = ref ([] : function_db) *)
+
+
+let from_function = ref Cmap.empty
+let from_graph = ref Indmap.empty
+(*
+let rec do_cache_info finfo = function
+ | [] -> raise Not_found
+ | (finfo'::finfos as l) ->
+ if finfo' == finfo then l
+ else if finfo'.function_constant = finfo.function_constant
+ then finfo::finfos
+ else
+ let res = do_cache_info finfo finfos in
+ if res == finfos then l else finfo'::l
+
+
+let cache_Function (_,(finfos)) =
+ let new_tbl =
+ try do_cache_info finfos !function_table
+ with Not_found -> finfos::!function_table
+ in
+ if new_tbl != !function_table
+ then function_table := new_tbl
+*)
+
+let cache_Function (_,finfos) =
+ from_function := Cmap.add finfos.function_constant finfos !from_function;
+ from_graph := Indmap.add finfos.graph_ind finfos !from_graph
+
+
+let load_Function _ = cache_Function
+let open_Function _ = cache_Function
+let subst_Function (subst,finfos) =
+ let do_subst_con c = fst (Mod_subst.subst_con subst c)
+ and do_subst_ind (kn,i) = (Mod_subst.subst_ind subst kn,i)
+ in
+ let function_constant' = do_subst_con finfos.function_constant in
+ let graph_ind' = do_subst_ind finfos.graph_ind in
+ let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in
+ let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in
+ let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in
+ let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in
+ let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in
+ let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in
+ if function_constant' == finfos.function_constant &&
+ graph_ind' == finfos.graph_ind &&
+ equation_lemma' == finfos.equation_lemma &&
+ correctness_lemma' == finfos.correctness_lemma &&
+ completeness_lemma' == finfos.completeness_lemma &&
+ rect_lemma' == finfos.rect_lemma &&
+ rec_lemma' == finfos.rec_lemma &&
+ prop_lemma' == finfos.prop_lemma
+ then finfos
+ else
+ { function_constant = function_constant';
+ graph_ind = graph_ind';
+ equation_lemma = equation_lemma' ;
+ correctness_lemma = correctness_lemma' ;
+ completeness_lemma = completeness_lemma' ;
+ rect_lemma = rect_lemma' ;
+ rec_lemma = rec_lemma';
+ prop_lemma = prop_lemma';
+ is_general = finfos.is_general
+ }
+
+let classify_Function infos = Libobject.Substitute infos
+
+
+let discharge_Function (_,finfos) =
+ let function_constant' = Lib.discharge_con finfos.function_constant
+ and graph_ind' = Lib.discharge_inductive finfos.graph_ind
+ and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma
+ and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma
+ and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma
+ and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma
+ and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma
+ and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma
+ in
+ if function_constant' == finfos.function_constant &&
+ graph_ind' == finfos.graph_ind &&
+ equation_lemma' == finfos.equation_lemma &&
+ correctness_lemma' == finfos.correctness_lemma &&
+ completeness_lemma' == finfos.completeness_lemma &&
+ rect_lemma' == finfos.rect_lemma &&
+ rec_lemma' == finfos.rec_lemma &&
+ prop_lemma' == finfos.prop_lemma
+ then Some finfos
+ else
+ Some { function_constant = function_constant' ;
+ graph_ind = graph_ind' ;
+ equation_lemma = equation_lemma' ;
+ correctness_lemma = correctness_lemma' ;
+ completeness_lemma = completeness_lemma';
+ rect_lemma = rect_lemma';
+ rec_lemma = rec_lemma';
+ prop_lemma = prop_lemma' ;
+ is_general = finfos.is_general
+ }
+
+open Term
+let pr_info f_info =
+ str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++
+ str "function_constant_type := " ++
+ (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++
+ str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
+ str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
+ str "correctness_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++
+ str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
+ str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
+ str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++
+ str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl ()
+
+let pr_table 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 =
+ Libobject.declare_object
+ {(Libobject.default_object "FUNCTIONS_DB") with
+ Libobject.cache_function = cache_Function;
+ Libobject.load_function = load_Function;
+ Libobject.classify_function = classify_Function;
+ Libobject.subst_function = subst_Function;
+ Libobject.discharge_function = discharge_Function
+(* Libobject.open_function = open_Function; *)
+ }
+
+
+
+(* Synchronisation with reset *)
+let freeze () =
+ !from_function,!from_graph
+let unfreeze (functions,graphs) =
+(* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *)
+ from_function := functions;
+ from_graph := graphs
+
+let init () =
+(* Pp.msgnl (str "reseting function_table"); *)
+ from_function := Cmap.empty;
+ from_graph := Indmap.empty
+
+let _ =
+ Summary.declare_summary "functions_db_sum"
+ { Summary.freeze_function = freeze;
+ Summary.unfreeze_function = unfreeze;
+ Summary.init_function = init }
+
+let find_or_none id =
+ try Some
+ (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant"
+ )
+ with Not_found -> None
+
+
+
+let find_Function_infos f =
+ Cmap.find f !from_function
+
+
+let find_Function_of_graph ind =
+ Indmap.find ind !from_graph
+
+let update_Function finfo =
+(* Pp.msgnl (pr_info finfo); *)
+ Lib.add_anonymous_leaf (in_Function finfo)
+
+
+let add_Function is_general f =
+ let f_id = id_of_label (con_label f) in
+ let equation_lemma = find_or_none (mk_equation_id f_id)
+ and correctness_lemma = find_or_none (mk_correct_id f_id)
+ and completeness_lemma = find_or_none (mk_complete_id f_id)
+ and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect")
+ and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec")
+ and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
+ and graph_ind =
+ match Nametab.locate (qualid_of_ident (mk_rel_id f_id))
+ with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive"
+ in
+ let finfos =
+ { function_constant = f;
+ equation_lemma = equation_lemma;
+ completeness_lemma = completeness_lemma;
+ correctness_lemma = correctness_lemma;
+ rect_lemma = rect_lemma;
+ rec_lemma = rec_lemma;
+ prop_lemma = prop_lemma;
+ graph_ind = graph_ind;
+ is_general = is_general
+
+ }
+ in
+ update_Function finfos
+
+let pr_table () = pr_table !from_function
+(*********************************)
+(* Debuging *)
+let functional_induction_rewrite_dependent_proofs = ref true
+let function_debug = ref false
+open Goptions
+
+let functional_induction_rewrite_dependent_proofs_sig =
+ {
+ optsync = false;
+ optname = "Functional Induction Rewrite Dependent";
+ optkey = ["Functional";"Induction";"Rewrite";"Dependent"];
+ optread = (fun () -> !functional_induction_rewrite_dependent_proofs);
+ optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b)
+ }
+let _ = declare_bool_option functional_induction_rewrite_dependent_proofs_sig
+
+let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = true
+
+let function_debug_sig =
+ {
+ optsync = false;
+ optname = "Function debug";
+ optkey = ["Function_debug"];
+ optread = (fun () -> !function_debug);
+ optwrite = (fun b -> function_debug := b)
+ }
+
+let _ = declare_bool_option function_debug_sig
+
+
+let do_observe () =
+ !function_debug = true
+
+
+
+let strict_tcc = ref false
+let is_strict_tcc () = !strict_tcc
+let strict_tcc_sig =
+ {
+ optsync = false;
+ optname = "Raw Function Tcc";
+ optkey = ["Function_raw_tcc"];
+ optread = (fun () -> !strict_tcc);
+ optwrite = (fun b -> strict_tcc := b)
+ }
+
+let _ = declare_bool_option strict_tcc_sig
+
+
+exception Building_graph of exn
+exception Defining_principle of exn
+exception ToShow of exn
+
+let init_constant dir s =
+ try
+ Coqlib.gen_constant "Function" dir s
+ with e -> raise (ToShow e)
+
+let jmeq () =
+ try
+ (Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+ init_constant ["Logic";"JMeq"] "JMeq")
+ with e -> raise (ToShow e)
+
+let jmeq_rec () =
+ try
+ Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+ init_constant ["Logic";"JMeq"] "JMeq_rec"
+ with e -> raise (ToShow e)
+
+let jmeq_refl () =
+ try
+ Coqlib.check_required_library ["Coq";"Logic";"JMeq"];
+ init_constant ["Logic";"JMeq"] "JMeq_refl"
+ with e -> raise (ToShow e)
diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
new file mode 100644
index 00000000..6f6607fc
--- /dev/null
+++ b/plugins/funind/indfun_common.mli
@@ -0,0 +1,121 @@
+open Names
+open Pp
+
+(*
+ The mk_?_id function build different name w.r.t. a function
+ Each of their use is justified in the code
+*)
+val mk_rel_id : identifier -> identifier
+val mk_correct_id : identifier -> identifier
+val mk_complete_id : identifier -> identifier
+val mk_equation_id : identifier -> identifier
+
+
+val msgnl : std_ppcmds -> unit
+
+val invalid_argument : string -> 'a
+
+val fresh_id : identifier list -> string -> identifier
+val fresh_name : identifier list -> string -> name
+val get_name : identifier list -> ?default:string -> name -> name
+
+val array_get_start : 'a array -> 'a array
+
+val id_of_name : name -> identifier
+
+val locate_ind : Libnames.reference -> inductive
+val locate_constant : Libnames.reference -> constant
+val locate_with_msg :
+ Pp.std_ppcmds -> (Libnames.reference -> 'a) ->
+ Libnames.reference -> 'a
+
+val filter_map : ('a -> bool) -> ('a -> 'b) -> 'a list -> 'b list
+val list_union_eq :
+ ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list
+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_rprod_n : int -> Rawterm.rawconstr ->
+ (name*Rawterm.rawconstr) list * Rawterm.rawconstr
+
+val def_of_const : Term.constr -> Term.constr
+val eq : Term.constr Lazy.t
+val refl_equal : Term.constr Lazy.t
+val const_of_id: identifier -> constant
+val jmeq : unit -> Term.constr
+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 ->
+ Tacexpr.declaration_hook -> unit
+
+(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and
+ abort the proof
+*)
+val get_proof_clean : bool ->
+ Names.identifier *
+ (Entries.definition_entry * Decl_kinds.goal_kind *
+ Tacexpr.declaration_hook)
+
+
+
+(* [with_full_print f a] applies [f] to [a] in full printing environment
+
+ This function preserves the print settings
+*)
+val with_full_print : ('a -> 'b) -> 'a -> 'b
+
+
+(*****************)
+
+type function_info =
+ {
+ function_constant : constant;
+ graph_ind : inductive;
+ equation_lemma : constant option;
+ correctness_lemma : constant option;
+ completeness_lemma : constant option;
+ rect_lemma : constant option;
+ rec_lemma : constant option;
+ prop_lemma : constant option;
+ is_general : bool;
+ }
+
+val find_Function_infos : constant -> function_info
+val find_Function_of_graph : inductive -> function_info
+(* WARNING: To be used just after the graph definition !!! *)
+val add_Function : bool -> constant -> unit
+
+val update_Function : function_info -> unit
+
+
+(** debugging *)
+val pr_info : function_info -> Pp.std_ppcmds
+val pr_table : unit -> Pp.std_ppcmds
+
+
+(* val function_debug : bool ref *)
+val do_observe : unit -> bool
+val do_rewrite_dependent : unit -> bool
+
+(* To localize pb *)
+exception Building_graph of exn
+exception Defining_principle of exn
+exception ToShow of exn
+
+val is_strict_tcc : unit -> bool
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
new file mode 100644
index 00000000..8c22265d
--- /dev/null
+++ b/plugins/funind/invfun.ml
@@ -0,0 +1,1020 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+open Tacexpr
+open Declarations
+open Util
+open Names
+open Term
+open Pp
+open Libnames
+open Tacticals
+open Tactics
+open Indfun_common
+open Tacmach
+open Termops
+open Sign
+open Hiddentac
+
+(* Some pretty printing function for debugging purpose *)
+
+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)
+
+let pr_bindings prc prlc = function
+ | Rawterm.ImplicitBindings l ->
+ brk (1,1) ++ str "with" ++ brk (1,1) ++
+ Util.prlist_with_sep spc prc l
+ | Rawterm.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 ()
+
+
+let pr_with_bindings prc prlc (c,bl) =
+ prc c ++ hv 0 (pr_bindings prc prlc bl)
+
+
+
+let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds =
+ pr_with_bindings prc prc (c,bl)
+
+(* The local debuging mechanism *)
+let msgnl = Pp.msgnl
+
+let observe strm =
+ if do_observe ()
+ then Pp.msgnl strm
+ else ()
+
+let observennl strm =
+ if do_observe ()
+ then begin Pp.msg strm;Pp.pp_flush () end
+ else ()
+
+
+let do_observe_tac s tac g =
+ let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
+ try
+ let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
+ with e ->
+ msgnl (str "observation "++ s++str " raised exception " ++
+ Cerrors.explain_exn e ++ str " on goal " ++ goal );
+ raise e;;
+
+
+let observe_tac s tac g =
+ if do_observe ()
+ then do_observe_tac (str s) tac g
+ else tac g
+
+(* [nf_zeta] $\zeta$-normalization of a term *)
+let nf_zeta =
+ Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+ Environ.empty_env
+ Evd.empty
+
+
+(* [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
+ with Not_found ->
+ raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id))
+
+(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true]
+ (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block.
+
+ [generate_type true f i] returns
+ \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
+ graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion
+
+ [generate_type false f i] returns
+ \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res,
+ res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion
+ *)
+
+let generate_type g_to_f f graph i =
+ (*i we deduce the number of arguments of the function and its returned type from the graph i*)
+ let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in
+ let ctxt,_ = decompose_prod_assum graph_arity in
+ let fun_ctxt,res_type =
+ match ctxt with
+ | [] | [_] -> anomaly "Not a valid context"
+ | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
+ in
+ let nb_args = List.length fun_ctxt in
+ let args_from_decl i decl =
+ match decl with
+ | (_,Some _,_) -> incr i; failwith "args_from_decl"
+ | _ -> let j = !i in incr i;mkRel (nb_args - j + 1)
+ in
+ (*i We need to name the vars [res] and [fv] i*)
+ let res_id =
+ Namegen.next_ident_away_in_goal
+ (id_of_string "res")
+ (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt)
+ in
+ let fv_id =
+ Namegen.next_ident_away_in_goal
+ (id_of_string "fv")
+ (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt))
+ in
+ (*i we can then type the argument to be applied to the function [f] i*)
+ let args_as_rels =
+ let i = ref 0 in
+ Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt)))
+ in
+ let args_as_rels = Array.map Termops.pop args_as_rels in
+ (*i
+ the hypothesis [res = fv] can then be computed
+ We will need to lift it by one in order to use it as a conclusion
+ i*)
+ let res_eq_f_of_args =
+ mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|])
+ in
+ (*i
+ The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed
+ We will need to lift it by one in order to use it as a conclusion
+ i*)
+ let graph_applied =
+ let args_and_res_as_rels =
+ let i = ref 0 in
+ Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) )
+ in
+ let args_and_res_as_rels =
+ Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels
+ in
+ mkApp(graph,args_and_res_as_rels)
+ in
+ (*i The [pre_context] is the defined to be the context corresponding to
+ \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \]
+ i*)
+ let pre_ctxt =
+ (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt
+ in
+ (*i and we can return the solution depending on which lemma type we are defining i*)
+ if g_to_f
+ then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args)
+ else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied)
+
+
+(*
+ [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect]
+
+ WARNING: while convertible, [type_of body] and [type] can be non equal
+*)
+let find_induction_principle f =
+ let f_as_constant = match kind_of_term f with
+ | Const c' -> c'
+ | _ -> error "Must be used with a function"
+ in
+ let infos = find_Function_infos f_as_constant in
+ match infos.rect_lemma with
+ | None -> raise Not_found
+ | Some rect_lemma ->
+ let rect_lemma = mkConst rect_lemma in
+ let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in
+ rect_lemma,typ
+
+
+
+(* let fname = *)
+(* match kind_of_term f with *)
+(* | Const c' -> *)
+(* id_of_label (con_label c') *)
+(* | _ -> error "Must be used with a function" *)
+(* in *)
+
+(* let princ_name = *)
+(* ( *)
+(* Indrec.make_elimination_ident *)
+(* fname *)
+(* InType *)
+(* ) *)
+(* in *)
+(* let c = (\* mkConst(mk_from_const (destConst f) princ_name ) in *\) failwith "" in *)
+(* c,Typing.type_of (Global.env ()) Evd.empty c *)
+
+
+let rec generate_fresh_id x avoid i =
+ if i == 0
+ then []
+ else
+ let id = Namegen.next_ident_away_in_goal x avoid in
+ id::(generate_fresh_id x (id::avoid) (pred i))
+
+
+(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ]
+ is the tactic used to prove correctness lemma.
+
+ [functional_induction] is the tactic defined in [indfun] (dependency problem)
+ [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions
+ (resp. graphs of the functions and principles and correctness lemma types) to prove correct.
+
+ [i] is the indice of the function to prove correct
+
+ The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
+ it looks like~:
+ [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
+ res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res]
+
+
+ The sketch of the proof is the following one~:
+ \begin{enumerate}
+ \item intros until $x_n$
+ \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i)
+ \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the
+ apply the corresponding constructor of the corresponding graph inductive.
+ \end{enumerate}
+
+*)
+let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic =
+ fun g ->
+ (* first of all we recreate the lemmas types to be used as predicates of the induction principle
+ that is~:
+ \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\]
+ *)
+ let lemmas =
+ Array.map
+ (fun (_,(ctxt,concl)) ->
+ match ctxt with
+ | [] | [_] | [_;_] -> anomaly "bad context"
+ | hres::res::(x,_,t)::ctxt ->
+ Termops.it_mkLambda_or_LetIn
+ ~init:(Termops.it_mkProd_or_LetIn ~init:concl [hres;res])
+ ((x,None,t)::ctxt)
+ )
+ lemmas_types_infos
+ in
+ (* we the get the definition of the graphs block *)
+ let graph_ind = destInd graphs_constr.(i) in
+ let kn = fst graph_ind in
+ let mib,_ = Global.lookup_inductive graph_ind in
+ (* and the principle to use in this lemma in $\zeta$ normal form *)
+ let f_principle,princ_type = schemes.(i) in
+ let princ_type = nf_zeta princ_type in
+ let princ_infos = Tactics.compute_elim_sig princ_type in
+ (* The number of args of the function is then easilly computable *)
+ let nb_fun_args = nb_prod (pf_concl g) - 2 in
+ let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
+ let ids = args_names@(pf_ids_of_hyps g) in
+ (* Since we cannot ensure that the funcitonnal principle is defined in the
+ environement and due to the bug #1174, we will need to pose the principle
+ using a name
+ *)
+ let principle_id = Namegen.next_ident_away_in_goal (id_of_string "princ") ids in
+ let ids = principle_id :: ids in
+ (* We get the branches of the principle *)
+ let branches = List.rev princ_infos.branches in
+ (* and built the intro pattern for each of them *)
+ let intro_pats =
+ List.map
+ (fun (_,_,br_type) ->
+ List.map
+ (fun id -> dummy_loc, Genarg.IntroIdentifier id)
+ (generate_fresh_id (id_of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
+ )
+ branches
+ in
+ (* before building the full intro pattern for the principle *)
+ let pat = Some (dummy_loc,Genarg.IntroOrAndPattern intro_pats) in
+ let eq_ind = Coqlib.build_coq_eq () in
+ let eq_construct = mkConstruct((destInd eq_ind),1) in
+ (* The next to referencies will be used to find out which constructor to apply in each branch *)
+ let ind_number = ref 0
+ and min_constr_number = ref 0 in
+ (* The tactic to prove the ith branch of the principle *)
+ let prove_branche i g =
+ (* We get the identifiers of this branch *)
+ let this_branche_ids =
+ List.fold_right
+ (fun (_,pat) acc ->
+ match pat with
+ | Genarg.IntroIdentifier id -> Idset.add id acc
+ | _ -> anomaly "Not an identifier"
+ )
+ (List.nth intro_pats (pred i))
+ Idset.empty
+ in
+ (* and get the real args of the branch by unfolding the defined constant *)
+ let pre_args,pre_tac =
+ List.fold_right
+ (fun (id,b,t) (pre_args,pre_tac) ->
+ if Idset.mem id this_branche_ids
+ then
+ match b with
+ | None -> (id::pre_args,pre_tac)
+ | Some b ->
+ (pre_args,
+ tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
+ )
+
+ else (pre_args,pre_tac)
+ )
+ (pf_hyps g)
+ ([],tclIDTAC)
+ in
+ (*
+ We can then recompute the arguments of the constructor.
+ For each [hid] introduced by this branch, if [hid] has type
+ $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are
+ [ fv (hid fv (refl_equal fv)) ].
+
+ If [hid] has another type the corresponding argument of the constructor is [hid]
+ *)
+ let constructor_args =
+ List.fold_right
+ (fun hid acc ->
+ let type_of_hid = pf_type_of g (mkVar hid) in
+ match kind_of_term type_of_hid with
+ | Prod(_,_,t') ->
+ begin
+ match kind_of_term t' with
+ | Prod(_,t'',t''') ->
+ begin
+ match kind_of_term t'',kind_of_term t''' with
+ | App(eq,args), App(graph',_)
+ when
+ (eq_constr eq eq_ind) &&
+ array_exists (eq_constr graph') graphs_constr ->
+ ((mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|]))
+ ::args.(2)::acc)
+ | _ -> mkVar hid :: acc
+ end
+ | _ -> mkVar hid :: acc
+ end
+ | _ -> mkVar hid :: acc
+ ) pre_args []
+ in
+ (* in fact we must also add the parameters to the constructor args *)
+ let constructor_args =
+ let params_id = fst (list_chop princ_infos.nparams args_names) in
+ (List.map mkVar params_id)@(List.rev constructor_args)
+ in
+ (* We then get the constructor corresponding to this branch and
+ modifies the references has needed i.e.
+ if the constructor is the last one of the current inductive then
+ add one the number of the inductive to take and add the number of constructor of the previous
+ graph to the minimal constructor number
+ *)
+ let constructor =
+ let constructor_num = i - !min_constr_number in
+ let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in
+ if constructor_num <= length
+ then
+ begin
+ (kn,!ind_number),constructor_num
+ end
+ else
+ begin
+ incr ind_number;
+ min_constr_number := !min_constr_number + length ;
+ (kn,!ind_number),1
+ end
+ in
+ (* we can then build the final proof term *)
+ let app_constructor = applist((mkConstruct(constructor)),constructor_args) in
+ (* an apply the tactic *)
+ let res,hres =
+ match generate_fresh_id (id_of_string "z") (ids(* @this_branche_ids *)) 2 with
+ | [res;hres] -> res,hres
+ | _ -> assert false
+ in
+ observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor);
+ (
+ tclTHENSEQ
+ [
+ (* unfolding of all the defined variables introduced by this branch *)
+ observe_tac "unfolding" pre_tac;
+ (* $zeta$ normalizing of the conclusion *)
+ h_reduce
+ (Rawterm.Cbv
+ { Rawterm.all_flags with
+ Rawterm.rDelta = false ;
+ Rawterm.rConst = []
+ }
+ )
+ onConcl;
+ (* introducing the the result of the graph and the equality hypothesis *)
+ observe_tac "introducing" (tclMAP h_intro [res;hres]);
+ (* replacing [res] with its value *)
+ observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres));
+ (* Conclusion *)
+ observe_tac "exact" (h_exact app_constructor)
+ ]
+ )
+ g
+ in
+ (* end of branche proof *)
+ let param_names = fst (list_chop princ_infos.nparams args_names) in
+ let params = List.map mkVar param_names in
+ let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in
+ (* The bindings of the principle
+ that is the params of the principle and the different lemma types
+ *)
+ let bindings =
+ let params_bindings,avoid =
+ 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
+ )
+ ([],pf_ids_of_hyps g)
+ princ_infos.params
+ (List.rev params)
+ in
+ let lemmas_bindings =
+ List.rev (fst (List.fold_left2
+ (fun (bindings,avoid) (x,_,_) p ->
+ let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+ (dummy_loc,Rawterm.NamedHyp id,(nf_zeta p))::bindings,id::avoid)
+ ([],avoid)
+ princ_infos.predicates
+ (lemmas)))
+ in
+ Rawterm.ExplicitBindings (params_bindings@lemmas_bindings)
+ in
+ tclTHENSEQ
+ [ observe_tac "intro args_names" (tclMAP h_intro args_names);
+ observe_tac "principle" (assert_by
+ (Name principle_id)
+ princ_type
+ (h_exact f_principle));
+ tclTHEN_i
+ (observe_tac "functional_induction" (
+ fun g ->
+ observe
+ (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings));
+ functional_induction false (applist(funs_constr.(i),List.map mkVar args_names))
+ (Some (mkVar principle_id,bindings))
+ pat g
+ ))
+ (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g )
+ ]
+ g
+
+(* [generalize_dependent_of x hyp g]
+ generalize every hypothesis which depends of [x] but [hyp]
+*)
+let generalize_dependent_of x hyp g =
+ tclMAP
+ (function
+ | (id,None,t) when not (id = hyp) &&
+ (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id])
+ | _ -> tclIDTAC
+ )
+ (pf_hyps g)
+ g
+
+
+
+
+
+ (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis
+ (unfolding, substituting, destructing cases \ldots)
+ *)
+let rec intros_with_rewrite g =
+ observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
+and intros_with_rewrite_aux : tactic =
+ fun g ->
+ let eq_ind = Coqlib.build_coq_eq () in
+ match kind_of_term (pf_concl g) with
+ | Prod(_,t,t') ->
+ begin
+ match kind_of_term t with
+ | App(eq,args) when (eq_constr eq eq_ind) ->
+ if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2)
+ then
+ let id = pf_get_new_id (id_of_string "y") g in
+ tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g
+
+ else if isVar args.(1)
+ then
+ let id = pf_get_new_id (id_of_string "y") g in
+ tclTHENSEQ [ h_intro id;
+ generalize_dependent_of (destVar args.(1)) id;
+ tclTRY (Equality.rewriteLR (mkVar id));
+ intros_with_rewrite
+ ]
+ g
+ else
+ begin
+ let id = pf_get_new_id (id_of_string "y") g in
+ tclTHENSEQ[
+ h_intro id;
+ tclTRY (Equality.rewriteLR (mkVar id));
+ intros_with_rewrite
+ ] g
+ end
+ | Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
+ Tauto.tauto g
+ | Case(_,_,v,_) ->
+ tclTHENSEQ[
+ h_case false (v,Rawterm.NoBindings);
+ intros_with_rewrite
+ ] g
+ | LetIn _ ->
+ tclTHENSEQ[
+ h_reduce
+ (Rawterm.Cbv
+ {Rawterm.all_flags
+ with Rawterm.rDelta = false;
+ })
+ onConcl
+ ;
+ intros_with_rewrite
+ ] g
+ | _ ->
+ let id = pf_get_new_id (id_of_string "y") g in
+ tclTHENSEQ [ h_intro id;intros_with_rewrite] g
+ end
+ | LetIn _ ->
+ tclTHENSEQ[
+ h_reduce
+ (Rawterm.Cbv
+ {Rawterm.all_flags
+ with Rawterm.rDelta = false;
+ })
+ onConcl
+ ;
+ intros_with_rewrite
+ ] g
+ | _ -> tclIDTAC g
+
+let rec reflexivity_with_destruct_cases g =
+ let destruct_case () =
+ try
+ match kind_of_term (snd (destApp (pf_concl g))).(2) with
+ | Case(_,_,v,_) ->
+ tclTHENSEQ[
+ h_case false (v,Rawterm.NoBindings);
+ intros;
+ observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
+ ]
+ | _ -> reflexivity
+ with _ -> reflexivity
+ in
+ let eq_ind = Coqlib.build_coq_eq () in
+ let discr_inject =
+ Tacticals.onAllHypsAndConcl (
+ fun sc g ->
+ match sc with
+ None -> tclIDTAC g
+ | Some id ->
+ match kind_of_term (pf_type_of g (mkVar id)) with
+ | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind ->
+ if Equality.discriminable (pf_env g) (project g) t1 t2
+ then Equality.discrHyp id g
+ else if Equality.injectable (pf_env g) (project g) t1 t2
+ then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g
+ else tclIDTAC g
+ | _ -> tclIDTAC g
+ )
+ in
+ (tclFIRST
+ [ reflexivity;
+ tclTHEN (tclPROGRESS discr_inject) (destruct_case ());
+ (* We reach this point ONLY if
+ the same value is matched (at least) two times
+ along binding path.
+ In this case, either we have a discriminable hypothesis and we are done,
+ either at least an injectable one and we do the injection before continuing
+ *)
+ tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases
+ ])
+ g
+
+
+(* [prove_fun_complete funs graphs schemes lemmas_types_infos i]
+ is the tactic used to prove completness lemma.
+
+ [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions
+ (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct.
+
+ [i] is the indice of the function to prove complete
+
+ The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is
+ it looks like~:
+ [\forall (x_1:t_1)\ldots(x_n:t_n), forall res,
+ graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in]
+
+
+ The sketch of the proof is the following one~:
+ \begin{enumerate}
+ \item intros until $H:graph\ x_1\ldots x_n\ res$
+ \item $elim\ H$ using schemes.(i)
+ \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has
+ type [x=?] with [x] a variable, then subst [x],
+ if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else
+ if [h] is a match then destruct it, else do just introduce it,
+ after all intros, the conclusion should be a reflexive equality.
+ \end{enumerate}
+
+*)
+
+
+let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
+ fun g ->
+ (* We compute the types of the different mutually recursive lemmas
+ in $\zeta$ normal form
+ *)
+ let lemmas =
+ Array.map
+ (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt))
+ lemmas_types_infos
+ in
+ (* We get the constant and the principle corresponding to this lemma *)
+ let f = funcs.(i) in
+ let graph_principle = nf_zeta schemes.(i) in
+ let princ_type = pf_type_of g graph_principle in
+ let princ_infos = Tactics.compute_elim_sig princ_type in
+ (* Then we get the number of argument of the function
+ and compute a fresh name for each of them
+ *)
+ let nb_fun_args = nb_prod (pf_concl g) - 2 in
+ let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in
+ let ids = args_names@(pf_ids_of_hyps g) in
+ (* and fresh names for res H and the principle (cf bug bug #1174) *)
+ let res,hres,graph_principle_id =
+ match generate_fresh_id (id_of_string "z") ids 3 with
+ | [res;hres;graph_principle_id] -> res,hres,graph_principle_id
+ | _ -> assert false
+ in
+ let ids = res::hres::graph_principle_id::ids in
+ (* we also compute fresh names for each hyptohesis of each branche of the principle *)
+ let branches = List.rev princ_infos.branches in
+ let intro_pats =
+ List.map
+ (fun (_,_,br_type) ->
+ List.map
+ (fun id -> id)
+ (generate_fresh_id (id_of_string "y") ids (nb_prod br_type))
+ )
+ branches
+ in
+ (* We will need to change the function by its body
+ using [f_equation] if it is recursive (that is the graph is infinite
+ or unfold if the graph is finite
+ *)
+ let rewrite_tac j ids : tactic =
+ let graph_def = graphs.(j) in
+ let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in
+ if infos.is_general || Rtree.is_infinite graph_def.mind_recargs
+ then
+ let eq_lemma =
+ try Option.get (infos).equation_lemma
+ with Option.IsNone -> anomaly "Cannot find equation lemma"
+ in
+ tclTHENSEQ[
+ tclMAP h_intro ids;
+ 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;
+ })
+ onConcl
+ ;
+ h_generalize (List.map mkVar ids);
+ thin ids
+ ]
+ else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))]
+ in
+ (* The proof of each branche itself *)
+ let ind_number = ref 0 in
+ let min_constr_number = ref 0 in
+ let prove_branche i g =
+ (* we fist compute the inductive corresponding to the branch *)
+ let this_ind_number =
+ let constructor_num = i - !min_constr_number in
+ let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in
+ if constructor_num <= length
+ then !ind_number
+ else
+ begin
+ incr ind_number;
+ min_constr_number := !min_constr_number + length;
+ !ind_number
+ end
+ in
+ let this_branche_ids = List.nth intro_pats (pred i) in
+ tclTHENSEQ[
+ (* we expand the definition of the function *)
+ observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
+ (* introduce hypothesis with some rewrite *)
+ observe_tac "intros_with_rewrite" intros_with_rewrite;
+ (* The proof is (almost) complete *)
+ observe_tac "reflexivity" (reflexivity_with_destruct_cases)
+ ]
+ g
+ in
+ let params_names = fst (list_chop princ_infos.nparams args_names) in
+ let params = List.map mkVar params_names in
+ tclTHENSEQ
+ [ tclMAP h_intro (args_names@[res;hres]);
+ observe_tac "h_generalize"
+ (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)))))
+ (fun i g -> observe_tac "prove_branche" (prove_branche i) g ))
+ ]
+ g
+
+
+
+
+let do_save () = Lemmas.save_named false
+
+
+(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness
+ lemmas for each function in [funs] w.r.t. [graphs]
+
+ [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and
+ [functional_induction] is Indfun.functional_induction (same pb)
+*)
+
+let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) =
+ let funs = Array.of_list funs and graphs = Array.of_list graphs in
+ let funs_constr = Array.map mkConst funs in
+ try
+ let graphs_constr = Array.map mkInd graphs in
+ let lemmas_types_infos =
+ Util.array_map2_i
+ (fun i f_constr graph ->
+ let const_of_f = destConst f_constr in
+ 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 = nf_zeta type_of_lemma in
+ observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
+ type_of_lemma,type_info
+ )
+ funs_constr
+ graphs_constr
+ in
+ let schemes =
+ (* The functional induction schemes are computed and not saved if there is more that one function
+ if the block contains only one function we can safely reuse [f_rect]
+ *)
+ try
+ if Array.length funs_constr <> 1 then raise Not_found;
+ [| find_induction_principle funs_constr.(0) |]
+ with Not_found ->
+ Array.of_list
+ (List.map
+ (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))
+ )
+ in
+ let proving_tac =
+ prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos
+ in
+ Array.iteri
+ (fun i f_as_constant ->
+ let f_id = id_of_label (con_label f_as_constant) in
+ Lemmas.start_proof
+ (*i The next call to mk_correct_id is valid since we are constructing the lemma
+ Ensures by: obvious
+ i*)
+ (mk_correct_id f_id)
+ (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
+ (fst lemmas_types_infos.(i))
+ (fun _ _ -> ());
+ Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i));
+ do_save ();
+ let finfo = find_Function_infos f_as_constant in
+ update_Function
+ {finfo with
+ correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id)))
+ }
+
+ )
+ funs;
+ let lemmas_types_infos =
+ Util.array_map2_i
+ (fun i f_constr graph ->
+ let const_of_f = destConst f_constr in
+ 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 = nf_zeta type_of_lemma in
+ observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma);
+ type_of_lemma,type_info
+ )
+ funs_constr
+ graphs_constr
+ in
+ let kn,_ as graph_ind = destInd graphs_constr.(0) in
+ let mib,mip = Global.lookup_inductive graph_ind in
+ let schemes =
+ Array.of_list
+ (Indrec.build_mutual_induction_scheme (Global.env ()) Evd.empty
+ (Array.to_list
+ (Array.mapi
+ (fun i _ -> (kn,i),true,InType)
+ mib.Declarations.mind_packets
+ )
+ )
+ )
+ in
+ let proving_tac =
+ prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos
+ in
+ Array.iteri
+ (fun i f_as_constant ->
+ let f_id = id_of_label (con_label f_as_constant) in
+ Lemmas.start_proof
+ (*i The next call to mk_complete_id is valid since we are constructing the lemma
+ Ensures by: obvious
+ i*)
+ (mk_complete_id f_id)
+ (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem))
+ (fst lemmas_types_infos.(i))
+ (fun _ _ -> ());
+ Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i));
+ do_save ();
+ let finfo = find_Function_infos f_as_constant in
+ update_Function
+ {finfo with
+ completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id)))
+ }
+ )
+ funs;
+ with e ->
+ (* In case of problem, we reset all the lemmas *)
+ (*i The next call to mk_correct_id is valid since we are erasing the lemmas
+ Ensures by: obvious
+ i*)
+ let first_lemma_id =
+ let f_id = id_of_label (con_label funs.(0)) in
+
+ mk_correct_id f_id
+ in
+ ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ());
+ raise e
+
+
+
+
+
+(***********************************************)
+
+(* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res
+ when [kn] denotes a graph block into
+ f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result
+
+ if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing
+*)
+let revert_graph kn post_tac hid g =
+ let typ = pf_type_of g (mkVar hid) in
+ match kind_of_term typ with
+ | App(i,args) when isInd i ->
+ let ((kn',num) as ind') = destInd i in
+ if kn = kn'
+ then (* We have generated a graph hypothesis so that we must change it if we can *)
+ let info =
+ try find_Function_of_graph ind'
+ with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*)
+ anomaly "Cannot retrieve infos about a mutual block"
+ in
+ (* if we can find a completeness lemma for this function
+ then we can come back to the functional form. If not, we do nothing
+ *)
+ match info.completeness_lemma with
+ | None -> tclIDTAC g
+ | Some f_complete ->
+ let f_args,res = array_chop (Array.length args - 1) args in
+ tclTHENSEQ
+ [
+ h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
+ thin [hid];
+ h_intro hid;
+ post_tac hid
+ ]
+ g
+
+ else tclIDTAC g
+ | _ -> tclIDTAC g
+
+
+(*
+ [functional_inversion hid fconst f_correct ] is the functional version of [inversion]
+
+ [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct]
+ is the correctness lemma for [fconst].
+
+ The sketch is the follwing~:
+ \begin{enumerate}
+ \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$
+ (fails if it is not possible)
+ \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct]
+ \item apply [inversion] on [hid]
+ \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever
+ such a lemma exists)
+ \end{enumerate}
+*)
+
+let functional_inversion kn hid fconst f_correct : tactic =
+ fun g ->
+ let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in
+ let type_of_h = pf_type_of g (mkVar hid) in
+ match kind_of_term type_of_h with
+ | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
+ let pre_tac,f_args,res =
+ match kind_of_term args.(1),kind_of_term args.(2) with
+ | App(f,f_args),_ when eq_constr f fconst ->
+ ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2))
+ |_,App(f,f_args) when eq_constr f fconst ->
+ ((fun hid -> tclIDTAC),f_args,args.(1))
+ | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2)
+ in
+ tclTHENSEQ[
+ pre_tac hid;
+ 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);
+ (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
+ );
+ ] g
+ | _ -> tclFAIL 1 (mt ()) g
+
+
+
+let invfun qhyp f =
+ let f =
+ match f with
+ | ConstRef f -> f
+ | _ -> raise (Util.UserError("",str "Not a function"))
+ in
+ try
+ let finfos = find_Function_infos f in
+ let f_correct = mkConst(Option.get finfos.correctness_lemma)
+ and kn = fst finfos.graph_ind
+ in
+ Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp
+ with
+ | Not_found -> error "No graph found"
+ | Option.IsNone -> error "Cannot use equivalence with graph!"
+
+
+let invfun qhyp f g =
+ match f with
+ | Some f -> invfun qhyp f g
+ | None ->
+ Tactics.try_intros_until
+ (fun hid g ->
+ let hyp_typ = pf_type_of g (mkVar hid) in
+ match kind_of_term hyp_typ with
+ | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) ->
+ begin
+ let f1,_ = decompose_app args.(1) in
+ try
+ if not (isConst f1) then failwith "";
+ let finfos = find_Function_infos (destConst f1) in
+ let f_correct = mkConst(Option.get finfos.correctness_lemma)
+ and kn = fst finfos.graph_ind
+ in
+ functional_inversion kn hid f1 f_correct g
+ with | Failure "" | Option.IsNone | Not_found ->
+ try
+ let f2,_ = decompose_app args.(2) in
+ if not (isConst f2) then failwith "";
+ let finfos = find_Function_infos (destConst f2) in
+ let f_correct = mkConst(Option.get finfos.correctness_lemma)
+ and kn = fst finfos.graph_ind
+ in
+ functional_inversion kn hid f2 f_correct g
+ with
+ | Failure "" ->
+ errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function")
+ | Option.IsNone ->
+ if do_observe ()
+ then
+ error "Cannot use equivalence with graph for any side of the equality"
+ else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
+ | Not_found ->
+ if do_observe ()
+ then
+ error "No graph found for any side of equality"
+ else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid)
+ end
+ | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ")
+ )
+ qhyp
+ g
diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml
new file mode 100644
index 00000000..f596e2d7
--- /dev/null
+++ b/plugins/funind/merge.ml
@@ -0,0 +1,1032 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Merging of induction principles. *)
+
+(*i $Id: i*)
+open Libnames
+open Tactics
+open Indfun_common
+open Util
+open Topconstr
+open Vernacexpr
+open Pp
+open Names
+open Term
+open Termops
+open Declarations
+open Environ
+open Rawterm
+open Rawtermops
+
+(** {1 Utilities} *)
+
+(** {2 Useful operations on constr and rawconstr} *)
+
+let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
+
+(** Substitutions in constr *)
+let compare_constr_nosub t1 t2 =
+ if compare_constr (fun _ _ -> false) t1 t2
+ then true
+ else false
+
+let rec compare_constr' t1 t2 =
+ if compare_constr_nosub t1 t2
+ then true
+ else (compare_constr (compare_constr') t1 t2)
+
+let rec substitterm prof t by_t in_u =
+ if (compare_constr' (lift prof t) in_u)
+ then (lift prof by_t)
+ else map_constr_with_binders succ
+ (fun i -> substitterm i t by_t) prof in_u
+
+let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl
+
+let understand = Pretyping.Default.understand Evd.empty (Global.env())
+
+(** Operations on names and identifiers *)
+let id_of_name = function
+ Anonymous -> id_of_string "H"
+ | Name id -> id;;
+let name_of_string str = Name (id_of_string str)
+let string_of_name nme = string_of_id (id_of_name nme)
+
+(** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *)
+let isVarf f x =
+ match x with
+ | RVar (_,x) -> Pervasives.compare x f = 0
+ | _ -> false
+
+(** [ident_global_exist id] returns true if identifier [id] is linked
+ in global environment. *)
+let ident_global_exist id =
+ try
+ let ans = CRef (Libnames.Ident (dummy_loc,id)) in
+ let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in
+ true
+ with _ -> false
+
+(** [next_ident_fresh id] returns a fresh identifier (ie not linked in
+ global env) with base [id]. *)
+let next_ident_fresh (id:identifier) =
+ let res = ref id in
+ while ident_global_exist !res do res := Nameops.lift_subscript !res done;
+ !res
+
+
+(** {2 Debugging} *)
+(* comment this line to see debug msgs *)
+let msg x = () ;; let pr_lconstr c = str ""
+(* uncomment this to see debugging *)
+let prconstr c = msg (str" " ++ Printer.pr_lconstr c)
+let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n")
+let prlistconstr lc = List.iter prconstr lc
+let prstr s = msg(str s)
+let prNamedConstr s c =
+ begin
+ msg(str "");
+ msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} ");
+ msg(str "");
+ end
+let prNamedRConstr s c =
+ begin
+ msg(str "");
+ msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} ");
+ msg(str "");
+ end
+let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc
+let prNamedLConstr s lc =
+ begin
+ prstr "[§§§ ";
+ prstr s;
+ prNamedLConstr_aux lc;
+ prstr " §§§]\n";
+ end
+let prNamedLDecl s lc =
+ begin
+ prstr s; prstr "\n";
+ List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc;
+ prstr "\n";
+ end
+let prNamedRLDecl s lc =
+ begin
+ prstr s; prstr "\n"; prstr "{§§ ";
+ List.iter
+ (fun x ->
+ match x with
+ | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp
+ | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy
+ | _ -> assert false
+ ) lc;
+ prstr " §§}\n";
+ prstr "\n";
+ end
+
+let showind (id:identifier) =
+ let cstrid = Tacinterp.constr_of_id (Global.env()) id in
+ let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
+ let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in
+ List.iter (fun (nm, optcstr, tp) ->
+ print_string (string_of_name nm^":");
+ prconstr tp; print_string "\n")
+ ib1.mind_arity_ctxt;
+ (match ib1.mind_arity with
+ | Monomorphic x ->
+ Printf.printf "arity :"; prconstr x.mind_user_arity
+ | Polymorphic x ->
+ Printf.printf "arity : universe?");
+ Array.iteri
+ (fun i x -> Printf.printf"type constr %d :" i ; prconstr x)
+ ib1.mind_user_lc
+
+(** {2 Misc} *)
+
+exception Found of int
+
+(* Array scanning *)
+
+let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int =
+ try
+ for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
+ Array.length arr (* all elt are positive *)
+ with Found i -> i
+
+let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a =
+ let i = ref 0 in
+ Array.fold_left
+ (fun acc x ->
+ let res = f !i acc x in i := !i + 1; res)
+ acc arr
+
+(* Like list_chop but except that [i] is the size of the suffix of [l]. *)
+let list_chop_end i l =
+ let size_prefix = List.length l -i in
+ if size_prefix < 0 then failwith "list_chop_end"
+ else list_chop size_prefix l
+
+let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a =
+ let i = ref 0 in
+ List.fold_left
+ (fun acc x ->
+ let res = f !i acc x in i := !i + 1; res)
+ acc arr
+
+let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list =
+ let i = ref 0 in
+ List.filter (fun x -> let res = f !i x in i := !i + 1; res) l
+
+
+(** Iteration module *)
+module For =
+struct
+ let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f)
+ let rec foldup i j (f: 'a -> int -> 'a) acc =
+ if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc
+ let rec folddown i j (f: 'a -> int -> 'a) acc =
+ if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc
+ let fold i j = if i<j then foldup i j else folddown i j
+end
+
+
+(** {1 Parameters shifting and linking information} *)
+
+(** This type is used to deal with debruijn linked indices. When a
+ variable is linked to a previous one, we will ignore it and refer
+ to previous one. *)
+type linked_var =
+ | Linked of int
+ | Unlinked
+ | Funres
+
+(** When merging two graphs, parameters may become regular arguments,
+ and thus be shifted. This type describes the result of computing
+ the changes. *)
+type 'a shifted_params =
+ {
+ nprm1:'a;
+ nprm2:'a;
+ prm2_unlinked:'a list; (* ranks of unlinked params in nprms2 *)
+ nuprm1:'a;
+ nuprm2:'a;
+ nargs1:'a;
+ nargs2:'a;
+ }
+
+
+let prlinked x =
+ match x with
+ | Linked i -> Printf.sprintf "Linked %d" i
+ | Unlinked -> Printf.sprintf "Unlinked"
+ | Funres -> Printf.sprintf "Funres"
+
+let linkmonad f lnkvar =
+ match lnkvar with
+ | Linked i -> Linked (f i)
+ | Unlinked -> Unlinked
+ | Funres -> Funres
+
+let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar
+
+(* This map is used to deal with debruijn linked indices. *)
+module Link = Map.Make (struct type t = int let compare = Pervasives.compare end)
+
+let pr_links l =
+ Printf.printf "links:\n";
+ Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l;
+ Printf.printf "_____________\n"
+
+type 'a merged_arg =
+ | Prm_stable of 'a
+ | Prm_linked of 'a
+ | Prm_arg of 'a
+ | Arg_stable of 'a
+ | Arg_linked of 'a
+ | Arg_funres
+
+(** Information about graph merging of two inductives.
+ All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *)
+
+type merge_infos =
+ {
+ ident:identifier; (** new inductive name *)
+ mib1: mutual_inductive_body;
+ oib1: one_inductive_body;
+ mib2: mutual_inductive_body;
+ oib2: one_inductive_body;
+
+ (** Array of links of the first inductive (should be all stable) *)
+ lnk1: int merged_arg array;
+
+ (** Array of links of the second inductive (point to the first ind param/args) *)
+ lnk2: int merged_arg array;
+
+ (** rec params which remain rec param (ie not linked) *)
+ recprms1: rel_declaration list;
+ recprms2: rel_declaration list;
+ nrecprms1: int;
+ nrecprms2: int;
+
+ (** rec parms which became non parm (either linked to something
+ or because after a rec parm that became non parm) *)
+ otherprms1: rel_declaration list;
+ otherprms2: rel_declaration list;
+ notherprms1:int;
+ notherprms2:int;
+
+ (** args which remain args in merge *)
+ args1:rel_declaration list;
+ args2:rel_declaration list;
+ nargs1:int;
+ nargs2:int;
+
+ (** functional result args *)
+ funresprms1: rel_declaration list;
+ funresprms2: rel_declaration list;
+ nfunresprms1:int;
+ nfunresprms2:int;
+ }
+
+
+let pr_merginfo x =
+ let i,s=
+ match x with
+ | Prm_linked i -> Some i,"Prm_linked"
+ | Arg_linked i -> Some i,"Arg_linked"
+ | Prm_stable i -> Some i,"Prm_stable"
+ | Prm_arg i -> Some i,"Prm_arg"
+ | Arg_stable i -> Some i,"Arg_stable"
+ | Arg_funres -> None , "Arg_funres" in
+ match i with
+ | Some i -> Printf.sprintf "%s(%d)" s i
+ | None -> Printf.sprintf "%s" s
+
+let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false
+
+(* ?? prm_linked?? *)
+let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false
+
+let is_stable x =
+ match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false
+
+let isArg_funres x = match x with Arg_funres -> true | _ -> false
+
+let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list =
+ let prms = list_filteri (fun i _ -> isPrm_stable lnk.(i)) l in
+ let args = list_filteri (fun i _ -> isArg_stable lnk.(i)) l in
+ let fres = list_filteri (fun i _ -> isArg_funres lnk.(i)) l in
+ prms@args@fres
+
+(** Reverse the link map, keeping only linked vars, elements are list
+ of int as several vars may be linked to the same var. *)
+let revlinked lnk =
+ For.fold 0 (Array.length lnk - 1)
+ (fun acc k ->
+ match lnk.(k) with
+ | Unlinked | Funres -> acc
+ | Linked i ->
+ let old = try Link.find i acc with Not_found -> [] in
+ Link.add i (k::old) acc)
+ Link.empty
+
+let array_switch arr i j =
+ let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux
+
+let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list =
+ let larr = Array.of_list l in
+ let _ =
+ Array.iteri
+ (fun j x ->
+ match x with
+ | Prm_linked i -> array_switch larr i j
+ | Arg_linked i -> array_switch larr i j
+ | Prm_stable i -> ()
+ | Prm_arg i -> ()
+ | Arg_stable i -> ()
+ | Arg_funres -> ()
+ ) lnk in
+ filter_shift_stable lnk (Array.to_list larr)
+
+
+
+
+(** {1 Utilities for merging} *)
+
+let ind1name = id_of_string "__ind1"
+let ind2name = id_of_string "__ind2"
+
+(** Performs verifications on two graphs before merging: they must not
+ be co-inductive, and for the moment they must not be mutual
+ either. *)
+let verify_inds mib1 mib2 =
+ if not mib1.mind_finite then error "First argument is coinductive";
+ if not mib2.mind_finite then error "Second argument is coinductive";
+ if mib1.mind_ntypes <> 1 then error "First argument is mutual";
+ if mib2.mind_ntypes <> 1 then error "Second argument is mutual";
+ ()
+
+(*
+(** [build_raw_params prms_decl avoid] returns a list of variables
+ attributed to the list of decl [prms_decl], avoiding names in
+ [avoid]. *)
+let build_raw_params prms_decl avoid =
+ let dummy_constr = compose_prod (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 comblist = List.combine prms_decl res in
+ comblist, res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr)))
+*)
+
+let ids_of_rawlist avoid rawl =
+ List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl)
+
+
+
+(** {1 Merging function graphs} *)
+
+(** [shift_linked_params mib1 mib2 lnk] Computes which parameters (rec
+ uniform and ordinary ones) of mutual inductives [mib1] and [mib2]
+ remain uniform when linked by [lnk]. All parameters are
+ considered, ie we take parameters of the first inductive body of
+ [mib1] and [mib2].
+
+ Explanation: The two inductives have parameters, some of the first
+ are recursively uniform, some of the last are functional result of
+ the functional graph.
+
+ (I x1 x2 ... xk ... xk' ... xn)
+ (J y1 y2 ... xl ... yl' ... ym)
+
+ Problem is, if some rec unif params are linked to non rec unif
+ ones, they become non rec (and the following too). And functinal
+ argument have to be shifted at the end *)
+let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array) id =
+ let _ = prstr "\nYOUHOU shift\n" in
+ let linked_targets = revlinked lnk2 in
+ let is_param_of_mib1 x = x < mib1.mind_nparams_rec in
+ let is_param_of_mib2 x = x < mib2.mind_nparams_rec in
+ let is_targetted_by_non_recparam_lnk1 i =
+ try
+ let targets = Link.find i linked_targets in
+ List.exists (fun x -> not (is_param_of_mib2 x)) targets
+ with Not_found -> false in
+ let mlnk1 =
+ Array.mapi
+ (fun i lkv ->
+ let isprm = is_param_of_mib1 i in
+ let prmlost = is_targetted_by_non_recparam_lnk1 i in
+ match isprm , prmlost, lnk1.(i) with
+ | true , true , _ -> Prm_arg i (* recparam becoming ordinary *)
+ | true , false , _-> Prm_stable i (* recparam remains recparam*)
+ | false , false , Funres -> Arg_funres
+ | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *)
+ | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *)
+ lnk1 in
+ let mlnk2 =
+ Array.mapi
+ (fun i lkv ->
+ (* Is this correct if some param of ind2 is lost? *)
+ let isprm = is_param_of_mib2 i in
+ match isprm , lnk2.(i) with
+ | true , Linked j when not (is_param_of_mib1 j) ->
+ Prm_arg j (* recparam becoming ordinary *)
+ | true , Linked j -> Prm_linked j (*recparam linked to recparam*)
+ | true , Unlinked -> Prm_stable i (* recparam remains recparam*)
+ | false , Linked j -> Arg_linked j (* Args of lnk2 lost *)
+ | false , Unlinked -> Arg_stable i (* Args of lnk2 remains *)
+ | false , Funres -> Arg_funres
+ | true , Funres -> assert false (* fun res cannot be a rec param *)
+ )
+ lnk2 in
+ let oib1 = mib1.mind_packets.(0) in
+ let oib2 = mib2.mind_packets.(0) in
+ (* count params remaining params *)
+ let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in
+ let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in
+ let bldprms arity_ctxt mlnk =
+ list_fold_lefti
+ (fun i (acc1,acc2,acc3,acc4) x ->
+ prstr (pr_merginfo mlnk.(i));prstr "\n";
+ match mlnk.(i) with
+ | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4
+ | Prm_arg _ -> acc1 , x::acc2 , acc3, acc4
+ | Arg_stable _ -> acc1 , acc2 , x::acc3, acc4
+ | Arg_funres -> acc1 , acc2 , acc3, x::acc4
+ | _ -> acc1 , acc2 , acc3, acc4)
+ ([],[],[],[]) arity_ctxt in
+(* let arity_ctxt2 =
+ build_raw_params oib2.mind_arity_ctxt
+ (Idset.elements (ids_of_rawterm 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
+ let _ = prstr "\notherprms1:\n" in
+ let _ =
+ List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
+ otherprms1 in
+ let _ = prstr "\notherprms2:\n" in
+ let _ =
+ List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
+ otherprms2 in
+ {
+ ident=id;
+ mib1=mib1;
+ oib1 = oib1;
+ mib2=mib2;
+ oib2 = oib2;
+ lnk1 = mlnk1;
+ lnk2 = mlnk2;
+ nrecprms1 = n_params1;
+ recprms1 = recprms1;
+ otherprms1 = otherprms1;
+ args1 = args1;
+ funresprms1 = funresprms1;
+ notherprms1 = Array.length mlnk1 - n_params1;
+ nfunresprms1 = List.length funresprms1;
+ nargs1 = List.length args1;
+ nrecprms2 = n_params2;
+ recprms2 = recprms2;
+ otherprms2 = otherprms2;
+ args2 = args2;
+ funresprms2 = funresprms2;
+ notherprms2 = Array.length mlnk2 - n_params2;
+ nargs2 = List.length args2;
+ nfunresprms2 = List.length funresprms2;
+ }
+
+
+
+
+(** {1 Merging functions} *)
+
+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 ->
+ 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) , _ ->
+ 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) ->
+ 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)
+ | _ -> 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) ->
+ let args = filter_shift_stable lnk (arr1 @ arr2) in
+ RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args)
+ (* FIXME: what if the function appears in the body of the let? *)
+ | RLetIn(_,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) ->
+ 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)
+ | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge
+
+
+
+(* Heuristic when merging two lists of hypothesis: merge every rec
+ 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 =
+ let mergeonehyp t reldecl =
+ match reldecl with
+ | (nme,x,Some (RApp(_,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 ->
+ 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 =
+ List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
+
+
+let find_app (nme:identifier) ltyp =
+ try
+ ignore
+ (List.map
+ (fun x ->
+ match x with
+ | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0)
+ | _ -> ())
+ ltyp);
+ false
+ with Found _ -> true
+
+let prnt_prod_or_letin nm letbdy typ =
+ match letbdy , typ with
+ | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy
+ | None , Some tp -> prNamedRConstr (string_of_name nm) tp
+ | _ , _ -> assert false
+
+
+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 =
+ 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
+ let _ = prstr "\nltyp 2 : " in
+ let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp2 in
+ let _ = prstr "\n" in
+ let res =
+ match ltyp1 with
+ | [] ->
+ let isrec1 = (accrec1<>[]) in
+ let isrec2 = find_app ind2name ltyp2 in
+ let rechyps =
+ if isrec1 && isrec2
+ then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *)
+ merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
+ filter_shift_stable_right
+ @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2]
+ filter_shift_stable
+ else if isrec1
+ (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *)
+ then
+ merge_rec_hyps shift accrec1
+ (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable
+ else if isrec2
+ then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
+ filter_shift_stable_right
+ else ltyp2 in
+ let _ = prstr"\nrechyps : " in
+ let _ = List.iter(fun (nm,lbdy,tp)-> prnt_prod_or_letin nm lbdy tp) rechyps in
+ let _ = prstr "MERGE CONCL : " in
+ let _ = prNamedRConstr "concl1" concl1 in
+ let _ = prstr " with " in
+ let _ = prNamedRConstr "concl2" concl2 in
+ let _ = prstr "\n" in
+ let concl =
+ merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in
+ let _ = prstr "FIN " in
+ let _ = prNamedRConstr "concl" concl in
+ let _ = prstr "\n" in
+
+ rechyps , concl
+ | (nme,None, Some t1)as e ::lt1 ->
+ (match t1 with
+ | RApp(_,f,carr) when isVarf ind1name f ->
+ merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2
+ | _ ->
+ let recres, recconcl2 =
+ merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
+ ((nme,None,Some t1) :: recres) , recconcl2)
+ | (nme,Some bd, None) ::lt1 ->
+ (* FIXME: what if ind1name appears in bd? *)
+ let recres, recconcl2 =
+ merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in
+ ((nme,Some bd,None) :: recres) , recconcl2
+ | (_,None,None)::_ | (_,Some _,Some _)::_ -> assert false
+ in
+ res
+
+
+(** [build_link_map_aux allargs1 allargs2 shift] returns the mapping of
+ linked args [allargs2] to target args of [allargs1] as specified
+ in [shift]. [allargs1] and [allargs2] are in reverse order. Also
+ returns the list of unlinked vars of [allargs2]. *)
+let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
+ (lnk:int merged_arg array) =
+ array_fold_lefti
+ (fun i acc e ->
+ if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *)
+ else
+ match e with
+ | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc
+ | _ -> acc)
+ Idmap.empty lnk
+
+let build_link_map allargs1 allargs2 lnk =
+ let allargs1 =
+ Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs1)) in
+ let allargs2 =
+ Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in
+ build_link_map_aux allargs1 allargs2 lnk
+
+
+(** [merge_one_constructor lnk shift typcstr1 typcstr2] merges the two
+ constructor rawtypes [typcstr1] and [typcstr2]. [typcstr1] and
+ [typcstr2] contain all parameters (including rec. unif. ones) of
+ their inductive.
+
+ if [typcstr1] and [typcstr2] are of the form:
+
+ forall recparams1, forall ordparams1, H1a -> H2a... (I1 x1 y1 ... z1)
+ forall recparams2, forall ordparams2, H2b -> H2b... (I2 x2 y2 ... z2)
+
+ we build:
+
+ forall recparams1 (recparams2 without linked params),
+ forall ordparams1 (ordparams2 without linked params),
+ H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ...
+ -> (newI x1 ... z1 x2 y2 ...z2 without linked params)
+
+ where Hix' have been adapted, ie:
+ - linked vars have been changed,
+ - rec calls to I1 and I2 have been replaced by rec calls to
+ newI. More precisely calls to I1 and I2 have been merge by an
+ experimental heuristic (in particular if n o rec calls for I1
+ or I2 is found, we use the conclusion as a rec call). See
+ [merge_types] above.
+
+ Precond: vars sets of [typcstr1] and [typcstr2] must be disjoint.
+
+ TODO: return nothing if equalities (after linking) are contradictory. *)
+let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
+ (typcstr2:rawconstr) : rawconstr =
+ (* FIXME: les noms des parametres corerspondent en principe au
+ parametres du niveau mib, mais il faudrait s'en assurer *)
+ (* shift.nfunresprmsx last args are functional result *)
+ let nargs1 =
+ shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in
+ let nargs2 =
+ shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in
+ let allargs1,rest1 = raw_decompose_prod_or_letin_n nargs1 typcstr1 in
+ let allargs2,rest2 = raw_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 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 revargs1 =
+ list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in
+ let _ = prNamedRLDecl "ltyp allargs1" allargs1 in
+ let _ = prNamedRLDecl "ltyp revargs1" revargs1 in
+ let revargs2 =
+ list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in
+ 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
+ typwithprms
+
+
+(** constructor numbering *)
+let fresh_cstror_suffix , cstror_suffix_init =
+ let cstror_num = ref 0 in
+ (fun () ->
+ let res = string_of_int !cstror_num in
+ cstror_num := !cstror_num + 1;
+ res) ,
+ (fun () -> cstror_num := 0)
+
+(** [merge_constructor_id id1 id2 shift] returns the identifier of the
+ new constructor from the id of the two merged constructor and
+ the merging info. *)
+let merge_constructor_id id1 id2 shift:identifier =
+ let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in
+ next_ident_fresh (id_of_string id)
+
+
+
+(** [merge_constructors lnk shift avoid] merges the two list of
+ constructor [(name*type)]. These are translated to rawterms
+ first, each of them having distinct var names. *)
+let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
+ (typcstr1:(identifier * rawconstr) list)
+ (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list =
+ List.flatten
+ (List.map
+ (fun (id1,rawtyp1) ->
+ List.map
+ (fun (id2,rawtyp2) ->
+ let typ = merge_one_constructor shift rawtyp1 rawtyp2 in
+ let newcstror_id = merge_constructor_id id1 id2 shift in
+ let _ = prstr "\n**************\n" in
+ newcstror_id , typ)
+ typcstr2)
+ typcstr1)
+
+(** [merge_inductive_body lnk shift avoid oib1 oib2] merges two
+ inductive bodies [oib1] and [oib2], linking with [lnk], params
+ info in [shift], avoiding identifiers in [avoid]. *)
+let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
+ (oib2:one_inductive_body) =
+ (* building rawconstr 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 =
+ 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
+ let lcstr2 =
+ Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in
+ let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in
+
+ let params1 =
+ try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
+ with _ -> [] in
+ let params2 =
+ try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
+ with _ -> [] in
+
+ let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
+ let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in
+
+ cstror_suffix_init();
+ params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2
+
+
+(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual
+ inductive bodies [mib1] and [mib2] linking vars with
+ [lnk]. [shift] information on parameters of the new inductive.
+ For the moment, inductives are supposed to be non mutual.
+*)
+let rec merge_mutual_inductive_body
+ (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) =
+ (* Mutual not treated, we take first ind body of each. *)
+ 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 merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
+ let params = prms2 @ prms1 in
+ let resparams =
+ List.fold_left
+ (fun acc (nme,tp) ->
+ let _ = prstr "param :" in
+ let _ = prNamedRConstr (string_of_name nme) tp in
+ let _ = prstr " ; " in
+ let typ = rawterm_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
+ let arity,_ =
+ List.fold_left
+ (fun (acc,env) (nm,_,c) ->
+ let typ = Constrextern.extern_constr false env c in
+ let newenv = Environ.push_rel (nm,None,c) env in
+ CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv)
+ (concl,Global.env())
+ (shift.funresprms2 @ shift.funresprms1
+ @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in
+ resparams,arity
+
+
+
+(** [rawterm_list_to_inductive_expr ident rawlist] returns the
+ induct_expr corresponding to the the list of constructor types
+ [rawlist], named ident.
+ FIXME: params et cstr_expr (arity) *)
+let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
+ (rawlist:(identifier * rawconstr) 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))
+ rawlist in
+ lident , bindlist , Some cstr_expr , lcstor_expr
+
+
+
+let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
+ match rdecl with
+ | (nme,None,t) ->
+ let traw = Detyping.detype false [] [] t in
+ RProd (dummy_loc,nme,Explicit,traw,t2)
+ | (_,Some _,_) -> assert false
+
+
+
+
+let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) =
+ match rdecl with
+ | (nme,None,t) ->
+ let traw = Detyping.detype false [] [] t in
+ RProd (dummy_loc,nme,Explicit,traw,t2)
+ | (_,Some _,_) -> assert false
+
+
+(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking
+ variables specified in [lnk]. Graphs are not supposed to be mutual
+ inductives for the moment. *)
+let merge_inductive (ind1: inductive) (ind2: inductive)
+ (lnk1: linked_var array) (lnk2: linked_var array) id =
+ let env = Global.env() in
+ let mib1,_ = Inductive.lookup_mind_specif env ind1 in
+ let mib2,_ = Inductive.lookup_mind_specif env ind2 in
+ let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *)
+ (* compute params that become ordinary args (because linked to ord. args) *)
+ let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in
+ let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
+ let _ = prstr "\nrawlist : " in
+ let _ =
+ List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in
+ let _ = prstr "\nend rawlist\n" in
+(* FIX: retransformer en constr ici
+ let shift_prm =
+ { shift_prm with
+ recprms1=prms1;
+ recprms1=prms1;
+ } in *)
+ let indexpr = rawterm_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
+ (* Declare the mutual inductive block with its associated schemes *)
+ ignore (Command.declare_mutual_inductive_with_eliminations Declare.UserVerbose mie impls)
+
+
+(* Find infos on identifier id. *)
+let find_Function_infos_safe (id:identifier): Indfun_common.function_info =
+ let kn_of_id x =
+ let f_ref = Libnames.Ident (dummy_loc,x) in
+ locate_with_msg (str "Don't know what to do with " ++ Libnames.pr_reference f_ref)
+ locate_constant f_ref in
+ try find_Function_infos (kn_of_id id)
+ with Not_found ->
+ errorlabstrm "indfun" (Nameops.pr_id id ++ str " has no functional scheme")
+
+(** [merge id1 id2 args1 args2 id] builds and declares a new inductive
+ type called [id], representing the merged graphs of both graphs
+ [ind1] and [ind2]. identifiers occuring in both arrays [args1] and
+ [args2] are considered linked (i.e. are the same variable) in the
+ new graph.
+
+ Warning: For the moment, repetitions of an id in [args1] or
+ [args2] are not supported. *)
+let merge (id1:identifier) (id2:identifier) (args1:identifier array)
+ (args2:identifier array) id : unit =
+ let finfo1 = find_Function_infos_safe id1 in
+ let finfo2 = find_Function_infos_safe id2 in
+ (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *)
+ (* We add one arg (functional arg of the graph) *)
+ let lnk1 = Array.make (Array.length args1 + 1) Unlinked in
+ let lnk2' = (* args2 may be linked to args1 members. FIXME: same
+ as above: vars may be linked inside args2?? *)
+ Array.mapi
+ (fun i c ->
+ match array_find_i (fun i x -> x=c) args1 with
+ | Some j -> Linked j
+ | None -> Unlinked)
+ args2 in
+ (* We add one arg (functional arg of the graph) *)
+ let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in
+ (* setting functional results *)
+ let _ = lnk1.(Array.length lnk1 - 1) <- Funres in
+ let _ = lnk2.(Array.length lnk2 - 1) <- Funres in
+ merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id
+
+
+let remove_last_arg c =
+ let (x,y) = decompose_prod c in
+ let xnolast = List.rev (List.tl (List.rev x)) in
+ compose_prod xnolast y
+
+let rec remove_n_fst_list n l = if n=0 then l else remove_n_fst_list (n-1) (List.tl l)
+let remove_n_last_list n l = List.rev (remove_n_fst_list n (List.rev l))
+
+let remove_last_n_arg n c =
+ let (x,y) = decompose_prod c in
+ let xnolast = remove_n_last_list n x in
+ compose_prod xnolast y
+
+(* [funify_branches relinfo nfuns branch] returns the branch [branch]
+ of the relinfo [relinfo] modified to fit in a functional principle.
+ Things to do:
+ - remove indargs from rel applications
+ - replace *variables only* corresponding to function (recursive)
+ results by the actual function application. *)
+let funify_branches relinfo nfuns branch =
+ let mut_induct, induct =
+ match relinfo.indref with
+ | None -> assert false
+ | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind
+ | _ -> assert false in
+ let is_dom c =
+ match kind_of_term c with
+ | Ind((u,_)) | Construct((u,_),_) -> u = mut_induct
+ | _ -> false in
+ let _dom_i c =
+ assert (is_dom c);
+ match kind_of_term c with
+ | Ind((u,i)) | Construct((u,_),i) -> i
+ | _ -> assert false in
+ let _is_pred c shift =
+ match kind_of_term c with
+ | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches)
+ | _ -> false in
+ (* FIXME: *)
+ (Anonymous,Some mkProp,mkProp)
+
+
+let relprinctype_to_funprinctype relprinctype nfuns =
+ let relinfo = compute_elim_sig relprinctype in
+ assert (not relinfo.farg_in_concl);
+ assert (relinfo.indarg_in_concl);
+ (* first remove indarg and indarg_in_concl *)
+ let relinfo_noindarg = { relinfo with
+ indarg_in_concl = false; indarg = None;
+ concl = remove_last_arg (pop relinfo.concl); } in
+ (* the nfuns last induction arguments are functional ones: remove them *)
+ let relinfo_argsok = { relinfo_noindarg with
+ nargs = relinfo_noindarg.nargs - nfuns;
+ (* args is in reverse order, so remove fst *)
+ args = remove_n_fst_list nfuns relinfo_noindarg.args;
+ concl = popn nfuns relinfo_noindarg.concl
+ } in
+ let new_branches =
+ List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in
+ let relinfo_branches = { relinfo_argsok with branches = new_branches } in
+ relinfo_branches
+
+(* @article{ bundy93rippling,
+ author = "Alan Bundy and Andrew Stevens and Frank van Harmelen and Andrew Ireland and Alan Smaill",
+ title = "Rippling: A Heuristic for Guiding Inductive Proofs",
+ journal = "Artificial Intelligence",
+ volume = "62",
+ number = "2",
+ pages = "185-253",
+ year = "1993",
+ url = "citeseer.ist.psu.edu/bundy93rippling.html" }
+
+ *)
+(*
+*** Local Variables: ***
+*** compile-command: "make -C ../.. plugins/funind/merge.cmo" ***
+*** indent-tabs-mode: nil ***
+*** End: ***
+*)
diff --git a/plugins/funind/rawterm_to_relation.ml b/plugins/funind/rawterm_to_relation.ml
new file mode 100644
index 00000000..3c3a36f0
--- /dev/null
+++ b/plugins/funind/rawterm_to_relation.ml
@@ -0,0 +1,1419 @@
+open Printer
+open Pp
+open Names
+open Term
+open Rawterm
+open Libnames
+open Indfun_common
+open Util
+open Rawtermops
+
+let observe strm =
+ if do_observe ()
+ then Pp.msgnl strm
+ else ()
+let observennl strm =
+ if do_observe ()
+ then Pp.msg strm
+ else ()
+
+
+type binder_type =
+ | Lambda of name
+ | Prod of name
+ | LetIn of name
+
+type raw_context = (binder_type*rawconstr) list
+
+(*
+ compose_raw_context [(bt_1,n_1,t_1);......] rt returns
+ b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the
+ binders corresponding to the bt_i's
+*)
+let compose_raw_context =
+ let compose_binder (bt,t) acc =
+ match bt with
+ | Lambda n -> mkRLambda(n,t,acc)
+ | Prod n -> mkRProd(n,t,acc)
+ | LetIn n -> mkRLetIn(n,t,acc)
+ in
+ List.fold_right compose_binder
+
+
+(*
+ The main part deals with building a list of raw constructor expressions
+ from the rhs of a fixpoint equation.
+*)
+
+type 'a build_entry_pre_return =
+ {
+ context : raw_context; (* the binding context of the result *)
+ value : 'a; (* The value *)
+ }
+
+type 'a build_entry_return =
+ {
+ result : 'a build_entry_pre_return list;
+ to_avoid : identifier list
+ }
+
+(*
+ [combine_results combine_fun res1 res2] combine two results [res1] and [res2]
+ w.r.t. [combine_fun].
+
+ Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...]
+ and [res2_1,....] and we need to produce
+ [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........]
+*)
+
+let combine_results
+ (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return ->
+ 'c build_entry_pre_return
+ )
+ (res1: 'a build_entry_return)
+ (res2 : 'b build_entry_return)
+ : 'c build_entry_return
+ =
+ let pre_result = List.map
+ ( fun res1 -> (* for each result in arg_res *)
+ List.map (* we add it in each args_res *)
+ (fun res2 ->
+ combine_fun res1 res2
+ )
+ res2.result
+ )
+ res1.result
+ in (* and then we flatten the map *)
+ {
+ result = List.concat pre_result;
+ to_avoid = list_union res1.to_avoid res2.to_avoid
+ }
+
+
+(*
+ The combination function for an argument with a list of argument
+*)
+
+let combine_args arg args =
+ {
+ context = arg.context@args.context;
+ (* Note that the binding context of [arg] MUST be placed before the one of
+ [args] in order to preserve possible type dependencies
+ *)
+ value = arg.value::args.value;
+ }
+
+
+let ids_of_binder = function
+ | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> []
+ | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id]
+
+let rec change_vars_in_binder mapping = function
+ [] -> []
+ | (bt,t)::l ->
+ let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in
+ (bt,change_vars mapping t)::
+ (if idmap_is_empty new_mapping
+ then l
+ else change_vars_in_binder new_mapping l
+ )
+
+let rec replace_var_by_term_in_binder x_id term = function
+ | [] -> []
+ | (bt,t)::l ->
+ (bt,replace_var_by_term x_id term t)::
+ if List.mem x_id (ids_of_binder bt)
+ then l
+ else replace_var_by_term_in_binder x_id term l
+
+let add_bt_names bt = List.append (ids_of_binder bt)
+
+let apply_args ctxt body args =
+ let need_convert_id avoid id =
+ List.exists (is_free_in id) args || List.mem id avoid
+ in
+ let need_convert avoid bt =
+ List.exists (need_convert_id avoid) (ids_of_binder bt)
+ in
+ let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) =
+ match na with
+ | Name id when List.mem id avoid ->
+ let new_id = Namegen.next_ident_away id avoid in
+ Name new_id,Idmap.add id new_id mapping,new_id::avoid
+ | _ -> na,mapping,avoid
+ in
+ let next_bt_away bt (avoid:identifier list) =
+ match bt with
+ | LetIn na ->
+ let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in
+ LetIn new_na,mapping,new_avoid
+ | Prod na ->
+ let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in
+ Prod new_na,mapping,new_avoid
+ | Lambda na ->
+ let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in
+ Lambda new_na,mapping,new_avoid
+ in
+ let rec do_apply avoid ctxt body args =
+ match ctxt,args with
+ | _,[] -> (* No more args *)
+ (ctxt,body)
+ | [],_ -> (* no more fun *)
+ let f,args' = raw_decompose_app body in
+ (ctxt,mkRApp(f,args'@args))
+ | (Lambda Anonymous,t)::ctxt',arg::args' ->
+ do_apply avoid ctxt' body args'
+ | (Lambda (Name id),t)::ctxt',arg::args' ->
+ let new_avoid,new_ctxt',new_body,new_id =
+ if need_convert_id avoid id
+ then
+ let new_avoid = id::avoid in
+ let new_id = Namegen.next_ident_away id new_avoid in
+ let new_avoid' = new_id :: new_avoid in
+ let mapping = Idmap.add id new_id Idmap.empty in
+ let new_ctxt' = change_vars_in_binder mapping ctxt' in
+ let new_body = change_vars mapping body in
+ new_avoid',new_ctxt',new_body,new_id
+ else
+ id::avoid,ctxt',body,id
+ in
+ let new_body = replace_var_by_term new_id arg new_body in
+ let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in
+ do_apply avoid new_ctxt' new_body args'
+ | (bt,t)::ctxt',_ ->
+ let new_avoid,new_ctxt',new_body,new_bt =
+ let new_avoid = add_bt_names bt avoid in
+ if need_convert avoid bt
+ then
+ let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in
+ (
+ new_avoid,
+ change_vars_in_binder mapping ctxt',
+ change_vars mapping body,
+ new_bt
+ )
+ else new_avoid,ctxt',body,bt
+ in
+ let new_ctxt',new_body =
+ do_apply new_avoid new_ctxt' new_body args
+ in
+ (new_bt,t)::new_ctxt',new_body
+ in
+ do_apply [] ctxt body args
+
+
+let combine_app f args =
+ let new_ctxt,new_value = apply_args f.context f.value args.value in
+ {
+ (* Note that the binding context of [args] MUST be placed before the one of
+ the applied value in order to preserve possible type dependencies
+ *)
+ context = args.context@new_ctxt;
+ value = new_value;
+ }
+
+let combine_lam n t b =
+ {
+ context = [];
+ value = mkRLambda(n, compose_raw_context t.context t.value,
+ compose_raw_context b.context b.value )
+ }
+
+
+
+let combine_prod n t b =
+ { context = t.context@((Prod n,t.value)::b.context); value = b.value}
+
+let combine_letin n t b =
+ { context = t.context@((LetIn n,t.value)::b.context); value = b.value}
+
+
+let mk_result ctxt value avoid =
+ {
+ result =
+ [{context = ctxt;
+ value = value}]
+ ;
+ to_avoid = avoid
+ }
+(*************************************************
+ Some functions to deal with overlapping patterns
+**************************************************)
+
+let coq_True_ref =
+ lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True")
+
+let coq_False_ref =
+ lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False")
+
+(*
+ [make_discr_match_el \[e1,...en\]] builds match e1,...,en with
+ (the list of expresions on which we will do the matching)
+ *)
+let make_discr_match_el =
+ List.map (fun e -> (e,(Anonymous,None)))
+
+(*
+ [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression.
+ that is.
+ match ?????? with \\
+ | pat_1 => False \\
+ | pat_{i-1} => False \\
+ | pat_i => True \\
+ | pat_{i+1} => False \\
+ \vdots
+ | pat_n => False
+ end
+*)
+let make_discr_match_brl i =
+ list_map_i
+ (fun j (_,idl,patl,_) ->
+ if j=i
+ then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref))
+ else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref))
+ )
+ 0
+(*
+ [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff
+ brl_{i} is the first branch matched by [el]
+
+ Used when we want to simulate the coq pattern matching algorithm
+*)
+let make_discr_match brl =
+ fun el i ->
+ mkRCases(None,
+ make_discr_match_el el,
+ make_discr_match_brl i brl)
+
+let pr_name = function
+ | Name id -> Ppconstr.pr_id id
+ | Anonymous -> str "_"
+
+(**********************************************************************)
+(* functions used to build case expression from lettuple and if ones *)
+(**********************************************************************)
+
+(* [build_constructors_of_type] construct the array of pattern of its inductive argument*)
+let build_constructors_of_type ind' argl =
+ let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in
+ let npar = mib.Declarations.mind_nparams in
+ Array.mapi (fun i _ ->
+ let construct = ind',i+1 in
+ let constructref = ConstructRef(construct) in
+ let _implicit_positions_of_cst =
+ Impargs.implicits_of_global constructref
+ in
+ let cst_narg =
+ Inductiveops.mis_constructor_nargs_env
+ (Global.env ())
+ construct
+ in
+ let argl =
+ if argl = []
+ then
+ Array.to_list
+ (Array.init (cst_narg - npar) (fun _ -> mkRHole ())
+ )
+ else argl
+ in
+ let pat_as_term =
+ mkRApp(mkRRef (ConstructRef(ind',i+1)),argl)
+ in
+ cases_pattern_of_rawconstr Anonymous pat_as_term
+ )
+ ind.Declarations.mind_consnames
+
+(* [find_type_of] very naive attempts to discover the type of an if or a letin *)
+let rec find_type_of nb b =
+ let f,_ = raw_decompose_app b in
+ match f with
+ | RRef(_,ref) ->
+ begin
+ let ind_type =
+ match ref with
+ | VarRef _ | ConstRef _ ->
+ let constr_of_ref = constr_of_global ref in
+ let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in
+ let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in
+ let ret_type,_ = decompose_app ret_type in
+ if not (isInd ret_type) then
+ begin
+(* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *)
+ raise (Invalid_argument "not an inductive")
+ end;
+ destInd ret_type
+ | IndRef ind -> ind
+ | ConstructRef c -> fst c
+ in
+ let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in
+ if not (Array.length ind_type_info.Declarations.mind_consnames = nb )
+ then raise (Invalid_argument "find_type_of : not a valid inductive");
+ ind_type
+ end
+ | RCast(_,b,_) -> find_type_of nb b
+ | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *)
+ | _ -> raise (Invalid_argument "not a ref")
+
+
+
+
+(******************)
+(* Main functions *)
+(******************)
+
+
+
+let raw_push_named (na,raw_value,raw_typ) env =
+ match na with
+ | Anonymous -> env
+ | Name id ->
+ let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in
+ let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in
+ Environ.push_named (id,value,typ) env
+
+
+let add_pat_variables pat typ env : Environ.env =
+ let rec add_pat_variables env pat typ : Environ.env =
+ observe (str "new rel env := " ++ Printer.pr_rel_context_of env);
+
+ match pat with
+ | PatVar(_,na) -> Environ.push_rel (na,None,typ) env
+ | PatCstr(_,c,patl,na) ->
+ let Inductiveops.IndType(indf,indargs) =
+ try Inductiveops.find_rectype env Evd.empty typ
+ with Not_found -> assert false
+ in
+ let constructors = Inductiveops.get_constructors env indf in
+ let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in
+ let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
+ List.fold_left2 add_pat_variables env patl (List.rev cs_args_types)
+ in
+ let new_env = add_pat_variables env pat typ in
+ let res =
+ fst (
+ Sign.fold_rel_context
+ (fun (na,v,t) (env,ctxt) ->
+ match na with
+ | Anonymous -> assert false
+ | Name id ->
+ let new_t = substl ctxt t in
+ let new_v = Option.map (substl ctxt) v in
+ observe (str "for variable " ++ Ppconstr.pr_id id ++ fnl () ++
+ str "old type := " ++ Printer.pr_lconstr t ++ fnl () ++
+ str "new type := " ++ Printer.pr_lconstr new_t ++ fnl () ++
+ Option.fold_right (fun v _ -> str "old value := " ++ Printer.pr_lconstr v ++ fnl ()) v (mt ()) ++
+ Option.fold_right (fun v _ -> str "new value := " ++ Printer.pr_lconstr v ++ fnl ()) new_v (mt ())
+ );
+ (Environ.push_named (id,new_v,new_t) env,mkVar id::ctxt)
+ )
+ (Environ.rel_context new_env)
+ ~init:(env,[])
+ )
+ in
+ observe (str "new var env := " ++ Printer.pr_named_context_of res);
+ res
+
+
+
+
+let rec pattern_to_term_and_type env typ = function
+ | PatVar(loc,Anonymous) -> assert false
+ | PatVar(loc,Name id) ->
+ mkRVar id
+ | PatCstr(loc,constr,patternl,_) ->
+ let cst_narg =
+ Inductiveops.mis_constructor_nargs_env
+ (Global.env ())
+ constr
+ in
+ let Inductiveops.IndType(indf,indargs) =
+ try Inductiveops.find_rectype env Evd.empty typ
+ with Not_found -> assert false
+ in
+ let constructors = Inductiveops.get_constructors env indf in
+ let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in
+ let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
+ let _,cstl = Inductiveops.dest_ind_family indf in
+ let csta = Array.of_list cstl in
+ let implicit_args =
+ Array.to_list
+ (Array.init
+ (cst_narg - List.length patternl)
+ (fun i -> Detyping.detype false [] (Termops.names_of_rel_context env) csta.(i))
+ )
+ in
+ let patl_as_term =
+ List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl
+ in
+ mkRApp(mkRRef(ConstructRef constr),
+ implicit_args@patl_as_term
+ )
+
+(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return)
+ of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the
+ corresponding graphs.
+
+
+ The idea to transform a term [t] into a list of constructors [lc] is the following:
+ \begin{itemize}
+ \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding
+ to [body] and add (bind x. _) to each elements of [lc]
+ \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames)
+ then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
+ then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn],
+ [g c1 ... cn] is an element of [lc]
+ \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then
+ compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn],
+ then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn]
+ create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc]
+ \item if the term is a cast just treat its body part
+ \item
+ if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case
+ and concatenate them (informally, each branch of a match produces a new constructor)
+ \end{itemize}
+
+ WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed.
+ We must wait to have complete all the current calculi to set the recursive calls.
+ At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by
+ a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later.
+ We in fact not create a constructor list since then end of each constructor has not the expected form
+ but only the value of the function
+*)
+
+
+let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
+ observe (str " Entering : " ++ Printer.pr_rawconstr rt);
+ match rt with
+ | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ ->
+ (* do nothing (except changing type of course) *)
+ mk_result [] rt avoid
+ | RApp(_,_,_) ->
+ let f,args = raw_decompose_app rt in
+ let args_res : (rawconstr list) build_entry_return =
+ List.fold_right (* create the arguments lists of constructors and combine them *)
+ (fun arg ctxt_argsl ->
+ let arg_res = build_entry_lc env funnames ctxt_argsl.to_avoid arg in
+ combine_results combine_args arg_res ctxt_argsl
+ )
+ args
+ (mk_result [] [] avoid)
+ in
+ begin
+ match f with
+ | RLambda _ ->
+ let rec aux t l =
+ match l with
+ | [] -> t
+ | u::l ->
+ match t with
+ | RLambda(loc,na,_,nat,b) ->
+ RLetIn(dummy_loc,na,u,aux b l)
+ | _ ->
+ RApp(dummy_loc,t,l)
+ in
+ build_entry_lc env funnames avoid (aux f args)
+ | RVar(_,id) when Idset.mem id funnames ->
+ (* if we have [f t1 ... tn] with [f]$\in$[fnames]
+ then we create a fresh variable [res],
+ add [res] and its "value" (i.e. [res v1 ... vn]) to each
+ pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and
+ a pseudo value "v1 ... vn".
+ The "value" of this branch is then simply [res]
+ *)
+ let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in
+ let rt_typ = Typing.type_of env Evd.empty rt_as_constr in
+ let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in
+ let res = fresh_id args_res.to_avoid "res" in
+ let new_avoid = res::args_res.to_avoid in
+ let res_rt = mkRVar res in
+ let new_result =
+ List.map
+ (fun arg_res ->
+ let new_hyps =
+ [Prod (Name res),res_raw_type;
+ Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)]
+ in
+ {context = arg_res.context@new_hyps; value = res_rt }
+ )
+ args_res.result
+ in
+ { result = new_result; to_avoid = new_avoid }
+ | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ ->
+ (* if have [g t1 ... tn] with [g] not appearing in [funnames]
+ then
+ foreach [ctxt,v1 ... vn] in [args_res] we return
+ [ctxt, g v1 .... vn]
+ *)
+ {
+ args_res with
+ result =
+ List.map
+ (fun args_res ->
+ {args_res with value = mkRApp(f,args_res.value)})
+ args_res.result
+ }
+ | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *)
+ | RLetIn(_,n,t,b) ->
+ (* if we have [(let x := v in b) t1 ... tn] ,
+ we discard our work and compute the list of constructor for
+ [let x = v in (b t1 ... tn)] up to alpha conversion
+ *)
+ let new_n,new_b,new_avoid =
+ match n with
+ | Name id when List.exists (is_free_in id) args ->
+ (* need to alpha-convert the name *)
+ let new_id = Namegen.next_ident_away id avoid in
+ let new_avoid = id:: avoid in
+ let new_b =
+ replace_var_by_term
+ id
+ (RVar(dummy_loc,id))
+ b
+ in
+ (Name new_id,new_b,new_avoid)
+ | _ -> n,b,avoid
+ in
+ build_entry_lc
+ env
+ funnames
+ avoid
+ (mkRLetIn(new_n,t,mkRApp(new_b,args)))
+ | RCases _ | RIf _ | RLetTuple _ ->
+ (* we have [(match e1, ...., en with ..... end) t1 tn]
+ we first compute the result from the case and
+ then combine each of them with each of args one
+ *)
+ let f_res = build_entry_lc env funnames args_res.to_avoid f in
+ combine_results combine_app f_res args_res
+ | RDynamic _ ->error "Not handled RDynamic"
+ | RCast(_,b,_) ->
+ (* for an applied cast we just trash the cast part
+ and restart the work.
+
+ WARNING: We need to restart since [b] itself should be an application term
+ *)
+ build_entry_lc env funnames avoid (mkRApp(b,args))
+ | RRec _ -> error "Not handled RRec"
+ | RProd _ -> error "Cannot apply a type"
+ end (* end of the application treatement *)
+
+ | RLambda(_,n,_,t,b) ->
+ (* we first compute the list of constructor
+ corresponding to the body of the function,
+ then the one corresponding to the type
+ and combine the two result
+ *)
+ let t_res = build_entry_lc env funnames avoid t in
+ let new_n =
+ match n with
+ | Name _ -> n
+ | Anonymous -> Name (Indfun_common.fresh_id [] "_x")
+ in
+ let new_env = raw_push_named (new_n,None,t) env in
+ let b_res = build_entry_lc new_env funnames avoid b in
+ combine_results (combine_lam new_n) t_res b_res
+ | RProd(_,n,_,t,b) ->
+ (* we first compute the list of constructor
+ corresponding to the body of the function,
+ then the one corresponding to the type
+ and combine the two result
+ *)
+ let t_res = build_entry_lc env funnames avoid t in
+ let new_env = raw_push_named (n,None,t) env in
+ let b_res = build_entry_lc new_env funnames avoid b in
+ combine_results (combine_prod n) t_res b_res
+ | RLetIn(_,n,v,b) ->
+ (* we first compute the list of constructor
+ corresponding to the body of the function,
+ then the one corresponding to the value [t]
+ and combine the two result
+ *)
+ let v_res = build_entry_lc env funnames avoid v in
+ let v_as_constr = Pretyping.Default.understand Evd.empty env v in
+ let v_type = Typing.type_of env Evd.empty v_as_constr in
+ let new_env =
+ match n with
+ Anonymous -> env
+ | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env
+ in
+ let b_res = build_entry_lc new_env funnames avoid b in
+ combine_results (combine_letin n) v_res b_res
+ | RCases(_,_,_,el,brl) ->
+ (* we create the discrimination function
+ and treat the case itself
+ *)
+ let make_discr = make_discr_match brl in
+ build_entry_lc_from_case env funnames make_discr el brl avoid
+ | RIf(_,b,(na,e_option),lhs,rhs) ->
+ let b_as_constr = Pretyping.Default.understand Evd.empty env b in
+ let b_typ = Typing.type_of env Evd.empty b_as_constr in
+ let (ind,_) =
+ try Inductiveops.find_inductive env Evd.empty b_typ
+ with Not_found ->
+ errorlabstrm "" (str "Cannot find the inductive associated to " ++
+ Printer.pr_rawconstr b ++ str " in " ++
+ Printer.pr_rawconstr rt ++ str ". try again with a cast")
+ in
+ let case_pats = build_constructors_of_type ind [] in
+ assert (Array.length case_pats = 2);
+ let brl =
+ list_map_i
+ (fun i x -> (dummy_loc,[],[case_pats.(i)],x))
+ 0
+ [lhs;rhs]
+ in
+ let match_expr =
+ mkRCases(None,[(b,(Anonymous,None))],brl)
+ in
+ (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *)
+ build_entry_lc env funnames avoid match_expr
+ | RLetTuple(_,nal,_,b,e) ->
+ begin
+ let nal_as_rawconstr =
+ List.map
+ (function
+ Name id -> mkRVar id
+ | Anonymous -> mkRHole ()
+ )
+ nal
+ in
+ let b_as_constr = Pretyping.Default.understand Evd.empty env b in
+ let b_typ = Typing.type_of env Evd.empty b_as_constr in
+ let (ind,_) =
+ try Inductiveops.find_inductive env Evd.empty b_typ
+ with Not_found ->
+ errorlabstrm "" (str "Cannot find the inductive associated to " ++
+ Printer.pr_rawconstr b ++ str " in " ++
+ Printer.pr_rawconstr rt ++ str ". try again with a cast")
+ in
+ let case_pats = build_constructors_of_type ind nal_as_rawconstr in
+ assert (Array.length case_pats = 1);
+ let br =
+ (dummy_loc,[],[case_pats.(0)],e)
+ in
+ let match_expr = mkRCases(None,[b,(Anonymous,None)],[br]) in
+ build_entry_lc env funnames avoid match_expr
+
+ end
+ | RRec _ -> error "Not handled RRec"
+ | RCast(_,b,_) ->
+ build_entry_lc env funnames avoid b
+ | RDynamic _ -> error "Not handled RDynamic"
+and build_entry_lc_from_case env funname make_discr
+ (el:tomatch_tuples)
+ (brl:Rawterm.cases_clauses) avoid :
+ rawconstr build_entry_return =
+ match el with
+ | [] -> assert false (* this case correspond to match <nothing> with .... !*)
+ | el ->
+ (* this case correspond to
+ match el with brl end
+ we first compute the list of lists corresponding to [el] and
+ combine them .
+ Then for each elemeent of the combinations,
+ we compute the result we compute one list per branch in [brl] and
+ finally we just concatenate those list
+ *)
+ let case_resl =
+ List.fold_right
+ (fun (case_arg,_) ctxt_argsl ->
+ let arg_res = build_entry_lc env funname avoid case_arg in
+ combine_results combine_args arg_res ctxt_argsl
+ )
+ el
+ (mk_result [] [] avoid)
+ in
+ let types =
+ List.map (fun (case_arg,_) ->
+ let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in
+ Typing.type_of env Evd.empty case_arg_as_constr
+ ) el
+ in
+ (****** The next works only if the match is not dependent ****)
+ let results =
+ List.map
+ (fun ca ->
+ let res = build_entry_lc_from_case_term
+ env types
+ funname (make_discr)
+ [] brl
+ case_resl.to_avoid
+ ca
+ in
+ res
+ )
+ case_resl.result
+ in
+ {
+ result = List.concat (List.map (fun r -> r.result) results);
+ to_avoid =
+ List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results
+ }
+
+and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid
+ matched_expr =
+ match brl with
+ | [] -> (* computed_branches *) {result = [];to_avoid = avoid}
+ | br::brl' ->
+ (* alpha convertion to prevent name clashes *)
+ let _,idl,patl,return = alpha_br avoid br in
+ let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *)
+ (* building a list of precondition stating that we are not in this branch
+ (will be used in the following recursive calls)
+ *)
+ let new_env = List.fold_right2 add_pat_variables patl types env in
+ let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list =
+ List.map2
+ (fun pat typ ->
+ fun avoid pat'_as_term ->
+ let renamed_pat,_,_ = alpha_pat avoid pat in
+ let pat_ids = get_pattern_id renamed_pat in
+ let env_with_pat_ids = add_pat_variables pat typ new_env in
+ List.fold_right
+ (fun id acc ->
+ let typ_of_id =
+ Typing.type_of env_with_pat_ids Evd.empty (mkVar id)
+ in
+ let raw_typ_of_id =
+ Detyping.detype false []
+ (Termops.names_of_rel_context env_with_pat_ids) typ_of_id
+ in
+ mkRProd (Name id,raw_typ_of_id,acc))
+ pat_ids
+ (raw_make_neq pat'_as_term (pattern_to_term renamed_pat))
+ )
+ patl
+ types
+ in
+ (* Checking if we can be in this branch
+ (will be used in the following recursive calls)
+ *)
+ let unify_with_those_patterns : (cases_pattern -> bool*bool) list =
+ List.map
+ (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat')
+ patl
+ in
+ (*
+ we first compute the other branch result (in ordrer to keep the order of the matching
+ as much as possible)
+ *)
+ let brl'_res =
+ build_entry_lc_from_case_term
+ env
+ types
+ funname
+ make_discr
+ ((unify_with_those_patterns,not_those_patterns)::patterns_to_prevent)
+ brl'
+ avoid
+ matched_expr
+ in
+ (* We now create the precondition of this branch i.e.
+ 1- the list of variable appearing in the different patterns of this branch and
+ the list of equation stating than el = patl (List.flatten ...)
+ 2- If there exists a previous branch which pattern unify with the one of this branch
+ then a discrimination precond stating that we are not in a previous branch (if List.exists ...)
+ *)
+ let those_pattern_preconds =
+ (List.flatten
+ (
+ list_map3
+ (fun pat e typ_as_constr ->
+ let this_pat_ids = ids_of_pat pat in
+ let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in
+ let pat_as_term = pattern_to_term pat in
+ List.fold_right
+ (fun id acc ->
+ if Idset.mem id this_pat_ids
+ then (Prod (Name id),
+ let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in
+ let raw_typ_of_id =
+ Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id
+ in
+ raw_typ_of_id
+ )::acc
+ else acc
+ )
+ idl
+ [(Prod Anonymous,raw_make_eq ~typ pat_as_term e)]
+ )
+ patl
+ matched_expr.value
+ types
+ )
+ )
+ @
+ (if List.exists (function (unifl,_) ->
+ let (unif,_) =
+ List.split (List.map2 (fun x y -> x y) unifl patl)
+ in
+ List.for_all (fun x -> x) unif) patterns_to_prevent
+ then
+ let i = List.length patterns_to_prevent in
+ let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in
+ [(Prod Anonymous,make_discr pats_as_constr i )]
+ else
+ []
+ )
+ in
+ (* We compute the result of the value returned by the branch*)
+ let return_res = build_entry_lc new_env funname new_avoid return in
+ (* and combine it with the preconds computed for this branch *)
+ let this_branch_res =
+ List.map
+ (fun res ->
+ { context = matched_expr.context@those_pattern_preconds@res.context ;
+ value = res.value}
+ )
+ return_res.result
+ in
+ { brl'_res with result = this_branch_res@brl'_res.result }
+
+
+let is_res id =
+ try
+ String.sub (string_of_id id) 0 3 = "res"
+ with Invalid_argument _ -> false
+
+
+exception Continue
+(*
+ The second phase which reconstruct the real type of the constructor.
+ rebuild the raw constructors expression.
+ eliminates some meaningless equalities, applies some rewrites......
+*)
+let rec rebuild_cons env nb_args relname args crossed_types depth rt =
+ observe (str "rebuilding : " ++ pr_rawconstr rt);
+
+ match rt with
+ | RProd(_,n,k,t,b) ->
+ let not_free_in_t id = not (is_free_in id t) in
+ let new_crossed_types = t::crossed_types in
+ begin
+ match t with
+ | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id ->
+ begin
+ match args' with
+ | (RVar(_,this_relname))::args' ->
+ (*i The next call to mk_rel_id is
+ valid since we are constructing the graph
+ Ensures by: obvious
+ i*)
+
+ let new_t =
+ mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt])
+ in
+ let t' = Pretyping.Default.understand Evd.empty env new_t in
+ let new_env = Environ.push_rel (n,None,t') env in
+ let new_b,id_to_exclude =
+ rebuild_cons new_env
+ nb_args relname
+ args new_crossed_types
+ (depth + 1) b
+ in
+ mkRProd(n,new_t,new_b),
+ Idset.filter not_free_in_t id_to_exclude
+ | _ -> (* the first args is the name of the function! *)
+ assert false
+ end
+ | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt])
+ when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous
+ ->
+ begin
+ try
+ observe (str "computing new type for eq : " ++ pr_rawconstr rt);
+ let t' =
+ try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue
+ in
+ let is_in_b = is_free_in id b in
+ let _keep_eq =
+ not (List.exists (is_free_in id) args) || is_in_b ||
+ List.exists (is_free_in id) crossed_types
+ in
+ let new_args = List.map (replace_var_by_term id rt) args in
+ let subst_b =
+ if is_in_b then b else replace_var_by_term id rt b
+ in
+ let new_env = Environ.push_rel (n,None,t') env in
+ let new_b,id_to_exclude =
+ rebuild_cons
+ new_env
+ nb_args relname
+ new_args new_crossed_types
+ (depth + 1) subst_b
+ in
+ mkRProd(n,t,new_b),id_to_exclude
+ with Continue ->
+ let jmeq = Libnames.IndRef (destInd (jmeq ())) in
+ let ty' = Pretyping.Default.understand Evd.empty env ty in
+ let ind,args' = Inductive.find_inductive env ty' in
+ let mib,_ = Global.lookup_inductive ind in
+ let nparam = mib.Declarations.mind_nparams in
+ let params,arg' =
+ ((Util.list_chop nparam args'))
+ in
+ let rt_typ =
+ RApp(Util.dummy_loc,
+ RRef (Util.dummy_loc,Libnames.IndRef ind),
+ (List.map
+ (fun p -> Detyping.detype false []
+ (Termops.names_of_rel_context env)
+ p) params)@(Array.to_list
+ (Array.make
+ (List.length args' - nparam)
+ (mkRHole ()))))
+ in
+ let eq' =
+ RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt])
+ in
+ observe (str "computing new type for jmeq : " ++ pr_rawconstr eq');
+ let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in
+ observe (str " computing new type for jmeq : done") ;
+ let new_args =
+ match kind_of_term eq'_as_constr with
+ | App(_,[|_;_;ty;_|]) ->
+ let ty = Array.to_list (snd (destApp ty)) in
+ let ty' = snd (Util.list_chop nparam ty) in
+ List.fold_left2
+ (fun acc var_as_constr arg ->
+ if isRel var_as_constr
+ then
+ let (na,_,_) =
+ Environ.lookup_rel (destRel var_as_constr) env
+ in
+ match na with
+ | Anonymous -> acc
+ | Name id' ->
+ (id',Detyping.detype false []
+ (Termops.names_of_rel_context env)
+ arg)::acc
+ else if isVar var_as_constr
+ then (destVar var_as_constr,Detyping.detype false []
+ (Termops.names_of_rel_context env)
+ arg)::acc
+ else acc
+ )
+ []
+ arg'
+ ty'
+ | _ -> assert false
+ in
+ let is_in_b = is_free_in id b in
+ let _keep_eq =
+ not (List.exists (is_free_in id) args) || is_in_b ||
+ List.exists (is_free_in id) crossed_types
+ in
+ let new_args =
+ List.fold_left
+ (fun args (id,rt) ->
+ List.map (replace_var_by_term id rt) args
+ )
+ args
+ ((id,rt)::new_args)
+ in
+ let subst_b =
+ if is_in_b then b else replace_var_by_term id rt b
+ in
+ let new_env =
+ let t' = Pretyping.Default.understand Evd.empty env eq' in
+ Environ.push_rel (n,None,t') env
+ in
+ let new_b,id_to_exclude =
+ rebuild_cons
+ new_env
+ nb_args relname
+ new_args new_crossed_types
+ (depth + 1) subst_b
+ in
+ mkRProd(n,eq',new_b),id_to_exclude
+ end
+ (* J.F:. keep this comment it explain how to remove some meaningless equalities
+ if keep_eq then
+ mkRProd(n,t,new_b),id_to_exclude
+ else new_b, Idset.add id id_to_exclude
+ *)
+ | _ ->
+ observe (str "computing new type for prod : " ++ pr_rawconstr rt);
+ let t' = Pretyping.Default.understand Evd.empty env t in
+ let new_env = Environ.push_rel (n,None,t') env in
+ let new_b,id_to_exclude =
+ rebuild_cons new_env
+ nb_args relname
+ args new_crossed_types
+ (depth + 1) b
+ in
+ match n with
+ | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
+ new_b,Idset.remove id
+ (Idset.filter not_free_in_t id_to_exclude)
+ | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+ end
+ | RLambda(_,n,k,t,b) ->
+ begin
+ let not_free_in_t id = not (is_free_in id t) in
+ let new_crossed_types = t :: crossed_types in
+ observe (str "computing new type for lambda : " ++ pr_rawconstr rt);
+ let t' = Pretyping.Default.understand Evd.empty env t in
+ match n with
+ | Name id ->
+ let new_env = Environ.push_rel (n,None,t') env in
+ let new_b,id_to_exclude =
+ rebuild_cons new_env
+ nb_args relname
+ (args@[mkRVar id])new_crossed_types
+ (depth + 1 ) b
+ in
+ if Idset.mem id id_to_exclude && depth >= nb_args
+ then
+ new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
+ else
+ RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude
+ | _ -> anomaly "Should not have an anonymous function here"
+ (* We have renamed all the anonymous functions during alpha_renaming phase *)
+
+ end
+ | RLetIn(_,n,t,b) ->
+ begin
+ let not_free_in_t id = not (is_free_in id t) in
+ let t' = Pretyping.Default.understand Evd.empty env t in
+ let type_t' = Typing.type_of env Evd.empty t' in
+ let new_env = Environ.push_rel (n,Some t',type_t') env in
+ let new_b,id_to_exclude =
+ rebuild_cons new_env
+ nb_args relname
+ args (t::crossed_types)
+ (depth + 1 ) b in
+ match n with
+ | Name id when Idset.mem id id_to_exclude && depth >= nb_args ->
+ new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
+ | _ -> RLetIn(dummy_loc,n,t,new_b),
+ Idset.filter not_free_in_t id_to_exclude
+ end
+ | RLetTuple(_,nal,(na,rto),t,b) ->
+ assert (rto=None);
+ begin
+ let not_free_in_t id = not (is_free_in id t) in
+ let new_t,id_to_exclude' =
+ rebuild_cons env
+ nb_args
+ relname
+ args (crossed_types)
+ depth t
+ in
+ let t' = Pretyping.Default.understand Evd.empty env new_t in
+ let new_env = Environ.push_rel (na,None,t') env in
+ let new_b,id_to_exclude =
+ rebuild_cons new_env
+ nb_args relname
+ args (t::crossed_types)
+ (depth + 1) b
+ in
+(* match n with *)
+(* | Name id when Idset.mem id id_to_exclude -> *)
+(* new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) *)
+(* | _ -> *)
+ RLetTuple(dummy_loc,nal,(na,None),t,new_b),
+ Idset.filter not_free_in_t (Idset.union id_to_exclude id_to_exclude')
+
+ end
+
+ | _ -> mkRApp(mkRVar relname,args@[rt]),Idset.empty
+
+
+(* debuging wrapper *)
+let rebuild_cons env nb_args relname args crossed_types rt =
+(* observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ *)
+(* str "nb_args := " ++ str (string_of_int nb_args)); *)
+ let res =
+ rebuild_cons env nb_args relname args crossed_types 0 rt
+ in
+(* observe (str " leads to "++ pr_rawconstr (fst res)); *)
+ res
+
+
+(* naive implementation of parameter detection.
+
+ A parameter is an argument which is only preceded by parameters and whose
+ calls are all syntaxically equal.
+
+ TODO: Find a valid way to deal with implicit arguments here!
+*)
+let rec compute_cst_params relnames params = function
+ | RRef _ | RVar _ | REvar _ | RPatVar _ -> params
+ | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames ->
+ compute_cst_params_from_app [] (params,rtl)
+ | RApp(_,f,args) ->
+ List.fold_left (compute_cst_params relnames) params (f::args)
+ | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) ->
+ let t_params = compute_cst_params relnames params t in
+ compute_cst_params relnames t_params b
+ | RCases _ ->
+ params (* If there is still cases at this point they can only be
+ discriminitation ones *)
+ | RSort _ -> params
+ | RHole _ -> params
+ | RIf _ | RRec _ | RCast _ | RDynamic _ ->
+ raise (UserError("compute_cst_params", str "Not handled case"))
+and compute_cst_params_from_app acc (params,rtl) =
+ match params,rtl with
+ | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *)
+ | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl'
+ when id_ord id id' == 0 && not is_defined ->
+ compute_cst_params_from_app (param::acc) (params',rtl')
+ | _ -> List.rev acc
+
+let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts =
+ let rels_params =
+ Array.mapi
+ (fun i args ->
+ List.fold_left
+ (fun params (_,cst) -> compute_cst_params relnames params cst)
+ args
+ csts.(i)
+ )
+ args
+ in
+ let l = ref [] in
+ let _ =
+ try
+ list_iter_i
+ (fun i ((n,nt,is_defined) as param) ->
+ if array_for_all
+ (fun l ->
+ let (n',nt',is_defined') = List.nth l i in
+ n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined')
+ rels_params
+ then
+ l := param::!l
+ )
+ rels_params.(0)
+ with _ ->
+ ()
+ in
+ List.rev !l
+
+let rec rebuild_return_type rt =
+ match rt with
+ | Topconstr.CProdN(loc,n,t') ->
+ Topconstr.CProdN(loc,n,rebuild_return_type t')
+ | Topconstr.CArrow(loc,t,t') ->
+ Topconstr.CArrow(loc,t,rebuild_return_type t')
+ | Topconstr.CLetIn(loc,na,t,t') ->
+ Topconstr.CLetIn(loc,na,t,rebuild_return_type t')
+ | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None))
+
+
+let do_build_inductive
+ funnames (funsargs: (Names.name * rawconstr * bool) list list)
+ returned_types
+ (rtl:rawconstr list) =
+ let _time1 = System.get_time () in
+(* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *)
+ let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in
+ let funnames = Array.of_list funnames in
+ let funsargs = Array.of_list funsargs in
+ let returned_types = Array.of_list returned_types in
+ (* alpha_renaming of the body to prevent variable capture during manipulation *)
+ let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in
+ let rta = Array.of_list rtl_alpha in
+ (*i The next call to mk_rel_id is valid since we are constructing the graph
+ Ensures by: obvious
+ i*)
+ let relnames = Array.map mk_rel_id funnames in
+ let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in
+ (* Construction of the pseudo constructors *)
+ let env =
+ Array.fold_right
+ (fun id env ->
+ Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env
+ )
+ funnames
+ (Global.env ())
+ in
+ let resa = Array.map (build_entry_lc env funnames_as_set []) rta in
+ let env_with_graphs =
+ let rel_arity i funargs = (* Reduilding arities (with parameters) *)
+ let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list =
+ funargs
+ in
+ List.fold_right
+ (fun (n,t,is_defined) acc ->
+ if is_defined
+ then
+ Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
+ acc)
+ else
+ Topconstr.CProdN
+ (dummy_loc,
+ [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
+ acc
+ )
+ )
+ rel_first_args
+ (rebuild_return_type returned_types.(i))
+ in
+ (* We need to lift back our work topconstr but only with all information
+ We mimick a Set Printing All.
+ Then save the graphs and reset Printing options to their primitive values
+ *)
+ let rel_arities = Array.mapi rel_arity funsargs in
+ Util.array_fold_left2 (fun env rel_name rel_ar ->
+ Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities
+ in
+ (* and of the real constructors*)
+ let constr i res =
+ List.map
+ (function result (* (args',concl') *) ->
+ let rt = compose_raw_context result.context result.value in
+ let nb_args = List.length funsargs.(i) in
+ (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *)
+ fst (
+ rebuild_cons env_with_graphs nb_args relnames.(i)
+ []
+ []
+ rt
+ )
+ )
+ res.result
+ in
+ (* adding names to constructors *)
+ let next_constructor_id = ref (-1) in
+ let mk_constructor_id i =
+ incr next_constructor_id;
+ (*i The next call to mk_rel_id is valid since we are constructing the graph
+ Ensures by: obvious
+ i*)
+ id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id))
+ in
+ let rel_constructors i rt : (identifier*rawconstr) list =
+ next_constructor_id := (-1);
+ List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt)
+ in
+ let rel_constructors = Array.mapi rel_constructors resa in
+ (* Computing the set of parameters if asked *)
+ let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in
+ let nrel_params = List.length rels_params in
+ let rel_constructors = (* Taking into account the parameters in constructors *)
+ Array.map (List.map
+ (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt))))
+ rel_constructors
+ in
+ let rel_arity i funargs = (* Reduilding arities (with parameters) *)
+ let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list =
+ (snd (list_chop nrel_params funargs))
+ in
+ List.fold_right
+ (fun (n,t,is_defined) acc ->
+ if is_defined
+ then
+ Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t,
+ acc)
+ else
+ Topconstr.CProdN
+ (dummy_loc,
+ [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
+ acc
+ )
+ )
+ rel_first_args
+ (rebuild_return_type returned_types.(i))
+ in
+ (* We need to lift back our work topconstr but only with all information
+ We mimick a Set Printing All.
+ Then save the graphs and reset Printing options to their primitive values
+ *)
+ let rel_arities = Array.mapi rel_arity funsargs in
+ let rel_params =
+ List.map
+ (fun (n,t,is_defined) ->
+ if is_defined
+ then
+ Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t)
+ else
+ Topconstr.LocalRawAssum
+ ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t)
+ )
+ rels_params
+ in
+ let ext_rels_constructors =
+ Array.map (List.map
+ (fun (id,t) ->
+ false,((dummy_loc,id),
+ Flags.with_option
+ Flags.raw_print
+ (Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t)
+ )
+ ))
+ (rel_constructors)
+ in
+ let rel_ind i ext_rel_constructors =
+ ((dummy_loc,relnames.(i)),
+ rel_params,
+ Some rel_arities.(i),
+ ext_rel_constructors),[]
+ in
+ let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in
+ let rel_inds = Array.to_list ext_rel_constructors in
+(* let _ = *)
+(* Pp.msgnl (\* observe *\) ( *)
+(* str "Inductive" ++ spc () ++ *)
+(* prlist_with_sep *)
+(* (fun () -> fnl ()++spc () ++ str "with" ++ spc ()) *)
+(* (function ((_,id),_,params,ar,constr) -> *)
+(* Ppconstr.pr_id id ++ spc () ++ *)
+(* Ppconstr.pr_binders params ++ spc () ++ *)
+(* str ":" ++ spc () ++ *)
+(* Ppconstr.pr_lconstr_expr ar ++ spc () ++ str ":=" ++ *)
+(* prlist_with_sep *)
+(* (fun _ -> fnl () ++ spc () ++ str "|" ++ spc ()) *)
+(* (function (_,((_,id),t)) -> *)
+(* Ppconstr.pr_id id ++ spc () ++ str ":" ++ spc () ++ *)
+(* Ppconstr.pr_lconstr_expr t) *)
+(* constr *)
+(* ) *)
+(* rel_inds *)
+(* ) *)
+(* in *)
+ let _time2 = System.get_time () in
+ try
+ with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds)) true
+ with
+ | UserError(s,msg) as e ->
+ let _time3 = System.get_time () in
+(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
+ let repacked_rel_inds =
+ List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn )
+ rel_inds
+ in
+ let msg =
+ str "while trying to define"++ spc () ++
+ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
+ ++ fnl () ++
+ msg
+ in
+ observe (msg);
+ raise e
+ | e ->
+ let _time3 = System.get_time () in
+(* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *)
+ let repacked_rel_inds =
+ List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn )
+ rel_inds
+ in
+ let msg =
+ str "while trying to define"++ spc () ++
+ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds))
+ ++ fnl () ++
+ Cerrors.explain_exn e
+ in
+ observe msg;
+ raise e
+
+
+
+let build_inductive funnames funsargs returned_types rtl =
+ try
+ do_build_inductive funnames funsargs returned_types rtl
+ with e -> raise (Building_graph e)
+
+
diff --git a/plugins/funind/rawterm_to_relation.mli b/plugins/funind/rawterm_to_relation.mli
new file mode 100644
index 00000000..a314050f
--- /dev/null
+++ b/plugins/funind/rawterm_to_relation.mli
@@ -0,0 +1,16 @@
+
+
+
+(*
+ [build_inductive parametrize funnames funargs returned_types bodies]
+ constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments
+ and returning [returned_types] using bodies [bodies]
+*)
+
+val build_inductive :
+ Names.identifier list -> (* The list of function name *)
+ (Names.name*Rawterm.rawconstr*bool) list list -> (* The list of function args *)
+ Topconstr.constr_expr list -> (* The list of function returned type *)
+ Rawterm.rawconstr list -> (* the list of body *)
+ unit
+
diff --git a/plugins/funind/rawtermops.ml b/plugins/funind/rawtermops.ml
new file mode 100644
index 00000000..e31f1452
--- /dev/null
+++ b/plugins/funind/rawtermops.ml
@@ -0,0 +1,718 @@
+open Pp
+open Rawterm
+open Util
+open Names
+(* Ocaml 3.06 Map.S does not handle is_empty *)
+let idmap_is_empty m = m = Idmap.empty
+
+(*
+ Some basic functions to rebuild rawconstr
+ In each of them the location is Util.dummy_loc
+*)
+let mkRRef ref = RRef(dummy_loc,ref)
+let mkRVar id = RVar(dummy_loc,id)
+let mkRApp(rt,rtl) = RApp(dummy_loc,rt,rtl)
+let mkRLambda(n,t,b) = RLambda(dummy_loc,n,Explicit,t,b)
+let mkRProd(n,t,b) = RProd(dummy_loc,n,Explicit,t,b)
+let mkRLetIn(n,t,b) = RLetIn(dummy_loc,n,t,b)
+let mkRCases(rto,l,brl) = RCases(dummy_loc,Term.RegularStyle,rto,l,brl)
+let mkRSort s = RSort(dummy_loc,s)
+let mkRHole () = RHole(dummy_loc,Evd.BinderType Anonymous)
+let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
+
+(*
+ Some basic functions to decompose rawconstrs
+ These are analogous to the ones constrs
+*)
+let raw_decompose_prod =
+ let rec raw_decompose_prod args = function
+ | RProd(_,n,k,t,b) ->
+ raw_decompose_prod ((n,t)::args) b
+ | rt -> args,rt
+ in
+ raw_decompose_prod []
+
+let raw_decompose_prod_or_letin =
+ let rec raw_decompose_prod args = function
+ | RProd(_,n,k,t,b) ->
+ raw_decompose_prod ((n,None,Some t)::args) b
+ | RLetIn(_,n,t,b) ->
+ raw_decompose_prod ((n,Some t,None)::args) b
+ | rt -> args,rt
+ in
+ raw_decompose_prod []
+
+let raw_compose_prod =
+ List.fold_left (fun b (n,t) -> mkRProd(n,t,b))
+
+let raw_compose_prod_or_letin =
+ List.fold_left (
+ fun concl decl ->
+ match decl with
+ | (n,None,Some t) -> mkRProd(n,t,concl)
+ | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl)
+ | _ -> assert false)
+
+let raw_decompose_prod_n n =
+ let rec raw_decompose_prod i args c =
+ if i<=0 then args,c
+ else
+ match c with
+ | RProd(_,n,_,t,b) ->
+ raw_decompose_prod (i-1) ((n,t)::args) b
+ | rt -> args,rt
+ in
+ raw_decompose_prod n []
+
+
+let raw_decompose_prod_or_letin_n n =
+ let rec raw_decompose_prod i args c =
+ if i<=0 then args,c
+ else
+ match c with
+ | RProd(_,n,_,t,b) ->
+ raw_decompose_prod (i-1) ((n,None,Some t)::args) b
+ | RLetIn(_,n,t,b) ->
+ raw_decompose_prod (i-1) ((n,Some t,None)::args) b
+ | rt -> args,rt
+ in
+ raw_decompose_prod n []
+
+
+let raw_decompose_app =
+ let rec decompose_rapp acc rt =
+(* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *)
+ match rt with
+ | RApp(_,rt,rtl) ->
+ decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt
+ | rt -> rt,List.rev acc
+ in
+ decompose_rapp []
+
+
+
+
+(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *)
+let raw_make_eq ?(typ= mkRHole ()) t1 t2 =
+ mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1])
+
+(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *)
+let raw_make_neq t1 t2 =
+ mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2])
+
+(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *)
+let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2])
+
+(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding
+ to [P1 \/ ( .... \/ Pn)]
+*)
+let rec raw_make_or_list = function
+ | [] -> raise (Invalid_argument "mk_or")
+ | [e] -> e
+ | e::l -> raw_make_or e (raw_make_or_list l)
+
+
+let remove_name_from_mapping mapping na =
+ match na with
+ | Anonymous -> mapping
+ | Name id -> Idmap.remove id mapping
+
+let change_vars =
+ let rec change_vars mapping rt =
+ match rt with
+ | RRef _ -> rt
+ | RVar(loc,id) ->
+ let new_id =
+ try
+ Idmap.find id mapping
+ with Not_found -> id
+ in
+ RVar(loc,new_id)
+ | REvar _ -> rt
+ | RPatVar _ -> rt
+ | RApp(loc,rt',rtl) ->
+ RApp(loc,
+ change_vars mapping rt',
+ List.map (change_vars mapping) rtl
+ )
+ | RLambda(loc,name,k,t,b) ->
+ RLambda(loc,
+ name,
+ k,
+ change_vars mapping t,
+ change_vars (remove_name_from_mapping mapping name) b
+ )
+ | RProd(loc,name,k,t,b) ->
+ RProd(loc,
+ name,
+ k,
+ change_vars mapping t,
+ change_vars (remove_name_from_mapping mapping name) b
+ )
+ | RLetIn(loc,name,def,b) ->
+ RLetIn(loc,
+ name,
+ change_vars mapping def,
+ change_vars (remove_name_from_mapping mapping name) b
+ )
+ | RLetTuple(loc,nal,(na,rto),b,e) ->
+ let new_mapping = List.fold_left remove_name_from_mapping mapping nal in
+ RLetTuple(loc,
+ nal,
+ (na, Option.map (change_vars mapping) rto),
+ change_vars mapping b,
+ change_vars new_mapping e
+ )
+ | RCases(loc,sty,infos,el,brl) ->
+ RCases(loc,sty,
+ infos,
+ List.map (fun (e,x) -> (change_vars mapping e,x)) el,
+ List.map (change_vars_br mapping) brl
+ )
+ | RIf(loc,b,(na,e_option),lhs,rhs) ->
+ RIf(loc,
+ change_vars mapping b,
+ (na,Option.map (change_vars mapping) e_option),
+ change_vars mapping lhs,
+ change_vars mapping rhs
+ )
+ | RRec _ -> error "Local (co)fixes are not supported"
+ | RSort _ -> rt
+ | RHole _ -> rt
+ | RCast(loc,b,CastConv (k,t)) ->
+ RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t))
+ | RCast(loc,b,CastCoerce) ->
+ RCast(loc,change_vars mapping b,CastCoerce)
+ | RDynamic _ -> error "Not handled RDynamic"
+ and change_vars_br mapping ((loc,idl,patl,res) as br) =
+ let new_mapping = List.fold_right Idmap.remove idl mapping in
+ if idmap_is_empty new_mapping
+ then br
+ else (loc,idl,patl,change_vars new_mapping res)
+ in
+ change_vars
+
+
+
+let rec alpha_pat excluded pat =
+ match pat with
+ | PatVar(loc,Anonymous) ->
+ let new_id = Indfun_common.fresh_id excluded "_x" in
+ PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty
+ | PatVar(loc,Name id) ->
+ if List.mem id excluded
+ then
+ let new_id = Namegen.next_ident_away id excluded in
+ PatVar(loc,Name new_id),(new_id::excluded),
+ (Idmap.add id new_id Idmap.empty)
+ else pat,excluded,Idmap.empty
+ | PatCstr(loc,constr,patl,na) ->
+ let new_na,new_excluded,map =
+ match na with
+ | Name id when List.mem id excluded ->
+ let new_id = Namegen.next_ident_away id excluded in
+ Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty
+ | _ -> na,excluded,Idmap.empty
+ in
+ let new_patl,new_excluded,new_map =
+ List.fold_left
+ (fun (patl,excluded,map) pat ->
+ let new_pat,new_excluded,new_map = alpha_pat excluded pat in
+ (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map)
+ )
+ ([],new_excluded,map)
+ patl
+ in
+ PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map
+
+let alpha_patl excluded patl =
+ let patl,new_excluded,map =
+ List.fold_left
+ (fun (patl,excluded,map) pat ->
+ let new_pat,new_excluded,new_map = alpha_pat excluded pat in
+ new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map)
+ )
+ ([],excluded,Idmap.empty)
+ patl
+ in
+ (List.rev patl,new_excluded,map)
+
+
+
+
+let raw_get_pattern_id pat acc =
+ let rec get_pattern_id pat =
+ match pat with
+ | PatVar(loc,Anonymous) -> assert false
+ | PatVar(loc,Name id) ->
+ [id]
+ | PatCstr(loc,constr,patternl,_) ->
+ List.fold_right
+ (fun pat idl ->
+ let idl' = get_pattern_id pat in
+ idl'@idl
+ )
+ patternl
+ []
+ in
+ (get_pattern_id pat)@acc
+
+let get_pattern_id pat = raw_get_pattern_id pat []
+
+let rec alpha_rt excluded rt =
+ let new_rt =
+ match rt with
+ | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt
+ | RLambda(loc,Anonymous,k,t,b) ->
+ let new_id = Namegen.next_ident_away (id_of_string "_x") excluded in
+ let new_excluded = new_id :: excluded in
+ let new_t = alpha_rt new_excluded t in
+ let new_b = alpha_rt new_excluded b in
+ RLambda(loc,Name new_id,k,new_t,new_b)
+ | RProd(loc,Anonymous,k,t,b) ->
+ let new_t = alpha_rt excluded t in
+ let new_b = alpha_rt excluded b in
+ RProd(loc,Anonymous,k,new_t,new_b)
+ | RLetIn(loc,Anonymous,t,b) ->
+ let new_t = alpha_rt excluded t in
+ let new_b = alpha_rt excluded b in
+ RLetIn(loc,Anonymous,new_t,new_b)
+ | RLambda(loc,Name id,k,t,b) ->
+ let new_id = Namegen.next_ident_away id excluded in
+ let t,b =
+ if new_id = id
+ then t,b
+ else
+ let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+ (t,replace b)
+ in
+ let new_excluded = new_id::excluded in
+ let new_t = alpha_rt new_excluded t in
+ let new_b = alpha_rt new_excluded b in
+ RLambda(loc,Name new_id,k,new_t,new_b)
+ | RProd(loc,Name id,k,t,b) ->
+ let new_id = Namegen.next_ident_away id excluded in
+ let new_excluded = new_id::excluded in
+ let t,b =
+ if new_id = id
+ then t,b
+ else
+ let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+ (t,replace b)
+ in
+ let new_t = alpha_rt new_excluded t in
+ let new_b = alpha_rt new_excluded b in
+ RProd(loc,Name new_id,k,new_t,new_b)
+ | RLetIn(loc,Name id,t,b) ->
+ let new_id = Namegen.next_ident_away id excluded in
+ let t,b =
+ if new_id = id
+ then t,b
+ else
+ let replace = change_vars (Idmap.add id new_id Idmap.empty) in
+ (t,replace b)
+ in
+ let new_excluded = new_id::excluded in
+ let new_t = alpha_rt new_excluded t in
+ let new_b = alpha_rt new_excluded b in
+ RLetIn(loc,Name new_id,new_t,new_b)
+
+
+ | RLetTuple(loc,nal,(na,rto),t,b) ->
+ let rev_new_nal,new_excluded,mapping =
+ List.fold_left
+ (fun (nal,excluded,mapping) na ->
+ match na with
+ | Anonymous -> (na::nal,excluded,mapping)
+ | Name id ->
+ let new_id = Namegen.next_ident_away id excluded in
+ if new_id = id
+ then
+ na::nal,id::excluded,mapping
+ else
+ (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping)
+ )
+ ([],excluded,Idmap.empty)
+ nal
+ in
+ let new_nal = List.rev rev_new_nal in
+ let new_rto,new_t,new_b =
+ if idmap_is_empty mapping
+ then rto,t,b
+ else let replace = change_vars mapping in
+ (Option.map replace rto, t,replace b)
+ in
+ let new_t = alpha_rt new_excluded new_t in
+ let new_b = alpha_rt new_excluded new_b in
+ let new_rto = Option.map (alpha_rt new_excluded) new_rto in
+ RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b)
+ | RCases(loc,sty,infos,el,brl) ->
+ let new_el =
+ List.map (function (rt,i) -> alpha_rt excluded rt, i) el
+ in
+ RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl)
+ | RIf(loc,b,(na,e_o),lhs,rhs) ->
+ RIf(loc,alpha_rt excluded b,
+ (na,Option.map (alpha_rt excluded) e_o),
+ alpha_rt excluded lhs,
+ alpha_rt excluded rhs
+ )
+ | RRec _ -> error "Not handled RRec"
+ | RSort _ -> rt
+ | RHole _ -> rt
+ | RCast (loc,b,CastConv (k,t)) ->
+ RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t))
+ | RCast (loc,b,CastCoerce) ->
+ RCast(loc,alpha_rt excluded b,CastCoerce)
+ | RDynamic _ -> error "Not handled RDynamic"
+ | RApp(loc,f,args) ->
+ RApp(loc,
+ alpha_rt excluded f,
+ List.map (alpha_rt excluded) args
+ )
+ in
+ new_rt
+
+and alpha_br excluded (loc,ids,patl,res) =
+ let new_patl,new_excluded,mapping = alpha_patl excluded patl in
+ let new_ids = List.fold_right raw_get_pattern_id new_patl [] in
+ let new_excluded = new_ids@excluded in
+ let renamed_res = change_vars mapping res in
+ let new_res = alpha_rt new_excluded renamed_res in
+ (loc,new_ids,new_patl,new_res)
+
+(*
+ [is_free_in id rt] checks if [id] is a free variable in [rt]
+*)
+let is_free_in id =
+ let rec is_free_in = function
+ | RRef _ -> false
+ | RVar(_,id') -> id_ord id' id == 0
+ | REvar _ -> false
+ | RPatVar _ -> false
+ | RApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl)
+ | RLambda(_,n,_,t,b) | RProd(_,n,_,t,b) | RLetIn(_,n,t,b) ->
+ let check_in_b =
+ match n with
+ | Name id' -> id_ord id' id <> 0
+ | _ -> true
+ in
+ is_free_in t || (check_in_b && is_free_in b)
+ | RCases(_,_,_,el,brl) ->
+ (List.exists (fun (e,_) -> is_free_in e) el) ||
+ List.exists is_free_in_br brl
+ | RLetTuple(_,nal,_,b,t) ->
+ let check_in_nal =
+ not (List.exists (function Name id' -> id'= id | _ -> false) nal)
+ in
+ is_free_in t || (check_in_nal && is_free_in b)
+
+ | RIf(_,cond,_,br1,br2) ->
+ is_free_in cond || is_free_in br1 || is_free_in br2
+ | RRec _ -> raise (UserError("",str "Not handled RRec"))
+ | RSort _ -> false
+ | RHole _ -> false
+ | RCast (_,b,CastConv (_,t)) -> is_free_in b || is_free_in t
+ | RCast (_,b,CastCoerce) -> is_free_in b
+ | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+ and is_free_in_br (_,ids,_,rt) =
+ (not (List.mem id ids)) && is_free_in rt
+ in
+ is_free_in
+
+
+
+let rec pattern_to_term = function
+ | PatVar(loc,Anonymous) -> assert false
+ | PatVar(loc,Name id) ->
+ mkRVar id
+ | PatCstr(loc,constr,patternl,_) ->
+ let cst_narg =
+ Inductiveops.mis_constructor_nargs_env
+ (Global.env ())
+ constr
+ in
+ let implicit_args =
+ Array.to_list
+ (Array.init
+ (cst_narg - List.length patternl)
+ (fun _ -> mkRHole ())
+ )
+ in
+ let patl_as_term =
+ List.map pattern_to_term patternl
+ in
+ mkRApp(mkRRef(Libnames.ConstructRef constr),
+ implicit_args@patl_as_term
+ )
+
+
+
+let replace_var_by_term x_id term =
+ let rec replace_var_by_pattern rt =
+ match rt with
+ | RRef _ -> rt
+ | RVar(_,id) when id_ord id x_id == 0 -> term
+ | RVar _ -> rt
+ | REvar _ -> rt
+ | RPatVar _ -> rt
+ | RApp(loc,rt',rtl) ->
+ RApp(loc,
+ replace_var_by_pattern rt',
+ List.map replace_var_by_pattern rtl
+ )
+ | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+ | RLambda(loc,name,k,t,b) ->
+ RLambda(loc,
+ name,
+ k,
+ replace_var_by_pattern t,
+ replace_var_by_pattern b
+ )
+ | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt
+ | RProd(loc,name,k,t,b) ->
+ RProd(loc,
+ name,
+ k,
+ replace_var_by_pattern t,
+ replace_var_by_pattern b
+ )
+ | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt
+ | RLetIn(loc,name,def,b) ->
+ RLetIn(loc,
+ name,
+ replace_var_by_pattern def,
+ replace_var_by_pattern b
+ )
+ | RLetTuple(_,nal,_,_,_)
+ when List.exists (function Name id -> id = x_id | _ -> false) nal ->
+ rt
+ | RLetTuple(loc,nal,(na,rto),def,b) ->
+ RLetTuple(loc,
+ nal,
+ (na,Option.map replace_var_by_pattern rto),
+ replace_var_by_pattern def,
+ replace_var_by_pattern b
+ )
+ | RCases(loc,sty,infos,el,brl) ->
+ RCases(loc,sty,
+ infos,
+ List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el,
+ List.map replace_var_by_pattern_br brl
+ )
+ | RIf(loc,b,(na,e_option),lhs,rhs) ->
+ RIf(loc, replace_var_by_pattern b,
+ (na,Option.map replace_var_by_pattern e_option),
+ replace_var_by_pattern lhs,
+ replace_var_by_pattern rhs
+ )
+ | RRec _ -> raise (UserError("",str "Not handled RRec"))
+ | RSort _ -> rt
+ | RHole _ -> rt
+ | RCast(loc,b,CastConv(k,t)) ->
+ RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t))
+ | RCast(loc,b,CastCoerce) ->
+ RCast(loc,replace_var_by_pattern b,CastCoerce)
+ | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+ and replace_var_by_pattern_br ((loc,idl,patl,res) as br) =
+ if List.exists (fun id -> id_ord id x_id == 0) idl
+ then br
+ else (loc,idl,patl,replace_var_by_pattern res)
+ in
+ replace_var_by_pattern
+
+
+
+
+(* checking unifiability of patterns *)
+exception NotUnifiable
+
+let rec are_unifiable_aux = function
+ | [] -> ()
+ | eq::eqs ->
+ match eq with
+ | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs
+ | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
+ if constructor2 <> constructor1
+ then raise NotUnifiable
+ else
+ let eqs' =
+ try ((List.combine cpl1 cpl2)@eqs)
+ with _ -> anomaly "are_unifiable_aux"
+ in
+ are_unifiable_aux eqs'
+
+let are_unifiable pat1 pat2 =
+ try
+ are_unifiable_aux [pat1,pat2];
+ true
+ with NotUnifiable -> false
+
+
+let rec eq_cases_pattern_aux = function
+ | [] -> ()
+ | eq::eqs ->
+ match eq with
+ | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs
+ | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) ->
+ if constructor2 <> constructor1
+ then raise NotUnifiable
+ else
+ let eqs' =
+ try ((List.combine cpl1 cpl2)@eqs)
+ with _ -> anomaly "eq_cases_pattern_aux"
+ in
+ eq_cases_pattern_aux eqs'
+ | _ -> raise NotUnifiable
+
+let eq_cases_pattern pat1 pat2 =
+ try
+ eq_cases_pattern_aux [pat1,pat2];
+ true
+ with NotUnifiable -> false
+
+
+
+let ids_of_pat =
+ let rec ids_of_pat ids = function
+ | PatVar(_,Anonymous) -> ids
+ | PatVar(_,Name id) -> Idset.add id ids
+ | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl
+ in
+ ids_of_pat Idset.empty
+
+let id_of_name = function
+ | Names.Anonymous -> id_of_string "x"
+ | Names.Name x -> x
+
+(* TODO: finish Rec caes *)
+let ids_of_rawterm c =
+ let rec ids_of_rawterm acc c =
+ let idof = id_of_name in
+ match c with
+ | RVar (_,id) -> id::acc
+ | RApp (loc,g,args) ->
+ ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc
+ | RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
+ | RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
+ | RLetIn (loc,na,b,c) -> idof na :: ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
+ | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc
+ | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc
+ | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc
+ | RLetTuple (_,nal,(na,po),b,c) ->
+ List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc
+ | RCases (loc,sty,rtntypopt,tml,brchl) ->
+ List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl)
+ | RRec _ -> failwith "Fix inside a constructor branch"
+ | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> []
+ in
+ (* build the set *)
+ List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c)
+
+
+
+
+
+let zeta_normalize =
+ let rec zeta_normalize_term rt =
+ match rt with
+ | RRef _ -> rt
+ | RVar _ -> rt
+ | REvar _ -> rt
+ | RPatVar _ -> rt
+ | RApp(loc,rt',rtl) ->
+ RApp(loc,
+ zeta_normalize_term rt',
+ List.map zeta_normalize_term rtl
+ )
+ | RLambda(loc,name,k,t,b) ->
+ RLambda(loc,
+ name,
+ k,
+ zeta_normalize_term t,
+ zeta_normalize_term b
+ )
+ | RProd(loc,name,k,t,b) ->
+ RProd(loc,
+ name,
+ k,
+ zeta_normalize_term t,
+ zeta_normalize_term b
+ )
+ | RLetIn(_,Name id,def,b) ->
+ zeta_normalize_term (replace_var_by_term id def b)
+ | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b
+ | RLetTuple(loc,nal,(na,rto),def,b) ->
+ RLetTuple(loc,
+ nal,
+ (na,Option.map zeta_normalize_term rto),
+ zeta_normalize_term def,
+ zeta_normalize_term b
+ )
+ | RCases(loc,sty,infos,el,brl) ->
+ RCases(loc,sty,
+ infos,
+ List.map (fun (e,x) -> (zeta_normalize_term e,x)) el,
+ List.map zeta_normalize_br brl
+ )
+ | RIf(loc,b,(na,e_option),lhs,rhs) ->
+ RIf(loc, zeta_normalize_term b,
+ (na,Option.map zeta_normalize_term e_option),
+ zeta_normalize_term lhs,
+ zeta_normalize_term rhs
+ )
+ | RRec _ -> raise (UserError("",str "Not handled RRec"))
+ | RSort _ -> rt
+ | RHole _ -> rt
+ | RCast(loc,b,CastConv(k,t)) ->
+ RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t))
+ | RCast(loc,b,CastCoerce) ->
+ RCast(loc,zeta_normalize_term b,CastCoerce)
+ | RDynamic _ -> raise (UserError("",str "Not handled RDynamic"))
+ and zeta_normalize_br (loc,idl,patl,res) =
+ (loc,idl,patl,zeta_normalize_term res)
+ in
+ zeta_normalize_term
+
+
+
+
+let expand_as =
+
+ let rec add_as map pat =
+ match pat with
+ | PatVar _ -> map
+ | PatCstr(_,_,patl,Name id) ->
+ Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl)
+ | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl
+ in
+ let rec expand_as map rt =
+ match rt with
+ | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt
+ | RVar(_,id) ->
+ begin
+ try
+ Idmap.find id map
+ with Not_found -> rt
+ end
+ | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args)
+ | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b)
+ | RProd(loc,na,k,t,b) -> RProd(loc,na,k,expand_as map t, expand_as map b)
+ | RLetIn(loc,na,v,b) -> RLetIn(loc,na, expand_as map v,expand_as map b)
+ | RLetTuple(loc,nal,(na,po),v,b) ->
+ RLetTuple(loc,nal,(na,Option.map (expand_as map) po),
+ expand_as map v, expand_as map b)
+ | RIf(loc,e,(na,po),br1,br2) ->
+ RIf(loc,expand_as map e,(na,Option.map (expand_as map) po),
+ expand_as map br1, expand_as map br2)
+ | RRec _ -> error "Not handled RRec"
+ | RDynamic _ -> error "Not handled RDynamic"
+ | RCast(loc,b,CastConv(kind,t)) -> RCast(loc,expand_as map b,CastConv(kind,expand_as map t))
+ | RCast(loc,b,CastCoerce) -> RCast(loc,expand_as map b,CastCoerce)
+ | RCases(loc,sty,po,el,brl) ->
+ RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
+ List.map (expand_as_br map) brl)
+ and expand_as_br map (loc,idl,cpl,rt) =
+ (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
+ in
+ expand_as Idmap.empty
diff --git a/plugins/funind/rawtermops.mli b/plugins/funind/rawtermops.mli
new file mode 100644
index 00000000..455e7c89
--- /dev/null
+++ b/plugins/funind/rawtermops.mli
@@ -0,0 +1,126 @@
+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
new file mode 100644
index 00000000..3b0b8628
--- /dev/null
+++ b/plugins/funind/recdef.ml
@@ -0,0 +1,1473 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Term
+open Termops
+open Namegen
+open Environ
+open Declarations
+open Entries
+open Pp
+open Names
+open Libnames
+open Nameops
+open Util
+open Closure
+open RedFlags
+open Tacticals
+open Typing
+open Tacmach
+open Tactics
+open Nametab
+open Decls
+open Declare
+open Decl_kinds
+open Tacred
+open Proof_type
+open Vernacinterp
+open Pfedit
+open Topconstr
+open Rawterm
+open Pretyping
+open Pretyping.Default
+open Safe_typing
+open Constrintern
+open Hiddentac
+
+open Equality
+open Auto
+open Eauto
+
+open Genarg
+
+
+let compute_renamed_type gls c =
+ rename_bound_vars_as_displayed [] (pf_type_of gls c)
+
+let qed () = Lemmas.save_named true
+let defined () = Lemmas.save_named false
+
+let pf_get_new_ids idl g =
+ let ids = pf_ids_of_hyps g in
+ List.fold_right
+ (fun id acc -> next_global_ident_away id (acc@ids)::acc)
+ idl
+ []
+
+let pf_get_new_id id g =
+ List.hd (pf_get_new_ids [id] g)
+
+let h_intros l =
+ tclMAP h_intro l
+
+let debug_queue = Queue.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
+ begin
+ print_debug_queue e;
+ msgnl (str " from " ++ lmsg ++ str " on goal " ++ goal);
+ 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;
+ try
+ let v = tac g in
+ ignore(Queue.pop debug_queue);
+ v
+ with e ->
+ if not (Queue.is_empty debug_queue)
+ then
+ print_debug_queue e;
+ raise e
+
+(*let do_observe_tac s tac g =
+ let goal = begin (Printer.pr_goal (sig_it g)) end in
+ try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++
+ (str s)++(str " ")++(str "finished")); v
+ with e ->
+ msgnl (str "observation "++str s++str " raised exception " ++
+ Cerrors.explain_exn e ++ str " on goal " ++ goal );
+ raise e;;
+*)
+
+let observe_tac s tac g =
+ if Tacinterp.get_debug () <> Tactic_debug.DebugOff
+ then do_observe_tac s tac g
+ else tac g
+
+let hyp_ids = List.map id_of_string
+ ["x";"v";"k";"def";"p";"h";"n";"h'"; "anonymous"; "teq"; "rec_res";
+ "hspec";"heq"; "hrec"; "hex"; "teq"; "pmax";"hle"];;
+
+let rec nthtl = function
+ l, 0 -> l | _::tl, n -> nthtl (tl, n-1) | [], _ -> [];;
+
+let hyp_id n l = List.nth l n;;
+
+let (x_id:identifier) = hyp_id 0 hyp_ids;;
+let (v_id:identifier) = hyp_id 1 hyp_ids;;
+let (k_id:identifier) = hyp_id 2 hyp_ids;;
+let (def_id:identifier) = hyp_id 3 hyp_ids;;
+let (p_id:identifier) = hyp_id 4 hyp_ids;;
+let (h_id:identifier) = hyp_id 5 hyp_ids;;
+let (n_id:identifier) = hyp_id 6 hyp_ids;;
+let (h'_id:identifier) = hyp_id 7 hyp_ids;;
+let (ano_id:identifier) = hyp_id 8 hyp_ids;;
+let (rec_res_id:identifier) = hyp_id 10 hyp_ids;;
+let (hspec_id:identifier) = hyp_id 11 hyp_ids;;
+let (heq_id:identifier) = hyp_id 12 hyp_ids;;
+let (hrec_id:identifier) = hyp_id 13 hyp_ids;;
+let (hex_id:identifier) = hyp_id 14 hyp_ids;;
+let (teq_id:identifier) = hyp_id 15 hyp_ids;;
+let (pmax_id:identifier) = hyp_id 16 hyp_ids;;
+let (hle_id:identifier) = hyp_id 17 hyp_ids;;
+
+let message s = if Flags.is_verbose () then msgnl(str s);;
+
+let def_of_const t =
+ match (kind_of_term t) with
+ Const sp ->
+ (try (match (Global.lookup_constant sp) with
+ {const_body=Some c} -> Declarations.force c
+ |_ -> assert false)
+ with _ ->
+ anomaly ("Cannot find definition of constant "^
+ (string_of_id (id_of_label (con_label sp))))
+ )
+ |_ -> assert false
+
+let type_of_const t =
+ match (kind_of_term t) with
+ Const sp -> Typeops.type_of_constant (Global.env()) sp
+ |_ -> assert false
+
+let arg_type t =
+ match kind_of_term (def_of_const t) with
+ Lambda(a,b,c) -> b
+ | _ -> assert false;;
+
+let evaluable_of_global_reference r =
+ match r with
+ ConstRef sp -> EvalConstRef sp
+ | VarRef id -> EvalVarRef id
+ | _ -> assert false;;
+
+
+let rank_for_arg_list h =
+ let predicate a b =
+ try List.for_all2 eq_constr a b with
+ Invalid_argument _ -> false in
+ let rec rank_aux i = function
+ | [] -> None
+ | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
+ rank_aux 0;;
+
+let rec (find_call_occs : int -> constr -> constr ->
+ (constr list -> constr) * constr list list) =
+ fun nb_lam f expr ->
+ match (kind_of_term expr) with
+ App (g, args) when g = f ->
+ (fun l -> List.hd l), [Array.to_list args]
+ | App (g, args) ->
+ let (largs: constr list) = Array.to_list args in
+ let rec find_aux = function
+ [] -> (fun x -> []), []
+ | 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
+ cf2, (_ :: _ as other_args) ->
+ let rec avoid_duplicates args =
+ match args with
+ | [] -> (fun _ -> []), []
+ | h::tl ->
+ let recomb_tl, args_for_tl =
+ avoid_duplicates tl in
+ match rank_for_arg_list h args_for_upper_tl with
+ | None ->
+ (fun l -> List.hd l::recomb_tl(List.tl l)),
+ h::args_for_tl
+ | Some i ->
+ (fun l -> List.nth l (i+List.length args_for_tl)::
+ recomb_tl l),
+ args_for_tl
+ in
+ let recombine, other_args' =
+ avoid_duplicates other_args in
+ let len1 = List.length other_args' in
+ (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))),
+ other_args'@args_for_upper_tl
+ | _, [] -> (fun x -> a::cf x), args_for_upper_tl)
+ | _, [] ->
+ (match find_call_occs nb_lam f a with
+ cf, (arg1::args) -> (fun l -> cf l::upper_tl), (arg1::args)
+ | _, [] -> (fun x -> a::upper_tl), [])) in
+ begin
+ match (find_aux largs) with
+ cf, [] -> (fun l -> mkApp(g, args)), []
+ | cf, args ->
+ (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(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
+ | Prod(_,_,_) -> error "find_call_occs : Prod"
+ | Lambda(na,t,b) ->
+ begin
+ match find_call_occs (succ nb_lam) f b with
+ | _, [] -> (* Lambda are authorized as long as they do not contain
+ recursives calls *)
+ (fun l -> expr),[]
+ | _ -> error "find_call_occs : Lambda"
+ end
+ | LetIn(na,v,t,b) ->
+ begin
+ match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with
+ | (_,[]),(_,[]) ->
+ ((fun l -> expr), [])
+ | (_,[]),(cf,(_::_ as l)) ->
+ ((fun l -> mkLetIn(na,v,t,cf l)),l)
+ | (cf,(_::_ as l)),(_,[]) ->
+ ((fun l -> mkLetIn(na,cf l,t,b)), l)
+ | _ -> error "find_call_occs : LetIn"
+ end
+ | Const(_) -> (fun l -> expr), []
+ | Ind(_) -> (fun l -> expr), []
+ | Construct (_, _) -> (fun l -> expr), []
+ | Case(i,t,a,r) ->
+ (match find_call_occs nb_lam f a with
+ cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
+ | _ -> (fun l -> expr),[])
+ | Fix(_) -> error "find_call_occs : Fix"
+ | CoFix(_) -> error "find_call_occs : CoFix";;
+
+let coq_constant s =
+ Coqlib.gen_constant_in_modules "RecursiveDefinition"
+ (Coqlib.init_modules @ Coqlib.arith_modules) s;;
+
+let coq_base_constant s =
+ Coqlib.gen_constant_in_modules "RecursiveDefinition"
+ (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s;;
+
+let constant sl s =
+ constr_of_global
+ (locate (make_qualid(Names.make_dirpath
+ (List.map id_of_string (List.rev sl)))
+ (id_of_string s)));;
+
+let find_reference sl s =
+ (locate (make_qualid(Names.make_dirpath
+ (List.map id_of_string (List.rev sl)))
+ (id_of_string s)));;
+
+let delayed_force f = f ()
+
+let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS")
+let le_lt_n_Sm = function () -> (coq_base_constant "le_lt_n_Sm")
+
+let le_trans = function () -> (coq_base_constant "le_trans")
+let le_lt_trans = function () -> (coq_base_constant "le_lt_trans")
+let lt_S_n = function () -> (coq_base_constant "lt_S_n")
+let le_n = function () -> (coq_base_constant "le_n")
+let refl_equal = function () -> (coq_base_constant "eq_refl")
+let eq = function () -> (coq_base_constant "eq")
+let ex = function () -> (coq_base_constant "ex")
+let coq_sig_ref = function () -> (find_reference ["Coq";"Init";"Specif"] "sig")
+let coq_sig = function () -> (coq_base_constant "sig")
+let coq_O = function () -> (coq_base_constant "O")
+let coq_S = function () -> (coq_base_constant "S")
+
+let gt_antirefl = function () -> (coq_constant "gt_irrefl")
+let lt_n_O = function () -> (coq_base_constant "lt_n_O")
+let lt_n_Sn = function () -> (coq_base_constant "lt_n_Sn")
+
+let f_equal = function () -> (coq_constant "f_equal")
+let well_founded_induction = function () -> (coq_constant "well_founded_induction")
+let well_founded = function () -> (coq_constant "well_founded")
+let acc_rel = function () -> (coq_constant "Acc")
+let acc_inv_id = function () -> (coq_constant "Acc_inv")
+let well_founded_ltof = function () -> (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof")
+let iter_ref = function () -> (try find_reference ["Recdef"] "iter" with Not_found -> error "module Recdef not loaded")
+let max_ref = function () -> (find_reference ["Recdef"] "max")
+let iter = function () -> (constr_of_global (delayed_force iter_ref))
+let max_constr = function () -> (constr_of_global (delayed_force max_ref))
+
+let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof")
+let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj"
+
+(* These are specific to experiments in nat with lt as well_founded_relation, *)
+(* but this should be made more general. *)
+let nat = function () -> (coq_base_constant "nat")
+let lt = function () -> (coq_base_constant "lt")
+
+(* This is simply an implementation of the case_eq tactic. this code
+ should be replaced with the tactic defined in Ltac in Init/Tactics.v *)
+let mkCaseEq a : tactic =
+ (fun g ->
+ let type_of_a = pf_type_of g a in
+ tclTHENLIST
+ [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])];
+ (fun g2 ->
+ change_in_concl None
+ (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2))
+ g2);
+ simplest_case a] g);;
+
+(* This is like the previous one except that it also rewrite on all
+ hypotheses except the ones given in the first argument. All the
+ modified hypotheses are generalized in the process and should be
+ introduced back later; the result is the pair of the tactic and the
+ list of hypotheses that have been generalized and cleared. *)
+let mkDestructEq :
+ identifier list -> constr -> goal sigma -> tactic * identifier list =
+ fun not_on_hyp expr g ->
+ let hyps = pf_hyps g in
+ let to_revert =
+ Util.map_succeed
+ (fun (id,_,t) ->
+ if List.mem id not_on_hyp || not (Termops.occur_term expr t)
+ then failwith "is_expr_context";
+ id) hyps in
+ let to_revert_constr = List.rev_map mkVar to_revert in
+ let type_of_expr = pf_type_of g expr in
+ let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|])::
+ to_revert_constr in
+ tclTHENLIST
+ [h_generalize new_hyps;
+ (fun g2 ->
+ change_in_concl None
+ (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2);
+ simplest_case expr], to_revert
+
+let rec mk_intros_and_continue thin_intros (extra_eqn:bool)
+ cont_function (eqs:constr list) nb_lam (expr:constr) g =
+ observe_tac "mk_intros_and_continue" (
+ let finalize () = if extra_eqn then
+ let teq = pf_get_new_id teq_id g in
+ tclTHENLIST
+ [ h_intro teq;
+ thin thin_intros;
+ h_intros thin_intros;
+
+ tclMAP
+ (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences (* 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
+ args.(1),args.(2)
+ in
+ cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1
+ )
+ ]
+
+ else
+ tclTHENSEQ[
+ thin thin_intros;
+ h_intros thin_intros;
+ cont_function eqs expr
+ ]
+ in
+ if nb_lam = 0
+ then finalize ()
+ else
+ match kind_of_term expr with
+ | Lambda (n, _, b) ->
+ let n1 =
+ match n with
+ Name x -> x
+ | Anonymous -> ano_id
+ in
+ let new_n = pf_get_new_id n1 g in
+ tclTHEN (h_intro new_n)
+ (mk_intros_and_continue thin_intros extra_eqn cont_function eqs
+ (pred nb_lam) (subst1 (mkVar new_n) b))
+ | _ ->
+ assert false) g
+(* finalize () *)
+let const_of_ref = function
+ ConstRef kn -> kn
+ | _ -> anomaly "ConstRef expected"
+
+let simpl_iter clause =
+ reduce
+ (Lazy
+ {rBeta=true;rIota=true;rZeta= true; rDelta=false;
+ rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
+(* (Simpl (Some ([],mkConst (const_of_ref (delayed_force iter_ref))))) *)
+ clause
+
+(* The boolean value is_mes expresses that the termination is expressed
+ using a measure function instead of a well-founded relation. *)
+let tclUSER tac is_mes l g =
+ let clear_tac =
+ match l with
+ | None -> h_clear true []
+ | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l)
+ in
+ tclTHENSEQ
+ [
+ clear_tac;
+ if is_mes
+ then tclTHEN
+ (unfold_in_concl [(all_occurrences, evaluable_of_global_reference
+ (delayed_force ltof_ref))])
+ tac
+ else tac
+ ]
+ g
+
+
+let list_rewrite (rev:bool) (eqs: constr list) =
+ tclREPEAT
+ (List.fold_right
+ (fun eq i -> tclORELSE (rewriteLR eq) i)
+ (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));;
+
+let base_leaf_terminate (func:global_reference) eqs expr =
+(* let _ = msgnl (str "entering base_leaf") in *)
+ (fun g ->
+ let k',h =
+ match pf_get_new_ids [k_id;h_id] g with
+ [k';h] -> k',h
+ | _ -> assert false
+ in
+ tclTHENLIST
+ [observe_tac "first split" (split (ImplicitBindings [expr]));
+ observe_tac "second split"
+ (split (ImplicitBindings [delayed_force coq_O]));
+ observe_tac "intro k" (h_intro k');
+ observe_tac "case on k"
+ (tclTHENS (simplest_case (mkVar k'))
+ [(tclTHEN (h_intro h)
+ (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl,
+ [| delayed_force coq_O |])))
+ default_auto)); tclIDTAC ]);
+ intros;
+ simpl_iter onConcl;
+ unfold_constr func;
+ list_rewrite true eqs;
+ default_auto] g);;
+
+(* La fonction est donnee en premier argument a la
+ fonctionnelle suivie d'autres Lambdas et de Case ...
+ Pour recuperer la fonction f a partir de la
+ fonctionnelle *)
+
+let get_f foncl =
+ match (kind_of_term (def_of_const foncl)) with
+ Lambda (Name f, _, _) -> f
+ |_ -> error "la fonctionnelle est mal definie";;
+
+
+let rec compute_le_proofs = function
+ [] -> assumption
+ | a::tl ->
+ tclORELSE assumption
+ (tclTHENS
+ (fun g ->
+ let le_trans = delayed_force le_trans in
+ let t_le_trans = compute_renamed_type g le_trans in
+ let m_id =
+ let _,_,t = destProd t_le_trans in
+ let na,_,_ = destProd t in
+ Nameops.out_name na
+ in
+ apply_with_bindings
+ (le_trans,
+ ExplicitBindings[dummy_loc,NamedHyp m_id,a])
+ g)
+ [compute_le_proofs tl;
+ tclORELSE (apply (delayed_force le_n)) assumption])
+
+let make_lt_proof pmax le_proof =
+ tclTHENS
+ (fun g ->
+ let le_lt_trans = delayed_force le_lt_trans in
+ let t_le_lt_trans = compute_renamed_type g le_lt_trans in
+ let m_id =
+ let _,_,t = destProd t_le_lt_trans in
+ let na,_,_ = destProd t in
+ Nameops.out_name na
+ in
+ apply_with_bindings
+ (le_lt_trans,
+ ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g)
+ [observe_tac "compute_le_proofs" (compute_le_proofs le_proof);
+ tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];;
+
+let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
+ match cond_eqs with
+ [] -> tclIDTAC
+ | eq::eqs ->
+ (fun g ->
+ let t_eq = compute_renamed_type g (mkVar eq) in
+ let k_id,def_id =
+ let k_na,_,t = destProd t_eq in
+ let _,_,t = destProd t in
+ let def_na,_,_ = destProd t in
+ Nameops.out_name k_na,Nameops.out_name def_na
+ in
+ tclTHENS
+ (general_rewrite_bindings false all_occurrences
+ (* dep proofs also: *) true
+ (mkVar eq,
+ ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k;
+ dummy_loc, NamedHyp def_id, mkVar def]) false)
+ [list_cond_rewrite k def pmax eqs le_proofs;
+ observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g
+ )
+
+let rec introduce_all_equalities func eqs values specs bound le_proofs
+ cond_eqs =
+ match specs with
+ [] ->
+ fun g ->
+ let ids = pf_ids_of_hyps g in
+ let s_max = mkApp(delayed_force coq_S, [|bound|]) in
+ let k = next_ident_away_in_goal k_id ids in
+ let ids = k::ids in
+ let h' = next_ident_away_in_goal (h'_id) ids in
+ let ids = h'::ids in
+ let def = next_ident_away_in_goal def_id ids in
+ tclTHENLIST
+ [observe_tac "introduce_all_equalities_final split" (split (ImplicitBindings [s_max]));
+ observe_tac "introduce_all_equalities_final intro k" (h_intro k);
+ tclTHENS
+ (observe_tac "introduce_all_equalities_final case k" (simplest_case (mkVar k)))
+ [
+ tclTHENLIST[h_intro h';
+ simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]));
+ default_full_auto];
+ tclIDTAC
+ ];
+ observe_tac "clearing k " (clear [k]);
+ observe_tac "intros k h' def" (h_intros [k;h';def]);
+ observe_tac "simple_iter" (simpl_iter onConcl);
+ observe_tac "unfold functional"
+ (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]);
+ observe_tac "rewriting equations"
+ (list_rewrite true eqs);
+ observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite k def bound cond_eqs 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 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
+ let ids = pmax::ids in
+ let hle1 = next_ident_away_in_goal hle_id ids in
+ let ids = hle1::ids in
+ let hle2 = next_ident_away_in_goal hle_id ids in
+ let ids = hle2::ids in
+ let heq = next_ident_away_in_goal heq_id ids in
+ tclTHENLIST
+ [simplest_elim (mkVar spec1);
+ list_rewrite true eqs;
+ h_intros [p; heq];
+ simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|]));
+ h_intros [pmax; hle1; hle2];
+ introduce_all_equalities func eqs values specs
+ (mkVar pmax) ((mkVar pmax)::le_proofs)
+ (heq::cond_eqs)] g;;
+
+let string_match s =
+ if String.length s < 3 then failwith "string_match";
+ try
+ for i = 0 to 3 do
+ if String.get s i <> String.get "Acc_" i then failwith "string_match"
+ done;
+ with Invalid_argument _ -> failwith "string_match"
+
+let retrieve_acc_var g =
+ (* Julien: I don't like this version .... *)
+ let hyps = pf_ids_of_hyps g in
+ map_succeed
+ (fun id -> string_match (string_of_id id);id)
+ hyps
+
+let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
+ eqs hrec args values specs =
+ (match args with
+ [] ->
+ tclTHENLIST
+ [observe_tac "split" (split(ImplicitBindings
+ [context_fn (List.map mkVar (List.rev values))]));
+ observe_tac "introduce_all_equalities" (introduce_all_equalities func eqs
+ (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 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
+ let tac =
+ observe_tac "introduce_all_values" (
+ introduce_all_values concl_tac is_mes acc_inv func context_fn eqs
+ hrec args
+ (rec_res::values)(hspec::specs)) in
+ (tclTHENS
+ (observe_tac "elim h_rec"
+ (simplest_elim (mkApp(mkVar hrec, Array.of_list arg)))
+ )
+ [tclTHENLIST [h_intros [rec_res; hspec];
+ tac];
+ (tclTHENS
+ (observe_tac "acc_inv" (apply (Lazy.force acc_inv)))
+ [(* tclTHEN (tclTRY(list_rewrite true eqs)) *)
+ (observe_tac "h_assumption" h_assumption)
+ ;
+ tclTHENLIST
+ [
+ tclTRY(list_rewrite true eqs);
+ observe_tac "user proof"
+ (fun g ->
+ tclUSER
+ concl_tac
+ is_mes
+ (Some (hrec::hspec::(retrieve_acc_var g)@specs))
+ g
+ )
+ ]
+ ]
+ )
+ ]) g)
+
+ )
+
+
+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
+ | 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)
+ (f_constr:constr) (func:global_reference) base_leaf rec_leaf =
+ let rec proveterminate (eqs:constr list) (expr:constr) =
+ try
+ (* let _ = msgnl (str "entering proveterminate") in *)
+ let v =
+ match (kind_of_term expr) with
+ Case (ci, t, a, l) ->
+ (match find_call_occs 0 f_constr a with
+ _,[] ->
+ (fun g ->
+ let destruct_tac, rev_to_thin_intro =
+ mkDestructEq rec_arg_id a g in
+ tclTHENS destruct_tac
+ (list_map_i
+ (fun i -> mk_intros_and_continue
+ (List.rev rev_to_thin_intro)
+ true
+ proveterminate
+ eqs
+ ci.ci_cstr_nargs.(i))
+ 0 (Array.to_list l)) g)
+ | _, _::_ ->
+ (match find_call_occs 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
+ _,[] ->
+ (try observe_tac "base_leaf" (base_leaf func eqs expr)
+ with e -> (msgerrnl (str "failure in base case");raise e ))
+ | _, _::_ ->
+ observe_tac "rec_leaf"
+ (rec_leaf is_mes acc_inv hrec func eqs expr)) in
+ v
+ with e -> begin msgerrnl(str "failure in proveterminate"); raise e end
+ in
+ proveterminate
+
+let hyp_terminates nb_args func =
+ let a_arrow_b = arg_type (constr_of_global func) in
+ let rev_args,b = decompose_prod_n nb_args a_arrow_b in
+ let left =
+ mkApp(delayed_force iter,
+ Array.of_list
+ (lift 5 a_arrow_b:: mkRel 3::
+ constr_of_global func::mkRel 1::
+ List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
+ )
+ )
+ in
+ let right = mkRel 5 in
+ let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in
+ let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in
+ let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in
+ let nb_iter =
+ mkApp(delayed_force ex,
+ [|delayed_force nat;
+ (mkLambda
+ (Name
+ p_id,
+ delayed_force nat,
+ (mkProd (Name k_id, delayed_force nat,
+ mkArrow cond result))))|])in
+ let value = mkApp(delayed_force coq_sig,
+ [|b;
+ (mkLambda (Name v_id, b, nb_iter))|]) in
+ compose_prod rev_args value
+
+
+
+let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
+ if is_mes
+ then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof))
+ else tclUSER concl_tac is_mes names_to_suppress
+
+let termination_proof_header is_mes input_type ids args_id relation
+ rec_arg_num rec_arg_id tac wf_tac : tactic =
+ begin
+ fun g ->
+ let nargs = List.length args_id in
+ let pre_rec_args =
+ List.rev_map
+ mkVar (fst (list_chop (rec_arg_num - 1) args_id))
+ in
+ let relation = substl pre_rec_args relation in
+ let input_type = substl pre_rec_args input_type in
+ let wf_thm = next_ident_away_in_goal (id_of_string ("wf_R")) ids in
+ let wf_rec_arg =
+ next_ident_away_in_goal
+ (id_of_string ("Acc_"^(string_of_id rec_arg_id)))
+ (wf_thm::ids)
+ in
+ let hrec = next_ident_away_in_goal hrec_id
+ (wf_rec_arg::wf_thm::ids) in
+ let acc_inv =
+ lazy (
+ mkApp (
+ delayed_force acc_inv_id,
+ [|input_type;relation;mkVar rec_arg_id|]
+ )
+ )
+ in
+ tclTHEN
+ (h_intros args_id)
+ (tclTHENS
+ (observe_tac
+ "first assert"
+ (assert_tac
+ (Name wf_rec_arg)
+ (mkApp (delayed_force acc_rel,
+ [|input_type;relation;mkVar rec_arg_id|])
+ )
+ )
+ )
+ [
+ (* accesibility proof *)
+ tclTHENS
+ (observe_tac
+ "second assert"
+ (assert_tac
+ (Name wf_thm)
+ (mkApp (delayed_force well_founded,[|input_type;relation|]))
+ )
+ )
+ [
+ (* interactive proof that the relation is well_founded *)
+ observe_tac "wf_tac" (wf_tac is_mes (Some args_id));
+ (* this gives the accessibility argument *)
+ observe_tac
+ "apply wf_thm"
+ (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))
+ )
+ ]
+ ;
+ (* rest of the proof *)
+ tclTHENSEQ
+ [observe_tac "generalize"
+ (onNLastHypsId (nargs+1)
+ (tclMAP (fun id ->
+ tclTHEN (h_generalize [mkVar id]) (h_clear false [id]))
+ ))
+ ;
+ observe_tac "h_fix" (h_fix (Some hrec) (nargs+1));
+ h_intros args_id;
+ h_intro wf_rec_arg;
+ observe_tac "tac" (tac wf_rec_arg hrec acc_inv)
+ ]
+ ]
+ ) g
+ end
+
+
+
+let rec instantiate_lambda t l =
+ match l with
+ | [] -> t
+ | a::l ->
+ let (bound_name, _, body) = destLambda t in
+ instantiate_lambda (subst1 a body) 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 func_body = (def_of_const (constr_of_global func)) in
+ let (f_name, _, body1) = destLambda func_body in
+ let f_id =
+ match f_name with
+ | Name f_id -> next_ident_away_in_goal f_id ids
+ | Anonymous -> anomaly "Anonymous function"
+ in
+ let n_names_types,_ = decompose_lam_n nb_args body1 in
+ let n_ids,ids =
+ List.fold_left
+ (fun (n_ids,ids) (n_name,_) ->
+ match n_name with
+ | Name id ->
+ let n_id = next_ident_away_in_goal id ids in
+ n_id::n_ids,n_id::ids
+ | _ -> anomaly "anonymous argument"
+ )
+ ([],(f_id::ids))
+ n_names_types
+ in
+ let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in
+ let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in
+ termination_proof_header
+ is_mes
+ input_type
+ ids
+ n_ids
+ relation
+ rec_arg_num
+ rec_arg_id
+ (fun rec_arg_id hrec acc_inv g ->
+ (proveterminate
+ [rec_arg_id]
+ is_mes
+ acc_inv
+ hrec
+ (mkVar f_id)
+ func
+ base_leaf_terminate
+ (rec_leaf_terminate (mkVar f_id) concl_tac)
+ []
+ expr
+ )
+ g
+ )
+ (tclUSER_if_not_mes concl_tac)
+ g
+ 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 build_and_l l =
+ let and_constr = Coqlib.build_coq_and () in
+ let conj_constr = coq_conj () in
+ let mk_and p1 p2 =
+ Term.mkApp(and_constr,[|p1;p2|]) in
+ let rec f = function
+ | [] -> failwith "empty list of subgoals!"
+ | [p] -> p,tclIDTAC,1
+ | p1::pl ->
+ let c,tac,nb = f pl in
+ mk_and p1 c,
+ tclTHENS
+ (apply (constr_of_global conj_constr))
+ [tclIDTAC;
+ tac
+ ],nb+1
+ in f l
+
+
+let is_rec_res id =
+ let rec_res_name = string_of_id rec_res_id in
+ let id_name = string_of_id id in
+ try
+ String.sub id_name 0 (String.length rec_res_name) = rec_res_name
+ with _ -> false
+
+let clear_goals =
+ let rec clear_goal t =
+ match kind_of_term t with
+ | Prod(Name id as na,t',b) ->
+ let b' = clear_goal b in
+ if noccurn 1 b' && (is_rec_res id)
+ then pop b'
+ else if b' == b then t
+ else mkProd(na,t',b')
+ | _ -> map_constr clear_goal t
+ in
+ List.map clear_goal
+
+
+let build_new_goal_type () =
+ let sub_gls_types = get_current_subgoals_types () in
+ (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
+ let sub_gls_types = clear_goals sub_gls_types in
+ (* Pp.msgnl (str "sub_gls_types2 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *)
+ let res = build_and_l sub_gls_types in
+ res
+
+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
+ let name = match goal_name with
+ | Some s -> s
+ | None ->
+ 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 na = next_global_ident_away name [] in
+ if 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
+ | _ -> anomaly "equation_lemma: not a constant"
+ in
+ let lemma = mkConst (Lib.make_con na) in
+ ref_ := Some lemma ;
+ let lid = ref [] in
+ let h_num = ref (-1) in
+ Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None);
+ build_proof
+ ( fun gls ->
+ let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in
+ tclTHENSEQ
+ [
+ h_generalize [lemma];
+ h_intro hid;
+ (fun g ->
+ let ids = pf_ids_of_hyps g in
+ tclTHEN
+ (Elim.h_decompose_and (mkVar hid))
+ (fun g ->
+ let ids' = pf_ids_of_hyps g in
+ lid := List.rev (list_subtract ids' ids);
+ if !lid = [] then lid := [hid];
+ tclIDTAC g
+ )
+ g
+ );
+ ] gls)
+ (fun g ->
+ match kind_of_term (pf_concl g) with
+ | App(f,_) when eq_constr f (well_founded ()) ->
+ Auto.h_auto None [] (Some []) g
+ | _ ->
+ incr h_num;
+ (observe_tac "finishing using"
+ (
+ tclCOMPLETE(
+ tclFIRST[
+ tclTHEN
+ (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
+ e_assumption;
+ Eauto.eauto_with_bases
+ false
+ (true,5)
+ [delayed_force refl_equal]
+ [Auto.Hint_db.empty empty_transparent_state false]
+ ]
+ )
+ )
+ )
+ g)
+;
+ Lemmas.save_named opacity;
+ in
+ start_proof
+ na
+ (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma)
+ sign
+ gls_type
+ hook ;
+ if Indfun_common.is_strict_tcc ()
+ then
+ by (tclIDTAC)
+ else
+ begin
+ by (
+ fun g ->
+ tclTHEN
+ (decompose_and_tac)
+ (tclORELSE
+ (tclFIRST
+ (List.map
+ (fun c ->
+ tclTHENSEQ
+ [intros;
+ h_simplest_apply (interp_constr Evd.empty (Global.env()) c);
+ tclCOMPLETE Auto.default_auto
+ ]
+ )
+ using_lemmas)
+ ) tclIDTAC)
+ g)
+ end;
+ try
+ by tclIDTAC; (* raises UserError _ if the proof is complete *)
+ if Flags.is_verbose () then (pp (Printer.pr_open_subgoals()))
+ with UserError _ ->
+ defined ()
+
+;;
+
+
+let com_terminate
+ tcc_lemma_name
+ tcc_lemma_ref
+ is_mes
+ fonctional_ref
+ input_type
+ relation
+ rec_arg_num
+ thm_name using_lemmas
+ nb_args
+ hook =
+ let start_proof (tac_start:tactic) (tac_end:tactic) =
+ let (evmap, env) = Lemmas.get_current_context() in
+ start_proof thm_name
+ (Global, Proof Lemma) (Environ.named_context_val env)
+ (hyp_terminates nb_args fonctional_ref) hook;
+
+ by (observe_tac "starting_tac" tac_start);
+ by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref
+ input_type relation rec_arg_num ))
+ in
+ start_proof tclIDTAC tclIDTAC;
+ try
+ let new_goal_type = build_new_goal_type () in
+ open_new_goal start_proof using_lemmas tcc_lemma_ref
+ (Some tcc_lemma_name)
+ (new_goal_type);
+
+ with Failure "empty list of subgoals!" ->
+ (* a non recursive function declared with measure ! *)
+ defined ()
+
+
+
+
+let ind_of_ref = function
+ | IndRef (ind,i) -> (ind,i)
+ | _ -> anomaly "IndRef expected"
+
+let (value_f:constr list -> global_reference -> constr) =
+ fun al fterm ->
+ let d0 = dummy_loc in
+ let rev_x_id_l =
+ (
+ List.fold_left
+ (fun x_id_l _ ->
+ let x_id = next_ident_away_in_goal x_id x_id_l in
+ x_id::x_id_l
+ )
+ []
+ al
+ )
+ in
+ let fun_body =
+ RCases
+ (d0,RegularStyle,None,
+ [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(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)
+ in
+ understand Evd.empty (Global.env()) value;;
+
+let (declare_fun : identifier -> logical_kind -> constr -> global_reference) =
+ fun f_id kind value ->
+ let ce = {const_entry_body = value;
+ const_entry_type = None;
+ const_entry_opaque = false;
+ const_entry_boxed = true} in
+ ConstRef(declare_constant f_id (DefinitionEntry ce, kind));;
+
+let (declare_f : identifier -> logical_kind -> constr list -> global_reference -> global_reference) =
+ fun f_id kind input_type fterm_ref ->
+ declare_fun f_id kind (value_f input_type fterm_ref);;
+
+let rec n_x_id ids n =
+ if n = 0 then []
+ else let x = next_ident_away_in_goal x_id ids in
+ x::n_x_id (x::ids) (n-1);;
+
+let start_equation (f:global_reference) (term_f:global_reference)
+ (cont_tactic:identifier list -> tactic) g =
+ let ids = pf_ids_of_hyps g in
+ let terminate_constr = constr_of_global term_f in
+ let nargs = nb_prod (type_of_const terminate_constr) in
+ let x = n_x_id ids nargs in
+ tclTHENLIST [
+ h_intros x;
+ unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)];
+ observe_tac "simplest_case"
+ (simplest_case (mkApp (terminate_constr,
+ Array.of_list (List.map mkVar x))));
+ observe_tac "prove_eq" (cont_tactic x)] g;;
+
+let base_leaf_eq func eqs f_id g =
+ let ids = pf_ids_of_hyps g in
+ let k = next_ident_away_in_goal k_id ids in
+ let p = next_ident_away_in_goal p_id (k::ids) in
+ let v = next_ident_away_in_goal v_id (p::k::ids) in
+ let heq = next_ident_away_in_goal heq_id (v::p::k::ids) in
+ let heq1 = next_ident_away_in_goal heq_id (heq::v::p::k::ids) in
+ let hex = next_ident_away_in_goal hex_id (heq1::heq::v::p::k::ids) in
+ tclTHENLIST [
+ h_intros [v; hex];
+ simplest_elim (mkVar hex);
+ h_intros [p;heq1];
+ tclTRY
+ (rewriteRL
+ (mkApp(mkVar heq1,
+ [|mkApp (delayed_force coq_S, [|mkVar p|]);
+ mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|])));
+ simpl_iter onConcl;
+ tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]);
+ observe_tac "list_revrite" (list_rewrite true eqs);
+ apply (delayed_force refl_equal)] g;;
+
+let f_S t = mkApp(delayed_force coq_S, [|t|]);;
+
+
+let rec introduce_all_values_eq cont_tac functional termine
+ f p heq1 pmax bounds le_proofs eqs ids =
+ function
+ [] ->
+ let heq2 = next_ident_away_in_goal heq_id ids in
+ tclTHENLIST
+ [pose_proof (Name heq2)
+ (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|]));
+ simpl_iter (onHyp heq2);
+ unfold_in_hyp [((true,[1]), evaluable_of_global_reference
+ (global_of_constr functional))]
+ (heq2, InHyp);
+ tclTHENS
+ (fun gls ->
+ let t_eq = compute_renamed_type gls (mkVar heq2) in
+ let def_id =
+ 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,
+ ExplicitBindings[dummy_loc,NamedHyp def_id,
+ f]) false) gls)
+ [tclTHENLIST
+ [observe_tac "list_rewrite" (list_rewrite true eqs);
+ cont_tac pmax le_proofs];
+ tclTHENLIST[apply (delayed_force le_lt_SS);
+ compute_le_proofs le_proofs]]]
+ | arg::args ->
+ let v' = next_ident_away_in_goal v_id ids in
+ let ids = v'::ids in
+ let hex' = next_ident_away_in_goal hex_id ids in
+ let ids = hex'::ids in
+ let p' = next_ident_away_in_goal p_id ids in
+ let ids = p'::ids in
+ let new_pmax = next_ident_away_in_goal pmax_id ids in
+ let ids = pmax::ids in
+ let hle1 = next_ident_away_in_goal hle_id ids in
+ let ids = hle1::ids in
+ let hle2 = next_ident_away_in_goal hle_id ids in
+ let ids = hle2::ids in
+ let heq = next_ident_away_in_goal heq_id ids in
+ let ids = heq::ids in
+ let heq2 = next_ident_away_in_goal heq_id ids in
+ let ids = heq2::ids in
+ tclTHENLIST
+ [mkCaseEq(mkApp(termine, Array.of_list arg));
+ h_intros [v'; hex'];
+ simplest_elim(mkVar hex');
+ h_intros [p'];
+ simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax;
+ mkVar p'|]));
+ h_intros [new_pmax;hle1;hle2];
+ introduce_all_values_eq
+ (fun pmax' le_proofs'->
+ tclTHENLIST
+ [cont_tac pmax' le_proofs';
+ h_intros [heq;heq2];
+ observe_tac ("rewriteRL " ^ (string_of_id heq2))
+ (tclTRY (rewriteLR (mkVar heq2)));
+ tclTRY (tclTHENS
+ ( fun g ->
+ let t_eq = compute_renamed_type g (mkVar heq) in
+ let k_id,def_id =
+ let k_na,_,t = destProd t_eq in
+ let _,_,t = destProd t in
+ let def_na,_,_ = destProd t in
+ Nameops.out_name k_na,Nameops.out_name def_na
+ in
+ let c_b = (mkVar heq,
+ ExplicitBindings
+ [dummy_loc, NamedHyp k_id,
+ 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
+ c_b false))
+ g
+ )
+ [tclIDTAC;
+ tclTHENLIST
+ [apply (delayed_force le_lt_n_Sm);
+ compute_le_proofs le_proofs']])])
+ functional termine f p heq1 new_pmax
+ (p'::bounds)((mkVar pmax)::le_proofs) eqs
+ (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args]
+
+
+let rec_leaf_eq termine f ids functional eqs expr fn args =
+ let p = next_ident_away_in_goal p_id ids in
+ let ids = p::ids in
+ let v = next_ident_away_in_goal v_id ids in
+ let ids = v::ids in
+ let hex = next_ident_away_in_goal hex_id ids in
+ let ids = hex::ids in
+ let heq1 = next_ident_away_in_goal heq_id ids in
+ let ids = heq1::ids in
+ let hle1 = next_ident_away_in_goal hle_id ids in
+ let ids = hle1::ids in
+ tclTHENLIST
+ [observe_tac "intros v hex" (h_intros [v;hex]);
+ simplest_elim (mkVar hex);
+ h_intros [p;heq1];
+ h_generalize [mkApp(delayed_force le_n,[|mkVar p|])];
+ h_intros [hle1];
+ observe_tac "introduce_all_values_eq" (introduce_all_values_eq
+ (fun _ _ -> tclIDTAC)
+ 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)
+ (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
+ _,[] ->
+ (fun g ->
+ let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in
+ tclTHENS
+ destruct_tac
+ (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))
+ 0 (Array.to_list l)) g)
+ | _,_::_ ->
+ (match find_call_occs 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
+ 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
+ _,[] -> 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
+ observe_tac "rec_leaf_eq" (rec_leaf_eq
+ termine f ids (constr_of_global functional)
+ eqs expr fn args) g));;
+
+let (com_eqn : identifier ->
+ global_reference -> global_reference -> global_reference
+ -> constr -> unit) =
+ fun 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
+ | _ -> anomaly "terminate_lemma: not a constant"
+ in
+ let (evmap, env) = Lemmas.get_current_context() in
+ let f_constr = (constr_of_global f_ref) in
+ let equation_lemma_type = subst1 f_constr equation_lemma_type in
+ (start_proof eq_name (Global, Proof Lemma)
+ (Environ.named_context_val env) equation_lemma_type (fun _ _ -> ());
+ by
+ (start_equation f_ref terminate_ref
+ (fun x ->
+ prove_eq
+ (constr_of_global terminate_ref)
+ f_constr
+ functional_ref
+ []
+ (instantiate_lambda
+ (def_of_const (constr_of_global functional_ref))
+ (f_constr::List.map mkVar x)
+ )
+ )
+ );
+(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *)
+(* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *)
+ Flags.silently (fun () -> Lemmas.save_named opacity) () ;
+(* Pp.msgnl (str "eqn finished"); *)
+
+ );;
+
+let nf_zeta env =
+ Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+ env
+ Evd.empty
+
+let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_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 Environ.empty_env Evd.empty
+
+
+let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq
+ generate_induction_principle using_lemmas : unit =
+ let function_type = interp_constr Evd.empty (Global.env()) type_of_f in
+ let env = push_named (function_name,None,function_type) (Global.env()) in
+(* 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 ()); *)
+ 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
+ let res =
+(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
+(* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *)
+(* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *)
+ match kind_of_term eq' with
+ | App(e,[|_;_;eq_fix|]) ->
+ mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix))
+ | _ -> failwith "Recursive Definition (res not eq)"
+ in
+ let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in
+ let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in
+ let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in
+ 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 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
+ Evd.empty
+ env_with_pre_rec_args
+ r
+ in
+ let tcc_lemma_name = add_suffix function_name "_tcc" in
+ let tcc_lemma_constr = ref None in
+ (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *)
+ 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
+(* message "start second proof"; *)
+ let stop = ref false in
+ begin
+ try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type)
+ with e ->
+ begin
+ if Tacinterp.get_debug () <> Tactic_debug.DebugOff
+ then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e)
+ else anomaly "Cannot create equation Lemma"
+ ;
+(* ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); *)
+ stop := true;
+ end
+ end;
+ if not !stop
+ then
+ let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in
+ let f_ref = destConst (constr_of_global f_ref)
+ and functional_ref = destConst (constr_of_global functional_ref)
+ and eq_ref = destConst (constr_of_global eq_ref) in
+ generate_induction_principle f_ref tcc_lemma_constr
+ functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation;
+ if Flags.is_verbose ()
+ then msgnl (h 1 (Ppconstr.pr_id function_name ++
+ spc () ++ str"is defined" )++ fnl () ++
+ h 1 (Ppconstr.pr_id equation_id ++
+ spc () ++ str"is defined" )
+ )
+ in
+ try
+ com_terminate
+ tcc_lemma_name
+ tcc_lemma_constr
+ is_mes functional_ref
+ rec_arg_type
+ relation rec_arg_num
+ term_id
+ using_lemmas
+ (List.length res_vars)
+ hook
+ with e ->
+ begin
+ ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
+(* anomaly "Cannot create termination Lemma" *)
+ raise e
+ end
+
+
+
diff --git a/plugins/funind/recdef_plugin.mllib b/plugins/funind/recdef_plugin.mllib
new file mode 100644
index 00000000..31818c39
--- /dev/null
+++ b/plugins/funind/recdef_plugin.mllib
@@ -0,0 +1,11 @@
+Indfun_common
+Rawtermops
+Recdef
+Rawterm_to_relation
+Functional_principles_proofs
+Functional_principles_types
+Invfun
+Indfun
+Merge
+G_indfun
+Recdef_plugin_mod
diff --git a/plugins/funind/vo.itarget b/plugins/funind/vo.itarget
new file mode 100644
index 00000000..33c96830
--- /dev/null
+++ b/plugins/funind/vo.itarget
@@ -0,0 +1 @@
+Recdef.vo
diff --git a/plugins/micromega/CheckerMaker.v b/plugins/micromega/CheckerMaker.v
new file mode 100644
index 00000000..93b4d213
--- /dev/null
+++ b/plugins/micromega/CheckerMaker.v
@@ -0,0 +1,129 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import Decidable.
+Require Import List.
+Require Import Refl.
+
+Set Implicit Arguments.
+
+Section CheckerMaker.
+
+(* 'Formula' is a syntactic representation of a certain kind of propositions. *)
+Variable Formula : Type.
+
+Variable Env : Type.
+
+Variable eval : Env -> Formula -> Prop.
+
+Variable Formula' : Type.
+
+Variable eval' : Env -> Formula' -> Prop.
+
+Variable normalise : Formula -> Formula'.
+
+Variable negate : Formula -> Formula'.
+
+Hypothesis normalise_sound :
+ forall (env : Env) (t : Formula), eval env t -> eval' env (normalise t).
+
+Hypothesis negate_correct :
+ forall (env : Env) (t : Formula), eval env t <-> ~ (eval' env (negate t)).
+
+Variable Witness : Type.
+
+Variable check_formulas' : list Formula' -> Witness -> bool.
+
+Hypothesis check_formulas'_sound :
+ forall (l : list Formula') (w : Witness),
+ check_formulas' l w = true ->
+ forall env : Env, make_impl (eval' env) l False.
+
+Definition normalise_list : list Formula -> list Formula' := map normalise.
+Definition negate_list : list Formula -> list Formula' := map negate.
+
+Definition check_formulas (l : list Formula) (w : Witness) : bool :=
+ check_formulas' (map normalise l) w.
+
+(* Contraposition of normalise_sound for lists *)
+Lemma normalise_sound_contr : forall (env : Env) (l : list Formula),
+ make_impl (eval' env) (map normalise l) False -> make_impl (eval env) l False.
+Proof.
+intros env l; induction l as [| t l IH]; simpl in *.
+trivial.
+intros H1 H2. apply IH. apply H1. now apply normalise_sound.
+Qed.
+
+Theorem check_formulas_sound :
+ forall (l : list Formula) (w : Witness),
+ check_formulas l w = true -> forall env : Env, make_impl (eval env) l False.
+Proof.
+unfold check_formulas; intros l w H env. destruct l as [| t l]; simpl in *.
+pose proof (check_formulas'_sound H env) as H1; now simpl in H1.
+intro H1. apply normalise_sound in H1.
+pose proof (check_formulas'_sound H env) as H2; simpl in H2.
+apply H2 in H1. now apply normalise_sound_contr.
+Qed.
+
+(* In check_conj_formulas', t2 is supposed to be a list of negations of
+formulas. If, for example, t1 = [A1, A2] and t2 = [~ B1, ~ B2], then
+check_conj_formulas' checks that each of [~ B1, A1, A2] and [~ B2, A1, A2] is
+inconsistent. This means that A1 /\ A2 -> B1 and A1 /\ A2 -> B1, i.e., that
+A1 /\ A2 -> B1 /\ B2. *)
+
+Fixpoint check_conj_formulas'
+ (t1 : list Formula') (wits : list Witness) (t2 : list Formula') {struct wits} : bool :=
+match t2 with
+| nil => true
+| t':: rt2 =>
+ match wits with
+ | nil => false
+ | w :: rwits =>
+ match check_formulas' (t':: t1) w with
+ | true => check_conj_formulas' t1 rwits rt2
+ | false => false
+ end
+ end
+end.
+
+(* checks whether the conjunction of t1 implies the conjunction of t2 *)
+
+Definition check_conj_formulas
+ (t1 : list Formula) (wits : list Witness) (t2 : list Formula) : bool :=
+ check_conj_formulas' (normalise_list t1) wits (negate_list t2).
+
+Theorem check_conj_formulas_sound :
+ forall (t1 : list Formula) (t2 : list Formula) (wits : list Witness),
+ check_conj_formulas t1 wits t2 = true ->
+ forall env : Env, make_impl (eval env) t1 (make_conj (eval env) t2).
+Proof.
+intro t1; induction t2 as [| a2 t2' IH].
+intros; apply make_impl_true.
+intros wits H env.
+unfold check_conj_formulas in H; simpl in H.
+destruct wits as [| w ws]; simpl in H. discriminate.
+case_eq (check_formulas' (negate a2 :: normalise_list t1) w);
+intro H1; rewrite H1 in H; [| discriminate].
+assert (H2 : make_impl (eval' env) (negate a2 :: normalise_list t1) False) by
+now apply check_formulas'_sound with (w := w). clear H1.
+pose proof (IH ws H env) as H1. simpl in H2.
+assert (H3 : eval' env (negate a2) -> make_impl (eval env) t1 False)
+by auto using normalise_sound_contr. clear H2.
+rewrite <- make_conj_impl in *.
+rewrite make_conj_cons. intro H2. split.
+apply <- negate_correct. intro; now elim H3. exact (H1 H2).
+Qed.
+
+End CheckerMaker.
diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v
new file mode 100644
index 00000000..231004bc
--- /dev/null
+++ b/plugins/micromega/Env.v
@@ -0,0 +1,182 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import ZArith.
+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 nth (n:positive) (e : Env ) := e n.
+
+ Definition hd (x:D) (e: Env) := nth xH e.
+
+ Definition tail (e: Env) := jump xH e.
+
+ Lemma psucc : forall p, (match p with
+ | xI y' => xO (Psucc y')
+ | xO y' => xI y'
+ | 1%positive => 2%positive
+ end) = (p+1)%positive.
+ Proof.
+ destruct p.
+ auto with zarith.
+ rewrite xI_succ_xO.
+ auto with zarith.
+ reflexivity.
+ Qed.
+
+ Lemma jump_Pplus : forall i j l,
+ forall x, jump (i + j) l x = jump i (jump j l) x.
+ Proof.
+ unfold jump.
+ intros.
+ rewrite Pplus_assoc.
+ reflexivity.
+ Qed.
+
+ Lemma jump_simpl : forall p l,
+ forall x, jump p l x =
+ match p with
+ | xH => tail l x
+ | xO p => jump p (jump p l) x
+ | xI p => jump p (jump p (tail l)) x
+ end.
+ Proof.
+ destruct p ; unfold tail ; intros ; repeat rewrite <- jump_Pplus.
+ (* xI p = p + p + 1 *)
+ rewrite xI_succ_xO.
+ rewrite Pplus_diag.
+ rewrite <- Pplus_one_succ_r.
+ reflexivity.
+ (* xO p = p + p *)
+ rewrite Pplus_diag.
+ reflexivity.
+ reflexivity.
+ Qed.
+
+ Ltac jump_s :=
+ repeat
+ match goal with
+ | |- context [jump xH ?e] => rewrite (jump_simpl xH)
+ | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p))
+ | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p))
+ end.
+
+ Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x.
+ Proof.
+ unfold tail.
+ intros.
+ repeat rewrite <- jump_Pplus.
+ rewrite Pplus_comm.
+ reflexivity.
+ Qed.
+
+ Lemma jump_Psucc : forall j l,
+ forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x).
+ Proof.
+ intros.
+ rewrite <- jump_Pplus.
+ rewrite Pplus_one_succ_r.
+ rewrite Pplus_comm.
+ reflexivity.
+ Qed.
+
+ Lemma jump_Pdouble_minus_one : forall i l,
+ forall x, (jump (Pdouble_minus_one i) (tail l)) x = (jump i (jump i l)) x.
+ 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, forall x, jump (xO p) (tail l) x = jump (xI p) l x.
+ Proof.
+ intros.
+ unfold jump.
+ unfold tail.
+ unfold jump.
+ rewrite <- Pplus_assoc.
+ simpl.
+ reflexivity.
+ Qed.
+
+ Lemma nth_spec : forall p l x,
+ nth p l =
+ match p with
+ | xH => hd x l
+ | xO p => nth p (jump p l)
+ | xI p => nth p (jump p (tail l))
+ end.
+ Proof.
+ unfold nth.
+ destruct p.
+ intros.
+ unfold jump, tail.
+ unfold jump.
+ rewrite Pplus_diag.
+ rewrite xI_succ_xO.
+ simpl.
+ reflexivity.
+ unfold jump.
+ rewrite Pplus_diag.
+ reflexivity.
+ unfold hd.
+ unfold nth.
+ reflexivity.
+ Qed.
+
+
+ Lemma nth_jump : forall p l x, nth p (tail l) = hd x (jump p l).
+ Proof.
+ unfold tail.
+ unfold hd.
+ unfold jump.
+ unfold nth.
+ intros.
+ 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.
+ intros.
+ unfold tail.
+ unfold nth, jump.
+ rewrite Pplus_diag.
+ rewrite <- Psucc_o_double_minus_one_eq_xO.
+ rewrite Pplus_one_succ_r.
+ reflexivity.
+ Qed.
+
+End S.
+
diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v
new file mode 100644
index 00000000..e58f8e68
--- /dev/null
+++ b/plugins/micromega/EnvRing.v
@@ -0,0 +1,1403 @@
+(************************************************************************)
+(* V * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* F. Besson: to evaluate polynomials, the original code is using a list.
+ For big polynomials, this is inefficient -- linear access.
+ I have modified the code to use binary trees -- logarithmic access. *)
+
+
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinList.
+Require Import Env.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Export Ring_theory.
+
+Open Local Scope positive_scope.
+Import RingSyntax.
+
+Section MakeRingPol.
+
+ (* Ring elements *)
+ Variable R:Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+ Variable req : R -> R -> Prop.
+
+ (* Ring properties *)
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
+
+ (* Coefficients *)
+ Variable C: Type.
+ Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool.
+ Variable phi : C -> R.
+ Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+ cO cI cadd cmul csub copp ceqb phi.
+
+ (* Power coefficients *)
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R.
+ Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+
+
+ (* R notations *)
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+
+ (* C notations *)
+ Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
+ Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
+ Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+
+ (* Usefull tactics *)
+ Add Setoid R req Rsth as R_set1.
+ Ltac rrefl := gen_reflexivity Rsth.
+ Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed.
+ Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
+ Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+ Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
+
+ (* Definition of multivariable polynomials with coefficients in C :
+ Type [Pol] represents [X1 ... Xn].
+ The representation is Horner's where a [n] variable polynomial
+ (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients
+ are polynomials with [n-1] variables (C[X2..Xn]).
+ There are several optimisations to make the repr compacter:
+ - [Pc c] is the constant polynomial of value c
+ == c*X1^0*..*Xn^0
+ - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables.
+ variable indices are shifted of j in Q.
+ == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn}
+ - [PX P i Q] is an optimised Horner form of P*X^i + Q
+ with P not the null polynomial
+ == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn}
+
+ In addition:
+ - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden
+ since they can be represented by the simpler form (PX P (i+j) Q)
+ - (Pinj i (Pinj j P)) is (Pinj (i+j) P)
+ - (Pinj i (Pc c)) is (Pc c)
+ *)
+
+ Inductive Pol : Type :=
+ | Pc : C -> Pol
+ | Pinj : positive -> Pol -> Pol
+ | PX : Pol -> positive -> Pol -> Pol.
+
+ Definition P0 := Pc cO.
+ Definition P1 := Pc cI.
+
+ Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
+ match P, P' with
+ | Pc c, Pc c' => c ?=! c'
+ | Pinj j Q, Pinj j' Q' =>
+ match Pcompare j j' Eq with
+ | Eq => Peq Q Q'
+ | _ => false
+ end
+ | PX P i Q, PX P' i' Q' =>
+ match Pcompare i i' Eq with
+ | Eq => if Peq P P' then Peq Q Q' else false
+ | _ => false
+ end
+ | _, _ => false
+ end.
+
+ Notation " P ?== P' " := (Peq P P').
+
+ Definition mkPinj j P :=
+ match P with
+ | Pc _ => P
+ | Pinj j' Q => Pinj ((j + j'):positive) Q
+ | _ => Pinj j P
+ end.
+
+ Definition mkPinj_pred j P:=
+ match j with
+ | xH => P
+ | xO j => Pinj (Pdouble_minus_one j) P
+ | xI j => Pinj (xO j) P
+ end.
+
+ Definition mkPX P i Q :=
+ match P with
+ | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q
+ | Pinj _ _ => PX P i Q
+ | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q
+ end.
+
+ Definition mkXi i := PX P1 i P0.
+
+ Definition mkX := mkXi 1.
+
+ (** Opposite of addition *)
+
+ Fixpoint Popp (P:Pol) : Pol :=
+ match P with
+ | Pc c => Pc (-! c)
+ | Pinj j Q => Pinj j (Popp Q)
+ | PX P i Q => PX (Popp P) i (Popp Q)
+ end.
+
+ Notation "-- P" := (Popp P).
+
+ (** Addition et subtraction *)
+
+ Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
+ match P with
+ | Pc c1 => Pc (c1 +! c)
+ | Pinj j Q => Pinj j (PaddC Q c)
+ | PX P i Q => PX P i (PaddC Q c)
+ end.
+
+ Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol :=
+ match P with
+ | Pc c1 => Pc (c1 -! c)
+ | Pinj j Q => Pinj j (PsubC Q c)
+ | PX P i Q => PX P i (PsubC Q c)
+ end.
+
+ Section PopI.
+
+ Variable Pop : Pol -> Pol -> Pol.
+ Variable Q : Pol.
+
+ Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
+ match P with
+ | Pc c => mkPinj j (PaddC Q c)
+ | Pinj j' Q' =>
+ match ZPminus j' j with
+ | Zpos k => mkPinj j (Pop (Pinj k Q') Q)
+ | Z0 => mkPinj j (Pop Q' Q)
+ | Zneg k => mkPinj j' (PaddI k Q')
+ end
+ | PX P i Q' =>
+ match j with
+ | xH => PX P i (Pop Q' Q)
+ | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
+ | xI j => PX P i (PaddI (xO j) Q')
+ end
+ end.
+
+ Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
+ match P with
+ | Pc c => mkPinj j (PaddC (--Q) c)
+ | Pinj j' Q' =>
+ match ZPminus j' j with
+ | Zpos k => mkPinj j (Pop (Pinj k Q') Q)
+ | Z0 => mkPinj j (Pop Q' Q)
+ | Zneg k => mkPinj j' (PsubI k Q')
+ end
+ | PX P i Q' =>
+ match j with
+ | xH => PX P i (Pop Q' Q)
+ | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
+ | xI j => PX P i (PsubI (xO j) Q')
+ end
+ end.
+
+ Variable P' : Pol.
+
+ Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
+ match P with
+ | Pc c => PX P' i' P
+ | Pinj j Q' =>
+ match j with
+ | xH => PX P' i' Q'
+ | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q')
+ | xI j => PX P' i' (Pinj (xO j) Q')
+ end
+ | PX P i Q' =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+ | Z0 => mkPX (Pop P P') i Q'
+ | Zneg k => mkPX (PaddX k P) i Q'
+ end
+ end.
+
+ Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol :=
+ match P with
+ | Pc c => PX (--P') i' P
+ | Pinj j Q' =>
+ match j with
+ | xH => PX (--P') i' Q'
+ | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q')
+ | xI j => PX (--P') i' (Pinj (xO j) Q')
+ end
+ | PX P i Q' =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+ | Z0 => mkPX (Pop P P') i Q'
+ | Zneg k => mkPX (PsubX k P) i Q'
+ end
+ end.
+
+
+ End PopI.
+
+ Fixpoint Padd (P P': Pol) {struct P'} : Pol :=
+ match P' with
+ | Pc c' => PaddC P c'
+ | Pinj j' Q' => PaddI Padd Q' j' P
+ | PX P' i' Q' =>
+ match P with
+ | Pc c => PX P' i' (PaddC Q' c)
+ | Pinj j Q =>
+ match j with
+ | xH => PX P' i' (Padd Q Q')
+ | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
+ | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
+ end
+ | PX P i Q =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
+ | Z0 => mkPX (Padd P P') i (Padd Q Q')
+ | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
+ end
+ end
+ end.
+ Notation "P ++ P'" := (Padd P P').
+
+ Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
+ match P' with
+ | Pc c' => PsubC P c'
+ | Pinj j' Q' => PsubI Psub Q' j' P
+ | PX P' i' Q' =>
+ match P with
+ | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c)
+ | Pinj j Q =>
+ match j with
+ | xH => PX (--P') i' (Psub Q Q')
+ | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
+ | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
+ end
+ | PX P i Q =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
+ | Z0 => mkPX (Psub P P') i (Psub Q Q')
+ | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
+ end
+ end
+ end.
+ Notation "P -- P'" := (Psub P P').
+
+ (** Multiplication *)
+
+ Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
+ match P with
+ | Pc c' => Pc (c' *! c)
+ | Pinj j Q => mkPinj j (PmulC_aux Q c)
+ | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c)
+ end.
+
+ Definition PmulC P c :=
+ if c ?=! cO then P0 else
+ if c ?=! cI then P else PmulC_aux P c.
+
+ Section PmulI.
+ Variable Pmul : Pol -> Pol -> Pol.
+ Variable Q : Pol.
+ Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
+ match P with
+ | Pc c => mkPinj j (PmulC Q c)
+ | Pinj j' Q' =>
+ match ZPminus j' j with
+ | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
+ | Z0 => mkPinj j (Pmul Q' Q)
+ | Zneg k => mkPinj j' (PmulI k Q')
+ end
+ | PX P' i' Q' =>
+ match j with
+ | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
+ | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q')
+ | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
+ end
+ end.
+
+ End PmulI.
+(* A symmetric version of the multiplication *)
+
+ Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
+ match P'' with
+ | Pc c => PmulC P c
+ | Pinj j' Q' => PmulI Pmul Q' j' P
+ | PX P' i' Q' =>
+ match P with
+ | Pc c => PmulC P'' c
+ | Pinj j Q =>
+ let QQ' :=
+ match j with
+ | xH => Pmul Q Q'
+ | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q'
+ | xI j => Pmul (Pinj (xO j) Q) Q'
+ end in
+ mkPX (Pmul P P') i' QQ'
+ | PX P i Q=>
+ let QQ' := Pmul Q Q' in
+ let PQ' := PmulI Pmul Q' xH P in
+ let QP' := Pmul (mkPinj xH Q) P' in
+ let PP' := Pmul P P' in
+ (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ'
+ end
+ end.
+
+(* Non symmetric *)
+(*
+ Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
+ match P' with
+ | Pc c' => PmulC P c'
+ | Pinj j' Q' => PmulI Pmul_aux Q' j' P
+ | PX P' i' Q' =>
+ (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
+ end.
+
+ Definition Pmul P P' :=
+ match P with
+ | Pc c => PmulC P' c
+ | Pinj j Q => PmulI Pmul_aux Q j P'
+ | PX P i Q =>
+ (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
+ end.
+*)
+ Notation "P ** P'" := (Pmul P P').
+
+ Fixpoint Psquare (P:Pol) : Pol :=
+ match P with
+ | Pc c => Pc (c *! c)
+ | Pinj j Q => Pinj j (Psquare Q)
+ | PX P i Q =>
+ let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
+ let Q2 := Psquare Q in
+ let P2 := Psquare P in
+ mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
+ end.
+
+ (** Monomial **)
+
+ Inductive Mon: Set :=
+ mon0: Mon
+ | zmon: positive -> Mon -> Mon
+ | vmon: positive -> Mon -> Mon.
+
+ Fixpoint Mphi(l:Env R) (M: Mon) {struct M} : R :=
+ match M with
+ mon0 => rI
+ | zmon j M1 => Mphi (jump j l) M1
+ | vmon i M1 =>
+ let x := hd 0 l in
+ let xi := pow_pos rmul x i in
+ (Mphi (tail l) M1) * xi
+ end.
+
+ Definition mkZmon j M :=
+ match M with mon0 => mon0 | _ => zmon j M end.
+
+ Definition zmon_pred j M :=
+ match j with xH => M | _ => mkZmon (Ppred j) M end.
+
+ Definition mkVmon i M :=
+ match M with
+ | mon0 => vmon i mon0
+ | zmon j m => vmon i (zmon_pred j m)
+ | vmon i' m => vmon (i+i') m
+ end.
+
+ Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
+ match P, M with
+ _, mon0 => (Pc cO, P)
+ | Pc _, _ => (P, Pc cO)
+ | Pinj j1 P1, zmon j2 M1 =>
+ match (j1 ?= j2) Eq with
+ Eq => let (R,S) := MFactor P1 M1 in
+ (mkPinj j1 R, mkPinj j1 S)
+ | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
+ (mkPinj j1 R, mkPinj j1 S)
+ | Gt => (P, Pc cO)
+ end
+ | Pinj _ _, vmon _ _ => (P, Pc cO)
+ | PX P1 i Q1, zmon j M1 =>
+ let M2 := zmon_pred j M1 in
+ let (R1, S1) := MFactor P1 M in
+ let (R2, S2) := MFactor Q1 M2 in
+ (mkPX R1 i R2, mkPX S1 i S2)
+ | PX P1 i Q1, vmon j M1 =>
+ match (i ?= j) Eq with
+ Eq => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+ (mkPX R1 i Q1, S1)
+ | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
+ (mkPX R1 i Q1, S1)
+ | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+ (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
+ end
+ end.
+
+ Definition POneSubst (P1: Pol) (M1: Mon) (P2: Pol): option Pol :=
+ let (Q1,R1) := MFactor P1 M1 in
+ match R1 with
+ (Pc c) => if c ?=! cO then None
+ else Some (Padd Q1 (Pmul P2 R1))
+ | _ => Some (Padd Q1 (Pmul P2 R1))
+ end.
+
+ Fixpoint PNSubst1 (P1: Pol) (M1: Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+ match POneSubst P1 M1 P2 with
+ Some P3 => match n with S n1 => PNSubst1 P3 M1 P2 n1 | _ => P3 end
+ | _ => P1
+ end.
+
+ Definition PNSubst (P1: Pol) (M1: Mon) (P2: Pol) (n: nat): option Pol :=
+ match POneSubst P1 M1 P2 with
+ Some P3 => match n with S n1 => Some (PNSubst1 P3 M1 P2 n1) | _ => None end
+ | _ => None
+ end.
+
+ Fixpoint PSubstL1 (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}:
+ Pol :=
+ match LM1 with
+ cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
+ | _ => P1
+ end.
+
+ Fixpoint PSubstL (P1: Pol) (LM1: list (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
+ match LM1 with
+ cons (M1,P2) LM2 =>
+ match PNSubst P1 M1 P2 n with
+ Some P3 => Some (PSubstL1 P3 LM2 n)
+ | None => PSubstL P1 LM2 n
+ end
+ | _ => None
+ end.
+
+ Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
+ match PSubstL P1 LM1 n with
+ Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
+ | _ => P1
+ end.
+
+ (** Evaluation of a polynomial towards R *)
+
+ Fixpoint Pphi(l:Env R) (P:Pol) {struct P} : R :=
+ match P with
+ | Pc c => [c]
+ | Pinj j Q => Pphi (jump j l) Q
+ | PX P i Q =>
+ let x := hd 0 l in
+ let xi := pow_pos rmul x i in
+ (Pphi l P) * xi + (Pphi (tail l) Q)
+ 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 (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+ replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial.
+ apply Pplus_xI_double_minus_one.
+ simpl;trivial.
+ replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial.
+ apply Pplus_xI_double_minus_one.
+ replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+ replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial.
+ rewrite <- Pplus_one_succ_l.
+ rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+ replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial.
+ replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial.
+ rewrite <- Pplus_one_succ_l.
+ rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+ simpl;trivial.
+ 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 (morph_eq CRmorph);trivial.
+ assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+ try discriminate H.
+ rewrite (IHP P' H); rewrite H1;trivial;rrefl.
+ assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+ try discriminate H.
+ rewrite H1;trivial. clear H1.
+ assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
+ destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H]
+ |discriminate H].
+ rewrite (H1 H);rewrite (H2 H);rrefl.
+ Qed.
+
+ Lemma Pphi0 : forall l, P0@l == 0.
+ Proof.
+ intros;simpl;apply (morph0 CRmorph).
+ Qed.
+
+Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) ->
+ p @ e1 = p @ e2.
+Proof.
+ induction p ; simpl.
+ reflexivity.
+ intros.
+ apply IHp.
+ intros.
+ unfold jump.
+ apply H.
+ intros.
+ rewrite (IHp1 e1 e2) ; auto.
+ rewrite (IHp2 (tail e1) (tail e2)) ; auto.
+ unfold hd. unfold nth. rewrite H. reflexivity.
+ unfold tail. unfold jump. intros ; apply H.
+Qed.
+
+Lemma Pjump_Pplus : forall P i j l, P @ (jump (i + j) l ) = P @ (jump j (jump i l)).
+Proof.
+ intros. apply env_morph. intros. rewrite <- jump_Pplus.
+ rewrite Pplus_comm.
+ reflexivity.
+Qed.
+
+Lemma Pjump_xO_tail : forall P p l,
+ P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l).
+Proof.
+ intros.
+ apply env_morph.
+ intros.
+ rewrite (@jump_simpl R (xI p)).
+ rewrite (@jump_simpl R (xO p)).
+ reflexivity.
+Qed.
+
+Lemma Pjump_Pdouble_minus_one : forall P p l,
+ P @ (jump (Pdouble_minus_one p) (tail l)) = P @ (jump (xO p) l).
+Proof.
+ intros.
+ apply env_morph.
+ intros.
+ rewrite jump_Pdouble_minus_one.
+ rewrite (@jump_simpl R (xO p)).
+ reflexivity.
+Qed.
+
+
+
+ Lemma Pphi1 : forall l, P1@l == 1.
+ Proof.
+ intros;simpl;apply (morph1 CRmorph).
+ Qed.
+
+ Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l).
+ Proof.
+ intros j l p;destruct p;simpl;rsimpl.
+ rewrite Pjump_Pplus.
+ reflexivity.
+ Qed.
+
+ Let pow_pos_Pplus :=
+ pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
+
+ Lemma mkPX_ok : forall l P i Q,
+ (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
+ Proof.
+ intros l P i Q;unfold mkPX.
+ destruct P;try (simpl;rrefl).
+ assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl.
+ rewrite (H (refl_equal true));rewrite (morph0 CRmorph).
+ rewrite mkPinj_ok;rsimpl;simpl;rrefl.
+ assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl.
+ rewrite (H (refl_equal true));trivial.
+ rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+
+ Ltac Esimpl :=
+ repeat (progress (
+ match goal with
+ | |- context [P0@?l] => rewrite (Pphi0 l)
+ | |- context [P1@?l] => rewrite (Pphi1 l)
+ | |- context [(mkPinj ?j ?P)@?l] => rewrite (mkPinj_ok j l P)
+ | |- context [(mkPX ?P ?i ?Q)@?l] => rewrite (mkPX_ok l P i Q)
+ | |- context [[cO]] => rewrite (morph0 CRmorph)
+ | |- context [[cI]] => rewrite (morph1 CRmorph)
+ | |- context [[?x +! ?y]] => rewrite ((morph_add CRmorph) x y)
+ | |- context [[?x *! ?y]] => rewrite ((morph_mul CRmorph) x y)
+ | |- context [[?x -! ?y]] => rewrite ((morph_sub CRmorph) x y)
+ | |- context [[-! ?x]] => rewrite ((morph_opp CRmorph) x)
+ end));
+ rsimpl; simpl.
+
+ Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
+ Proof.
+ induction P;simpl;intros;Esimpl;trivial.
+ rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c].
+ Proof.
+ induction P;simpl;intros.
+ Esimpl.
+ rewrite IHP;rsimpl.
+ rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c].
+ Proof.
+ induction P;simpl;intros;Esimpl;trivial.
+ rewrite IHP1;rewrite IHP2;rsimpl.
+ mul_push ([c]);rrefl.
+ Qed.
+
+ Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
+ Proof.
+ intros c P l; unfold PmulC.
+ assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO).
+ rewrite (H (refl_equal true));Esimpl.
+ assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+ rewrite (H1 (refl_equal true));Esimpl.
+ apply PmulC_aux_ok.
+ Qed.
+
+ Lemma Popp_ok : forall P l, (--P)@l == - P@l.
+ Proof.
+ induction P;simpl;intros.
+ Esimpl.
+ apply IHP.
+ rewrite IHP1;rewrite IHP2;rsimpl.
+ Qed.
+
+ Ltac Esimpl2 :=
+ Esimpl;
+ repeat (progress (
+ match goal with
+ | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
+ | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
+ | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
+ | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
+ end)); Esimpl.
+
+
+
+
+ Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l.
+ Proof.
+ induction P';simpl;intros;Esimpl2.
+ generalize P p l;clear P p l.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARadd_comm ARth).
+ assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+ rewrite H;Esimpl. rewrite IHP';rrefl.
+ rewrite H;Esimpl. rewrite IHP';Esimpl.
+ rewrite Pjump_Pplus. rrefl.
+ rewrite H;Esimpl. rewrite IHP.
+ rewrite Pjump_Pplus. rrefl.
+ destruct p0;simpl.
+ rewrite IHP2;simpl. rsimpl.
+ rewrite Pjump_xO_tail. Esimpl.
+ rewrite IHP2;simpl.
+ rewrite Pjump_Pdouble_minus_one.
+ rsimpl.
+ rewrite IHP'.
+ rsimpl.
+ destruct P;simpl.
+ Esimpl2;add_push [c];rrefl.
+ destruct p0;simpl;Esimpl2.
+ rewrite IHP'2;simpl.
+ rewrite Pjump_xO_tail.
+ rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+ rewrite IHP'2;simpl.
+ rewrite Pjump_Pdouble_minus_one. rsimpl.
+ add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+ rewrite IHP'2;rsimpl.
+ unfold tail.
+ add_push (P @ (jump 1 l));rrefl.
+ assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+ rewrite IHP'1;rewrite IHP'2;rsimpl.
+ add_push (P3 @ (tail l));rewrite H;rrefl.
+ rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
+ rewrite H;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;rsimpl.
+ add_push (P3 @ (tail l));rrefl.
+ assert (forall P k l,
+ (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
+ induction P;simpl;intros;try apply (ARadd_comm ARth).
+ destruct p2; simpl; try apply (ARadd_comm ARth).
+ rewrite Pjump_xO_tail.
+ apply (ARadd_comm ARth).
+ rewrite Pjump_Pdouble_minus_one.
+ apply (ARadd_comm ARth).
+ assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
+ rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
+ rewrite IHP'1;simpl;Esimpl.
+ rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;Esimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;rsimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite H0;rsimpl.
+ add_push (P3 @ (tail l)).
+ rewrite H;rewrite Pplus_comm.
+ rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl.
+ add_push (P3 @ (tail l));rrefl.
+ Qed.
+
+ Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
+ Proof.
+ induction P';simpl;intros;Esimpl2;trivial.
+ generalize P p l;clear P p l.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARadd_comm ARth).
+ assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+ rewrite H;Esimpl. rewrite IHP';rsimpl.
+ rewrite H;Esimpl. rewrite IHP';Esimpl.
+ rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
+ rewrite H;Esimpl. rewrite IHP.
+ rewrite <- Pjump_Pplus;rewrite Pplus_comm;rrefl.
+ destruct p0;simpl.
+ rewrite IHP2;simpl; try rewrite Pjump_xO_tail ; rsimpl.
+ rewrite IHP2;simpl.
+ rewrite Pjump_Pdouble_minus_one;rsimpl.
+ unfold tail ; rsimpl.
+ rewrite IHP';rsimpl.
+ destruct P;simpl.
+ repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
+ destruct p0;simpl;Esimpl2.
+ rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
+ rewrite Pjump_xO_tail.
+ add_push (P @ ((jump (xI p0) l)));rrefl.
+ rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl.
+ add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl.
+ unfold tail.
+ rewrite IHP'2;rsimpl;add_push (P @ (jump 1 l));rrefl.
+ assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+ rewrite IHP'1; rewrite IHP'2;rsimpl.
+ add_push (P3 @ (tail l));rewrite H;rrefl.
+ rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
+ rewrite H;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;rsimpl.
+ add_push (P3 @ (tail l));rrefl.
+ assert (forall P k l,
+ (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
+ induction P;simpl;intros.
+ rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
+ destruct p2;simpl; rewrite Popp_ok;rsimpl.
+ rewrite Pjump_xO_tail.
+ apply (ARadd_comm ARth);trivial.
+ rewrite Pjump_Pdouble_minus_one.
+ apply (ARadd_comm ARth);trivial.
+ apply (ARadd_comm ARth);trivial.
+ assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
+ rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
+ rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;Esimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;rsimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite H0;rsimpl.
+ rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
+ rewrite H;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+(* Proof for the symmetric version *)
+
+ Lemma PmulI_ok :
+ forall P',
+ (forall (P : Pol) (l : Env R), (Pmul P P') @ l == P @ l * P' @ l) ->
+ forall (P : Pol) (p : positive) (l : Env R),
+ (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARmul_comm ARth).
+ assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+ rewrite H1; rewrite H;rrefl.
+ rewrite H1; rewrite H.
+ rewrite Pjump_Pplus;simpl;rrefl.
+ rewrite H1.
+ rewrite Pjump_Pplus;rewrite IHP;rrefl.
+ destruct p0;Esimpl2.
+ rewrite IHP1;rewrite IHP2;rsimpl.
+ rewrite Pjump_xO_tail.
+ mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p); rewrite Pjump_Pdouble_minus_one.
+ rrefl.
+ rewrite IHP1;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p).
+ rewrite H;rrefl.
+ Qed.
+
+(*
+ Lemma PmulI_ok :
+ forall P',
+ (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
+ forall (P : Pol) (p : positive) (l : list R),
+ (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARmul_comm ARth).
+ assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+ rewrite H1; rewrite H;rrefl.
+ rewrite H1; rewrite H.
+ rewrite Pplus_comm.
+ rewrite jump_Pplus;simpl;rrefl.
+ rewrite H1;rewrite Pplus_comm.
+ rewrite jump_Pplus;rewrite IHP;rrefl.
+ destruct p0;Esimpl2.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
+ rewrite IHP1;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p).
+ rewrite H;rrefl.
+ Qed.
+
+ Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l.
+ Proof.
+ induction P';simpl;intros.
+ Esimpl2;trivial.
+ apply PmulI_ok;trivial.
+ rewrite Padd_ok;Esimpl2.
+ rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl.
+ Qed.
+*)
+
+(* Proof for the symmetric version *)
+ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+ intros P P';generalize P;clear P;induction P';simpl;intros.
+ apply PmulC_ok. apply PmulI_ok;trivial.
+ destruct P.
+ rewrite (ARmul_comm ARth);Esimpl2;Esimpl2.
+ Esimpl2. rewrite IHP'1;Esimpl2.
+ assert (match p0 with
+ | xI j => Pinj (xO j) P ** P'2
+ | xO j => Pinj (Pdouble_minus_one j) P ** P'2
+ | 1 => P ** P'2
+ end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
+ destruct p0;rewrite IHP'2;Esimpl.
+ rewrite Pjump_xO_tail. reflexivity.
+ rewrite Pjump_Pdouble_minus_one;Esimpl.
+ rewrite H;Esimpl.
+ rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
+ repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
+ rewrite PmulI_ok;trivial.
+ unfold tail.
+ mul_push (P'1@l). simpl. mul_push (P'2 @ (jump 1 l)). Esimpl.
+ Qed.
+
+(*
+Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+ destruct P;simpl;intros.
+ Esimpl2;apply (ARmul_comm ARth).
+ rewrite (PmulI_ok P (Pmul_aux_ok P)).
+ apply (ARmul_comm ARth).
+ rewrite Padd_ok; Esimpl2.
+ rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
+ rewrite Pmul_aux_ok;mul_push (P' @ l).
+ rewrite (ARmul_comm ARth (P' @ l));rrefl.
+ Qed.
+*)
+
+ Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
+ Proof.
+ induction P;simpl;intros;Esimpl2.
+ apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2.
+ rewrite IHP1;rewrite IHP2.
+ mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l).
+ rrefl.
+ Qed.
+
+ Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) ->
+ Mphi env P = Mphi env' P.
+ Proof.
+ induction P ; simpl.
+ reflexivity.
+ intros.
+ apply IHP.
+ intros.
+ unfold jump.
+ apply H.
+ (**)
+ intros.
+ replace (Mphi (tail env) P) with (Mphi (tail env') P).
+ unfold hd. unfold nth.
+ rewrite H.
+ reflexivity.
+ apply IHP.
+ unfold tail,jump.
+ intros. symmetry. apply H.
+ Qed.
+
+Lemma Mjump_xO_tail : forall M p l,
+ Mphi (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M.
+Proof.
+ intros.
+ apply Mphi_morph.
+ intros.
+ rewrite (@jump_simpl R (xI p)).
+ rewrite (@jump_simpl R (xO p)).
+ reflexivity.
+Qed.
+
+Lemma Mjump_Pdouble_minus_one : forall M p l,
+ Mphi (jump (Pdouble_minus_one p) (tail l)) M = Mphi (jump (xO p) l) M.
+Proof.
+ intros.
+ apply Mphi_morph.
+ intros.
+ rewrite jump_Pdouble_minus_one.
+ rewrite (@jump_simpl R (xO p)).
+ reflexivity.
+Qed.
+
+Lemma Mjump_Pplus : forall M i j l, Mphi (jump (i + j) l ) M = Mphi (jump j (jump i l)) M.
+Proof.
+ intros. apply Mphi_morph. intros. rewrite <- jump_Pplus.
+ rewrite Pplus_comm.
+ reflexivity.
+Qed.
+
+
+
+ Lemma mkZmon_ok: forall M j l,
+ Mphi l (mkZmon j M) == Mphi l (zmon j M).
+ intros M j l; case M; simpl; intros; rsimpl.
+ Qed.
+
+ Lemma zmon_pred_ok : forall M j l,
+ Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
+ Proof.
+ destruct j; simpl;intros l; rsimpl.
+ rewrite mkZmon_ok;rsimpl.
+ simpl.
+ rewrite Mjump_xO_tail.
+ reflexivity.
+ rewrite mkZmon_ok;simpl.
+ rewrite Mjump_Pdouble_minus_one; rsimpl.
+ Qed.
+
+ Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
+ Proof.
+ destruct M;simpl;intros;rsimpl.
+ rewrite zmon_pred_ok;simpl;rsimpl.
+ rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+
+ Lemma Mphi_ok: forall P M l,
+ let (Q,R) := MFactor P M in
+ P@l == Q@l + (Mphi l M) * (R@l).
+ Proof.
+ intros P; elim P; simpl; auto; clear P.
+ intros c M l; case M; simpl; auto; try intro p; try intro m;
+ try rewrite (morph0 CRmorph); rsimpl.
+
+ intros i P Hrec M l; case M; simpl; clear M.
+ rewrite (morph0 CRmorph); rsimpl.
+ intros j M.
+ case_eq ((i ?= j) Eq); intros He; simpl.
+ rewrite (Pcompare_Eq_eq _ _ He).
+ generalize (Hrec M (jump j l)); case (MFactor P M);
+ simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+ generalize (Hrec (zmon (j -i) M) (jump i l));
+ case (MFactor P (zmon (j -i) M)); simpl.
+ intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+ rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)).
+ rewrite Mjump_Pplus; auto.
+ rewrite (morph0 CRmorph); rsimpl.
+ intros P2 m; rewrite (morph0 CRmorph); rsimpl.
+
+ intros P2 Hrec1 i Q2 Hrec2 M l; case M; simpl; auto.
+ rewrite (morph0 CRmorph); rsimpl.
+ intros j M1.
+ generalize (Hrec1 (zmon j M1) l);
+ case (MFactor P2 (zmon j M1)).
+ intros R1 S1 H1.
+ generalize (Hrec2 (zmon_pred j M1) (tail l));
+ case (MFactor Q2 (zmon_pred j M1)); simpl.
+ intros R2 S2 H2; rewrite H1; rewrite H2.
+ repeat rewrite mkPX_ok; simpl.
+ rsimpl.
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ rewrite zmon_pred_ok;rsimpl.
+ intros j M1.
+ case_eq ((i ?= j) Eq); intros He; simpl.
+ rewrite (Pcompare_Eq_eq _ _ He).
+ generalize (Hrec1 (mkZmon xH M1) l); case (MFactor P2 (mkZmon xH M1));
+ simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+ rewrite H; rewrite mkPX_ok; rsimpl.
+ repeat (rewrite <-(ARadd_assoc ARth)).
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ rewrite mkZmon_ok.
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ generalize (Hrec1 (vmon (j - i) M1) l);
+ case (MFactor P2 (vmon (j - i) M1));
+ simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+ rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
+ rewrite mkPX_ok; rsimpl.
+ repeat (rewrite <-(ARadd_assoc ARth)).
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ apply rmul_ext; rsimpl.
+ rewrite <- pow_pos_Pplus.
+ rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
+ generalize (Hrec1 (mkZmon 1 M1) l);
+ case (MFactor P2 (mkZmon 1 M1));
+ simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+ rewrite H; rsimpl.
+ rewrite mkPX_ok; rsimpl.
+ repeat (rewrite <-(ARadd_assoc ARth)).
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ rewrite mkZmon_ok.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ rewrite mkPX_ok; simpl; rsimpl.
+ rewrite (morph0 CRmorph); rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
+ apply rmul_ext; rsimpl.
+ rewrite <- pow_pos_Pplus.
+ rewrite (Pplus_minus _ _ He); rsimpl.
+ Qed.
+
+(* Proof for the symmetric version *)
+
+ Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+ POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+ intros c H; rewrite H.
+ generalize (morph_eq CRmorph c cO);
+ case (c ?=! cO); simpl; auto.
+ intros H1 H2; rewrite H1; auto; rsimpl.
+ discriminate.
+ intros _ H1 H2; injection H1; intros; subst.
+ rewrite H2; rsimpl.
+ (* new version *)
+ rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
+ intros i P5 H; rewrite H.
+ intros HH H1; injection HH; intros; subst; rsimpl.
+ rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl.
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+ assert (P4 = Q1 ++ P3 ** PX i P5 P6).
+ injection H2; intros; subst;trivial.
+ rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl.
+Qed.
+(*
+ Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+ POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+Proof.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+ intros c H; rewrite H.
+ generalize (morph_eq CRmorph c cO);
+ case (c ?=! cO); simpl; auto.
+ intros H1 H2; rewrite H1; auto; rsimpl.
+ discriminate.
+ intros _ H1 H2; injection H1; intros; subst.
+ rewrite H2; rsimpl.
+ rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
+ intros i P5 H; rewrite H.
+ intros HH H1; injection HH; intros; subst; rsimpl.
+ rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl.
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+ injection H2; intros; subst; rsimpl.
+ rewrite Padd_ok.
+ rewrite Pmul_ok; rsimpl.
+ Qed.
+*)
+ Lemma PNSubst1_ok: forall n P1 M1 P2 l,
+ Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+ Proof.
+ intros n; elim n; simpl; auto.
+ intros P2 M1 P3 l H.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+ intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
+ intros n1 Hrec P2 M1 P3 l H.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+ intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
+ Qed.
+
+ Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
+ PNSubst P1 M1 P2 n = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+ Proof.
+ intros n P2 M1 P3 l P4; unfold PNSubst.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; discriminate].
+ intros P5 H1; case n; try (intros; discriminate).
+ intros n1 H2; injection H2; intros; subst.
+ rewrite <- PNSubst1_ok; auto.
+ Qed.
+
+ Fixpoint MPcond (LM1: list (Mon * Pol)) (l: Env R) {struct LM1} : Prop :=
+ match LM1 with
+ cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
+ | _ => True
+ end.
+
+ Lemma PSubstL1_ok: forall n LM1 P1 l,
+ MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+ intros; rsimpl.
+ intros (M2,P2) LM2 Hrec P3 l [H H1].
+ rewrite <- Hrec; auto.
+ apply PNSubst1_ok; auto.
+ Qed.
+
+ Lemma PSubstL_ok: forall n LM1 P1 P2 l,
+ PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+ intros; discriminate.
+ intros (M2,P2) LM2 Hrec P3 P4 l.
+ generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
+ intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
+ rewrite <- PSubstL1_ok; auto.
+ intros l1 H [H1 H2]; auto.
+ Qed.
+
+ Lemma PNSubstL_ok: forall m n LM1 P1 l,
+ MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l.
+ Proof.
+ intros m; elim m; simpl; auto.
+ intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+ case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ intros m1 Hrec n LM1 P2 l H.
+ generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+ case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ rewrite <- Hrec; auto.
+ Qed.
+
+ (** Definition of polynomial expressions *)
+
+ 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.
+
+ (** evaluation of polynomial expressions towards R *)
+ Definition mk_X j := mkPinj_pred j mkX.
+
+ (** evaluation of polynomial expressions towards R *)
+
+ Fixpoint PEeval (l:Env R) (pe:PExpr) {struct pe} : R :=
+ match pe with
+ | PEc c => phi c
+ | PEX j => nth 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.
+
+ (** Correctness proofs *)
+
+ Lemma mkX_ok : forall p l, nth p l == (mk_X p) @ l.
+ Proof.
+ destruct p;simpl;intros;Esimpl;trivial.
+ rewrite nth_spec ; auto.
+ unfold hd.
+ rewrite <- nth_Pdouble_minus_one.
+ rewrite (nth_jump (Pdouble_minus_one p) l 1).
+ reflexivity.
+ Qed.
+
+ Ltac Esimpl3 :=
+ repeat match goal with
+ | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
+ | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
+ end;Esimpl2;try rrefl;try apply (ARadd_comm ARth).
+
+(* Power using the chinise algorithm *)
+(*Section POWER.
+ Variable subst_l : Pol -> Pol.
+ Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol :=
+ match p with
+ | xH => P
+ | xO p => subst_l (Psquare (Ppow_pos P p))
+ | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
+ end.
+
+ Definition Ppow_N P n :=
+ match n with
+ | N0 => P1
+ | Npos p => Ppow_pos P p
+ end.
+
+ Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
+ Proof.
+ intros l subst_l_ok P.
+ induction p;simpl;intros;try rrefl;try rewrite subst_l_ok.
+ repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+ repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+ Qed.
+
+ Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+ Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed.
+
+ End POWER. *)
+
+Section POWER.
+ Variable subst_l : Pol -> Pol.
+ Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
+ match p with
+ | xH => subst_l (Pmul res P)
+ | xO p => Ppow_pos (Ppow_pos res P p) P p
+ | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P)
+ end.
+
+ Definition Ppow_N P n :=
+ match n with
+ | N0 => P1
+ | Npos p => Ppow_pos P1 P p
+ end.
+
+ Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
+ Proof.
+ intros l subst_l_ok res P p. generalize res;clear res.
+ induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp.
+ rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl.
+ Qed.
+
+ Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+ Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok. trivial. Esimpl. auto. Qed.
+
+ End POWER.
+
+ (** Normalization and rewriting *)
+
+ Section NORM_SUBST_REC.
+ Variable n : nat.
+ Variable lmp:list (Mon*Pol).
+ Let subst_l P := PNSubstL P lmp n n.
+ Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+ Let Ppow_subst := Ppow_N subst_l.
+
+ Fixpoint norm_aux (pe:PExpr) : Pol :=
+ match pe with
+ | PEc c => Pc c
+ | PEX j => mk_X j
+ | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
+ | PEadd pe1 (PEopp pe2) =>
+ Psub (norm_aux pe1) (norm_aux pe2)
+ | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2)
+ | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
+ | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2)
+ | PEopp pe1 => Popp (norm_aux pe1)
+ | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
+ end.
+
+ Definition norm_subst pe := subst_l (norm_aux pe).
+
+ (*
+ Fixpoint norm_subst (pe:PExpr) : Pol :=
+ match pe with
+ | PEc c => Pc c
+ | PEX j => subst_l (mk_X j)
+ | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
+ | PEadd pe1 (PEopp pe2) =>
+ Psub (norm_subst pe1) (norm_subst pe2)
+ | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2)
+ | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
+ | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2)
+ | PEopp pe1 => Popp (norm_subst pe1)
+ | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
+ end.
+
+ Lemma norm_subst_spec :
+ forall l pe, MPcond lmp l ->
+ PEeval l pe == (norm_subst pe)@l.
+ Proof.
+ intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l).
+ unfold subst_l;intros.
+ rewrite <- PNSubstL_ok;trivial. rrefl.
+ assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
+ intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
+ induction pe;simpl;Esimpl3.
+ rewrite subst_l_ok;apply mkX_ok.
+ rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
+ rewrite IHpe1;rewrite IHpe2;rrefl.
+ rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
+ rewrite IHpe;rrefl.
+ unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
+ rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+ induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
+ repeat rewrite Pmul_ok;rrefl.
+ Qed.
+*)
+ Lemma norm_aux_spec :
+ forall l pe, (*MPcond lmp l ->*)
+ PEeval l pe == (norm_aux pe)@l.
+ Proof.
+ intros.
+ induction pe;simpl;Esimpl3.
+ apply mkX_ok.
+ rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
+ rewrite IHpe1;rewrite IHpe2;rrefl.
+ rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
+ rewrite IHpe;rrefl.
+ rewrite Ppow_N_ok by reflexivity.
+ rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+ induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
+ repeat rewrite Pmul_ok;rrefl.
+ Qed.
+
+
+ End NORM_SUBST_REC.
+
+
+End MakeRingPol.
+
diff --git a/plugins/micromega/LICENSE.sos b/plugins/micromega/LICENSE.sos
new file mode 100644
index 00000000..5aadfa2a
--- /dev/null
+++ b/plugins/micromega/LICENSE.sos
@@ -0,0 +1,29 @@
+ HOL Light copyright notice, licence and disclaimer
+
+ (c) University of Cambridge 1998
+ (c) Copyright, John Harrison 1998-2006
+
+HOL Light version 2.20, hereinafter referred to as "the software", is a
+computer theorem proving system written by John Harrison. Much of the
+software was developed at the University of Cambridge Computer Laboratory,
+New Museums Site, Pembroke Street, Cambridge, CB2 3QG, England. The
+software is copyright, University of Cambridge 1998 and John Harrison
+1998-2006.
+
+Permission to use, copy, modify, and distribute the software and its
+documentation for any purpose and without fee is hereby granted. In the
+case of further distribution of the software the present text, including
+copyright notice, licence and disclaimer of warranty, must be included in
+full and unmodified form in any release. Distribution of derivative
+software obtained by modifying the software, or incorporating it into
+other software, is permitted, provided the inclusion of the software is
+acknowledged and that any changes made to the software are clearly
+documented.
+
+John Harrison and the University of Cambridge disclaim all warranties
+with regard to the software, including all implied warranties of
+merchantability and fitness. In no event shall John Harrison or the
+University of Cambridge be liable for any special, indirect,
+incidental or consequential damages or any damages whatsoever,
+including, but not limited to, those arising from computer failure or
+malfunction, work stoppage, loss of profit or loss of contracts.
diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
new file mode 100644
index 00000000..1d7fbd56
--- /dev/null
+++ b/plugins/micromega/MExtraction.v
@@ -0,0 +1,48 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+(* Used to generate micromega.ml *)
+
+Require Import ZMicromega.
+Require Import QMicromega.
+Require Import RMicromega.
+Require Import VarMap.
+Require Import RingMicromega.
+Require Import NArith.
+Require Import QArith.
+
+Extract Inductive prod => "( * )" [ "(,)" ].
+Extract Inductive List.list => list [ "[]" "(::)" ].
+Extract Inductive bool => bool [ true false ].
+Extract Inductive sumbool => bool [ true false ].
+Extract Inductive option => option [ Some None ].
+Extract Inductive sumor => option [ Some None ].
+(** Then, in a ternary alternative { }+{ }+{ },
+ - leftmost choice (Inleft Left) is (Some true),
+ - middle choice (Inleft Right) is (Some false),
+ - rightmost choice (Inright) is (None) *)
+
+
+(** To preserve its laziness, andb is normally expansed.
+ Let's rather use the ocaml && *)
+Extract Inlined Constant andb => "(&&)".
+
+Extraction "micromega.ml"
+ List.map simpl_cone (*map_cone indexes*)
+ denorm Qpower
+ n_of_Z Nnat.N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v
new file mode 100644
index 00000000..803dd903
--- /dev/null
+++ b/plugins/micromega/OrderedRing.v
@@ -0,0 +1,458 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* Evgeny Makarov, INRIA, 2007 *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import Ring.
+
+(** Generic properties of ordered rings on a setoid equality *)
+
+Set Implicit Arguments.
+
+Module Import OrderedRingSyntax.
+Export RingSyntax.
+
+Reserved Notation "x ~= y" (at level 70, no associativity).
+Reserved Notation "x [=] y" (at level 70, no associativity).
+Reserved Notation "x [~=] y" (at level 70, no associativity).
+Reserved Notation "x [<] y" (at level 70, no associativity).
+Reserved Notation "x [<=] y" (at level 70, no associativity).
+End OrderedRingSyntax.
+
+Section DEFINITIONS.
+
+Variable R : Type.
+Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
+Variable req rle rlt : R -> R -> Prop.
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+Record SOR : Type := mk_SOR_theory {
+ SORsetoid : Setoid_Theory R req;
+ SORplus_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
+ SORtimes_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
+ SORopp_wd : forall x1 x2, x1 == x2 -> -x1 == -x2;
+ SORle_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 <= y1 <-> x2 <= y2);
+ SORlt_wd : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> (x1 < y1 <-> x2 < y2);
+ SORrt : ring_theory rO rI rplus rtimes rminus ropp req;
+ SORle_refl : forall n : R, n <= n;
+ SORle_antisymm : forall n m : R, n <= m -> m <= n -> n == m;
+ SORle_trans : forall n m p : R, n <= m -> m <= p -> n <= p;
+ SORlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m;
+ SORlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n;
+ SORplus_le_mono_l : forall n m p : R, n <= m -> p + n <= p + m;
+ SORtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m;
+ SORneq_0_1 : 0 ~= 1
+}.
+
+(* We cannot use Relation_Definitions.order.ord_antisym and
+Relations_1.Antisymmetric because they refer to Leibniz equality *)
+
+End DEFINITIONS.
+
+Section STRICT_ORDERED_RING.
+
+Variable R : Type.
+Variable (rO rI : R) (rplus rtimes rminus: R -> R -> R) (ropp : R -> R).
+Variable req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+
+Add Relation R req
+ reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
+ symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
+ transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+as sor_setoid.
+
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact sor.(SORlt_wd).
+Qed.
+
+Add Ring SOR : sor.(SORrt).
+
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+intros x1 x2 H1 y1 y2 H2.
+rewrite (sor.(SORrt).(Rsub_def) x1 y1).
+rewrite (sor.(SORrt).(Rsub_def) x2 y2).
+rewrite H1; now rewrite H2.
+Qed.
+
+Theorem Rneq_symm : forall n m : R, n ~= m -> m ~= n.
+Proof.
+intros n m H1 H2; rewrite H2 in H1; now apply H1.
+Qed.
+
+(* Propeties of plus, minus and opp *)
+
+Theorem Rplus_0_l : forall n : R, 0 + n == n.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rplus_0_r : forall n : R, n + 0 == n.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rtimes_0_r : forall n : R, n * 0 == 0.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rplus_comm : forall n m : R, n + m == m + n.
+Proof.
+intros; ring.
+Qed.
+
+Theorem Rtimes_0_l : forall n : R, 0 * n == 0.
+Proof.
+intro; ring.
+Qed.
+
+Theorem Rtimes_comm : forall n m : R, n * m == m * n.
+Proof.
+intros; ring.
+Qed.
+
+Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m.
+Proof.
+intros n m.
+split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H.
+now rewrite Rplus_0_l.
+rewrite H; ring.
+Qed.
+
+Theorem Rplus_cancel_l : forall n m p : R, p + n == p + m <-> n == m.
+Proof.
+intros n m p; split; intro H.
+setoid_replace n with (- p + (p + n)) by ring.
+setoid_replace m with (- p + (p + m)) by ring. now rewrite H.
+now rewrite H.
+Qed.
+
+(* Relations *)
+
+Theorem Rle_refl : forall n : R, n <= n.
+Proof sor.(SORle_refl).
+
+Theorem Rle_antisymm : forall n m : R, n <= m -> m <= n -> n == m.
+Proof sor.(SORle_antisymm).
+
+Theorem Rle_trans : forall n m p : R, n <= m -> m <= p -> n <= p.
+Proof sor.(SORle_trans).
+
+Theorem Rlt_trichotomy : forall n m : R, n < m \/ n == m \/ m < n.
+Proof sor.(SORlt_trichotomy).
+
+Theorem Rlt_le_neq : forall n m : R, n < m <-> n <= m /\ n ~= m.
+Proof sor.(SORlt_le_neq).
+
+Theorem Rneq_0_1 : 0 ~= 1.
+Proof sor.(SORneq_0_1).
+
+Theorem Req_em : forall n m : R, n == m \/ n ~= m.
+Proof.
+intros n m. destruct (Rlt_trichotomy n m) as [H | [H | H]]; try rewrite Rlt_le_neq in H.
+right; now destruct H.
+now left.
+right; apply Rneq_symm; now destruct H.
+Qed.
+
+Theorem Req_dne : forall n m : R, ~ ~ n == m <-> n == m.
+Proof.
+intros n m; destruct (Req_em n m) as [H | H].
+split; auto.
+split. intro H1; false_hyp H H1. auto.
+Qed.
+
+Theorem Rle_lt_eq : forall n m : R, n <= m <-> n < m \/ n == m.
+Proof.
+intros n m; rewrite Rlt_le_neq.
+split; [intro H | intros [[H1 H2] | H]].
+destruct (Req_em n m) as [H1 | H1]. now right. left; now split.
+assumption.
+rewrite H; apply Rle_refl.
+Qed.
+
+Ltac le_less := rewrite Rle_lt_eq; left; try assumption.
+Ltac le_equal := rewrite Rle_lt_eq; right; try reflexivity; try assumption.
+Ltac le_elim H := rewrite Rle_lt_eq in H; destruct H as [H | H].
+
+Theorem Rlt_trans : forall n m p : R, n < m -> m < p -> n < p.
+Proof.
+intros n m p; repeat rewrite Rlt_le_neq; intros [H1 H2] [H3 H4]; split.
+now apply Rle_trans with m.
+intro H. rewrite H in H1. pose proof (Rle_antisymm H3 H1). now apply H4.
+Qed.
+
+Theorem Rle_lt_trans : forall n m p : R, n <= m -> m < p -> n < p.
+Proof.
+intros n m p H1 H2; le_elim H1.
+now apply Rlt_trans with (m := m). now rewrite H1.
+Qed.
+
+Theorem Rlt_le_trans : forall n m p : R, n < m -> m <= p -> n < p.
+Proof.
+intros n m p H1 H2; le_elim H2.
+now apply Rlt_trans with (m := m). now rewrite <- H2.
+Qed.
+
+Theorem Rle_gt_cases : forall n m : R, n <= m \/ m < n.
+Proof.
+intros n m; destruct (Rlt_trichotomy n m) as [H | [H | H]].
+left; now le_less. left; now le_equal. now right.
+Qed.
+
+Theorem Rlt_neq : forall n m : R, n < m -> n ~= m.
+Proof.
+intros n m; rewrite Rlt_le_neq; now intros [_ H].
+Qed.
+
+Theorem Rle_ngt : forall n m : R, n <= m <-> ~ m < n.
+Proof.
+intros n m; split.
+intros H H1; assert (H2 : n < n) by now apply Rle_lt_trans with m. now apply (Rlt_neq H2).
+intro H. destruct (Rle_gt_cases n m) as [H1 | H1]. assumption. false_hyp H1 H.
+Qed.
+
+Theorem Rlt_nge : forall n m : R, n < m <-> ~ m <= n.
+Proof.
+intros n m; split.
+intros H H1; assert (H2 : n < n) by now apply Rlt_le_trans with m. now apply (Rlt_neq H2).
+intro H. destruct (Rle_gt_cases m n) as [H1 | H1]. false_hyp H1 H. assumption.
+Qed.
+
+(* Plus, minus and order *)
+
+Theorem Rplus_le_mono_l : forall n m p : R, n <= m <-> p + n <= p + m.
+Proof.
+intros n m p; split.
+apply sor.(SORplus_le_mono_l).
+intro H. apply (sor.(SORplus_le_mono_l) (p + n) (p + m) (- p)) in H.
+setoid_replace (- p + (p + n)) with n in H by ring.
+setoid_replace (- p + (p + m)) with m in H by ring. assumption.
+Qed.
+
+Theorem Rplus_le_mono_r : forall n m p : R, n <= m <-> n + p <= m + p.
+Proof.
+intros n m p; rewrite (Rplus_comm n p); rewrite (Rplus_comm m p).
+apply Rplus_le_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono_l : forall n m p : R, n < m <-> p + n < p + m.
+Proof.
+intros n m p; do 2 rewrite Rlt_le_neq. rewrite Rplus_cancel_l.
+now rewrite <- Rplus_le_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono_r : forall n m p : R, n < m <-> n + p < m + p.
+Proof.
+intros n m p.
+rewrite (Rplus_comm n p); rewrite (Rplus_comm m p); apply Rplus_lt_mono_l.
+Qed.
+
+Theorem Rplus_lt_mono : forall n m p q : R, n < m -> p < q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rlt_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_lt_mono_l].
+Qed.
+
+Theorem Rplus_le_mono : forall n m p q : R, n <= m -> p <= q -> n + p <= m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rle_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_le_mono_l].
+Qed.
+
+Theorem Rplus_lt_le_mono : forall n m p q : R, n < m -> p <= q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rlt_le_trans with (m + p); [now apply -> Rplus_lt_mono_r | now apply -> Rplus_le_mono_l].
+Qed.
+
+Theorem Rplus_le_lt_mono : forall n m p q : R, n <= m -> p < q -> n + p < m + q.
+Proof.
+intros n m p q H1 H2.
+apply Rle_lt_trans with (m + p); [now apply -> Rplus_le_mono_r | now apply -> Rplus_lt_mono_l].
+Qed.
+
+Theorem Rplus_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_mono.
+Qed.
+
+Theorem Rplus_pos_nonneg : forall n m : R, 0 < n -> 0 <= m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_lt_le_mono.
+Qed.
+
+Theorem Rplus_nonneg_pos : forall n m : R, 0 <= n -> 0 < m -> 0 < n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_lt_mono.
+Qed.
+
+Theorem Rplus_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n + m.
+Proof.
+intros n m H1 H2. rewrite <- (Rplus_0_l 0). now apply Rplus_le_mono.
+Qed.
+
+Theorem Rle_le_minus : forall n m : R, n <= m <-> 0 <= m - n.
+Proof.
+intros n m. rewrite (@Rplus_le_mono_r n m (- n)).
+setoid_replace (n + - n) with 0 by ring.
+now setoid_replace (m + - n) with (m - n) by ring.
+Qed.
+
+Theorem Rlt_lt_minus : forall n m : R, n < m <-> 0 < m - n.
+Proof.
+intros n m. rewrite (@Rplus_lt_mono_r n m (- n)).
+setoid_replace (n + - n) with 0 by ring.
+now setoid_replace (m + - n) with (m - n) by ring.
+Qed.
+
+Theorem Ropp_lt_mono : forall n m : R, n < m <-> - m < - n.
+Proof.
+intros n m. split; intro H.
+apply -> (@Rplus_lt_mono_l n m (- n - m)) in H.
+setoid_replace (- n - m + n) with (- m) in H by ring.
+now setoid_replace (- n - m + m) with (- n) in H by ring.
+apply -> (@Rplus_lt_mono_l (- m) (- n) (n + m)) in H.
+setoid_replace (n + m + - m) with n in H by ring.
+now setoid_replace (n + m + - n) with m in H by ring.
+Qed.
+
+Theorem Ropp_pos_neg : forall n : R, 0 < - n <-> n < 0.
+Proof.
+intro n; rewrite (Ropp_lt_mono n 0). now setoid_replace (- 0) with 0 by ring.
+Qed.
+
+(* Times and order *)
+
+Theorem Rtimes_pos_pos : forall n m : R, 0 < n -> 0 < m -> 0 < n * m.
+Proof sor.(SORtimes_pos_pos).
+
+Theorem Rtimes_nonneg_nonneg : forall n m : R, 0 <= n -> 0 <= m -> 0 <= n * m.
+Proof.
+intros n m H1 H2.
+le_elim H1. le_elim H2.
+le_less; now apply Rtimes_pos_pos.
+rewrite <- H2; rewrite Rtimes_0_r; le_equal.
+rewrite <- H1; rewrite Rtimes_0_l; le_equal.
+Qed.
+
+Theorem Rtimes_pos_neg : forall n m : R, 0 < n -> m < 0 -> n * m < 0.
+Proof.
+intros n m H1 H2. apply -> Ropp_pos_neg.
+setoid_replace (- (n * m)) with (n * (- m)) by ring.
+apply Rtimes_pos_pos. assumption. now apply <- Ropp_pos_neg.
+Qed.
+
+Theorem Rtimes_neg_neg : forall n m : R, n < 0 -> m < 0 -> 0 < n * m.
+Proof.
+intros n m H1 H2.
+setoid_replace (n * m) with ((- n) * (- m)) by ring.
+apply Rtimes_pos_pos; now apply <- Ropp_pos_neg.
+Qed.
+
+Theorem Rtimes_square_nonneg : forall n : R, 0 <= n * n.
+Proof.
+intro n; destruct (Rlt_trichotomy 0 n) as [H | [H | H]].
+le_less; now apply Rtimes_pos_pos.
+rewrite <- H, Rtimes_0_l; le_equal.
+le_less; now apply Rtimes_neg_neg.
+Qed.
+
+Theorem Rtimes_neq_0 : forall n m : R, n ~= 0 /\ m ~= 0 -> n * m ~= 0.
+Proof.
+intros n m [H1 H2].
+destruct (Rlt_trichotomy n 0) as [H3 | [H3 | H3]];
+destruct (Rlt_trichotomy m 0) as [H4 | [H4 | H4]];
+try (false_hyp H3 H1); try (false_hyp H4 H2).
+apply Rneq_symm. apply Rlt_neq. now apply Rtimes_neg_neg.
+apply Rlt_neq. rewrite Rtimes_comm. now apply Rtimes_pos_neg.
+apply Rlt_neq. now apply Rtimes_pos_neg.
+apply Rneq_symm. apply Rlt_neq. now apply Rtimes_pos_pos.
+Qed.
+
+(* The following theorems are used to build a morphism from Z to R and
+prove its properties in ZCoeff.v. They are not used in RingMicromega.v. *)
+
+(* Surprisingly, multilication is needed to prove the following theorem *)
+
+Theorem Ropp_neg_pos : forall n : R, - n < 0 <-> 0 < n.
+Proof.
+intro n; setoid_replace n with (- - n) by ring. rewrite Ropp_pos_neg.
+now setoid_replace (- - n) with n by ring.
+Qed.
+
+Theorem Rlt_0_1 : 0 < 1.
+Proof.
+apply <- Rlt_le_neq. split.
+setoid_replace 1 with (1 * 1) by ring. apply Rtimes_square_nonneg.
+apply Rneq_0_1.
+Qed.
+
+Theorem Rlt_succ_r : forall n : R, n < 1 + n.
+Proof.
+intro n. rewrite <- (Rplus_0_l n); setoid_replace (1 + (0 + n)) with (1 + n) by ring.
+apply -> Rplus_lt_mono_r. apply Rlt_0_1.
+Qed.
+
+Theorem Rlt_lt_succ : forall n m : R, n < m -> n < 1 + m.
+Proof.
+intros n m H; apply Rlt_trans with m. assumption. apply Rlt_succ_r.
+Qed.
+
+(*Theorem Rtimes_lt_mono_pos_l : forall n m p : R, 0 < p -> n < m -> p * n < p * m.
+Proof.
+intros n m p H1 H2. apply <- Rlt_lt_minus.
+setoid_replace (p * m - p * n) with (p * (m - n)) by ring.
+apply Rtimes_pos_pos. assumption. now apply -> Rlt_lt_minus.
+Qed.*)
+
+End STRICT_ORDERED_RING.
+
diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v
new file mode 100644
index 00000000..444a590a
--- /dev/null
+++ b/plugins/micromega/Psatz.v
@@ -0,0 +1,86 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import ZMicromega.
+Require Import QMicromega.
+Require Import RMicromega.
+Require Import QArith.
+Require Export Ring_normalize.
+Require Import ZArith.
+Require Import Raxioms.
+Require Export RingMicromega.
+Require Import VarMap.
+Require Tauto.
+Declare ML Module "micromega_plugin".
+
+Ltac xpsatz dom d :=
+ let tac := lazymatch dom with
+ | Z =>
+ (sos_Z || psatz_Z d) ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | R =>
+ (sos_R || psatz_R d) ;
+ (* If csdp is not installed, the previous step might not produce any
+ progress: the rest of the tactical will then fail. Hence the 'try'. *)
+ try (intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
+ apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+ | Q =>
+ (sos_Q || psatz_Q d) ;
+ (* If csdp is not installed, the previous step might not produce any
+ progress: the rest of the tactical will then fail. Hence the 'try'. *)
+ try (intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
+ apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+ | _ => fail "Unsupported domain"
+ end in tac.
+
+Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
+Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1.
+
+Ltac psatzl dom :=
+ let tac := lazymatch dom with
+ | Z =>
+ psatzl_Z ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | Q =>
+ psatzl_Q ;
+ (* If csdp is not installed, the previous step might not produce any
+ progress: the rest of the tactical will then fail. Hence the 'try'. *)
+ try (intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
+ apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+ | R =>
+ 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'. *)
+ try (intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
+ apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity)
+ | _ => fail "Unsupported domain"
+ end in tac.
+
+Ltac lia :=
+ xlia ;
+ 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
new file mode 100644
index 00000000..1e909cbc
--- /dev/null
+++ b/plugins/micromega/QMicromega.v
@@ -0,0 +1,197 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import Refl.
+Require Import QArith.
+Require Import Qfield.
+(*Declare ML Module "micromega_plugin".*)
+
+Lemma Qsor : SOR 0 1 Qplus Qmult Qminus Qopp Qeq Qle Qlt.
+Proof.
+ constructor; intros ; subst ; try (intuition (subst; auto with qarith)).
+ apply Q_Setoid.
+ rewrite H ; rewrite H0 ; reflexivity.
+ rewrite H ; rewrite H0 ; reflexivity.
+ rewrite H ; auto ; reflexivity.
+ rewrite <- H ; rewrite <- H0 ; auto.
+ rewrite H ; rewrite H0 ; auto.
+ rewrite <- H ; rewrite <- H0 ; auto.
+ rewrite H ; rewrite H0 ; auto.
+ apply Qsrt.
+ eapply Qle_trans ; eauto.
+ apply (Qlt_not_eq n m H H0) ; auto.
+ destruct(Q_dec n m) as [[H1 |H1] | H1 ] ; tauto.
+ apply (Qplus_le_compat p p n m (Qle_refl p) H).
+ generalize (Qmult_lt_compat_r 0 n m H0 H).
+ rewrite Qmult_0_l.
+ auto.
+ compute in H.
+ discriminate.
+Qed.
+
+
+Lemma QSORaddon :
+ SORaddon 0 1 Qplus Qmult Qminus Qopp Qeq Qle (* ring elements *)
+ 0 1 Qplus Qmult Qminus Qopp (* coefficients *)
+ Qeq_bool Qle_bool
+ (fun x => x) (fun x => x) (pow_N 1 Qmult).
+Proof.
+ constructor.
+ constructor ; intros ; try reflexivity.
+ apply Qeq_bool_eq; auto.
+ constructor.
+ reflexivity.
+ intros x y.
+ apply Qeq_bool_neq ; auto.
+ apply Qle_bool_imp_le.
+Qed.
+
+
+(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*)
+Require Import EnvRing.
+
+Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q :=
+ match e with
+ | PEc c => c
+ | PEX j => env j
+ | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
+ | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
+ | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
+ | PEopp pe1 => - (Qeval_expr env pe1)
+ | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n)
+ end.
+
+Lemma Qeval_expr_simpl : forall env e,
+ Qeval_expr env e =
+ match e with
+ | PEc c => c
+ | PEX j => env j
+ | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2)
+ | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2)
+ | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2)
+ | PEopp pe1 => - (Qeval_expr env pe1)
+ | PEpow pe1 n => Qpower (Qeval_expr env pe1) (Z_of_N n)
+ end.
+Proof.
+ destruct e ; reflexivity.
+Qed.
+
+Definition Qeval_expr' := eval_pexpr Qplus Qmult Qminus Qopp (fun x => x) (fun x => x) (pow_N 1 Qmult).
+
+Lemma QNpower : forall r n, r ^ Z_of_N n = pow_N 1 Qmult r n.
+Proof.
+ destruct n ; reflexivity.
+Qed.
+
+
+Lemma Qeval_expr_compat : forall env e, Qeval_expr env e = Qeval_expr' env e.
+Proof.
+ induction e ; simpl ; subst ; try congruence.
+ reflexivity.
+ rewrite IHe.
+ apply QNpower.
+Qed.
+
+Definition Qeval_op2 (o : Op2) : Q -> Q -> Prop :=
+match o with
+| OpEq => Qeq
+| OpNEq => fun x y => ~ x == y
+| OpLe => Qle
+| OpGe => fun x y => Qle y x
+| OpLt => Qlt
+| OpGt => fun x y => Qlt y x
+end.
+
+Definition Qeval_formula (e:PolEnv Q) (ff : Formula Q) :=
+ let (lhs,o,rhs) := ff in Qeval_op2 o (Qeval_expr e lhs) (Qeval_expr e rhs).
+
+Definition Qeval_formula' :=
+ eval_formula Qplus Qmult Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).
+
+Lemma Qeval_formula_compat : forall env f, Qeval_formula env f <-> Qeval_formula' env f.
+Proof.
+ intros.
+ unfold Qeval_formula.
+ destruct f.
+ repeat rewrite Qeval_expr_compat.
+ unfold Qeval_formula'.
+ unfold Qeval_expr'.
+ split ; destruct Fop ; simpl; auto.
+Qed.
+
+
+Definition Qeval_nformula :=
+ eval_nformula 0 Qplus Qmult Qeq Qle Qlt (fun x => x) .
+
+Definition Qeval_op1 (o : Op1) : Q -> Prop :=
+match o with
+| Equal => fun x : Q => x == 0
+| NonEqual => fun x : Q => ~ x == 0
+| Strict => fun x : Q => 0 < x
+| NonStrict => fun x : Q => 0 <= x
+end.
+
+
+Lemma Qeval_nformula_dec : forall env d, (Qeval_nformula env d) \/ ~ (Qeval_nformula env d).
+Proof.
+ exact (fun env d =>eval_nformula_dec Qsor (fun x => x) env d).
+Qed.
+
+Definition QWitness := Psatz Q.
+
+Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qeq_bool Qle_bool.
+
+Require Import List.
+
+Lemma QWeakChecker_sound : forall (l : list (NFormula Q)) (cm : QWitness),
+ QWeakChecker l cm = true ->
+ forall env, make_impl (Qeval_nformula env) l False.
+Proof.
+ intros l cm H.
+ intro.
+ unfold Qeval_nformula.
+ apply (checker_nf_sound Qsor QSORaddon l cm).
+ unfold QWeakChecker in H.
+ exact H.
+Qed.
+
+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 QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool :=
+ @tauto_checker (Formula Q) (NFormula Q)
+ Qnormalise
+ Qnegate QWitness QWeakChecker f w.
+
+
+
+Lemma QTautoChecker_sound : forall f w, QTautoChecker f w = true -> forall env, eval_f (Qeval_formula env) f.
+Proof.
+ intros f w.
+ unfold QTautoChecker.
+ apply (tauto_checker_sound Qeval_formula Qeval_nformula).
+ apply Qeval_nformula_dec.
+ 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.
+ apply QWeakChecker_sound.
+Qed.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
new file mode 100644
index 00000000..21f991ef
--- /dev/null
+++ b/plugins/micromega/RMicromega.v
@@ -0,0 +1,182 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import Refl.
+Require Import Raxioms RIneq Rpow_def DiscrR.
+Require Setoid.
+(*Declare ML Module "micromega_plugin".*)
+
+Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R).
+Proof.
+ constructor.
+ exact Rplus_0_l.
+ exact Rplus_comm.
+ intros. rewrite Rplus_assoc. auto.
+ exact Rmult_1_l.
+ exact Rmult_comm.
+ intros ; rewrite Rmult_assoc ; auto.
+ intros. rewrite Rmult_comm. rewrite Rmult_plus_distr_l.
+ rewrite (Rmult_comm z). rewrite (Rmult_comm z). auto.
+ reflexivity.
+ exact Rplus_opp_r.
+Qed.
+
+Add Ring Rring : Rsrt.
+Open Scope R_scope.
+
+Lemma Rmult_neutral : forall x:R , 0 * x = 0.
+Proof.
+ intro ; ring.
+Qed.
+
+
+Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt.
+Proof.
+ constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)).
+ constructor.
+ constructor.
+ unfold RelationClasses.Symmetric. auto.
+ unfold RelationClasses.Transitive. intros. subst. reflexivity.
+ apply Rsrt.
+ eapply Rle_trans ; eauto.
+ apply (Rlt_irrefl m) ; auto.
+ apply Rnot_le_lt. auto with real.
+ destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto.
+ intros.
+ rewrite <- (Rmult_neutral m).
+ apply (Rmult_lt_compat_r) ; auto.
+Qed.
+
+Require ZMicromega.
+(* R with coeffs in Z *)
+
+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.
+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 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.
+Qed.
+
+
+Require Import EnvRing.
+
+Definition INZ (n:N) : R :=
+ match n with
+ | N0 => IZR 0%Z
+ | Npos p => IZR (Zpos p)
+ end.
+
+Definition Reval_expr := eval_pexpr Rplus Rmult Rminus Ropp IZR Nnat.nat_of_N pow.
+
+
+Definition Reval_op2 (o:Op2) : R -> R -> Prop :=
+ match o with
+ | OpEq => @eq R
+ | OpNEq => fun x y => ~ x = y
+ | OpLe => Rle
+ | OpGe => Rge
+ | OpLt => Rlt
+ | OpGt => Rgt
+ end.
+
+
+Definition Reval_formula (e: PolEnv R) (ff : Formula Z) :=
+ 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.
+
+Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f.
+Proof.
+ intros.
+ unfold Reval_formula.
+ destruct f.
+ unfold Reval_formula'.
+ unfold Reval_expr.
+ split ; destruct Fop ; simpl ; auto.
+ apply Rge_le.
+ apply Rle_ge.
+Qed.
+
+Definition Reval_nformula :=
+ eval_nformula 0 Rplus Rmult (@eq R) Rle Rlt IZR.
+
+
+Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d).
+Proof.
+ exact (fun env d =>eval_nformula_dec Rsor IZR env d).
+Qed.
+
+Definition RWitness := Psatz Z.
+
+Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zeq_bool Zle_bool.
+
+Require Import List.
+
+Lemma RWeakChecker_sound : forall (l : list (NFormula Z)) (cm : RWitness),
+ RWeakChecker l cm = true ->
+ forall env, make_impl (Reval_nformula env) l False.
+Proof.
+ intros l cm H.
+ intro.
+ unfold Reval_nformula.
+ apply (checker_nf_sound Rsor RZSORaddon 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 RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool :=
+ @tauto_checker (Formula Z) (NFormula Z)
+ Rnormalise Rnegate
+ RWitness RWeakChecker 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).
+ 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).
+ 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
new file mode 100644
index 00000000..3b0de76b
--- /dev/null
+++ b/plugins/micromega/Refl.v
@@ -0,0 +1,130 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import List.
+Require Setoid.
+
+Set Implicit Arguments.
+
+(* Refl of '->' '/\': basic properties *)
+
+Fixpoint make_impl (A : Type) (eval : A -> Prop) (l : list A) (goal : Prop) {struct l} : Prop :=
+ match l with
+ | nil => goal
+ | cons e l => (eval e) -> (make_impl eval l goal)
+ end.
+
+Theorem make_impl_true :
+ forall (A : Type) (eval : A -> Prop) (l : list A), make_impl eval l True.
+Proof.
+induction l as [| a l IH]; simpl.
+trivial.
+intro; apply IH.
+Qed.
+
+Fixpoint make_conj (A : Type) (eval : A -> Prop) (l : list A) {struct l} : Prop :=
+ match l with
+ | nil => True
+ | cons e nil => (eval e)
+ | cons e l2 => ((eval e) /\ (make_conj eval l2))
+ end.
+
+Theorem make_conj_cons : forall (A : Type) (eval : A -> Prop) (a : A) (l : list A),
+ make_conj eval (a :: l) <-> eval a /\ make_conj eval l.
+Proof.
+intros; destruct l; simpl; tauto.
+Qed.
+
+
+Lemma make_conj_impl : forall (A : Type) (eval : A -> Prop) (l : list A) (g : Prop),
+ (make_conj eval l -> g) <-> make_impl eval l g.
+Proof.
+ induction l.
+ simpl.
+ tauto.
+ simpl.
+ intros.
+ destruct l.
+ simpl.
+ tauto.
+ generalize (IHl g).
+ tauto.
+Qed.
+
+Lemma make_conj_in : forall (A : Type) (eval : A -> Prop) (l : list A),
+ make_conj eval l -> (forall p, In p l -> eval p).
+Proof.
+ induction l.
+ simpl.
+ tauto.
+ simpl.
+ intros.
+ destruct l.
+ simpl in H0.
+ destruct H0.
+ subst; auto.
+ tauto.
+ destruct H.
+ destruct H0.
+ subst;auto.
+ apply IHl; auto.
+Qed.
+
+
+
+Lemma make_conj_app : forall A eval l1 l2, @make_conj A eval (l1 ++ l2) <-> @make_conj A eval l1 /\ @make_conj A eval l2.
+Proof.
+ induction l1.
+ simpl.
+ tauto.
+ intros.
+ change ((a::l1) ++ l2) with (a :: (l1 ++ l2)).
+ rewrite make_conj_cons.
+ rewrite IHl1.
+ rewrite make_conj_cons.
+ tauto.
+Qed.
+
+Lemma not_make_conj_cons : forall (A:Type) (t:A) a eval (no_middle_eval : (eval t) \/ ~ (eval t)),
+ ~ make_conj eval (t ::a) -> ~ (eval t) \/ (~ make_conj eval a).
+Proof.
+ intros.
+ simpl in H.
+ destruct a.
+ tauto.
+ tauto.
+Qed.
+
+Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval
+ (no_middle_eval : forall d, eval d \/ ~ eval d) ,
+ ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a).
+Proof.
+ induction t.
+ simpl.
+ tauto.
+ intros.
+ simpl ((a::t)++a0)in H.
+ destruct (@not_make_conj_cons _ _ _ _ (no_middle_eval a) H).
+ left ; red ; intros.
+ apply H0.
+ rewrite make_conj_cons in H1.
+ tauto.
+ destruct (IHt _ _ no_middle_eval H0).
+ left ; red ; intros.
+ apply H1.
+ rewrite make_conj_cons in H2.
+ tauto.
+ right ; auto.
+Qed.
diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
new file mode 100644
index 00000000..d556cd03
--- /dev/null
+++ b/plugins/micromega/RingMicromega.v
@@ -0,0 +1,884 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* Evgeny Makarov, INRIA, 2007 *)
+(************************************************************************)
+
+Require Import NArith.
+Require Import Relation_Definitions.
+Require Import Setoid.
+(*****)
+Require Import Env.
+Require Import EnvRing.
+(*****)
+Require Import List.
+Require Import Bool.
+Require Import OrderedRing.
+Require Import Refl.
+
+Set Implicit Arguments.
+
+Import OrderedRingSyntax.
+
+Section Micromega.
+
+(* Assume we have a strict(ly?) ordered ring *)
+
+Variable R : Type.
+Variables rO rI : R.
+Variables rplus rtimes rminus: R -> R -> R.
+Variable ropp : R -> R.
+Variables req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+(* Assume we have a type of coefficients C and a morphism from C to R *)
+
+Variable C : Type.
+Variables cO cI : C.
+Variables cplus ctimes cminus: C -> C -> C.
+Variable copp : C -> C.
+Variables ceqb cleb : C -> C -> bool.
+Variable phi : C -> R.
+
+(* Power coefficients *)
+Variable E : Set. (* the type of exponents *)
+Variable pow_phi : N -> E.
+Variable rpow : R -> E -> R.
+
+Notation "[ x ]" := (phi x).
+Notation "x [=] y" := (ceqb x y).
+Notation "x [<=] y" := (cleb x y).
+
+(* Let's collect all hypotheses in addition to the ordered ring axioms into
+one structure *)
+
+Record SORaddon := mk_SOR_addon {
+ SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi;
+ SORpower : power_theory rI rtimes req pow_phi rpow;
+ SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y];
+ SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y]
+}.
+
+Variable addon : SORaddon.
+
+Add Relation R req
+ reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _ )
+ symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _ )
+ transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _ )
+as micomega_sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+ exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+ exact sor.(SORlt_wd).
+Qed.
+
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+ exact (rminus_morph sor). (* We already proved that minus is a morphism in OrderedRing.v *)
+Qed.
+
+Definition cneqb (x y : C) := negb (ceqb x y).
+Definition cltb (x y : C) := (cleb x y) && (cneqb x y).
+
+Notation "x [~=] y" := (cneqb x y).
+Notation "x [<] y" := (cltb x y).
+
+Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
+Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
+Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H].
+
+Lemma cleb_sound : forall x y : C, x [<=] y = true -> [x] <= [y].
+Proof.
+ exact addon.(SORcleb_morph).
+Qed.
+
+Lemma cneqb_sound : forall x y : C, x [~=] y = true -> [x] ~= [y].
+Proof.
+intros x y H1. apply addon.(SORcneqb_morph). unfold cneqb, negb in H1.
+destruct (ceqb x y); now try discriminate.
+Qed.
+
+
+Lemma cltb_sound : forall x y : C, x [<] y = true -> [x] < [y].
+Proof.
+intros x y H. unfold cltb in H. apply andb_prop in H. destruct H as [H1 H2].
+apply cleb_sound in H1. apply cneqb_sound in H2. apply <- (Rlt_le_neq sor). now split.
+Qed.
+
+(* Begin Micromega *)
+
+Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
+Definition PolEnv := Env R. (* For interpreting PolC *)
+Definition eval_pol (env : PolEnv) (p:PolC) : R :=
+ Pphi 0 rplus rtimes phi env p.
+
+Inductive Op1 : Set := (* relations with 0 *)
+| Equal (* == 0 *)
+| NonEqual (* ~= 0 *)
+| Strict (* > 0 *)
+| NonStrict (* >= 0 *).
+
+Definition NFormula := (PolC * Op1)%type. (* normalized formula *)
+
+Definition eval_op1 (o : Op1) : R -> Prop :=
+match o with
+| Equal => fun x => x == 0
+| NonEqual => fun x : R => x ~= 0
+| Strict => fun x : R => 0 < x
+| NonStrict => fun x : R => 0 <= x
+end.
+
+Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop :=
+let (p, op) := f in eval_op1 op (eval_pol env p).
+
+
+(** Rule of "signs" for addition and multiplication.
+ An arbitrary result is coded buy None. *)
+
+Definition OpMult (o o' : Op1) : option Op1 :=
+match o with
+| Equal => Some Equal
+| NonStrict =>
+ match o' with
+ | Equal => Some Equal
+ | NonEqual => None
+ | Strict => Some NonStrict
+ | NonStrict => Some NonStrict
+ end
+| Strict => match o' with
+ | NonEqual => None
+ | _ => Some o'
+ end
+| NonEqual => match o' with
+ | Equal => Some Equal
+ | NonEqual => Some NonEqual
+ | _ => None
+ end
+end.
+
+Definition OpAdd (o o': Op1) : option Op1 :=
+ match o with
+ | Equal => Some o'
+ | NonStrict =>
+ match o' with
+ | Strict => Some Strict
+ | NonEqual => None
+ | _ => Some NonStrict
+ end
+ | Strict => match o' with
+ | NonEqual => None
+ | _ => Some Strict
+ end
+ | NonEqual => match o' with
+ | Equal => Some NonEqual
+ | _ => None
+ end
+ end.
+
+
+Lemma OpMult_sound :
+ forall (o o' om: Op1) (x y : R),
+ eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y).
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3.
+(* x == 0 *)
+inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor).
+(* x ~= 0 *)
+destruct o' ; inversion H3.
+ (* y == 0 *)
+ rewrite H2. now rewrite (Rtimes_0_r sor).
+ (* y ~= 0 *)
+ apply (Rtimes_neq_0 sor) ; auto.
+(* 0 < x *)
+destruct o' ; inversion H3.
+ (* y == 0 *)
+ rewrite H2; now rewrite (Rtimes_0_r sor).
+ (* 0 < y *)
+ now apply (Rtimes_pos_pos sor).
+ (* 0 <= y *)
+ apply (Rtimes_nonneg_nonneg sor); [le_less | assumption].
+(* 0 <= x *)
+destruct o' ; inversion H3.
+ (* y == 0 *)
+ rewrite H2; now rewrite (Rtimes_0_r sor).
+ (* 0 < y *)
+ apply (Rtimes_nonneg_nonneg sor); [assumption | le_less ].
+ (* 0 <= y *)
+ now apply (Rtimes_nonneg_nonneg sor).
+Qed.
+
+Lemma OpAdd_sound :
+ forall (o o' oa : Op1) (e e' : R),
+ eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e').
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa.
+(* e == 0 *)
+inversion Hoa. rewrite <- H0.
+destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor).
+(* e ~= 0 *)
+ destruct o'.
+ (* e' == 0 *)
+ inversion Hoa.
+ rewrite H2. now rewrite (Rplus_0_r sor).
+ (* e' ~= 0 *)
+ discriminate.
+ (* 0 < e' *)
+ discriminate.
+ (* 0 <= e' *)
+ discriminate.
+(* 0 < e *)
+ destruct o'.
+ (* e' == 0 *)
+ inversion Hoa.
+ rewrite H2. now rewrite (Rplus_0_r sor).
+ (* e' ~= 0 *)
+ discriminate.
+ (* 0 < e' *)
+ inversion Hoa.
+ now apply (Rplus_pos_pos sor).
+ (* 0 <= e' *)
+ inversion Hoa.
+ now apply (Rplus_pos_nonneg sor).
+(* 0 <= e *)
+ destruct o'.
+ (* e' == 0 *)
+ inversion Hoa.
+ now rewrite H2, (Rplus_0_r sor).
+ (* e' ~= 0 *)
+ discriminate.
+ (* 0 < e' *)
+ inversion Hoa.
+ now apply (Rplus_nonneg_pos sor).
+ (* 0 <= e' *)
+ inversion Hoa.
+ now apply (Rplus_nonneg_nonneg sor).
+Qed.
+
+Inductive Psatz : Type :=
+| PsatzIn : nat -> Psatz
+| PsatzSquare : PolC -> Psatz
+| PsatzMulC : PolC -> Psatz -> Psatz
+| PsatzMulE : Psatz -> Psatz -> Psatz
+| PsatzAdd : Psatz -> Psatz -> Psatz
+| PsatzC : C -> Psatz
+| PsatzZ : Psatz.
+
+(** Given a list [l] of NFormula and an extended polynomial expression
+ [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a
+ logic consequence of the conjunction of the formulae in l.
+ Moreover, the polynomial expression is obtained by replacing the (PsatzIn n)
+ by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *)
+
+(* Might be defined elsewhere *)
+Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B :=
+ match o with
+ | None => None
+ | Some x => f x
+ end.
+
+Implicit Arguments map_option [A B].
+
+Definition map_option2 (A B C : Type) (f : A -> B -> option C)
+ (o: option A) (o': option B) : option C :=
+ match o , o' with
+ | None , _ => None
+ | _ , None => None
+ | Some x , Some x' => f x x'
+ end.
+
+Implicit Arguments map_option2 [A B C].
+
+Definition Rops_wd := mk_reqe rplus rtimes ropp req
+ sor.(SORplus_wd)
+ sor.(SORtimes_wd)
+ sor.(SORopp_wd).
+
+Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula :=
+ let (ef,o) := f in
+ match o with
+ | Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal)
+ | _ => None
+ end.
+
+Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula :=
+ 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).
+
+ Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula :=
+ 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).
+
+
+Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula :=
+ match e with
+ | PsatzIn n => Some (nth n l (Pc cO, Equal))
+ | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e , NonStrict)
+ | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e)
+ | PsatzMulE f1 f2 => map_option2 nformula_times_nformula (eval_Psatz l f1) (eval_Psatz l f2)
+ | PsatzAdd f1 f2 => map_option2 nformula_plus_nformula (eval_Psatz l f1) (eval_Psatz l f2)
+ | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None
+(* This could be 0, or <> 0 -- but these cases are useless *)
+ | 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'.
+Proof.
+ unfold pexpr_times_nformula.
+ destruct f.
+ intros. destruct o ; inversion H0 ; try discriminate.
+ simpl in *. unfold eval_pol in *.
+ rewrite (Pmul_ok sor.(SORsetoid) Rops_wd
+ (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
+ rewrite H. apply (Rtimes_0_r sor).
+Qed.
+
+Lemma nformula_times_nformula_correct : forall (env:PolEnv)
+ (f1 f2 f : NFormula),
+ eval_nformula env f1 -> eval_nformula env f2 ->
+ nformula_times_nformula f1 f2 = Some f ->
+ eval_nformula env f.
+Proof.
+ unfold nformula_times_nformula.
+ destruct f1 ; destruct f2.
+ case_eq (OpMult o o0) ; simpl ; try discriminate.
+ intros. inversion H2 ; simpl.
+ unfold eval_pol.
+ destruct o1; simpl;
+ rewrite (Pmul_ok sor.(SORsetoid) Rops_wd
+ (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm));
+ apply OpMult_sound with (3:= H);assumption.
+Qed.
+
+Lemma nformula_plus_nformula_correct : forall (env:PolEnv)
+ (f1 f2 f : NFormula),
+ eval_nformula env f1 -> eval_nformula env f2 ->
+ nformula_plus_nformula f1 f2 = Some f ->
+ eval_nformula env f.
+Proof.
+ unfold nformula_plus_nformula.
+ destruct f1 ; destruct f2.
+ case_eq (OpAdd o o0) ; simpl ; try discriminate.
+ intros. inversion H2 ; simpl.
+ unfold eval_pol.
+ destruct o1; simpl;
+ rewrite (Padd_ok sor.(SORsetoid) Rops_wd
+ (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm));
+ apply OpAdd_sound with (3:= H);assumption.
+Qed.
+
+Lemma eval_Psatz_Sound :
+ forall (l : list NFormula) (env : PolEnv),
+ (forall (f : NFormula), In f l -> eval_nformula env f) ->
+ forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f ->
+ eval_nformula env f.
+Proof.
+ induction e.
+ (* PsatzIn *)
+ simpl ; intros.
+ destruct (nth_in_or_default n l (Pc cO, Equal)).
+ (* index is in bounds *)
+ apply H ; congruence.
+ (* index is out-of-bounds *)
+ inversion H0.
+ rewrite e. simpl.
+ now apply addon.(SORrm).(morph0).
+ (* PsatzSquare *)
+ simpl. intros. inversion H0.
+ 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.
+ intro.
+ case_eq (eval_Psatz l e) ; simpl ; intros.
+ apply IHe in H0.
+ apply pexpr_times_nformula_correct with (1:=H0) (2:= H1).
+ discriminate.
+ (* PsatzMulC *)
+ simpl ; intro.
+ case_eq (eval_Psatz l e1) ; simpl ; try discriminate.
+ case_eq (eval_Psatz l e2) ; simpl ; try discriminate.
+ intros.
+ apply IHe1 in H1. apply IHe2 in H0.
+ apply (nformula_times_nformula_correct env n0 n) ; assumption.
+ (* PsatzAdd *)
+ simpl ; intro.
+ case_eq (eval_Psatz l e1) ; simpl ; try discriminate.
+ case_eq (eval_Psatz l e2) ; simpl ; try discriminate.
+ intros.
+ apply IHe1 in H1. apply IHe2 in H0.
+ apply (nformula_plus_nformula_correct env n0 n) ; assumption.
+ (* PsatzC *)
+ simpl.
+ intro. case_eq (cO [<] c).
+ intros. inversion H1. simpl.
+ rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
+ discriminate.
+ (* PsatzZ *)
+ simpl. intros. inversion H0.
+ simpl. apply addon.(SORrm).(morph0).
+Qed.
+
+Fixpoint ge_bool (n m : nat) : bool :=
+ match n with
+ | O => match m with
+ | O => true
+ | S _ => false
+ end
+ | S n => match m with
+ | O => true
+ | S m => ge_bool n m
+ end
+ end.
+
+Lemma ge_bool_cases : forall n m, (if ge_bool n m then n >= m else n < m)%nat.
+Proof.
+ induction n ; simpl.
+ destruct m ; simpl.
+ constructor.
+ omega.
+ destruct m.
+ constructor.
+ omega.
+ generalize (IHn m).
+ destruct (ge_bool n m) ; omega.
+Qed.
+
+
+Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat :=
+ match prf with
+ | PsatzC _ | PsatzZ | PsatzSquare _ => acc
+ | PsatzMulC _ prf => xhyps_of_psatz base acc prf
+ | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1
+ | PsatzIn n => if ge_bool n base then (n::acc) else acc
+ end.
+
+
+(* roughly speaking, normalise_pexpr_correct is a proof of
+ forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
+
+(*****)
+Definition paddC := PaddC cplus.
+Definition psubC := PsubC cminus.
+
+Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] :=
+ let Rops_wd := mk_reqe rplus rtimes ropp req
+ sor.(SORplus_wd)
+ sor.(SORtimes_wd)
+ sor.(SORopp_wd) in
+ PsubC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
+ addon.(SORrm).
+
+Definition PaddC_ok : forall c P env, eval_pol env (paddC P c) == eval_pol env P + [c] :=
+ let Rops_wd := mk_reqe rplus rtimes ropp req
+ sor.(SORplus_wd)
+ sor.(SORtimes_wd)
+ sor.(SORopp_wd) in
+ PaddC_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
+ addon.(SORrm).
+
+
+(* Check that a formula f is inconsistent by normalizing and comparing the
+resulting constant with 0 *)
+
+Definition check_inconsistent (f : NFormula) : bool :=
+let (e, op) := f in
+ match e with
+ | Pc c =>
+ match op with
+ | Equal => cneqb c cO
+ | NonStrict => c [<] cO
+ | Strict => c [<=] cO
+ | NonEqual => c [=] cO
+ end
+ | _ => false (* not a constant *)
+ end.
+
+Lemma check_inconsistent_sound :
+ forall (p : PolC) (op : Op1),
+ check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p).
+Proof.
+intros p op H1 env. unfold check_inconsistent in H1.
+destruct op; simpl ;
+(*****)
+destruct p ; simpl; try discriminate H1;
+try rewrite <- addon.(SORrm).(morph0); trivial.
+now apply cneqb_sound.
+apply addon.(SORrm).(morph_eq) in H1. congruence.
+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
+ | None => false
+ | Some f => check_inconsistent f
+ end.
+
+Lemma checker_nf_sound :
+ forall (l : list NFormula) (cm : Psatz),
+ check_normalised_formulas l cm = true ->
+ forall env : PolEnv, make_impl (eval_nformula env) l False.
+Proof.
+intros l cm H env.
+unfold check_normalised_formulas in H.
+revert H.
+case_eq (eval_Psatz l cm) ; [|discriminate].
+intros nf. intros.
+rewrite <- make_conj_impl. intro.
+assert (H1' := make_conj_in _ _ H1).
+assert (Hnf := @eval_Psatz_Sound _ _ H1' _ _ H).
+destruct nf.
+apply (@check_inconsistent_sound _ _ H0 env Hnf).
+Qed.
+
+(** Normalisation of formulae **)
+
+Inductive Op2 : Set := (* binary relations *)
+| OpEq
+| OpNEq
+| OpLe
+| OpGe
+| OpLt
+| OpGt.
+
+Definition eval_op2 (o : Op2) : R -> R -> Prop :=
+match o with
+| OpEq => req
+| OpNEq => fun x y : R => x ~= y
+| OpLe => rle
+| OpGe => fun x y : R => y <= x
+| OpLt => fun x y : R => x < y
+| OpGt => fun x y : R => y < x
+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;
+ Fop : Op2;
+ Frhs : PExpr C
+}.
+
+Definition eval_formula (env : PolEnv) (f : Formula) : 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.
+
+Definition psub := Psub cO cplus cminus copp ceqb.
+
+Definition padd := Padd cO cplus ceqb.
+
+Definition normalise (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+ let lhs := norm lhs in
+ let rhs := norm rhs in
+ match op with
+ | OpEq => (psub lhs rhs, Equal)
+ | OpNEq => (psub lhs rhs, NonEqual)
+ | OpLe => (psub rhs lhs, NonStrict)
+ | OpGe => (psub lhs rhs, NonStrict)
+ | OpGt => (psub lhs rhs, Strict)
+ | OpLt => (psub rhs lhs, Strict)
+ end.
+
+Definition negate (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+ let lhs := norm lhs in
+ let rhs := norm rhs in
+ match op with
+ | OpEq => (psub rhs lhs, NonEqual)
+ | OpNEq => (psub rhs lhs, Equal)
+ | OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
+ | OpGe => (psub rhs lhs, Strict)
+ | OpGt => (psub rhs lhs, NonStrict)
+ | OpLt => (psub lhs rhs, NonStrict)
+ end.
+
+
+Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs.
+Proof.
+ intros.
+ apply (Psub_ok sor.(SORsetoid) Rops_wd
+ (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
+Qed.
+
+Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs.
+Proof.
+ intros.
+ apply (Padd_ok sor.(SORsetoid) Rops_wd
+ (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)).
+Qed.
+
+Lemma eval_pol_norm : forall env lhs, eval_pexpr env lhs == eval_pol env (norm lhs).
+Proof.
+ intros.
+ apply (norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ).
+Qed.
+
+
+Theorem normalise_sound :
+ forall (env : PolEnv) (f : Formula),
+ eval_formula env f -> eval_nformula env (normalise f).
+Proof.
+intros env f H; destruct f as [lhs op rhs]; simpl in *.
+destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm.
+now apply <- (Rminus_eq_0 sor).
+intros H1. apply -> (Rminus_eq_0 sor) in H1. now apply H.
+now apply -> (Rle_le_minus sor).
+now apply -> (Rle_le_minus sor).
+now apply -> (Rlt_lt_minus sor).
+now apply -> (Rlt_lt_minus sor).
+Qed.
+
+Theorem negate_correct :
+ forall (env : PolEnv) (f : Formula),
+ eval_formula env f <-> ~ (eval_nformula env (negate f)).
+Proof.
+intros env f; destruct f as [lhs op rhs]; simpl.
+destruct op; simpl in *; rewrite eval_pol_sub ; rewrite <- eval_pol_norm ; rewrite <- eval_pol_norm.
+symmetry. rewrite (Rminus_eq_0 sor).
+split; intro H; [symmetry; now apply -> (Req_dne sor) | symmetry in H; now apply <- (Req_dne sor)].
+rewrite (Rminus_eq_0 sor). split; intro; now apply (Rneq_symm sor).
+rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
+rewrite <- (Rlt_lt_minus sor). now rewrite <- (Rle_ngt sor).
+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 **)
+
+Definition xnormalise (t:Formula) : list (NFormula) :=
+ let (lhs,o,rhs) := t in
+ let lhs := norm lhs in
+ let rhs := norm rhs in
+ match o with
+ | OpEq =>
+ (psub lhs rhs, Strict)::(psub rhs lhs , Strict)::nil
+ | OpNEq => (psub lhs rhs,Equal) :: nil
+ | OpGt => (psub rhs lhs,NonStrict) :: nil
+ | OpLt => (psub lhs rhs,NonStrict) :: nil
+ | OpGe => (psub rhs lhs , Strict) :: nil
+ | OpLe => (psub lhs rhs ,Strict) :: nil
+ end.
+
+Require Import Tauto.
+
+Definition cnf_normalise (t:Formula) : 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.
+Proof.
+ unfold cnf_normalise, xnormalise ; simpl ; intros env t.
+ unfold eval_cnf.
+ 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);
+ generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros.
+ (**)
+ apply sor.(SORle_antisymm).
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+ now rewrite <- (Rminus_eq_0 sor).
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto.
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). auto.
+ rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto.
+ rewrite (Rlt_nge sor). rewrite (Rle_le_minus sor). auto.
+Qed.
+
+Definition xnegate (t:Formula) : list (NFormula) :=
+ let (lhs,o,rhs) := t in
+ let lhs := norm lhs in
+ let rhs := norm rhs in
+ match o with
+ | OpEq => (psub lhs rhs,Equal) :: nil
+ | OpNEq => (psub lhs rhs ,Strict)::(psub rhs lhs,Strict)::nil
+ | OpGt => (psub lhs rhs,Strict) :: nil
+ | OpLt => (psub rhs lhs,Strict) :: nil
+ | OpGe => (psub lhs rhs,NonStrict) :: nil
+ | OpLe => (psub rhs lhs,NonStrict) :: nil
+ end.
+
+Definition cnf_negate (t:Formula) : 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.
+Proof.
+ unfold cnf_negate, xnegate ; simpl ; intros env t.
+ unfold eval_cnf.
+ 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);
+ generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition.
+ (**)
+ apply H0.
+ rewrite H1 ; ring.
+ (**)
+ apply H1.
+ apply sor.(SORle_antisymm).
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+ rewrite (Rle_ngt sor). rewrite (Rlt_lt_minus sor). tauto.
+ (**)
+ apply H0. now rewrite (Rle_le_minus sor) in H1.
+ apply H0. now rewrite (Rle_le_minus sor) in H1.
+ apply H0. now rewrite (Rlt_lt_minus sor) in H1.
+ apply H0. now rewrite (Rlt_lt_minus sor) in H1.
+Qed.
+
+Lemma eval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
+Proof.
+ intros.
+ destruct d ; simpl.
+ generalize (eval_pol env p); intros.
+ destruct o ; simpl.
+ apply (Req_em sor r 0).
+ destruct (Req_em sor r 0) ; tauto.
+ rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto.
+ rewrite <- (Rlt_nge sor r 0). generalize (Rle_gt_cases sor 0 r). tauto.
+Qed.
+
+(** Reverse transformation *)
+
+Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C :=
+ match p with
+ | Pc c => PEc c
+ | Pinj j p => xdenorm (Pplus j jmp ) p
+ | PX p j q => PEadd
+ (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j)))
+ (xdenorm (Psucc jmp) q)
+ end.
+
+Lemma xdenorm_correct : forall p i env, eval_pol (jump i env) p == eval_pexpr env (xdenorm (Psucc i) p).
+Proof.
+ unfold eval_pol.
+ induction p.
+ simpl. reflexivity.
+ (* Pinj *)
+ simpl.
+ intros.
+ rewrite Pplus_succ_permute_r.
+ rewrite <- IHp.
+ symmetry.
+ rewrite Pplus_comm.
+ rewrite Pjump_Pplus. reflexivity.
+ (* PX *)
+ simpl.
+ intros.
+ rewrite <- IHp1.
+ rewrite <- IHp2.
+ unfold Env.tail , Env.hd.
+ rewrite <- Pjump_Pplus.
+ rewrite <- Pplus_one_succ_r.
+ unfold Env.nth.
+ unfold jump at 2.
+ rewrite Pplus_one_succ_l.
+ rewrite addon.(SORpower).(rpow_pow_N).
+ unfold pow_N. ring.
+Qed.
+
+Definition denorm (p : Pol C) := xdenorm xH p.
+
+Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p).
+Proof.
+ unfold denorm.
+ induction p.
+ reflexivity.
+ simpl.
+ rewrite <- Pplus_one_succ_r.
+ apply xdenorm_correct.
+ simpl.
+ intros.
+ rewrite IHp1.
+ unfold Env.tail.
+ rewrite xdenorm_correct.
+ change (Psucc xH) with 2%positive.
+ rewrite addon.(SORpower).(rpow_pow_N).
+ simpl. reflexivity.
+Qed.
+
+
+(** Some syntactic simplifications of expressions *)
+
+
+Definition simpl_cone (e:Psatz) : Psatz :=
+ match e with
+ | PsatzSquare t =>
+ match t with
+ | Pc c => if ceqb cO c then PsatzZ else PsatzC (ctimes c c)
+ | _ => PsatzSquare t
+ end
+ | PsatzMulE t1 t2 =>
+ match t1 , t2 with
+ | PsatzZ , x => PsatzZ
+ | x , PsatzZ => PsatzZ
+ | PsatzC c , PsatzC c' => PsatzC (ctimes c c')
+ | PsatzC p1 , PsatzMulE (PsatzC p2) x => PsatzMulE (PsatzC (ctimes p1 p2)) x
+ | PsatzC p1 , PsatzMulE x (PsatzC p2) => PsatzMulE (PsatzC (ctimes p1 p2)) x
+ | PsatzMulE (PsatzC p2) x , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x
+ | PsatzMulE x (PsatzC p2) , PsatzC p1 => PsatzMulE (PsatzC (ctimes p1 p2)) x
+ | PsatzC x , PsatzAdd y z => PsatzAdd (PsatzMulE (PsatzC x) y) (PsatzMulE (PsatzC x) z)
+ | PsatzC c , _ => if ceqb cI c then t2 else PsatzMulE t1 t2
+ | _ , PsatzC c => if ceqb cI c then t1 else PsatzMulE t1 t2
+ | _ , _ => e
+ end
+ | PsatzAdd t1 t2 =>
+ match t1 , t2 with
+ | PsatzZ , x => x
+ | x , PsatzZ => x
+ | x , y => PsatzAdd x y
+ end
+ | _ => e
+ end.
+
+
+
+
+End Micromega.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *) \ No newline at end of file
diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v
new file mode 100644
index 00000000..b1d02176
--- /dev/null
+++ b/plugins/micromega/Tauto.v
@@ -0,0 +1,327 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import List.
+Require Import Refl.
+Require Import Bool.
+
+Set Implicit Arguments.
+
+
+ Inductive BFormula (A:Type) : Type :=
+ | TT : BFormula A
+ | FF : BFormula A
+ | X : Prop -> BFormula A
+ | A : A -> BFormula A
+ | Cj : BFormula A -> BFormula A -> BFormula A
+ | D : BFormula A-> BFormula A -> BFormula A
+ | N : BFormula A -> BFormula A
+ | I : BFormula A-> BFormula A-> BFormula A.
+
+ Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop :=
+ match f with
+ | TT => True
+ | FF => False
+ | A a => ev a
+ | X p => p
+ | Cj e1 e2 => (eval_f ev e1) /\ (eval_f ev e2)
+ | D e1 e2 => (eval_f ev e1) \/ (eval_f ev e2)
+ | N e => ~ (eval_f ev e)
+ | I f1 f2 => (eval_f ev f1) -> (eval_f ev f2)
+ end.
+
+
+ Lemma map_simpl : forall A B f l, @map A B f l = match l with
+ | nil => nil
+ | a :: l=> (f a) :: (@map A B f l)
+ end.
+ Proof.
+ destruct l ; reflexivity.
+ Qed.
+
+
+
+ Section S.
+
+ Variable Env : Type.
+ Variable Term : Type.
+ Variable eval : Env -> Term -> Prop.
+ Variable Term' : Type.
+ Variable eval' : Env -> Term' -> Prop.
+
+
+
+ Variable no_middle_eval' : forall env d, (eval' env d) \/ ~ (eval' env d).
+
+
+ Definition clause := list Term'.
+ Definition cnf := list clause.
+
+ Variable normalise : Term -> cnf.
+ Variable negate : Term -> cnf.
+
+
+ Definition tt : cnf := @nil clause.
+ Definition ff : cnf := cons (@nil Term') nil.
+
+
+ Definition or_clause_cnf (t:clause) (f:cnf) : cnf :=
+ List.map (fun x => (t++x)) f.
+
+ Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf :=
+ match f with
+ | nil => tt
+ | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f')
+ end.
+
+
+ Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf :=
+ f1 ++ f2.
+
+ Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf :=
+ match f with
+ | TT => if pol then tt else ff
+ | FF => if pol then ff else tt
+ | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *)
+ | A x => if pol then normalise x else negate x
+ | N e => xcnf (negb pol) e
+ | Cj e1 e2 =>
+ (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
+ | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
+ | 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.
+
+
+ Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y.
+ Proof.
+ unfold eval_cnf.
+ intros.
+ rewrite make_conj_app in H ; auto.
+ 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).
+ Proof.
+ unfold eval_cnf.
+ unfold or_clause_cnf.
+ induction f.
+ simpl.
+ intros ; right;auto.
+ (**)
+ rewrite map_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.
+ 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).
+ 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').
+ Proof.
+ induction f.
+ unfold eval_cnf.
+ simpl.
+ tauto.
+ (**)
+ intros.
+ simpl in H.
+ destruct (eval_cnf_app _ _ _ H).
+ clear H.
+ destruct (IHf _ H0).
+ destruct (or_clause_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 negate_correct : forall env t, eval_cnf (eval' 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).
+ Proof.
+ induction f.
+ (* TT *)
+ unfold eval_cnf.
+ simpl.
+ destruct pol ; simpl ; auto.
+ (* FF *)
+ unfold eval_cnf.
+ destruct pol; simpl ; auto.
+ (* P *)
+ simpl.
+ destruct pol ; intros ;simpl.
+ unfold eval_cnf in H.
+ (* Here I have to drop the proposition *)
+ simpl in H.
+ tauto.
+ (* Here, I could store P in the clause *)
+ unfold eval_cnf in H;simpl in H.
+ tauto.
+ (* A *)
+ simpl.
+ destruct pol ; simpl.
+ intros.
+ apply normalise_correct ; auto.
+ (* A 2 *)
+ intros.
+ apply negate_correct ; auto.
+ auto.
+ (* Cj *)
+ destruct pol ; simpl.
+ (* pol = true *)
+ intros.
+ unfold and_cnf in H.
+ destruct (eval_cnf_app _ _ _ H).
+ clear H.
+ split.
+ apply (IHf1 _ _ H0).
+ apply (IHf2 _ _ H1).
+ (* pol = false *)
+ intros.
+ destruct (or_cnf_correct _ _ _ H).
+ generalize (IHf1 false env H0).
+ simpl.
+ tauto.
+ generalize (IHf2 false env H0).
+ simpl.
+ tauto.
+ (* D *)
+ simpl.
+ destruct pol.
+ (* pol = true *)
+ intros.
+ destruct (or_cnf_correct _ _ _ H).
+ generalize (IHf1 _ env H0).
+ simpl.
+ tauto.
+ generalize (IHf2 _ env H0).
+ simpl.
+ tauto.
+ (* pol = true *)
+ unfold and_cnf.
+ intros.
+ destruct (eval_cnf_app _ _ _ H).
+ clear H.
+ simpl.
+ generalize (IHf1 _ _ H0).
+ generalize (IHf2 _ _ H1).
+ simpl.
+ tauto.
+ (**)
+ simpl.
+ destruct pol ; simpl.
+ intros.
+ apply (IHf false) ; auto.
+ intros.
+ generalize (IHf _ _ H).
+ tauto.
+ (* I *)
+ simpl; intros.
+ destruct pol.
+ simpl.
+ intro.
+ destruct (or_cnf_correct _ _ _ H).
+ generalize (IHf1 _ _ H1).
+ simpl in *.
+ tauto.
+ generalize (IHf2 _ _ H1).
+ auto.
+ (* pol = false *)
+ unfold and_cnf in H.
+ simpl in H.
+ destruct (eval_cnf_app _ _ _ H).
+ generalize (IHf1 _ _ H0).
+ generalize (IHf2 _ _ H1).
+ simpl.
+ tauto.
+ Qed.
+
+
+ Variable Witness : Type.
+ Variable checker : list Term' -> Witness -> bool.
+
+ Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False.
+
+ Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool :=
+ match f with
+ | nil => true
+ | e::f => match l with
+ | nil => false
+ | c::l => match checker e c with
+ | true => cnf_checker f l
+ | _ => false
+ end
+ end
+ end.
+
+ Lemma cnf_checker_sound : forall t w, cnf_checker t w = true -> forall env, eval_cnf (eval' env) t.
+ Proof.
+ unfold eval_cnf.
+ induction t.
+ (* bc *)
+ simpl.
+ auto.
+ (* ic *)
+ simpl.
+ destruct w.
+ intros ; discriminate.
+ case_eq (checker a w) ; intros ; try discriminate.
+ generalize (@checker_sound _ _ H env).
+ generalize (IHt _ H0 env) ; intros.
+ destruct t.
+ red ; intro.
+ rewrite <- make_conj_impl in H2.
+ tauto.
+ rewrite <- make_conj_impl in H2.
+ tauto.
+ Qed.
+
+
+ Definition tauto_checker (f:BFormula Term) (w:list Witness) : bool :=
+ cnf_checker (xcnf true f) w.
+
+ Lemma tauto_checker_sound : forall t w, tauto_checker t w = true -> forall env, eval_f (eval env) t.
+ Proof.
+ unfold tauto_checker.
+ intros.
+ change (eval_f (eval env) t) with (eval_f (eval env) (if true then t else TT Term)).
+ apply (xcnf_correct t true).
+ eapply cnf_checker_sound ; eauto.
+ Qed.
+
+
+
+
+End S.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v
new file mode 100644
index 00000000..0a66fce3
--- /dev/null
+++ b/plugins/micromega/VarMap.v
@@ -0,0 +1,259 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import ZArith.
+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 MakeVarMap.
+ Variable A : Type.
+ Variable default : A.
+
+ Inductive t : Type :=
+ | Empty : t
+ | Leaf : A -> t
+ | Node : t -> A -> t -> t .
+
+ Fixpoint find (vm : t ) (p:positive) {struct vm} : A :=
+ match vm with
+ | Empty => default
+ | Leaf i => i
+ | Node l e r => match p with
+ | xH => e
+ | xO p => find l p
+ | xI p => find r p
+ 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
new file mode 100644
index 00000000..f27cd15e
--- /dev/null
+++ b/plugins/micromega/ZCoeff.v
@@ -0,0 +1,173 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* Evgeny Makarov, INRIA, 2007 *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZArith.
+Require Import InitialRing.
+Require Import Setoid.
+
+Import OrderedRingSyntax.
+
+Set Implicit Arguments.
+
+Section InitialMorphism.
+
+Variable R : Type.
+Variables rO rI : R.
+Variables rplus rtimes rminus: R -> R -> R.
+Variable ropp : R -> R.
+Variables req rle rlt : R -> R -> Prop.
+
+Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
+
+Notation "0" := rO.
+Notation "1" := rI.
+Notation "x + y" := (rplus x y).
+Notation "x * y " := (rtimes x y).
+Notation "x - y " := (rminus x y).
+Notation "- x" := (ropp x).
+Notation "x == y" := (req x y).
+Notation "x ~= y" := (~ req x y).
+Notation "x <= y" := (rle x y).
+Notation "x < y" := (rlt x y).
+
+Lemma req_refl : forall x, req x x.
+Proof.
+ destruct sor.(SORsetoid).
+ apply Equivalence_Reflexive.
+Qed.
+
+Lemma req_sym : forall x y, req x y -> req y x.
+Proof.
+ destruct sor.(SORsetoid).
+ apply Equivalence_Symmetric.
+Qed.
+
+Lemma req_trans : forall x y z, req x y -> req y z -> req x z.
+Proof.
+ destruct sor.(SORsetoid).
+ apply Equivalence_Transitive.
+Qed.
+
+
+Add Relation R req
+ reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _)
+ symmetry proved by sor.(SORsetoid).(@Equivalence_Symmetric _ _)
+ transitivity proved by sor.(SORsetoid).(@Equivalence_Transitive _ _)
+as sor_setoid.
+
+Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
+Proof.
+exact sor.(SORplus_wd).
+Qed.
+Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
+Proof.
+exact sor.(SORtimes_wd).
+Qed.
+Add Morphism ropp with signature req ==> req as ropp_morph.
+Proof.
+exact sor.(SORopp_wd).
+Qed.
+Add Morphism rle with signature req ==> req ==> iff as rle_morph.
+Proof.
+exact sor.(SORle_wd).
+Qed.
+Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
+Proof.
+exact sor.(SORlt_wd).
+Qed.
+Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
+Proof.
+ exact (rminus_morph sor).
+Qed.
+
+Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
+Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
+
+Definition gen_order_phi_Z : Z -> R := gen_phiZ 0 1 rplus rtimes ropp.
+
+Notation phi_pos := (gen_phiPOS 1 rplus rtimes).
+Notation phi_pos1 := (gen_phiPOS1 1 rplus rtimes).
+
+Notation "[ x ]" := (gen_order_phi_Z x).
+
+Lemma ring_ops_wd : ring_eq_ext rplus rtimes ropp req.
+Proof.
+constructor.
+exact rplus_morph.
+exact rtimes_morph.
+exact ropp_morph.
+Qed.
+
+Lemma Zring_morph :
+ ring_morph 0 1 rplus rtimes rminus ropp req
+ 0%Z 1%Z Zplus Zmult Zminus Zopp
+ Zeq_bool gen_order_phi_Z.
+Proof.
+exact (gen_phiZ_morph sor.(SORsetoid) ring_ops_wd sor.(SORrt)).
+Qed.
+
+Lemma phi_pos1_pos : forall x : positive, 0 < phi_pos1 x.
+Proof.
+induction x as [x IH | x IH |]; simpl;
+try apply (Rplus_pos_pos sor); try apply (Rtimes_pos_pos sor); try apply (Rplus_pos_pos sor);
+try apply (Rlt_0_1 sor); assumption.
+Qed.
+
+Lemma phi_pos1_succ : forall x : positive, phi_pos1 (Psucc x) == 1 + phi_pos1 x.
+Proof.
+exact (ARgen_phiPOS_Psucc sor.(SORsetoid) ring_ops_wd
+ (Rth_ARth sor.(SORsetoid) ring_ops_wd sor.(SORrt))).
+Qed.
+
+Lemma clt_pos_morph : forall x y : positive, (x < y)%positive -> phi_pos1 x < phi_pos1 y.
+Proof.
+intros x y H. pattern y; apply Plt_ind with x.
+rewrite phi_pos1_succ; apply (Rlt_succ_r sor).
+clear y H; intros y _ H. rewrite phi_pos1_succ. now apply (Rlt_lt_succ sor).
+assumption.
+Qed.
+
+Lemma clt_morph : forall x y : Z, (x < y)%Z -> [x] < [y].
+Proof.
+unfold Zlt; 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.
+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.
+Qed.
+
+Lemma Zcleb_morph : forall x y : Z, Zle_bool x y = true -> [x] <= [y].
+Proof.
+unfold Zle_bool; intros x y H.
+case_eq (x ?= y)%Z; intro H1; rewrite H1 in H.
+le_equal. apply Zring_morph.(morph_eq). unfold Zeq_bool; now rewrite H1.
+le_less. now apply clt_morph.
+discriminate.
+Qed.
+
+Lemma Zcneqb_morph : forall x y : Z, Zeq_bool x y = false -> [x] ~= [y].
+Proof.
+intros x y H. unfold Zeq_bool in H.
+case_eq (Zcompare x y); intro H1; rewrite H1 in *; (discriminate || clear H).
+apply (Rlt_neq sor). now apply clt_morph.
+fold (x > y)%Z in H1. rewrite Zgt_iff_lt in H1.
+apply (Rneq_symm sor). apply (Rlt_neq sor). now apply clt_morph.
+Qed.
+
+End InitialMorphism.
+
+
diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v
new file mode 100644
index 00000000..b02a9850
--- /dev/null
+++ b/plugins/micromega/ZMicromega.v
@@ -0,0 +1,1023 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+Require Import OrderedRing.
+Require Import RingMicromega.
+Require Import ZCoeff.
+Require Import Refl.
+Require Import ZArith.
+Require Import List.
+Require Import Bool.
+(*Declare ML Module "micromega_plugin".*)
+
+Ltac flatten_bool :=
+ repeat match goal with
+ [ id : (_ && _)%bool = true |- _ ] => destruct (andb_prop _ _ id); clear id
+ | [ id : (_ || _)%bool = true |- _ ] => destruct (orb_prop _ _ id); clear id
+ end.
+
+Ltac inv H := inversion H ; try subst ; clear H.
+
+
+Require Import EnvRing.
+
+Open Scope Z_scope.
+
+Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt.
+Proof.
+ constructor ; intros ; subst ; try (intuition (auto with zarith)).
+ apply Zsth.
+ apply Zth.
+ destruct (Ztrichotomy n m) ; intuition (auto with zarith).
+ apply Zmult_lt_0_compat ; auto.
+Qed.
+
+Lemma ZSORaddon :
+ SORaddon 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle (* ring elements *)
+ 0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
+ Zeq_bool Zle_bool
+ (fun x => x) (fun x => x) (pow_N 1 Zmult).
+Proof.
+ constructor.
+ constructor ; intros ; try reflexivity.
+ apply Zeq_bool_eq ; auto.
+ constructor.
+ reflexivity.
+ intros x y.
+ apply Zeq_bool_neq ; auto.
+ apply Zle_bool_imp_le.
+Qed.
+
+Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z :=
+ match e with
+ | PEc c => c
+ | PEX x => env x
+ | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2
+ | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2
+ | PEpow e1 n => Zpower (Zeval_expr env e1) (Z_of_N n)
+ | PEsub e1 e2 => (Zeval_expr env e1) - (Zeval_expr env e2)
+ | PEopp e => Zopp (Zeval_expr env e)
+ end.
+
+Definition eval_expr := eval_pexpr Zplus Zmult Zminus Zopp (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Lemma ZNpower : forall r n, r ^ Z_of_N n = pow_N 1 Zmult r n.
+Proof.
+ destruct n.
+ reflexivity.
+ simpl.
+ unfold Zpower_pos.
+ replace (pow_pos Zmult r p) with (1 * (pow_pos Zmult r p)) by ring.
+ generalize 1.
+ induction p; simpl ; intros ; repeat rewrite IHp ; ring.
+Qed.
+
+Lemma Zeval_expr_compat : forall env e, Zeval_expr env e = eval_expr env e.
+Proof.
+ induction e ; simpl ; try congruence.
+ reflexivity.
+ rewrite ZNpower. congruence.
+Qed.
+
+Definition Zeval_op2 (o : Op2) : Z -> Z -> Prop :=
+match o with
+| OpEq => @eq Z
+| OpNEq => fun x y => ~ x = y
+| OpLe => Zle
+| OpGe => Zge
+| OpLt => Zlt
+| OpGt => Zgt
+end.
+
+Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):=
+ let (lhs, op, rhs) := f in
+ (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs).
+
+Definition Zeval_formula' :=
+ eval_formula Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f.
+Proof.
+ destruct f ; simpl.
+ rewrite Zeval_expr_compat. rewrite Zeval_expr_compat.
+ unfold eval_expr.
+ generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : N => x) (pow_N 1 Zmult) env Flhs).
+ generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : N => x) (pow_N 1 Zmult) env Frhs)).
+ destruct Fop ; simpl; intros ; intuition (auto with zarith).
+Qed.
+
+
+Definition eval_nformula :=
+ eval_nformula 0 Zplus Zmult (@eq Z) Zle Zlt (fun x => x) .
+
+Definition Zeval_op1 (o : Op1) : Z -> Prop :=
+match o with
+| Equal => fun x : Z => x = 0
+| NonEqual => fun x : Z => x <> 0
+| Strict => fun x : Z => 0 < x
+| NonStrict => fun x : Z => 0 <= x
+end.
+
+
+Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d).
+Proof.
+ intros.
+ apply (eval_nformula_dec Zsor).
+Qed.
+
+Definition ZWitness := Psatz Z.
+
+Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zeq_bool Zle_bool.
+
+Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness),
+ ZWeakChecker l cm = true ->
+ forall env, make_impl (eval_nformula env) l False.
+Proof.
+ intros l cm H.
+ intro.
+ unfold eval_nformula.
+ apply (checker_nf_sound Zsor ZSORaddon l cm).
+ unfold ZWeakChecker in H.
+ exact H.
+Qed.
+
+Definition psub := psub Z0 Zplus Zminus Zopp Zeq_bool.
+
+Definition padd := padd Z0 Zplus Zeq_bool.
+
+Definition norm := norm 0 1 Zplus Zmult Zminus Zopp Zeq_bool.
+
+Definition eval_pol := eval_pol 0 Zplus Zmult (fun x => x).
+
+Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) = eval_pol env lhs - eval_pol env rhs.
+Proof.
+ intros.
+ apply (eval_pol_sub Zsor ZSORaddon).
+Qed.
+
+Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) = eval_pol env lhs + eval_pol env rhs.
+Proof.
+ intros.
+ apply (eval_pol_add Zsor ZSORaddon).
+Qed.
+
+Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) .
+Proof.
+ intros.
+ apply (eval_pol_norm Zsor ZSORaddon).
+Qed.
+
+Definition xnormalise (t:Formula Z) : list (NFormula Z) :=
+ let (lhs,o,rhs) := t in
+ let lhs := norm lhs in
+ let rhs := norm rhs in
+ match o with
+ | OpEq =>
+ ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil
+ | OpNEq => (psub lhs rhs,Equal) :: nil
+ | OpGt => (psub rhs lhs,NonStrict) :: nil
+ | OpLt => (psub lhs rhs,NonStrict) :: nil
+ | OpGe => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil
+ | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
+ end.
+
+Require Import Tauto.
+
+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.
+Proof.
+ Opaque padd.
+ unfold normalise, xnormalise ; simpl; intros env t.
+ rewrite Zeval_formula_compat.
+ unfold eval_cnf.
+ destruct t as [lhs o rhs]; case_eq o; simpl;
+ repeat rewrite eval_pol_sub;
+ repeat rewrite eval_pol_add;
+ repeat rewrite <- eval_pol_norm ; simpl in *;
+ unfold eval_expr;
+ generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
+ generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
+ intuition (auto with zarith).
+ Transparent padd.
+Qed.
+
+Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) :=
+ let (lhs,o,rhs) := t in
+ let lhs := norm lhs in
+ let rhs := norm rhs in
+ match o with
+ | OpEq => (psub lhs rhs,Equal) :: nil
+ | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil
+ | OpGt => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
+ | OpLt => (psub rhs (padd lhs (Pc 1)),NonStrict) :: nil
+ | OpGe => (psub lhs rhs,NonStrict) :: nil
+ | OpLe => (psub rhs lhs,NonStrict) :: nil
+ end.
+
+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.
+Proof.
+Proof.
+ Opaque padd.
+ intros env t.
+ rewrite Zeval_formula_compat.
+ unfold negate, xnegate ; simpl.
+ unfold eval_cnf.
+ destruct t as [lhs o rhs]; case_eq o; simpl;
+ repeat rewrite eval_pol_sub;
+ repeat rewrite eval_pol_add;
+ repeat rewrite <- eval_pol_norm ; simpl in *;
+ unfold eval_expr;
+ generalize ( eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : BinNat.N => x) (pow_N 1 Zmult) env lhs);
+ generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x)
+ (fun x : BinNat.N => x) (pow_N 1 Zmult) env rhs) ; intros z1 z2 ; intros ; subst;
+ intuition (auto with zarith).
+ Transparent padd.
+Qed.
+
+
+
+Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : bool :=
+ @tauto_checker (Formula Z) (NFormula Z) normalise negate ZWitness ZWeakChecker f w.
+
+(* To get a complete checker, the proof format has to be enriched *)
+
+Require Import Zdiv.
+Open Scope Z_scope.
+
+Definition ceiling (a b:Z) : Z :=
+ let (q,r) := Zdiv_eucl a b in
+ match r with
+ | Z0 => q
+ | _ => q + 1
+ end.
+
+Lemma narrow_interval_lower_bound : forall a b x, a > 0 -> a * x >= b -> x >= ceiling b a.
+Proof.
+ unfold ceiling.
+ intros.
+ generalize (Z_div_mod b a H).
+ destruct (Zdiv_eucl b a).
+ intros.
+ destruct H1.
+ destruct H2.
+ subst.
+ destruct (Ztrichotomy z0 0) as [ HH1 | [HH2 | HH3]]; destruct z0 ; try auto with zarith ; try discriminate.
+ assert (HH :x >= z \/ x < z) by (destruct (Ztrichotomy x z) ; auto with zarith).
+ destruct HH ;auto.
+ generalize (Zmult_lt_compat_l _ _ _ H3 H1).
+ auto with zarith.
+ clear H2.
+ assert (HH :x >= z +1 \/ x <= z) by (destruct (Ztrichotomy x z) ; intuition (auto with zarith)).
+ destruct HH ;auto.
+ assert (0 < a) by auto with zarith.
+ generalize (Zmult_lt_0_le_compat_r _ _ _ H2 H1).
+ intros.
+ rewrite Zmult_comm in H4.
+ rewrite (Zmult_comm z) in H4.
+ auto with zarith.
+Qed.
+
+(** NB: narrow_interval_upper_bound is Zdiv.Zdiv_le_lower_bound *)
+
+Require Import QArith.
+
+Inductive ZArithProof : Type :=
+| DoneProof
+| RatProof : ZWitness -> ZArithProof -> ZArithProof
+| CutProof : ZWitness -> ZArithProof -> ZArithProof
+| EnumProof : ZWitness -> ZWitness -> list ZArithProof -> ZArithProof.
+
+(* n/d <= x -> d*x - n >= 0 *)
+(*
+Definition makeLb (v:PExpr Z) (q:Q) : NFormula Z :=
+ let (n,d) := q in (PEsub (PEmul (PEc (Zpos d)) v) (PEc n),NonStrict).
+
+(* x <= n/d -> d * x <= d *)
+Definition makeUb (v:PExpr Z) (q:Q) : NFormula Z :=
+ let (n,d) := q in
+ (PEsub (PEc n) (PEmul (PEc (Zpos d)) v), NonStrict).
+
+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).
+
+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
+ - a is the gcd of the other coefficient.
+*)
+Require Import Znumtheory.
+
+Definition isZ0 (x:Z) :=
+ match x with
+ | Z0 => true
+ | _ => false
+ end.
+
+Lemma isZ0_0 : forall x, isZ0 x = true <-> x = 0.
+Proof.
+ destruct x ; simpl ; intuition congruence.
+Qed.
+
+Lemma isZ0_n0 : forall x, isZ0 x = false <-> x <> 0.
+Proof.
+ destruct x ; simpl ; intuition congruence.
+Qed.
+
+Definition ZgcdM (x y : Z) := Zmax (Zgcd x y) 1.
+
+
+Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) :=
+ match p with
+ | Pc c => (0,c)
+ | Pinj _ p => Zgcd_pol p
+ | PX p _ q =>
+ let (g1,c1) := Zgcd_pol p in
+ let (g2,c2) := Zgcd_pol q in
+ (ZgcdM (ZgcdM g1 c1) g2 , c2)
+ end.
+
+(*Eval compute in (Zgcd_pol ((PX (Pc (-2)) 1 (Pc 4)))).*)
+
+
+Fixpoint Zdiv_pol (p:PolC Z) (x:Z) : PolC Z :=
+ match p with
+ | Pc c => Pc (Zdiv c x)
+ | Pinj j p => Pinj j (Zdiv_pol p x)
+ | PX p j q => PX (Zdiv_pol p x) j (Zdiv_pol q x)
+ end.
+
+Inductive Zdivide_pol (x:Z): PolC Z -> Prop :=
+| Zdiv_Pc : forall c, (x | c) -> Zdivide_pol x (Pc c)
+| Zdiv_Pinj : forall p, Zdivide_pol x p -> forall j, Zdivide_pol x (Pinj j p)
+| Zdiv_PX : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q).
+
+
+Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p ->
+ forall env, eval_pol env p = a * eval_pol env (Zdiv_pol p a).
+Proof.
+ intros until 2.
+ induction H0.
+ (* Pc *)
+ simpl.
+ intros.
+ apply Zdivide_Zdiv_eq ; auto.
+ (* Pinj *)
+ simpl.
+ intros.
+ apply IHZdivide_pol.
+ (* PX *)
+ simpl.
+ intros.
+ rewrite IHZdivide_pol1.
+ rewrite IHZdivide_pol2.
+ ring.
+Qed.
+
+Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0.
+Proof.
+ induction p.
+ simpl. auto with zarith.
+ simpl. auto.
+ simpl.
+ case_eq (Zgcd_pol p1).
+ case_eq (Zgcd_pol p3).
+ intros.
+ simpl.
+ unfold ZgcdM.
+ generalize (Zgcd_is_pos z1 z2).
+ generalize (Zmax_spec (Zgcd z1 z2) 1).
+ generalize (Zgcd_is_pos (Zmax (Zgcd z1 z2) 1) z).
+ generalize (Zmax_spec (Zgcd (Zmax (Zgcd z1 z2) 1) z) 1).
+ auto with zarith.
+Qed.
+
+Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) -> Zdivide_pol y p.
+Proof.
+ intros.
+ induction H.
+ constructor.
+ apply Zdivide_trans with (1:= H0) ; assumption.
+ constructor. auto.
+ constructor ; auto.
+Qed.
+
+Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p.
+Proof.
+ induction p ; constructor ; auto.
+ exists c. ring.
+Qed.
+
+Lemma Zgcd_minus : forall a b c, (a | c - b ) -> (Zgcd a b | c).
+Proof.
+ intros a b c (q,Hq).
+ destruct (Zgcd_is_gcd a b) as [(a',Ha) (b',Hb) _].
+ set (g:=Zgcd a b) in *; clearbody g.
+ exists (q * a' + b').
+ symmetry in Hq. rewrite <- Zeq_plus_swap in Hq.
+ rewrite <- Hq, Hb, Ha. ring.
+Qed.
+
+Lemma Zdivide_pol_sub : forall p a b,
+ 0 < Zgcd a b ->
+ Zdivide_pol a (PsubC Zminus p b) ->
+ Zdivide_pol (Zgcd a b) p.
+Proof.
+ induction p.
+ simpl.
+ intros. inversion H0.
+ constructor.
+ apply Zgcd_minus ; auto.
+ intros.
+ constructor.
+ simpl in H0. inversion H0 ; subst; clear H0.
+ apply IHp ; auto.
+ simpl. intros.
+ inv H0.
+ constructor.
+ apply Zdivide_pol_Zdivide with (1:= H3).
+ destruct (Zgcd_is_gcd a b) ; assumption.
+ apply IHp2 ; assumption.
+Qed.
+
+Lemma Zdivide_pol_sub_0 : forall p a,
+ Zdivide_pol a (PsubC Zminus p 0) ->
+ Zdivide_pol a p.
+Proof.
+ induction p.
+ simpl.
+ intros. inversion H.
+ constructor. replace (c - 0) with c in H1 ; auto with zarith.
+ intros.
+ constructor.
+ simpl in H. inversion H ; subst; clear H.
+ apply IHp ; auto.
+ simpl. intros.
+ inv H.
+ constructor. auto.
+ apply IHp2 ; assumption.
+Qed.
+
+
+Lemma Zgcd_pol_div : forall p g c,
+ Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Zminus p c).
+Proof.
+ induction p ; simpl.
+ (* Pc *)
+ intros. inv H.
+ constructor.
+ exists 0. now ring.
+ (* Pinj *)
+ intros.
+ constructor. apply IHp ; auto.
+ (* PX *)
+ intros g c.
+ case_eq (Zgcd_pol p1) ; case_eq (Zgcd_pol p3) ; intros.
+ inv H1.
+ unfold ZgcdM at 1.
+ destruct (Zmax_spec (Zgcd (ZgcdM z1 z2) z) 1) as [HH1 | HH1];
+ destruct HH1 as [HH1 HH1'] ; rewrite HH1'.
+ constructor.
+ apply Zdivide_pol_Zdivide with (x:= ZgcdM z1 z2).
+ unfold ZgcdM.
+ destruct (Zmax_spec (Zgcd z1 z2) 1) as [HH2 | HH2].
+ destruct HH2.
+ rewrite H2.
+ apply Zdivide_pol_sub ; auto.
+ auto with zarith.
+ destruct HH2. rewrite H2.
+ apply Zdivide_pol_one.
+ unfold ZgcdM in HH1. unfold ZgcdM.
+ destruct (Zmax_spec (Zgcd z1 z2) 1) as [HH2 | HH2].
+ destruct HH2. rewrite H2 in *.
+ destruct (Zgcd_is_gcd (Zgcd z1 z2) z); auto.
+ destruct HH2. rewrite H2.
+ destruct (Zgcd_is_gcd 1 z); auto.
+ apply Zdivide_pol_Zdivide with (x:= z).
+ apply (IHp2 _ _ H); auto.
+ destruct (Zgcd_is_gcd (ZgcdM z1 z2) z); auto.
+ constructor. apply Zdivide_pol_one.
+ apply Zdivide_pol_one.
+Qed.
+
+
+
+
+Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) + c.
+Proof.
+ intros.
+ rewrite <- Zdiv_pol_correct ; auto.
+ rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+ unfold eval_pol. ring.
+ (**)
+ apply Zgcd_pol_div ; auto.
+Qed.
+
+
+
+Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z :=
+ let (g,c) := Zgcd_pol p in
+ if Zgt_bool g Z0
+ then (Zdiv_pol (PsubC Zminus p c) g , Zopp (ceiling (Zopp c) g))
+ else (p,Z0).
+
+
+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)))
+ then None (* inconsistent *)
+ else Some (e, Z0,op) (* It could still be inconsistent -- but not a cut *)
+ | NonEqual => Some (e,Z0,op)
+ | Strict => let (p,c) := makeCuttingPlane (PsubC Zminus e 1) in
+ Some (p,c,NonStrict)
+ | NonStrict => let (p,c) := makeCuttingPlane e in
+ Some (p,c,NonStrict)
+ end.
+
+Definition nformula_of_cutting_plane (t : PolC Z * Z * Op1) : NFormula Z :=
+ let (e_z, o) := t in
+ let (e,z) := e_z in
+ (padd e (Pc z) , o).
+
+Definition is_pol_Z0 (p : PolC Z) : bool :=
+ match p with
+ | Pc Z0 => true
+ | _ => false
+ end.
+
+Lemma is_pol_Z0_eval_pol : forall p, is_pol_Z0 p = true -> forall env, eval_pol env p = 0.
+Proof.
+ unfold is_pol_Z0.
+ destruct p ; try discriminate.
+ destruct z ; try discriminate.
+ reflexivity.
+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.
+
+
+
+Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool :=
+ match pf with
+ | DoneProof => false
+ | RatProof w pf =>
+ match eval_Psatz l w with
+ | None => false
+ | Some f =>
+ if check_inconsistent f then true
+ else ZChecker (f::l) pf
+ end
+ | CutProof w pf =>
+ match eval_Psatz l w with
+ | None => false
+ | Some f =>
+ match genCuttingPlane f with
+ | None => true
+ | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf
+ 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.
+
+
+
+Fixpoint bdepth (pf : ZArithProof) : nat :=
+ match pf with
+ | DoneProof => O
+ | RatProof _ p => S (bdepth p)
+ | CutProof _ p => S (bdepth p)
+ | EnumProof _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l)
+ end.
+
+Require Import Wf_nat.
+
+Lemma in_bdepth : forall l a b y, In y l -> ltof ZArithProof bdepth y (EnumProof a b l).
+Proof.
+ induction l.
+ (* nil *)
+ simpl.
+ tauto.
+ (* cons *)
+ simpl.
+ intros.
+ destruct H.
+ subst.
+ unfold ltof.
+ simpl.
+ generalize ( (fold_right
+ (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)).
+ intros.
+ generalize (bdepth y) ; intros.
+ generalize (Max.max_l n0 n) (Max.max_r n0 n).
+ auto with zarith.
+ generalize (IHl a0 b y H).
+ unfold ltof.
+ simpl.
+ generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat
+ l)).
+ intros.
+ generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n).
+ auto with zarith.
+Qed.
+
+
+Lemma eval_Psatz_sound : forall env w l f',
+ make_conj (eval_nformula env) l ->
+ eval_Psatz l w = Some f' -> eval_nformula env f'.
+Proof.
+ intros.
+ apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto.
+ apply make_conj_in ; auto.
+Qed.
+
+Lemma makeCuttingPlane_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)).
+Proof.
+ unfold nformula_of_cutting_plane.
+ unfold eval_nformula. unfold RingMicromega.eval_nformula.
+ unfold eval_op1.
+ intros.
+ rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
+ simpl.
+ (**)
+ unfold makeCuttingPlane in H0.
+ revert H0.
+ case_eq (Zgcd_pol e) ; intros g c0.
+ generalize (Zgt_cases g 0) ; destruct (Zgt_bool g 0).
+ intros.
+ inv H2.
+ change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in *.
+ apply Zgcd_pol_correct_lt with (env:=env) in H1.
+ generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Zminus e c0) g)) H0).
+ auto with zarith.
+ auto with zarith.
+ (* g <= 0 *)
+ intros. inv H2. auto with zarith.
+Qed.
+
+
+Lemma cutting_plane_sound : forall env f p,
+ eval_nformula env f ->
+ genCuttingPlane f = Some p ->
+ eval_nformula env (nformula_of_cutting_plane p).
+Proof.
+ unfold genCuttingPlane.
+ destruct f as [e op].
+ destruct op.
+ (* 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.
+ (* NonEqual *)
+ intros.
+ inv H0.
+ unfold eval_nformula in *.
+ unfold RingMicromega.eval_nformula in *.
+ unfold nformula_of_cutting_plane.
+ unfold eval_op1 in *.
+ rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon).
+ simpl. auto with zarith.
+ (* Strict *)
+ destruct p as [[e' z] op].
+ case_eq (makeCuttingPlane (PsubC Zminus e 1)).
+ intros.
+ inv H1.
+ apply makeCuttingPlane_sound with (env:=env) (2:= H).
+ simpl in *.
+ rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+ auto with zarith.
+ (* NonStrict *)
+ destruct p as [[e' z] op].
+ case_eq (makeCuttingPlane e).
+ intros.
+ inv H1.
+ apply makeCuttingPlane_sound with (env:=env) (2:= H).
+ assumption.
+Qed.
+
+Lemma genCuttingPlaneNone : forall env f,
+ genCuttingPlane f = None ->
+ eval_nformula env f -> False.
+Proof.
+ unfold genCuttingPlane.
+ 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))).
+ 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.
+ 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.
+ exists (-x).
+ rewrite <- Zopp_mult_distr_l, Zmult_comm; auto with zarith.
+ (**)
+ discriminate.
+ discriminate.
+ destruct (makeCuttingPlane (PsubC Zminus p 1)) ; discriminate.
+ destruct (makeCuttingPlane p) ; discriminate.
+Qed.
+
+
+Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False.
+Proof.
+ induction w using (well_founded_ind (well_founded_ltof _ bdepth)).
+ destruct w as [ | w pf | w pf | w1 w2 pf].
+ (* DoneProof *)
+ simpl. discriminate.
+ (* RatProof *)
+ simpl.
+ intro l. case_eq (eval_Psatz l w) ; [| discriminate].
+ intros f Hf.
+ case_eq (check_inconsistent 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.
+ intros.
+ assert (make_impl (eval_nformula env) (f::l) False).
+ apply H with (2:= H1).
+ unfold ltof.
+ simpl.
+ auto with arith.
+ destruct f.
+ rewrite <- make_conj_impl in H2.
+ rewrite make_conj_cons in H2.
+ rewrite <- make_conj_impl.
+ intro.
+ apply H2.
+ split ; auto.
+ apply eval_Psatz_sound with (2:= Hf) ; assumption.
+ (* CutProof *)
+ simpl.
+ intro l.
+ case_eq (eval_Psatz l w) ; [ | discriminate].
+ intros f' Hlc.
+ case_eq (genCuttingPlane f').
+ intros.
+ assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False).
+ eapply (H pf) ; auto.
+ unfold ltof.
+ simpl.
+ auto with arith.
+ rewrite <- make_conj_impl in H2.
+ rewrite make_conj_cons in H2.
+ rewrite <- make_conj_impl.
+ intro.
+ apply H2.
+ split ; auto.
+ apply eval_Psatz_sound with (env:=env) in Hlc.
+ apply cutting_plane_sound with (1:= Hlc) (2:= H0).
+ auto.
+ (* genCuttingPlane = None *)
+ intros.
+ rewrite <- make_conj_impl.
+ intros.
+ apply eval_Psatz_sound with (2:= Hlc) in H2.
+ apply genCuttingPlaneNone with (2:= H2) ; auto.
+ (* EnumProof *)
+ intro.
+ simpl.
+ case_eq (eval_Psatz l w1) ; [ | discriminate].
+ case_eq (eval_Psatz l w2) ; [ | discriminate].
+ intros f1 Hf1 f2 Hf2.
+ case_eq (genCuttingPlane f2) ; [ | discriminate].
+ destruct p as [ [p1 z1] op1].
+ case_eq (genCuttingPlane f1) ; [ | discriminate].
+ 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.
+ (* 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 is_pol_Z0_eval_pol with (env := env) in H0.
+ rewrite eval_pol_add in H0.
+ 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)).
+ 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.
+ generalize (-z1). clear z1. intro z1.
+ revert z1 z2.
+ induction pf;simpl ;intros.
+ generalize (Zgt_cases z1 z2).
+ destruct (Zgt_bool z1 z2).
+ intros.
+ apply False_ind ; omega.
+ discriminate.
+ flatten_bool.
+ assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega.
+ destruct HH.
+ subst.
+ exists a ; auto.
+ assert (z1 + 1 <= x <= z2)%Z by omega.
+ destruct (IHpf _ _ H1 _ H3).
+ destruct H4.
+ exists x0 ; split;auto.
+ (*/asser *)
+ destruct (HH _ H7) 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_cons.
+ split ;auto.
+ unfold eval_nformula.
+ unfold RingMicromega.eval_nformula.
+ simpl.
+ rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon).
+ unfold eval_pol. ring.
+Qed.
+
+Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ZArithProof): bool :=
+ @tauto_checker (Formula Z) (NFormula Z) 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.
+ intros f w.
+ unfold ZTautoChecker.
+ apply (tauto_checker_sound Zeval_formula eval_nformula).
+ apply Zeval_nformula_dec.
+ intros env t.
+ rewrite normalise_correct ; auto.
+ intros env t.
+ rewrite negate_correct ; auto.
+ intros t w0.
+ apply ZChecker_sound.
+Qed.
+
+Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat :=
+ match pt with
+ | DoneProof => acc
+ | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt
+ | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt
+ | EnumProof c1 c2 l =>
+ let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in
+ List.fold_left (xhyps_of_pt (S base)) l acc
+ end.
+
+Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt.
+
+
+(*Lemma hyps_of_pt_correct : forall pt l, *)
+
+
+
+
+
+
+Open Scope Z_scope.
+
+
+(** To ease bindings from ml code **)
+(*Definition varmap := Quote.varmap.*)
+Definition make_impl := Refl.make_impl.
+Definition make_conj := Refl.make_conj.
+
+Require VarMap.
+
+(*Definition varmap_type := VarMap.t Z. *)
+Definition env := PolEnv Z.
+Definition node := @VarMap.Node Z.
+Definition empty := @VarMap.Empty Z.
+Definition leaf := @VarMap.Leaf Z.
+
+Definition coneMember := ZWitness.
+
+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.
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
+
+
diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml
new file mode 100644
index 00000000..c5760229
--- /dev/null
+++ b/plugins/micromega/certificate.ml
@@ -0,0 +1,813 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+(* We take as input a list of polynomials [p1...pn] and return an unfeasibility
+ certificate polynomial. *)
+
+(*open Micromega.Polynomial*)
+open Big_int
+open Num
+open Sos_lib
+
+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 = {
+ bigint_to_number : big_int -> 'a;
+ number_to_num : 'a -> num;
+ zero : 'a;
+ unit : 'a;
+ mult : 'a -> 'a -> 'a;
+ eqb : 'a -> 'a -> bool
+}
+
+let z_spec = {
+ bigint_to_number = Ml2C.bigint ;
+ number_to_num = (fun x -> Big_int (C2Ml.z_big_int x));
+ zero = Mc.Z0;
+ unit = Mc.Zpos Mc.XH;
+ mult = Mc.zmult;
+ eqb = Mc.zeq_bool
+}
+
+
+let q_spec = {
+ bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH});
+ number_to_num = C2Ml.q_to_num;
+ zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH};
+ unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH};
+ mult = Mc.qmult;
+ eqb = Mc.qeq_bool
+}
+
+let r_spec = z_spec
+
+
+
+
+let dev_form n_spec 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) ->
+ let p1 = dev_form p1 in
+ let p2 = dev_form p2 in
+ 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) ->
+ let p = dev_form p in
+ let n = C2Ml.n n in
+ 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 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
+ else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
+ 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 =
+ let y' = f x in
+ if y' = x then y'
+ else fixpoint f y'
+
+
+
+
+
+
+
+
+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) ->
+ simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone 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
+ | Other of cone
+and cone = Mc.zWitness
+
+
+
+let factorise_linear_cone c =
+
+ 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') ->
+ if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
+ | 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 ->
+ (match pending with
+ | 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) )
+ ) in
+
+ (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
+
+
+
+(* 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
+ where pi >= 0 qi > 0
+ ai >= 0
+ bi >= 0
+ Sum bi + c >= 1
+ This is a linear problem: each monomial is considered as a variable.
+ Hence, we can use fourier.
+
+ The variable c is at index 0
+*)
+
+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 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 ;
+ cst = Big_int zero_big_int }
+ else
+ { 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 =
+ match l with
+ | [] -> []
+ | (_,Mc.Equal)::l -> xpositivity (i+1) l
+ | (_,_)::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.Equal -> "= 0"
+ | Mc.NonEqual -> "<> 0"
+
+
+
+(* 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 *)
+ let l' = List.map fst l in
+ let monomials =
+ List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l'
+ in (* For each monomial, compute a constraint *)
+ let s0 =
+ Poly.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
+ | _ -> 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 ;
+ 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
+ -- at a lower layer, certificates are using nums... *)
+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
+ | 0 -> Mc.PsatzZ
+ | 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)))))
+
+
+exception Found of Monomial.t
+
+exception Strict
+
+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
+ then (map,vect)
+ 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 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) =
+(* 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
+ match Fourier.find_point sys with
+ | Inr _ -> None
+ | 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);
+ flush stdout) ;
+ None
+
+
+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 ;
+ 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 ;
+ Some (rats_to_ints (Vect.to_list cert))
+ | Inl _ -> None
+ with Strict ->
+ (* Fourier elimination should handle > *)
+ dual_raw_certificate l
+
+
+let simple_linear_prover (*to_constant*) 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)
+
+
+
+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 =
+ try linear_prover n_spec l with
+ x -> (print_string (Printexc.to_string x); None)
+
+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)
+ (Poly.constant (Int 0)) l' in
+ 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 ;
+ cst = minus_num ( (Poly.get Monomial.const c))}) l
+ ,monomials)
+
+
+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 =
+ match l with [] -> false | e::l -> if p x e then true else mem 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)
+
+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 --
+ 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 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 =
+ match t with
+ | Zero -> unit_big_int , Zero
+ | Const n -> (denominator n) , Const (Big_int (numerator n))
+ | Var n -> unit_big_int , Var n
+ | Inv _ -> failwith "scale_term : not implemented"
+ | Opp t -> let s, t = scale_term t in s, Opp t
+ | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 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
+ let e = mult_big_int g (mult_big_int s1' s2') in
+ if (compare_big_int e unit_big_int) = 0
+ then (unit_big_int, Add (y1,y2))
+ else e, Add (Mul(Const (Big_int s2'), y1),
+ Mul (Const (Big_int s1'), y2))
+ | Sub _ -> failwith "scale term: not implemented"
+ | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in
+ mult_big_int s1 s2 , Mul (y1, y2)
+ | Pow(t,n) -> let s,t = scale_term t in
+ power_big_int_positive_int s n , Pow(t,n)
+ | _ -> failwith "scale_term : not implemented"
+
+let scale_term t =
+ let (s,t') = scale_term t in
+ s,t'
+
+
+let get_index_of_ith_match f i l =
+ let rec get j res l =
+ match l with
+ | [] -> failwith "bad index"
+ | e::l -> if f e
+ then
+ (if j = i then res else get (j+1) (res+1) l )
+ else get j (res+1) l in
+ get 0 0 l
+
+
+let rec scale_certificate pos = match pos with
+ | Axiom_eq i -> unit_big_int , Axiom_eq i
+ | Axiom_le i -> unit_big_int , Axiom_le i
+ | Axiom_lt i -> unit_big_int , Axiom_lt i
+ | Monoid l -> unit_big_int , Monoid l
+ | 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
+ 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
+ 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'),
+ Sum (Product(Rational_le (Big_int s2'), y1),
+ Product (Rational_le (Big_int s1'), y2))
+ | Product (y, z) ->
+ let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
+ mult_big_int s1 s2 , Product (y1,y2)
+
+
+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
+ (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)
+ | Opp p -> PEopp (term_to_q_expr p)
+ | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n)
+ | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2)
+ | _ -> failwith "term_to_q_expr: not implemented"
+
+ 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 =
+ 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 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 ->
+ 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)
+ | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_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 q_spec (_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
+ (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)
+ | Opp p -> PEopp (term_to_z_expr p)
+ | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n)
+ | 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 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 ->
+ 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)
+ | 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)
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
new file mode 100644
index 00000000..abe4b368
--- /dev/null
+++ b/plugins/micromega/coq_micromega.ml
@@ -0,0 +1,1710 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* ** Toplevel definition of tactics ** *)
+(* *)
+(* - Modules ISet, M, Mc, Env, Cache, CacheZ *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2009 *)
+(* *)
+(************************************************************************)
+
+open Mutils
+
+(**
+ * Debug flag
+ *)
+
+let debug = false
+
+(**
+ * Time function
+ *)
+
+let time str f x =
+ let t0 = (Unix.times()).Unix.tms_utime in
+ let res = f x in
+ let t1 = (Unix.times()).Unix.tms_utime in
+ (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ;
+ flush stdout);
+ res
+
+(**
+ * Initialize a tag type to the Tag module declaration (see Mutils).
+ *)
+
+type tag = Tag.t
+
+(**
+ * An atom is of the form:
+ * pExpr1 {<,>,=,<>,<=,>=} pExpr2
+ * where pExpr1, pExpr2 are polynomial expressions (see Micromega). pExprs are
+ * parametrized by 'cst, which is used as the type of constants.
+ *)
+
+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
+ | FF
+ | X of Term.constr
+ | A of 'cst atom * tag * Term.constr
+ | C of 'cst formula * 'cst formula
+ | D of 'cst formula * 'cst formula
+ | N of 'cst formula
+ | I of 'cst formula * Names.identifier option * 'cst formula
+
+(**
+ * Formula pretty-printer.
+ *)
+
+let rec pp_formula o f =
+ match f with
+ | TT -> output_string o "tt"
+ | FF -> output_string o "ff"
+ | X c -> output_string o "X "
+ | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t
+ | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2
+ | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2
+ | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)"
+ pp_formula f1
+ (match n with
+ | Some id -> Names.string_of_id id
+ | None -> "") pp_formula f2
+ | N(f) -> Printf.fprintf o "N(%a)" pp_formula f
+
+(**
+ * Collect the identifiers of a (string of) implications. Implication labels
+ * are inherited from Coq/CoC's higher order dependent type constructor (Pi).
+ *)
+
+let rec ids_of_formula f =
+ match f with
+ | I(f1,Some id,f2) -> id::(ids_of_formula f2)
+ | _ -> []
+
+(**
+ * A clause is a list of (tagged) nFormulas.
+ * nFormulas are normalized formulas, i.e., of the form:
+ * cPol {=,<>,>,>=} 0
+ * with cPol compact polynomials (see the Pol inductive type in EnvRing.v).
+ *)
+
+type 'cst clause = ('cst Micromega.nFormula * tag) list
+
+(**
+ * A CNF is a list of clauses.
+ *)
+
+type 'cst cnf = ('cst clause) list
+
+(**
+ * True and False are empty cnfs and clauses.
+ *)
+
+let tt : 'cst cnf = []
+
+let ff : 'cst cnf = [ [] ]
+
+(**
+ * A refinement of cnf with tags left out. This is an intermediary form
+ * between the cnf tagged list representation ('cst cnf) used to solve psatz,
+ * and the freeform formulas ('cst formula) that is retrieved from Coq.
+ *)
+
+type 'cst mc_cnf = ('cst Micromega.nFormula) list list
+
+(**
+ * From a freeform formula, build a cnf.
+ * The parametric functions negate and normalize are theory-dependent, and
+ * originate in micromega.ml (extracted, e.g. for rnegate, from RMicromega.v
+ * and RingMicromega.v).
+ *)
+
+let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) =
+ let negate a t =
+ List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in
+
+ let normalise a t =
+ List.map (fun cl -> List.map (fun x -> (x,t)) cl) (normalise a) in
+
+ let and_cnf x y = x @ y in
+
+ let or_clause_cnf t f = List.map (fun x -> t@x) f in
+
+ let rec or_cnf f f' =
+ match f with
+ | [] -> tt
+ | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') 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
+ | N(e) -> xcnf (not polarity) e
+ | C(e1,e2) ->
+ (if polarity then and_cnf else or_cnf) (xcnf polarity e1) (xcnf polarity e2)
+ | D(e1,e2) ->
+ (if polarity then or_cnf else and_cnf) (xcnf polarity e1) (xcnf polarity e2)
+ | I(e1,_,e2) ->
+ (if polarity then or_cnf else and_cnf) (xcnf (not polarity) e1) (xcnf polarity e2) in
+
+ xcnf true f
+
+(**
+ * MODULE: Ordered set of integers.
+ *)
+
+module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+
+(**
+ * Given a set of integers s={i0,...,iN} and a list m, return the list of
+ * elements of m that are at position i0,...,iN.
+ *)
+
+let selecti s m =
+ let rec xselecti i m =
+ match m with
+ | [] -> []
+ | e::m -> if ISet.mem i s then e::(xselecti (i+1) m) else xselecti (i+1) m in
+ xselecti 0 m
+
+(**
+ * MODULE: Mapping of the Coq data-strustures into Caml and Caml extracted
+ * code. This includes initializing Caml variables based on Coq terms, parsing
+ * various Coq expressions into Caml, and dumping Caml expressions into Coq.
+ *
+ * Opened here and in csdpcert.ml.
+ *)
+
+module M =
+struct
+
+ open Coqlib
+ open Term
+
+ (**
+ * Location of the Coq libraries.
+ *)
+
+ let logic_dir = ["Coq";"Logic";"Decidable"]
+ let coq_modules =
+ init_modules @
+ [logic_dir] @ arith_modules @ zarith_base_modules @
+ [ ["Coq";"Lists";"List"];
+ ["ZMicromega"];
+ ["Tauto"];
+ ["RingMicromega"];
+ ["EnvRing"];
+ ["Coq"; "micromega"; "ZMicromega"];
+ ["Coq" ; "micromega" ; "Tauto"];
+ ["Coq" ; "micromega" ; "RingMicromega"];
+ ["Coq" ; "micromega" ; "EnvRing"];
+ ["Coq";"QArith"; "QArith_base"];
+ ["Coq";"Reals" ; "Rdefinitions"];
+ ["Coq";"Reals" ; "Rpow_def"];
+ ["LRing_normalise"]]
+
+ (**
+ * Initialization : a large amount of Caml symbols are derived from
+ * ZMicromega.v
+ *)
+
+ let init_constant = gen_constant_in_modules "ZMicromega" init_modules
+ let constant = gen_constant_in_modules "ZMicromega" coq_modules
+ (* let constant = gen_constant_in_modules "Omicron" coq_modules *)
+
+ let coq_and = lazy (init_constant "and")
+ let coq_or = lazy (init_constant "or")
+ let coq_not = lazy (init_constant "not")
+ let coq_iff = lazy (init_constant "iff")
+ let coq_True = lazy (init_constant "True")
+ let coq_False = lazy (init_constant "False")
+
+ let coq_cons = lazy (constant "cons")
+ let coq_nil = lazy (constant "nil")
+ let coq_list = lazy (constant "list")
+
+ let coq_O = lazy (init_constant "O")
+ 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_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_N0 = lazy (constant "N0")
+ let coq_N0 = lazy (constant "Npos")
+
+ 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_R0 = lazy (constant "R0")
+ let coq_R1 = lazy (constant "R1")
+
+ let coq_proofTerm = lazy (constant "ZArithProof")
+ let coq_doneProof = lazy (constant "DoneProof")
+ let coq_ratProof = lazy (constant "RatProof")
+ let coq_cutProof = lazy (constant "CutProof")
+ let coq_enumProof = lazy (constant "EnumProof")
+
+ let coq_Zgt = lazy (constant "Zgt")
+ let coq_Zge = lazy (constant "Zge")
+ let coq_Zle = lazy (constant "Zle")
+ let coq_Zlt = lazy (constant "Zlt")
+ let coq_Eq = lazy (init_constant "eq")
+
+ let coq_Zplus = lazy (constant "Zplus")
+ let coq_Zminus = lazy (constant "Zminus")
+ let coq_Zopp = lazy (constant "Zopp")
+ let coq_Zmult = lazy (constant "Zmult")
+ let coq_Zpower = lazy (constant "Zpower")
+
+ let coq_Qgt = lazy (constant "Qgt")
+ let coq_Qge = lazy (constant "Qge")
+ let coq_Qle = lazy (constant "Qle")
+ let coq_Qlt = lazy (constant "Qlt")
+ let coq_Qeq = lazy (constant "Qeq")
+
+ let coq_Qplus = lazy (constant "Qplus")
+ let coq_Qminus = lazy (constant "Qminus")
+ let coq_Qopp = lazy (constant "Qopp")
+ 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_PEX = lazy (constant "PEX" )
+ let coq_PEc = lazy (constant"PEc")
+ let coq_PEadd = lazy (constant "PEadd")
+ let coq_PEopp = lazy (constant "PEopp")
+ let coq_PEmul = lazy (constant "PEmul")
+ let coq_PEsub = lazy (constant "PEsub")
+ let coq_PEpow = lazy (constant "PEpow")
+
+ let coq_PX = lazy (constant "PX" )
+ let coq_Pc = lazy (constant"Pc")
+ let coq_Pinj = lazy (constant "Pinj")
+
+ let coq_OpEq = lazy (constant "OpEq")
+ let coq_OpNEq = lazy (constant "OpNEq")
+ let coq_OpLe = lazy (constant "OpLe")
+ let coq_OpLt = lazy (constant "OpLt")
+ let coq_OpGe = lazy (constant "OpGe")
+ let coq_OpGt = lazy (constant "OpGt")
+
+ let coq_PsatzIn = lazy (constant "PsatzIn")
+ let coq_PsatzSquare = lazy (constant "PsatzSquare")
+ let coq_PsatzMulE = lazy (constant "PsatzMulE")
+ let coq_PsatzMultC = lazy (constant "PsatzMulC")
+ let coq_PsatzAdd = lazy (constant "PsatzAdd")
+ let coq_PsatzC = lazy (constant "PsatzC")
+ let coq_PsatzZ = lazy (constant "PsatzZ")
+ let coq_coneMember = lazy (constant "coneMember")
+
+ let coq_make_impl = lazy
+ (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl")
+ let coq_make_conj = lazy
+ (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj")
+
+ let coq_TT = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT")
+ let coq_FF = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF")
+ let coq_And = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj")
+ let coq_Or = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D")
+ let coq_Neg = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N")
+ let coq_Atom = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A")
+ let coq_X = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X")
+ let coq_Impl = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I")
+ let coq_Formula = lazy
+ (gen_constant_in_modules "ZMicromega"
+ [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula")
+
+ (**
+ * Initialization : a few Caml symbols are derived from other libraries;
+ * QMicromega, ZArithRing, RingMicromega.
+ *)
+
+ let coq_QWitness = lazy
+ (gen_constant_in_modules "QMicromega"
+ [["Coq"; "micromega"; "QMicromega"]] "QWitness")
+ let coq_ZWitness = lazy
+ (gen_constant_in_modules "QMicromega"
+ [["Coq"; "micromega"; "ZMicromega"]] "ZWitness")
+
+ let coq_N_of_Z = lazy
+ (gen_constant_in_modules "ZArithRing"
+ [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z")
+
+ let coq_Build = lazy
+ (gen_constant_in_modules "RingMicromega"
+ [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ]
+ "Build_Formula")
+ let coq_Cstr = lazy
+ (gen_constant_in_modules "RingMicromega"
+ [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula")
+
+ (**
+ * Parsing and dumping : transformation functions between Caml and Coq
+ * data-structures.
+ *
+ * dump_* functions go from Micromega to Coq terms
+ * parse_* functions go from Coq to Micromega terms
+ * pp_* functions pretty-print Coq terms.
+ *)
+
+ (* Error datastructures *)
+
+ type parse_error =
+ | Ukn
+ | BadStr of string
+ | BadNum of int
+ | BadTerm of Term.constr
+ | Msg of string
+ | Goal of (Term.constr list ) * Term.constr * parse_error
+
+ let string_of_error = function
+ | Ukn -> "ukn"
+ | BadStr s -> s
+ | BadNum i -> string_of_int i
+ | BadTerm _ -> "BadTerm"
+ | Msg s -> s
+ | Goal _ -> "Goal"
+
+ exception ParseError
+
+ (* A simple but useful getter function *)
+
+ let get_left_construct term =
+ match Term.kind_of_term term with
+ | Term.Construct(_,i) -> (i,[| |])
+ | Term.App(l,rst) ->
+ (match Term.kind_of_term l with
+ | Term.Construct(_,i) -> (i,rst)
+ | _ -> raise ParseError
+ )
+ | _ -> raise ParseError
+
+ (* Access the Micromega module *)
+
+ module Mc = Micromega
+
+ (* parse/dump/print from numbers up to expressions and formulas *)
+
+ let rec parse_nat term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.O
+ | 2 -> Mc.S (parse_nat (c.(0)))
+ | i -> raise ParseError
+
+ let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n)
+
+ let rec dump_nat x =
+ match x with
+ | Mc.O -> Lazy.force coq_O
+ | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |])
+
+ let rec parse_positive term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.XI (parse_positive c.(0))
+ | 2 -> Mc.XO (parse_positive c.(0))
+ | 3 -> Mc.XH
+ | i -> raise ParseError
+
+ let rec dump_positive x =
+ match x with
+ | Mc.XH -> Lazy.force coq_xH
+ | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |])
+ | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |])
+
+ let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x)
+
+ let rec dump_n x =
+ match x with
+ | Mc.N0 -> Lazy.force coq_N0
+ | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|])
+
+ let rec dump_index x =
+ match x with
+ | Mc.XH -> Lazy.force coq_xH
+ | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |])
+ | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |])
+
+ 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) =
+ Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|])
+
+ let rec parse_z term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.Z0
+ | 2 -> Mc.Zpos (parse_positive c.(0))
+ | 3 -> Mc.Zneg (parse_positive c.(0))
+ | i -> raise ParseError
+
+ let dump_z x =
+ match x with
+ | Mc.Z0 ->Lazy.force coq_ZERO
+ | 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 dump_num bd1 =
+ Term.mkApp(Lazy.force coq_Qmake,
+ [|dump_z (CamlToCoq.bigint (numerator bd1)) ;
+ dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |])
+
+ let dump_q q =
+ Term.mkApp(Lazy.force coq_Qmake,
+ [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|])
+
+ let parse_q term =
+ match Term.kind_of_term term with
+ | Term.App(c, args) -> if c = Lazy.force coq_Qmake then
+ {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
+ else raise ParseError
+ | _ -> raise ParseError
+
+ let rec parse_list parse_elt term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> []
+ | 2 -> parse_elt c.(1) :: parse_list parse_elt c.(2)
+ | i -> raise ParseError
+
+ let rec dump_list typ dump_elt l =
+ match l with
+ | [] -> Term.mkApp(Lazy.force coq_nil,[| typ |])
+ | e :: l -> Term.mkApp(Lazy.force coq_cons,
+ [| typ; dump_elt e;dump_list typ dump_elt l|])
+
+ let pp_list op cl elt o l =
+ let rec _pp o l =
+ match l with
+ | [] -> ()
+ | [e] -> Printf.fprintf o "%a" elt e
+ | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in
+ Printf.fprintf o "%s%a%s" op _pp l cl
+
+ let pp_var = pp_positive
+
+ let dump_var = dump_positive
+
+ let pp_expr pp_z o e =
+ let rec pp_expr o e =
+ match e with
+ | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n
+ | Mc.PEc z -> pp_z o z
+ | Mc.PEadd(e1,e2) -> Printf.fprintf o "(%a)+(%a)" pp_expr e1 pp_expr e2
+ | Mc.PEmul(e1,e2) -> Printf.fprintf o "%a*(%a)" pp_expr e1 pp_expr e2
+ | Mc.PEopp e -> Printf.fprintf o "-(%a)" pp_expr e
+ | Mc.PEsub(e1,e2) -> Printf.fprintf o "(%a)-(%a)" pp_expr e1 pp_expr e2
+ | Mc.PEpow(e,n) -> Printf.fprintf o "(%a)^(%a)" pp_expr e pp_n n in
+ pp_expr o e
+
+ let dump_expr typ dump_z e =
+ let rec dump_expr e =
+ match e with
+ | Mc.PEX n -> mkApp(Lazy.force coq_PEX,[| typ; dump_var n |])
+ | Mc.PEc z -> mkApp(Lazy.force coq_PEc,[| typ ; dump_z z |])
+ | Mc.PEadd(e1,e2) -> mkApp(Lazy.force coq_PEadd,
+ [| typ; dump_expr e1;dump_expr e2|])
+ | Mc.PEsub(e1,e2) -> mkApp(Lazy.force coq_PEsub,
+ [| typ; dump_expr e1;dump_expr e2|])
+ | Mc.PEopp e -> mkApp(Lazy.force coq_PEopp,
+ [| typ; dump_expr e|])
+ | Mc.PEmul(e1,e2) -> mkApp(Lazy.force coq_PEmul,
+ [| typ; dump_expr e1;dump_expr e2|])
+ | Mc.PEpow(e,n) -> mkApp(Lazy.force coq_PEpow,
+ [| typ; dump_expr e; dump_n n|])
+ in
+ dump_expr e
+
+ let dump_pol typ dump_c e =
+ let rec dump_pol e =
+ match e with
+ | Mc.Pc n -> mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|])
+ | Mc.Pinj(p,pol) -> mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|])
+ | Mc.PX(pol1,p,pol2) -> mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in
+ dump_pol e
+
+ let pp_pol pp_c o e =
+ let rec pp_pol o e =
+ match e with
+ | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n
+ | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol
+ | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in
+ pp_pol o e
+
+ let pp_cnf pp_c o f =
+ let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in
+ List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f
+
+ let dump_psatz typ dump_z e =
+ let z = Lazy.force typ in
+ let rec dump_cone e =
+ match e with
+ | Mc.PsatzIn n -> mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |])
+ | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC,
+ [| z; dump_pol z dump_z e ; dump_cone c |])
+ | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare,
+ [| z;dump_pol z dump_z e|])
+ | Mc.PsatzAdd(e1,e2) -> mkApp(Lazy.force coq_PsatzAdd,
+ [| z; dump_cone e1; dump_cone e2|])
+ | Mc.PsatzMulE(e1,e2) -> mkApp(Lazy.force coq_PsatzMulE,
+ [| z; dump_cone e1; dump_cone e2|])
+ | Mc.PsatzC p -> mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|])
+ | Mc.PsatzZ -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in
+ dump_cone e
+
+ let pp_psatz pp_z o e =
+ let rec pp_cone o e =
+ match e with
+ | Mc.PsatzIn n ->
+ Printf.fprintf o "(In %a)%%nat" pp_nat n
+ | Mc.PsatzMulC(e,c) ->
+ Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c
+ | Mc.PsatzSquare e ->
+ Printf.fprintf o "(%a^2)" (pp_pol pp_z) e
+ | Mc.PsatzAdd(e1,e2) ->
+ Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2
+ | Mc.PsatzMulE(e1,e2) ->
+ Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2
+ | Mc.PsatzC p ->
+ Printf.fprintf o "(%a)%%positive" pp_z p
+ | Mc.PsatzZ ->
+ Printf.fprintf o "0" in
+ pp_cone o e
+
+ let rec dump_op = function
+ | Mc.OpEq-> Lazy.force coq_OpEq
+ | Mc.OpNEq-> Lazy.force coq_OpNEq
+ | Mc.OpLe -> Lazy.force coq_OpLe
+ | Mc.OpGe -> Lazy.force coq_OpGe
+ | Mc.OpGt-> Lazy.force coq_OpGt
+ | Mc.OpLt-> Lazy.force coq_OpLt
+
+ let pp_op o e=
+ match e with
+ | Mc.OpEq-> Printf.fprintf o "="
+ | Mc.OpNEq-> Printf.fprintf o "<>"
+ | Mc.OpLe -> Printf.fprintf o "=<"
+ | Mc.OpGe -> Printf.fprintf o ">="
+ | Mc.OpGt-> Printf.fprintf o ">"
+ | Mc.OpLt-> Printf.fprintf o "<"
+
+ let pp_cstr pp_z o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } =
+ Printf.fprintf o"(%a %a %a)" (pp_expr pp_z) l pp_op op (pp_expr pp_z) r
+
+ let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} =
+ Term.mkApp(Lazy.force coq_Build,
+ [| typ; dump_expr typ dump_constant e1 ;
+ dump_op o ;
+ dump_expr typ dump_constant e2|])
+
+ let assoc_const x l =
+ try
+ snd (List.find (fun (x',y) -> x = Lazy.force x') l)
+ with
+ Not_found -> raise ParseError
+
+ let zop_table = [
+ coq_Zgt, Mc.OpGt ;
+ coq_Zge, Mc.OpGe ;
+ coq_Zlt, Mc.OpLt ;
+ coq_Zle, Mc.OpLe ]
+
+ let rop_table = [
+ coq_Rgt, Mc.OpGt ;
+ coq_Rge, Mc.OpGe ;
+ coq_Rlt, Mc.OpLt ;
+ coq_Rle, Mc.OpLe ]
+
+ let qop_table = [
+ coq_Qlt, Mc.OpLt ;
+ coq_Qle, Mc.OpLe ;
+ coq_Qeq, Mc.OpEq
+ ]
+
+ let parse_zop (op,args) =
+ match kind_of_term op with
+ | Const x -> (assoc_const op zop_table, args.(0) , args.(1))
+ | Ind(n,0) ->
+ if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_Z
+ then (Mc.OpEq, args.(1), args.(2))
+ else raise ParseError
+ | _ -> failwith "parse_zop"
+
+ let parse_rop (op,args) =
+ match kind_of_term op with
+ | Const x -> (assoc_const op rop_table, args.(0) , args.(1))
+ | Ind(n,0) ->
+ if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_R
+ then (Mc.OpEq, args.(1), args.(2))
+ else raise ParseError
+ | _ -> failwith "parse_zop"
+
+ let parse_qop (op,args) =
+ (assoc_const op qop_table, args.(0) , args.(1))
+
+ let is_constant t = (* This is an approx *)
+ match kind_of_term t with
+ | Construct(i,_) -> true
+ | _ -> false
+
+ type 'a op =
+ | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr)
+ | Opp
+ | Power
+ | Ukn of string
+
+ let assoc_ops x l =
+ try
+ snd (List.find (fun (x',y) -> x = Lazy.force x') l)
+ with
+ Not_found -> Ukn "Oups"
+
+ (**
+ * MODULE: Env is for environment.
+ *)
+
+ module Env =
+ struct
+ type t = constr list
+
+ let compute_rank_add env v =
+ let rec _add env n v =
+ match env with
+ | [] -> ([v],n)
+ | e::l ->
+ if eq_constr e v
+ then (env,n)
+ else
+ let (env,n) = _add l ( n+1) v in
+ (e::env,n) in
+ let (env, n) = _add env 1 v in
+ (env, CamlToCoq.idx n)
+
+ let empty = []
+
+ let elements env = env
+
+ end (* MODULE END: Env *)
+
+ (**
+ * This is the big generic function for expression parsers.
+ *)
+
+ let parse_expr parse_constant parse_exp ops_spec env term =
+ if debug
+ then (Pp.pp (Pp.str "parse_expr: ");
+ Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ());
+
+ 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 rec parse_expr env term =
+ let combine env op (t1,t2) =
+ let (expr1,env) = parse_expr env t1 in
+ 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)
+ )
+ | _ -> constant_or_variable env term
+ )
+ | _ -> constant_or_variable env term in
+ parse_expr env term
+
+ let zop_spec =
+ [
+ coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
+ coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
+ coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ;
+ coq_Zopp , Opp ;
+ coq_Zpower , Power]
+
+ let qop_spec =
+ [
+ coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
+ coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
+ coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ;
+ coq_Qopp , Opp ;
+ coq_Qpower , Power]
+
+ let rop_spec =
+ [
+ coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ;
+ coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ;
+ coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ;
+ coq_Ropp , Opp ;
+ coq_Rpower , Power]
+
+ 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 ());
+ match Term.kind_of_term term with
+ | Const x ->
+ if term = Lazy.force coq_R0
+ then Mc.Z0
+ else if term = Lazy.force coq_R1
+ then Mc.Zpos Mc.XH
+ else raise ParseError
+ | _ -> raise ParseError
+
+ 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))
+ zop_spec
+
+ let parse_qexpr = parse_expr
+ qconstant
+ (fun expr x ->
+ let exp = parse_z x in
+ match exp with
+ | Mc.Zneg _ ->
+ begin
+ match expr with
+ | 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
+ 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
+ Mc.PEpow(expr,exp))
+ rop_spec
+
+ let parse_arith parse_op parse_expr env cstr =
+ if debug
+ then (Pp.pp_flush ();
+ Pp.pp (Pp.str "parse_arith: ");
+ Pp.pp (Printer.prterm cstr);
+ Pp.pp_flush ());
+ match kind_of_term cstr with
+ | App(op,args) ->
+ let (op,lhs,rhs) = parse_op (op,args) in
+ let (e1,env) = parse_expr env lhs in
+ let (e2,env) = parse_expr env rhs in
+ ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env)
+ | _ -> failwith "error : parse_arith(2)"
+
+ let parse_zarith = parse_arith parse_zop parse_zexpr
+
+ let parse_qarith = parse_arith parse_qop parse_qexpr
+
+ let parse_rarith = parse_arith parse_rop parse_rexpr
+
+ (* generic parsing of arithmetic expressions *)
+
+ let rec f2f = function
+ | TT -> Mc.TT
+ | FF -> Mc.FF
+ | X _ -> Mc.X
+ | A (x,_,_) -> Mc.A x
+ | C (a,b) -> Mc.Cj(f2f a,f2f b)
+ | D (a,b) -> Mc.D(f2f a,f2f b)
+ | N (a) -> Mc.N(f2f a)
+ | I(a,_,b) -> Mc.I(f2f a,f2f b)
+
+ let is_prop t =
+ match t with
+ | Names.Anonymous -> true (* Not quite right *)
+ | Names.Name x -> false
+
+ let mkC f1 f2 = C(f1,f2)
+ let mkD f1 f2 = D(f1,f2)
+ let mkIff f1 f2 = C(I(f1,None,f2),I(f2,None,f1))
+ let mkI f1 f2 = I(f1,None,f2)
+
+ let mkformula_binary g term f1 f2 =
+ match f1 , f2 with
+ | X _ , X _ -> X(term)
+ | _ -> g f1 f2
+
+ (**
+ * This is the big generic function for formula parsers.
+ *)
+
+ let parse_formula parse_atom env term =
+
+ let parse_atom env tg t = try let (at,env) = parse_atom env t in
+ (A(at,tg,t), env,Tag.next tg) with _ -> (X(t),env,tg) in
+
+ let rec xparse_formula env tg term =
+ match kind_of_term term with
+ | App(l,rst) ->
+ (match rst with
+ | [|a;b|] when l = Lazy.force coq_and ->
+ 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 ->
+ 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 ->
+ let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg)
+ | [|a;b|] when 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
+ | _ -> parse_atom env tg term)
+ | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
+ 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)
+ | _ -> X(term),env,tg in
+ xparse_formula env term
+
+ let dump_formula typ dump_atom f =
+ let rec xdump f =
+ match f with
+ | TT -> mkApp(Lazy.force coq_TT,[|typ|])
+ | FF -> mkApp(Lazy.force coq_FF,[|typ|])
+ | C(x,y) -> mkApp(Lazy.force coq_And,[|typ ; xdump x ; xdump y|])
+ | D(x,y) -> mkApp(Lazy.force coq_Or,[|typ ; xdump x ; xdump y|])
+ | I(x,_,y) -> mkApp(Lazy.force coq_Impl,[|typ ; xdump x ; xdump y|])
+ | N(x) -> mkApp(Lazy.force coq_Neg,[|typ ; xdump x|])
+ | A(x,_,_) -> mkApp(Lazy.force coq_Atom,[|typ ; dump_atom x|])
+ | X(t) -> mkApp(Lazy.force coq_X,[|typ ; t|]) in
+ xdump f
+
+ (**
+ * Given a conclusion and a list of affectations, rebuild a term prefixed by
+ * the appropriate letins.
+ * TODO: reverse the list of bindings!
+ *)
+
+ let set l concl =
+ let rec xset acc = function
+ | [] -> acc
+ | (e::l) ->
+ let (name,expr,typ) = e in
+ xset (Term.mkNamedLetIn
+ (Names.id_of_string name)
+ expr typ acc) l in
+ xset concl l
+
+end (**
+ * MODULE END: M
+ *)
+
+open M
+
+let rec sig_of_cone = function
+ | Mc.PsatzIn n -> [CoqToCaml.nat n]
+ | Mc.PsatzMulE(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2)
+ | Mc.PsatzMulC(w1,w2) -> (sig_of_cone w2)
+ | Mc.PsatzAdd(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2)
+ | _ -> []
+
+let same_proof sg cl1 cl2 =
+ let rec xsame_proof sg =
+ match sg with
+ | [] -> true
+ | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false)
+ && (xsame_proof sg ) in
+ xsame_proof sg
+
+let tags_of_clause tgs wit clause =
+ let rec xtags tgs = function
+ | Mc.PsatzIn n -> Names.Idset.union tgs
+ (snd (List.nth clause (CoqToCaml.nat n) ))
+ | Mc.PsatzMulC(e,w) -> xtags tgs w
+ | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2
+ | _ -> tgs in
+ xtags tgs wit
+
+let tags_of_cnf wits cnf =
+ List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl)
+ Names.Idset.empty wits cnf
+
+let find_witness prover polys1 = try_any prover polys1
+
+let rec witness prover l1 l2 =
+ match l2 with
+ | [] -> Some []
+ | e :: l2 ->
+ match find_witness prover (e::l1) with
+ | None -> None
+ | Some w ->
+ (match witness prover l1 l2 with
+ | None -> None
+ | Some l -> Some (w::l)
+ )
+
+let rec apply_ids t ids =
+ match ids with
+ | [] -> t
+ | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids
+
+let coq_Node = lazy
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node")
+let coq_Leaf = lazy
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf")
+let coq_Empty = lazy
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty")
+
+let btree_of_array typ a =
+ let size_of_a = Array.length a in
+ let semi_size_of_a = size_of_a lsr 1 in
+ let node = Lazy.force coq_Node
+ and leaf = Lazy.force coq_Leaf
+ and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in
+ let rec aux n =
+ if n > size_of_a
+ then empty
+ else if n > semi_size_of_a
+ then Term.mkApp (leaf, [| typ; a.(n-1) |])
+ else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |])
+ in
+ aux 1
+
+let btree_of_array typ a =
+ try
+ btree_of_array typ a
+ with x ->
+ failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x))
+
+let dump_varmap typ env =
+ btree_of_array typ (Array.of_list env)
+
+
+let rec pp_varmap o vm =
+ match vm with
+ | Mc.Empty -> output_string o "[]"
+ | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z
+ | Mc.Node(l,z,r) -> Printf.fprintf o "[%a, %a, %a]" pp_varmap l pp_z z pp_varmap r
+
+
+
+let rec dump_proof_term = function
+ | Micromega.DoneProof -> Lazy.force coq_doneProof
+ | Micromega.RatProof(cone,rst) ->
+ Term.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|])
+ | Micromega.CutProof(cone,prf) ->
+ Term.mkApp(Lazy.force coq_cutProof,
+ [| dump_psatz coq_Z dump_z cone ;
+ dump_proof_term prf|])
+ | Micromega.EnumProof(c1,c2,prfs) ->
+ Term.mkApp (Lazy.force coq_enumProof,
+ [| 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 pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden
+
+
+let rec pp_proof_term o = function
+ | Micromega.DoneProof -> Printf.fprintf o "D"
+ | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst
+ | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst
+ | Micromega.EnumProof(c1,c2,rst) ->
+ Printf.fprintf o "EP[%a,%a,%a]"
+ (pp_psatz pp_z) c1 (pp_psatz pp_z) c2
+ (pp_list "[" "]" pp_proof_term) rst
+
+let rec parse_hyps parse_arith env tg hyps =
+ match hyps with
+ | [] -> ([],env,tg)
+ | (i,t)::l ->
+ let (lhyps,env,tg) = parse_hyps parse_arith env tg l in
+ try
+ let (c,env,tg) = parse_formula parse_arith env tg t in
+ ((i,c)::lhyps, env,tg)
+ with _ -> (lhyps,env,tg)
+ (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
+
+
+(*exception ParseError*)
+
+let parse_goal parse_arith env hyps term =
+ (* try*)
+ let (f,env,tg) = parse_formula parse_arith env (Tag.from 0) term in
+ let (lhyps,env,tg) = parse_hyps parse_arith env tg hyps in
+ (lhyps,f,env)
+ (* with Failure x -> raise ParseError*)
+
+(**
+ * 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
+}
+
+let zz_domain_spec = lazy {
+ typ = Lazy.force coq_Z;
+ coeff = Lazy.force coq_Z;
+ dump_coeff = dump_z ;
+ proof_typ = Lazy.force coq_proofTerm ;
+ dump_proof = dump_proof_term
+}
+
+let qq_domain_spec = lazy {
+ typ = Lazy.force coq_Q;
+ coeff = Lazy.force coq_Q;
+ dump_coeff = dump_q ;
+ proof_typ = Lazy.force coq_QWitness ;
+ dump_proof = dump_psatz coq_Q dump_q
+}
+
+let rz_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
+}
+
+(**
+ * Instanciate the current Coq goal with a Micromega formula, a varmap, and a
+ * witness.
+ *)
+
+let micromega_order_change spec cert cert_typ env ff gl =
+ let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in
+ let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in
+ let vm = dump_varmap (spec.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", [|spec.typ|]));
+ ("__wit", cert, cert_typ)
+ ]
+ (Tacmach.pf_concl gl)
+ )
+ gl
+
+(**
+ * The datastructures that aggregate prover attributes.
+ *)
+
+type ('a,'prf) prover = {
+ name : string ; (* name of the prover *)
+ prover : 'a list -> 'prf option ; (* the prover itself *)
+ hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *)
+ compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *)
+ pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *)
+ pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*)
+}
+
+(**
+ * Given a list of provers and a disjunction of atoms, find a proof of any of
+ * the atoms. Returns an (optional) pair of a proof and a prover
+ * datastructure.
+ *)
+
+let find_witness provers polys1 =
+ let provers = List.map (fun p ->
+ (fun l ->
+ match p.prover l with
+ | None -> None
+ | Some prf -> Some(prf,p)) , p.name) provers in
+ try_any provers (List.map fst polys1)
+
+(**
+ * Given a list of provers and a CNF, find a proof for each of the clauses.
+ * Return the proofs as a list.
+ *)
+
+let witness_list prover l =
+ let rec xwitness_list l =
+ match l with
+ | [] -> Some []
+ | e :: l ->
+ match find_witness prover e with
+ | None -> None
+ | Some w ->
+ (match xwitness_list l with
+ | None -> None
+ | Some l -> Some (w :: l)
+ ) in
+ xwitness_list l
+
+let witness_list_tags = witness_list
+
+(* *Deprecated* let is_singleton = function [] -> true | [e] -> true | _ -> false *)
+
+let pp_ml_list pp_elt o l =
+ output_string o "[" ;
+ List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ;
+ output_string o "]"
+
+(**
+ * Prune the proof object, according to the 'diff' between two cnf formulas.
+ *)
+
+let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
+
+ let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
+ let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in
+ 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
+ begin
+ Printf.printf "\ncompact_proof : %a %a %a"
+ (pp_ml_list prover.pp_f) (List.map fst old_cl)
+ prover.pp_prf prf
+ (pp_ml_list prover.pp_f) (List.map fst new_cl) ;
+ flush stdout
+ end ;
+ let res = try prover.compact prf remap with x ->
+ if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ;
+ (* This should not happen -- this is the recovery plan... *)
+ match prover.prover (List.map fst new_cl) with
+ | None -> failwith "proof compaction error"
+ | Some p -> p
+ in
+ if debug then
+ begin
+ Printf.printf " -> %a\n"
+ prover.pp_prf res ;
+ flush stdout
+ end ;
+ res in
+
+ let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) =
+ let hyps_idx = prover.hyps prf in
+ let hyps = selecti hyps_idx old_cl in
+ is_sublist hyps new_cl in
+
+ let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *)
+
+ List.map (fun x ->
+ let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res
+ in compact_proof o p x) cnf_ff'
+
+
+(**
+ * "Hide out" tagged atoms of a formula by transforming them into generic
+ * variables. See the Tag module in mutils.ml for more.
+ *)
+
+let abstract_formula hyps f =
+ let rec xabs f =
+ match f with
+ | X c -> X c
+ | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term)
+ | C(f1,f2) ->
+ (match xabs f1 , xabs f2 with
+ | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_and, [|a1;a2|]))
+ | f1 , f2 -> C(f1,f2) )
+ | D(f1,f2) ->
+ (match xabs f1 , xabs f2 with
+ | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_or, [|a1;a2|]))
+ | f1 , f2 -> D(f1,f2) )
+ | N(f) ->
+ (match xabs f with
+ | X a -> X (Term.mkApp(Lazy.force coq_not, [|a|]))
+ | f -> N f)
+ | I(f1,hyp,f2) ->
+ (match xabs f1 , hyp, xabs f2 with
+ | X a1 , Some _ , af2 -> af2
+ | X a1 , None , X a2 -> X (Term.mkArrow a1 a2)
+ | af1 , _ , af2 -> I(af1,hyp,af2)
+ )
+ | FF -> FF
+ | TT -> TT
+ in xabs f
+
+(**
+ * This exception is raised by really_call_csdpcert if Coq's configure didn't
+ * find a CSDP executable.
+ *)
+
+exception CsdpNotFound
+
+(**
+ * This is the core of Micromega: apply the prover, analyze the result and
+ * 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) =
+ List.fold_right
+ (fun (id,f) (cc,ids) ->
+ match f with
+ X _ -> (cc,ids)
+ | _ -> (I(f,Some id,cc), id::ids))
+ polys1 (polys2,[]) in
+
+ (* Convert the aplpication into a (mc_)cnf (a list of lists of formulas) *)
+ let cnf_ff = cnf negate normalise ff in
+
+ if debug then
+ begin
+ Pp.pp (Pp.str "Formula....\n") ;
+ let formula_typ = (Term.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in
+ let ff = dump_formula formula_typ
+ (dump_cstr spec.typ spec.dump_coeff) ff in
+ Pp.pp (Printer.prterm ff) ; Pp.pp_flush ();
+ Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff
+ end;
+
+ match witness_list_tags prover cnf_ff with
+ | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
+ | 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
+
+ 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
+
+ if debug then
+ begin
+ Pp.pp (Pp.str "\nAFormula\n") ;
+ let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in
+ let ff' = dump_formula formula_typ
+ (dump_cstr spec.typ spec.dump_coeff) ff' in
+ Pp.pp (Printer.prterm ff') ; Pp.pp_flush ();
+ Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff'
+ end;
+
+ (* Even if it does not work, this does not mean it is not provable
+ -- the prover is REALLY incomplete *)
+ (* if debug then
+ begin
+ (* recompute the proofs *)
+ match witness_list_tags prover cnf_ff' with
+ | None -> failwith "abstraction is wrong"
+ | Some res -> ()
+ 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 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
+
+(**
+ * Parse the proof environment, and call micromega_tauto
+ *)
+
+let micromega_gen
+ parse_arith
+ (negate:'cst atom -> 'cst mc_cnf)
+ (normalise:'cst atom -> 'cst mc_cnf)
+ 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
+ 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 this instance of Coq isn't aware of the presence of any \"csdp\" executable. \n\n"
+ ^ "You may need to specify the location during Coq's pre-compilation configuration step")) gl
+
+let lift_ratproof prover l =
+ match prover l with
+ | None -> None
+ | Some c -> Some (Mc.RatProof( c,Mc.DoneProof))
+
+type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list
+type csdp_certificate = S of Sos_types.positivstellensatz option | F of string
+type provername = string * int option
+
+(**
+ * The caching mechanism.
+ *)
+
+open Persistent_cache
+
+module Cache = PHashtable(struct
+ type t = (provername * micromega_polys)
+ let equal = (=)
+ let hash = Hashtbl.hash
+end)
+
+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.
+ *)
+
+let require_csdp =
+ match System.search_exe_in_path "csdp" with
+ | Some _ -> lazy ()
+ | _ -> lazy (raise CsdpNotFound)
+
+let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option =
+ fun provername poly ->
+
+ Lazy.force require_csdp;
+
+ let cmdname =
+ List.fold_left Filename.concat (Envars.coqlib ())
+ ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in
+
+ match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with
+ | F str -> failwith str
+ | S res -> res
+
+(**
+ * Check the cache before calling the prover.
+ *)
+
+let xcall_csdpcert =
+ Cache.memo csdp_cache (fun (prover,pb) -> really_call_csdpcert prover pb)
+
+(**
+ * Prover callback functions.
+ *)
+
+let call_csdpcert prover pb = xcall_csdpcert (prover,pb)
+
+let rec z_to_q_pol e =
+ match e with
+ | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH}
+ | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol)
+ | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2)
+
+let call_csdpcert_q provername poly =
+ match call_csdpcert provername poly with
+ | None -> None
+ | Some cert ->
+ let cert = Certificate.q_cert_of_pos cert in
+ if Mc.qWeakChecker poly cert
+ then Some cert
+ else ((print_string "buggy certificate" ; flush stdout) ;None)
+
+let call_csdpcert_z provername poly =
+ let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in
+ match call_csdpcert provername l with
+ | None -> None
+ | Some cert ->
+ let cert = Certificate.z_cert_of_pos cert in
+ if Mc.zWeakChecker poly cert
+ then Some cert
+ else ((print_string "buggy certificate" ; flush stdout) ;None)
+
+let xhyps_of_cone base acc prf =
+ let rec xtract e acc =
+ match e with
+ | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc
+ | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in
+ if n >= base
+ then ISet.add (n-base) acc
+ else acc
+ | Mc.PsatzMulC(_,c) -> xtract c acc
+ | Mc.PsatzAdd(e1,e2) | Mc.PsatzMulE(e1,e2) -> xtract e1 (xtract e2 acc) in
+
+ xtract prf acc
+
+let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf
+
+let compact_cone prf f =
+ let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in
+
+ let rec xinterp prf =
+ match prf with
+ | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf
+ | Mc.PsatzIn n -> Mc.PsatzIn (np n)
+ | Mc.PsatzMulC(e,c) -> Mc.PsatzMulC(e,xinterp c)
+ | Mc.PsatzAdd(e1,e2) -> Mc.PsatzAdd(xinterp e1,xinterp e2)
+ | Mc.PsatzMulE(e1,e2) -> Mc.PsatzMulE(xinterp e1,xinterp e2) in
+
+ xinterp prf
+
+let hyps_of_pt pt =
+
+ let rec xhyps base pt acc =
+ match pt with
+ | Mc.DoneProof -> acc
+ | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c)
+ | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c)
+ | Mc.EnumProof(c1,c2,l) ->
+ let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in
+ List.fold_left (fun s x -> xhyps (base + 1) x s) s l in
+
+ xhyps 0 pt ISet.empty
+
+let hyps_of_pt pt =
+ let res = hyps_of_pt pt in
+ if debug
+ then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res);
+ res
+
+let compact_pt pt f =
+ let translate ofset x =
+ if x < ofset then x
+ else (f (x-ofset) + ofset) in
+
+ let rec compact_pt ofset pt =
+ match pt with
+ | Mc.DoneProof -> Mc.DoneProof
+ | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt )
+ | Mc.CutProof(c,pt) -> Mc.CutProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt )
+ | Mc.EnumProof(c1,c2,l) -> Mc.EnumProof(compact_cone c1 (translate (ofset)), compact_cone c2 (translate (ofset)),
+ Mc.map (fun x -> compact_pt (ofset+1) x) l) in
+ compact_pt 0 pt
+
+(**
+ * Definition of provers.
+ * Instantiates the type ('a,'prf) prover defined above.
+ *)
+
+let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l)
+
+let linear_prover_Z = {
+ name = "linear prover" ;
+ prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ;
+ 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 linear_prover_Q = {
+ name = "linear prover";
+ prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ;
+ hyps = hyps_of_cone ;
+ compact = compact_cone ;
+ pp_prf = pp_psatz pp_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) ;
+ 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)
+}
+
+let non_linear_prover_Q str o = {
+ name = "real nonlinear prover";
+ prover = call_csdpcert_q (str, o);
+ hyps = hyps_of_cone;
+ compact = compact_cone ;
+ pp_prf = pp_psatz pp_q ;
+ pp_f = fun o x -> pp_pol pp_q o (fst x)
+}
+
+let non_linear_prover_R str o = {
+ name = "real nonlinear prover";
+ prover = call_csdpcert_z (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)
+}
+
+let non_linear_prover_Z str o = {
+ name = "real nonlinear prover";
+ prover = lift_ratproof (call_csdpcert_z (str, o));
+ hyps = hyps_of_pt;
+ compact = compact_pt;
+ pp_prf = pp_proof_term;
+ pp_f = fun o x -> pp_pol pp_z o (fst x)
+}
+
+module CacheZ = PHashtable(struct
+ type t = (Mc.z Mc.pol * Mc.op1) list
+ let equal = (=)
+ let hash = Hashtbl.hash
+end)
+
+let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)
+
+let linear_Z = {
+ name = "lia";
+ prover = memo_zlinear_prover ;
+ hyps = hyps_of_pt;
+ compact = compact_pt;
+ pp_prf = pp_proof_term;
+ pp_f = fun o x -> pp_pol pp_z o (fst x)
+}
+
+(**
+ * 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
+ [ linear_prover_Z ] gl
+
+let psatzl_Q gl =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec
+ [ linear_prover_Q ] gl
+
+let psatz_Q i gl =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise 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
+
+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
+
+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
+
+let sos_Z gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise 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
+ [ 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
+
+let xlia gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+ [ linear_Z ] gl
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml
new file mode 100644
index 00000000..d4e6d920
--- /dev/null
+++ b/plugins/micromega/csdpcert.ml
@@ -0,0 +1,214 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+open Big_int
+open Num
+open Sos
+open Sos_types
+open Sos_lib
+
+
+module Mc = Micromega
+module Ml2C = Mutils.CamlToCoq
+module C2Ml = Mutils.CoqToCaml
+
+type micromega_polys = (Micromega.q Mc.pol * Mc.op1) list
+type csdp_certificate = S of Sos_types.positivstellensatz option | F of string
+type provername = string * int option
+
+
+let debug = true
+let flags = [Open_append;Open_binary;Open_creat]
+
+let chan = open_out_gen flags 0o666 "trace"
+
+
+module M =
+struct
+ open Mc
+
+ let rec expr_to_term = function
+ | PEc z -> Const (C2Ml.q_to_num z)
+ | PEX v -> Var ("x"^(string_of_int (C2Ml.index v)))
+ | PEmul(p1,p2) ->
+ let p1 = expr_to_term p1 in
+ let p2 = expr_to_term p2 in
+ let res = Mul(p1,p2) in res
+
+ | PEadd(p1,p2) -> Add(expr_to_term p1, expr_to_term p2)
+ | PEsub(p1,p2) -> Sub(expr_to_term p1, expr_to_term p2)
+ | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n)
+ | PEopp p -> Opp (expr_to_term p)
+
+
+end
+open M
+
+open List
+open Mutils
+
+
+
+
+let rec canonical_sum_to_string = function s -> failwith "not implemented"
+
+let print_canonical_sum m = Format.print_string (canonical_sum_to_string m)
+
+let print_list_term o l =
+ output_string o "print_list_term\n";
+ List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;"
+ (string_of_poly (poly_of_term (expr_to_term e)))
+ (match k with
+ Mc.Equal -> "= "
+ | Mc.Strict -> "> "
+ | Mc.NonStrict -> ">= "
+ | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ;
+ output_string o "\n"
+
+
+let partition_expr l =
+ let rec f i = function
+ | [] -> ([],[],[])
+ | (e,k)::l ->
+ let (eq,ge,neq) = f (i+1) l in
+ match k with
+ | Mc.Equal -> ((e,i)::eq,ge,neq)
+ | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq)
+ | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *)
+ (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq)
+ | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq)
+ (* Not quite sure -- Coq interface has changed *)
+ in f 0 l
+
+
+let rec sets_of_list l =
+ match l with
+ | [] -> [[]]
+ | e::l -> let s = sets_of_list l in
+ s@(List.map (fun s0 -> e::s0) s)
+
+(* The exploration is probably not complete - for simple cases, it works... *)
+let real_nonlinear_prover d l =
+ let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in
+ try
+ let (eq,ge,neq) = partition_expr l in
+
+ let rec elim_const = function
+ [] -> []
+ | (x,y)::l -> let p = poly_of_term (expr_to_term x) in
+ if poly_isconst p
+ then elim_const l
+ else (p,y)::(elim_const l) in
+
+ let eq = elim_const eq in
+ let peq = List.map fst eq in
+
+ let pge = List.map
+ (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in
+
+ let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y ->
+ let p = poly_of_term (expr_to_term p) in
+ match kd with
+ | Axiom_lt i -> poly_mul p y
+ | Axiom_eq i -> poly_mul (poly_pow p 2) y
+ | _ -> failwith "monoids") m (poly_const (Int 1)) , map snd m))
+ (sets_of_list neq) in
+
+ let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d ->
+ list_try_find (fun m -> let (ci,cc) =
+ real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in
+ (ci,cc,snd m)) monoids) 0 in
+
+ let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i))
+ cert_ideal (List.map snd eq) in
+
+ let proofs_cone = map term_of_sos cert_cone in
+
+ let proof_ne =
+ let (neq , lt) = List.partition
+ (function Axiom_eq _ -> true | _ -> false ) monoid in
+ let sq = match
+ (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq)
+ with
+ | [] -> Rational_lt (Int 1)
+ | l -> Monoid l in
+ List.fold_right (fun x y -> Product(x,y)) lt sq in
+
+ let proof = list_fold_right_elements
+ (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
+ S (Some proof)
+ with
+ | Sos_lib.TooDeep -> S None
+ | x -> F (Printexc.to_string x)
+
+(* This is somewhat buggy, over Z, strict inequality vanish... *)
+let pure_sos l =
+ let l = List.map (fun (e,o) -> Mc.denorm e, o) l in
+
+ (* If there is no strict inequality,
+ I should nonetheless be able to try something - over Z > is equivalent to -1 >= *)
+ try
+ let l = List.combine l (interval 0 (length l -1)) in
+ let (lt,i) = try (List.find (fun (x,_) -> snd x = Mc.Strict) l)
+ with Not_found -> List.hd l in
+ let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in
+ let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *)
+ let pos = Product (Rational_lt n,
+ List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square
+ (term_of_poly p)), rst))
+ polys (Rational_lt (Int 0))) in
+ let proof = Sum(Axiom_lt i, pos) in
+(* let s,proof' = scale_certificate proof in
+ let cert = snd (cert_of_pos proof') in *)
+ S (Some proof)
+ with
+(* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *)
+ | x -> (* May be that could be refined *) S None
+
+
+
+let run_prover prover pb =
+ match prover with
+ | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb
+ | "pure_sos", None -> pure_sos pb
+ | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1)
+
+
+let output_csdp_certificate o = function
+ | S None -> output_string o "S None"
+ | S (Some p) -> Printf.fprintf o "S (Some %a)" output_psatz p
+ | F s -> Printf.fprintf o "F %s" s
+
+
+let main () =
+ try
+ let (prover,poly) = (input_value stdin : provername * micromega_polys) in
+ let cert = run_prover prover poly in
+(* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ;
+ close_out chan ; *)
+
+ output_value stdout (cert:csdp_certificate);
+ flush stdout ;
+ Marshal.to_channel chan (cert:csdp_certificate) [] ;
+ flush chan ;
+ exit 0
+ with x -> (Printf.fprintf chan "error %s" (Printexc.to_string x) ; exit 1)
+
+;;
+
+let _ = main () in ()
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
new file mode 100644
index 00000000..f4d04e5d
--- /dev/null
+++ b/plugins/micromega/g_micromega.ml4
@@ -0,0 +1,76 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Quote
+open Ring
+open Mutils
+open Rawterm
+open Util
+
+let out_arg = function
+ | ArgVar _ -> anomaly "Unevaluated or_var variable"
+ | ArgArg x -> x
+
+TACTIC EXTEND PsatzZ
+| [ "psatz_Z" int_or_var(i) ] -> [ Coq_micromega.psatz_Z (out_arg i) ]
+| [ "psatz_Z" ] -> [ Coq_micromega.psatz_Z (-1) ]
+END
+
+TACTIC EXTEND ZOmicron
+[ "xlia" ] -> [ Coq_micromega.xlia]
+END
+
+
+TACTIC EXTEND Sos_Z
+| [ "sos_Z" ] -> [ Coq_micromega.sos_Z]
+ END
+
+TACTIC EXTEND Sos_Q
+| [ "sos_Q" ] -> [ Coq_micromega.sos_Q]
+ END
+
+TACTIC EXTEND Sos_R
+| [ "sos_R" ] -> [ Coq_micromega.sos_R]
+END
+
+
+TACTIC EXTEND Omicron
+[ "psatzl_Z" ] -> [ Coq_micromega.psatzl_Z]
+END
+
+TACTIC EXTEND QOmicron
+[ "psatzl_Q" ] -> [ Coq_micromega.psatzl_Q]
+END
+
+
+
+TACTIC EXTEND ROmicron
+[ "psatzl_R" ] -> [ Coq_micromega.psatzl_R]
+END
+
+TACTIC EXTEND RMicromega
+| [ "psatz_R" int_or_var(i) ] -> [ Coq_micromega.psatz_R (out_arg i) ]
+| [ "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) ]
+END
+
diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
new file mode 100644
index 00000000..6250e324
--- /dev/null
+++ b/plugins/micromega/mfourier.ml
@@ -0,0 +1,1012 @@
+open Num
+module Utils = Mutils
+
+let map_option = Utils.map_option
+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
+
+ (** The type of intervals is *)
+ type interval = num option * num option
+ (** None models the absence of bound i.e. infinity *)
+ (** As a result,
+ - None , None -> ]-oo,+oo[
+ - None , Some v -> ]-oo,v]
+ - Some v, None -> [v,+oo[
+ - Some v, Some v' -> [v,v']
+ Intervals needs to be explicitely normalised.
+ *)
+
+ type who = Left | Right
+
+
+ (** if then interval [itv] is empty, [norm_itv itv] returns [None]
+ otherwise, it returns [Some itv] *)
+
+ let norm_itv itv =
+ match itv with
+ | Some a , Some b -> if a <=/ b then Some itv else None
+ | _ -> Some itv
+
+ (** [opp_itv itv] computes the opposite interval *)
+ let opp_itv itv =
+ let (l,r) = itv in
+ (map_option minus_num r, map_option minus_num l)
+
+
+
+
+(** [inter i1 i2 = None] if the intersection of intervals is empty
+ [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *)
+ let inter i1 i2 =
+ let (l1,r1) = i1
+ and (l2,r2) = i2 in
+
+ let inter f o1 o2 =
+ match o1 , o2 with
+ | None , None -> None
+ | Some _ , None -> o1
+ | None , Some _ -> o2
+ | Some n1 , Some n2 -> Some (f n1 n2) in
+
+ norm_itv (inter max_num l1 l2 , inter min_num r1 r2)
+
+ let range = function
+ | None,_ | _,None -> None
+ | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1))
+
+
+ let smaller_itv i1 i2 =
+ match range i1 , range i2 with
+ | None , _ -> false
+ | _ , None -> true
+ | Some i , Some j -> i <=/ j
+
+
+(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *)
+let in_bound bnd v =
+ let (l,r) = bnd in
+ match l , r with
+ | None , None -> true
+ | None , Some a -> v <=/ a
+ | 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
+**)
+
+module ISet = Set.Make(struct type t = int let compare = Pervasives.compare end)
+
+
+module PSet = ISet
+
+
+module System = Hashtbl.Make(Vect)
+
+ type proof =
+ | Hyp of int
+ | Elim of var * proof * proof
+ | And of proof * proof
+
+
+
+type system = {
+ sys : cstr_info ref System.t ;
+ vars : ISet.t
+}
+and cstr_info = {
+ bound : interval ;
+ prf : proof ;
+ pos : int ;
+ neg : int ;
+}
+
+
+(** A system of constraints has the form [{sys = s ; vars = v}].
+ [s] is a hashtable mapping a normalised vector to a [cstr_info] record where
+ - [bound] is an interval
+ - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint.
+ In the initial system, each constraint is given an unique singleton proof_idx.
+ When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn]
+ - [pos] is the number of positive values of the vector
+ - [neg] is the number of negative values of the vector
+ ( [neg] + [pos] is therefore the length of the vector)
+ [v] is an upper-bound of the set of variables which appear in [s].
+*)
+
+(** To be thrown when a system has no solution *)
+exception SystemContradiction of proof
+let hyps prf =
+ let rec hyps prf acc =
+ match prf with
+ | Hyp i -> ISet.add i acc
+ | Elim(_,prf1,prf2)
+ | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in
+ hyps prf ISet.empty
+
+
+(** Pretty printing *)
+ let rec pp_proof o prf =
+ match prf with
+ | Hyp i -> Printf.fprintf o "H%i" i
+ | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2
+ | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2
+
+let pp_bound o = function
+ | None -> output_string o "oo"
+ | Some a -> output_string o (string_of_num a)
+
+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 "{" ;
+ ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s ();
+ output_string o "}"
+
+let pp_pset o s =
+ output_string o "{" ;
+ PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s ();
+ output_string o "}"
+
+
+let pp_info o i = pp_itv o i.bound
+
+let pp_cstr o (vect,bnd) =
+ let (l,r) = bnd in
+ (match l with
+ | None -> ()
+ | Some n -> Printf.fprintf o "%s <= " (string_of_num n))
+ ;
+ pp_vect o vect ;
+ (match r with
+ | None -> output_string o"\n"
+ | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n))
+
+
+let pp_system o sys=
+ System.iter (fun vect ibnd ->
+ pp_cstr o (vect,(!ibnd).bound)) sys
+
+
+
+let pp_split_cstr o (vl,v,c,_) =
+ Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect v (string_of_num c)
+
+(** [merge_cstr_info] takes:
+ - the intersection of bounds and
+ - the union of proofs
+ - [pos] and [neg] fields should be identical *)
+
+let merge_cstr_info i1 i2 =
+ let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1
+ and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in
+ assert (p1 = p2 && n1 = n2) ;
+ match inter i1 i2 with
+ | None -> None (* Could directly raise a system contradiction exception *)
+ | Some bnd ->
+ Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) }
+
+(** [xadd_cstr vect cstr_info] loads an constraint into the system.
+ The constraint is neither redundant nor contradictory.
+ @raise SystemContradiction if [cstr_info] returns [None]
+*)
+
+let xadd_cstr vect cstr_info sys =
+ if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ;
+ try
+ let info = System.find sys vect in
+ match merge_cstr_info cstr_info !info with
+ | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf)))
+ | Some info' -> info := info'
+ with
+ | Not_found -> System.replace sys vect (ref cstr_info)
+
+
+type cstr_ext =
+ | Contradiction (** The constraint is contradictory.
+ Typically, a [SystemContradiction] exception will be raised. *)
+ | Redundant (** The constrain is redundant.
+ Typically, the constraint will be dropped *)
+ | Cstr of vector * cstr_info (** Taken alone, the constraint is neither contradictory nor redundant.
+ Typically, it will be added to the constraint system. *)
+
+(** [normalise_cstr] : vector -> cstr_info -> cstr_ext *)
+let normalise_cstr vect cinfo =
+ match norm_itv cinfo.bound with
+ | None -> Contradiction
+ | Some (l,r) ->
+ match vect with
+ | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction
+ | (_,n)::_ -> Cstr(
+ (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect),
+ let divn x = x // n in
+ if sign_num n = 1
+ 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 -> ">="
+
+
+let eval_op = function
+ | Eq -> (=/)
+ | Ge -> (>=/)
+
+let count v =
+ let rec count n p v =
+ match v with
+ | [] -> (n,p)
+ | (_,vl)::v -> let sg = sign_num vl in
+ assert (sg <> 0) ;
+ if sg = 1 then count n (p+1) v else count (n+1) p v in
+ count 0 0 v
+
+
+let norm_cstr {coeffs = v ; op = o ; cst = c} idx =
+ let (n,p) = count v in
+
+ normalise_cstr v {pos = p ; neg = n ; bound =
+ (match o with
+ | Eq -> Some c , Some c
+ | Ge -> Some c , None) ;
+ prf = Hyp idx }
+
+
+(** [load_system l] takes a list of constraints of type [cstr_compat]
+ @return a system of constraints
+ @raise SystemContradiction if a contradiction is found
+*)
+let load_system l =
+
+ let sys = System.create 1000 in
+
+ let li = Mutils.mapi (fun e i -> (e,i)) l in
+
+ let vars = List.fold_left (fun vrs (cstr,i) ->
+ match norm_cstr cstr i with
+ | Contradiction -> raise (SystemContradiction (Hyp i))
+ | Redundant -> vrs
+ | Cstr(vect,info) ->
+ xadd_cstr vect info sys ;
+ List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in
+
+ {sys = sys ;vars = vars}
+
+let system_list sys =
+ let { sys = s ; vars = v } = sys in
+ System.fold (fun k bi l -> (k, !bi)::l) s []
+
+
+(** [add (v1,c1) (v2,c2) ]
+ precondition: (c1 <>/ Int 0 && c2 <>/ Int 0)
+ @return a pair [(v,ln)] such that
+ [v] is the sum of vector [v1] divided by [c1] and vector [v2] divided by [c2]
+ Note that the resulting vector is not normalised.
+*)
+
+let add (v1,c1) (v2,c2) =
+ assert (c1 <>/ Int 0 && c2 <>/ Int 0) ;
+
+ let rec xadd v1 v2 =
+ match v1 , v2 with
+ | (x1,n1)::v1' , (x2,n2)::v2' ->
+ if x1 = x2
+ then
+ let n' = (n1 // c1) +/ (n2 // c2) in
+ if n' =/ Int 0 then xadd v1' v2'
+ else
+ let res = xadd v1' v2' in
+ (x1,n') ::res
+ else if x1 < x2
+ then let res = xadd v1' v2 in
+ (x1, n1 // c1)::res
+ else let res = xadd v1 v2' in
+ (x2, n2 // c2)::res
+ | [] , [] -> []
+ | [] , _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2
+ | _ , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in
+
+ let res = xadd v1 v2 in
+ (res, count res)
+
+let add (v1,c1) (v2,c2) =
+ let res = add (v1,c1) (v2,c2) in
+ (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*)
+ res
+
+type tlr = (num * vector * cstr_info) list
+type tm = (vector * cstr_info ) list
+
+(** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *)
+
+(** [split x vect info (l,m,r)]
+ @param v is the variable to eliminate
+ @param l contains constraints such that (e + a*x) // a >= c / a
+ @param r contains constraints such that (e + a*x) // - a >= c / -a
+ @param m contains constraints which do not mention [x]
+*)
+
+let split x (vect: vector) info (l,m,r) =
+ match get x vect with
+ | None -> (* The constraint does not mention [x], store it in m *)
+ (l,(vect,info)::m,r)
+ | Some vl -> (* otherwise *)
+
+ let cons_bound lst bd =
+ match bd with
+ | None -> lst
+ | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in
+
+ let lb,rb = info.bound in
+ if sign_num vl = 1
+ then (cons_bound l lb,m,cons_bound r rb)
+ else (* sign_num vl = -1 *)
+ (cons_bound l rb,m,cons_bound r lb)
+
+
+(** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ].
+ This is a one step Fourier elimination.
+*)
+let project vr sys =
+
+ let (l,m,r) = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys ([],[],[]) in
+
+ let new_sys = System.create (System.length sys.sys) in
+
+ (* Constraints in [m] belong to the projection - for those [vr] is already projected out *)
+ List.iter (fun (vect,info) -> System.replace new_sys vect (ref info) ) m ;
+
+ let elim (v1,vect1,info1) (v2,vect2,info2) =
+ let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1
+ and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in
+
+ let bnd1 = from_option (fst bound1)
+ and bnd2 = from_option (fst bound2) in
+ let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in
+ let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in
+ (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in
+
+ List.iter(fun l_elem -> List.iter (fun r_elem ->
+ let (vect,info) = elim l_elem r_elem in
+ match normalise_cstr vect info with
+ | Redundant -> ()
+ | Contradiction -> raise (SystemContradiction info.prf)
+ | Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l;
+ {sys = new_sys ; vars = ISet.remove vr sys.vars}
+
+
+(** [project_using_eq] performs elimination by pivoting using an equation.
+ This is the counter_part of the [elim] sub-function of [!project].
+ @param vr is the variable to be used as pivot
+ @param c is the coefficient of variable [vr] in vector [vect]
+ @param len is the length of the equation
+ @param bound is the bound of the equation
+ @param prf is the proof of the equation
+*)
+
+let project_using_eq vr c vect bound prf (vect',info') =
+ match get vr vect' with
+ | Some c2 ->
+ let c1 = if c2 >=/ Int 0 then minus_num c else c in
+
+ let c2 = abs_num c2 in
+
+ let (vres,(n,p)) = add (vect,c1) (vect', c2) in
+
+ let cst = bound // c1 in
+
+ let bndres =
+ let f x = cst +/ x // c2 in
+ let (l,r) = info'.bound in
+ (map_option f l , map_option f r) in
+
+ (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)})
+ | None -> (vect',info')
+
+let elim_var_using_eq vr vect cst prf sys =
+ let c = from_option (get vr vect) in
+
+ let elim_var = project_using_eq vr c vect cst prf in
+
+ let new_sys = System.create (System.length sys.sys) in
+
+ System.iter(fun vect iref ->
+ let (vect',info') = elim_var (vect,!iref) in
+ match normalise_cstr vect' info' with
+ | Redundant -> ()
+ | Contradiction -> raise (SystemContradiction info'.prf)
+ | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ;
+
+ {sys = new_sys ; vars = ISet.remove vr sys.vars}
+
+
+(** [size sys] computes the number of entries in the system of constraints *)
+let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0
+
+module IMap = Map.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end)
+
+let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (string_of_num elt)) map ()
+
+(** [eval_vect map vect] evaluates vector [vect] using the values of [map].
+ If [map] binds all the variables of [vect], we get
+ [eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []]
+ The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *)
+
+let eval_vect map vect =
+ let rec xeval_vect vect sum rst =
+ match vect with
+ | [] -> (sum,rst)
+ | (v,vl)::vect ->
+ try
+ let val_v = IMap.find v map in
+ xeval_vect vect (sum +/ (val_v */ vl)) rst
+ with
+ Not_found -> xeval_vect vect sum ((v,vl)::rst) in
+ xeval_vect vect (Int 0) []
+
+
+(** [restrict_bound n sum itv] returns the interval of [x]
+ given that (fst itv) <= x * n + sum <= (snd itv) *)
+let restrict_bound n sum (itv:interval) =
+ let f x = (x -/ sum) // n in
+ let l,r = itv in
+ match sign_num n with
+ | 0 -> if in_bound itv sum
+ then (None,None) (* redundant *)
+ else failwith "SystemContradiction"
+ | 1 -> map_option f l , map_option f r
+ | _ -> map_option f r , map_option f l
+
+
+(** [bound_of_variable map v sys] computes the interval of [v] in
+ [sys] given a mapping [map] binding all the other variables *)
+let bound_of_variable map v sys =
+ System.fold (fun vect iref bnd ->
+ let sum,rst = eval_vect map vect in
+ let vl = match get v rst with
+ | None -> Int 0
+ | Some v -> v in
+ match inter bnd (restrict_bound vl sum (!iref).bound) with
+ | None -> failwith "bound_of_variable: impossible"
+ | Some itv -> itv) sys (None,None)
+
+
+(** [pick_small_value bnd] picks a value being closed to zero within the interval *)
+let pick_small_value bnd =
+ match bnd with
+ | None , None -> Int 0
+ | None , Some i -> if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i
+ | Some i,None -> if i <=/ (Int 0) then Int 0 else ceiling_num i
+ | Some i,Some j ->
+ if i <=/ Int 0 && Int 0 <=/ j
+ then Int 0
+ else if ceiling_num i <=/ floor_num j
+ then ceiling_num i (* why not *) else i
+
+
+(** [solution s1 sys_l = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)]
+ then [sn] is a system which contains only [black_v] -- if it existed in [s1]
+ and [sn+1] is obtained by projecting [vn] out of [sn]
+ @raise SystemContradiction if system [s] has no solution
+*)
+
+let solve_sys black_v choose_eq choose_variable sys sys_l =
+
+ let rec solve_sys sys sys_l =
+ if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys);
+
+ let eqs = choose_eq sys in
+ try
+ let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in
+ if debug then
+ (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ;
+ flush stdout);
+ let sys' = elim_var_using_eq v vect cst ln sys in
+ solve_sys sys' ((v,sys)::sys_l)
+ with Not_found ->
+ 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) ;
+ let sys' = project v sys in
+ solve_sys sys' ((v,sys)::sys_l)
+ with Not_found -> (* we are done *) Inl (sys,sys_l) in
+ solve_sys sys sys_l
+
+
+
+
+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 ; *)
+ solve_sys black_v choose_eq choose_variable sys []
+ with SystemContradiction prf -> Inr prf
+
+
+(** The purpose of module [EstimateElimVar] is to try to estimate the cost of eliminating a variable.
+ The output is an ordered list of (variable,cost).
+*)
+
+module EstimateElimVar =
+struct
+ type sys_list = (vector * cstr_info) list
+
+ let abstract_partition (v:int) (l: sys_list) =
+
+ let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) =
+ match l with
+ | [] -> (ltl, n,z,p)
+ | (l1,info) ::rl ->
+ match l1 with
+ | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p
+ | (vr,vl)::rl1 ->
+ if v = vr
+ then
+ let cons_bound lst bd =
+ match bd with
+ | None -> lst
+ | Some bnd -> info.neg+info.pos::lst in
+
+ let lb,rb = info.bound in
+ if sign_num vl = 1
+ then xpart rl ((rl1,info)::ltl) (cons_bound n lb) z (cons_bound p rb)
+ else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb)
+ else
+ (* the variable is greater *)
+ xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p
+
+ in
+ let (sys',n,z,p) = xpart l [] [] 0 [] in
+
+ let ln = float_of_int (List.length n) in
+ let sn = float_of_int (List.fold_left (+) 0 n) in
+ let lp = float_of_int (List.length p) in
+ let sp = float_of_int (List.fold_left (+) 0 p) in
+ (sys', float_of_int z +. lp *. sn +. ln *. sp -. lp*.ln)
+
+
+ let choose_variable sys =
+ let {sys = s ; vars = v} = sys in
+
+ let sl = system_list sys in
+
+ let evals = fst
+ (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s in
+ ((v,vl)::eval, ts)) v ([],sl)) in
+
+ List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) evals
+
+
+end
+open EstimateElimVar
+
+(** The module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations.
+*)
+module EstimateElimEq =
+struct
+
+ let itv_point bnd =
+ match bnd with
+ |(Some a, Some b) -> a =/ b
+ | _ -> false
+
+ let eq_bound bnd c =
+ match bnd with
+ |(Some a, Some b) -> a =/ b && c =/ b
+ | _ -> false
+
+
+ let rec unroll_until v l =
+ match l with
+ | [] -> (false,[])
+ | (i,_)::rl -> if i = v
+ then (true,rl)
+ else if i < v then unroll_until v rl else (false,l)
+
+
+ let choose_primal_equation eqs sys_l =
+
+ let is_primal_equation_var v =
+ List.fold_left (fun (nb_eq,nb_cst) (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
+
+ 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
+ then Some i else find_var vect in
+
+ let rec find_eq_var eqs =
+ match eqs with
+ | [] -> None
+ | (vect,a,prf,ln)::l ->
+ match find_var vect with
+ | None -> find_eq_var l
+ | Some r -> Some (r,vect,a,prf,ln)
+ in
+
+
+ find_eq_var eqs
+
+
+
+
+ let choose_equality_var sys =
+
+ let sys_l = system_list sys in
+
+ let equalities = List.fold_left
+ (fun l (vect,info) ->
+ match info.bound with
+ | Some a , Some b ->
+ if a =/ b then (* This an equation *)
+ (vect,a,info.prf,info.neg+info.pos)::l else l
+ | _ -> l
+ ) [] sys_l in
+
+ let rec estimate_cost v ct sysl acc tlsys =
+ match sysl with
+ | [] -> (acc,tlsys)
+ | (l,info)::rsys ->
+ let ln = info.pos + info.neg in
+ let (b,l) = unroll_until v l in
+ match b with
+ | true ->
+ if itv_point info.bound
+ then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *)
+ else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *)
+ | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in
+
+ match choose_primal_equation equalities sys_l with
+ | None ->
+ let cost_eq eq const prf ln acc_costs =
+
+ let rec cost_eq eqr sysl costs =
+ match eqr with
+ | [] -> costs
+ | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in
+ cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in
+ cost_eq eq sys_l acc_costs in
+
+ let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in
+
+ (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *)
+
+ List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) all_costs
+ | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0]
+
+
+end
+open EstimateElimEq
+
+module Fourier =
+struct
+
+ let optimise vect l =
+ (* We add a dummy (fresh) variable for vector *)
+ let fresh =
+ List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 l in
+ let cstr = {
+ coeffs = Vect.set fresh (Int (-1)) vect ;
+ op = Eq ;
+ cst = (Int 0)} in
+ match solve fresh choose_equality_var choose_variable (cstr::l) with
+ | Inr prf -> None (* This is an unsatisfiability proof *)
+ | Inl (s,_) ->
+ try
+ Some (bound_of_variable IMap.empty fresh s.sys)
+ with
+ x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None
+
+
+ let find_point cstrs =
+
+ match solve max_int choose_equality_var choose_variable cstrs with
+ | Inr prf -> Inr prf
+ | Inl (_,l) ->
+
+ let rec rebuild_solution l map =
+ match l with
+ | [] -> map
+ | (v,e)::l ->
+ let itv = bound_of_variable map v e.sys in
+ let map = IMap.add v (pick_small_value itv) map in
+ rebuild_solution l map
+ in
+
+ let map = rebuild_solution l IMap.empty in
+ let vect = List.rev (IMap.fold (fun v i vect -> (v,i)::vect) map []) in
+(* Printf.printf "SOLUTION %a" pp_vect vect ; *)
+ let res = Inl vect in
+ res
+
+
+end
+
+
+module Proof =
+struct
+
+
+
+
+(** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction.
+ The proofs constructed by Fourier elimination are more like execution traces:
+ - certain facts are recorded but are useless
+ - certain inferences are implicit.
+ The following code implements proof reconstruction.
+*)
+ let add x y = fst (add x y)
+
+
+ let forall_pairs f l1 l2 =
+ List.fold_left (fun acc e1 ->
+ List.fold_left (fun acc e2 ->
+ match f e1 e2 with
+ | None -> acc
+ | Some v -> v::acc) acc l2) [] l1
+
+
+ let add_op x y =
+ match x , y with
+ | Eq , Eq -> Eq
+ | _ -> Ge
+
+
+ let pivot v (p1,c1) (p2,c2) =
+ let {coeffs = v1 ; op = op1 ; cst = n1} = c1
+ and {coeffs = v2 ; op = op2 ; cst = n2} = c2 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 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) })
+ else if op1 = Eq
+ then Some (add (p1,minus_num (a // b)) (p2,Int 1),
+ {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ;
+ op = add_op op1 op2;
+ cst = n1 // (minus_num (a// b)) +/ n2 // (Int 1)})
+ else if op2 = Eq
+ then
+ Some (add (p2,minus_num (b // a)) (p1,Int 1),
+ {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ;
+ op = add_op op1 op2;
+ cst = n2 // (minus_num (b// a)) +/ n1 // (Int 1)})
+ else None (* op2 could be Eq ... this might happen *)
+
+
+ let normalise_proofs l =
+ List.fold_left (fun acc (prf,cstr) ->
+ match acc with
+ | Inr _ -> acc (* I already found a contradiction *)
+ | Inl acc ->
+ match norm_cstr cstr 0 with
+ | Redundant -> Inl acc
+ | Contradiction -> Inr (prf,cstr)
+ | Cstr(v,info) -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l
+
+
+ type oproof = (vector * cstr_compat * num) option
+
+ let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) =
+ let (l,r) = info.bound in
+
+ let keep p ob bd =
+ match ob , bd with
+ | None , None -> None
+ | None , Some b -> Some(prf,cstr,b)
+ | Some _ , None -> ob
+ | Some(prfl,cstrl,bl) , Some b -> if p bl b then Some(prf,cstr, b) else ob in
+
+ let oleft = keep (<=/) oleft l in
+ let oright = keep (>=/) oright r in
+ (* Now, there might be a contradiction *)
+ match oleft , oright with
+ | None , _ | _ , None -> Inl (oleft,oright)
+ | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) ->
+ if l <=/ r
+ then Inl (oleft,oright)
+ else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*)
+ match cstrr.coeffs with
+ | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *)
+ | (v,_)::_ ->
+ match pivot v (prfl,cstrl) (prfr,cstrr) with
+ | None -> failwith "merge_proof : pivot is not possible"
+ | Some x -> Inr x
+
+let mk_proof hyps prf =
+ (* I am keeping list - I might have a proof for the left bound and a proof for the right bound.
+ If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2.
+ For each proof list, all the vectors should be of the form a.v for different constants a.
+ *)
+
+ let rec mk_proof prf =
+ match prf with
+ | Hyp i -> [ ([i, Int 1] , List.nth hyps i) ]
+
+ | Elim(v,prf1,prf2) ->
+ let prfsl = mk_proof prf1
+ and prfsr = mk_proof prf2 in
+ (* I take only the pairs for which the elimination is meaningfull *)
+ forall_pairs (pivot v) prfsl prfsr
+ | And(prf1,prf2) ->
+ let prfsl1 = mk_proof prf1
+ and prfsl2 = mk_proof prf2 in
+ (* detect trivial redundancies and contradictions *)
+ match normalise_proofs (prfsl1@prfsl2) with
+ | Inr x -> [x] (* This is a contradiction - this should be the end of the proof *)
+ | Inl l -> (* All the vectors are the same *)
+ let prfs =
+ List.fold_left (fun acc e ->
+ match acc with
+ | Inr _ -> acc (* I have a contradiction *)
+ | Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in
+ match prfs with
+ | Inr x -> [x]
+ | Inl (oleft,oright) ->
+ match oleft , oright with
+ | None , None -> []
+ | None , Some(prf,cstr,_) | Some(prf,cstr,_) , None -> [prf,cstr]
+ | Some(prf1,cstr1,_) , Some(prf2,cstr2,_) -> [prf1,cstr1;prf2,cstr2] in
+
+ mk_proof prf
+
+
+end
+
diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml
new file mode 100644
index 00000000..c350ed0f
--- /dev/null
+++ b/plugins/micromega/micromega.ml
@@ -0,0 +1,1703 @@
+(** val negb : bool -> bool **)
+
+let negb = function
+ | true -> false
+ | false -> true
+
+type nat =
+ | O
+ | S of nat
+
+type comparison =
+ | Eq
+ | Lt
+ | Gt
+
+(** val compOpp : comparison -> comparison **)
+
+let compOpp = function
+ | Eq -> Eq
+ | Lt -> Gt
+ | Gt -> Lt
+
+(** val plus : nat -> nat -> nat **)
+
+let rec plus n0 m =
+ match n0 with
+ | O -> m
+ | S p -> S (plus p m)
+
+(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
+
+let rec app l m =
+ match l with
+ | [] -> m
+ | a :: l1 -> a :: (app l1 m)
+
+(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **)
+
+let rec nth n0 l default =
+ match n0 with
+ | O -> (match l with
+ | [] -> default
+ | x :: l' -> x)
+ | S m -> (match l with
+ | [] -> default
+ | x :: t0 -> nth m t0 default)
+
+(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
+
+let rec map f = function
+ | [] -> []
+ | a :: t0 -> (f a) :: (map f t0)
+
+type positive =
+ | XI of positive
+ | XO of positive
+ | XH
+
+(** val psucc : positive -> positive **)
+
+let rec psucc = function
+ | XI p -> XO (psucc p)
+ | XO p -> XI p
+ | XH -> XO XH
+
+(** val pplus : positive -> positive -> positive **)
+
+let rec pplus 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))
+ | XO p ->
+ (match y with
+ | XI q0 -> XI (pplus p q0)
+ | XO q0 -> XO (pplus 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
+ | XI p ->
+ (match y with
+ | XI q0 -> XI (pplus_carry p q0)
+ | XO q0 -> XO (pplus_carry p q0)
+ | XH -> XI (psucc p))
+ | XO p ->
+ (match y with
+ | XI q0 -> XO (pplus_carry p q0)
+ | XO q0 -> XI (pplus p q0)
+ | XH -> XO (psucc 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
+ | XI p -> XI (XO p)
+ | XO p -> XI (pdouble_minus_one p)
+ | XH -> XH
+
+type positive_mask =
+ | IsNul
+ | IsPos of positive
+ | IsNeg
+
+(** val pdouble_plus_one_mask : positive_mask -> positive_mask **)
+
+let pdouble_plus_one_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
+ | IsPos p -> IsPos (XO p)
+ | IsNeg -> IsNeg
+
+(** val pdouble_minus_two : positive -> positive_mask **)
+
+let pdouble_minus_two = function
+ | XI p -> IsPos (XO (XO p))
+ | XO p -> IsPos (XO (pdouble_minus_one p))
+ | XH -> IsNul
+
+(** val pminus_mask : positive -> positive -> positive_mask **)
+
+let rec pminus_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))
+ | 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
+ | 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))
+ | 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)
+ | XH -> IsNeg
+
+(** val pminus : positive -> positive -> positive **)
+
+let pminus x y =
+ match pminus_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)
+ | XH -> y
+
+(** val pcompare : positive -> positive -> comparison -> comparison **)
+
+let rec pcompare x y r =
+ match x with
+ | XI p ->
+ (match y with
+ | XI q0 -> pcompare p q0 r
+ | XO q0 -> pcompare p q0 Gt
+ | XH -> Gt)
+ | 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)
+ | XH -> S O
+
+type n =
+ | N0
+ | Npos of positive
+
+(** 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
+
+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 **)
+
+let zdouble_minus_one = function
+ | Z0 -> Zneg XH
+ | Zpos p -> Zpos (pdouble_minus_one p)
+ | Zneg p -> Zneg (XI p)
+
+(** val zdouble : z -> z **)
+
+let zdouble = 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
+ | XI p ->
+ (match y with
+ | XI q0 -> zdouble (zPminus p q0)
+ | XO q0 -> zdouble_plus_one (zPminus 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))
+ | 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
+ | 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')))
+ | 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
+ | 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
+ | Z0 -> Z0
+ | Zpos x' ->
+ (match y with
+ | Z0 -> Z0
+ | Zpos y' -> Zpos (pmult x' y')
+ | Zneg y' -> Zneg (pmult 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)
+ | Zneg x' ->
+ (match y with
+ | Zneg y' -> compOpp (pcompare x' y' Eq)
+ | _ -> Lt)
+
+(** val zabs : z -> z **)
+
+let zabs = 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
+ | Gt -> false
+ | _ -> true
+
+(** val zge_bool : z -> z -> bool **)
+
+let zge_bool x y =
+ match zcompare x y with
+ | Lt -> false
+ | _ -> true
+
+(** val zgt_bool : z -> z -> bool **)
+
+let zgt_bool x y =
+ match zcompare x y with
+ | Gt -> true
+ | _ -> false
+
+(** val zeq_bool : z -> z -> bool **)
+
+let zeq_bool x y =
+ match zcompare x y with
+ | Eq -> 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
+ | 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)
+ | 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
+ | 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)))
+ | 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))
+
+(** val zdiv : z -> z -> z **)
+
+let zdiv a b =
+ let q0 , x = zdiv_eucl a b in q0
+
+type 'c pol =
+ | Pc of 'c
+ | Pinj of positive * 'c pol
+ | PX of 'c pol * positive * 'c pol
+
+(** val p0 : 'a1 -> 'a1 pol **)
+
+let p0 cO =
+ Pc cO
+
+(** val p1 : 'a1 -> 'a1 pol **)
+
+let p1 cI =
+ Pc cI
+
+(** val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool **)
+
+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)
+
+(** 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
+
+(** 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)
+
+(** val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol **)
+
+let mkXi cO cI i =
+ PX ((p1 cI), i, (p0 cO))
+
+(** val mkX : 'a1 -> 'a1 -> 'a1 pol **)
+
+let mkX cO cI =
+ mkXi cO cI XH
+
+(** 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))
+
+(** 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))
+
+(** 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))
+
+(** 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)))
+
+(** 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)))
+
+(** 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')
+
+(** 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')
+
+(** 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')))
+
+(** 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')))
+
+(** val pmulC_aux :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 ->
+ 'a1 pol **)
+
+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)
+
+(** val pmulC :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol ->
+ 'a1 -> 'a1 pol **)
+
+let pmulC cO cI cmul ceqb p c =
+ if ceqb c cO
+ then p0 cO
+ else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c
+
+(** val pmulI :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
+ '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))
+
+(** 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')))
+
+(** 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)
+
+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
+
+(** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **)
+
+let mk_X cO cI j =
+ mkPinj_pred j (mkX cO cI)
+
+(** val ppow_pos :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1
+ 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)
+
+(** 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
+
+(** 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
+
+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
+
+type 'term' clause = 'term' list
+
+type 'term' cnf = 'term' clause list
+
+(** val tt : 'a1 cnf **)
+
+let tt =
+ []
+
+(** val ff : 'a1 cnf **)
+
+let ff =
+ [] :: []
+
+(** val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf **)
+
+let or_clause_cnf t0 f =
+ map (fun x -> app t0 x) f
+
+(** val or_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
+
+let rec or_cnf f f' =
+ match f with
+ | [] -> tt
+ | e :: rst -> app (or_cnf rst f') (or_clause_cnf e f')
+
+(** val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf **)
+
+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)
+
+(** 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)
+
+(** val tauto_checker :
+ ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1
+ bFormula -> 'a3 list -> bool **)
+
+let tauto_checker normalise0 negate0 checker f w =
+ cnf_checker checker (xcnf normalise0 negate0 true f) w
+
+type 'c polC = 'c pol
+
+type op1 =
+ | Equal
+ | NonEqual
+ | Strict
+ | NonStrict
+
+type 'c nFormula = 'c polC * op1
+
+(** 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)
+
+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
+
+(** 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)
+
+(** 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)))
+
+(** 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)
+
+(** val eval_Psatz :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1
+ 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)
+
+(** 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)
+
+(** val check_normalised_formulas :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz ->
+ bool **)
+
+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
+
+type op2 =
+ | OpEq
+ | OpNEq
+ | OpLe
+ | OpGe
+ | OpLt
+ | OpGt
+
+type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr }
+
+(** val flhs : 'a1 formula -> 'a1 pExpr **)
+
+let flhs x = x.flhs
+
+(** val fop : 'a1 formula -> op2 **)
+
+let fop x = x.fop
+
+(** val frhs : 'a1 formula -> 'a1 pExpr **)
+
+let frhs x = x.frhs
+
+(** val norm :
+ '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
+
+(** 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'
+
+(** 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'
+
+(** 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 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) ::
+ [])
+
+(** 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)
+
+(** 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 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) :: [])
+
+(** 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)
+
+(** 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))
+
+(** val denorm : 'a1 pol -> 'a1 pExpr **)
+
+let denorm p =
+ xdenorm XH p
+
+(** 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))
+ | 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 }
+
+(** val qnum : q -> z **)
+
+let qnum x = x.qnum
+
+(** val qden : q -> positive **)
+
+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))
+
+(** 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))
+
+(** 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) }
+
+(** val qmult : q -> q -> q **)
+
+let qmult x y =
+ { qnum = (zmult x.qnum y.qnum); qden = (pmult x.qden y.qden) }
+
+(** val qopp : q -> q **)
+
+let qopp x =
+ { qnum = (zopp x.qnum); qden = x.qden }
+
+(** val qminus : q -> q -> q **)
+
+let qminus x y =
+ qplus x (qopp y)
+
+(** val qinv : q -> q **)
+
+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 }
+
+(** val qpower_positive : q -> positive -> q **)
+
+let qpower_positive q0 p =
+ pow_pos qmult 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)
+
+(** val pgcdn : nat -> positive -> positive -> positive **)
+
+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 **)
+
+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)
+
+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
+
+(** val psub1 : z pol -> z pol -> z pol **)
+
+let psub1 p p' =
+ psub0 Z0 zplus zminus zopp zeq_bool p p'
+
+(** val padd1 : z pol -> z pol -> z pol **)
+
+let padd1 p p' =
+ padd0 Z0 zplus zeq_bool p p'
+
+(** val norm0 : z pExpr -> z pol **)
+
+let norm0 pe =
+ norm Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool pe
+
+(** val xnormalise0 : z formula -> z nFormula list **)
+
+let xnormalise0 t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 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) :: [])
+
+(** val normalise : z formula -> z nFormula cnf **)
+
+let normalise t0 =
+ map (fun x -> x :: []) (xnormalise0 t0)
+
+(** val xnegate0 : z formula -> z nFormula list **)
+
+let xnegate0 t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 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) :: [])
+
+(** val negate : z formula -> z nFormula cnf **)
+
+let negate t0 =
+ map (fun x -> x :: []) (xnegate0 t0)
+
+(** val ceiling : z -> z -> z **)
+
+let ceiling a b =
+ let q0 , r = zdiv_eucl a b in
+ (match r with
+ | Z0 -> q0
+ | _ -> zplus q0 (Zpos XH))
+
+type zArithProof =
+ | 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)
+
+(** 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
+
+(** 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))
+
+(** 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
+
+(** 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 **)
+
+let nformula_of_cutting_plane = function
+ | 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
+
+(** 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
+
+(** val check_inconsistent0 : z nFormula -> bool **)
+
+let check_inconsistent0 f =
+ check_inconsistent Z0 zeq_bool zle_bool f
+
+(** 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)
+
+(** 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
+
+type qWitness = q psatz
+
+(** val qWeakChecker : q nFormula list -> q psatz -> bool **)
+
+let qWeakChecker x x0 =
+ check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
+ qden = XH } qplus qmult qeq_bool qle_bool x x0
+
+(** val qnormalise : q formula -> q nFormula cnf **)
+
+let qnormalise t0 =
+ cnf_normalise { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH }
+ qplus qmult qminus qopp qeq_bool t0
+
+(** val qnegate : q formula -> q nFormula cnf **)
+
+let qnegate t0 =
+ cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus
+ qmult qminus qopp qeq_bool t0
+
+(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **)
+
+let qTautoChecker f w =
+ tauto_checker qnormalise qnegate qWeakChecker f w
+
+type rWitness = z psatz
+
+(** val rWeakChecker : z nFormula list -> z psatz -> bool **)
+
+let rWeakChecker x x0 =
+ check_normalised_formulas Z0 (Zpos XH) zplus zmult zeq_bool zle_bool x x0
+
+(** val rnormalise : z formula -> z nFormula cnf **)
+
+let rnormalise t0 =
+ cnf_normalise Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0
+
+(** val rnegate : z formula -> z nFormula cnf **)
+
+let rnegate t0 =
+ cnf_negate Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool t0
+
+(** val rTautoChecker : z formula bFormula -> rWitness list -> bool **)
+
+let rTautoChecker f w =
+ tauto_checker rnormalise rnegate rWeakChecker f w
+
diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli
new file mode 100644
index 00000000..3e3ae2c3
--- /dev/null
+++ b/plugins/micromega/micromega.mli
@@ -0,0 +1,442 @@
+val negb : bool -> bool
+
+type nat =
+ | O
+ | S of nat
+
+type comparison =
+ | Eq
+ | Lt
+ | Gt
+
+val compOpp : comparison -> comparison
+
+val plus : nat -> nat -> nat
+
+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
+
+val pdouble_plus_one_mask : positive_mask -> positive_mask
+
+val pdouble_mask : positive_mask -> positive_mask
+
+val pdouble_minus_two : positive -> positive_mask
+
+val pminus_mask : positive -> positive -> positive_mask
+
+val pminus_mask_carry : positive -> positive -> positive_mask
+
+val pminus : positive -> positive -> positive
+
+val pmult : positive -> positive -> positive
+
+val pcompare : positive -> positive -> comparison -> comparison
+
+val psize : positive -> nat
+
+type n =
+ | N0
+ | Npos of positive
+
+val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1
+
+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
+
+val zmax : z -> z -> z
+
+val zle_bool : z -> z -> bool
+
+val zge_bool : z -> z -> bool
+
+val zgt_bool : z -> z -> bool
+
+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
+
+val p0 : 'a1 -> 'a1 pol
+
+val p1 : 'a1 -> 'a1 pol
+
+val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool
+
+val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol
+
+val mkPX :
+ 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol
+
+val mkX : 'a1 -> 'a1 -> 'a1 pol
+
+val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol
+
+val paddC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
+
+val psubC : ('a1 -> 'a1 -> 'a1) -> 'a1 pol -> 'a1 -> 'a1 pol
+
+val paddI :
+ ('a1 -> 'a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol ->
+ positive -> 'a1 pol -> 'a1 pol
+
+val psubI :
+ ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 pol -> 'a1 pol -> 'a1 pol) ->
+ 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val paddX :
+ 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol
+ -> positive -> 'a1 pol -> 'a1 pol
+
+val psubX :
+ 'a1 -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1
+ pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val padd :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol ->
+ 'a1 pol
+
+val psub :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
+ -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+
+val pmulC_aux :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> 'a1
+ pol
+
+val pmulC :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
+ -> 'a1 pol
+
+val pmulI :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
+ 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol
+
+val pmul :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+
+val psquare :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 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
+
+val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol
+
+val ppow_pos :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol
+
+val ppow_N :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol
+
+val norm_aux :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ '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
+
+type 'term' clause = 'term' list
+
+type 'term' cnf = 'term' clause list
+
+val tt : 'a1 cnf
+
+val ff : 'a1 cnf
+
+val or_clause_cnf : 'a1 clause -> 'a1 cnf -> 'a1 cnf
+
+val or_cnf : '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
+
+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
+
+type 'c polC = 'c pol
+
+type op1 =
+ | Equal
+ | NonEqual
+ | Strict
+ | NonStrict
+
+type 'c nFormula = 'c polC * op1
+
+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
+
+val pexpr_times_nformula :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option
+
+val nformula_times_nformula :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option
+
+val nformula_plus_nformula :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1
+ nFormula -> 'a1 nFormula option
+
+val eval_Psatz :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1
+ nFormula option
+
+val check_inconsistent :
+ 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool
+
+val check_normalised_formulas :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool
+
+type op2 =
+ | OpEq
+ | OpNEq
+ | OpLe
+ | OpGe
+ | OpLt
+ | OpGt
+
+type 'c formula = { flhs : 'c pExpr; fop : op2; frhs : 'c pExpr }
+
+val flhs : 'a1 formula -> 'a1 pExpr
+
+val fop : 'a1 formula -> op2
+
+val frhs : 'a1 formula -> 'a1 pExpr
+
+val norm :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
+
+val psub0 :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
+ -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+
+val padd0 :
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol ->
+ 'a1 pol
+
+val xnormalise :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
+ list
+
+val cnf_normalise :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
+ cnf
+
+val xnegate :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
+ list
+
+val cnf_negate :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
+ cnf
+
+val xdenorm : positive -> 'a1 pol -> 'a1 pExpr
+
+val denorm : 'a1 pol -> 'a1 pExpr
+
+val simpl_cone :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
+ 'a1 psatz
+
+type q = { qnum : z; qden : positive }
+
+val qnum : q -> z
+
+val qden : q -> positive
+
+val qeq_bool : q -> q -> bool
+
+val qle_bool : q -> q -> bool
+
+val qplus : q -> q -> q
+
+val qmult : q -> q -> q
+
+val qopp : q -> q
+
+val qminus : q -> q -> q
+
+val qinv : q -> q
+
+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
+
+val find : 'a1 -> 'a1 t -> positive -> 'a1
+
+type zWitness = z psatz
+
+val zWeakChecker : z nFormula list -> z psatz -> bool
+
+val psub1 : z pol -> z pol -> z pol
+
+val padd1 : z pol -> z pol -> z pol
+
+val norm0 : z pExpr -> z pol
+
+val xnormalise0 : z formula -> z nFormula list
+
+val normalise : z formula -> z nFormula cnf
+
+val xnegate0 : z formula -> z nFormula list
+
+val negate : z formula -> z nFormula cnf
+
+val ceiling : z -> z -> z
+
+type zArithProof =
+ | 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 zdiv_pol : z polC -> z -> z polC
+
+val makeCuttingPlane : z polC -> z polC * z
+
+val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option
+
+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 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
+
+val qnormalise : q formula -> q nFormula cnf
+
+val qnegate : q formula -> q nFormula cnf
+
+val qTautoChecker : q formula bFormula -> qWitness list -> bool
+
+type rWitness = z psatz
+
+val rWeakChecker : z nFormula list -> z psatz -> bool
+
+val rnormalise : z formula -> z nFormula cnf
+
+val rnegate : z formula -> z nFormula cnf
+
+val rTautoChecker : z formula bFormula -> rWitness list -> bool
+
diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mllib
new file mode 100644
index 00000000..debc296e
--- /dev/null
+++ b/plugins/micromega/micromega_plugin.mllib
@@ -0,0 +1,9 @@
+Sos_types
+Mutils
+Micromega
+Mfourier
+Certificate
+Persistent_cache
+Coq_micromega
+G_micromega
+Micromega_plugin_mod
diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml
new file mode 100644
index 00000000..ec06fa58
--- /dev/null
+++ b/plugins/micromega/mutils.ml
@@ -0,0 +1,402 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+let debug = false
+
+let finally f rst =
+ try
+ let res = f () in
+ rst () ; res
+ with x ->
+ (try rst ()
+ with _ -> raise x
+ ); raise x
+
+let map_option f x =
+ match x with
+ | None -> None
+ | Some v -> Some (f v)
+
+let from_option = function
+ | None -> failwith "from_option"
+ | Some v -> v
+
+let rec try_any l x =
+ match l with
+ | [] -> None
+ | (f,s)::l -> match f x with
+ | None -> try_any l x
+ | x -> x
+
+let iteri f l =
+ let rec xiter i l =
+ match l with
+ | [] -> ()
+ | 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 rec map3 f l1 l2 l3 =
+ match l1 , l2 ,l3 with
+ | [] , [] , [] -> []
+ | 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
+ | e::l1', [] -> false
+ | e::l1' , e'::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"
+ | h::t -> try f h with Failure _ -> try_find_f t
+ in
+ try_find_f
+
+let rec list_fold_right_elements f l =
+ let rec aux = function
+ | [] -> invalid_arg "list_fold_right_elements"
+ | [x] -> x
+ | x::l -> f x (aux l) in
+ aux l
+
+let interval n m =
+ let rec interval_n (l,m) =
+ if n > m then l else interval_n (m::l,pred m)
+ in
+ interval_n ([],m)
+
+open Num
+open Big_int
+
+let ppcm x y =
+ let g = gcd_big_int x y in
+ let x' = div_big_int x g in
+ 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
+
+let numerator = function
+ | Ratio r -> Ratio.numerator_ratio r
+ | Int i -> Big_int.big_int_of_int i
+ | Big_int i -> i
+
+let rec ppcm_list c l =
+ match l with
+ | [] -> c
+ | e::l -> ppcm_list (ppcm c (denominator e)) l
+
+let rec rec_gcd_list c l =
+ match l with
+ | [] -> c
+ | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l
+
+let rec gcd_list l =
+ let res = rec_gcd_list zero_big_int l in
+ 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)
+ (denominator x))) l
+
+(* Nasty reordering of lists - useful to trim certificate down *)
+let mapi f l =
+ let rec xmapi i l =
+ match l with
+ | [] -> []
+ | 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 *)
+let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l))
+
+let assoc_pos_assoc l =
+ let rec xpos i l =
+ match l with
+ | [] -> []
+ | (x,l) ::rst -> let (l',j) = assoc_pos i l in
+ (x,l')::(xpos j rst) in
+ xpos 0 l
+
+let filter_pos f l =
+ (* Could sort ... take care of duplicates... *)
+ let rec xfilter l =
+ match l with
+ | [] -> []
+ | (x,e)::l ->
+ if List.exists (fun ee -> List.mem ee f) (List.map snd e)
+ then (x,e)::(xfilter l)
+ else xfilter l in
+ xfilter l
+
+let select_pos lpos l =
+ let rec xselect i lpos l =
+ match lpos with
+ | [] -> []
+ | j::rpos ->
+ match l with
+ | [] -> failwith "select_pos"
+ | e::l ->
+ if i = j
+ then e:: (xselect (i+1) rpos l)
+ else xselect (i+1) lpos l in
+ xselect 0 lpos l
+
+
+module CoqToCaml =
+struct
+ open Micromega
+
+ let rec nat = function
+ | O -> 0
+ | S n -> (nat n) + 1
+
+
+ let rec positive p =
+ match p with
+ | XH -> 1
+ | 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
+ | Zpos p -> (positive p)
+ | Zneg p -> - (positive p)
+
+ open Big_int
+
+ let rec positive_big_int p =
+ match p with
+ | XH -> unit_big_int
+ | 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} =
+ Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y)))
+
+end
+
+
+module CamlToCoq =
+struct
+ open Micromega
+
+ let rec nat = function
+ | 0 -> O
+ | n -> S (nat (n-1))
+
+
+ let rec positive n =
+ if n=1 then XH
+ else if n land 1 = 1 then XI (positive (n lsr 1))
+ else XO (positive (n lsr 1))
+
+ let n nt =
+ if nt < 0
+ then assert false
+ else if nt = 0 then N0
+ else Npos (positive nt)
+
+ let rec index n =
+ if n=1 then XH
+ else if n land 1 = 1 then XI (index (n lsr 1))
+ else XO (index (n lsr 1))
+
+
+ let idx n =
+ (*a.k.a path_of_int *)
+ (* returns the list of digits of n in reverse order with
+ initial 1 removed *)
+ let rec digits_of_int n =
+ if n=1 then []
+ else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+ in
+ List.fold_right
+ (fun b c -> (if b then XI c else XO c))
+ (List.rev (digits_of_int n))
+ (XH)
+
+ let z x =
+ match compare x 0 with
+ | 0 -> Z0
+ | 1 -> Zpos (positive x)
+ | _ -> (* this should be -1 *)
+ Zneg (positive (-x))
+
+ open Big_int
+
+ let positive_big_int n =
+ let two = big_int_of_int 2 in
+ let rec _pos n =
+ if eq_big_int n unit_big_int then XH
+ else
+ let (q,m) = quomod_big_int n two in
+ if eq_big_int unit_big_int m
+ then XI (_pos q)
+ else XO (_pos q) in
+ _pos n
+
+ let bigint x =
+ match sign_big_int x with
+ | 0 -> Z0
+ | 1 -> Zpos (positive_big_int x)
+ | _ -> Zneg (positive_big_int (minus_big_int x))
+
+ let q n =
+ {Micromega.qnum = bigint (numerator n) ;
+ Micromega.qden = positive_big_int (denominator n)}
+
+end
+
+module Cmp =
+struct
+
+ let rec compare_lexical l =
+ match l with
+ | [] -> 0 (* Equal *)
+ | f::l ->
+ let cmp = f () in
+ if cmp = 0 then compare_lexical l else cmp
+
+ let rec compare_list cmp l1 l2 =
+ match l1 , l2 with
+ | [] , [] -> 0
+ | [] , _ -> -1
+ | _ , [] -> 1
+ | e1::l1 , e2::l2 ->
+ let c = cmp e1 e2 in
+ if c = 0 then compare_list cmp l1 l2 else c
+
+ 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
+
+ _hash_list l 0
+end
+
+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 TagSet = Set.Make(Tag)
+
+
+let command exe_path args vl =
+ (* creating pipes for stdin, stdout, stderr *)
+ let (stdin_read,stdin_write) = Unix.pipe ()
+ 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
+
+ (* Write the data on the stdin of the created process *)
+ let outch = Unix.out_channel_of_descr stdin_write in
+ output_value outch vl ;
+ flush outch ;
+
+ (* Wait for its completion *)
+ let _pid,status = Unix.waitpid [] pid in
+
+ finally
+ (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)
+ | 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))
+ (fun () ->
+ (* Cleanup *)
+ 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 *)
+(* End: *)
diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml
new file mode 100644
index 00000000..f17e1c35
--- /dev/null
+++ b/plugins/micromega/persistent_cache.ml
@@ -0,0 +1,180 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* *)
+(* A persistent hashtable *)
+(* *)
+(* Frédéric Besson (Inria Rennes) 2009 *)
+(* *)
+(************************************************************************)
+
+
+module type PHashtable =
+ sig
+ type 'a t
+ type key
+
+ val create : int -> string -> 'a t
+ (** [create i f] creates an empty persistent table
+ with initial size i
+ associated with file [f] *)
+
+
+ val open_in : string -> 'a t
+ (** [open_in f] rebuilds a table from the records stored in file [f].
+ As marshaling is not type-safe, it migth segault.
+ *)
+
+ val find : 'a t -> key -> 'a
+ (** find has the specification of Hashtable.find *)
+
+ val add : 'a t -> key -> 'a -> unit
+ (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl].
+ (and writes the binding to the file associated with [tbl].)
+ If [key] is already bound, raises KeyAlreadyBound *)
+
+ 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 *)
+
+ val memo : string -> (key -> 'a) -> (key -> 'a)
+ (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table.
+ Note that the cache will only be loaded when the function is used for the first time *)
+
+ end
+
+open Hashtbl
+
+module PHashtable(Key:HashedType) : PHashtable with type key = Key.t =
+struct
+
+ type key = Key.t
+
+ module Table = Hashtbl.Make(Key)
+
+
+
+ exception InvalidTableFormat
+ exception UnboundTable
+
+
+ type mode = Closed | Open
+
+
+ type 'a t =
+ {
+ outch : out_channel ;
+ mutable status : mode ;
+ htbl : 'a Table.t
+ }
+
+
+let create i f =
+ {
+ outch = open_out_bin f ;
+ status = Open ;
+ htbl = Table.create i
+ }
+
+let finally f rst =
+ try
+ let res = f () in
+ rst () ; res
+ with x ->
+ (try rst ()
+ with _ -> raise x
+ ); raise x
+
+
+let read_key_elem inch =
+ try
+ Some (Marshal.from_channel inch)
+ with
+ | End_of_file -> None
+ | _ -> raise InvalidTableFormat
+
+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 rec xload () =
+ match read_key_elem inch with
+ | None -> ()
+ | Some (key,elem) ->
+ Table.add htbl key elem ;
+ xload () in
+
+ try
+ finally (fun () -> xload () ) (fun () -> close_in inch) ;
+ {
+ outch = begin
+ let flags = [Open_append;Open_binary;Open_creat] in
+ open_out_gen flags 0o666 f
+ end ;
+ 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
+ }
+ end
+
+
+let close t =
+ let {outch = outch ; status = status ; htbl = tbl} = t in
+ match t.status with
+ | Closed -> () (* don't do it twice *)
+ | Open ->
+ close_out outch ;
+ Table.clear tbl ;
+ t.status <- Closed
+
+let add t k e =
+ let {outch = outch ; status = status ; htbl = tbl} = t in
+ if status = Closed
+ then raise UnboundTable
+ else
+ begin
+ Table.add tbl k e ;
+ Marshal.to_channel outch (k,e) [Marshal.No_sharing]
+ end
+
+let find t k =
+ let {outch = outch ; status = status ; htbl = tbl} = t in
+ if status = Closed
+ then raise UnboundTable
+ else
+ let res = Table.find tbl k in
+ res
+
+let memo cache f =
+ let tbl = lazy (open_in cache) in
+ fun x ->
+ let tbl = Lazy.force tbl in
+ try
+ find tbl x
+ with
+ Not_found ->
+ let res = f x in
+ add tbl x res ;
+ res
+
+end
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml
new file mode 100644
index 00000000..3029496b
--- /dev/null
+++ b/plugins/micromega/sos.ml
@@ -0,0 +1,1859 @@
+(* ========================================================================= *)
+(* - This code originates from John Harrison's HOL LIGHT 2.30 *)
+(* (see file LICENSE.sos for license, copyright and disclaimer) *)
+(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *)
+(* independent bits *)
+(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *)
+(* ========================================================================= *)
+
+(* ========================================================================= *)
+(* Nonlinear universal reals procedure using SOS decomposition. *)
+(* ========================================================================= *)
+open Num;;
+open List;;
+open Sos_types;;
+open Sos_lib;;
+
+(*
+prioritize_real();;
+*)
+
+let debugging = ref false;;
+
+exception Sanity;;
+
+exception Unsolvable;;
+
+(* ------------------------------------------------------------------------- *)
+(* Turn a rational into a decimal string with d sig digits. *)
+(* ------------------------------------------------------------------------- *)
+
+let decimalize =
+ let rec normalize y =
+ if abs_num y </ Int 1 // Int 10 then normalize (Int 10 */ y) - 1
+ else if abs_num y >=/ Int 1 then normalize (y // Int 10) + 1
+ else 0 in
+ fun d x ->
+ if x =/ Int 0 then "0.0" else
+ let y = abs_num x in
+ let e = normalize y in
+ let z = pow10(-e) */ y +/ Int 1 in
+ let k = round_num(pow10 d */ z) in
+ (if x </ Int 0 then "-0." else "0.") ^
+ implode(tl(explode(string_of_num k))) ^
+ (if e = 0 then "" else "e"^string_of_int e);;
+
+(* ------------------------------------------------------------------------- *)
+(* Iterations over numbers, and lists indexed by numbers. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec itern k l f a =
+ match l with
+ [] -> a
+ | h::t -> itern (k + 1) t f (f h k a);;
+
+let rec iter (m,n) f a =
+ if n < m then a
+ else iter (m+1,n) f (f m a);;
+
+(* ------------------------------------------------------------------------- *)
+(* The main types. *)
+(* ------------------------------------------------------------------------- *)
+
+type vector = int*(int,num)func;;
+
+type matrix = (int*int)*(int*int,num)func;;
+
+type monomial = (vname,int)func;;
+
+type poly = (monomial,num)func;;
+
+(* ------------------------------------------------------------------------- *)
+(* Assignment avoiding zeros. *)
+(* ------------------------------------------------------------------------- *)
+
+let (|-->) x y a = if y =/ Int 0 then a else (x |-> y) a;;
+
+(* ------------------------------------------------------------------------- *)
+(* This can be generic. *)
+(* ------------------------------------------------------------------------- *)
+
+let element (d,v) i = tryapplyd v i (Int 0);;
+
+let mapa f (d,v) =
+ d,foldl (fun a i c -> (i |--> f(c)) a) undefined v;;
+
+let is_zero (d,v) =
+ match v with
+ Empty -> true
+ | _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Vectors. Conventionally indexed 1..n. *)
+(* ------------------------------------------------------------------------- *)
+
+let vector_0 n = (n,undefined:vector);;
+
+let dim (v:vector) = fst v;;
+
+let vector_const c n =
+ if c =/ Int 0 then vector_0 n
+ else (n,itlist (fun k -> k |-> c) (1--n) undefined :vector);;
+
+let vector_1 = vector_const (Int 1);;
+
+let vector_cmul c (v:vector) =
+ let n = dim v in
+ if c =/ Int 0 then vector_0 n
+ else n,mapf (fun x -> c */ x) (snd v)
+
+let vector_neg (v:vector) = (fst v,mapf minus_num (snd v) :vector);;
+
+let vector_add (v1:vector) (v2:vector) =
+ let m = dim v1 and n = dim v2 in
+ if m <> n then failwith "vector_add: incompatible dimensions" else
+ (n,combine (+/) (fun x -> x =/ Int 0) (snd v1) (snd v2) :vector);;
+
+let vector_sub v1 v2 = vector_add v1 (vector_neg v2);;
+
+let vector_dot (v1:vector) (v2:vector) =
+ let m = dim v1 and n = dim v2 in
+ if m <> n then failwith "vector_add: incompatible dimensions" else
+ foldl (fun a i x -> x +/ a) (Int 0)
+ (combine ( */ ) (fun x -> x =/ Int 0) (snd v1) (snd v2));;
+
+let vector_of_list l =
+ let n = length l in
+ (n,itlist2 (|->) (1--n) l undefined :vector);;
+
+(* ------------------------------------------------------------------------- *)
+(* Matrices; again rows and columns indexed from 1. *)
+(* ------------------------------------------------------------------------- *)
+
+let matrix_0 (m,n) = ((m,n),undefined:matrix);;
+
+let dimensions (m:matrix) = fst m;;
+
+let matrix_const c (m,n as mn) =
+ if m <> n then failwith "matrix_const: needs to be square"
+ else if c =/ Int 0 then matrix_0 mn
+ else (mn,itlist (fun k -> (k,k) |-> c) (1--n) undefined :matrix);;
+
+let matrix_1 = matrix_const (Int 1);;
+
+let matrix_cmul c (m:matrix) =
+ let (i,j) = dimensions m in
+ if c =/ Int 0 then matrix_0 (i,j)
+ else (i,j),mapf (fun x -> c */ x) (snd m);;
+
+let matrix_neg (m:matrix) = (dimensions m,mapf minus_num (snd m) :matrix);;
+
+let matrix_add (m1:matrix) (m2:matrix) =
+ let d1 = dimensions m1 and d2 = dimensions m2 in
+ if d1 <> d2 then failwith "matrix_add: incompatible dimensions"
+ else (d1,combine (+/) (fun x -> x =/ Int 0) (snd m1) (snd m2) :matrix);;
+
+let matrix_sub m1 m2 = matrix_add m1 (matrix_neg m2);;
+
+let row k (m:matrix) =
+ let i,j = dimensions m in
+ (j,
+ foldl (fun a (i,j) c -> if i = k then (j |-> c) a else a) undefined (snd m)
+ : vector);;
+
+let column k (m:matrix) =
+ let i,j = dimensions m in
+ (i,
+ foldl (fun a (i,j) c -> if j = k then (i |-> c) a else a) undefined (snd m)
+ : vector);;
+
+let transp (m:matrix) =
+ let i,j = dimensions m in
+ ((j,i),foldl (fun a (i,j) c -> ((j,i) |-> c) a) undefined (snd m) :matrix);;
+
+let diagonal (v:vector) =
+ let n = dim v in
+ ((n,n),foldl (fun a i c -> ((i,i) |-> c) a) undefined (snd v) : matrix);;
+
+let matrix_of_list l =
+ let m = length l in
+ if m = 0 then matrix_0 (0,0) else
+ let n = length (hd l) in
+ (m,n),itern 1 l (fun v i -> itern 1 v (fun c j -> (i,j) |-> c)) undefined;;
+
+(* ------------------------------------------------------------------------- *)
+(* Monomials. *)
+(* ------------------------------------------------------------------------- *)
+
+let monomial_eval assig (m:monomial) =
+ foldl (fun a x k -> a */ power_num (apply assig x) (Int k))
+ (Int 1) m;;
+
+let monomial_1 = (undefined:monomial);;
+
+let monomial_var x = (x |=> 1 :monomial);;
+
+let (monomial_mul:monomial->monomial->monomial) =
+ combine (+) (fun x -> false);;
+
+let monomial_pow (m:monomial) k =
+ if k = 0 then monomial_1
+ else mapf (fun x -> k * x) m;;
+
+let monomial_divides (m1:monomial) (m2:monomial) =
+ foldl (fun a x k -> tryapplyd m2 x 0 >= k & a) true m1;;
+
+let monomial_div (m1:monomial) (m2:monomial) =
+ let m = combine (+) (fun x -> x = 0) m1 (mapf (fun x -> -x) m2) in
+ if foldl (fun a x k -> k >= 0 & a) true m then m
+ else failwith "monomial_div: non-divisible";;
+
+let monomial_degree x (m:monomial) = tryapplyd m x 0;;
+
+let monomial_lcm (m1:monomial) (m2:monomial) =
+ (itlist (fun x -> x |-> max (monomial_degree x m1) (monomial_degree x m2))
+ (union (dom m1) (dom m2)) undefined :monomial);;
+
+let monomial_multidegree (m:monomial) = foldl (fun a x k -> k + a) 0 m;;
+
+let monomial_variables m = dom m;;
+
+(* ------------------------------------------------------------------------- *)
+(* Polynomials. *)
+(* ------------------------------------------------------------------------- *)
+
+let eval assig (p:poly) =
+ foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;;
+
+let poly_0 = (undefined:poly);;
+
+let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 & a) true p;;
+
+let poly_var x = ((monomial_var x) |=> Int 1 :poly);;
+
+let poly_const c =
+ if c =/ Int 0 then poly_0 else (monomial_1 |=> c);;
+
+let poly_cmul c (p:poly) =
+ if c =/ Int 0 then poly_0
+ else mapf (fun x -> c */ x) p;;
+
+let poly_neg (p:poly) = (mapf minus_num p :poly);;
+
+let poly_add (p1:poly) (p2:poly) =
+ (combine (+/) (fun x -> x =/ Int 0) p1 p2 :poly);;
+
+let poly_sub p1 p2 = poly_add p1 (poly_neg p2);;
+
+let poly_cmmul (c,m) (p:poly) =
+ if c =/ Int 0 then poly_0
+ else if m = monomial_1 then mapf (fun d -> c */ d) p
+ else foldl (fun a m' d -> (monomial_mul m m' |-> c */ d) a) poly_0 p;;
+
+let poly_mul (p1:poly) (p2:poly) =
+ foldl (fun a m c -> poly_add (poly_cmmul (c,m) p2) a) poly_0 p1;;
+
+let poly_div (p1:poly) (p2:poly) =
+ if not(poly_isconst p2) then failwith "poly_div: non-constant" else
+ let c = eval undefined p2 in
+ if c =/ Int 0 then failwith "poly_div: division by zero"
+ else poly_cmul (Int 1 // c) p1;;
+
+let poly_square p = poly_mul p p;;
+
+let rec poly_pow p k =
+ if k = 0 then poly_const (Int 1)
+ else if k = 1 then p
+ else let q = poly_square(poly_pow p (k / 2)) in
+ if k mod 2 = 1 then poly_mul p q else q;;
+
+let poly_exp p1 p2 =
+ if not(poly_isconst p2) then failwith "poly_exp: not a constant" else
+ poly_pow p1 (Num.int_of_num (eval undefined p2));;
+
+let degree x (p:poly) = foldl (fun a m c -> max (monomial_degree x m) a) 0 p;;
+
+let multidegree (p:poly) =
+ foldl (fun a m c -> max (monomial_multidegree m) a) 0 p;;
+
+let poly_variables (p:poly) =
+ foldr (fun m c -> union (monomial_variables m)) p [];;
+
+(* ------------------------------------------------------------------------- *)
+(* Order monomials for human presentation. *)
+(* ------------------------------------------------------------------------- *)
+
+let humanorder_varpow (x1,k1) (x2,k2) = x1 < x2 or x1 = x2 & k1 > k2;;
+
+let humanorder_monomial =
+ let rec ord l1 l2 = match (l1,l2) with
+ _,[] -> true
+ | [],_ -> false
+ | h1::t1,h2::t2 -> humanorder_varpow h1 h2 or h1 = h2 & ord t1 t2 in
+ fun m1 m2 -> m1 = m2 or
+ ord (sort humanorder_varpow (graph m1))
+ (sort humanorder_varpow (graph m2));;
+
+(* ------------------------------------------------------------------------- *)
+(* Conversions to strings. *)
+(* ------------------------------------------------------------------------- *)
+
+let string_of_vector min_size max_size (v:vector) =
+ let n_raw = dim v in
+ if n_raw = 0 then "[]" else
+ let n = max min_size (min n_raw max_size) in
+ let xs = map ((o) string_of_num (element v)) (1--n) in
+ "[" ^ end_itlist (fun s t -> s ^ ", " ^ t) xs ^
+ (if n_raw > max_size then ", ...]" else "]");;
+
+let string_of_matrix max_size (m:matrix) =
+ let i_raw,j_raw = dimensions m in
+ let i = min max_size i_raw and j = min max_size j_raw in
+ let rstr = map (fun k -> string_of_vector j j (row k m)) (1--i) in
+ "["^end_itlist(fun s t -> s^";\n "^t) rstr ^
+ (if j > max_size then "\n ...]" else "]");;
+
+let string_of_vname (v:vname): string = (v: string);;
+
+let rec string_of_term t =
+ match t with
+ Opp t1 -> "(- " ^ string_of_term t1 ^ ")"
+| Add (t1, t2) ->
+ "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")"
+| Sub (t1, t2) ->
+ "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")"
+| Mul (t1, t2) ->
+ "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")"
+| Inv t1 -> "(/ " ^ string_of_term t1 ^ ")"
+| Div (t1, t2) ->
+ "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")"
+| Pow (t1, n1) ->
+ "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")"
+| Zero -> "0"
+| Var v -> "x" ^ (string_of_vname v)
+| Const x -> string_of_num x;;
+
+
+let string_of_varpow x k =
+ if k = 1 then string_of_vname x else string_of_vname x^"^"^string_of_int k;;
+
+let string_of_monomial m =
+ if m = monomial_1 then "1" else
+ let vps = List.fold_right (fun (x,k) a -> string_of_varpow x k :: a)
+ (sort humanorder_varpow (graph m)) [] in
+ end_itlist (fun s t -> s^"*"^t) vps;;
+
+let string_of_cmonomial (c,m) =
+ if m = monomial_1 then string_of_num c
+ else if c =/ Int 1 then string_of_monomial m
+ else string_of_num c ^ "*" ^ string_of_monomial m;;
+
+let string_of_poly (p:poly) =
+ if p = poly_0 then "<<0>>" else
+ let cms = sort (fun (m1,_) (m2,_) -> humanorder_monomial m1 m2) (graph p) in
+ let s =
+ List.fold_left (fun a (m,c) ->
+ if c </ Int 0 then a ^ " - " ^ string_of_cmonomial(minus_num c,m)
+ else a ^ " + " ^ string_of_cmonomial(c,m))
+ "" cms in
+ let s1 = String.sub s 0 3
+ and s2 = String.sub s 3 (String.length s - 3) in
+ "<<" ^(if s1 = " + " then s2 else "-"^s2)^">>";;
+
+(* ------------------------------------------------------------------------- *)
+(* Printers. *)
+(* ------------------------------------------------------------------------- *)
+
+let print_vector v = Format.print_string(string_of_vector 0 20 v);;
+
+let print_matrix m = Format.print_string(string_of_matrix 20 m);;
+
+let print_monomial m = Format.print_string(string_of_monomial m);;
+
+let print_poly m = Format.print_string(string_of_poly m);;
+
+(*
+#install_printer print_vector;;
+#install_printer print_matrix;;
+#install_printer print_monomial;;
+#install_printer print_poly;;
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* Conversion from term. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec poly_of_term t = match t with
+ Zero -> poly_0
+| Const n -> poly_const n
+| Var x -> poly_var x
+| Opp t1 -> poly_neg (poly_of_term t1)
+| Inv t1 ->
+ let p = poly_of_term t1 in
+ if poly_isconst p then poly_const(Int 1 // eval undefined p)
+ else failwith "poly_of_term: inverse of non-constant polyomial"
+| Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r)
+| Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r)
+| Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r)
+| Div (l, r) ->
+ let p = poly_of_term l and q = poly_of_term r in
+ if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p
+ else failwith "poly_of_term: division by non-constant polynomial"
+| Pow (t, n) ->
+ poly_pow (poly_of_term t) n;;
+
+(* ------------------------------------------------------------------------- *)
+(* String of vector (just a list of space-separated numbers). *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_vector (v:vector) =
+ let n = dim v in
+ let strs = map (o (decimalize 20) (element v)) (1--n) in
+ end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
+
+(* ------------------------------------------------------------------------- *)
+(* String for block diagonal matrix numbered k. *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_blockdiagonal k m =
+ let pfx = string_of_int k ^" " in
+ let ents =
+ foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
+ let entss = sort (increasing fst) ents in
+ itlist (fun ((b,i,j),c) a ->
+ pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
+
+(* ------------------------------------------------------------------------- *)
+(* String for a matrix numbered k, in SDPA sparse format. *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_matrix k (m:matrix) =
+ let pfx = string_of_int k ^ " 1 " in
+ let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a)
+ (snd m) [] in
+ let mss = sort (increasing fst) ms in
+ itlist (fun ((i,j),c) a ->
+ pfx ^ string_of_int i ^ " " ^ string_of_int j ^
+ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
+
+(* ------------------------------------------------------------------------- *)
+(* String in SDPA sparse format for standard SDP problem: *)
+(* *)
+(* X = v_1 * [M_1] + ... + v_m * [M_m] - [M_0] must be PSD *)
+(* Minimize obj_1 * v_1 + ... obj_m * v_m *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_problem comment obj mats =
+ let m = length mats - 1
+ and n,_ = dimensions (hd mats) in
+ "\"" ^ comment ^ "\"\n" ^
+ string_of_int m ^ "\n" ^
+ "1\n" ^
+ string_of_int n ^ "\n" ^
+ sdpa_of_vector obj ^
+ itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
+ (1--length mats) mats "";;
+
+(* ------------------------------------------------------------------------- *)
+(* More parser basics. *)
+(* ------------------------------------------------------------------------- *)
+
+let word s =
+ end_itlist (fun p1 p2 -> (p1 ++ p2) >> (fun (s,t) -> s^t))
+ (map a (explode s));;
+let token s =
+ many (some isspace) ++ word s ++ many (some isspace)
+ >> (fun ((_,t),_) -> t);;
+
+let decimal =
+ let numeral = some isnum in
+ let decimalint = atleast 1 numeral >> ((o) Num.num_of_string implode) in
+ let decimalfrac = atleast 1 numeral
+ >> (fun s -> Num.num_of_string(implode s) // pow10 (length s)) in
+ let decimalsig =
+ decimalint ++ possibly (a "." ++ decimalfrac >> snd)
+ >> (function (h,[x]) -> h +/ x | (h,_) -> h) in
+ let signed prs =
+ a "-" ++ prs >> ((o) minus_num snd)
+ || a "+" ++ prs >> snd
+ || prs in
+ let exponent = (a "e" || a "E") ++ signed decimalint >> snd in
+ signed decimalsig ++ possibly exponent
+ >> (function (h,[x]) -> h */ power_num (Int 10) x | (h,_) -> h);;
+
+let mkparser p s =
+ let x,rst = p(explode s) in
+ if rst = [] then x else failwith "mkparser: unparsed input";;
+
+let parse_decimal = mkparser decimal;;
+
+(* ------------------------------------------------------------------------- *)
+(* Parse back a vector. *)
+(* ------------------------------------------------------------------------- *)
+
+let parse_sdpaoutput,parse_csdpoutput =
+ let vector =
+ token "{" ++ listof decimal (token ",") "decimal" ++ token "}"
+ >> (fun ((_,v),_) -> vector_of_list v) in
+ let rec skipupto dscr prs inp =
+ (dscr ++ prs >> snd
+ || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
+ let ignore inp = (),[] in
+ let sdpaoutput =
+ skipupto (word "xVec" ++ token "=")
+ (vector ++ ignore >> fst) in
+ let csdpoutput =
+ (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++
+ (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in
+ mkparser sdpaoutput,mkparser csdpoutput;;
+
+(* ------------------------------------------------------------------------- *)
+(* Also parse the SDPA output to test success (CSDP yields a return code). *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_run_succeeded =
+ let rec skipupto dscr prs inp =
+ (dscr ++ prs >> snd
+ || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
+ let prs = skipupto (word "phase.value" ++ token "=")
+ (possibly (a "p") ++ possibly (a "d") ++
+ (word "OPT" || word "FEAS")) in
+ fun s -> try ignore (prs (explode s)); true with Noparse -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* The default parameters. Unfortunately this goes to a fixed file. *)
+(* ------------------------------------------------------------------------- *)
+
+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;
+";;
+
+(* ------------------------------------------------------------------------- *)
+(* These were suggested by Makoto Yamashita for problems where we are *)
+(* right at the edge of the semidefinite cone, as sometimes happens. *)
+(* ------------------------------------------------------------------------- *)
+
+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;
+";;
+
+let sdpa_params = sdpa_alt_parameters;;
+
+(* ------------------------------------------------------------------------- *)
+(* CSDP parameters; so far I'm sticking with the defaults. *)
+(* ------------------------------------------------------------------------- *)
+
+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
+";;
+
+let csdp_params = csdp_default_parameters;;
+
+(* ------------------------------------------------------------------------- *)
+(* Now call CSDP on a problem and parse back the output. *)
+(* ------------------------------------------------------------------------- *)
+
+let run_csdp dbg obj mats =
+ let input_file = Filename.temp_file "sos" ".dat-s" in
+ let output_file =
+ String.sub input_file 0 (String.length input_file - 6) ^ ".out"
+ and params_file = Filename.concat (!temp_path) "param.csdp" in
+ file_of_string input_file (sdpa_of_problem "" obj mats);
+ file_of_string params_file csdp_params;
+ let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^
+ " " ^ output_file ^
+ (if dbg then "" else "> /dev/null")) in
+ let op = string_of_file output_file in
+ let res = parse_csdpoutput op in
+ ((if dbg then ()
+ else (Sys.remove input_file; Sys.remove output_file));
+ rv,res);;
+
+let csdp obj mats =
+ let rv,res = run_csdp (!debugging) obj mats in
+ (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible"
+ else if rv = 3 then ()
+ (* Format.print_string "csdp warning: Reduced accuracy";
+ Format.print_newline() *)
+ else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
+ else ());
+ res;;
+
+(* ------------------------------------------------------------------------- *)
+(* Try some apparently sensible scaling first. Note that this is purely to *)
+(* get a cleaner translation to floating-point, and doesn't affect any of *)
+(* the results, in principle. In practice it seems a lot better when there *)
+(* are extreme numbers in the original problem. *)
+(* ------------------------------------------------------------------------- *)
+
+let scale_then =
+ let common_denominator amat acc =
+ foldl (fun a m c -> lcm_num (denominator c) a) acc amat
+ and maximal_element amat acc =
+ foldl (fun maxa m c -> max_num maxa (abs_num c)) acc amat in
+ fun solver obj mats ->
+ let cd1 = itlist common_denominator mats (Int 1)
+ and cd2 = common_denominator (snd obj) (Int 1) in
+ let mats' = map (mapf (fun x -> cd1 */ x)) mats
+ and obj' = vector_cmul cd2 obj in
+ let max1 = itlist maximal_element mats' (Int 0)
+ and max2 = maximal_element (snd obj') (Int 0) in
+ let scal1 = pow2 (20-int_of_float(log(float_of_num max1) /. log 2.0))
+ and scal2 = pow2 (20-int_of_float(log(float_of_num max2) /. log 2.0)) in
+ let mats'' = map (mapf (fun x -> x */ scal1)) mats'
+ and obj'' = vector_cmul scal2 obj' in
+ solver obj'' mats'';;
+
+(* ------------------------------------------------------------------------- *)
+(* Round a vector to "nice" rationals. *)
+(* ------------------------------------------------------------------------- *)
+
+let nice_rational n x = round_num (n */ x) // n;;
+
+let nice_vector n = mapa (nice_rational n);;
+
+(* ------------------------------------------------------------------------- *)
+(* Reduce linear program to SDP (diagonal matrices) and test with CSDP. This *)
+(* one tests A [-1;x1;..;xn] >= 0 (i.e. left column is negated constants). *)
+(* ------------------------------------------------------------------------- *)
+
+let linear_program_basic a =
+ let m,n = dimensions a in
+ let mats = map (fun j -> diagonal (column j a)) (1--n)
+ and obj = vector_const (Int 1) m in
+ let rv,res = run_csdp false obj mats in
+ if rv = 1 or rv = 2 then false
+ else if rv = 0 then true
+ else failwith "linear_program: An error occurred in the SDP solver";;
+
+(* ------------------------------------------------------------------------- *)
+(* Alternative interface testing A x >= b for matrix A, vector b. *)
+(* ------------------------------------------------------------------------- *)
+
+let linear_program a b =
+ let m,n = dimensions a in
+ if dim b <> m then failwith "linear_program: incompatible dimensions" else
+ let mats = diagonal b :: map (fun j -> diagonal (column j a)) (1--n)
+ and obj = vector_const (Int 1) m in
+ let rv,res = run_csdp false obj mats in
+ if rv = 1 or rv = 2 then false
+ else if rv = 0 then true
+ else failwith "linear_program: An error occurred in the SDP solver";;
+
+(* ------------------------------------------------------------------------- *)
+(* Test whether a point is in the convex hull of others. Rather than use *)
+(* computational geometry, express as linear inequalities and call CSDP. *)
+(* This is a bit lazy of me, but it's easy and not such a bottleneck so far. *)
+(* ------------------------------------------------------------------------- *)
+
+let in_convex_hull pts pt =
+ let pts1 = (1::pt) :: map (fun x -> 1::x) pts in
+ let pts2 = map (fun p -> map (fun x -> -x) p @ p) pts1 in
+ let n = length pts + 1
+ and v = 2 * (length pt + 1) in
+ let m = v + n - 1 in
+ let mat =
+ (m,n),
+ itern 1 pts2 (fun pts j -> itern 1 pts (fun x i -> (i,j) |-> Int x))
+ (iter (1,n) (fun i -> (v + i,i+1) |-> Int 1) undefined) in
+ linear_program_basic mat;;
+
+(* ------------------------------------------------------------------------- *)
+(* Filter down a set of points to a minimal set with the same convex hull. *)
+(* ------------------------------------------------------------------------- *)
+
+let minimal_convex_hull =
+ let augment1 = function
+ | [] -> assert false
+ | (m::ms) -> if in_convex_hull ms m then ms else ms@[m] in
+ let augment m ms = funpow 3 augment1 (m::ms) in
+ fun mons ->
+ let mons' = itlist augment (tl mons) [hd mons] in
+ funpow (length mons') augment1 mons';;
+
+(* ------------------------------------------------------------------------- *)
+(* Stuff for "equations" (generic A->num functions). *)
+(* ------------------------------------------------------------------------- *)
+
+let equation_cmul c eq =
+ if c =/ Int 0 then Empty else mapf (fun d -> c */ d) eq;;
+
+let equation_add eq1 eq2 = combine (+/) (fun x -> x =/ Int 0) eq1 eq2;;
+
+let equation_eval assig eq =
+ let value v = apply assig v in
+ foldl (fun a v c -> a +/ value(v) */ c) (Int 0) eq;;
+
+(* ------------------------------------------------------------------------- *)
+(* Eliminate among linear equations: return unconstrained variables and *)
+(* assignments for the others in terms of them. We give one pseudo-variable *)
+(* "one" that's used for a constant term. *)
+(* ------------------------------------------------------------------------- *)
+
+let failstore = ref [];;
+
+let eliminate_equations =
+ let rec extract_first p l =
+ match l with
+ [] -> failwith "extract_first"
+ | h::t -> if p(h) then h,t else
+ let k,s = extract_first p t in
+ k,h::s in
+ let rec eliminate vars dun eqs =
+ match vars with
+ [] -> if forall is_undefined eqs then dun
+ else (failstore := [vars,dun,eqs]; raise Unsolvable)
+ | v::vs ->
+ try let eq,oeqs = extract_first (fun e -> defined e v) eqs in
+ let a = apply eq v in
+ let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in
+ let elim e =
+ let b = tryapplyd e v (Int 0) in
+ if b =/ Int 0 then e else
+ equation_add e (equation_cmul (minus_num b // a) eq) in
+ eliminate vs ((v |-> eq') (mapf elim dun)) (map elim oeqs)
+ with Failure _ -> eliminate vs dun eqs in
+ fun one vars eqs ->
+ let assig = eliminate vars undefined eqs in
+ let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
+ setify vs,assig;;
+
+(* ------------------------------------------------------------------------- *)
+(* Eliminate all variables, in an essentially arbitrary order. *)
+(* ------------------------------------------------------------------------- *)
+
+let eliminate_all_equations one =
+ let choose_variable eq =
+ let (v,_) = choose eq in
+ if v = one then
+ let eq' = undefine v eq in
+ if is_undefined eq' then failwith "choose_variable" else
+ let (w,_) = choose eq' in w
+ else v in
+ let rec eliminate dun eqs =
+ match eqs with
+ [] -> dun
+ | eq::oeqs ->
+ if is_undefined eq then eliminate dun oeqs else
+ let v = choose_variable eq in
+ let a = apply eq v in
+ let eq' = equation_cmul (Int(-1) // a) (undefine v eq) in
+ let elim e =
+ let b = tryapplyd e v (Int 0) in
+ if b =/ Int 0 then e else
+ equation_add e (equation_cmul (minus_num b // a) eq) in
+ eliminate ((v |-> eq') (mapf elim dun)) (map elim oeqs) in
+ fun eqs ->
+ let assig = eliminate undefined eqs in
+ let vs = foldl (fun a x f -> subtract (dom f) [one] @ a) [] assig in
+ setify vs,assig;;
+
+(* ------------------------------------------------------------------------- *)
+(* Solve equations by assigning arbitrary numbers. *)
+(* ------------------------------------------------------------------------- *)
+
+let solve_equations one eqs =
+ let vars,assigs = eliminate_all_equations one eqs in
+ let vfn = itlist (fun v -> (v |-> Int 0)) vars (one |=> Int(-1)) in
+ let ass =
+ combine (+/) (fun c -> false) (mapf (equation_eval vfn) assigs) vfn in
+ if forall (fun e -> equation_eval ass e =/ Int 0) eqs
+ then undefine one ass else raise Sanity;;
+
+(* ------------------------------------------------------------------------- *)
+(* Hence produce the "relevant" monomials: those whose squares lie in the *)
+(* Newton polytope of the monomials in the input. (This is enough according *)
+(* to Reznik: "Extremal PSD forms with few terms", Duke Math. Journal, *)
+(* vol 45, pp. 363--374, 1978. *)
+(* *)
+(* These are ordered in sort of decreasing degree. In particular the *)
+(* constant monomial is last; this gives an order in diagonalization of the *)
+(* quadratic form that will tend to display constants. *)
+(* ------------------------------------------------------------------------- *)
+
+let newton_polytope pol =
+ let vars = poly_variables pol in
+ let mons = map (fun m -> map (fun x -> monomial_degree x m) vars) (dom pol)
+ and ds = map (fun x -> (degree x pol + 1) / 2) vars in
+ let all = itlist (fun n -> allpairs (fun h t -> h::t) (0--n)) ds [[]]
+ and mons' = minimal_convex_hull mons in
+ let all' =
+ filter (fun m -> in_convex_hull mons' (map (fun x -> 2 * x) m)) all in
+ map (fun m -> itlist2 (fun v i a -> if i = 0 then a else (v |-> i) a)
+ vars m monomial_1) (rev all');;
+
+(* ------------------------------------------------------------------------- *)
+(* Diagonalize (Cholesky/LDU) the matrix corresponding to a quadratic form. *)
+(* ------------------------------------------------------------------------- *)
+
+let diag m =
+ let nn = dimensions m in
+ let n = fst nn in
+ if snd nn <> n then failwith "diagonalize: non-square matrix" else
+ let rec diagonalize i m =
+ if is_zero m then [] else
+ let a11 = element m (i,i) in
+ if a11 </ Int 0 then failwith "diagonalize: not PSD"
+ else if a11 =/ Int 0 then
+ if is_zero(row i m) then diagonalize (i + 1) m
+ else failwith "diagonalize: not PSD"
+ else
+ let v = row i m in
+ let v' = mapa (fun a1k -> a1k // a11) v in
+ let m' =
+ (n,n),
+ iter (i+1,n) (fun j ->
+ iter (i+1,n) (fun k ->
+ ((j,k) |--> (element m (j,k) -/ element v j */ element v' k))))
+ undefined in
+ (a11,v')::diagonalize (i + 1) m' in
+ diagonalize 1 m;;
+
+(* ------------------------------------------------------------------------- *)
+(* Adjust a diagonalization to collect rationals at the start. *)
+(* ------------------------------------------------------------------------- *)
+
+let deration d =
+ if d = [] then Int 0,d else
+ let adj(c,l) =
+ let a = foldl (fun a i c -> lcm_num a (denominator c)) (Int 1) (snd l) //
+ foldl (fun a i c -> gcd_num a (numerator c)) (Int 0) (snd l) in
+ (c // (a */ a)),mapa (fun x -> a */ x) l in
+ let d' = map adj d in
+ let a = itlist ((o) lcm_num ( (o) denominator fst)) d' (Int 1) //
+ itlist ((o) gcd_num ( (o) numerator fst)) d' (Int 0) in
+ (Int 1 // a),map (fun (c,l) -> (a */ c,l)) d';;
+
+(* ------------------------------------------------------------------------- *)
+(* Enumeration of monomials with given multidegree bound. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec enumerate_monomials d vars =
+ if d < 0 then []
+ else if d = 0 then [undefined]
+ else if vars = [] then [monomial_1] else
+ let alts =
+ map (fun k -> let oths = enumerate_monomials (d - k) (tl vars) in
+ map (fun ks -> if k = 0 then ks else (hd vars |-> k) ks) oths)
+ (0--d) in
+ end_itlist (@) alts;;
+
+(* ------------------------------------------------------------------------- *)
+(* Enumerate products of distinct input polys with degree <= d. *)
+(* We ignore any constant input polynomials. *)
+(* Give the output polynomial and a record of how it was derived. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec enumerate_products d pols =
+ if d = 0 then [poly_const num_1,Rational_lt num_1] else if d < 0 then [] else
+ match pols with
+ [] -> [poly_const num_1,Rational_lt num_1]
+ | (p,b)::ps -> let e = multidegree p in
+ if e = 0 then enumerate_products d ps else
+ enumerate_products d ps @
+ map (fun (q,c) -> poly_mul p q,Product(b,c))
+ (enumerate_products (d - e) ps);;
+
+(* ------------------------------------------------------------------------- *)
+(* Multiply equation-parametrized poly by regular poly and add accumulator. *)
+(* ------------------------------------------------------------------------- *)
+
+let epoly_pmul p q acc =
+ foldl (fun a m1 c ->
+ foldl (fun b m2 e ->
+ let m = monomial_mul m1 m2 in
+ let es = tryapplyd b m undefined in
+ (m |-> equation_add (equation_cmul c e) es) b)
+ a q) acc p;;
+
+(* ------------------------------------------------------------------------- *)
+(* Usual operations on equation-parametrized poly. *)
+(* ------------------------------------------------------------------------- *)
+
+let epoly_cmul c l =
+ if c =/ Int 0 then undefined else mapf (equation_cmul c) l;;
+
+let epoly_neg = epoly_cmul (Int(-1));;
+
+let epoly_add = combine equation_add is_undefined;;
+
+let epoly_sub p q = epoly_add p (epoly_neg q);;
+
+(* ------------------------------------------------------------------------- *)
+(* Convert regular polynomial. Note that we treat (0,0,0) as -1. *)
+(* ------------------------------------------------------------------------- *)
+
+let epoly_of_poly p =
+ foldl (fun a m c -> (m |-> ((0,0,0) |=> minus_num c)) a) undefined p;;
+
+(* ------------------------------------------------------------------------- *)
+(* String for block diagonal matrix numbered k. *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_blockdiagonal k m =
+ let pfx = string_of_int k ^" " in
+ let ents =
+ foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
+ let entss = sort (increasing fst) ents in
+ itlist (fun ((b,i,j),c) a ->
+ pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
+
+(* ------------------------------------------------------------------------- *)
+(* SDPA for problem using block diagonal (i.e. multiple SDPs) *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_blockproblem comment nblocks blocksizes obj mats =
+ let m = length mats - 1 in
+ "\"" ^ comment ^ "\"\n" ^
+ string_of_int m ^ "\n" ^
+ string_of_int nblocks ^ "\n" ^
+ (end_itlist (fun s t -> s^" "^t) (map string_of_int blocksizes)) ^
+ "\n" ^
+ sdpa_of_vector obj ^
+ itlist2 (fun k m a -> sdpa_of_blockdiagonal (k - 1) m ^ a)
+ (1--length mats) mats "";;
+
+(* ------------------------------------------------------------------------- *)
+(* Hence run CSDP on a problem in block diagonal form. *)
+(* ------------------------------------------------------------------------- *)
+
+let run_csdp dbg nblocks blocksizes obj mats =
+ let input_file = Filename.temp_file "sos" ".dat-s" in
+ let output_file =
+ String.sub input_file 0 (String.length input_file - 6) ^ ".out"
+ and params_file = Filename.concat (!temp_path) "param.csdp" in
+ file_of_string input_file
+ (sdpa_of_blockproblem "" nblocks blocksizes obj mats);
+ file_of_string params_file csdp_params;
+ let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^
+ " " ^ output_file ^
+ (if dbg then "" else "> /dev/null")) in
+ let op = string_of_file output_file in
+ let res = parse_csdpoutput op in
+ ((if dbg then ()
+ else (Sys.remove input_file; Sys.remove output_file));
+ rv,res);;
+
+let csdp nblocks blocksizes obj mats =
+ let rv,res = run_csdp (!debugging) nblocks blocksizes obj mats in
+ (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible"
+ else if rv = 3 then ()
+ (*Format.print_string "csdp warning: Reduced accuracy";
+ Format.print_newline() *)
+ else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
+ else ());
+ res;;
+
+(* ------------------------------------------------------------------------- *)
+(* 3D versions of matrix operations to consider blocks separately. *)
+(* ------------------------------------------------------------------------- *)
+
+let bmatrix_add = combine (+/) (fun x -> x =/ Int 0);;
+
+let bmatrix_cmul c bm =
+ if c =/ Int 0 then undefined
+ else mapf (fun x -> c */ x) bm;;
+
+let bmatrix_neg = bmatrix_cmul (Int(-1));;
+
+let bmatrix_sub m1 m2 = bmatrix_add m1 (bmatrix_neg m2);;
+
+(* ------------------------------------------------------------------------- *)
+(* Smash a block matrix into components. *)
+(* ------------------------------------------------------------------------- *)
+
+let blocks blocksizes bm =
+ map (fun (bs,b0) ->
+ let m = foldl
+ (fun a (b,i,j) c -> if b = b0 then ((i,j) |-> c) a else a)
+ undefined bm in
+ (((bs,bs),m):matrix))
+ (zip blocksizes (1--length blocksizes));;
+
+(* ------------------------------------------------------------------------- *)
+(* Positiv- and Nullstellensatz. Flag "linf" forces a linear representation. *)
+(* ------------------------------------------------------------------------- *)
+
+let real_positivnullstellensatz_general linf d eqs leqs pol =
+ let vars = itlist ((o) union poly_variables) (pol::eqs @ map fst leqs) [] in
+ let monoid =
+ if linf then
+ (poly_const num_1,Rational_lt num_1)::
+ (filter (fun (p,c) -> multidegree p <= d) leqs)
+ else enumerate_products d leqs in
+ let nblocks = length monoid in
+ let mk_idmultiplier k p =
+ let e = d - multidegree p in
+ let mons = enumerate_monomials e vars in
+ let nons = zip mons (1--length mons) in
+ mons,
+ itlist (fun (m,n) -> (m |-> ((-k,-n,n) |=> Int 1))) nons undefined in
+ let mk_sqmultiplier k (p,c) =
+ let e = (d - multidegree p) / 2 in
+ let mons = enumerate_monomials e vars in
+ let nons = zip mons (1--length mons) in
+ mons,
+ itlist (fun (m1,n1) ->
+ itlist (fun (m2,n2) a ->
+ let m = monomial_mul m1 m2 in
+ if n1 > n2 then a else
+ let c = if n1 = n2 then Int 1 else Int 2 in
+ let e = tryapplyd a m undefined in
+ (m |-> equation_add ((k,n1,n2) |=> c) e) a)
+ nons)
+ nons undefined in
+ let sqmonlist,sqs = unzip(map2 mk_sqmultiplier (1--length monoid) monoid)
+ and idmonlist,ids = unzip(map2 mk_idmultiplier (1--length eqs) eqs) in
+ let blocksizes = map length sqmonlist in
+ let bigsum =
+ itlist2 (fun p q a -> epoly_pmul p q a) eqs ids
+ (itlist2 (fun (p,c) s a -> epoly_pmul p s a) monoid sqs
+ (epoly_of_poly(poly_neg pol))) in
+ let eqns = foldl (fun a m e -> e::a) [] bigsum in
+ let pvs,assig = eliminate_all_equations (0,0,0) eqns in
+ let qvars = (0,0,0)::pvs in
+ let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
+ let mk_matrix v =
+ foldl (fun m (b,i,j) ass -> if b < 0 then m else
+ let c = tryapplyd ass v (Int 0) in
+ if c =/ Int 0 then m else
+ ((b,j,i) |-> c) (((b,i,j) |-> c) m))
+ undefined allassig in
+ let diagents = foldl
+ (fun a (b,i,j) e -> if b > 0 & i = j then equation_add e a else a)
+ undefined allassig in
+ let mats = map mk_matrix qvars
+ and obj = length pvs,
+ itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
+ undefined in
+ let raw_vec = if pvs = [] then vector_0 0
+ else scale_then (csdp nblocks blocksizes) obj mats in
+ let find_rounding d =
+ (if !debugging then
+ (Format.print_string("Trying rounding with limit "^string_of_num d);
+ Format.print_newline())
+ else ());
+ let vec = nice_vector d raw_vec in
+ let blockmat = iter (1,dim vec)
+ (fun i a -> bmatrix_add (bmatrix_cmul (element vec i) (el i mats)) a)
+ (bmatrix_neg (el 0 mats)) in
+ let allmats = blocks blocksizes blockmat in
+ vec,map diag allmats in
+ let vec,ratdias =
+ if pvs = [] then find_rounding num_1
+ else tryfind find_rounding (map Num.num_of_int (1--31) @
+ map pow2 (5--66)) in
+ let newassigs =
+ itlist (fun k -> el (k - 1) pvs |-> element vec k)
+ (1--dim vec) ((0,0,0) |=> Int(-1)) in
+ let finalassigs =
+ foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs
+ allassig in
+ let poly_of_epoly p =
+ foldl (fun a v e -> (v |--> equation_eval finalassigs e) a)
+ undefined p in
+ let mk_sos mons =
+ let mk_sq (c,m) =
+ c,itlist (fun k a -> (el (k - 1) mons |--> element m k) a)
+ (1--length mons) undefined in
+ map mk_sq in
+ let sqs = map2 mk_sos sqmonlist ratdias
+ and cfs = map poly_of_epoly ids in
+ let msq = filter (fun (a,b) -> b <> []) (map2 (fun a b -> a,b) monoid sqs) in
+ let eval_sq sqs = itlist
+ (fun (c,q) -> poly_add (poly_cmul c (poly_mul q q))) sqs poly_0 in
+ let sanity =
+ itlist (fun ((p,c),s) -> poly_add (poly_mul p (eval_sq s))) msq
+ (itlist2 (fun p q -> poly_add (poly_mul p q)) cfs eqs
+ (poly_neg pol)) in
+ if not(is_undefined sanity) then raise Sanity else
+ cfs,map (fun (a,b) -> snd a,b) msq;;
+
+(* ------------------------------------------------------------------------- *)
+(* Iterative deepening. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec deepen f n =
+ try print_string "Searching with depth limit ";
+ print_int n; print_newline(); f n
+ with Failure _ -> deepen f (n + 1);;
+
+(* ------------------------------------------------------------------------- *)
+(* The ordering so we can create canonical HOL polynomials. *)
+(* ------------------------------------------------------------------------- *)
+
+let dest_monomial mon = sort (increasing fst) (graph mon);;
+
+let monomial_order =
+ let rec lexorder l1 l2 =
+ match (l1,l2) with
+ [],[] -> true
+ | vps,[] -> false
+ | [],vps -> true
+ | ((x1,n1)::vs1),((x2,n2)::vs2) ->
+ if x1 < x2 then true
+ else if x2 < x1 then false
+ else if n1 < n2 then false
+ else if n2 < n1 then true
+ else lexorder vs1 vs2 in
+ fun m1 m2 ->
+ if m2 = monomial_1 then true else if m1 = monomial_1 then false else
+ let mon1 = dest_monomial m1 and mon2 = dest_monomial m2 in
+ let deg1 = itlist ((o) (+) snd) mon1 0
+ and deg2 = itlist ((o) (+) snd) mon2 0 in
+ if deg1 < deg2 then false else if deg1 > deg2 then true
+ else lexorder mon1 mon2;;
+
+let dest_poly p =
+ map (fun (m,c) -> c,dest_monomial m)
+ (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p));;
+
+(* ------------------------------------------------------------------------- *)
+(* Map back polynomials and their composites to HOL. *)
+(* ------------------------------------------------------------------------- *)
+
+let term_of_varpow =
+ fun x k ->
+ if k = 1 then Var x else Pow (Var x, k);;
+
+let term_of_monomial =
+ fun m -> if m = monomial_1 then Const num_1 else
+ let m' = dest_monomial m in
+ let vps = itlist (fun (x,k) a -> term_of_varpow x k :: a) m' [] in
+ end_itlist (fun s t -> Mul (s,t)) vps;;
+
+let term_of_cmonomial =
+ fun (m,c) ->
+ if m = monomial_1 then Const c
+ else if c =/ num_1 then term_of_monomial m
+ else Mul (Const c,term_of_monomial m);;
+
+let term_of_poly =
+ fun p ->
+ if p = poly_0 then Zero else
+ let cms = map term_of_cmonomial
+ (sort (fun (m1,_) (m2,_) -> monomial_order m1 m2) (graph p)) in
+ end_itlist (fun t1 t2 -> Add (t1,t2)) cms;;
+
+let term_of_sqterm (c,p) =
+ Product(Rational_lt c,Square(term_of_poly p));;
+
+let term_of_sos (pr,sqs) =
+ if sqs = [] then pr
+ else Product(pr,end_itlist (fun a b -> Sum(a,b)) (map term_of_sqterm sqs));;
+
+(* ------------------------------------------------------------------------- *)
+(* Interface to HOL. *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_NONLINEAR_PROVER translator (eqs,les,lts) =
+ let eq0 = map (poly_of_term o lhand o concl) eqs
+ and le0 = map (poly_of_term o lhand o concl) les
+ and lt0 = map (poly_of_term o lhand o concl) lts in
+ let eqp0 = map (fun (t,i) -> t,Axiom_eq i) (zip eq0 (0--(length eq0 - 1)))
+ and lep0 = map (fun (t,i) -> t,Axiom_le i) (zip le0 (0--(length le0 - 1)))
+ and ltp0 = map (fun (t,i) -> t,Axiom_lt i) (zip lt0 (0--(length lt0 - 1))) in
+ let keq,eq = partition (fun (p,_) -> multidegree p = 0) eqp0
+ and klep,lep = partition (fun (p,_) -> multidegree p = 0) lep0
+ and kltp,ltp = partition (fun (p,_) -> multidegree p = 0) ltp0 in
+ let trivial_axiom (p,ax) =
+ match ax with
+ Axiom_eq n when eval undefined p <>/ num_0 -> el n eqs
+ | Axiom_le n when eval undefined p </ num_0 -> el n les
+ | Axiom_lt n when eval undefined p <=/ num_0 -> el n lts
+ | _ -> failwith "not a trivial axiom" in
+ try let th = tryfind trivial_axiom (keq @ klep @ kltp) in
+ CONV_RULE (LAND_CONV REAL_POLY_CONV THENC REAL_RAT_RED_CONV) th
+ with Failure _ ->
+ let pol = itlist poly_mul (map fst ltp) (poly_const num_1) in
+ let leq = lep @ ltp in
+ let tryall d =
+ let e = multidegree pol in
+ let k = if e = 0 then 0 else d / e in
+ let eq' = map fst eq in
+ tryfind (fun i -> d,i,real_positivnullstellensatz_general false d eq' leq
+ (poly_neg(poly_pow pol i)))
+ (0--k) in
+ let d,i,(cert_ideal,cert_cone) = deepen tryall 0 in
+ let proofs_ideal =
+ map2 (fun q (p,ax) -> Eqmul(term_of_poly q,ax)) cert_ideal eq
+ and proofs_cone = map term_of_sos cert_cone
+ and proof_ne =
+ if ltp = [] then Rational_lt num_1 else
+ let p = end_itlist (fun s t -> Product(s,t)) (map snd ltp) in
+ funpow i (fun q -> Product(p,q)) (Rational_lt num_1) in
+ let proof = end_itlist (fun s t -> Sum(s,t))
+ (proof_ne :: proofs_ideal @ proofs_cone) in
+ print_string("Translating proof certificate to HOL");
+ print_newline();
+ translator (eqs,les,lts) proof;;
+*)
+(* ------------------------------------------------------------------------- *)
+(* A wrapper that tries to substitute away variables first. *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_NONLINEAR_SUBST_PROVER =
+ let zero = `&0:real`
+ and mul_tm = `( * ):real->real->real`
+ and shuffle1 =
+ CONV_RULE(REWR_CONV(REAL_ARITH `a + x = (y:real) <=> x = y - a`))
+ and shuffle2 =
+ CONV_RULE(REWR_CONV(REAL_ARITH `x + a = (y:real) <=> x = y - a`)) in
+ let rec substitutable_monomial fvs tm =
+ match tm with
+ Var(_,Tyapp("real",[])) when not (mem tm fvs) -> Int 1,tm
+ | Comb(Comb(Const("real_mul",_),c),(Var(_,_) as t))
+ when is_ratconst c & not (mem t fvs)
+ -> rat_of_term c,t
+ | Comb(Comb(Const("real_add",_),s),t) ->
+ (try substitutable_monomial (union (frees t) fvs) s
+ with Failure _ -> substitutable_monomial (union (frees s) fvs) t)
+ | _ -> failwith "substitutable_monomial"
+ and isolate_variable v th =
+ match lhs(concl th) with
+ x when x = v -> th
+ | Comb(Comb(Const("real_add",_),(Var(_,Tyapp("real",[])) as x)),t)
+ when x = v -> shuffle2 th
+ | Comb(Comb(Const("real_add",_),s),t) ->
+ isolate_variable v(shuffle1 th) in
+ let make_substitution th =
+ let (c,v) = substitutable_monomial [] (lhs(concl th)) in
+ let th1 = AP_TERM (mk_comb(mul_tm,term_of_rat(Int 1 // c))) th in
+ let th2 = CONV_RULE(BINOP_CONV REAL_POLY_MUL_CONV) th1 in
+ CONV_RULE (RAND_CONV REAL_POLY_CONV) (isolate_variable v th2) in
+ fun translator ->
+ let rec substfirst(eqs,les,lts) =
+ try let eth = tryfind make_substitution eqs in
+ let modify =
+ CONV_RULE(LAND_CONV(SUBS_CONV[eth] THENC REAL_POLY_CONV)) in
+ substfirst(filter (fun t -> lhand(concl t) <> zero) (map modify eqs),
+ map modify les,map modify lts)
+ with Failure _ -> REAL_NONLINEAR_PROVER translator (eqs,les,lts) in
+ substfirst;;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Overall function. *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_SOS =
+ let init = GEN_REWRITE_CONV ONCE_DEPTH_CONV [DECIMAL]
+ and pure = GEN_REAL_ARITH REAL_NONLINEAR_SUBST_PROVER in
+ fun tm -> let th = init tm in EQ_MP (SYM th) (pure(rand(concl th)));;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Add hacks for division. *)
+(* ------------------------------------------------------------------------- *)
+(*
+let REAL_SOSFIELD =
+ let inv_tm = `inv:real->real` in
+ let prenex_conv =
+ TOP_DEPTH_CONV BETA_CONV THENC
+ PURE_REWRITE_CONV[FORALL_SIMP; EXISTS_SIMP; real_div;
+ REAL_INV_INV; REAL_INV_MUL; GSYM REAL_POW_INV] THENC
+ NNFC_CONV THENC DEPTH_BINOP_CONV `(/\)` CONDS_CELIM_CONV THENC
+ PRENEX_CONV
+ and setup_conv = NNF_CONV THENC WEAK_CNF_CONV THENC CONJ_CANON_CONV
+ and core_rule t =
+ try REAL_ARITH t
+ with Failure _ -> try REAL_RING t
+ with Failure _ -> REAL_SOS t
+ and is_inv =
+ let is_div = is_binop `(/):real->real->real` in
+ fun tm -> (is_div tm or (is_comb tm & rator tm = inv_tm)) &
+ not(is_ratconst(rand tm)) in
+ let BASIC_REAL_FIELD tm =
+ let is_freeinv t = is_inv t & free_in t tm in
+ let itms = setify(map rand (find_terms is_freeinv tm)) in
+ let hyps = map (fun t -> SPEC t REAL_MUL_RINV) itms in
+ let tm' = itlist (fun th t -> mk_imp(concl th,t)) hyps tm in
+ let itms' = map (curry mk_comb inv_tm) itms in
+ let gvs = map (genvar o type_of) itms' in
+ let tm'' = subst (zip gvs itms') tm' in
+ let th1 = setup_conv tm'' in
+ let cjs = conjuncts(rand(concl th1)) in
+ let ths = map core_rule cjs in
+ let th2 = EQ_MP (SYM th1) (end_itlist CONJ ths) in
+ rev_itlist (C MP) hyps (INST (zip itms' gvs) th2) in
+ fun tm ->
+ let th0 = prenex_conv tm in
+ let tm0 = rand(concl th0) in
+ let avs,bod = strip_forall tm0 in
+ let th1 = setup_conv bod in
+ let ths = map BASIC_REAL_FIELD (conjuncts(rand(concl th1))) in
+ EQ_MP (SYM th0) (GENL avs (EQ_MP (SYM th1) (end_itlist CONJ ths)));;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Integer version. *)
+(* ------------------------------------------------------------------------- *)
+(*
+let INT_SOS =
+ let atom_CONV =
+ let pth = prove
+ (`(~(x <= y) <=> y + &1 <= x:int) /\
+ (~(x < y) <=> y <= x) /\
+ (~(x = y) <=> x + &1 <= y \/ y + &1 <= x) /\
+ (x < y <=> x + &1 <= y)`,
+ REWRITE_TAC[INT_NOT_LE; INT_NOT_LT; INT_NOT_EQ; INT_LT_DISCRETE]) in
+ GEN_REWRITE_CONV I [pth]
+ and bub_CONV = GEN_REWRITE_CONV TOP_SWEEP_CONV
+ [int_eq; int_le; int_lt; int_ge; int_gt;
+ int_of_num_th; int_neg_th; int_add_th; int_mul_th;
+ int_sub_th; int_pow_th; int_abs_th; int_max_th; int_min_th] in
+ let base_CONV = TRY_CONV atom_CONV THENC bub_CONV in
+ let NNF_NORM_CONV = GEN_NNF_CONV false
+ (base_CONV,fun t -> base_CONV t,base_CONV(mk_neg t)) in
+ let init_CONV =
+ GEN_REWRITE_CONV DEPTH_CONV [FORALL_SIMP; EXISTS_SIMP] THENC
+ GEN_REWRITE_CONV DEPTH_CONV [INT_GT; INT_GE] THENC
+ CONDS_ELIM_CONV THENC NNF_NORM_CONV in
+ let p_tm = `p:bool`
+ and not_tm = `(~)` in
+ let pth = TAUT(mk_eq(mk_neg(mk_neg p_tm),p_tm)) in
+ fun tm ->
+ let th0 = INST [tm,p_tm] pth
+ and th1 = NNF_NORM_CONV(mk_neg tm) in
+ let th2 = REAL_SOS(mk_neg(rand(concl th1))) in
+ EQ_MP th0 (EQ_MP (AP_TERM not_tm (SYM th1)) th2);;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Natural number version. *)
+(* ------------------------------------------------------------------------- *)
+(*
+let SOS_RULE tm =
+ let avs = frees tm in
+ let tm' = list_mk_forall(avs,tm) in
+ let th1 = NUM_TO_INT_CONV tm' in
+ let th2 = INT_SOS (rand(concl th1)) in
+ SPECL avs (EQ_MP (SYM th1) th2);;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Now pure SOS stuff. *)
+(* ------------------------------------------------------------------------- *)
+
+(*prioritize_real();;*)
+
+(* ------------------------------------------------------------------------- *)
+(* Some combinatorial helper functions. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec allpermutations l =
+ if l = [] then [[]] else
+ itlist (fun h acc -> map (fun t -> h::t)
+ (allpermutations (subtract l [h])) @ acc) l [];;
+
+let allvarorders l =
+ map (fun vlis x -> index x vlis) (allpermutations l);;
+
+let changevariables_monomial zoln (m:monomial) =
+ foldl (fun a x k -> (assoc x zoln |-> k) a) monomial_1 m;;
+
+let changevariables zoln pol =
+ foldl (fun a m c -> (changevariables_monomial zoln m |-> c) a)
+ poly_0 pol;;
+
+(* ------------------------------------------------------------------------- *)
+(* Return to original non-block matrices. *)
+(* ------------------------------------------------------------------------- *)
+
+let sdpa_of_vector (v:vector) =
+ let n = dim v in
+ let strs = map (o (decimalize 20) (element v)) (1--n) in
+ end_itlist (fun x y -> x ^ " " ^ y) strs ^ "\n";;
+
+let sdpa_of_blockdiagonal k m =
+ let pfx = string_of_int k ^" " in
+ let ents =
+ foldl (fun a (b,i,j) c -> if i > j then a else ((b,i,j),c)::a) [] m in
+ let entss = sort (increasing fst) ents in
+ itlist (fun ((b,i,j),c) a ->
+ pfx ^ string_of_int b ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^
+ " " ^ decimalize 20 c ^ "\n" ^ a) entss "";;
+
+let sdpa_of_matrix k (m:matrix) =
+ let pfx = string_of_int k ^ " 1 " in
+ let ms = foldr (fun (i,j) c a -> if i > j then a else ((i,j),c)::a)
+ (snd m) [] in
+ let mss = sort (increasing fst) ms in
+ itlist (fun ((i,j),c) a ->
+ pfx ^ string_of_int i ^ " " ^ string_of_int j ^
+ " " ^ decimalize 20 c ^ "\n" ^ a) mss "";;
+
+let sdpa_of_problem comment obj mats =
+ let m = length mats - 1
+ and n,_ = dimensions (hd mats) in
+ "\"" ^ comment ^ "\"\n" ^
+ string_of_int m ^ "\n" ^
+ "1\n" ^
+ string_of_int n ^ "\n" ^
+ sdpa_of_vector obj ^
+ itlist2 (fun k m a -> sdpa_of_matrix (k - 1) m ^ a)
+ (1--length mats) mats "";;
+
+let run_csdp dbg obj mats =
+ let input_file = Filename.temp_file "sos" ".dat-s" in
+ let output_file =
+ String.sub input_file 0 (String.length input_file - 6) ^ ".out"
+ and params_file = Filename.concat (!temp_path) "param.csdp" in
+ file_of_string input_file (sdpa_of_problem "" obj mats);
+ file_of_string params_file csdp_params;
+ let rv = Sys.command("cd "^(!temp_path)^"; csdp "^input_file ^
+ " " ^ output_file ^
+ (if dbg then "" else "> /dev/null")) in
+ let op = string_of_file output_file in
+ let res = parse_csdpoutput op in
+ ((if dbg then ()
+ else (Sys.remove input_file; Sys.remove output_file));
+ rv,res);;
+
+let csdp obj mats =
+ let rv,res = run_csdp (!debugging) obj mats in
+ (if rv = 1 or rv = 2 then failwith "csdp: Problem is infeasible"
+ else if rv = 3 then ()
+(* (Format.print_string "csdp warning: Reduced accuracy";
+ Format.print_newline()) *)
+ else if rv <> 0 then failwith("csdp: error "^string_of_int rv)
+ else ());
+ res;;
+
+(* ------------------------------------------------------------------------- *)
+(* Sum-of-squares function with some lowbrow symmetry reductions. *)
+(* ------------------------------------------------------------------------- *)
+
+let sumofsquares_general_symmetry tool pol =
+ let vars = poly_variables pol
+ and lpps = newton_polytope pol in
+ let n = length lpps in
+ let sym_eqs =
+ let invariants = filter
+ (fun vars' ->
+ is_undefined(poly_sub pol (changevariables (zip vars vars') pol)))
+ (allpermutations vars) in
+ let lpns = zip lpps (1--length lpps) in
+ let lppcs =
+ filter (fun (m,(n1,n2)) -> n1 <= n2)
+ (allpairs
+ (fun (m1,n1) (m2,n2) -> (m1,m2),(n1,n2)) lpns lpns) in
+ let clppcs = end_itlist (@)
+ (map (fun ((m1,m2),(n1,n2)) ->
+ map (fun vars' ->
+ (changevariables_monomial (zip vars vars') m1,
+ changevariables_monomial (zip vars vars') m2),(n1,n2))
+ invariants)
+ lppcs) in
+ let clppcs_dom = setify(map fst clppcs) in
+ let clppcs_cls = map (fun d -> filter (fun (e,_) -> e = d) clppcs)
+ clppcs_dom in
+ let eqvcls = map (o setify (map snd)) clppcs_cls in
+ let mk_eq cls acc =
+ match cls with
+ [] -> raise Sanity
+ | [h] -> acc
+ | h::t -> map (fun k -> (k |-> Int(-1)) (h |=> Int 1)) t @ acc in
+ itlist mk_eq eqvcls [] in
+ let eqs = foldl (fun a x y -> y::a) []
+ (itern 1 lpps (fun m1 n1 ->
+ itern 1 lpps (fun m2 n2 f ->
+ let m = monomial_mul m1 m2 in
+ if n1 > n2 then f else
+ let c = if n1 = n2 then Int 1 else Int 2 in
+ (m |-> ((n1,n2) |-> c) (tryapplyd f m undefined)) f))
+ (foldl (fun a m c -> (m |-> ((0,0)|=>c)) a)
+ undefined pol)) @
+ sym_eqs in
+ let pvs,assig = eliminate_all_equations (0,0) eqs in
+ let allassig = itlist (fun v -> (v |-> (v |=> Int 1))) pvs assig in
+ let qvars = (0,0)::pvs in
+ let diagents =
+ end_itlist equation_add (map (fun i -> apply allassig (i,i)) (1--n)) in
+ let mk_matrix v =
+ ((n,n),
+ foldl (fun m (i,j) ass -> let c = tryapplyd ass v (Int 0) in
+ if c =/ Int 0 then m else
+ ((j,i) |-> c) (((i,j) |-> c) m))
+ undefined allassig :matrix) in
+ let mats = map mk_matrix qvars
+ and obj = length pvs,
+ itern 1 pvs (fun v i -> (i |--> tryapplyd diagents v (Int 0)))
+ undefined in
+ let raw_vec = if pvs = [] then vector_0 0 else tool obj mats in
+ let find_rounding d =
+ (if !debugging then
+ (Format.print_string("Trying rounding with limit "^string_of_num d);
+ Format.print_newline())
+ else ());
+ let vec = nice_vector d raw_vec in
+ let mat = iter (1,dim vec)
+ (fun i a -> matrix_add (matrix_cmul (element vec i) (el i mats)) a)
+ (matrix_neg (el 0 mats)) in
+ deration(diag mat) in
+ let rat,dia =
+ if pvs = [] then
+ let mat = matrix_neg (el 0 mats) in
+ deration(diag mat)
+ else
+ tryfind find_rounding (map Num.num_of_int (1--31) @
+ map pow2 (5--66)) in
+ let poly_of_lin(d,v) =
+ d,foldl(fun a i c -> (el (i - 1) lpps |-> c) a) undefined (snd v) in
+ let lins = map poly_of_lin dia in
+ let sqs = map (fun (d,l) -> poly_mul (poly_const d) (poly_pow l 2)) lins in
+ let sos = poly_cmul rat (end_itlist poly_add sqs) in
+ if is_undefined(poly_sub sos pol) then rat,lins else raise Sanity;;
+
+let sumofsquares = sumofsquares_general_symmetry csdp;;
+
+(* ------------------------------------------------------------------------- *)
+(* Pure HOL SOS conversion. *)
+(* ------------------------------------------------------------------------- *)
+(*
+let SOS_CONV =
+ let mk_square =
+ let pow_tm = `(pow)` and two_tm = `2` in
+ fun tm -> mk_comb(mk_comb(pow_tm,tm),two_tm)
+ and mk_prod = mk_binop `( * )`
+ and mk_sum = mk_binop `(+)` in
+ fun tm ->
+ let k,sos = sumofsquares(poly_of_term tm) in
+ let mk_sqtm(c,p) =
+ mk_prod (term_of_rat(k */ c)) (mk_square(term_of_poly p)) in
+ let tm' = end_itlist mk_sum (map mk_sqtm sos) in
+ let th = REAL_POLY_CONV tm and th' = REAL_POLY_CONV tm' in
+ TRANS th (SYM th');;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Attempt to prove &0 <= x by direct SOS decomposition. *)
+(* ------------------------------------------------------------------------- *)
+(*
+let PURE_SOS_TAC =
+ let tac =
+ MATCH_ACCEPT_TAC(REWRITE_RULE[GSYM REAL_POW_2] REAL_LE_SQUARE) ORELSE
+ MATCH_ACCEPT_TAC REAL_LE_SQUARE ORELSE
+ (MATCH_MP_TAC REAL_LE_ADD THEN CONJ_TAC) ORELSE
+ (MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC) ORELSE
+ CONV_TAC(RAND_CONV REAL_RAT_REDUCE_CONV THENC REAL_RAT_LE_CONV) in
+ REPEAT GEN_TAC THEN REWRITE_TAC[real_ge] THEN
+ GEN_REWRITE_TAC I [GSYM REAL_SUB_LE] THEN
+ CONV_TAC(RAND_CONV SOS_CONV) THEN
+ REPEAT tac THEN NO_TAC;;
+
+let PURE_SOS tm = prove(tm,PURE_SOS_TAC);;
+*)
+(* ------------------------------------------------------------------------- *)
+(* Examples. *)
+(* ------------------------------------------------------------------------- *)
+
+(*****
+
+time REAL_SOS
+ `a1 >= &0 /\ a2 >= &0 /\
+ (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + &2) /\
+ (a1 * b1 + a2 * b2 = &0)
+ ==> a1 * a2 - b1 * b2 >= &0`;;
+
+time REAL_SOS `&3 * x + &7 * a < &4 /\ &3 < &2 * x ==> a < &0`;;
+
+time REAL_SOS
+ `b pow 2 < &4 * a * c ==> ~(a * x pow 2 + b * x + c = &0)`;;
+
+time REAL_SOS
+ `(a * x pow 2 + b * x + c = &0) ==> b pow 2 >= &4 * a * c`;;
+
+time REAL_SOS
+ `&0 <= x /\ x <= &1 /\ &0 <= y /\ y <= &1
+ ==> x pow 2 + y pow 2 < &1 \/
+ (x - &1) pow 2 + y pow 2 < &1 \/
+ x pow 2 + (y - &1) pow 2 < &1 \/
+ (x - &1) pow 2 + (y - &1) pow 2 < &1`;;
+
+time REAL_SOS
+ `&0 <= b /\ &0 <= c /\ &0 <= x /\ &0 <= y /\
+ (x pow 2 = c) /\ (y pow 2 = a pow 2 * c + b)
+ ==> a * c <= y * x`;;
+
+time REAL_SOS
+ `&0 <= x /\ &0 <= y /\ &0 <= z /\ x + y + z <= &3
+ ==> x * y + x * z + y * z >= &3 * x * y * z`;;
+
+time REAL_SOS
+ `(x pow 2 + y pow 2 + z pow 2 = &1) ==> (x + y + z) pow 2 <= &3`;;
+
+time REAL_SOS
+ `(w pow 2 + x pow 2 + y pow 2 + z pow 2 = &1)
+ ==> (w + x + y + z) pow 2 <= &4`;;
+
+time REAL_SOS
+ `x >= &1 /\ y >= &1 ==> x * y >= x + y - &1`;;
+
+time REAL_SOS
+ `x > &1 /\ y > &1 ==> x * y > x + y - &1`;;
+
+time REAL_SOS
+ `abs(x) <= &1
+ ==> abs(&64 * x pow 7 - &112 * x pow 5 + &56 * x pow 3 - &7 * x) <= &1`;;
+
+time REAL_SOS
+ `abs(x - z) <= e /\ abs(y - z) <= e /\ &0 <= u /\ &0 <= v /\ (u + v = &1)
+ ==> abs((u * x + v * y) - z) <= e`;;
+
+(* ------------------------------------------------------------------------- *)
+(* One component of denominator in dodecahedral example. *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+ `&2 <= x /\ x <= &125841 / &50000 /\
+ &2 <= y /\ y <= &125841 / &50000 /\
+ &2 <= z /\ z <= &125841 / &50000
+ ==> &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= &0`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Over a larger but simpler interval. *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+ `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4
+ ==> &0 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* We can do 12. I think 12 is a sharp bound; see PP's certificate. *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+ `&2 <= x /\ x <= &4 /\ &2 <= y /\ y <= &4 /\ &2 <= z /\ z <= &4
+ ==> &12 <= &2 * (x * z + x * y + y * z) - (x * x + y * y + z * z)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Gloptipoly example. *)
+(* ------------------------------------------------------------------------- *)
+
+(*** This works but normalization takes minutes
+
+time REAL_SOS
+ `(x - y - &2 * x pow 4 = &0) /\ &0 <= x /\ x <= &2 /\ &0 <= y /\ y <= &3
+ ==> y pow 2 - &7 * y - &12 * x + &17 >= &0`;;
+
+ ***)
+
+(* ------------------------------------------------------------------------- *)
+(* Inequality from sci.math (see "Leon-Sotelo, por favor"). *)
+(* ------------------------------------------------------------------------- *)
+
+time REAL_SOS
+ `&0 <= x /\ &0 <= y /\ (x * y = &1)
+ ==> x + y <= x pow 2 + y pow 2`;;
+
+time REAL_SOS
+ `&0 <= x /\ &0 <= y /\ (x * y = &1)
+ ==> x * y * (x + y) <= x pow 2 + y pow 2`;;
+
+time REAL_SOS
+ `&0 <= x /\ &0 <= y ==> x * y * (x + y) pow 2 <= (x pow 2 + y pow 2) pow 2`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Some examples over integers and natural numbers. *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE `!m n. 2 * m + n = (n + m) + m`;;
+time SOS_RULE `!n. ~(n = 0) ==> (0 MOD n = 0)`;;
+time SOS_RULE `!m n. m < n ==> (m DIV n = 0)`;;
+time SOS_RULE `!n:num. n <= n * n`;;
+time SOS_RULE `!m n. n * (m DIV n) <= m`;;
+time SOS_RULE `!n. ~(n = 0) ==> (0 DIV n = 0)`;;
+time SOS_RULE `!m n p. ~(p = 0) /\ m <= n ==> m DIV p <= n DIV p`;;
+time SOS_RULE `!a b n. ~(a = 0) ==> (n <= b DIV a <=> a * n <= b)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* This is particularly gratifying --- cf hideous manual proof in arith.ml *)
+(* ------------------------------------------------------------------------- *)
+
+(*** This doesn't now seem to work as well as it did; what changed?
+
+time SOS_RULE
+ `!a b c d. ~(b = 0) /\ b * c < (a + 1) * d ==> c DIV d <= a DIV b`;;
+
+ ***)
+
+(* ------------------------------------------------------------------------- *)
+(* Key lemma for injectivity of Cantor-type pairing functions. *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE
+ `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1)
+ ==> (x1 + y1 = x2 + y2)`;;
+
+time SOS_RULE
+ `!x1 y1 x2 y2. ((x1 + y1) EXP 2 + x1 + 1 = (x2 + y2) EXP 2 + x2 + 1) /\
+ (x1 + y1 = x2 + y2)
+ ==> (x1 = x2) /\ (y1 = y2)`;;
+
+time SOS_RULE
+ `!x1 y1 x2 y2.
+ (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 =
+ ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2)
+ ==> (x1 + y1 = x2 + y2)`;;
+
+time SOS_RULE
+ `!x1 y1 x2 y2.
+ (((x1 + y1) EXP 2 + 3 * x1 + y1) DIV 2 =
+ ((x2 + y2) EXP 2 + 3 * x2 + y2) DIV 2) /\
+ (x1 + y1 = x2 + y2)
+ ==> (x1 = x2) /\ (y1 = y2)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Reciprocal multiplication (actually just ARITH_RULE does these). *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE `x <= 127 ==> ((86 * x) DIV 256 = x DIV 3)`;;
+
+time SOS_RULE `x < 2 EXP 16 ==> ((104858 * x) DIV (2 EXP 20) = x DIV 10)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* This is more impressive since it's really nonlinear. See REMAINDER_DECODE *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_RULE `0 < m /\ m < n ==> ((m * ((n * x) DIV m + 1)) DIV n = x)`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Some conversion examples. *)
+(* ------------------------------------------------------------------------- *)
+
+time SOS_CONV
+ `&2 * x pow 4 + &2 * x pow 3 * y - x pow 2 * y pow 2 + &5 * y pow 4`;;
+
+time SOS_CONV
+ `x pow 4 - (&2 * y * z + &1) * x pow 2 +
+ (y pow 2 * z pow 2 + &2 * y * z + &2)`;;
+
+time SOS_CONV `&4 * x pow 4 +
+ &4 * x pow 3 * y - &7 * x pow 2 * y pow 2 - &2 * x * y pow 3 +
+ &10 * y pow 4`;;
+
+time SOS_CONV `&4 * x pow 4 * y pow 6 + x pow 2 - x * y pow 2 + y pow 2`;;
+
+time SOS_CONV
+ `&4096 * (x pow 4 + x pow 2 + z pow 6 - &3 * x pow 2 * z pow 2) + &729`;;
+
+time SOS_CONV
+ `&120 * x pow 2 - &63 * x pow 4 + &10 * x pow 6 +
+ &30 * x * y - &120 * y pow 2 + &120 * y pow 4 + &31`;;
+
+time SOS_CONV
+ `&9 * x pow 2 * y pow 4 + &9 * x pow 2 * z pow 4 + &36 * x pow 2 * y pow 3 +
+ &36 * x pow 2 * y pow 2 - &48 * x * y * z pow 2 + &4 * y pow 4 +
+ &4 * z pow 4 - &16 * y pow 3 + &16 * y pow 2`;;
+
+time SOS_CONV
+ `(x pow 2 + y pow 2 + z pow 2) *
+ (x pow 4 * y pow 2 + x pow 2 * y pow 4 +
+ z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2)`;;
+
+time SOS_CONV
+ `x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3`;;
+
+(*** I think this will work, but normalization is slow
+
+time SOS_CONV
+ `&100 * (x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z) + &212`;;
+
+ ***)
+
+time SOS_CONV
+ `&100 * ((&2 * x - &2) pow 2 + (x pow 3 - &8 * x - &2) pow 2) - &588`;;
+
+time SOS_CONV
+ `x pow 2 * (&120 - &63 * x pow 2 + &10 * x pow 4) + &30 * x * y +
+ &30 * y pow 2 * (&4 * y pow 2 - &4) + &31`;;
+
+(* ------------------------------------------------------------------------- *)
+(* Example of basic rule. *)
+(* ------------------------------------------------------------------------- *)
+
+time PURE_SOS
+ `!x. x pow 4 + y pow 4 + z pow 4 - &4 * x * y * z + x + y + z + &3
+ >= &1 / &7`;;
+
+time PURE_SOS
+ `&0 <= &98 * x pow 12 +
+ -- &980 * x pow 10 +
+ &3038 * x pow 8 +
+ -- &2968 * x pow 6 +
+ &1022 * x pow 4 +
+ -- &84 * x pow 2 +
+ &2`;;
+
+time PURE_SOS
+ `!x. &0 <= &2 * x pow 14 +
+ -- &84 * x pow 12 +
+ &1022 * x pow 10 +
+ -- &2968 * x pow 8 +
+ &3038 * x pow 6 +
+ -- &980 * x pow 4 +
+ &98 * x pow 2`;;
+
+(* ------------------------------------------------------------------------- *)
+(* From Zeng et al, JSC vol 37 (2004), p83-99. *)
+(* All of them work nicely with pure SOS_CONV, except (maybe) the one noted. *)
+(* ------------------------------------------------------------------------- *)
+
+PURE_SOS
+ `x pow 6 + y pow 6 + z pow 6 - &3 * x pow 2 * y pow 2 * z pow 2 >= &0`;;
+
+PURE_SOS `x pow 4 + y pow 4 + z pow 4 + &1 - &4*x*y*z >= &0`;;
+
+PURE_SOS `x pow 4 + &2*x pow 2*z + x pow 2 - &2*x*y*z + &2*y pow 2*z pow 2 +
+&2*y*z pow 2 + &2*z pow 2 - &2*x + &2* y*z + &1 >= &0`;;
+
+(**** This is harder. Interestingly, this fails the pure SOS test, it seems.
+ Yet only on rounding(!?) Poor Newton polytope optimization or something?
+ But REAL_SOS does finally converge on the second run at level 12!
+
+REAL_SOS
+`x pow 4*y pow 4 - &2*x pow 5*y pow 3*z pow 2 + x pow 6*y pow 2*z pow 4 + &2*x
+pow 2*y pow 3*z - &4* x pow 3*y pow 2*z pow 3 + &2*x pow 4*y*z pow 5 + z pow
+2*y pow 2 - &2*z pow 4*y*x + z pow 6*x pow 2 >= &0`;;
+
+ ****)
+
+PURE_SOS
+`x pow 4 + &4*x pow 2*y pow 2 + &2*x*y*z pow 2 + &2*x*y*w pow 2 + y pow 4 + z
+pow 4 + w pow 4 + &2*z pow 2*w pow 2 + &2*x pow 2*w + &2*y pow 2*w + &2*x*y +
+&3*w pow 2 + &2*z pow 2 + &1 >= &0`;;
+
+PURE_SOS
+`w pow 6 + &2*z pow 2*w pow 3 + x pow 4 + y pow 4 + z pow 4 + &2*x pow 2*w +
+&2*x pow 2*z + &3*x pow 2 + w pow 2 + &2*z*w + z pow 2 + &2*z + &2*w + &1 >=
+&0`;;
+
+*****)
diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli
new file mode 100644
index 00000000..e38caba0
--- /dev/null
+++ b/plugins/micromega/sos.mli
@@ -0,0 +1,36 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Sos_types
+
+type poly
+
+val poly_isconst : poly -> bool
+
+val poly_neg : poly -> poly
+
+val poly_mul : poly -> poly -> poly
+
+val poly_pow : poly -> int -> poly
+
+val poly_const : Num.num -> poly
+
+val poly_of_term : term -> poly
+
+val term_of_poly : poly -> term
+
+val term_of_sos : positivstellensatz * (Num.num * poly) list ->
+ positivstellensatz
+
+val string_of_poly : poly -> string
+
+val real_positivnullstellensatz_general : bool -> int -> poly list ->
+ (poly * positivstellensatz) list ->
+ poly -> poly list * (positivstellensatz * (Num.num * poly) list) list
+
+val sumofsquares : poly -> Num.num * ( Num.num * poly) list
diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml
new file mode 100644
index 00000000..baf90d4d
--- /dev/null
+++ b/plugins/micromega/sos_lib.ml
@@ -0,0 +1,621 @@
+(* ========================================================================= *)
+(* - This code originates from John Harrison's HOL LIGHT 2.30 *)
+(* (see file LICENSE.sos for license, copyright and disclaimer) *)
+(* This code is the HOL LIGHT library code used by sos.ml *)
+(* - Laurent Théry (thery@sophia.inria.fr) has isolated the HOL *)
+(* independent bits *)
+(* - Frédéric Besson (fbesson@irisa.fr) is using it to feed micromega *)
+(* ========================================================================= *)
+open Sos_types
+open Num
+open List
+
+let debugging = ref false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Comparisons that are reflexive on NaN and also short-circuiting. *)
+(* ------------------------------------------------------------------------- *)
+
+let (=?) = fun x y -> Pervasives.compare x y = 0;;
+let (<?) = fun x y -> Pervasives.compare x y < 0;;
+let (<=?) = fun x y -> Pervasives.compare x y <= 0;;
+let (>?) = fun x y -> Pervasives.compare x y > 0;;
+let (>=?) = fun x y -> Pervasives.compare x y >= 0;;
+
+(* ------------------------------------------------------------------------- *)
+(* Combinators. *)
+(* ------------------------------------------------------------------------- *)
+
+let (o) = fun f g x -> f(g x);;
+
+(* ------------------------------------------------------------------------- *)
+(* Some useful functions on "num" type. *)
+(* ------------------------------------------------------------------------- *)
+
+
+let num_0 = Int 0
+and num_1 = Int 1
+and num_2 = Int 2
+and num_10 = Int 10;;
+
+let pow2 n = power_num num_2 (Int n);;
+let pow10 n = power_num num_10 (Int n);;
+
+let numdom r =
+ let r' = Ratio.normalize_ratio (ratio_of_num r) in
+ num_of_big_int(Ratio.numerator_ratio r'),
+ num_of_big_int(Ratio.denominator_ratio r');;
+
+let numerator = (o) fst numdom
+and denominator = (o) snd numdom;;
+
+let gcd_num n1 n2 =
+ num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;
+
+let lcm_num x y =
+ if x =/ num_0 & y =/ num_0 then num_0
+ else abs_num((x */ y) // gcd_num x y);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* List basics. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec el n l =
+ if n = 0 then hd l else el (n - 1) (tl l);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Various versions of list iteration. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec itlist f l b =
+ match l with
+ [] -> b
+ | (h::t) -> f h (itlist f t b);;
+
+let rec end_itlist f l =
+ match l with
+ [] -> failwith "end_itlist"
+ | [x] -> x
+ | (h::t) -> f h (end_itlist f t);;
+
+let rec itlist2 f l1 l2 b =
+ match (l1,l2) with
+ ([],[]) -> b
+ | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b)
+ | _ -> failwith "itlist2";;
+
+(* ------------------------------------------------------------------------- *)
+(* All pairs arising from applying a function over two lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec allpairs f l1 l2 =
+ match l1 with
+ h1::t1 -> itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
+ | [] -> [];;
+
+(* ------------------------------------------------------------------------- *)
+(* String operations (surely there is a better way...) *)
+(* ------------------------------------------------------------------------- *)
+
+let implode l = itlist (^) l "";;
+
+let explode s =
+ let rec exap n l =
+ if n < 0 then l else
+ exap (n - 1) ((String.sub s n 1)::l) in
+ exap (String.length s - 1) [];;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Attempting function or predicate applications. *)
+(* ------------------------------------------------------------------------- *)
+
+let can f x = try (f x; true) with Failure _ -> false;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Repetition of a function. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec funpow n f x =
+ if n < 1 then x else funpow (n-1) f (f x);;
+
+
+
+(* ------------------------------------------------------------------------- *)
+(* Replication and sequences. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec replicate x n =
+ if n < 1 then []
+ else x::(replicate x (n - 1));;
+
+let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;
+
+(* ------------------------------------------------------------------------- *)
+(* Various useful list operations. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec forall p l =
+ match l with
+ [] -> true
+ | h::t -> p(h) & forall p t;;
+
+let rec tryfind f l =
+ match l with
+ [] -> failwith "tryfind"
+ | (h::t) -> try f h with Failure _ -> tryfind f t;;
+
+let index x =
+ let rec ind n l =
+ match l with
+ [] -> failwith "index"
+ | (h::t) -> if x =? h then n else ind (n + 1) t in
+ ind 0;;
+
+(* ------------------------------------------------------------------------- *)
+(* "Set" operations on lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec mem x lis =
+ match lis with
+ [] -> false
+ | (h::t) -> x =? h or mem x t;;
+
+let insert x l =
+ if mem x l then l else x::l;;
+
+let union l1 l2 = itlist insert l1 l2;;
+
+let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;
+
+(* ------------------------------------------------------------------------- *)
+(* Merging and bottom-up mergesort. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec merge ord l1 l2 =
+ match l1 with
+ [] -> l2
+ | h1::t1 -> match l2 with
+ [] -> l1
+ | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2)
+ else h2::(merge ord l1 t2);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Common measure predicates to use with "sort". *)
+(* ------------------------------------------------------------------------- *)
+
+let increasing f x y = f x <? f y;;
+
+let decreasing f x y = f x >? f y;;
+
+(* ------------------------------------------------------------------------- *)
+(* Zipping, unzipping etc. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec zip l1 l2 =
+ match (l1,l2) with
+ ([],[]) -> []
+ | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)
+ | _ -> failwith "zip";;
+
+let rec unzip =
+ function [] -> [],[]
+ | ((a,b)::rest) -> let alist,blist = unzip rest in
+ (a::alist,b::blist);;
+
+(* ------------------------------------------------------------------------- *)
+(* Iterating functions over lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec do_list f l =
+ match l with
+ [] -> ()
+ | (h::t) -> (f h; do_list f t);;
+
+(* ------------------------------------------------------------------------- *)
+(* Sorting. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec sort cmp lis =
+ match lis with
+ [] -> []
+ | piv::rest ->
+ let r,l = partition (cmp piv) rest in
+ (sort cmp l) @ (piv::(sort cmp r));;
+
+(* ------------------------------------------------------------------------- *)
+(* Removing adjacent (NB!) equal elements from list. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec uniq l =
+ match l with
+ x::(y::_ as t) -> let t' = uniq t in
+ if x =? y then t' else
+ if t'==t then l else x::t'
+ | _ -> l;;
+
+(* ------------------------------------------------------------------------- *)
+(* Convert list into set by eliminating duplicates. *)
+(* ------------------------------------------------------------------------- *)
+
+let setify s = uniq (sort (<=?) s);;
+
+(* ------------------------------------------------------------------------- *)
+(* Polymorphic finite partial functions via Patricia trees. *)
+(* *)
+(* The point of this strange representation is that it is canonical (equal *)
+(* functions have the same encoding) yet reasonably efficient on average. *)
+(* *)
+(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *)
+(* ------------------------------------------------------------------------- *)
+
+type ('a,'b)func =
+ Empty
+ | Leaf of int * ('a*'b)list
+ | Branch of int * int * ('a,'b)func * ('a,'b)func;;
+
+(* ------------------------------------------------------------------------- *)
+(* Undefined function. *)
+(* ------------------------------------------------------------------------- *)
+
+let undefined = Empty;;
+
+(* ------------------------------------------------------------------------- *)
+(* In case of equality comparison worries, better use this. *)
+(* ------------------------------------------------------------------------- *)
+
+let is_undefined f =
+ match f with
+ Empty -> true
+ | _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Operation analagous to "map" for lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let mapf =
+ let rec map_list f l =
+ match l with
+ [] -> []
+ | (x,y)::t -> (x,f(y))::(map_list f t) in
+ let rec mapf f t =
+ match t with
+ Empty -> Empty
+ | Leaf(h,l) -> Leaf(h,map_list f l)
+ | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in
+ mapf;;
+
+(* ------------------------------------------------------------------------- *)
+(* Operations analogous to "fold" for lists. *)
+(* ------------------------------------------------------------------------- *)
+
+let foldl =
+ let rec foldl_list f a l =
+ match l with
+ [] -> a
+ | (x,y)::t -> foldl_list f (f a x y) t in
+ let rec foldl f a t =
+ match t with
+ Empty -> a
+ | Leaf(h,l) -> foldl_list f a l
+ | Branch(p,b,l,r) -> foldl f (foldl f a l) r in
+ foldl;;
+
+let foldr =
+ let rec foldr_list f l a =
+ match l with
+ [] -> a
+ | (x,y)::t -> f x y (foldr_list f t a) in
+ let rec foldr f t a =
+ match t with
+ Empty -> a
+ | Leaf(h,l) -> foldr_list f l a
+ | Branch(p,b,l,r) -> foldr f l (foldr f r a) in
+ foldr;;
+
+(* ------------------------------------------------------------------------- *)
+(* Redefinition and combination. *)
+(* ------------------------------------------------------------------------- *)
+
+let (|->),combine =
+ let ldb x y = let z = x lxor y in z land (-z) in
+ let newbranch p1 t1 p2 t2 =
+ let b = ldb p1 p2 in
+ let p = p1 land (b - 1) in
+ if p1 land b = 0 then Branch(p,b,t1,t2)
+ else Branch(p,b,t2,t1) in
+ let rec define_list (x,y as xy) l =
+ match l with
+ (a,b as ab)::t ->
+ if x =? a then xy::t
+ else if x <? a then xy::l
+ else ab::(define_list xy t)
+ | [] -> [xy]
+ and combine_list op z l1 l2 =
+ match (l1,l2) with
+ [],_ -> l2
+ | _,[] -> l1
+ | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->
+ if x1 <? x2 then xy1::(combine_list op z t1 l2)
+ else if x2 <? x1 then xy2::(combine_list op z l1 t2) else
+ let y = op y1 y2 and l = combine_list op z t1 t2 in
+ if z(y) then l else (x1,y)::l in
+ let (|->) x y =
+ let k = Hashtbl.hash x in
+ let rec upd t =
+ match t with
+ Empty -> Leaf (k,[x,y])
+ | Leaf(h,l) ->
+ if h = k then Leaf(h,define_list (x,y) l)
+ else newbranch h t k (Leaf(k,[x,y]))
+ | Branch(p,b,l,r) ->
+ if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))
+ else if k land b = 0 then Branch(p,b,upd l,r)
+ else Branch(p,b,l,upd r) in
+ upd in
+ let rec combine op z t1 t2 =
+ match (t1,t2) with
+ Empty,_ -> t2
+ | _,Empty -> t1
+ | Leaf(h1,l1),Leaf(h2,l2) ->
+ if h1 = h2 then
+ let l = combine_list op z l1 l2 in
+ if l = [] then Empty else Leaf(h1,l)
+ else newbranch h1 t1 h2 t2
+ | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) |
+ (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->
+ if k land (b - 1) = p then
+ if k land b = 0 then
+ let l' = combine op z lf l in
+ if is_undefined l' then r else Branch(p,b,l',r)
+ else
+ let r' = combine op z lf r in
+ if is_undefined r' then l else Branch(p,b,l,r')
+ else
+ newbranch k lf p br
+ | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->
+ if b1 < b2 then
+ if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
+ else if p2 land b1 = 0 then
+ let l = combine op z l1 t2 in
+ if is_undefined l then r1 else Branch(p1,b1,l,r1)
+ else
+ let r = combine op z r1 t2 in
+ if is_undefined r then l1 else Branch(p1,b1,l1,r)
+ else if b2 < b1 then
+ if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
+ else if p1 land b2 = 0 then
+ let l = combine op z t1 l2 in
+ if is_undefined l then r2 else Branch(p2,b2,l,r2)
+ else
+ let r = combine op z t1 r2 in
+ if is_undefined r then l2 else Branch(p2,b2,l2,r)
+ else if p1 = p2 then
+ let l = combine op z l1 l2 and r = combine op z r1 r2 in
+ if is_undefined l then r
+ else if is_undefined r then l else Branch(p1,b1,l,r)
+ else
+ newbranch p1 t1 p2 t2 in
+ (|->),combine;;
+
+(* ------------------------------------------------------------------------- *)
+(* Special case of point function. *)
+(* ------------------------------------------------------------------------- *)
+
+let (|=>) = fun x y -> (x |-> y) undefined;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Grab an arbitrary element. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec choose t =
+ match t with
+ Empty -> failwith "choose: completely undefined function"
+ | Leaf(h,l) -> hd l
+ | Branch(b,p,t1,t2) -> choose t1;;
+
+(* ------------------------------------------------------------------------- *)
+(* Application. *)
+(* ------------------------------------------------------------------------- *)
+
+let applyd =
+ let rec apply_listd l d x =
+ match l with
+ (a,b)::t -> if x =? a then b
+ else if x >? a then apply_listd t d x else d x
+ | [] -> d x in
+ fun f d x ->
+ let k = Hashtbl.hash x in
+ let rec look t =
+ match t with
+ Leaf(h,l) when h = k -> apply_listd l d x
+ | Branch(p,b,l,r) -> look (if k land b = 0 then l else r)
+ | _ -> d x in
+ look f;;
+
+let apply f = applyd f (fun x -> failwith "apply");;
+
+let tryapplyd f a d = applyd f (fun x -> d) a;;
+
+let defined f x = try apply f x; true with Failure _ -> false;;
+
+(* ------------------------------------------------------------------------- *)
+(* Undefinition. *)
+(* ------------------------------------------------------------------------- *)
+
+let undefine =
+ let rec undefine_list x l =
+ match l with
+ (a,b as ab)::t ->
+ if x =? a then t
+ else if x <? a then l else
+ let t' = undefine_list x t in
+ if t' == t then l else ab::t'
+ | [] -> [] in
+ fun x ->
+ let k = Hashtbl.hash x in
+ let rec und t =
+ match t with
+ Leaf(h,l) when h = k ->
+ let l' = undefine_list x l in
+ if l' == l then t
+ else if l' = [] then Empty
+ else Leaf(h,l')
+ | Branch(p,b,l,r) when k land (b - 1) = p ->
+ if k land b = 0 then
+ let l' = und l in
+ if l' == l then t
+ else if is_undefined l' then r
+ else Branch(p,b,l',r)
+ else
+ let r' = und r in
+ if r' == r then t
+ else if is_undefined r' then l
+ else Branch(p,b,l,r')
+ | _ -> t in
+ und;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Mapping to sorted-list representation of the graph, domain and range. *)
+(* ------------------------------------------------------------------------- *)
+
+let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);;
+
+let dom f = setify(foldl (fun a x y -> x::a) [] f);;
+
+let ran f = setify(foldl (fun a x y -> y::a) [] f);;
+
+(* ------------------------------------------------------------------------- *)
+(* More parser basics. *)
+(* ------------------------------------------------------------------------- *)
+
+exception Noparse;;
+
+
+let isspace,issep,isbra,issymb,isalpha,isnum,isalnum =
+ let charcode s = Char.code(String.get s 0) in
+ let spaces = " \t\n\r"
+ and separators = ",;"
+ and brackets = "()[]{}"
+ and symbs = "\\!@#$%^&*-+|\\<=>/?~.:"
+ and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ and nums = "0123456789" in
+ let allchars = spaces^separators^brackets^symbs^alphas^nums in
+ let csetsize = itlist ((o) max charcode) (explode allchars) 256 in
+ let ctable = Array.make csetsize 0 in
+ do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces);
+ do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators);
+ do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets);
+ do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs);
+ do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas);
+ do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums);
+ let isspace c = Array.get ctable (charcode c) = 1
+ and issep c = Array.get ctable (charcode c) = 2
+ and isbra c = Array.get ctable (charcode c) = 4
+ and issymb c = Array.get ctable (charcode c) = 8
+ and isalpha c = Array.get ctable (charcode c) = 16
+ and isnum c = Array.get ctable (charcode c) = 32
+ and isalnum c = Array.get ctable (charcode c) >= 16 in
+ isspace,issep,isbra,issymb,isalpha,isnum,isalnum;;
+
+let (||) parser1 parser2 input =
+ try parser1 input
+ with Noparse -> parser2 input;;
+
+let (++) parser1 parser2 input =
+ let result1,rest1 = parser1 input in
+ let result2,rest2 = parser2 rest1 in
+ (result1,result2),rest2;;
+
+let rec many prs input =
+ try let result,next = prs input in
+ let results,rest = many prs next in
+ (result::results),rest
+ with Noparse -> [],input;;
+
+let (>>) prs treatment input =
+ let result,rest = prs input in
+ treatment(result),rest;;
+
+let fix err prs input =
+ try prs input
+ with Noparse -> failwith (err ^ " expected");;
+
+let rec listof prs sep err =
+ prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;
+
+let possibly prs input =
+ try let x,rest = prs input in [x],rest
+ with Noparse -> [],input;;
+
+let some p =
+ function
+ [] -> raise Noparse
+ | (h::t) -> if p h then (h,t) else raise Noparse;;
+
+let a tok = some (fun item -> item = tok);;
+
+let rec atleast n prs i =
+ (if n <= 0 then many prs
+ else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;;
+
+let finished input =
+ if input = [] then 0,input else failwith "Unparsed input";;
+
+(* ------------------------------------------------------------------------- *)
+
+let temp_path = ref Filename.temp_dir_name;;
+
+(* ------------------------------------------------------------------------- *)
+(* Convenient conversion between files and (lists of) strings. *)
+(* ------------------------------------------------------------------------- *)
+
+let strings_of_file filename =
+ let fd = try Pervasives.open_in filename
+ with Sys_error _ ->
+ failwith("strings_of_file: can't open "^filename) in
+ let rec suck_lines acc =
+ try let l = Pervasives.input_line fd in
+ suck_lines (l::acc)
+ with End_of_file -> rev acc in
+ let data = suck_lines [] in
+ (Pervasives.close_in fd; data);;
+
+let string_of_file filename =
+ end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);;
+
+let file_of_string filename s =
+ let fd = Pervasives.open_out filename in
+ output_string fd s; close_out fd;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Iterative deepening. *)
+(* ------------------------------------------------------------------------- *)
+
+let rec deepen f n =
+ try (*print_string "Searching with depth limit ";
+ print_int n; print_newline();*) f n
+ with Failure _ -> deepen f (n + 1);;
+
+exception TooDeep
+
+let deepen_until limit f n =
+ match compare limit 0 with
+ | 0 -> raise TooDeep
+ | -1 -> deepen f n
+ | _ ->
+ let rec d_until f n =
+ try(* if !debugging
+ then (print_string "Searching with depth limit ";
+ print_int n; print_newline()) ;*) f n
+ with Failure x ->
+ (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *)
+ if n = limit then raise TooDeep else d_until f (n + 1) in
+ d_until f n
diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml
new file mode 100644
index 00000000..fe481ecc
--- /dev/null
+++ b/plugins/micromega/sos_types.ml
@@ -0,0 +1,68 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* The type of positivstellensatz -- used to communicate with sos *)
+open Num
+
+type vname = string;;
+
+type term =
+| Zero
+| Const of Num.num
+| Var of vname
+| Inv of term
+| Opp of term
+| Add of (term * term)
+| Sub of (term * term)
+| Mul of (term * term)
+| Div of (term * term)
+| Pow of (term * int);;
+
+
+let rec output_term o t =
+ match t with
+ | Zero -> output_string o "0"
+ | Const n -> output_string o (string_of_num n)
+ | Var n -> Printf.fprintf o "v%s" n
+ | Inv t -> Printf.fprintf o "1/(%a)" output_term t
+ | Opp t -> Printf.fprintf o "- (%a)" output_term t
+ | Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2
+ | Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2
+ | Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2
+ | Div(t1,t2) -> Printf.fprintf o "(%a)/(%a)" output_term t1 output_term t2
+ | Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i
+(* ------------------------------------------------------------------------- *)
+(* Data structure for Positivstellensatz refutations. *)
+(* ------------------------------------------------------------------------- *)
+
+type positivstellensatz =
+ Axiom_eq of int
+ | Axiom_le of int
+ | Axiom_lt of int
+ | Rational_eq of num
+ | Rational_le of num
+ | Rational_lt of num
+ | Square of term
+ | Monoid of int list
+ | Eqmul of term * positivstellensatz
+ | Sum of positivstellensatz * positivstellensatz
+ | Product of positivstellensatz * positivstellensatz;;
+
+
+let rec output_psatz o = function
+ | Axiom_eq i -> Printf.fprintf o "Aeq(%i)" i
+ | Axiom_le i -> Printf.fprintf o "Ale(%i)" i
+ | Axiom_lt i -> Printf.fprintf o "Alt(%i)" i
+ | Rational_eq n -> Printf.fprintf o "eq(%s)" (string_of_num n)
+ | Rational_le n -> Printf.fprintf o "le(%s)" (string_of_num n)
+ | Rational_lt n -> Printf.fprintf o "lt(%s)" (string_of_num n)
+ | Square t -> Printf.fprintf o "(%a)^2" output_term t
+ | Monoid l -> Printf.fprintf o "monoid"
+ | Eqmul (t,ps) -> Printf.fprintf o "%a * %a" output_term t output_psatz ps
+ | Sum (t1,t2) -> Printf.fprintf o "%a + %a" output_psatz t1 output_psatz t2
+ | Product (t1,t2) -> Printf.fprintf o "%a * %a" output_psatz t1 output_psatz t2
diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget
new file mode 100644
index 00000000..30201308
--- /dev/null
+++ b/plugins/micromega/vo.itarget
@@ -0,0 +1,13 @@
+CheckerMaker.vo
+EnvRing.vo
+Env.vo
+OrderedRing.vo
+Psatz.vo
+QMicromega.vo
+Refl.vo
+RingMicromega.vo
+RMicromega.vo
+Tauto.vo
+VarMap.vo
+ZCoeff.vo
+ZMicromega.vo
diff --git a/plugins/nsatz/NsatzR.v b/plugins/nsatz/NsatzR.v
new file mode 100644
index 00000000..c68c9584
--- /dev/null
+++ b/plugins/nsatz/NsatzR.v
@@ -0,0 +1,407 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*
+ Tactic nsatz: proofs of polynomials equalities with variables in R.
+ Uses Hilbert Nullstellensatz and Buchberger algorithm.
+ Thanks to B.Gregoire and L.Thery for help on ring tactic,
+ and to B.Barras for modularization of the ocaml code.
+ Example: see test-suite/success/Nsatz.v
+ L.Pottier, june 2010
+*)
+
+Require Import List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Import RealField Rdefinitions Rfunctions RIneq DiscrR.
+Require Import Ring_polynom Ring_tac InitialRing.
+
+Declare ML Module "nsatz_plugin".
+
+Local Open Scope R_scope.
+
+Lemma psos_r1b: forall x y, x - y = 0 -> x = y.
+intros x y H; replace x with ((x - y) + y);
+ [rewrite H | idtac]; ring.
+Qed.
+
+Lemma psos_r1: forall x y, x = y -> x - y = 0.
+intros x y H; rewrite H; ring.
+Qed.
+
+Lemma nsatzR_not1: forall x y:R, x<>y -> exists z:R, z*(x-y)-1=0.
+intros.
+exists (1/(x-y)).
+field.
+unfold not.
+unfold not in H.
+intros.
+apply H.
+replace x with ((x-y)+y).
+rewrite H0.
+ring.
+ring.
+Qed.
+
+Lemma nsatzR_not1_0: forall x:R, x<>0 -> exists z:R, z*x-1=0.
+intros.
+exists (1/(x)).
+field.
+auto.
+Qed.
+
+
+Ltac equalities_to_goal :=
+ lazymatch goal with
+ | H: (@eq R ?x 0) |- _ => try revert H
+ | H: (@eq R 0 ?x) |- _ =>
+ try generalize (sym_equal H); clear H
+ | H: (@eq R ?x ?y) |- _ =>
+ try generalize (psos_r1 _ _ H); clear H
+ end.
+
+Lemma nsatzR_not2: 1<>0.
+auto with *.
+Qed.
+
+Lemma nsatzR_diff: forall x y:R, x<>y -> x-y<>0.
+intros.
+intro; apply H.
+replace x with (x-y+y) by ring.
+rewrite H0; ring.
+Qed.
+
+(* Removes x<>0 from hypothesis *)
+Ltac nsatzR_not_hyp:=
+ match goal with
+ | H: ?x<>?y |- _ =>
+ match y with
+ |0 =>
+ let H1:=fresh "Hnsatz" in
+ let y:=fresh "x" in
+ destruct (@nsatzR_not1_0 _ H) as (y,H1); clear H
+ |_ => generalize (@nsatzR_diff _ _ H); clear H; intro
+ end
+ end.
+
+Ltac nsatzR_not_goal :=
+ match goal with
+ | |- ?x<>?y :> R => red; intro; apply nsatzR_not2
+ | |- False => apply nsatzR_not2
+ end.
+
+Ltac nsatzR_begin :=
+ intros;
+ repeat nsatzR_not_hyp;
+ try nsatzR_not_goal;
+ try apply psos_r1b;
+ repeat equalities_to_goal.
+
+(* code de Benjamin *)
+
+Definition PolZ := Pol Z.
+Definition PEZ := PExpr Z.
+
+Definition P0Z : PolZ := @P0 Z 0%Z.
+
+Definition PolZadd : PolZ -> PolZ -> PolZ :=
+ @Padd Z 0%Z Zplus Zeq_bool.
+
+Definition PolZmul : PolZ -> PolZ -> PolZ :=
+ @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool.
+
+Definition PolZeq := @Peq Z Zeq_bool.
+
+Definition norm :=
+ @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+
+Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ :=
+ match la, lp with
+ | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp)
+ | _, _ => P0Z
+ end.
+
+Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) :=
+ match lla with
+ | List.nil => lp
+ | la::lla => compute_list lla ((mult_l la lp)::lp)
+ end.
+
+Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) :=
+ let (lla, lq) := certif in
+ let lp := List.map norm lpe in
+ PolZeq (norm qe) (mult_l lq (compute_list lla lp)).
+
+
+(* Correction *)
+Definition PhiR : list R -> PolZ -> R :=
+ (Pphi 0 Rplus Rmult (gen_phiZ 0 1 Rplus Rmult Ropp)).
+
+Definition PEevalR : list R -> PEZ -> R :=
+ PEeval 0 Rplus Rmult Rminus Ropp (gen_phiZ 0 1 Rplus Rmult Ropp)
+ Nnat.nat_of_N pow.
+
+Lemma P0Z_correct : forall l, PhiR l P0Z = 0.
+Proof. trivial. Qed.
+
+
+Lemma PolZadd_correct : forall P' P l,
+ PhiR l (PolZadd P P') = (PhiR l P + PhiR l P').
+Proof.
+ refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (F_R Rfield))
+ (gen_phiZ_morph Rset Rext (F_R Rfield))).
+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 (F_R Rfield))
+ (gen_phiZ_morph Rset Rext (F_R Rfield))).
+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 (F_R Rfield))
+ (gen_phiZ_morph Rset Rext (F_R Rfield)) R_power_theory) with (lmp:= List.nil).
+ compute;trivial.
+Qed.
+
+Lemma PolZeq_correct : forall P P' l,
+ PolZeq P P' = true ->
+ PhiR l P = PhiR l P'.
+Proof.
+ intros;apply
+ (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (F_R Rfield)));trivial.
+Qed.
+
+Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
+ match l with
+ | List.nil => True
+ | a::l => Interp a = 0 /\ Cond0 A Interp l
+ end.
+
+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;trivial.
+ destruct lp;trivial.
+ simpl in H;destruct H.
+ rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring | trivial].
+Qed.
+
+Lemma compute_list_correct : forall l lla lp,
+ Cond0 PolZ (PhiR l) lp ->
+ Cond0 PolZ (PhiR l) (compute_list lla lp).
+Proof.
+ induction lla;simpl;intros;trivial.
+ apply IHlla;simpl;split;trivial.
+ apply mult_l_correct;trivial.
+Qed.
+
+Lemma check_correct :
+ forall l lpe qe certif,
+ check lpe qe certif = true ->
+ Cond0 PEZ (PEevalR l) lpe ->
+ PEevalR l qe = 0.
+Proof.
+ unfold check;intros l lpe qe (lla, lq) H2 H1.
+ apply PolZeq_correct with (l:=l) in H2.
+ rewrite norm_correct, H2.
+ apply mult_l_correct.
+ apply compute_list_correct.
+ clear H2 lq lla qe;induction lpe;simpl;trivial.
+ simpl in H1;destruct H1.
+ rewrite <- norm_correct;auto.
+Qed.
+
+(* fin du code de Benjamin *)
+
+Lemma nsatzR_l3:forall c p r, ~c=0 -> c*p^r=0 -> p=0.
+intros.
+elim (Rmult_integral _ _ H0);intros.
+ absurd (c=0);auto.
+
+ clear H0; induction r; simpl in *.
+ contradict H1; discrR.
+
+ elim (Rmult_integral _ _ H1); auto.
+Qed.
+
+
+Ltac generalise_eq_hyps:=
+ repeat
+ (match goal with
+ |h : (?p = ?q)|- _ => revert h
+ end).
+
+Ltac lpol_goal t :=
+ match t with
+ | ?a = 0 -> ?b =>
+ let r:= lpol_goal b in
+ constr:(a::r)
+ | ?a = 0 => constr:(a::nil)
+ end.
+
+Fixpoint IPR p {struct p}: R :=
+ match p with
+ xH => 1
+ | xO xH => 1 + 1
+ | xO p1 => 2 * (IPR p1)
+ | xI xH => 1 + (1 + 1)
+ | xI p1 => 1 + 2 * (IPR p1)
+ end.
+
+Definition IZR1 z :=
+ match z with Z0 => 0
+ | Zpos p => 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 (v1 + v2)
+ | (PEmul t1 t2) =>
+ let v1 := interpret3 t1 fv in
+ let v2 := interpret3 t2 fv in (v1 * v2)
+ | (PEsub t1 t2) =>
+ let v1 := interpret3 t1 fv in
+ let v2 := interpret3 t2 fv in (v1 - v2)
+ | (PEopp t1) =>
+ let v1 := interpret3 t1 fv in (-v1)
+ | (PEpow t1 t2) =>
+ let v1 := interpret3 t1 fv in v1 ^(Nnat.nat_of_N t2)
+ | (PEc t1) => (IZR1 t1)
+ | (PEX n) => List.nth (pred (nat_of_P n)) fv 0
+ end.
+
+(* lp est incluse dans fv. La met en tete. *)
+
+Ltac parametres_en_tete fv lp :=
+ match fv with
+ | (@nil _) => lp
+ | (@cons _ ?x ?fv1) =>
+ let res := AddFvTail x lp in
+ parametres_en_tete fv1 res
+ end.
+
+Ltac append1 a l :=
+ match l with
+ | (@nil _) => constr:(cons a l)
+ | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l')
+ end.
+
+Ltac rev l :=
+ match l with
+ |(@nil _) => l
+ | (cons ?x ?l) => let l' := rev l in append1 x l'
+ end.
+
+
+Ltac nsatz_call_n info nparam p rr lp kont :=
+ nsatz_compute (PEc info :: PEc nparam :: PEpow p rr :: lp);
+ match goal with
+ | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
+ intros _;
+ set (lci:=lci0);
+ set (lq:=lq0);
+ kont c rr lq lci
+ end.
+
+Ltac nsatz_call radicalmax info nparam p lp kont :=
+ let rec try_n n :=
+ lazymatch n with
+ | 0%N => fail
+ | _ =>
+(* idtac "Trying power: " n;*)
+ (let r := eval compute in (Nminus radicalmax (Npred n)) in
+ nsatz_call_n info nparam p r lp kont) ||
+ let n' := eval compute in (Npred n) in try_n n'
+ end in
+ try_n radicalmax.
+
+
+Ltac nsatzR_gen radicalmax info lparam lvar n RNG lH _rl :=
+ get_Pre RNG ();
+ let mkFV := Ring_tac.get_RingFV RNG in
+ let mkPol := Ring_tac.get_RingMeta RNG in
+ generalise_eq_hyps;
+ let t := Get_goal in
+ let lpol := lpol_goal t in
+ intros;
+ let fv :=
+ match lvar with
+ | nil =>
+ let fv1 := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in
+ let fv1 := list_fold_right mkFV fv1 lpol in
+ rev fv1
+ (* heuristique: les dernieres variables auront le poid le plus fort *)
+ | _ => lvar
+ end in
+ check_fv fv;
+ (*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;*)
+ let lpol := list_fold_right
+ ltac:(fun p l => let p' := mkPol p fv in constr:(p'::l))
+ (@nil (PExpr Z))
+ lpol in
+ let lpol := eval compute in (List.rev lpol) in
+ (*idtac lpol;*)
+ let SplitPolyList kont :=
+ match lpol with
+ | ?p2::?lp2 => kont p2 lp2
+ | _ => idtac "polynomial not in the ideal"
+ end in
+ SplitPolyList ltac:(fun p lp =>
+ set (p21:=p) ;
+ set (lp21:=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: interpret3 q fv = 0);
+ [ simpl; apply (@check_correct fv lp21 q (lci,lq) Hg); simpl;
+ repeat (split;[assumption|idtac]); exact I
+ | simpl in Hg2; simpl;
+ apply nsatzR_l3 with (interpret3 c fv) (Nnat.nat_of_N r);simpl;
+ [ discrR || idtac "could not prove discrimination result"
+ | exact Hg2]
+ ]
+ ])).
+
+Ltac nsatzRpv radicalmax info lparam lvar:=
+ nsatzR_begin;
+ intros;
+ let G := Get_goal in
+ ring_lookup
+ (PackRing ltac:(nsatzR_gen radicalmax info lparam lvar ring_subst_niter))
+ [] G.
+
+Ltac nsatzR := nsatzRpv 6%N 1%Z (@nil R) (@nil R).
+Ltac nsatzRradical radicalmax := nsatzRpv radicalmax 1%Z (@nil R) (@nil R).
+Ltac nsatzRparameters lparam := nsatzRpv 6%N 1%Z lparam (@nil R).
+
+Tactic Notation "nsatz" := nsatzR.
+Tactic Notation "nsatz" "with" "lexico" :=
+ nsatzRpv 6%N 2%Z (@nil R) (@nil R).
+Tactic Notation "nsatz" "with" "lexico" "sugar":=
+ nsatzRpv 6%N 3%Z (@nil R) (@nil R).
+Tactic Notation "nsatz" "without" "sugar":=
+ nsatzRpv 6%N 0%Z (@nil R) (@nil R).
+
+
diff --git a/plugins/nsatz/NsatzZ.v b/plugins/nsatz/NsatzZ.v
new file mode 100644
index 00000000..a65efac2
--- /dev/null
+++ b/plugins/nsatz/NsatzZ.v
@@ -0,0 +1,73 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Import Reals ZArith.
+Require Export NsatzR.
+
+Open Scope Z_scope.
+
+Lemma nsatzZhypR: forall x y:Z, x=y -> IZR x = IZR y.
+Proof IZR_eq. (* or f_equal ... *)
+
+Lemma nsatzZconclR: forall x y:Z, IZR x = IZR y -> x = y.
+Proof eq_IZR.
+
+Lemma nsatzZhypnotR: forall x y:Z, x<>y -> IZR x <> IZR y.
+Proof IZR_neq.
+
+Lemma nsatzZconclnotR: forall x y:Z, IZR x <> IZR y -> x <> y.
+Proof.
+intros x y H. contradict H. f_equal. assumption.
+Qed.
+
+Ltac nsatzZtoR1 :=
+ repeat
+ (match goal with
+ | H:(@eq Z ?x ?y) |- _ =>
+ generalize (@nsatzZhypR _ _ H); clear H; intro H
+ | |- (@eq Z ?x ?y) => apply nsatzZconclR
+ | H:not (@eq Z ?x ?y) |- _ =>
+ generalize (@nsatzZhypnotR _ _ H); clear H; intro H
+ | |- not (@eq Z ?x ?y) => apply nsatzZconclnotR
+ end).
+
+Lemma nsatzZR1: forall x y:Z, IZR(x+y) = (IZR x + IZR y)%R.
+Proof plus_IZR.
+
+Lemma nsatzZR2: forall x y:Z, IZR(x*y) = (IZR x * IZR y)%R.
+Proof mult_IZR.
+
+Lemma nsatzZR3: forall x y:Z, IZR(x-y) = (IZR x - IZR y)%R.
+Proof.
+intros; symmetry. apply Z_R_minus.
+Qed.
+
+Lemma nsatzZR4: forall (x:Z) p, IZR(x ^ Zpos p) = (IZR x ^ nat_of_P p)%R.
+Proof.
+intros. rewrite pow_IZR.
+do 2 f_equal.
+apply Zpos_eq_Z_of_nat_o_nat_of_P.
+Qed.
+
+Ltac nsatzZtoR2:=
+ repeat
+ (rewrite nsatzZR1 in * ||
+ rewrite nsatzZR2 in * ||
+ rewrite nsatzZR3 in * ||
+ rewrite nsatzZR4 in *).
+
+Ltac nsatzZ_begin :=
+ intros;
+ nsatzZtoR1;
+ nsatzZtoR2;
+ simpl in *.
+ (*cbv beta iota zeta delta [nat_of_P Pmult_nat plus mult] in *.*)
+
+Ltac nsatzZ :=
+ nsatzZ_begin; (*idtac "nsatzZ_begin;";*)
+ nsatzR.
diff --git a/plugins/nsatz/Nsatz_domain.v b/plugins/nsatz/Nsatz_domain.v
new file mode 100644
index 00000000..11f905f9
--- /dev/null
+++ b/plugins/nsatz/Nsatz_domain.v
@@ -0,0 +1,558 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*
+ Tactic nsatz: proofs of polynomials equalities with variables in R.
+ Uses Hilbert Nullstellensatz and Buchberger algorithm.
+ Thanks to B.Gregoire for the verification of the certicate
+ and L.Thery for help on ring tactic,
+ and to B.Barras for modularization of the ocaml code.
+ Example: see test-suite/success/Nsatz.v
+ L.Pottier, june 2010
+*)
+
+Require Import List.
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinList.
+Require Import Znumtheory.
+Require Import Ring_polynom Ring_tac InitialRing.
+
+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_ring:
+ ring_theory ring0 ring1 ring_plus ring_mult ring_sub
+ ring_opp (@eq R)}.
+
+Class Domain (R : Type) := {
+ domain_ring:> Ring R;
+ domain_axiom_product:
+ forall x y, ring_mult x y = ring0 -> x = ring0 \/ y = ring0;
+ domain_axiom_one_zero: ring1 <> ring0}.
+
+Ltac ring2 := simpl; ring.
+
+Section domain.
+
+Variable R: Type.
+Variable Rd: Domain R.
+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}.
+
+Lemma psos_r1b: forall x y:R, x - y = 0 -> x = y.
+intros x y H; replace x with ((x - y) + y);
+ [rewrite H | idtac]; ring2.
+Qed.
+
+Lemma psos_r1: forall x y, x = y -> x - y = 0.
+intros x y H; rewrite H; ring2.
+Qed.
+
+
+Lemma nsatzR_diff: forall x y:R, x<>y -> x - y<>0.
+intros.
+intro; apply H.
+replace x with ((x - y) + y) by ring2.
+rewrite H0; ring2.
+Qed.
+
+(* code de Benjamin *)
+Require Import ZArith.
+
+Definition PolZ := Pol Z.
+Definition PEZ := PExpr Z.
+
+Definition P0Z : PolZ := @P0 Z 0%Z.
+
+Definition PolZadd : PolZ -> PolZ -> PolZ :=
+ @Padd Z 0%Z Zplus Zeq_bool.
+
+Definition PolZmul : PolZ -> PolZ -> PolZ :=
+ @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool.
+
+Definition PolZeq := @Peq Z Zeq_bool.
+
+Definition norm :=
+ @norm_aux Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
+
+Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ :=
+ match la, lp with
+ | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp)
+ | _, _ => P0Z
+ end.
+
+Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) :=
+ match lla with
+ | List.nil => lp
+ | la::lla => compute_list lla ((mult_l la lp)::lp)
+ end.
+
+Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) :=
+ let (lla, lq) := certif in
+ let lp := List.map norm lpe in
+ PolZeq (norm qe) (mult_l lq (compute_list lla lp)).
+
+
+(* 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).
+
+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.
+
+Lemma P0Z_correct : forall l, PhiR l P0Z = 0.
+Proof. trivial. Qed.
+
+Lemma Rext: ring_eq_ext ring_plus ring_mult ring_opp eq.
+apply mk_reqe. intros. rewrite H; rewrite H0; trivial.
+ intros. rewrite H; rewrite H0; trivial.
+intros. rewrite H; trivial. Qed.
+
+Lemma Rset : Setoid_Theory R eq.
+apply Eqsth.
+Qed.
+
+Lemma PolZadd_correct : forall P' P l,
+ PhiR l (PolZadd P P') = ((PhiR l P) + (PhiR l P')).
+Proof.
+ refine (Padd_ok Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
+ (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd)))).
+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)))).
+Qed.
+
+Lemma R_power_theory
+ : power_theory 1 ring_mult eq Nnat.nat_of_N pow.
+apply mkpow_th. unfold pow. intros. rewrite Nnat.N_of_nat_of_N. trivial. Qed.
+
+Lemma norm_correct :
+ forall (l : list R) (pe : PEZ), PEevalR l pe = PhiR l (norm pe).
+Proof.
+ intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext (@ring_ring _ (@domain_ring _ Rd)))
+ (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))) R_power_theory)
+ with (lmp:= List.nil).
+ compute;trivial.
+Qed.
+
+Lemma PolZeq_correct : forall P P' l,
+ PolZeq P P' = true ->
+ PhiR l P = PhiR l P'.
+Proof.
+ intros;apply
+ (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (@ring_ring _ (@domain_ring _ Rd))));trivial.
+Qed.
+
+Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
+ match l with
+ | List.nil => True
+ | a::l => Interp a = 0 /\ Cond0 A Interp l
+ end.
+
+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;trivial.
+ destruct lp;trivial.
+ simpl in H;destruct H.
+ rewrite PolZadd_correct, PolZmul_correct, H, IHla;[ring2 | trivial].
+Qed.
+
+Lemma compute_list_correct : forall l lla lp,
+ Cond0 PolZ (PhiR l) lp ->
+ Cond0 PolZ (PhiR l) (compute_list lla lp).
+Proof.
+ induction lla;simpl;intros;trivial.
+ apply IHlla;simpl;split;trivial.
+ apply mult_l_correct;trivial.
+Qed.
+
+Lemma check_correct :
+ forall l lpe qe certif,
+ check lpe qe certif = true ->
+ Cond0 PEZ (PEevalR l) lpe ->
+ PEevalR l qe = 0.
+Proof.
+ unfold check;intros l lpe qe (lla, lq) H2 H1.
+ apply PolZeq_correct with (l:=l) in H2.
+ rewrite norm_correct, H2.
+ apply mult_l_correct.
+ apply compute_list_correct.
+ clear H2 lq lla qe;induction lpe;simpl;trivial.
+ simpl in H1;destruct H1.
+ rewrite <- norm_correct;auto.
+Qed.
+
+(* fin du code de Benjamin *)
+
+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. 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; try ring2. simpl.
+ rewrite pow_pos_Psucc. trivial. exact Rset.
+ intros. rewrite H; rewrite H0; trivial.
+ intros. ring2. intros. ring2. Qed.
+
+Lemma Rdomain_pow: forall c p r, ~c= 0 -> c * (pow p r)= 0 -> p = ring0.
+intros. case (@domain_axiom_product _ _ _ _ H0). intros; absurd (c = 0); auto.
+intros. apply pow_not_zero with r. trivial. Qed.
+
+Definition R2:= 1 + 1.
+
+Fixpoint IPR p {struct p}: R :=
+ match p with
+ xH => 1
+ | 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 => 0
+ | Zpos p => 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 (v1 + v2)
+ | (PEmul t1 t2) =>
+ let v1 := interpret3 t1 fv in
+ let v2 := interpret3 t2 fv in (v1 * v2)
+ | (PEsub t1 t2) =>
+ let v1 := interpret3 t1 fv in
+ let v2 := interpret3 t2 fv in (v1 - v2)
+ | (PEopp t1) =>
+ let v1 := interpret3 t1 fv in (- v1)
+ | (PEpow t1 t2) =>
+ let v1 := interpret3 t1 fv in pow v1 (Nnat.nat_of_N t2)
+ | (PEc t1) => (IZR1 t1)
+ | (PEX n) => List.nth (pred (nat_of_P n)) fv 0
+ end.
+
+
+End domain.
+
+Ltac equalities_to_goal :=
+ lazymatch goal with
+ | H: (@eq _ ?x 0) |- _ => try revert H
+ | H: (@eq _ 0 ?x) |- _ =>
+ try generalize (sym_equal H); clear H
+ | H: (@eq _ ?x ?y) |- _ =>
+ try generalize (@psos_r1 _ _ _ _ H); clear H
+ 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 : (?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 :=
+ match fv with
+ | (@nil _) => lp
+ | (@cons _ ?x ?fv1) =>
+ let res := AddFvTail x lp in
+ parametres_en_tete fv1 res
+ end.
+
+Ltac append1 a l :=
+ match l with
+ | (@nil _) => constr:(cons a l)
+ | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l')
+ end.
+
+Ltac rev l :=
+ match l with
+ |(@nil _) => l
+ | (cons ?x ?l) => let l' := rev l in append1 x l'
+ end.
+
+Ltac nsatz_call_n info nparam p rr lp kont :=
+ let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in
+ nsatz_compute ll;
+ match goal with
+ | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
+ intros _;
+ set (lci:=lci0);
+ set (lq:=lq0);
+ kont c rr lq lci
+ end.
+
+Ltac nsatz_call radicalmax info nparam p lp kont :=
+ let rec try_n n :=
+ lazymatch n with
+ | 0%N => fail
+ | _ =>
+(* idtac "Trying power: " n;*)
+ (let r := eval compute in (Nminus radicalmax (Npred n)) in
+ nsatz_call_n info nparam p r lp kont) ||
+ let n' := eval compute in (Npred n) in try_n n'
+ end in
+ try_n radicalmax.
+
+
+Set Implicit Arguments.
+Class Cclosed_seq T (l:list T) := {}.
+Instance Iclosed_nil T : Cclosed_seq (T:=T) nil.
+Instance Iclosed_cons T t l `{Cclosed_seq (T:=T) l} : Cclosed_seq (T:=T) (t::l).
+
+Class Cfind_at (R:Type) (b:R) (l:list R) (i:nat) := {}.
+Instance Ifind0 (R:Type) (b:R) l: Cfind_at b (b::l) 0.
+Instance IfindS (R:Type) (b2 b1:R) l i `{Cfind_at R b1 l i} : Cfind_at b1 (b2::l) (S i) | 1.
+Definition Ifind0' := Ifind0.
+Definition IfindS' := IfindS.
+
+Definition li_find_at (R:Type) (b:R) l i `{Cfind_at R b l i} {H:Cclosed_seq (T:=R) l} := (l,i).
+
+Class Creify (R:Type) (e:PExpr Z) (l:list R) (b:R) := {}.
+Instance Ireify_zero (R:Type) (Rd:Domain R) l : Creify (PEc 0%Z) l ring0.
+Instance Ireify_one (R:Type) (Rd:Domain R) l : Creify (PEc 1%Z) l ring1.
+Instance Ireify_plus (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+ : Creify (PEadd e1 e2) l (ring_plus b1 b2).
+Instance Ireify_mult (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+ : Creify (PEmul e1 e2) l (ring_mult b1 b2).
+Instance Ireify_sub (R:Type) (Rd:Domain R) e1 l b1 e2 b2 `{Creify R e1 l b1} `{Creify R e2 l b2}
+ : Creify (PEsub e1 e2) l (ring_sub b1 b2).
+Instance Ireify_opp (R:Type) (Rd:Domain R) e1 l b1 `{Creify R e1 l b1}
+ : Creify (PEopp e1) l (ring_opp b1).
+Instance Ireify_var (R:Type) b l i `{Cfind_at R b l i}
+ : Creify (PEX _ (P_of_succ_nat i)) l b | 100.
+
+
+Class Creifylist (R:Type) (le:list (PExpr Z)) (l:list R) (lb:list R) := {}.
+Instance Creify_nil (R:Type) l : Creifylist nil l (@nil R).
+Instance Creify_cons (R:Type) e1 l b1 le2 lb2 `{Creify R e1 l b1} `{Creifylist R le2 l lb2}
+ : Creifylist (e1::le2) l (b1::lb2).
+
+Definition li_reifyl (R:Type) le l lb `{Creifylist R le l lb}
+ {H:Cclosed_seq (T:=R) l} := (l,le).
+
+Unset Implicit Arguments.
+
+Ltac lterm_goal g :=
+ match g with
+ ?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:=
+ match le with
+ nil => idtac
+ | ?e::?le1 =>
+ match lb with
+ ?b::?lb1 =>
+ let x := fresh "B" in
+ set (x:= b) at 1;
+ change x with (@interpret3 _ _ e l);
+ clear x;
+ reify_goal l le1 lb1
+ end
+ end.
+
+Ltac get_lpol g :=
+ match g with
+ (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;
+ 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;
+
+ 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; *)
+ 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: interpret3 _ _ q fv = ring0);
+ [ tacsimpl;
+ apply (@check_correct _ Rd fv lp21 q (lci,lq) Hg);
+ tacsimpl;
+ repeat (split;[assumption|idtac]); exact I
+ | simpl in Hg2; tacsimpl;
+ apply Rdomain_pow with (interpret3 _ _ c fv) (Nnat.nat_of_N r); tacsimpl;
+ [ apply domain_axiom_one_zero || idtac "could not prove discrimination result"
+ | exact Hg2]
+ ]
+ ]
+)
+)
+end end end end .
+
+Ltac nsatz_domainpv radicalmax info lparam lvar tacsimpl rd:=
+ nsatz_domain_begin tacsimpl;
+ nsatz_domain_generic radicalmax info lparam lvar tacsimpl rd.
+
+Ltac nsatz_domain:=
+ intros;
+ match goal with
+ |- (@eq ?r _ _ ) =>
+ let a := constr:(@Ireify_zero _ _ (@nil r)) in
+ match a with
+ (@Ireify_zero _ ?rd _) =>
+ nsatz_domainpv 6%N 1%Z (@nil r) (@nil r) ltac:(simpl) rd
+ end
+ end.
+
+
+
+(* 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_ring := Zth}.
+
+Lemma Zaxiom_one_zero: 1%Z <> 0%Z.
+discriminate.
+Qed.
+
+Instance Zdi : Domain Z := {
+ domain_ring := Zri;
+ domain_axiom_product := Zmult_integral;
+ domain_axiom_one_zero := Zaxiom_one_zero}.
+
+
+Ltac simplZ:=
+ simpl;
+replace 0%Z with (@ring0 _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace 1%Z with (@ring1 _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zplus with (@ring_plus _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zmult with (@ring_mult _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zminus with (@ring_sub _ (@domain_ring _ Zdi));[idtac|reflexivity];
+replace Zopp with (@ring_opp _ (@domain_ring _ Zdi));[idtac|reflexivity].
+
+Ltac nsatz_domainZ:= nsatz_domainpv 6%N 1%Z (@nil Z) (@nil Z) ltac:simplZ Zdi.
+
+
+(* Dans R *)
+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_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}.
+
+
+Ltac simplR:=
+ simpl;
+replace 0%R with (@ring0 _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace 1%R with (@ring1 _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Rplus with (@ring_plus _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Rmult with (@ring_mult _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Rminus with (@ring_sub _ (@domain_ring _ Rdi));[idtac|reflexivity];
+replace Ropp with (@ring_opp _ (@domain_ring _ Rdi));[idtac|reflexivity].
+
+Ltac nsatz_domainR:= nsatz_domainpv 6%N 1%Z (@List.nil R) (@List.nil R) ltac:simplR Rdi.
diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml
new file mode 100644
index 00000000..b91f01d1
--- /dev/null
+++ b/plugins/nsatz/ideal.ml
@@ -0,0 +1,1057 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Nullstellensatz with Groebner basis computation
+
+We use a sparse representation for polynomials:
+a monomial is an array of exponents (one for each variable)
+with its degree in head
+a polynomial is a sorted list of (coefficient, monomial)
+
+ *)
+
+open Utile
+open List
+
+exception NotInIdeal
+
+module type S = sig
+
+(* Monomials *)
+type mon = int array
+
+val mult_mon : mon -> mon -> mon
+val deg : mon -> int
+val compare_mon : mon -> mon -> int
+val div_mon : mon -> mon -> mon
+val div_mon_test : mon -> mon -> bool
+val ppcm_mon : mon -> mon -> mon
+
+(* Polynomials *)
+
+type deg = int
+type coef
+type poly
+type polynom
+
+val repr : poly -> (coef * mon) list
+val polconst : coef -> poly
+val zeroP : poly
+val gen : int -> poly
+
+val equal : poly -> poly -> bool
+val name_var : string list ref
+val getvar : string list -> int -> string
+val lstringP : poly list -> string
+val printP : poly -> unit
+val lprintP : poly list -> unit
+
+val div_pol_coef : poly -> coef -> poly
+val plusP : poly -> poly -> poly
+val mult_t_pol : coef -> mon -> poly -> poly
+val selectdiv : mon -> poly list -> poly
+val oppP : poly -> poly
+val emultP : coef -> poly -> poly
+val multP : poly -> poly -> poly
+val puisP : poly -> int -> poly
+val contentP : poly -> coef
+val contentPlist : poly list -> coef
+val pgcdpos : coef -> coef -> coef
+val div_pol : poly -> poly -> coef -> coef -> mon -> poly
+val reduce2 : poly -> poly list -> coef * poly
+
+val poldepcontent : coef list ref
+val coefpoldep_find : poly -> poly -> poly
+val coefpoldep_set : poly -> poly -> poly -> unit
+val initcoefpoldep : poly list -> unit
+val reduce2_trace : poly -> poly list -> poly list -> poly list * poly
+val spol : poly -> poly -> poly
+val etrangers : poly -> poly -> bool
+val div_ppcm : poly -> poly -> poly -> bool
+
+val genPcPf : poly -> poly list -> poly list -> poly list
+val genOCPf : poly list -> poly list
+
+val is_homogeneous : poly -> bool
+
+type certificate =
+ { coef : coef; power : int;
+ gb_comb : poly list list; last_comb : poly list }
+
+val test_dans_ideal : poly -> poly list -> poly list ->
+ poly list * poly * certificate
+val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate
+
+end
+
+(***********************************************************************
+ Global options
+*)
+let lexico = ref false
+let use_hmon = ref false
+
+(* division of tail monomials *)
+
+let reduire_les_queues = false
+
+(* divide first with new polynomials *)
+
+let nouveaux_pol_en_tete = false
+
+(***********************************************************************
+ Functor
+*)
+
+module Make (P:Polynom.S) = struct
+
+ type coef = P.t
+ let coef0 = P.of_num (Num.Int 0)
+ let coef1 = P.of_num (Num.Int 1)
+ let coefm1 = P.of_num (Num.Int (-1))
+ let string_of_coef c = "["^(P.to_string c)^"]"
+
+(***********************************************************************
+ Monomials
+ array of integers, first is the degree
+*)
+
+type mon = int array
+type deg = int
+type poly = (coef * mon) list
+type polynom =
+ {pol : poly ref;
+ num : int;
+ sugar : int}
+
+let nvar m = Array.length m - 1
+
+let deg m = m.(0)
+
+let mult_mon m m' =
+ let d = nvar m in
+ let m'' = Array.create (d+1) 0 in
+ for i=0 to d do
+ m''.(i)<- (m.(i)+m'.(i));
+ done;
+ m''
+
+
+let compare_mon m m' =
+ let d = nvar m in
+ if !lexico
+ then (
+ (* Comparaison de monomes avec ordre du degre lexicographique = on commence par regarder la 1ere variable*)
+ let res=ref 0 in
+ let i=ref 1 in (* 1 si lexico pur 0 si degre*)
+ while (!res=0) && (!i<=d) do
+ res:= (compare m.(!i) m'.(!i));
+ i:=!i+1;
+ done;
+ !res)
+ else (
+ (* degre lexicographique inverse *)
+ match compare m.(0) m'.(0) with
+ | 0 -> (* meme degre total *)
+ let res=ref 0 in
+ let i=ref d in
+ while (!res=0) && (!i>=1) do
+ res:= - (compare m.(!i) m'.(!i));
+ i:=!i-1;
+ done;
+ !res
+ | x -> x)
+
+let div_mon m m' =
+ let d = nvar m in
+ let m'' = Array.create (d+1) 0 in
+ for i=0 to d do
+ m''.(i)<- (m.(i)-m'.(i));
+ done;
+ m''
+
+let div_pol_coef p c =
+ List.map (fun (a,m) -> (P.divP a c,m)) p
+
+(* m' divides m *)
+let div_mon_test m m' =
+ let d = nvar m in
+ let res=ref true in
+ let i=ref 0 in (*il faut que le degre total soit bien mis sinon, i=ref 1*)
+ while (!res) && (!i<=d) do
+ res:= (m.(!i) >= m'.(!i));
+ i:=succ !i;
+ done;
+ !res
+
+let set_deg m =
+ let d = nvar m in
+ m.(0)<-0;
+ for i=1 to d do
+ m.(0)<- m.(i)+m.(0);
+ done;
+ m
+
+(* lcm *)
+let ppcm_mon m m' =
+ let d = nvar m in
+ let m'' = Array.create (d+1) 0 in
+ for i=1 to d do
+ m''.(i)<- (max m.(i) m'.(i));
+ done;
+ set_deg m''
+
+
+
+(**********************************************************************
+ Polynomials
+ list of (coefficient, monomial) decreasing order
+*)
+
+let repr p = p
+
+let equal =
+ Util.list_for_all2eq
+ (fun (c1,m1) (c2,m2) -> P.equal c1 c2 && m1=m2)
+
+let hash p =
+ let c = map fst p in
+ let m = map snd p in
+ fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c
+
+module Hashpol = Hashtbl.Make(
+ struct
+ type t = poly
+ let equal = equal
+ let hash = hash
+ end)
+
+
+(* A pretty printer for polynomials, with Maple-like syntax. *)
+
+open Format
+
+let getvar lv i =
+ try (nth lv i)
+ with _ -> (fold_left (fun r x -> r^" "^x) "lv= " lv)
+ ^" i="^(string_of_int i)
+
+let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef
+ dimmon string_of_exp lvar p =
+
+
+ let rec string_of_mon m coefone =
+ let s=ref [] in
+ for i=1 to (dimmon m) do
+ (match (string_of_exp m i) with
+ "0" -> ()
+ | "1" -> s:= (!s) @ [(getvar !lvar (i-1))]
+ | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]);
+ done;
+ (match !s with
+ [] -> if coefone
+ then "1"
+ else ""
+ | l -> if coefone
+ then (String.concat "*" l)
+ else ( "*" ^
+ (String.concat "*" l)))
+ and string_of_term t start = let a = coefterm t and m = monterm t in
+ match (string_of_coef a) with
+ "0" -> ""
+ | "1" ->(match start with
+ true -> string_of_mon m true
+ |false -> ( "+ "^
+ (string_of_mon m true)))
+ | "-1" ->( "-" ^" "^(string_of_mon m true))
+ | c -> if (String.get c 0)='-'
+ then ( "- "^
+ (String.sub c 1
+ ((String.length c)-1))^
+ (string_of_mon m false))
+ else (match start with
+ true -> ( c^(string_of_mon m false))
+ |false -> ( "+ "^
+ c^(string_of_mon m false)))
+ and stringP p start =
+ if (zeroP p)
+ then (if start
+ then ("0")
+ else "")
+ else ((string_of_term (hdP p) start)^
+ " "^
+ (stringP (tlP p) false))
+ in
+ (stringP p true)
+
+
+
+let print_pol zeroP hdP tlP coefterm monterm string_of_coef
+ dimmon string_of_exp lvar p =
+
+ let rec print_mon m coefone =
+ let s=ref [] in
+ for i=1 to (dimmon m) do
+ (match (string_of_exp m i) with
+ "0" -> ()
+ | "1" -> s:= (!s) @ [(getvar !lvar (i-1))]
+ | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]);
+ done;
+ (match !s with
+ [] -> if coefone
+ then print_string "1"
+ else ()
+ | l -> if coefone
+ then print_string (String.concat "*" l)
+ else (print_string "*";
+ print_string (String.concat "*" l)))
+ and print_term t start = let a = coefterm t and m = monterm t in
+ match (string_of_coef a) with
+ "0" -> ()
+ | "1" ->(match start with
+ true -> print_mon m true
+ |false -> (print_string "+ ";
+ print_mon m true))
+ | "-1" ->(print_string "-";print_space();print_mon m true)
+ | c -> if (String.get c 0)='-'
+ then (print_string "- ";
+ print_string (String.sub c 1
+ ((String.length c)-1));
+ print_mon m false)
+ else (match start with
+ true -> (print_string c;print_mon m false)
+ |false -> (print_string "+ ";
+ print_string c;print_mon m false))
+ and printP p start =
+ if (zeroP p)
+ then (if start
+ then print_string("0")
+ else ())
+ else (print_term (hdP p) start;
+ if start then open_hovbox 0;
+ print_space();
+ print_cut();
+ printP (tlP p) false)
+ in open_hovbox 3;
+ printP p true;
+ print_flush()
+
+
+let name_var= ref []
+
+let stringP p =
+ string_of_pol
+ (fun p -> match p with [] -> true | _ -> false)
+ (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal")
+ (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal")
+ (fun (a,m) -> a)
+ (fun (a,m) -> m)
+ string_of_coef
+ (fun m -> (Array.length m)-1)
+ (fun m i -> (string_of_int (m.(i))))
+ name_var
+ p
+
+let nsP2 = ref max_int
+
+let stringPcut p =
+ (*Polynomesrec.nsP1:=20;*)
+ nsP2:=10;
+ let res =
+ if (length p)> !nsP2
+ then (stringP [hd p])^" + "^(string_of_int (length p))^" termes"
+ else stringP p in
+ (*Polynomesrec.nsP1:= max_int;*)
+ nsP2:= max_int;
+ res
+
+let rec lstringP l =
+ match l with
+ [] -> ""
+ |p::l -> (stringP p)^("\n")^(lstringP l)
+
+let printP = print_pol
+ (fun p -> match p with [] -> true | _ -> false)
+ (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal")
+ (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal")
+ (fun (a,m) -> a)
+ (fun (a,m) -> m)
+ string_of_coef
+ (fun m -> (Array.length m)-1)
+ (fun m i -> (string_of_int (m.(i))))
+ name_var
+
+
+let rec lprintP l =
+ match l with
+ [] -> ()
+ |p::l -> printP p;print_string "\n"; lprintP l
+
+
+(* Operations *)
+
+let zeroP = []
+
+(* returns a constant polynom ial with d variables *)
+let polconst d c =
+ let m = Array.create (d+1) 0 in
+ let m = set_deg m in
+ [(c,m)]
+
+let plusP p q =
+ let rec plusP p q =
+ match p with
+ [] -> q
+ |t::p' ->
+ match q with
+ [] -> p
+ |t'::q' ->
+ match compare_mon (snd t) (snd t') with
+ 1 -> t::(plusP p' q)
+ |(-1) -> t'::(plusP p q')
+ |_ -> let c=P.plusP (fst t) (fst t') in
+ match P.equal c coef0 with
+ true -> (plusP p' q')
+ |false -> (c,(snd t))::(plusP p' q')
+ in plusP p q
+
+(* multiplication by (a,monomial) *)
+let mult_t_pol a m p =
+ let rec mult_t_pol p =
+ match p with
+ [] -> []
+ |(b,m')::p -> ((P.multP a b),(mult_mon m m'))::(mult_t_pol p)
+ in mult_t_pol p
+
+let coef_of_int x = P.of_num (Num.Int x)
+
+(* variable i *)
+let gen d i =
+ let m = Array.create (d+1) 0 in
+ m.(i) <- 1;
+ let m = set_deg m in
+ [((coef_of_int 1),m)]
+
+let oppP p =
+ let rec oppP p =
+ match p with
+ [] -> []
+ |(b,m')::p -> ((P.oppP b),m')::(oppP p)
+ in oppP p
+
+(* multiplication by a coefficient *)
+let emultP a p =
+ let rec emultP p =
+ match p with
+ [] -> []
+ |(b,m')::p -> ((P.multP a b),m')::(emultP p)
+ in emultP p
+
+let multP p q =
+ let rec aux p =
+ match p with
+ [] -> []
+ |(a,m)::p' -> plusP (mult_t_pol a m q) (aux p')
+ in aux p
+
+let puisP p n=
+ match p with
+ [] -> []
+ |_ ->
+ let d = nvar (snd (hd p)) in
+ let rec puisP n =
+ match n with
+ 0 -> [coef1, Array.create (d+1) 0]
+ | 1 -> p
+ |_ -> multP p (puisP (n-1))
+ in puisP n
+
+let rec contentP p =
+ match p with
+ |[] -> coef1
+ |[a,m] -> a
+ |(a,m)::p1 ->
+ if P.equal a coef1 || P.equal a coefm1
+ then a
+ else P.pgcdP a (contentP p1)
+
+let contentPlist lp =
+ match lp with
+ |[] -> coef1
+ |p::l1 ->
+ fold_left
+ (fun r q ->
+ if P.equal r coef1 || P.equal r coefm1
+ then r
+ else P.pgcdP r (contentP q))
+ (contentP p) l1
+
+(***********************************************************************
+ Division of polynomials
+ *)
+
+let pgcdpos a b = P.pgcdP a b
+
+let polynom0 = {pol = ref []; num = 0; sugar = 0}
+
+let ppol p = !(p.pol)
+
+let lm p = snd (hd (ppol p))
+
+let nallpol = ref 0
+
+let allpol = ref (Array.create 1000 polynom0)
+
+let new_allpol p s =
+ nallpol := !nallpol + 1;
+ if !nallpol >= Array.length !allpol
+ then
+ allpol := Array.append !allpol (Array.create !nallpol polynom0);
+ let p = {pol = ref p; num = !nallpol; sugar = s} in
+ !allpol.(!nallpol)<- p;
+ p
+
+(* returns a polynomial of l whose head monomial divides m, else [] *)
+
+let rec selectdiv m l =
+ match l with
+ [] -> polynom0
+ |q::r -> let m'= snd (hd (ppol q)) in
+ match (div_mon_test m m') with
+ true -> q
+ |false -> selectdiv m r
+
+let div_pol p q a b m =
+(* info ".";*)
+ plusP (emultP a p) (mult_t_pol b m q)
+
+let hmon = Hashtbl.create 1000
+
+let use_hmon = ref false
+
+let find_hmon m =
+ if !use_hmon
+ then Hashtbl.find hmon m
+ else raise Not_found
+
+let add_hmon m q =
+ if !use_hmon
+ then Hashtbl.add hmon m q
+ else ()
+
+let div_coef a b = P.divP a b
+
+
+(* remainder r of the division of p by polynomials of l, returns (c,r) where c is the coefficient for pseudo-division : c p = sum_i q_i p_i + r *)
+
+let reduce2 p l =
+ let l = if nouveaux_pol_en_tete then rev l else l in
+ let rec reduce p =
+ match p with
+ [] -> (coef1,[])
+ |t::p' ->
+ let (a,m)=t in
+ let q = (try find_hmon m
+ with Not_found ->
+ let q = selectdiv m l in
+ match (ppol q) with
+ t'::q' -> (add_hmon m q;
+ q)
+ |[] -> q) in
+ match (ppol q) with
+ [] -> if reduire_les_queues
+ then
+ let (c,r)=(reduce p') in
+ (c,((P.multP a c,m)::r))
+ else (coef1,p)
+ |(b,m')::q' ->
+ let c=(pgcdpos a b) in
+ let a'= (div_coef b c) in
+ let b'=(P.oppP (div_coef a c)) in
+ let (e,r)=reduce (div_pol p' q' a' b'
+ (div_mon m m')) in
+ (P.multP a' e,r)
+ in let (c,r) = reduce p in
+ (c,r)
+
+(* trace of divisions *)
+
+(* list of initial polynomials *)
+let poldep = ref []
+let poldepcontent = ref []
+
+(* coefficients of polynomials when written with initial polynomials *)
+let coefpoldep = Hashtbl.create 51
+
+(* coef of q in p = sum_i c_i*q_i *)
+let coefpoldep_find p q =
+ try (Hashtbl.find coefpoldep (p.num,q.num))
+ with _ -> []
+
+let coefpoldep_remove p q =
+ Hashtbl.remove coefpoldep (p.num,q.num)
+
+let coefpoldep_set p q c =
+ Hashtbl.add coefpoldep (p.num,q.num) c
+
+let initcoefpoldep d lp =
+ poldep:=lp;
+ poldepcontent:= map (fun p -> contentP (ppol p)) lp;
+ iter
+ (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1)))
+ lp
+
+(* keeps trace in coefpoldep
+ divides without pseudodivisions *)
+
+let reduce2_trace p l lcp =
+ let l = if nouveaux_pol_en_tete then rev l else l in
+ (* rend (lq,r), ou r = p + sum(lq) *)
+ let rec reduce p =
+ match p with
+ [] -> ([],[])
+ |t::p' ->
+ let (a,m)=t in
+ let q =
+ (try find_hmon m
+ with Not_found ->
+ let q = selectdiv m l in
+ match (ppol q) with
+ t'::q' -> (add_hmon m q;
+ q)
+ |[] -> q) in
+ match (ppol q) with
+ [] ->
+ if reduire_les_queues
+ then
+ let (lq,r)=(reduce p') in
+ (lq,((a,m)::r))
+ else ([],p)
+ |(b,m')::q' ->
+ let b'=(P.oppP (div_coef a b)) in
+ let m''= div_mon m m' in
+ let p1=plusP p' (mult_t_pol b' m'' q') in
+ let (lq,r)=reduce p1 in
+ ((b',m'',q)::lq, r)
+ in let (lq,r) = reduce p in
+ (*info "reduce2_trace:\n";
+ iter
+ (fun (a,m,s) ->
+ let x = mult_t_pol a m s in
+ info ((stringP x)^"\n"))
+ lq;
+ info "ok\n";*)
+ (map2
+ (fun c0 q ->
+ let c =
+ fold_left
+ (fun x (a,m,s) ->
+ if equal (ppol s) (ppol q)
+ then
+ plusP x (mult_t_pol a m (polconst (nvar m) (coef_of_int 1)))
+ else x)
+ c0
+ lq in
+ c)
+ lcp
+ !poldep,
+ r)
+
+let homogeneous = ref false
+let pol_courant = ref polynom0
+
+(***********************************************************************
+ Completion
+ *)
+
+let sugar_flag = ref true
+
+let compute_sugar p =
+ fold_left (fun s (a,m) -> max s m.(0)) 0 p
+
+let mk_polynom p =
+ new_allpol p (compute_sugar p)
+
+let spol ps qs=
+ let p = ppol ps in
+ let q = ppol qs in
+ let m = snd (hd p) in
+ let m'= snd (hd q) in
+ let a = fst (hd p) in
+ let b = fst (hd q) in
+ let p'= tl p in
+ let q'= tl q in
+ let c = (pgcdpos a b) in
+ let m''=(ppcm_mon m m') in
+ let m1 = div_mon m'' m in
+ let m2 = div_mon m'' m' in
+ let fsp p' q' =
+ plusP
+ (mult_t_pol
+ (div_coef b c)
+ m1 p')
+ (mult_t_pol
+ (P.oppP (div_coef a c))
+ m2 q') in
+ let sp = fsp p' q' in
+ let sps =
+ new_allpol
+ sp
+ (max (m1.(0) + ps.sugar) (m2.(0) + qs.sugar)) in
+ coefpoldep_set sps ps (fsp (polconst (nvar m) (coef_of_int 1)) []);
+ coefpoldep_set sps qs (fsp [] (polconst (nvar m) (coef_of_int 1)));
+ sps
+
+
+let etrangers p p'=
+ let m = snd (hd p) in
+ let m'= snd (hd p') in
+ let d = nvar m in
+ let res=ref true in
+ let i=ref 1 in
+ while (!res) && (!i<=d) do
+ res:= (m.(!i) = 0) || (m'.(!i)=0);
+ i:=!i+1;
+ done;
+ !res
+
+(* teste if head monomial of p'' divides lcm of lhead monomials of p and p' *)
+
+let div_ppcm p p' p'' =
+ let m = snd (hd p) in
+ let m'= snd (hd p') in
+ let m''= snd (hd p'') in
+ let d = nvar m in
+ let res=ref true in
+ let i=ref 1 in
+ while (!res) && (!i<=d) do
+ res:= ((max m.(!i) m'.(!i)) >= m''.(!i));
+ i:=!i+1;
+ done;
+ !res
+
+(* code from extraction of Laurent Théry Coq program *)
+
+type 'poly cpRes =
+ Keep of ('poly list)
+ | DontKeep of ('poly list)
+
+let list_rec f0 f1 =
+ let rec f2 = function
+ [] -> f0
+ | a0::l0 -> f1 a0 l0 (f2 l0)
+ in f2
+
+let addRes i = function
+ Keep h'0 -> Keep (i::h'0)
+ | DontKeep h'0 -> DontKeep (i::h'0)
+
+let slice i a q =
+ list_rec
+ (match etrangers (ppol i) (ppol a) with
+ true -> DontKeep []
+ | false -> Keep [])
+ (fun b q1 rec_ren ->
+ match div_ppcm (ppol i) (ppol a) (ppol b) with
+ true -> DontKeep (b::q1)
+ | false ->
+ (match div_ppcm (ppol i) (ppol b) (ppol a) with
+ true -> rec_ren
+ | false -> addRes b rec_ren)) q
+
+(* sugar strategy *)
+
+let rec addS x l = l @ [x] (* oblige de mettre en queue sinon le certificat deconne *)
+
+let addSsugar x l =
+ if !sugar_flag
+ then
+ let sx = x.sugar in
+ let rec insere l =
+ match l with
+ | [] -> [x]
+ | y::l1 ->
+ if sx <= y.sugar
+ then x::l
+ else y::(insere l1)
+ in insere l
+ else addS x l
+
+(* ajoute les spolynomes de i avec la liste de polynomes aP,
+ a la liste q *)
+
+let genPcPf i aP q =
+ (let rec genPc aP0 =
+ match aP0 with
+ [] -> (fun r -> r)
+ | a::l1 ->
+ (fun l ->
+ (match slice i a l1 with
+ Keep l2 -> addSsugar (spol i a) (genPc l2 l)
+ | DontKeep l2 -> genPc l2 l))
+ in genPc aP) q
+
+let genOCPf h' =
+ list_rec [] (fun a l rec_ren ->
+ genPcPf a l rec_ren) h'
+
+(***********************************************************************
+ critical pairs/s-polynomials
+ *)
+
+let ordcpair ((i1,j1),m1) ((i2,j2),m2) =
+(* let s1 = (max
+ (!allpol.(i1).sugar + m1.(0)
+ - (snd (hd (ppol !allpol.(i1)))).(0))
+ (!allpol.(j1).sugar + m1.(0)
+ - (snd (hd (ppol !allpol.(j1)))).(0))) in
+ let s2 = (max
+ (!allpol.(i2).sugar + m2.(0)
+ - (snd (hd (ppol !allpol.(i2)))).(0))
+ (!allpol.(j2).sugar + m2.(0)
+ - (snd (hd (ppol !allpol.(j2)))).(0))) in
+ match compare s1 s2 with
+ | 1 -> 1
+ |(-1) -> -1
+ |0 -> compare_mon m1 m2*)
+
+ compare_mon m1 m2
+
+let sortcpairs lcp =
+ sort ordcpair lcp
+
+let mergecpairs l1 l2 =
+ merge ordcpair l1 l2
+
+let ord i j =
+ if i<j then (i,j) else (j,i)
+
+let cpair p q =
+ if etrangers (ppol p) (ppol q)
+ then []
+ else [(ord p.num q.num,
+ ppcm_mon (lm p) (lm q))]
+
+let cpairs1 p lq =
+ sortcpairs (fold_left (fun r q -> r @ (cpair p q)) [] lq)
+
+let cpairs lp =
+ let rec aux l =
+ match l with
+ []|[_] -> []
+ |p::l1 -> mergecpairs (cpairs1 p l1) (aux l1)
+ in aux lp
+
+
+let critere2 ((i,j),m) lp lcp =
+ exists
+ (fun h ->
+ h.num <> i && h.num <> j
+ && (div_mon_test m (lm h))
+ && (let c1 = ord i h.num in
+ not (exists (fun (c,_) -> c1 = c) lcp))
+ && (let c1 = ord j h.num in
+ not (exists (fun (c,_) -> c1 = c) lcp)))
+ lp
+
+let critere3 ((i,j),m) lp lcp =
+ exists
+ (fun h ->
+ h.num <> i && h.num <> j
+ && (div_mon_test m (lm h))
+ && (h.num < j
+ || not (m = ppcm_mon
+ (lm (!allpol.(i)))
+ (lm h)))
+ && (h.num < i
+ || not (m = ppcm_mon
+ (lm (!allpol.(j)))
+ (lm h))))
+ lp
+
+let add_cpairs p lp lcp =
+ mergecpairs (cpairs1 p lp) lcp
+
+let step = ref 0
+
+let infobuch p q =
+ if !step = 0
+ then (info ("[" ^ (string_of_int (length p))
+ ^ "," ^ (string_of_int (length q))
+ ^ "]"))
+
+(* in lp new polynomials are at the end *)
+
+let coef_courant = ref coef1
+
+type certificate =
+ { coef : coef; power : int;
+ gb_comb : poly list list; last_comb : poly list }
+
+let test_dans_ideal p lp lp0 =
+ let (c,r) = reduce2 (ppol !pol_courant) lp in
+ info ("remainder: "^(stringPcut r)^"\n");
+ coef_courant:= P.multP !coef_courant c;
+ pol_courant:= mk_polynom r;
+ if r=[]
+ then (info "polynomial reduced to 0\n";
+ let lcp = map (fun q -> []) !poldep in
+ let c = !coef_courant in
+ let (lcq,r) = reduce2_trace (emultP c p) lp lcp in
+ info "r ok\n";
+ info ("r: "^(stringP r)^"\n");
+ let res=ref (emultP c p) in
+ iter2
+ (fun cq q -> res:=plusP (!res) (multP cq (ppol q));
+ )
+ lcq !poldep;
+ info ("verif sum: "^(stringP (!res))^"\n");
+ info ("coefficient: "^(stringP (polconst 1 c))^"\n");
+ let rec aux lp =
+ match lp with
+ |[] -> []
+ |p::lp ->
+ (map
+ (fun q -> coefpoldep_find p q)
+ lp)::(aux lp)
+ in
+ let coefficient_multiplicateur = c in
+ let liste_polynomes_de_depart = rev lp0 in
+ let polynome_a_tester = p in
+ let liste_des_coefficients_intermediaires =
+ (let lci = rev (aux (rev lp)) in
+ let lci = ref lci (* (map rev lci) *) in
+ iter (fun x -> lci := tl (!lci)) lp0;
+ !lci) in
+ let liste_des_coefficients =
+ map
+ (fun cq -> emultP (coef_of_int (-1)) cq)
+ (rev lcq) in
+ (liste_polynomes_de_depart,
+ polynome_a_tester,
+ {coef = coefficient_multiplicateur;
+ power = 1;
+ gb_comb = liste_des_coefficients_intermediaires;
+ last_comb = liste_des_coefficients})
+ )
+ else ((*info "polynomial not reduced to 0\n";
+ info ("\nremainder: "^(stringPcut r)^"\n");*)
+ raise NotInIdeal)
+
+let divide_rem_with_critical_pair = ref false
+
+let list_diff l x =
+ filter (fun y -> y <> x) l
+
+let deg_hom p =
+ match p with
+ | [] -> -1
+ | (a,m)::_ -> m.(0)
+
+let pbuchf pq p lp0=
+ info "computation of the Groebner basis\n";
+ step:=0;
+ Hashtbl.clear hmon;
+ let rec pbuchf (lp, lpc) =
+ infobuch lp lpc;
+(* step:=(!step+1)mod 10;*)
+ match lpc with
+ [] ->
+
+ (* info ("List of polynomials:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));
+ info "--------------------\n";*)
+ test_dans_ideal (ppol p) lp lp0
+ | ((i,j),m) :: lpc2 ->
+(* info "choosen pair\n";*)
+ if critere3 ((i,j),m) lp lpc2
+ then (info "c"; pbuchf (lp, lpc2))
+ else
+ let a = spol !allpol.(i) !allpol.(j) in
+ if !homogeneous && (ppol a)<>[] && deg_hom (ppol a)
+ > deg_hom (ppol !pol_courant)
+ then (info "h"; pbuchf (lp, lpc2))
+ else
+(* let sa = a.sugar in*)
+ let (ca,a0)= reduce2 (ppol a) lp in
+ match a0 with
+ [] -> info "0";pbuchf (lp, lpc2)
+ | _ ->
+(* info "pair reduced\n";*)
+ a.pol := emultP ca (ppol a);
+ let (lca,a0) = reduce2_trace (ppol a) lp
+ (map (fun q -> emultP ca (coefpoldep_find a q))
+ !poldep) in
+(* info "paire re-reduced";*)
+ a.pol := a0;
+(* let a0 = new_allpol a0 sa in*)
+ iter2 (fun c q ->
+ coefpoldep_remove a q;
+ coefpoldep_set a q c) lca !poldep;
+ let a0 = a in
+ info ("\nnew polynomials: "^(stringPcut (ppol a0))^"\n");
+ let ct = coef1 (* contentP a0 *) in
+ (*info ("content: "^(string_of_coef ct)^"\n");*)
+ poldep:=addS a0 lp;
+ poldepcontent:=addS ct (!poldepcontent);
+
+ try test_dans_ideal (ppol p) (addS a0 lp) lp0
+ with NotInIdeal ->
+ let newlpc = add_cpairs a0 lp lpc2 in
+ pbuchf (((addS a0 lp), newlpc))
+ in pbuchf pq
+
+let is_homogeneous p =
+ match p with
+ | [] -> true
+ | (a,m)::p1 -> let d = m.(0) in
+ for_all (fun (b,m') -> m'.(0)=d) p1
+
+(* returns
+ c
+ lp = [pn;...;p1]
+ p
+ lci = [[a(n+1,n);...;a(n+1,1)];
+ [a(n+2,n+1);...;a(n+2,1)];
+ ...
+ [a(n+m,n+m-1);...;a(n+m,1)]]
+ lc = [qn+m; ... q1]
+
+ such that
+ c*p = sum qi*pi
+ where pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1
+ *)
+
+let in_ideal d lp p =
+ Hashtbl.clear hmon;
+ Hashtbl.clear coefpoldep;
+ nallpol := 0;
+ allpol := Array.create 1000 polynom0;
+ homogeneous := for_all is_homogeneous (p::lp);
+ if !homogeneous then info "homogeneous polynomials\n";
+ info ("p: "^(stringPcut p)^"\n");
+ info ("lp:\n"^(fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp));
+ (*info ("p: "^(stringP p)^"\n");
+ info ("lp:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));*)
+
+ let lp = map mk_polynom lp in
+ let p = mk_polynom p in
+ initcoefpoldep d lp;
+ coef_courant:=coef1;
+ pol_courant:=p;
+
+ let (lp1,p1,cert) =
+ try test_dans_ideal (ppol p) lp lp
+ with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in
+ info "computed\n";
+
+ (map ppol lp1, p1, cert)
+
+(* *)
+end
+
+
+
diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml4
new file mode 100644
index 00000000..892d6037
--- /dev/null
+++ b/plugins/nsatz/nsatz.ml4
@@ -0,0 +1,608 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Closure
+open Environ
+open Libnames
+open Tactics
+open Rawterm
+open Tacticals
+open Tacexpr
+open Pcoq
+open Tactic
+open Constr
+open Proof_type
+open Coqlib
+open Tacmach
+open Mod_subst
+open Tacinterp
+open Libobject
+open Printer
+open Declare
+open Decl_kinds
+open Entries
+
+open Num
+open Unix
+open Utile
+
+(***********************************************************************
+ Operations on coefficients
+*)
+
+let num_0 = Int 0
+and num_1 = Int 1
+and num_2 = Int 2
+and num_10 = Int 10
+
+let numdom r =
+ let r' = Ratio.normalize_ratio (ratio_of_num r) in
+ num_of_big_int(Ratio.numerator_ratio r'),
+ num_of_big_int(Ratio.denominator_ratio r')
+
+module BigInt = struct
+ open Big_int
+
+ type t = big_int
+ let of_int = big_int_of_int
+ let coef0 = of_int 0
+ let coef1 = of_int 1
+ let of_num = Num.big_int_of_num
+ let to_num = Num.num_of_big_int
+ let equal = eq_big_int
+ let lt = lt_big_int
+ let le = le_big_int
+ let abs = abs_big_int
+ let plus =add_big_int
+ let mult = mult_big_int
+ let sub = sub_big_int
+ let opp = minus_big_int
+ let div = div_big_int
+ let modulo = mod_big_int
+ let to_string = string_of_big_int
+ let to_int x = int_of_big_int x
+ let hash x =
+ try (int_of_big_int x)
+ with _-> 1
+ let puis = power_big_int_positive_int
+
+ (* a et b positifs, résultat positif *)
+ let rec pgcd a b =
+ if equal b coef0
+ then a
+ else if lt a b then pgcd b a else pgcd b (modulo a b)
+
+
+ (* signe du pgcd = signe(a)*signe(b) si non nuls. *)
+ let pgcd2 a b =
+ if equal a coef0 then b
+ else if equal b coef0 then a
+ else let c = pgcd (abs a) (abs b) in
+ if ((lt coef0 a)&&(lt b coef0))
+ ||((lt coef0 b)&&(lt a coef0))
+ then opp c else c
+end
+
+(*
+module Ent = struct
+ type t = Entiers.entiers
+ let of_int = Entiers.ent_of_int
+ let of_num x = Entiers.ent_of_string(Num.string_of_num x)
+ let to_num x = Num.num_of_string (Entiers.string_of_ent x)
+ let equal = Entiers.eq_ent
+ let lt = Entiers.lt_ent
+ let le = Entiers.le_ent
+ let abs = Entiers.abs_ent
+ let plus =Entiers.add_ent
+ let mult = Entiers.mult_ent
+ let sub = Entiers.moins_ent
+ let opp = Entiers.opp_ent
+ let div = Entiers.div_ent
+ let modulo = Entiers.mod_ent
+ let coef0 = Entiers.ent0
+ let coef1 = Entiers.ent1
+ let to_string = Entiers.string_of_ent
+ let to_int x = Entiers.int_of_ent x
+ let hash x =Entiers.hash_ent x
+ let signe = Entiers.signe_ent
+
+ let rec puis p n = match n with
+ 0 -> coef1
+ |_ -> (mult p (puis p (n-1)))
+
+ (* a et b positifs, résultat positif *)
+ let rec pgcd a b =
+ if equal b coef0
+ then a
+ else if lt a b then pgcd b a else pgcd b (modulo a b)
+
+
+ (* signe du pgcd = signe(a)*signe(b) si non nuls. *)
+ let pgcd2 a b =
+ if equal a coef0 then b
+ else if equal b coef0 then a
+ else let c = pgcd (abs a) (abs b) in
+ if ((lt coef0 a)&&(lt b coef0))
+ ||((lt coef0 b)&&(lt a coef0))
+ then opp c else c
+end
+*)
+
+(* ------------------------------------------------------------------------- *)
+(* ------------------------------------------------------------------------- *)
+
+type vname = string
+
+type term =
+ | Zero
+ | Const of Num.num
+ | Var of vname
+ | Opp of term
+ | Add of term * term
+ | Sub of term * term
+ | Mul of term * term
+ | Pow of term * int
+
+let const n =
+ if eq_num n num_0 then Zero else Const n
+let pow(p,i) = if i=1 then p else Pow(p,i)
+let add = function
+ (Zero,q) -> q
+ | (p,Zero) -> p
+ | (p,q) -> Add(p,q)
+let mul = function
+ (Zero,_) -> Zero
+ | (_,Zero) -> Zero
+ | (p,Const n) when eq_num n num_1 -> p
+ | (Const n,q) when eq_num n num_1 -> q
+ | (p,q) -> Mul(p,q)
+
+let unconstr = mkRel 1
+
+let tpexpr =
+ lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr")
+let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc")
+let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX")
+let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd")
+let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub")
+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 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 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 nN0 = lazy (gen_constant "CC" ["NArith";"BinNat"] "N0")
+let nNpos = lazy(gen_constant "CC" ["NArith";"BinNat"] "Npos")
+
+let mkt_app name l = mkApp (Lazy.force name, Array.of_list l)
+
+let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]]
+let tllp () = mkt_app tlist [tlp()]
+
+let rec mkt_pos n =
+ if n =/ num_1 then Lazy.force pxH
+ else if mod_num n num_2 =/ num_0 then
+ mkt_app pxO [mkt_pos (quo_num n num_2)]
+ else
+ mkt_app pxI [mkt_pos (quo_num n num_2)]
+
+let mkt_n n =
+ if n=num_0
+ then Lazy.force nN0
+ else mkt_app nNpos [mkt_pos n]
+
+let mkt_z z =
+ if z =/ num_0 then Lazy.force z0
+ else if z >/ num_0 then
+ mkt_app zpos [mkt_pos z]
+ else
+ mkt_app zneg [mkt_pos ((Int 0) -/ z)]
+
+let rec mkt_term t = match t with
+| Zero -> mkt_term (Const num_0)
+| Const r -> let (n,d) = numdom r in
+ mkt_app ttconst [Lazy.force tz; mkt_z n]
+| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)]
+| Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1]
+| Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2]
+| Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2]
+| Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2]
+| Pow (t1,n) -> if (n = 0) then
+ mkt_app ttconst [Lazy.force tz; mkt_z num_1]
+else
+ mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)]
+
+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)
+ 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))
+| _ -> num_0
+
+let parse_n z =
+ match kind_of_term z with
+| App (a,[|p2|]) ->
+ parse_pos p2
+| _ -> num_0
+
+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)
+ 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
+ Pow (parse_term p2, int_of_num (parse_n p3))
+ else Zero
+| _ -> Zero
+
+let rec parse_request lp =
+ match kind_of_term lp with
+ | App (_,[|_|]) -> []
+ | App (_,[|_;p;lp1|]) ->
+ (parse_term p)::(parse_request lp1)
+ |_-> assert false
+
+let nvars = ref 0
+
+let set_nvars_term t =
+ let rec aux t =
+ match t with
+ | Zero -> ()
+ | Const r -> ()
+ | Var v -> let n = int_of_string v in
+ nvars:= max (!nvars) n
+ | Opp t1 -> aux t1
+ | Add (t1,t2) -> aux t1; aux t2
+ | Sub (t1,t2) -> aux t1; aux t2
+ | Mul (t1,t2) -> aux t1; aux t2
+ | Pow (t1,n) -> aux t1
+ in aux t
+
+let string_of_term p =
+ let rec aux p =
+ match p with
+ | Zero -> "0"
+ | Const r -> string_of_num r
+ | Var v -> "x"^v
+ | Opp t1 -> "(-"^(aux t1)^")"
+ | Add (t1,t2) -> "("^(aux t1)^"+"^(aux t2)^")"
+ | Sub (t1,t2) -> "("^(aux t1)^"-"^(aux t2)^")"
+ | Mul (t1,t2) -> "("^(aux t1)^"*"^(aux t2)^")"
+ | Pow (t1,n) -> (aux t1)^"^"^(string_of_int n)
+ in aux p
+
+
+(***********************************************************************
+ Coefficients: recursive polynomials
+ *)
+
+module Coef = BigInt
+(*module Coef = Ent*)
+module Poly = Polynom.Make(Coef)
+module PIdeal = Ideal.Make(Poly)
+open PIdeal
+
+(* term to sparse polynomial
+ varaibles <=np are in the coefficients
+*)
+
+let term_pol_sparse np t=
+ let d = !nvars in
+ let rec aux t =
+ match t with
+ | Zero -> zeroP
+ | Const r ->
+ if r = num_0
+ then zeroP
+ else polconst d (Poly.Pint (Coef.of_num r))
+ | Var v ->
+ let v = int_of_string v in
+ if v <= np
+ then polconst d (Poly.x v)
+ else gen d v
+ | Opp t1 -> oppP (aux t1)
+ | Add (t1,t2) -> plusP (aux t1) (aux t2)
+ | 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");*)
+ let res= aux t in
+ (*info ("donne: "^(stringP res)^"\n");*)
+ res
+
+(* sparse polynomial to term *)
+
+let polrec_to_term p =
+ let rec aux p =
+ match p with
+ |Poly.Pint n -> const (Coef.to_num n)
+ |Poly.Prec (v,coefs) ->
+ let res = ref Zero in
+ Array.iteri
+ (fun i c ->
+ res:=add(!res, mul(aux c,
+ pow (Var (string_of_int v),
+ i))))
+ coefs;
+ !res
+ in aux p
+
+(* approximation of the Horner form used in the tactic ring *)
+
+let pol_sparse_to_term n2 p =
+ info "pol_sparse_to_term ->\n";
+ let p = PIdeal.repr p in
+ let rec aux p =
+ match p with
+ [] -> const (num_of_string "0")
+ | (a,m)::p1 ->
+ let n = (Array.length m)-1 in
+ let (i0,e0) =
+ List.fold_left (fun (r,d) (a,m) ->
+ let i0= ref 0 in
+ for k=1 to n do
+ if m.(k)>0
+ then i0:=k
+ done;
+ if !i0 = 0
+ then (r,d)
+ else if !i0 > r
+ then (!i0, m.(!i0))
+ else if !i0 = r && m.(!i0)<d
+ then (!i0, m.(!i0))
+ else (r,d))
+ (0,0)
+ p in
+ if i0=0
+ then
+ let mp = ref (polrec_to_term a) in
+ if p1=[]
+ then !mp
+ else add(!mp,aux p1)
+ else (
+ let p1=ref [] in
+ let p2=ref [] in
+ List.iter
+ (fun (a,m) ->
+ if m.(i0)>=e0
+ then (m.(i0)<-m.(i0)-e0;
+ p1:=(a,m)::(!p1))
+ else p2:=(a,m)::(!p2))
+ p;
+ let vm =
+ if e0=1
+ 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";
+ aux p
+
+
+let rec remove_list_tail l i =
+ let rec aux l i =
+ if l=[]
+ then []
+ else if i<0
+ then l
+ else if i=0
+ then List.tl l
+ else
+ match l with
+ |(a::l1) ->
+ a::(aux l1 (i-1))
+ |_ -> assert false
+ in
+ List.rev (aux (List.rev l) i)
+
+(*
+ lq = [cn+m+1 n+m ...cn+m+1 1]
+ lci=[[cn+1 n,...,cn1 1]
+ ...
+ [cn+m n+m-1,...,cn+m 1]]
+
+ removes intermediate polynomials not useful to compute the last one.
+ *)
+
+let remove_zeros zero lci =
+ let n = List.length (List.hd lci) in
+ let m=List.length lci in
+ let u = Array.create m false in
+ let rec utiles k =
+ if k>=m
+ then ()
+ else (
+ u.(k)<-true;
+ let lc = List.nth lci k in
+ for i=0 to List.length lc - 1 do
+ if not (zero (List.nth lc i))
+ then utiles (i+k+1);
+ done)
+ in utiles 0;
+ let lr = ref [] in
+ for i=0 to m-1 do
+ if u.(i)
+ then lr:=(List.nth lci i)::(!lr)
+ done;
+ let lr=List.rev !lr in
+ let lr = List.map
+ (fun lc ->
+ let lcr=ref lc in
+ for i=0 to m-1 do
+ if not u.(i)
+ then lcr:=remove_list_tail !lcr (m-i+(n-m))
+ done;
+ !lcr)
+ lr in
+ info ("unuseful spolynomials: "
+ ^string_of_int (m-List.length lr)^"\n");
+ info ("useful spolynomials: "
+ ^string_of_int (List.length lr)^"\n");
+ lr
+
+let theoremedeszeros lpol p =
+ let t1 = Unix.gettimeofday() in
+ let m = !nvars in
+ let (lp0,p,cert) = in_ideal m lpol p in
+ let lpc = List.rev !poldepcontent in
+ info ("time: "^Format.sprintf "@[%10.3f@]s\n" (Unix.gettimeofday ()-.t1));
+ (cert,lp0,p,lpc)
+
+open Ideal
+
+let theoremedeszeros_termes lp =
+ nvars:=0;(* mise a jour par term_pol_sparse *)
+ List.iter set_nvars_term lp;
+ match lp with
+ | Const (Int sugarparam)::Const (Int nparam)::lp ->
+ ((match sugarparam with
+ |0 -> info "calcul sans sugar\n";
+ lexico:=false;
+ sugar_flag := false;
+ divide_rem_with_critical_pair := false
+ |1 -> info "calcul avec sugar\n";
+ lexico:=false;
+ sugar_flag := true;
+ divide_rem_with_critical_pair := false
+ |2 -> info "ordre lexico calcul sans sugar\n";
+ lexico:=true;
+ sugar_flag := false;
+ divide_rem_with_critical_pair := false
+ |3 -> info "ordre lexico calcul avec sugar\n";
+ lexico:=true;
+ sugar_flag := true;
+ divide_rem_with_critical_pair := false
+ |4 -> info "calcul sans sugar, division par les paires\n";
+ lexico:=false;
+ sugar_flag := false;
+ divide_rem_with_critical_pair := true
+ |5 -> info "calcul avec sugar, division par les paires\n";
+ lexico:=false;
+ sugar_flag := true;
+ divide_rem_with_critical_pair := true
+ |6 -> info "ordre lexico calcul sans sugar, division par les paires\n";
+ lexico:=true;
+ sugar_flag := false;
+ divide_rem_with_critical_pair := true
+ |7 -> info "ordre lexico calcul avec sugar, division par les paires\n";
+ lexico:=true;
+ sugar_flag := true;
+ divide_rem_with_critical_pair := true
+ | _ -> error "nsatz: bad parameter"
+ );
+ let m= !nvars in
+ let lvar=ref [] in
+ for i=m downto 1 do lvar:=["x"^(string_of_int i)^""]@(!lvar); done;
+ lvar:=["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ (!lvar); (* pour macaulay *)
+ name_var:=!lvar;
+ let lp = List.map (term_pol_sparse nparam) lp in
+ match lp with
+ | [] -> assert false
+ | p::lp1 ->
+ let lpol = List.rev lp1 in
+ let (cert,lp0,p,_lct) = theoremedeszeros lpol p in
+ let lc = cert.last_comb::List.rev cert.gb_comb in
+ match remove_zeros (fun x -> x=zeroP) lc with
+ | [] -> assert false
+ | (lq::lci) ->
+ (* lci commence par les nouveaux polynomes *)
+ let m= !nvars in
+ let c = pol_sparse_to_term m (polconst m cert.coef) in
+ let r = Pow(Zero,cert.power) in
+ 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";
+ (c,r,lci,lq)
+ )
+ |_ -> assert false
+
+
+(* version avec hash-consing du certificat:
+let nsatz lpol =
+ Hashtbl.clear Dansideal.hmon;
+ Hashtbl.clear Dansideal.coefpoldep;
+ Hashtbl.clear Dansideal.sugartbl;
+ Hashtbl.clear Polynomesrec.hcontentP;
+ init_constants ();
+ let lp= parse_request lpol in
+ let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in
+ let certif = certificat_vers_polynome_creux rthz in
+ let certif = hash_certif certif in
+ let certif = certif_term certif in
+ let c = mkt_term c in
+ info "constr calcule\n";
+ (c, certif)
+*)
+
+let nsatz lpol =
+ let lp= parse_request lpol in
+ let (c,r,lci,lq) = theoremedeszeros_termes lp in
+ let res = [c::r::lq]@lci in
+ let res = List.map (fun lx -> List.map mkt_term lx) res in
+ let res =
+ List.fold_right
+ (fun lt r ->
+ let ltterm =
+ List.fold_right
+ (fun t r ->
+ mkt_app lcons [mkt_app tpexpr [Lazy.force tz];t;r])
+ lt
+ (mkt_app lnil [mkt_app tpexpr [Lazy.force tz]]) in
+ mkt_app lcons [tlp ();ltterm;r])
+ res
+ (mkt_app lnil [tlp ()]) in
+ info "terme calcule\n";
+ res
+
+let return_term t =
+ let a =
+ mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in
+ generalize [a]
+
+let nsatz_compute t =
+ let lpol =
+ try nsatz t
+ with Ideal.NotInIdeal ->
+ error "nsatz cannot solve this problem" in
+ return_term lpol
+
+TACTIC EXTEND nsatz_compute
+| [ "nsatz_compute" constr(lt) ] -> [ nsatz_compute lt ]
+END
+
+
diff --git a/plugins/nsatz/nsatz_plugin.mllib b/plugins/nsatz/nsatz_plugin.mllib
new file mode 100644
index 00000000..a25e649d
--- /dev/null
+++ b/plugins/nsatz/nsatz_plugin.mllib
@@ -0,0 +1,5 @@
+Utile
+Polynom
+Ideal
+Nsatz
+Nsatz_plugin_mod
diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml
new file mode 100644
index 00000000..14e279b5
--- /dev/null
+++ b/plugins/nsatz/polynom.ml
@@ -0,0 +1,679 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Recursive polynomials: R[x1]...[xn]. *)
+open Utile
+open Util
+
+(* 1. Coefficients: R *)
+
+module type Coef = sig
+ type t
+ val equal : t -> t -> bool
+ val lt : t -> t -> bool
+ val le : t -> t -> bool
+ val abs : t -> t
+ val plus : t -> t -> t
+ val mult : t -> t -> t
+ val sub : t -> t -> t
+ val opp : t -> t
+ val div : t -> t -> t
+ val modulo : t -> t -> t
+ val puis : t -> int -> t
+ val pgcd : t -> t -> t
+
+ val hash : t -> int
+ val of_num : Num.num -> t
+ val to_string : t -> string
+end
+
+module type S = sig
+ type coef
+ type variable = int
+ type t = Pint of coef | Prec of variable * t array
+
+ val of_num : Num.num -> t
+ val x : variable -> t
+ val monome : variable -> int -> t
+ val is_constantP : t -> bool
+ val is_zero : t -> bool
+
+ val max_var_pol : t -> variable
+ val max_var_pol2 : t -> variable
+ val max_var : t array -> variable
+ val equal : t -> t -> bool
+ val norm : t -> t
+ val deg : variable -> t -> int
+ val deg_total : t -> int
+ val copyP : t -> t
+ val coef : variable -> int -> t -> t
+
+ val plusP : t -> t -> t
+ val content : t -> coef
+ val div_int : t -> coef -> t
+ val vire_contenu : t -> t
+ val vars : t -> variable list
+ val int_of_Pint : t -> coef
+ val multx : int -> variable -> t -> t
+ val multP : t -> t -> t
+ val deriv : variable -> t -> t
+ val oppP : t -> t
+ val moinsP : t -> t -> t
+ val puisP : t -> int -> t
+ val ( @@ ) : t -> t -> t
+ val ( -- ) : t -> t -> t
+ val ( ^^ ) : t -> int -> t
+ val coefDom : variable -> t -> t
+ val coefConst : variable -> t -> t
+ val remP : variable -> t -> t
+ val coef_int_tete : t -> coef
+ val normc : t -> t
+ val coef_constant : t -> coef
+ val univ : bool ref
+ val string_of_var : int -> string
+ val nsP : int ref
+ val to_string : t -> string
+ val printP : t -> unit
+ val print_tpoly : t array -> unit
+ val print_lpoly : t list -> unit
+ val quo_rem_pol : t -> t -> variable -> t * t
+ val div_pol : t -> t -> variable -> t
+ val divP : t -> t -> t
+ val div_pol_rat : t -> t -> bool
+ val pseudo_div : t -> t -> variable -> t * t * int * t
+ val pgcdP : t -> t -> t
+ val pgcd_pol : t -> t -> variable -> t
+ val content_pol : t -> variable -> t
+ val pgcd_coef_pol : t -> t -> variable -> t
+ val pgcd_pol_rec : t -> t -> variable -> t
+ val gcd_sub_res : t -> t -> variable -> t
+ val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t
+ val lazard_power : t -> t -> int -> variable -> t
+ val hash : t -> int
+ module Hashpol : Hashtbl.S with type key=t
+end
+
+(***********************************************************************
+ 2. Type of polynomials, operations.
+*)
+module Make (C:Coef) = struct
+
+type coef = C.t
+let coef_of_int i = C.of_num (Num.Int i)
+let coef0 = coef_of_int 0
+let coef1 = coef_of_int 1
+
+type variable = int
+
+type t =
+ Pint of coef (* constant polynomial *)
+ | Prec of variable * (t array) (* coefficients, increasing degree *)
+
+(* by default, operations work with normalized polynomials:
+- variables are positive integers
+- coefficients of a polynomial in x only use variables < x
+- no zero coefficient at beginning
+- no Prec(x,a) where a is constant in x
+*)
+
+(* constant polynomials *)
+let of_num x = Pint (C.of_num x)
+let cf0 = of_num (Num.Int 0)
+let cf1 = of_num (Num.Int 1)
+
+(* nth variable *)
+let x n = Prec (n,[|cf0;cf1|])
+
+(* create v^n *)
+let monome v n =
+ match n with
+ 0->Pint coef1;
+ |_->let tmp = Array.create (n+1) (Pint coef0) in
+ tmp.(n)<-(Pint coef1);
+ Prec (v, tmp)
+
+let is_constantP = function
+ Pint _ -> true
+ | Prec _ -> false
+
+let int_of_Pint = function
+ Pint x -> x
+ | _ -> failwith "non"
+
+let is_zero p =
+ match p with Pint n -> if C.equal n coef0 then true else false |_-> false
+
+let max_var_pol p =
+ match p with
+ Pint _ -> 0
+ |Prec(x,_) -> x
+
+(* p not normalized *)
+let rec max_var_pol2 p =
+ match p with
+ Pint _ -> 0
+ |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v
+
+let rec max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0
+
+(* equality between polynomials *)
+
+let rec equal p q =
+ match (p,q) with
+ (Pint a,Pint b) -> C.equal a b
+ |(Prec(x,p1),Prec(y,q1)) ->
+ if x<>y then false
+ else if (Array.length p1)<>(Array.length q1) then false
+ else (try (Array.iteri (fun i a -> if not (equal a q1.(i))
+ then failwith "raté")
+ p1;
+ true)
+ with _ -> false)
+ | (_,_) -> false
+
+(* normalize polynomial: remove head zeros, coefficients are normalized
+ if constant, returns the coefficient
+*)
+
+let rec norm p = match p with
+ Pint _ -> p
+ |Prec (x,a)->
+ let d = (Array.length a -1) in
+ let n = ref d in
+ while !n>0 && (equal a.(!n) (Pint coef0)) do
+ n:=!n-1;
+ done;
+ if !n<0 then Pint coef0
+ else if !n=0 then a.(0)
+ else if !n=d then p
+ else (let b=Array.create (!n+1) (Pint coef0) in
+ for i=0 to !n do b.(i)<-a.(i);done;
+ Prec(x,b))
+
+
+(* degree in v, v >= max var of p *)
+let rec deg v p =
+ match p with
+ Prec(x,p1) when x=v -> Array.length p1 -1
+ |_ -> 0
+
+
+(* total degree *)
+let rec deg_total p =
+ match p with
+ Prec (x,p1) -> let d = ref 0 in
+ Array.iteri (fun i q -> d:= (max !d (i+(deg_total q)))) p1;
+ !d
+ |_ -> 0
+
+let rec copyP p =
+ match p with
+ Pint i -> Pint i
+ |Prec(x,q) -> Prec(x,Array.map copyP q)
+
+(* coefficient of degree i in v, v >= max var of p *)
+let coef v i p =
+ match p with
+ Prec (x,p1) when x=v -> if i<(Array.length p1) then p1.(i) else Pint coef0
+ |_ -> if i=0 then p else Pint coef0
+
+(* addition *)
+
+let rec plusP p q =
+ let res =
+ (match (p,q) with
+ (Pint a,Pint b) -> Pint (C.plus a b)
+ |(Pint a, Prec (y,q1)) -> let q2=Array.map copyP q1 in
+ q2.(0)<- plusP p q1.(0);
+ Prec (y,q2)
+ |(Prec (x,p1),Pint b) -> let p2=Array.map copyP p1 in
+ p2.(0)<- plusP p1.(0) q;
+ Prec (x,p2)
+ |(Prec (x,p1),Prec (y,q1)) ->
+ if x<y then (let q2=Array.map copyP q1 in
+ q2.(0)<- plusP p q1.(0);
+ Prec (y,q2))
+ else if x>y then (let p2=Array.map copyP p1 in
+ p2.(0)<- plusP p1.(0) q;
+ Prec (x,p2))
+ else
+ (let n=max (deg x p) (deg x q) in
+ let r=Array.create (n+1) (Pint coef0) in
+ for i=0 to n do
+ r.(i)<- plusP (coef x i p) (coef x i q);
+ done;
+ Prec(x,r)))
+ in norm res
+
+
+(* content, positive integer *)
+let rec content p =
+ match p with
+ Pint a -> C.abs a
+ | Prec (x ,p1) ->
+ Array.fold_left C.pgcd coef0 (Array.map content p1)
+
+let rec div_int p a=
+ match p with
+ Pint b -> Pint (C.div b a)
+ | Prec(x,p1) -> Prec(x,Array.map (fun x -> div_int x a) p1)
+
+let vire_contenu p =
+ let c = content p in
+ if C.equal c coef0 then p else div_int p c
+
+(* sorted list of variables of a polynomial *)
+
+let rec vars=function
+ Pint _->[]
+ | Prec (x,l)->(List.flatten ([x]::(List.map vars (Array.to_list l))))
+
+
+(* multiply p by v^n, v >= max_var p *)
+let rec multx n v p =
+ match p with
+ Prec (x,p1) when x=v -> let p2= Array.create ((Array.length p1)+n) (Pint coef0) in
+ for i=0 to (Array.length p1)-1 do
+ p2.(i+n)<-p1.(i);
+ done;
+ Prec (x,p2)
+ |_ -> if 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
+ (Pint a,Pint b) -> Pint (C.mult a b)
+ |(Pint a, Prec (y,q1)) ->
+ if C.equal a coef0 then Pint coef0
+ else let q2 = Array.map (fun z-> multP p z) q1 in
+ Prec (y,q2)
+
+ |(Prec (x,p1), Pint b) ->
+ if C.equal b coef0 then Pint coef0
+ else let p2 = Array.map (fun z-> multP z q) p1 in
+ Prec (x,p2)
+ |(Prec (x,p1), Prec(y,q1)) ->
+ if x<y
+ then (let q2 = Array.map (fun z-> multP p z) q1 in
+ Prec (y,q2))
+ else if x>y
+ then (let p2 = Array.map (fun z-> multP z q) p1 in
+ Prec (x,p2))
+ else Array.fold_left plusP (Pint coef0)
+ (Array.mapi (fun i z-> (multx i x (multP z q))) p1)
+
+
+
+(* derive p with variable v, v >= max_var p *)
+let rec deriv v p =
+ match p with
+ Pint a -> Pint coef0
+ | Prec(x,p1) when x=v ->
+ let d = Array.length p1 -1 in
+ if d=1 then p1.(1)
+ else
+ (let p2 = Array.create d (Pint coef0) in
+ for i=0 to d-1 do
+ p2.(i)<- multP (Pint (coef_of_int (i+1))) p1.(i+1);
+ done;
+ Prec (x,p2))
+ | Prec(x,p1)-> Pint coef0
+
+
+(* opposite *)
+let rec oppP p =
+ match p with
+ Pint a -> Pint (C.opp a)
+ |Prec(x,p1) -> Prec(x,Array.map oppP p1)
+
+let moinsP p q=plusP p (oppP q)
+
+let rec puisP p n = match n with
+ 0 -> cf1
+ |_ -> (multP p (puisP p (n-1)))
+
+
+(* infix notations *)
+(*let (++) a b = plusP a b
+*)
+let (@@) a b = multP a b
+
+let (--) a b = moinsP a b
+
+let (^^) a b = puisP a b
+
+
+(* leading coefficient in v, v>= max_var p *)
+
+let coefDom v p= coef v (deg v p) p
+
+let coefConst v p = coef v 0 p
+
+(* tail of a polynomial *)
+let remP v p =
+ moinsP p (multP (coefDom v p) (puisP (x v) (deg v p)))
+
+
+(* first interger coefficient of p *)
+let rec coef_int_tete p =
+ let v = max_var_pol p in
+ if v>0
+ then coef_int_tete (coefDom v p)
+ else (match p with | Pint a -> a |_ -> assert false)
+
+
+(* divide by the content and make the head int coef positive *)
+let normc p =
+ let p = vire_contenu p in
+ let a = coef_int_tete p in
+ if C.le coef0 a then p else oppP p
+
+
+(* constant coef of normalized polynomial *)
+let rec coef_constant p =
+ match p with
+ Pint a->a
+ |Prec(_,q)->coef_constant q.(0)
+
+
+(***********************************************************************
+ 3. Printing polynomials.
+*)
+
+(* if univ = false, we use x,y,z,a,b,c,d... as variables, else x1,x2,...
+*)
+let univ=ref true
+
+let string_of_var x=
+ if !univ then
+ "u"^(string_of_int x)
+ else
+ if x<=3 then String.make 1 (Char.chr(x+(Char.code 'w')))
+ else String.make 1 (Char.chr(x-4+(Char.code 'a')))
+
+let nsP = ref 0
+
+let rec string_of_Pcut p =
+ if (!nsP)<=0
+ then "..."
+ else
+ match p with
+ |Pint a-> nsP:=(!nsP)-1;
+ if C.le coef0 a
+ then C.to_string a
+ else "("^(C.to_string a)^")"
+ |Prec (x,t)->
+ let v=string_of_var x
+ and s=ref ""
+ and sp=ref "" in
+ let st0 = string_of_Pcut t.(0) in
+ if st0<>"0"
+ then s:=st0;
+ let fin = ref false in
+ for i=(Array.length t)-1 downto 1 do
+ if (!nsP)<0
+ then (sp:="...";
+ if not (!fin) then s:=(!s)^"+"^(!sp);
+ fin:=true)
+ else (
+ let si=string_of_Pcut t.(i) in
+ sp:="";
+ if i=1
+ then (
+ if si<>"0"
+ then (nsP:=(!nsP)-1;
+ if si="1"
+ then sp:=v
+ else
+ (if (String.contains si '+')
+ then sp:="("^si^")*"^v
+ else sp:=si^"*"^v)))
+ else (
+ if si<>"0"
+ then (nsP:=(!nsP)-1;
+ if si="1"
+ then sp:=v^"^"^(string_of_int i)
+ else (if (String.contains si '+')
+ then sp:="("^si^")*"^v^"^"^(string_of_int i)
+ else sp:=si^"*"^v^"^"^(string_of_int i))));
+ if !sp<>"" && not (!fin)
+ then (nsP:=(!nsP)-1;
+ if !s=""
+ then s:=!sp
+ else s:=(!s)^"+"^(!sp)));
+ done;
+ if !s="" then (nsP:=(!nsP)-1;
+ (s:="0"));
+ !s
+
+let to_string p =
+ nsP:=20;
+ string_of_Pcut p
+
+let printP p = Format.printf "@[%s@]" (to_string p)
+
+let print_tpoly lp =
+ let s = ref "\n{ " in
+ Array.iter (fun p -> s:=(!s)^(to_string p)^"\n") lp;
+ prt0 ((!s)^"}")
+
+let print_lpoly lp = print_tpoly (Array.of_list lp)
+
+(***********************************************************************
+ 4. Exact division of polynomials.
+*)
+
+(* return (s,r) s.t. p = s*q+r *)
+let rec quo_rem_pol p q x =
+ if x=0
+ then (match (p,q) with
+ |(Pint a, Pint b) ->
+ if C.equal (C.modulo a b) coef0
+ then (Pint (C.div a b), cf0)
+ else failwith "div_pol1"
+ |_ -> assert false)
+ else
+ let m = deg x q in
+ let b = coefDom x q in
+ let q1 = remP x q in (* q = b*x^m+q1 *)
+ let r = ref p in
+ let s = ref cf0 in
+ let continue =ref true in
+ while (!continue) && (not (equal !r cf0)) do
+ let n = deg x !r in
+ if n<m
+ then continue:=false
+ else (
+ let a = coefDom x !r in
+ let p1 = remP x !r in (* r = a*x^n+p1 *)
+ let c = div_pol a b (x-1) in (* a = c*b *)
+ let s1 = c @@ ((monome x (n-m))) in
+ s:= plusP (!s) s1;
+ r:= p1 -- (s1 @@ q1);
+ )
+ done;
+ (!s,!r)
+
+(* returns quotient p/q if q divides p, else fails *)
+and div_pol p q x =
+ let (s,r) = quo_rem_pol p q x in
+ if equal r cf0
+ then s
+ else failwith ("div_pol:\n"
+ ^"p:"^(to_string p)^"\n"
+ ^"q:"^(to_string q)^"\n"
+ ^"r:"^(to_string r)^"\n"
+ ^"x:"^(string_of_int x)^"\n"
+ )
+let divP p q=
+ let x = max (max_var_pol p) (max_var_pol q) in
+ div_pol p q x
+
+let div_pol_rat p q=
+ let x = max (max_var_pol p) (max_var_pol q) in
+ try (let s = div_pol (multP p (puisP (Pint(coef_int_tete q))
+ (1+(deg x p) - (deg x q))))
+ q x in
+ (* degueulasse, mais c 'est pour enlever un warning *)
+ if s==s then true else true)
+ with _ -> false
+
+(***********************************************************************
+ 5. Pseudo-division and gcd with subresultants.
+*)
+
+(* pseudo division :
+ q = c*x^m+q1
+ retruns (r,c,d,s) s.t. c^d*p = s*q + r.
+*)
+
+let pseudo_div p q x =
+ match q with
+ Pint _ -> (cf0, q,1, p)
+ | Prec (v,q1) when x<>v -> (cf0, q,1, p)
+ | Prec (v,q1) ->
+ (
+ (* pr "pseudo_division: c^d*p = s*q + r";*)
+ let delta = ref 0 in
+ let r = ref p in
+ let c = coefDom x q in
+ let q1 = remP x q in
+ let d' = deg x q in
+ let s = ref cf0 in
+ while (deg x !r)>=(deg x q) do
+ let d = deg x !r in
+ let a = coefDom x !r in
+ let r1=remP x !r in
+ let u = a @@ ((monome x (d-d'))) in
+ r:=(c @@ r1) -- (u @@ q1);
+ s:=plusP (c @@ (!s)) u;
+ delta := (!delta) + 1;
+ done;
+ (*
+ pr ("deg d: "^(string_of_int (!delta))^", deg c: "^(string_of_int (deg_total c)));
+ pr ("deg r:"^(string_of_int (deg_total !r)));
+ *)
+ (!r,c,!delta, !s)
+ )
+
+(* gcd with subresultants *)
+
+let rec pgcdP p q =
+ let x = max (max_var_pol p) (max_var_pol q) in
+ pgcd_pol p q x
+
+and pgcd_pol p q x =
+ pgcd_pol_rec p q x
+
+and content_pol p x =
+ match p with
+ Prec(v,p1) when v=x ->
+ Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1
+ | _ -> p
+
+and pgcd_coef_pol c p x =
+ match p with
+ Prec(v,p1) when x=v ->
+ Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c p1
+ |_ -> pgcd_pol_rec c p (x-1)
+
+and pgcd_pol_rec p q x =
+ match (p,q) with
+ (Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b))
+ |_ ->
+ if equal p cf0
+ then q
+ else if equal q cf0
+ then p
+ else if (deg x q) = 0
+ then pgcd_coef_pol q p x
+ else if (deg x p) = 0
+ then pgcd_coef_pol p q x
+ else (
+ let a = content_pol p x in
+ let b = content_pol q x in
+ let c = pgcd_pol_rec a b (x-1) in
+ pr (string_of_int x);
+ let p1 = div_pol p c x in
+ let q1 = div_pol q c x in
+ let r = gcd_sub_res p1 q1 x in
+ let cr = content_pol r x in
+ let res = c @@ (div_pol r cr x) in
+ res
+ )
+
+(* Sub-résultants:
+
+ ai*Ai = Qi*Ai+1 + bi*Ai+2
+
+ deg Ai+2 < deg Ai+1
+
+ Ai = ci*X^ni + ...
+ di = ni - ni+1
+
+ ai = (- ci+1)^(di + 1)
+ b1 = 1
+ bi = ci*si^di si i>1
+
+ s1 = 1
+ si+1 = ((ci+1)^di*si)/si^di
+
+*)
+and gcd_sub_res p q x =
+ if equal q cf0
+ then p
+ else
+ let d = deg x p in
+ let d' = deg x q in
+ if d<d'
+ then gcd_sub_res q p x
+ else
+ let delta = d-d' in
+ let c' = coefDom x q in
+ let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in
+ gcd_sub_res_rec q r (c'^^delta) c' d' x
+
+and gcd_sub_res_rec p q s c d x =
+ if equal q cf0
+ then p
+ else (
+ let d' = deg x q in
+ let c' = coefDom x q in
+ let delta = d-d' in
+ let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in
+ let s'= lazard_power c' s delta x in
+ gcd_sub_res_rec q (div_pol r (c @@ (s^^delta)) x) s' c' d' x
+ )
+
+and lazard_power c s d x =
+ let res = ref c in
+ for i=1 to d-1 do
+ res:= div_pol ((!res)@@c) s x;
+ done;
+ !res
+
+(* memoizations *)
+
+let rec hash = function
+ Pint a -> (C.hash a)
+ | Prec (v,p) ->
+ Array.fold_right (fun q h -> h + hash q) p 0
+
+module Hashpol = Hashtbl.Make(
+ struct
+ type poly = t
+ type t = poly
+ let equal = equal
+ let hash = hash
+ end)
+
+end
diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli
new file mode 100644
index 00000000..623d901e
--- /dev/null
+++ b/plugins/nsatz/polynom.mli
@@ -0,0 +1,97 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Building recursive polynom operations from a type of coefficients *)
+
+module type Coef = sig
+ type t
+ val equal : t -> t -> bool
+ val lt : t -> t -> bool
+ val le : t -> t -> bool
+ val abs : t -> t
+ val plus : t -> t -> t
+ val mult : t -> t -> t
+ val sub : t -> t -> t
+ val opp : t -> t
+ val div : t -> t -> t
+ val modulo : t -> t -> t
+ val puis : t -> int -> t
+ val pgcd : t -> t -> t
+
+ val hash : t -> int
+ val of_num : Num.num -> t
+ val to_string : t -> string
+end
+
+module type S = sig
+ type coef
+ type variable = int
+ type t = Pint of coef | Prec of variable * t array
+
+ val of_num : Num.num -> t
+ val x : variable -> t
+ val monome : variable -> int -> t
+ val is_constantP : t -> bool
+ val is_zero : t -> bool
+
+ val max_var_pol : t -> variable
+ val max_var_pol2 : t -> variable
+ val max_var : t array -> variable
+ val equal : t -> t -> bool
+ val norm : t -> t
+ val deg : variable -> t -> int
+ val deg_total : t -> int
+ val copyP : t -> t
+ val coef : variable -> int -> t -> t
+
+ val plusP : t -> t -> t
+ val content : t -> coef
+ val div_int : t -> coef -> t
+ val vire_contenu : t -> t
+ val vars : t -> variable list
+ val int_of_Pint : t -> coef
+ val multx : int -> variable -> t -> t
+ val multP : t -> t -> t
+ val deriv : variable -> t -> t
+ val oppP : t -> t
+ val moinsP : t -> t -> t
+ val puisP : t -> int -> t
+ val ( @@ ) : t -> t -> t
+ val ( -- ) : t -> t -> t
+ val ( ^^ ) : t -> int -> t
+ val coefDom : variable -> t -> t
+ val coefConst : variable -> t -> t
+ val remP : variable -> t -> t
+ val coef_int_tete : t -> coef
+ val normc : t -> t
+ val coef_constant : t -> coef
+ val univ : bool ref
+ val string_of_var : int -> string
+ val nsP : int ref
+ val to_string : t -> string
+ val printP : t -> unit
+ val print_tpoly : t array -> unit
+ val print_lpoly : t list -> unit
+ val quo_rem_pol : t -> t -> variable -> t * t
+ val div_pol : t -> t -> variable -> t
+ val divP : t -> t -> t
+ val div_pol_rat : t -> t -> bool
+ val pseudo_div : t -> t -> variable -> t * t * int * t
+ val pgcdP : t -> t -> t
+ val pgcd_pol : t -> t -> variable -> t
+ val content_pol : t -> variable -> t
+ val pgcd_coef_pol : t -> t -> variable -> t
+ val pgcd_pol_rec : t -> t -> variable -> t
+ val gcd_sub_res : t -> t -> variable -> t
+ val gcd_sub_res_rec : t -> t -> t -> t -> int -> variable -> t
+ val lazard_power : t -> t -> int -> variable -> t
+ val hash : t -> int
+ module Hashpol : Hashtbl.S with type key=t
+end
+
+module Make (C:Coef) : S with type coef = C.t
diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml
new file mode 100644
index 00000000..c16bd425
--- /dev/null
+++ b/plugins/nsatz/utile.ml
@@ -0,0 +1,130 @@
+(* Printing *)
+
+let pr x =
+ if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else ()
+
+let prn x =
+ if !Flags.debug then (Format.printf "@[%s\n@]" x; flush(stdout);) else ()
+
+let prt0 s = () (* print_string s;flush(stdout)*)
+
+let prt s =
+ if !Flags.debug then (print_string (s^"\n");flush(stdout)) else ()
+
+let info s =
+ Flags.if_verbose prerr_string s
+
+(* Lists *)
+
+let rec list_mem_eq eq x l =
+ match l with
+ [] -> false
+ |y::l1 -> if (eq x y) then true else (list_mem_eq eq x l1)
+
+let set_of_list_eq eq l =
+ let res = ref [] in
+ List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l;
+ List.rev !res
+
+
+(* Memoization
+ f is compatible with nf: f(nf(x)) = f(x)
+*)
+
+let memos s memoire nf f x =
+ try (let v = Hashtbl.find memoire (nf x) in pr s;v)
+ with _ -> (pr "#";
+ let v = f x in
+ Hashtbl.add memoire (nf x) v;
+ v)
+
+
+(**********************************************************************
+ Eléments minimaux pour un ordre partiel de division.
+ E est un ensemble, avec une multiplication
+ et une division partielle div (la fonction div peut échouer),
+ constant est un prédicat qui définit un sous-ensemble C de E.
+*)
+(*
+ Etant donnée une partie A de E, on calcule une partie B de E disjointe de C
+ telle que:
+ - les éléments de A sont des produits d'éléments de B et d'un de C.
+ - B est minimale pour cette propriété.
+*)
+
+let facteurs_liste div constant lp =
+ let lp = List.filter (fun x -> not (constant x)) lp in
+ let rec factor lmin lp = (* lmin: ne se divisent pas entre eux *)
+ match lp with
+ [] -> lmin
+ |p::lp1 ->
+ (let l1 = ref [] in
+ let p_dans_lmin = ref false in
+ List.iter (fun q -> try (let r = div p q in
+ if not (constant r)
+ then l1:=r::(!l1)
+ else p_dans_lmin:=true)
+ with _ -> ())
+ lmin;
+ if !p_dans_lmin
+ then factor lmin lp1
+ else if (!l1)=[]
+ (* aucun q de lmin ne divise p *)
+ then (let l1=ref lp1 in
+ let lmin1=ref [] in
+ List.iter (fun q -> try (let r = div q p in
+ if not (constant r)
+ then l1:=r::(!l1))
+ with _ -> lmin1:=q::(!lmin1))
+ lmin;
+ factor (List.rev (p::(!lmin1))) !l1)
+ (* au moins un q de lmin divise p non trivialement *)
+ else factor lmin ((!l1)@lp1))
+ in
+ factor [] lp
+
+
+(* On suppose que tout élément de A est produit d'éléments de B et d'un de C:
+ A et B sont deux tableaux, rend un tableau de couples
+ (élément de C, listes d'indices l)
+ tels que A.(i) = l.(i)_1*Produit(B.(j), j dans l.(i)_2)
+ zero est un prédicat sur E tel que (zero x) => (constant x):
+ si (zero x) est vrai on ne decompose pas x
+ c est un élément quelconque de E.
+*)
+let factorise_tableau div zero c f l1 =
+ let res = Array.create (Array.length f) (c,[]) in
+ Array.iteri (fun i p ->
+ let r = ref p in
+ let li = ref [] in
+ if not (zero p)
+ then
+ Array.iteri (fun j q ->
+ try (while true do
+ let rr = div !r q in
+ li:=j::(!li);
+ r:=rr;
+ done)
+ with _ -> ())
+ l1;
+ res.(i)<-(!r,!li))
+ f;
+ (l1,res)
+
+
+(* exemples:
+
+let l = [1;2;6;24;720]
+and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div")
+and constant = (fun x -> x<2)
+and zero = (fun x -> x=0)
+
+
+let f = facteurs_liste div1 constant l
+
+
+factorise_tableau div1 zero 0 (Array.of_list l) (Array.of_list f)
+
+*)
+
+
diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli
new file mode 100644
index 00000000..83b2ac39
--- /dev/null
+++ b/plugins/nsatz/utile.mli
@@ -0,0 +1,22 @@
+
+(* Printing *)
+val pr : string -> unit
+val prn : string -> unit
+val prt0 : 'a -> unit
+val prt : string -> unit
+val info : string -> unit
+
+(* Listes *)
+val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool
+val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list
+
+(* Memoization *)
+val memos :
+ string -> ('a, 'b) Hashtbl.t -> ('c -> 'a) -> ('c -> 'b) -> 'c -> 'b
+
+
+val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list
+val factorise_tableau :
+ ('a -> 'b -> 'a) ->
+ ('a -> bool) ->
+ 'a -> 'a array -> 'b array -> 'b array * ('a * int list) array
diff --git a/plugins/nsatz/vo.itarget b/plugins/nsatz/vo.itarget
new file mode 100644
index 00000000..4af4786d
--- /dev/null
+++ b/plugins/nsatz/vo.itarget
@@ -0,0 +1,3 @@
+NsatzR.vo
+Nsatz_domain.vo
+NsatzZ.vo
diff --git a/plugins/omega/Omega.v b/plugins/omega/Omega.v
new file mode 100644
index 00000000..30b94571
--- /dev/null
+++ b/plugins/omega/Omega.v
@@ -0,0 +1,59 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(**************************************************************************)
+(* *)
+(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *)
+(* *)
+(* Pierre Crégut (CNET, Lannion, France) *)
+(* *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+(* We do not require [ZArith] anymore, but only what's necessary for Omega *)
+Require Export ZArith_base.
+Require Export OmegaLemmas.
+Require Export PreOmega.
+Declare ML Module "omega_plugin".
+
+Hint Resolve Zle_refl Zplus_comm Zplus_assoc Zmult_comm Zmult_assoc Zplus_0_l
+ Zplus_0_r Zmult_1_l Zplus_opp_l Zplus_opp_r Zmult_plus_distr_l
+ Zmult_plus_distr_r: zarith.
+
+Require Export Zhints.
+
+(*
+(* The constant minus is required in coq_omega.ml *)
+Require Minus.
+*)
+
+Hint Extern 10 (_ = _ :>nat) => abstract omega: zarith.
+Hint Extern 10 (_ <= _) => abstract omega: zarith.
+Hint Extern 10 (_ < _) => abstract omega: zarith.
+Hint Extern 10 (_ >= _) => abstract omega: zarith.
+Hint Extern 10 (_ > _) => abstract omega: zarith.
+
+Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith.
+Hint Extern 10 (~ _ <= _) => abstract omega: zarith.
+Hint Extern 10 (~ _ < _) => abstract omega: zarith.
+Hint Extern 10 (~ _ >= _) => abstract omega: zarith.
+Hint Extern 10 (~ _ > _) => abstract omega: zarith.
+
+Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith.
+Hint Extern 10 (_ <= _)%Z => abstract omega: zarith.
+Hint Extern 10 (_ < _)%Z => abstract omega: zarith.
+Hint Extern 10 (_ >= _)%Z => abstract omega: zarith.
+Hint Extern 10 (_ > _)%Z => abstract omega: zarith.
+
+Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith.
+Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith.
+Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith.
+Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith.
+Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith.
+
+Hint Extern 10 False => abstract omega: zarith. \ No newline at end of file
diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v
new file mode 100644
index 00000000..56a854d6
--- /dev/null
+++ b/plugins/omega/OmegaLemmas.v
@@ -0,0 +1,302 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(*i $Id$ i*)
+
+Require Import ZArith_base.
+Open Local Scope Z_scope.
+
+(** Factorization lemmas *)
+
+Theorem Zred_factor0 : forall n:Z, n = n * 1.
+ intro x; rewrite (Zmult_1_r x); reflexivity.
+Qed.
+
+Theorem Zred_factor1 : forall n:Z, n + n = n * 2.
+Proof.
+ exact Zplus_diag_eq_mult_2.
+Qed.
+
+Theorem Zred_factor2 : forall n m:Z, n + n * m = n * (1 + m).
+Proof.
+ intros x y; pattern x at 1 in |- *; rewrite <- (Zmult_1_r x);
+ rewrite <- Zmult_plus_distr_r; trivial with arith.
+Qed.
+
+Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m).
+Proof.
+ intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x);
+ rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm;
+ trivial with arith.
+Qed.
+
+Theorem Zred_factor4 : forall n m p:Z, n * m + n * p = n * (m + p).
+Proof.
+ intros x y z; symmetry in |- *; apply Zmult_plus_distr_r.
+Qed.
+
+Theorem Zred_factor5 : forall n m:Z, n * 0 + m = m.
+Proof.
+ intros x y; rewrite <- Zmult_0_r_reverse; auto with arith.
+Qed.
+
+Theorem Zred_factor6 : forall n:Z, n = n + 0.
+Proof.
+ intro; rewrite Zplus_0_r; trivial with arith.
+Qed.
+
+(** Other specific variants of theorems dedicated for the Omega tactic *)
+
+Lemma new_var : forall x : Z, exists y : Z, x = y.
+intros x; exists x; trivial with arith.
+Qed.
+
+Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y.
+intros x y H; rewrite H; auto with arith.
+Qed.
+
+Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y.
+exact Zplus_le_0_compat.
+Qed.
+
+Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0.
+
+intros x y k H1 H2 H3; apply (Zmult_integral_l k);
+ [ unfold not in |- *; intros H4; absurd (k > 0);
+ [ rewrite H4; unfold Zgt in |- *; simpl in |- *; discriminate
+ | assumption ]
+ | rewrite <- H2; assumption ].
+Qed.
+
+Lemma OMEGA4 : forall x y z : Z, x > 0 -> y > x -> z * y + x <> 0.
+
+unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0);
+ [ intros H4; cut (0 <= z * y + x);
+ [ intros H5; generalize (Zmult_le_approx y z x H4 H2 H5); intros H6;
+ absurd (z * y + x > 0);
+ [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate
+ | apply Zle_gt_trans with x;
+ [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x);
+ apply Zplus_le_compat_r; rewrite Zmult_comm;
+ generalize H4; unfold Zgt in |- *; case y;
+ [ simpl in |- *; intros H7; discriminate H7
+ | intros p H7; rewrite <- (Zmult_0_r (Zpos p));
+ unfold Zle in |- *; rewrite Zcompare_mult_compat;
+ exact H6
+ | simpl in |- *; intros p H7; discriminate H7 ]
+ | assumption ] ]
+ | rewrite H3; unfold Zle in |- *; simpl in |- *; discriminate ]
+ | apply Zgt_trans with x; [ assumption | assumption ] ].
+Qed.
+
+Lemma OMEGA5 : forall x y z : Z, x = 0 -> y = 0 -> x + y * z = 0.
+
+intros x y z H1 H2; rewrite H1; rewrite H2; simpl in |- *; trivial with arith.
+Qed.
+
+Lemma OMEGA6 : forall x y z : Z, 0 <= x -> y = 0 -> 0 <= x + y * z.
+
+intros x y z H1 H2; rewrite H2; simpl in |- *; rewrite Zplus_0_r; assumption.
+Qed.
+
+Lemma OMEGA7 :
+ forall x y z t : Z, z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t.
+
+intros x y z t H1 H2 H3 H4; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat;
+ apply Zmult_gt_0_le_0_compat; assumption.
+Qed.
+
+Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0.
+
+intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1);
+ [ intros H4; absurd (0 < x);
+ [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y;
+ rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r;
+ assumption
+ | assumption ]
+ | intros H4; rewrite H4; trivial with arith ].
+Qed.
+
+Lemma OMEGA9 : forall x y z t : Z, y = 0 -> x = z -> y + (- x + z) * t = 0.
+
+intros x y z t H1 H2; rewrite H2; rewrite Zplus_opp_l; rewrite Zmult_0_l;
+ rewrite Zplus_0_r; assumption.
+Qed.
+
+Lemma OMEGA10 :
+ forall v c1 c2 l1 l2 k1 k2 : Z,
+ (v * c1 + l1) * k1 + (v * c2 + l2) * k2 =
+ v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2).
+
+intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
+ rewrite (Zplus_permute (l1 * k1) (v * c2 * k2)); trivial with arith.
+Qed.
+
+Lemma OMEGA11 :
+ forall v1 c1 l1 l2 k1 : Z,
+ (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2).
+
+intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
+ trivial with arith.
+Qed.
+
+Lemma OMEGA12 :
+ forall v2 c2 l1 l2 k2 : Z,
+ l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2).
+
+intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
+ rewrite Zplus_permute; trivial with arith.
+Qed.
+
+Lemma OMEGA13 :
+ forall (v l1 l2 : Z) (x : positive),
+ v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2.
+
+intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1);
+ rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
+ rewrite <- Zopp_neg; rewrite (Zplus_comm (- Zneg x) (Zneg x));
+ rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r;
+ trivial with arith.
+Qed.
+
+Lemma OMEGA14 :
+ forall (v l1 l2 : Z) (x : positive),
+ v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2.
+
+intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zneg x) l1);
+ rewrite (Zplus_assoc_reverse l1); rewrite <- Zmult_plus_distr_r;
+ rewrite <- Zopp_neg; rewrite Zplus_opp_r; rewrite Zmult_0_r;
+ rewrite Zplus_0_r; trivial with arith.
+Qed.
+Lemma OMEGA15 :
+ forall v c1 c2 l1 l2 k2 : Z,
+ v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2).
+
+intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
+ rewrite (Zplus_permute l1 (v * c2 * k2)); trivial with arith.
+Qed.
+
+Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k.
+
+intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r;
+ repeat rewrite Zmult_assoc; repeat elim Zplus_assoc;
+ trivial with arith.
+Qed.
+
+Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
+
+unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1;
+ apply Zplus_reg_l with (y * z); rewrite Zplus_comm;
+ rewrite H3; rewrite H2; auto with arith.
+Qed.
+
+Lemma OMEGA18 : forall x y k : Z, x = y * k -> Zne x 0 -> Zne y 0.
+
+unfold Zne, not in |- *; intros x y k H1 H2 H3; apply H2; rewrite H1;
+ rewrite H3; auto with arith.
+Qed.
+
+Lemma OMEGA19 : forall x : Z, Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1.
+
+unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x);
+ [ intros H1; elim Zle_lt_or_eq with (1 := H1);
+ [ intros H2; left; change (0 <= Zpred x) in |- *; apply Zsucc_le_reg;
+ rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption
+ | intros H2; absurd (x = 0); auto with arith ]
+ | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm;
+ apply Zle_left; apply Zsucc_le_reg; simpl in |- *;
+ apply Zlt_le_succ; auto with arith ].
+Qed.
+
+Lemma OMEGA20 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
+
+unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; rewrite H2 in H3;
+ simpl in H3; rewrite Zplus_0_r in H3; trivial with arith.
+Qed.
+
+Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop)
+ (H : P (y + x)) := eq_ind_r P H (Zplus_comm x y).
+
+Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop)
+ (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p).
+
+Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop)
+ (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p).
+
+Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop)
+ (H : P (m + (n + p))) := eq_ind_r P H (Zplus_permute n m p).
+
+Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop)
+ (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) :=
+ eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2).
+
+Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop)
+ (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) :=
+ eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1).
+Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop)
+ (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) :=
+ eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2).
+
+Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop)
+ (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) :=
+ eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2).
+Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop)
+ (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k).
+
+Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
+ (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x).
+
+Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
+ (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x).
+Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop)
+ (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x).
+
+Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop)
+ (H : P (x * -1)) := eq_ind_r P H (Zopp_eq_mult_neg_1 x).
+
+Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop)
+ (H : P (y * x)) := eq_ind_r P H (Zmult_comm x y).
+
+Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop)
+ (H : P (- x + - y)) := eq_ind_r P H (Zopp_plus_distr x y).
+
+Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) :=
+ eq_ind_r P H (Zopp_involutive x).
+
+Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop)
+ (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y).
+
+Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop)
+ (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p).
+Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop)
+ (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y).
+
+Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop)
+ (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p).
+
+Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop)
+ (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x).
+
+Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop)
+ (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y).
+
+Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop)
+ (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y).
+
+Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop)
+ (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z).
+
+Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop)
+ (H : P y) := eq_ind_r P H (Zred_factor5 x y).
+
+Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop)
+ (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x).
diff --git a/plugins/omega/OmegaPlugin.v b/plugins/omega/OmegaPlugin.v
new file mode 100644
index 00000000..21535f0d
--- /dev/null
+++ b/plugins/omega/OmegaPlugin.v
@@ -0,0 +1,11 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Declare ML Module "omega_plugin".
diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v
new file mode 100644
index 00000000..a5a085a9
--- /dev/null
+++ b/plugins/omega/PreOmega.v
@@ -0,0 +1,445 @@
+Require Import Arith Max Min ZArith_base NArith Nnat.
+
+Open Local Scope Z_scope.
+
+
+(** * zify: the Z-ification tactic *)
+
+(* This tactic searches for nat and N and positive elements in the goal and
+ translates everything into Z. It is meant as a pre-processor for
+ (r)omega; for instance a positivity hypothesis is added whenever
+ - a multiplication is encountered
+ - an atom is encountered (that is a variable or an unknown construct)
+
+ Recognized relations (can be handled as deeply as allowed by setoid rewrite):
+ - { eq, le, lt, ge, gt } on { Z, positive, N, nat }
+
+ Recognized operations:
+ - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < =
+ - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat
+ - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat
+ - on N: N0 Npos + * - Nsucc Nmin Nmax N_of_nat Zabs_N
+*)
+
+
+
+
+(** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *)
+
+Ltac zify_unop_core t thm a :=
+ (* Let's introduce the specification theorem for t *)
+ let H:= fresh "H" in assert (H:=thm a);
+ (* Then we replace (t a) everywhere with a fresh variable *)
+ let z := fresh "z" in set (z:=t a) in *; clearbody z.
+
+Ltac zify_unop_var_or_term t thm a :=
+ (* If a is a variable, no need for aliasing *)
+ let za := fresh "z" in
+ (rename a into za; rename za into a; zify_unop_core t thm a) ||
+ (* Otherwise, a is a complex term: we alias it. *)
+ (remember a as za; zify_unop_core t thm za).
+
+Ltac zify_unop t thm a :=
+ (* if a is a scalar, we can simply reduce the unop *)
+ let isz := isZcst a in
+ match isz with
+ | true => simpl (t a) in *
+ | _ => zify_unop_var_or_term t thm a
+ end.
+
+Ltac zify_unop_nored t thm a :=
+ (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *)
+ let isz := isZcst a in
+ match isz with
+ | true => zify_unop_core t thm a
+ | _ => zify_unop_var_or_term t thm a
+ end.
+
+Ltac zify_binop t thm a b:=
+ (* works as zify_unop, except that we should be careful when
+ dealing with b, since it can be equal to a *)
+ let isza := isZcst a in
+ match isza with
+ | true => zify_unop (t a) (thm a) b
+ | _ =>
+ let za := fresh "z" in
+ (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) ||
+ (remember a as za; match goal with
+ | H : za = b |- _ => zify_unop_nored (t za) (thm za) za
+ | _ => zify_unop_nored (t za) (thm za) b
+ end)
+ end.
+
+Ltac zify_op_1 :=
+ match goal with
+ | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b
+ | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b
+ | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b
+ | H : context [ Zmin ?a ?b ] |- _ => zify_binop Zmin Zmin_spec a b
+ | |- context [ Zsgn ?a ] => zify_unop Zsgn Zsgn_spec a
+ | H : context [ Zsgn ?a ] |- _ => zify_unop Zsgn Zsgn_spec a
+ | |- context [ Zabs ?a ] => zify_unop Zabs Zabs_spec a
+ | H : context [ Zabs ?a ] |- _ => zify_unop Zabs Zabs_spec a
+ end.
+
+Ltac zify_op := repeat zify_op_1.
+
+
+
+
+
+(** II) Conversion from nat to Z *)
+
+
+Definition Z_of_nat' := Z_of_nat.
+
+Ltac hide_Z_of_nat t :=
+ let z := fresh "z" in set (z:=Z_of_nat t) in *;
+ change Z_of_nat with Z_of_nat' in z;
+ unfold z in *; clear z.
+
+Ltac zify_nat_rel :=
+ match goal with
+ (* I: equalities *)
+ | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H
+ | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b)
+ | H : context [ @eq nat ?a ?b ] |- _ => rewrite (inj_eq_iff a b) in H
+ | |- context [ @eq nat ?a ?b ] => rewrite (inj_eq_iff a b)
+ (* II: less than *)
+ | H : (lt ?a ?b) |- _ => generalize (inj_lt _ _ H); clear H; intro H
+ | |- (lt ?a ?b) => apply (inj_lt_rev a b)
+ | H : context [ lt ?a ?b ] |- _ => rewrite (inj_lt_iff a b) in H
+ | |- context [ lt ?a ?b ] => rewrite (inj_lt_iff a b)
+ (* III: less or equal *)
+ | H : (le ?a ?b) |- _ => generalize (inj_le _ _ H); clear H; intro H
+ | |- (le ?a ?b) => apply (inj_le_rev a b)
+ | H : context [ le ?a ?b ] |- _ => rewrite (inj_le_iff a b) in H
+ | |- context [ le ?a ?b ] => rewrite (inj_le_iff a b)
+ (* IV: greater than *)
+ | H : (gt ?a ?b) |- _ => generalize (inj_gt _ _ H); clear H; intro H
+ | |- (gt ?a ?b) => apply (inj_gt_rev a b)
+ | H : context [ gt ?a ?b ] |- _ => rewrite (inj_gt_iff a b) in H
+ | |- context [ gt ?a ?b ] => rewrite (inj_gt_iff a b)
+ (* V: greater or equal *)
+ | H : (ge ?a ?b) |- _ => generalize (inj_ge _ _ H); clear H; intro H
+ | |- (ge ?a ?b) => apply (inj_ge_rev a b)
+ | H : context [ ge ?a ?b ] |- _ => rewrite (inj_ge_iff a b) in H
+ | |- context [ ge ?a ?b ] => rewrite (inj_ge_iff a b)
+ end.
+
+Ltac zify_nat_op :=
+ match goal with
+ (* misc type conversions: positive/N/Z to nat *)
+ | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H
+ | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a)
+ | H : context [ Z_of_nat (nat_of_N ?a) ] |- _ => rewrite (Z_of_nat_of_N a) in H
+ | |- context [ Z_of_nat (nat_of_N ?a) ] => rewrite (Z_of_nat_of_N a)
+ | H : context [ Z_of_nat (Zabs_nat ?a) ] |- _ => rewrite (inj_Zabs_nat a) in H
+ | |- context [ Z_of_nat (Zabs_nat ?a) ] => rewrite (inj_Zabs_nat a)
+
+ (* plus -> Zplus *)
+ | H : context [ Z_of_nat (plus ?a ?b) ] |- _ => rewrite (inj_plus a b) in H
+ | |- context [ Z_of_nat (plus ?a ?b) ] => rewrite (inj_plus a b)
+
+ (* min -> Zmin *)
+ | H : context [ Z_of_nat (min ?a ?b) ] |- _ => rewrite (inj_min a b) in H
+ | |- context [ Z_of_nat (min ?a ?b) ] => rewrite (inj_min a b)
+
+ (* max -> Zmax *)
+ | H : context [ Z_of_nat (max ?a ?b) ] |- _ => rewrite (inj_max a b) in H
+ | |- context [ Z_of_nat (max ?a ?b) ] => rewrite (inj_max a b)
+
+ (* minus -> Zmax (Zminus ... ...) 0 *)
+ | H : context [ Z_of_nat (minus ?a ?b) ] |- _ => rewrite (inj_minus a b) in H
+ | |- context [ Z_of_nat (minus ?a ?b) ] => rewrite (inj_minus a b)
+
+ (* pred -> minus ... -1 -> Zmax (Zminus ... -1) 0 *)
+ | H : context [ Z_of_nat (pred ?a) ] |- _ => rewrite (pred_of_minus a) in H
+ | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a)
+
+ (* mult -> Zmult and a positivity hypothesis *)
+ | H : context [ Z_of_nat (mult ?a ?b) ] |- _ =>
+ let H:= fresh "H" in
+ assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
+ | |- context [ Z_of_nat (mult ?a ?b) ] =>
+ let H:= fresh "H" in
+ assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in *
+
+ (* O -> Z0 *)
+ | H : context [ Z_of_nat O ] |- _ => simpl (Z_of_nat O) in H
+ | |- context [ Z_of_nat O ] => simpl (Z_of_nat O)
+
+ (* S -> number or Zsucc *)
+ | H : context [ Z_of_nat (S ?a) ] |- _ =>
+ let isnat := isnatcst a in
+ match isnat with
+ | true => simpl (Z_of_nat (S a)) in H
+ | _ => rewrite (inj_S a) in H
+ end
+ | |- context [ Z_of_nat (S ?a) ] =>
+ let isnat := isnatcst a in
+ match isnat with
+ | true => simpl (Z_of_nat (S a))
+ | _ => rewrite (inj_S a)
+ 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
+ end.
+
+Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *.
+
+
+
+
+(* III) conversion from positive to Z *)
+
+Definition Zpos' := Zpos.
+Definition Zneg' := Zneg.
+
+Ltac hide_Zpos t :=
+ let z := fresh "z" in set (z:=Zpos t) in *;
+ change Zpos with Zpos' in z;
+ unfold z in *; clear z.
+
+Ltac zify_positive_rel :=
+ match goal with
+ (* I: equalities *)
+ | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H
+ | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b)
+ | H : context [ @eq positive ?a ?b ] |- _ => rewrite (Zpos_eq_iff a b) in H
+ | |- context [ @eq positive ?a ?b ] => rewrite (Zpos_eq_iff a b)
+ (* 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)
+ (* 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)
+ (* 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)
+ (* 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)
+ end.
+
+Ltac zify_positive_op :=
+ match goal with
+ (* Zneg -> -Zpos (except for numbers) *)
+ | H : context [ Zneg ?a ] |- _ =>
+ let isp := isPcst a in
+ match isp with
+ | true => change (Zneg a) with (Zneg' a) in H
+ | _ => change (Zneg a) with (- Zpos a) in H
+ end
+ | |- context [ Zneg ?a ] =>
+ let isp := isPcst a in
+ match isp with
+ | true => change (Zneg a) with (Zneg' a)
+ | _ => change (Zneg a) with (- Zpos a)
+ end
+
+ (* misc type conversions: nat to positive *)
+ | H : context [ Zpos (P_of_succ_nat ?a) ] |- _ => rewrite (Zpos_P_of_succ_nat a) in H
+ | |- context [ Zpos (P_of_succ_nat ?a) ] => rewrite (Zpos_P_of_succ_nat a)
+
+ (* Pplus -> Zplus *)
+ | H : context [ Zpos (Pplus ?a ?b) ] |- _ => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b)) in H
+ | |- context [ Zpos (Pplus ?a ?b) ] => change (Zpos (Pplus a b)) with (Zplus (Zpos a) (Zpos b))
+
+ (* Pmin -> Zmin *)
+ | H : context [ Zpos (Pmin ?a ?b) ] |- _ => rewrite (Zpos_min a b) in H
+ | |- context [ Zpos (Pmin ?a ?b) ] => rewrite (Zpos_min a b)
+
+ (* Pmax -> Zmax *)
+ | H : context [ Zpos (Pmax ?a ?b) ] |- _ => rewrite (Zpos_max a b) in H
+ | |- context [ Zpos (Pmax ?a ?b) ] => rewrite (Zpos_max a b)
+
+ (* Pminus -> Zmax 1 (Zminus ... ...) *)
+ | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H
+ | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b)
+
+ (* Psucc -> Zsucc *)
+ | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H
+ | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a)
+
+ (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *)
+ | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H
+ | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a)
+
+ (* Pmult -> Zmult and a positivity hypothesis *)
+ | H : context [ Zpos (Pmult ?a ?b) ] |- _ =>
+ let H:= fresh "H" in
+ assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
+ | |- context [ Zpos (Pmult ?a ?b) ] =>
+ let H:= fresh "H" in
+ assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in *
+
+ (* xO *)
+ | H : context [ Zpos (xO ?a) ] |- _ =>
+ let isp := isPcst a in
+ match isp with
+ | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H
+ | _ => rewrite (Zpos_xO a) in H
+ end
+ | |- context [ Zpos (xO ?a) ] =>
+ let isp := isPcst a in
+ match isp with
+ | true => change (Zpos (xO a)) with (Zpos' (xO a))
+ | _ => rewrite (Zpos_xO a)
+ end
+ (* xI *)
+ | H : context [ Zpos (xI ?a) ] |- _ =>
+ let isp := isPcst a in
+ match isp with
+ | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H
+ | _ => rewrite (Zpos_xI a) in H
+ end
+ | |- context [ Zpos (xI ?a) ] =>
+ let isp := isPcst a in
+ match isp with
+ | true => change (Zpos (xI a)) with (Zpos' (xI a))
+ | _ => rewrite (Zpos_xI a)
+ end
+
+ (* xI : nothing to do, just prevent adding a useless positivity condition *)
+ | H : context [ Zpos xH ] |- _ => hide_Zpos xH
+ | |- 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
+ end.
+
+Ltac zify_positive :=
+ repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *.
+
+
+
+
+
+(* IV) conversion from N to Z *)
+
+Definition Z_of_N' := Z_of_N.
+
+Ltac hide_Z_of_N t :=
+ let z := fresh "z" in set (z:=Z_of_N t) in *;
+ change Z_of_N with Z_of_N' in z;
+ unfold z in *; clear z.
+
+Ltac zify_N_rel :=
+ match goal with
+ (* I: equalities *)
+ | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H
+ | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b)
+ | H : context [ @eq N ?a ?b ] |- _ => rewrite (Z_of_N_eq_iff a b) in H
+ | |- context [ @eq N ?a ?b ] => rewrite (Z_of_N_eq_iff a b)
+ (* 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)
+ (* 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)
+ (* 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)
+ (* 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)
+ end.
+
+Ltac zify_N_op :=
+ match goal with
+ (* misc type conversions: nat to positive *)
+ | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H
+ | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a)
+ | H : context [ Z_of_N (Zabs_N ?a) ] |- _ => rewrite (Z_of_N_abs a) in H
+ | |- context [ Z_of_N (Zabs_N ?a) ] => rewrite (Z_of_N_abs a)
+ | H : context [ Z_of_N (Npos ?a) ] |- _ => rewrite (Z_of_N_pos a) in H
+ | |- context [ Z_of_N (Npos ?a) ] => rewrite (Z_of_N_pos a)
+ | H : context [ Z_of_N N0 ] |- _ => change (Z_of_N N0) with Z0 in H
+ | |- context [ Z_of_N N0 ] => change (Z_of_N N0) with Z0
+
+ (* Nplus -> Zplus *)
+ | H : context [ Z_of_N (Nplus ?a ?b) ] |- _ => rewrite (Z_of_N_plus a b) in H
+ | |- context [ Z_of_N (Nplus ?a ?b) ] => rewrite (Z_of_N_plus a b)
+
+ (* Nmin -> Zmin *)
+ | H : context [ Z_of_N (Nmin ?a ?b) ] |- _ => rewrite (Z_of_N_min a b) in H
+ | |- context [ Z_of_N (Nmin ?a ?b) ] => rewrite (Z_of_N_min a b)
+
+ (* Nmax -> Zmax *)
+ | H : context [ Z_of_N (Nmax ?a ?b) ] |- _ => rewrite (Z_of_N_max a b) in H
+ | |- context [ Z_of_N (Nmax ?a ?b) ] => rewrite (Z_of_N_max a b)
+
+ (* Nminus -> Zmax 0 (Zminus ... ...) *)
+ | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H
+ | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b)
+
+ (* Nsucc -> Zsucc *)
+ | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H
+ | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a)
+
+ (* Nmult -> Zmult and a positivity hypothesis *)
+ | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ =>
+ let H:= fresh "H" in
+ assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
+ | |- context [ Z_of_N (Nmult ?a ?b) ] =>
+ let H:= fresh "H" in
+ assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in *
+
+ (* 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
+ end.
+
+Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.
+
+
+
+(** The complete Z-ification tactic *)
+
+Ltac zify :=
+ repeat progress (zify_nat; zify_positive; zify_N); zify_op.
+
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
new file mode 100644
index 00000000..60616845
--- /dev/null
+++ b/plugins/omega/coq_omega.ml
@@ -0,0 +1,1823 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(**************************************************************************)
+(* *)
+(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *)
+(* *)
+(* Pierre Crégut (CNET, Lannion, France) *)
+(* *)
+(**************************************************************************)
+
+(* $Id$ *)
+
+open Util
+open Pp
+open Reduction
+open Proof_type
+open Names
+open Nameops
+open Term
+open Termops
+open Declarations
+open Environ
+open Sign
+open Inductive
+open Tacticals
+open Tacmach
+open Evar_refiner
+open Tactics
+open Clenv
+open Logic
+open Libnames
+open Nametab
+open Contradiction
+
+module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
+open OmegaSolver
+
+(* Added by JCF, 09/03/98 *)
+
+let elim_id id gl = simplest_elim (pf_global gl id) gl
+let resolve_id id gl = apply (pf_global gl id) gl
+
+let timing timer_name f arg = f arg
+
+let display_time_flag = ref false
+let display_system_flag = ref false
+let display_action_flag = ref false
+let old_style_flag = ref false
+
+let read f () = !f
+let write f x = f:=x
+
+open Goptions
+
+let _ =
+ declare_bool_option
+ { optsync = false;
+ optname = "Omega system time displaying flag";
+ optkey = ["Omega";"System"];
+ optread = read display_system_flag;
+ optwrite = write display_system_flag }
+
+let _ =
+ declare_bool_option
+ { optsync = false;
+ optname = "Omega action display flag";
+ optkey = ["Omega";"Action"];
+ optread = read display_action_flag;
+ optwrite = write display_action_flag }
+
+let _ =
+ declare_bool_option
+ { optsync = false;
+ optname = "Omega old style flag";
+ optkey = ["Omega";"OldStyle"];
+ optread = read old_style_flag;
+ optwrite = write old_style_flag }
+
+
+let all_time = timing "Omega "
+let solver_time = timing "Solver "
+let exact_time = timing "Rewrites "
+let elim_time = timing "Elim "
+let simpl_time = timing "Simpl "
+let generalize_time = timing "Generalize"
+
+let new_identifier =
+ let cpt = ref 0 in
+ (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s)
+
+let new_identifier_state =
+ let cpt = ref 0 in
+ (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s)
+
+let new_identifier_var =
+ let cpt = ref 0 in
+ (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s)
+
+let new_id =
+ let cpt = ref 0 in fun () -> incr cpt; !cpt
+
+let new_var_num =
+ let cpt = ref 1000 in (fun () -> incr cpt; !cpt)
+
+let new_var =
+ let cpt = ref 0 in fun () -> incr cpt; Nameops.make_ident "WW" (Some !cpt)
+
+let display_var i = Printf.sprintf "X%d" i
+
+let intern_id,unintern_id =
+ let cpt = ref 0 in
+ let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in
+ (fun (name : identifier) ->
+ try Hashtbl.find table name with Not_found ->
+ let idx = !cpt in
+ Hashtbl.add table name idx;
+ Hashtbl.add co_table idx name;
+ incr cpt; idx),
+ (fun idx ->
+ try Hashtbl.find co_table idx with Not_found ->
+ let v = new_var () in
+ Hashtbl.add table v idx; Hashtbl.add co_table idx v; v)
+
+let mk_then = tclTHENLIST
+
+let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c])
+
+let generalize_tac t = generalize_time (generalize t)
+let elim t = elim_time (simplest_elim t)
+let exact t = exact_time (Tactics.refine t)
+let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s]
+
+let rev_assoc k =
+ let rec loop = function
+ | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l
+ in
+ loop
+
+let tag_hypothesis,tag_of_hyp, hyp_of_tag =
+ let l = ref ([]:(identifier * int) list) in
+ (fun h id -> l := (h,id):: !l),
+ (fun h -> try List.assoc h !l with Not_found -> failwith "tag_hypothesis"),
+ (fun h -> try rev_assoc h !l with Not_found -> failwith "tag_hypothesis")
+
+let hide_constr,find_constr,clear_tables,dump_tables =
+ let l = ref ([]:(constr * (identifier * identifier * bool)) list) in
+ (fun h id eg b -> l := (h,(id,eg,b)):: !l),
+ (fun h -> try List.assoc h !l with Not_found -> failwith "find_contr"),
+ (fun () -> l := []),
+ (fun () -> !l)
+
+(* Lazy evaluation is used for Coq constants, because this code
+ is evaluated before the compiled modules are loaded.
+ To use the constant Zplus, one must type "Lazy.force coq_Zplus"
+ This is the right way to access to Coq constants in tactics ML code *)
+
+open Coqlib
+
+let logic_dir = ["Coq";"Logic";"Decidable"]
+let coq_modules =
+ init_modules @arith_modules @ [logic_dir] @ zarith_base_modules
+ @ [["Coq"; "omega"; "OmegaLemmas"]]
+
+let init_constant = gen_constant_in_modules "Omega" init_modules
+let constant = gen_constant_in_modules "Omega" coq_modules
+
+(* Zarith *)
+let coq_xH = lazy (constant "xH")
+let coq_xO = lazy (constant "xO")
+let coq_xI = lazy (constant "xI")
+let coq_Z0 = lazy (constant "Z0")
+let coq_Zpos = lazy (constant "Zpos")
+let coq_Zneg = lazy (constant "Zneg")
+let coq_Z = lazy (constant "Z")
+let coq_comparison = lazy (constant "comparison")
+let coq_Gt = lazy (constant "Gt")
+let coq_Zplus = lazy (constant "Zplus")
+let coq_Zmult = lazy (constant "Zmult")
+let coq_Zopp = lazy (constant "Zopp")
+let coq_Zminus = lazy (constant "Zminus")
+let coq_Zsucc = lazy (constant "Zsucc")
+let coq_Zgt = lazy (constant "Zgt")
+let coq_Zle = lazy (constant "Zle")
+let coq_Z_of_nat = lazy (constant "Z_of_nat")
+let coq_inj_plus = lazy (constant "inj_plus")
+let coq_inj_mult = lazy (constant "inj_mult")
+let coq_inj_minus1 = lazy (constant "inj_minus1")
+let coq_inj_minus2 = lazy (constant "inj_minus2")
+let coq_inj_S = lazy (constant "inj_S")
+let coq_inj_le = lazy (constant "inj_le")
+let coq_inj_lt = lazy (constant "inj_lt")
+let coq_inj_ge = lazy (constant "inj_ge")
+let coq_inj_gt = lazy (constant "inj_gt")
+let coq_inj_neq = lazy (constant "inj_neq")
+let coq_inj_eq = lazy (constant "inj_eq")
+let coq_fast_Zplus_assoc_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")
+let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute")
+let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm")
+let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm")
+let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx")
+let coq_OMEGA1 = lazy (constant "OMEGA1")
+let coq_OMEGA2 = lazy (constant "OMEGA2")
+let coq_OMEGA3 = lazy (constant "OMEGA3")
+let coq_OMEGA4 = lazy (constant "OMEGA4")
+let coq_OMEGA5 = lazy (constant "OMEGA5")
+let coq_OMEGA6 = lazy (constant "OMEGA6")
+let coq_OMEGA7 = lazy (constant "OMEGA7")
+let coq_OMEGA8 = lazy (constant "OMEGA8")
+let coq_OMEGA9 = lazy (constant "OMEGA9")
+let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10")
+let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11")
+let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12")
+let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13")
+let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14")
+let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15")
+let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16")
+let coq_OMEGA17 = lazy (constant "OMEGA17")
+let coq_OMEGA18 = lazy (constant "OMEGA18")
+let coq_OMEGA19 = lazy (constant "OMEGA19")
+let coq_OMEGA20 = lazy (constant "OMEGA20")
+let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0")
+let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1")
+let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2")
+let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3")
+let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4")
+let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5")
+let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6")
+let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l")
+let coq_fast_Zmult_opp_comm = lazy (constant "fast_Zmult_opp_comm")
+let coq_fast_Zopp_plus_distr = lazy (constant "fast_Zopp_plus_distr")
+let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r")
+let coq_fast_Zopp_eq_mult_neg_1 = lazy (constant "fast_Zopp_eq_mult_neg_1")
+let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive")
+let coq_Zegal_left = lazy (constant "Zegal_left")
+let coq_Zne_left = lazy (constant "Zne_left")
+let coq_Zlt_left = lazy (constant "Zlt_left")
+let coq_Zge_left = lazy (constant "Zge_left")
+let coq_Zgt_left = lazy (constant "Zgt_left")
+let coq_Zle_left = lazy (constant "Zle_left")
+let coq_new_var = lazy (constant "new_var")
+let coq_intro_Z = lazy (constant "intro_Z")
+
+let coq_dec_eq = lazy (constant "dec_eq")
+let coq_dec_Zne = lazy (constant "dec_Zne")
+let coq_dec_Zle = lazy (constant "dec_Zle")
+let coq_dec_Zlt = lazy (constant "dec_Zlt")
+let coq_dec_Zgt = lazy (constant "dec_Zgt")
+let coq_dec_Zge = lazy (constant "dec_Zge")
+
+let coq_not_Zeq = lazy (constant "not_Zeq")
+let coq_Znot_le_gt = lazy (constant "Znot_le_gt")
+let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge")
+let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt")
+let coq_Znot_gt_le = lazy (constant "Znot_gt_le")
+let coq_neq = lazy (constant "neq")
+let coq_Zne = lazy (constant "Zne")
+let coq_Zle = lazy (constant "Zle")
+let coq_Zgt = lazy (constant "Zgt")
+let coq_Zge = lazy (constant "Zge")
+let coq_Zlt = lazy (constant "Zlt")
+
+(* Peano/Datatypes *)
+let coq_le = lazy (init_constant "le")
+let coq_lt = lazy (init_constant "lt")
+let coq_ge = lazy (init_constant "ge")
+let coq_gt = lazy (init_constant "gt")
+let coq_minus = lazy (init_constant "minus")
+let coq_plus = lazy (init_constant "plus")
+let coq_mult = lazy (init_constant "mult")
+let coq_pred = lazy (init_constant "pred")
+let coq_nat = lazy (init_constant "nat")
+let coq_S = lazy (init_constant "S")
+let coq_O = lazy (init_constant "O")
+
+(* Compare_dec/Peano_dec/Minus *)
+let coq_pred_of_minus = lazy (constant "pred_of_minus")
+let coq_le_gt_dec = lazy (constant "le_gt_dec")
+let coq_dec_eq_nat = lazy (constant "dec_eq_nat")
+let coq_dec_le = lazy (constant "dec_le")
+let coq_dec_lt = lazy (constant "dec_lt")
+let coq_dec_ge = lazy (constant "dec_ge")
+let coq_dec_gt = lazy (constant "dec_gt")
+let coq_not_eq = lazy (constant "not_eq")
+let coq_not_le = lazy (constant "not_le")
+let coq_not_lt = lazy (constant "not_lt")
+let coq_not_ge = lazy (constant "not_ge")
+let coq_not_gt = lazy (constant "not_gt")
+
+(* Logic/Decidable *)
+let coq_eq_ind_r = lazy (constant "eq_ind_r")
+
+let coq_dec_or = lazy (constant "dec_or")
+let coq_dec_and = lazy (constant "dec_and")
+let coq_dec_imp = lazy (constant "dec_imp")
+let coq_dec_iff = lazy (constant "dec_iff")
+let coq_dec_not = lazy (constant "dec_not")
+let coq_dec_False = lazy (constant "dec_False")
+let coq_dec_not_not = lazy (constant "dec_not_not")
+let coq_dec_True = lazy (constant "dec_True")
+
+let coq_not_or = lazy (constant "not_or")
+let coq_not_and = lazy (constant "not_and")
+let coq_not_imp = lazy (constant "not_imp")
+let coq_not_iff = lazy (constant "not_iff")
+let coq_not_not = lazy (constant "not_not")
+let coq_imp_simp = lazy (constant "imp_simp")
+let coq_iff = lazy (constant "iff")
+
+(* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *)
+
+(* For unfold *)
+open Closure
+let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with
+ | Const kn when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) ->
+ EvalConstRef kn
+ | _ -> anomaly ("Coq_omega: "^s^" is not an evaluable constant")
+
+let sp_Zsucc = lazy (evaluable_ref_of_constr "Zsucc" coq_Zsucc)
+let sp_Zminus = lazy (evaluable_ref_of_constr "Zminus" coq_Zminus)
+let sp_Zle = lazy (evaluable_ref_of_constr "Zle" coq_Zle)
+let sp_Zgt = lazy (evaluable_ref_of_constr "Zgt" coq_Zgt)
+let sp_Zge = lazy (evaluable_ref_of_constr "Zge" coq_Zge)
+let sp_Zlt = lazy (evaluable_ref_of_constr "Zlt" coq_Zlt)
+let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ())))
+
+let mk_var v = mkVar (id_of_string v)
+let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |])
+let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |])
+let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |])
+let mk_eq t1 t2 = mkApp (build_coq_eq (), [| Lazy.force coq_Z; t1; t2 |])
+let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |])
+let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |])
+let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |])
+let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |])
+let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |])
+let mk_not t = mkApp (build_coq_not (), [| t |])
+let mk_eq_rel t1 t2 = mkApp (build_coq_eq (),
+ [| Lazy.force coq_comparison; t1; t2 |])
+let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |])
+
+let mk_integer n =
+ let rec loop n =
+ if n =? one then Lazy.force coq_xH else
+ mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI),
+ [| loop (n/two) |])
+ in
+ if n =? zero then Lazy.force coq_Z0
+ else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg),
+ [| loop (abs n) |])
+
+type omega_constant =
+ | Zplus | Zmult | Zminus | Zsucc | Zopp
+ | Plus | Mult | Minus | Pred | S | O
+ | Zpos | Zneg | Z0 | Z_of_nat
+ | Eq | Neq
+ | Zne | Zle | Zlt | Zge | Zgt
+ | Z | Nat
+ | And | Or | False | True | Not | Iff
+ | Le | Lt | Ge | Gt
+ | Other of string
+
+type omega_proposition =
+ | Keq of constr * constr * constr
+ | Kn
+
+type result =
+ | Kvar of identifier
+ | Kapp of omega_constant * constr list
+ | Kimp of constr * constr
+ | Kufo
+
+let destructurate_prop t =
+ let c, args = decompose_app t in
+ match kind_of_term c, args with
+ | _, [_;_;_] when c = build_coq_eq () -> Kapp (Eq,args)
+ | _, [_;_] when c = Lazy.force coq_neq -> Kapp (Neq,args)
+ | _, [_;_] when c = Lazy.force coq_Zne -> Kapp (Zne,args)
+ | _, [_;_] when c = Lazy.force coq_Zle -> Kapp (Zle,args)
+ | _, [_;_] when c = Lazy.force coq_Zlt -> Kapp (Zlt,args)
+ | _, [_;_] when c = Lazy.force coq_Zge -> Kapp (Zge,args)
+ | _, [_;_] when c = Lazy.force coq_Zgt -> Kapp (Zgt,args)
+ | _, [_;_] when c = build_coq_and () -> Kapp (And,args)
+ | _, [_;_] when c = build_coq_or () -> Kapp (Or,args)
+ | _, [_;_] when c = 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)
+ | Const sp, args ->
+ Kapp (Other (string_of_id (basename_of_global (ConstRef sp))),args)
+ | Construct csp , args ->
+ Kapp (Other (string_of_id (basename_of_global (ConstructRef csp))), args)
+ | Ind isp, args ->
+ Kapp (Other (string_of_id (basename_of_global (IndRef isp))),args)
+ | Var id,[] -> Kvar id
+ | Prod (Anonymous,typ,body), [] -> Kimp(typ,body)
+ | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal"
+ | _ -> Kufo
+
+let destructurate_type t =
+ let c, args = decompose_app t in
+ match kind_of_term c, args with
+ | _, [] when c = Lazy.force coq_Z -> Kapp (Z,args)
+ | _, [] when c = Lazy.force coq_nat -> Kapp (Nat,args)
+ | _ -> Kufo
+
+let destructurate_term t =
+ let c, args = decompose_app t in
+ match kind_of_term c, args with
+ | _, [_;_] when c = Lazy.force coq_Zplus -> Kapp (Zplus,args)
+ | _, [_;_] when c = Lazy.force coq_Zmult -> Kapp (Zmult,args)
+ | _, [_;_] when c = Lazy.force coq_Zminus -> Kapp (Zminus,args)
+ | _, [_] when c = Lazy.force coq_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)
+ | 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
+ | _ -> 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
+ | _ -> failwith "not a number"
+
+type constr_path =
+ | P_APP of int
+ (* Abstraction and product *)
+ | P_BODY
+ | P_TYPE
+ (* Case *)
+ | P_BRANCH of int
+ | P_ARITY
+ | P_ARG
+
+let context operation path (t : constr) =
+ let rec loop i p0 t =
+ match (p0,kind_of_term t) with
+ | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t)
+ | ([], _) -> operation i t
+ | ((P_APP n :: p), App (f,v)) ->
+ let v' = Array.copy v in
+ v'.(pred n) <- loop i p v'.(pred n); mkApp (f, v')
+ | ((P_BRANCH n :: p), Case (ci,q,c,v)) ->
+ (* avant, y avait mkApp... anyway, BRANCH seems nowhere used *)
+ let v' = Array.copy v in
+ v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v'))
+ | ((P_ARITY :: p), App (f,l)) ->
+ appvect (loop i p f,l)
+ | ((P_ARG :: p), App (f,v)) ->
+ let v' = Array.copy v in
+ v'.(0) <- loop i p v'.(0); mkApp (f,v')
+ | (p, Fix ((_,n as ln),(tys,lna,v))) ->
+ let l = Array.length v in
+ let v' = Array.copy v in
+ v'.(n)<- loop (Pervasives.(+) i l) p v.(n); (mkFix (ln,(tys,lna,v')))
+ | ((P_BODY :: p), Prod (n,t,c)) ->
+ (mkProd (n,t,loop (succ i) p c))
+ | ((P_BODY :: p), Lambda (n,t,c)) ->
+ (mkLambda (n,t,loop (succ i) p c))
+ | ((P_BODY :: p), LetIn (n,b,t,c)) ->
+ (mkLetIn (n,b,t,loop (succ i) p c))
+ | ((P_TYPE :: p), Prod (n,t,c)) ->
+ (mkProd (n,loop i p t,c))
+ | ((P_TYPE :: p), Lambda (n,t,c)) ->
+ (mkLambda (n,loop i p t,c))
+ | ((P_TYPE :: p), LetIn (n,b,t,c)) ->
+ (mkLetIn (n,b,loop i p t,c))
+ | (p, _) ->
+ ppnl (Printer.pr_lconstr t);
+ failwith ("abstract_path " ^ string_of_int(List.length p))
+ in
+ loop 1 path t
+
+let occurence path (t : constr) =
+ let rec loop p0 t = match (p0,kind_of_term t) with
+ | (p, Cast (c,_,_)) -> loop p c
+ | ([], _) -> t
+ | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n)
+ | ((P_BRANCH n :: p), Case (_,_,_,v)) -> loop p v.(n)
+ | ((P_ARITY :: p), App (f,_)) -> loop p f
+ | ((P_ARG :: p), App (f,v)) -> loop p v.(0)
+ | (p, Fix((_,n) ,(_,_,v))) -> loop p v.(n)
+ | ((P_BODY :: p), Prod (n,t,c)) -> loop p c
+ | ((P_BODY :: p), Lambda (n,t,c)) -> loop p c
+ | ((P_BODY :: p), LetIn (n,b,t,c)) -> loop p c
+ | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term
+ | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term
+ | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term
+ | (p, _) ->
+ ppnl (Printer.pr_lconstr t);
+ failwith ("occurence " ^ string_of_int(List.length p))
+ in
+ loop path t
+
+let abstract_path typ path t =
+ let term_occur = ref (mkRel 0) in
+ let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in
+ mkLambda (Name (id_of_string "x"), typ, abstract), !term_occur
+
+let focused_simpl path gl =
+ let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in
+ convert_concl_no_check newc DEFAULTcast gl
+
+let focused_simpl path = simpl_time (focused_simpl path)
+
+type oformula =
+ | Oplus of oformula * oformula
+ | Oinv of oformula
+ | Otimes of oformula * oformula
+ | Oatom of identifier
+ | Oz of bigint
+ | Oufo of constr
+
+let rec oprint = function
+ | Oplus(t1,t2) ->
+ print_string "("; oprint t1; print_string "+";
+ oprint t2; print_string ")"
+ | Oinv t -> print_string "~"; oprint t
+ | Otimes (t1,t2) ->
+ print_string "("; oprint t1; print_string "*";
+ oprint t2; print_string ")"
+ | Oatom s -> print_string (string_of_id s)
+ | Oz i -> print_string (string_of_bigint i)
+ | Oufo f -> print_string "?"
+
+let rec weight = function
+ | Oatom c -> intern_id c
+ | Oz _ -> -1
+ | Oinv c -> weight c
+ | Otimes(c,_) -> weight c
+ | Oplus _ -> failwith "weight"
+ | Oufo _ -> -1
+
+let rec val_of = function
+ | Oatom c -> mkVar c
+ | Oz c -> mk_integer c
+ | Oinv c -> mkApp (Lazy.force coq_Zopp, [| val_of c |])
+ | Otimes (t1,t2) -> mkApp (Lazy.force coq_Zmult, [| val_of t1; val_of t2 |])
+ | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |])
+ | Oufo c -> c
+
+let compile name kind =
+ let rec loop accu = function
+ | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r
+ | Oz n ->
+ let id = new_id () in
+ tag_hypothesis name id;
+ {kind = kind; body = List.rev accu; constant = n; id = id}
+ | _ -> anomaly "compile_equation"
+ in
+ loop []
+
+let rec decompile af =
+ let rec loop = function
+ | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r)
+ | [] -> Oz af.constant
+ in
+ loop af.body
+
+let mkNewMeta () = mkMeta (Evarutil.new_meta())
+
+let clever_rewrite_base_poly typ p result theorem gl =
+ let full = pf_concl gl in
+ let (abstracted,occ) = abstract_path typ (List.rev p) full in
+ let t =
+ applist
+ (mkLambda
+ (Name (id_of_string "P"),
+ mkArrow typ mkProp,
+ mkLambda
+ (Name (id_of_string "H"),
+ applist (mkRel 1,[result]),
+ mkApp (Lazy.force coq_eq_ind_r,
+ [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))),
+ [abstracted])
+ in
+ exact (applist(t,[mkNewMeta()])) gl
+
+let clever_rewrite_base p result theorem gl =
+ clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl
+
+let clever_rewrite_base_nat p result theorem gl =
+ clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl
+
+let clever_rewrite_gen p result (t,args) =
+ let theorem = applist(t, args) in
+ clever_rewrite_base p result theorem
+
+let clever_rewrite_gen_nat p result (t,args) =
+ let theorem = applist(t, args) in
+ clever_rewrite_base_nat p result theorem
+
+let clever_rewrite p vpath t gl =
+ let full = pf_concl gl in
+ let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in
+ let vargs = List.map (fun p -> occurence p occ) vpath in
+ let t' = applist(t, (vargs @ [abstracted])) in
+ exact (applist(t',[mkNewMeta()])) gl
+
+let rec shuffle p (t1,t2) =
+ match t1,t2 with
+ | Oplus(l1,r1), Oplus(l2,r2) ->
+ if weight l1 > weight l2 then
+ let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in
+ (clever_rewrite p [[P_APP 1;P_APP 1];
+ [P_APP 1; P_APP 2];[P_APP 2]]
+ (Lazy.force coq_fast_Zplus_assoc_reverse)
+ :: tac,
+ Oplus(l1,t'))
+ else
+ let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in
+ (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
+ (Lazy.force coq_fast_Zplus_permute)
+ :: tac,
+ Oplus(l2,t'))
+ | Oplus(l1,r1), t2 ->
+ if weight l1 > weight t2 then
+ let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in
+ clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
+ (Lazy.force coq_fast_Zplus_assoc_reverse)
+ :: tac,
+ Oplus(l1, t')
+ else
+ [clever_rewrite p [[P_APP 1];[P_APP 2]]
+ (Lazy.force coq_fast_Zplus_comm)],
+ Oplus(t2,t1)
+ | t1,Oplus(l2,r2) ->
+ if weight l2 > weight t1 then
+ let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in
+ clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
+ (Lazy.force coq_fast_Zplus_permute)
+ :: tac,
+ Oplus(l2,t')
+ else [],Oplus(t1,t2)
+ | Oz t1,Oz t2 ->
+ [focused_simpl p], Oz(Bigint.add t1 t2)
+ | t1,t2 ->
+ if weight t1 < weight t2 then
+ [clever_rewrite p [[P_APP 1];[P_APP 2]]
+ (Lazy.force coq_fast_Zplus_comm)],
+ Oplus(t2,t1)
+ else [],Oplus(t1,t2)
+
+let rec shuffle_mult p_init k1 e1 k2 e2 =
+ let rec loop p = function
+ | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
+ if v1 = v2 then
+ let tac =
+ clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
+ [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 1; P_APP 2];
+ [P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 2]]
+ (Lazy.force coq_fast_OMEGA10)
+ in
+ if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then
+ let tac' =
+ clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
+ (Lazy.force coq_fast_Zred_factor5) in
+ tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' ::
+ loop p (l1,l2)
+ else tac :: loop (P_APP 2 :: p) (l1,l2)
+ else if v1 > v2 then
+ clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
+ [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 2];
+ [P_APP 1; P_APP 2]]
+ (Lazy.force coq_fast_OMEGA11) ::
+ loop (P_APP 2 :: p) (l1,l2')
+ else
+ clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
+ [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1];
+ [P_APP 2; P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 2]]
+ (Lazy.force coq_fast_OMEGA12) ::
+ loop (P_APP 2 :: p) (l1',l2)
+ | ({c=c1;v=v1}::l1), [] ->
+ clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
+ [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 2];
+ [P_APP 1; P_APP 2]]
+ (Lazy.force coq_fast_OMEGA11) ::
+ loop (P_APP 2 :: p) (l1,[])
+ | [],({c=c2;v=v2}::l2) ->
+ clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
+ [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1];
+ [P_APP 2; P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 2]]
+ (Lazy.force coq_fast_OMEGA12) ::
+ loop (P_APP 2 :: p) ([],l2)
+ | [],[] -> [focused_simpl p_init]
+ in
+ loop p_init (e1,e2)
+
+let rec shuffle_mult_right p_init e1 k2 e2 =
+ let rec loop p = function
+ | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') ->
+ if v1 = v2 then
+ let tac =
+ clever_rewrite p
+ [[P_APP 1; P_APP 1; P_APP 1];
+ [P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 2]]
+ (Lazy.force coq_fast_OMEGA15)
+ in
+ if Bigint.add c1 (Bigint.mult k2 c2) =? zero then
+ let tac' =
+ clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
+ (Lazy.force coq_fast_Zred_factor5)
+ in
+ tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' ::
+ loop p (l1,l2)
+ else tac :: loop (P_APP 2 :: p) (l1,l2)
+ else if v1 > v2 then
+ clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
+ (Lazy.force coq_fast_Zplus_assoc_reverse) ::
+ loop (P_APP 2 :: p) (l1,l2')
+ else
+ clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
+ [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1];
+ [P_APP 2; P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 2]]
+ (Lazy.force coq_fast_OMEGA12) ::
+ loop (P_APP 2 :: p) (l1',l2)
+ | ({c=c1;v=v1}::l1), [] ->
+ clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
+ (Lazy.force coq_fast_Zplus_assoc_reverse) ::
+ loop (P_APP 2 :: p) (l1,[])
+ | [],({c=c2;v=v2}::l2) ->
+ clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1];
+ [P_APP 2; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1];
+ [P_APP 2; P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 2]]
+ (Lazy.force coq_fast_OMEGA12) ::
+ loop (P_APP 2 :: p) ([],l2)
+ | [],[] -> [focused_simpl p_init]
+ in
+ loop p_init (e1,e2)
+
+let rec shuffle_cancel p = function
+ | [] -> [focused_simpl p]
+ | ({c=c1}::l1) ->
+ let tac =
+ clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2];
+ [P_APP 2; P_APP 2];
+ [P_APP 1; P_APP 1; P_APP 2; P_APP 1]]
+ (if c1 >? zero then
+ (Lazy.force coq_fast_OMEGA13)
+ else
+ (Lazy.force coq_fast_OMEGA14))
+ in
+ tac :: shuffle_cancel p l1
+
+let rec scalar p n = function
+ | Oplus(t1,t2) ->
+ let tac1,t1' = scalar (P_APP 1 :: p) n t1 and
+ tac2,t2' = scalar (P_APP 2 :: p) n t2 in
+ clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]]
+ (Lazy.force coq_fast_Zmult_plus_distr_l) ::
+ (tac1 @ tac2), Oplus(t1',t2')
+ | Oinv t ->
+ [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
+ (Lazy.force coq_fast_Zmult_opp_comm);
+ focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n))
+ | Otimes(t1,Oz x) ->
+ [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]]
+ (Lazy.force coq_fast_Zmult_assoc_reverse);
+ focused_simpl (P_APP 2 :: p)],
+ Otimes(t1,Oz (n*x))
+ | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products"
+ | (Oatom _ as t) -> [], Otimes(t,Oz n)
+ | Oz i -> [focused_simpl p],Oz(n*i)
+ | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |]))
+
+let rec scalar_norm p_init =
+ let rec loop p = function
+ | [] -> [focused_simpl p_init]
+ | (_::l) ->
+ clever_rewrite p
+ [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1; P_APP 2];[P_APP 2]]
+ (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l
+ in
+ loop p_init
+
+let rec norm_add p_init =
+ let rec loop p = function
+ | [] -> [focused_simpl p_init]
+ | _:: l ->
+ clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
+ (Lazy.force coq_fast_Zplus_assoc_reverse) ::
+ loop (P_APP 2 :: p) l
+ in
+ loop p_init
+
+let rec scalar_norm_add p_init =
+ let rec loop p = function
+ | [] -> [focused_simpl p_init]
+ | _ :: l ->
+ clever_rewrite p
+ [[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
+ [P_APP 1; P_APP 1; P_APP 1; P_APP 2];
+ [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]]
+ (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l
+ in
+ loop p_init
+
+let rec negate p = function
+ | Oplus(t1,t2) ->
+ let tac1,t1' = negate (P_APP 1 :: p) t1 and
+ tac2,t2' = negate (P_APP 2 :: p) t2 in
+ clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]]
+ (Lazy.force coq_fast_Zopp_plus_distr) ::
+ (tac1 @ tac2),
+ Oplus(t1',t2')
+ | Oinv t ->
+ [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t
+ | Otimes(t1,Oz x) ->
+ [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]]
+ (Lazy.force coq_fast_Zopp_mult_distr_r);
+ focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x))
+ | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products"
+ | (Oatom _ as t) ->
+ let r = Otimes(t,Oz(negone)) in
+ [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r
+ | Oz i -> [focused_simpl p],Oz(neg i)
+ | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |]))
+
+let rec transform p t =
+ let default isnat t' =
+ try
+ let v,th,_ = find_constr t' in
+ [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
+ with _ ->
+ let v = new_identifier_var ()
+ and th = new_identifier () in
+ hide_constr t' v th isnat;
+ [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
+ in
+ try match destructurate_term t with
+ | Kapp(Zplus,[t1;t2]) ->
+ let tac1,t1' = transform (P_APP 1 :: p) t1
+ and tac2,t2' = transform (P_APP 2 :: p) t2 in
+ let tac,t' = shuffle p (t1',t2') in
+ tac1 @ tac2 @ tac, t'
+ | Kapp(Zminus,[t1;t2]) ->
+ let tac,t =
+ transform p
+ (mkApp (Lazy.force coq_Zplus,
+ [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in
+ unfold sp_Zminus :: tac,t
+ | Kapp(Zsucc,[t1]) ->
+ let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
+ [| t1; mk_integer one |])) in
+ unfold sp_Zsucc :: tac,t
+ | Kapp(Zmult,[t1;t2]) ->
+ let tac1,t1' = transform (P_APP 1 :: p) t1
+ and tac2,t2' = transform (P_APP 2 :: p) t2 in
+ begin match t1',t2' with
+ | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t'
+ | (Oz n,_) ->
+ let sym =
+ clever_rewrite p [[P_APP 1];[P_APP 2]]
+ (Lazy.force coq_fast_Zmult_comm) in
+ let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t'
+ | _ -> default false t
+ end
+ | Kapp((Zpos|Zneg|Z0),_) ->
+ (try ([],Oz(recognize_number t)) with _ -> default false t)
+ | Kvar s -> [],Oatom s
+ | Kapp(Zopp,[t]) ->
+ let tac,t' = transform (P_APP 1 :: p) t in
+ let tac',t'' = negate p t' in
+ tac @ tac', t''
+ | Kapp(Z_of_nat,[t']) -> default true t'
+ | _ -> default false t
+ with e when catchable_exception e -> default false t
+
+let shrink_pair p f1 f2 =
+ match f1,f2 with
+ | Oatom v,Oatom _ ->
+ let r = Otimes(Oatom v,Oz two) in
+ clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r
+ | Oatom v, Otimes(_,c2) ->
+ let r = Otimes(Oatom v,Oplus(c2,Oz one)) in
+ clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]]
+ (Lazy.force coq_fast_Zred_factor2), r
+ | Otimes (v1,c1),Oatom v ->
+ let r = Otimes(Oatom v,Oplus(c1,Oz one)) in
+ clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]]
+ (Lazy.force coq_fast_Zred_factor3), r
+ | Otimes (Oatom v,c1),Otimes (v2,c2) ->
+ let r = Otimes(Oatom v,Oplus(c1,c2)) in
+ clever_rewrite p
+ [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]]
+ (Lazy.force coq_fast_Zred_factor4),r
+ | t1,t2 ->
+ begin
+ oprint t1; print_newline (); oprint t2; print_newline ();
+ flush Pervasives.stdout; error "shrink.1"
+ end
+
+let reduce_factor p = function
+ | Oatom v ->
+ let r = Otimes(Oatom v,Oz one) in
+ [clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor0)],r
+ | Otimes(Oatom v,Oz n) as f -> [],f
+ | Otimes(Oatom v,c) ->
+ let rec compute = function
+ | Oz n -> n
+ | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2)
+ | _ -> error "condense.1"
+ in
+ [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c))
+ | t -> oprint t; error "reduce_factor.1"
+
+let rec condense p = function
+ | Oplus(f1,(Oplus(f2,r) as t)) ->
+ if weight f1 = weight f2 then begin
+ let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in
+ let assoc_tac =
+ clever_rewrite p
+ [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]]
+ (Lazy.force coq_fast_Zplus_assoc) in
+ let tac_list,t' = condense p (Oplus(t,r)) in
+ (assoc_tac :: shrink_tac :: tac_list), t'
+ end else begin
+ let tac,f = reduce_factor (P_APP 1 :: p) f1 in
+ let tac',t' = condense (P_APP 2 :: p) t in
+ (tac @ tac'), Oplus(f,t')
+ end
+ | Oplus(f1,Oz n) ->
+ let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n)
+ | Oplus(f1,f2) ->
+ if weight f1 = weight f2 then begin
+ let tac_shrink,t = shrink_pair p f1 f2 in
+ let tac,t' = condense p t in
+ tac_shrink :: tac,t'
+ end else begin
+ let tac,f = reduce_factor (P_APP 1 :: p) f1 in
+ let tac',t' = condense (P_APP 2 :: p) f2 in
+ (tac @ tac'),Oplus(f,t')
+ end
+ | Oz _ as t -> [],t
+ | t ->
+ let tac,t' = reduce_factor p t in
+ let final = Oplus(t',Oz zero) in
+ let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in
+ tac @ [tac'], final
+
+let rec clear_zero p = function
+ | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero ->
+ let tac =
+ clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
+ (Lazy.force coq_fast_Zred_factor5) in
+ let tac',t = clear_zero p r in
+ tac :: tac',t
+ | Oplus(f,r) ->
+ let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t)
+ | t -> [],t
+
+let replay_history tactic_normalisation =
+ let aux = id_of_string "auxiliary" in
+ let aux1 = id_of_string "auxiliary_1" in
+ let aux2 = id_of_string "auxiliary_2" in
+ let izero = mk_integer zero in
+ let rec loop t =
+ match t with
+ | HYP e :: l ->
+ begin
+ try
+ tclTHEN
+ (List.assoc (hyp_of_tag e.id) tactic_normalisation)
+ (loop l)
+ with Not_found -> loop l end
+ | NEGATE_CONTRADICT (e2,e1,b) :: l ->
+ let eq1 = decompile e1
+ and eq2 = decompile e2 in
+ let id1 = hyp_of_tag e1.id
+ and id2 = hyp_of_tag e2.id in
+ let k = if b then negone else one in
+ let p_initial = [P_APP 1;P_TYPE] in
+ let tac= shuffle_mult_right p_initial e1.body k e2.body in
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_OMEGA17, [|
+ val_of eq1;
+ val_of eq2;
+ mk_integer k;
+ mkVar id1; mkVar id2 |])]);
+ (mk_then tac);
+ (intros_using [aux]);
+ (resolve_id aux);
+ reflexivity
+ ]
+ | CONTRADICTION (e1,e2) :: l ->
+ let eq1 = decompile e1
+ and eq2 = decompile e2 in
+ let p_initial = [P_APP 2;P_TYPE] in
+ let tac = shuffle_cancel p_initial e1.body in
+ let solve_le =
+ let not_sup_sup = mkApp (build_coq_eq (), [|
+ Lazy.force coq_comparison;
+ Lazy.force coq_Gt;
+ Lazy.force coq_Gt |])
+ in
+ tclTHENS
+ (tclTHENLIST [
+ (unfold sp_Zle);
+ (simpl_in_concl);
+ intro;
+ (absurd not_sup_sup) ])
+ [ assumption ; reflexivity ]
+ in
+ let theorem =
+ mkApp (Lazy.force coq_OMEGA2, [|
+ val_of eq1; val_of eq2;
+ mkVar (hyp_of_tag e1.id);
+ mkVar (hyp_of_tag e2.id) |])
+ in
+ tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le)
+ | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
+ let id = hyp_of_tag e1.id in
+ let eq1 = val_of(decompile e1)
+ and eq2 = val_of(decompile e2) in
+ let kk = mk_integer k
+ and dd = mk_integer d in
+ let rhs = mk_plus (mk_times eq2 kk) dd in
+ let state_eg = mk_eq eq1 rhs in
+ let tac = scalar_norm_add [P_APP 3] e2.body in
+ tclTHENS
+ (cut state_eg)
+ [ tclTHENS
+ (tclTHENLIST [
+ (intros_using [aux]);
+ (generalize_tac
+ [mkApp (Lazy.force coq_OMEGA1,
+ [| eq1; rhs; mkVar aux; mkVar id |])]);
+ (clear [aux;id]);
+ (intros_using [id]);
+ (cut (mk_gt kk dd)) ])
+ [ tclTHENS
+ (cut (mk_gt kk izero))
+ [ tclTHENLIST [
+ (intros_using [aux1; aux2]);
+ (generalize_tac
+ [mkApp (Lazy.force coq_Zmult_le_approx,
+ [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]);
+ (clear [aux1;aux2;id]);
+ (intros_using [id]);
+ (loop l) ];
+ tclTHENLIST [
+ (unfold sp_Zgt);
+ (simpl_in_concl);
+ reflexivity ] ];
+ tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ]
+ ];
+ tclTHEN (mk_then tac) reflexivity ]
+
+ | NOT_EXACT_DIVIDE (e1,k) :: l ->
+ let c = floor_div e1.constant k in
+ let d = Bigint.sub e1.constant (Bigint.mult c k) in
+ let e2 = {id=e1.id; kind=EQUA;constant = c;
+ body = map_eq_linear (fun c -> c / k) e1.body } in
+ let eq2 = val_of(decompile e2) in
+ let kk = mk_integer k
+ and dd = mk_integer d in
+ let tac = scalar_norm_add [P_APP 2] e2.body in
+ tclTHENS
+ (cut (mk_gt dd izero))
+ [ tclTHENS (cut (mk_gt kk dd))
+ [tclTHENLIST [
+ (intros_using [aux2;aux1]);
+ (generalize_tac
+ [mkApp (Lazy.force coq_OMEGA4,
+ [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]);
+ (clear [aux1;aux2]);
+ (unfold sp_not);
+ (intros_using [aux]);
+ (resolve_id aux);
+ (mk_then tac);
+ assumption ] ;
+ tclTHENLIST [
+ (unfold sp_Zgt);
+ simpl_in_concl;
+ reflexivity ] ];
+ tclTHENLIST [
+ (unfold sp_Zgt);
+ simpl_in_concl;
+ reflexivity ] ]
+ | EXACT_DIVIDE (e1,k) :: l ->
+ let id = hyp_of_tag e1.id in
+ let e2 = map_eq_afine (fun c -> c / k) e1 in
+ let eq1 = val_of(decompile e1)
+ and eq2 = val_of(decompile e2) in
+ let kk = mk_integer k in
+ let state_eq = mk_eq eq1 (mk_times eq2 kk) in
+ if e1.kind = DISE then
+ let tac = scalar_norm [P_APP 3] e2.body in
+ tclTHENS
+ (cut state_eq)
+ [tclTHENLIST [
+ (intros_using [aux1]);
+ (generalize_tac
+ [mkApp (Lazy.force coq_OMEGA18,
+ [| eq1;eq2;kk;mkVar aux1; mkVar id |])]);
+ (clear [aux1;id]);
+ (intros_using [id]);
+ (loop l) ];
+ tclTHEN (mk_then tac) reflexivity ]
+ else
+ let tac = scalar_norm [P_APP 3] e2.body in
+ tclTHENS (cut state_eq)
+ [
+ tclTHENS
+ (cut (mk_gt kk izero))
+ [tclTHENLIST [
+ (intros_using [aux2;aux1]);
+ (generalize_tac
+ [mkApp (Lazy.force coq_OMEGA3,
+ [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]);
+ (clear [aux1;aux2;id]);
+ (intros_using [id]);
+ (loop l) ];
+ tclTHENLIST [
+ (unfold sp_Zgt);
+ simpl_in_concl;
+ reflexivity ] ];
+ tclTHEN (mk_then tac) reflexivity ]
+ | (MERGE_EQ(e3,e1,e2)) :: l ->
+ let id = new_identifier () in
+ tag_hypothesis id e3;
+ let id1 = hyp_of_tag e1.id
+ and id2 = hyp_of_tag e2 in
+ let eq1 = val_of(decompile e1)
+ and eq2 = val_of (decompile (negate_eq e1)) in
+ let tac =
+ clever_rewrite [P_APP 3] [[P_APP 1]]
+ (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
+ scalar_norm [P_APP 3] e1.body
+ in
+ tclTHENS
+ (cut (mk_eq eq1 (mk_inv eq2)))
+ [tclTHENLIST [
+ (intros_using [aux]);
+ (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
+ [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]);
+ (clear [id1;id2;aux]);
+ (intros_using [id]);
+ (loop l) ];
+ tclTHEN (mk_then tac) reflexivity]
+
+ | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l ->
+ let id = new_identifier ()
+ and id2 = hyp_of_tag orig.id in
+ tag_hypothesis id e.id;
+ let eq1 = val_of(decompile def)
+ and eq2 = val_of(decompile orig) in
+ let vid = unintern_id v in
+ let theorem =
+ mkApp (build_coq_ex (), [|
+ Lazy.force coq_Z;
+ mkLambda
+ (Name vid,
+ Lazy.force coq_Z,
+ mk_eq (mkRel 1) eq1) |])
+ in
+ let mm = mk_integer m in
+ let p_initial = [P_APP 2;P_TYPE] in
+ let tac =
+ clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial)
+ [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) ::
+ shuffle_mult_right p_initial
+ orig.body m ({c= negone;v= v}::def.body) in
+ tclTHENS
+ (cut theorem)
+ [tclTHENLIST [
+ (intros_using [aux]);
+ (elim_id aux);
+ (clear [aux]);
+ (intros_using [vid; aux]);
+ (generalize_tac
+ [mkApp (Lazy.force coq_OMEGA9,
+ [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]);
+ (mk_then tac);
+ (clear [aux]);
+ (intros_using [id]);
+ (loop l) ];
+ tclTHEN (exists_tac eq1) reflexivity ]
+ | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l ->
+ let id1 = new_identifier ()
+ and id2 = new_identifier () in
+ tag_hypothesis id1 e1; tag_hypothesis id2 e2;
+ let id = hyp_of_tag e.id in
+ let tac1 = norm_add [P_APP 2;P_TYPE] e.body in
+ let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in
+ let eq = val_of(decompile e) in
+ tclTHENS
+ (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id])))
+ [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ];
+ tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]]
+ | SUM(e3,(k1,e1),(k2,e2)) :: l ->
+ let id = new_identifier () in
+ tag_hypothesis id e3;
+ let id1 = hyp_of_tag e1.id
+ and id2 = hyp_of_tag e2.id in
+ let eq1 = val_of(decompile e1)
+ and eq2 = val_of(decompile e2) in
+ if k1 =? one & e2.kind = EQUA then
+ let tac_thm =
+ match e1.kind with
+ | EQUA -> Lazy.force coq_OMEGA5
+ | INEQ -> Lazy.force coq_OMEGA6
+ | DISE -> Lazy.force coq_OMEGA20
+ in
+ let kk = mk_integer k2 in
+ let p_initial =
+ if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in
+ let tac = shuffle_mult_right p_initial e1.body k2 e2.body in
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]);
+ (mk_then tac);
+ (intros_using [id]);
+ (loop l)
+ ]
+ else
+ let kk1 = mk_integer k1
+ and kk2 = mk_integer k2 in
+ let p_initial = [P_APP 2;P_TYPE] in
+ let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in
+ tclTHENS (cut (mk_gt kk1 izero))
+ [tclTHENS
+ (cut (mk_gt kk2 izero))
+ [tclTHENLIST [
+ (intros_using [aux2;aux1]);
+ (generalize_tac
+ [mkApp (Lazy.force coq_OMEGA7, [|
+ eq1;eq2;kk1;kk2;
+ mkVar aux1;mkVar aux2;
+ mkVar id1;mkVar id2 |])]);
+ (clear [aux1;aux2]);
+ (mk_then tac);
+ (intros_using [id]);
+ (loop l) ];
+ tclTHENLIST [
+ (unfold sp_Zgt);
+ simpl_in_concl;
+ reflexivity ] ];
+ tclTHENLIST [
+ (unfold sp_Zgt);
+ simpl_in_concl;
+ reflexivity ] ]
+ | CONSTANT_NOT_NUL(e,k) :: l ->
+ tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl
+ | CONSTANT_NUL(e) :: l ->
+ tclTHEN (resolve_id (hyp_of_tag e)) reflexivity
+ | CONSTANT_NEG(e,k) :: l ->
+ tclTHENLIST [
+ (generalize_tac [mkVar (hyp_of_tag e)]);
+ (unfold sp_Zle);
+ simpl_in_concl;
+ (unfold sp_not);
+ (intros_using [aux]);
+ (resolve_id aux);
+ reflexivity
+ ]
+ | _ -> tclIDTAC
+ in
+ loop
+
+let normalize p_initial t =
+ let (tac,t') = transform p_initial t in
+ let (tac',t'') = condense p_initial t' in
+ let (tac'',t''') = clear_zero p_initial t'' in
+ tac @ tac' @ tac'' , t'''
+
+let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) =
+ let p_initial = [P_APP pos ;P_TYPE] in
+ let (tac,t') = normalize p_initial t in
+ let shift_left =
+ tclTHEN
+ (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])
+ (tclTRY (clear [id]))
+ in
+ if tac <> [] then
+ let id' = new_identifier () in
+ ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ]))
+ :: tactic,
+ compile id' flag t' :: defs)
+ else
+ (tactic,defs)
+
+let destructure_omega gl tac_def (id,c) =
+ if atompart_of_id id = "State" then
+ tac_def
+ else
+ try match destructurate_prop c with
+ | Kapp(Eq,[typ;t1;t2])
+ when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) ->
+ let t = mk_plus t1 (mk_inv t2) in
+ normalize_equation
+ id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def
+ | Kapp(Zne,[t1;t2]) ->
+ let t = mk_plus t1 (mk_inv t2) in
+ normalize_equation
+ id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def
+ | Kapp(Zle,[t1;t2]) ->
+ let t = mk_plus t2 (mk_inv t1) in
+ normalize_equation
+ id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def
+ | Kapp(Zlt,[t1;t2]) ->
+ let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in
+ normalize_equation
+ id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def
+ | Kapp(Zge,[t1;t2]) ->
+ let t = mk_plus t1 (mk_inv t2) in
+ normalize_equation
+ id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def
+ | Kapp(Zgt,[t1;t2]) ->
+ let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in
+ normalize_equation
+ id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def
+ | _ -> tac_def
+ with e when catchable_exception e -> tac_def
+
+let reintroduce id =
+ (* [id] cannot be cleared if dependent: protect it by a try *)
+ tclTHEN (tclTRY (clear [id])) (intro_using id)
+
+let coq_omega gl =
+ clear_tables ();
+ let tactic_normalisation, system =
+ List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in
+ let prelude,sys =
+ List.fold_left
+ (fun (tac,sys) (t,(v,th,b)) ->
+ if b then
+ let id = new_identifier () in
+ let i = new_id () in
+ tag_hypothesis id i;
+ (tclTHENLIST [
+ (simplest_elim (applist (Lazy.force coq_intro_Z, [t])));
+ (intros_using [v; id]);
+ (elim_id id);
+ (clear [id]);
+ (intros_using [th;id]);
+ tac ]),
+ {kind = INEQ;
+ body = [{v=intern_id v; c=one}];
+ constant = zero; id = i} :: sys
+ else
+ (tclTHENLIST [
+ (simplest_elim (applist (Lazy.force coq_new_var, [t])));
+ (intros_using [v;th]);
+ tac ]),
+ sys)
+ (tclIDTAC,[]) (dump_tables ())
+ in
+ let system = system @ sys in
+ if !display_system_flag then display_system display_var system;
+ if !old_style_flag then begin
+ try
+ let _ = simplify (new_id,new_var_num,display_var) false system in
+ tclIDTAC gl
+ with UNSOLVABLE ->
+ let _,path = depend [] [] (history ()) in
+ if !display_action_flag then display_action display_var path;
+ (tclTHEN prelude (replay_history tactic_normalisation path)) gl
+ end else begin
+ try
+ let path = simplify_strong (new_id,new_var_num,display_var) system in
+ if !display_action_flag then display_action display_var path;
+ (tclTHEN prelude (replay_history tactic_normalisation path)) gl
+ with NO_CONTRADICTION -> error "Omega can't solve this system"
+ end
+
+let coq_omega = solver_time coq_omega
+
+let nat_inject gl =
+ let rec explore p t =
+ try match destructurate_term t with
+ | Kapp(Plus,[t1;t2]) ->
+ tclTHENLIST [
+ (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2))
+ ((Lazy.force coq_inj_plus),[t1;t2]));
+ (explore (P_APP 1 :: p) t1);
+ (explore (P_APP 2 :: p) t2)
+ ]
+ | Kapp(Mult,[t1;t2]) ->
+ tclTHENLIST [
+ (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2))
+ ((Lazy.force coq_inj_mult),[t1;t2]));
+ (explore (P_APP 1 :: p) t1);
+ (explore (P_APP 2 :: p) t2)
+ ]
+ | Kapp(Minus,[t1;t2]) ->
+ let id = new_identifier () in
+ tclTHENS
+ (tclTHEN
+ (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1])))
+ (intros_using [id]))
+ [
+ tclTHENLIST [
+ (clever_rewrite_gen p
+ (mk_minus (mk_inj t1) (mk_inj t2))
+ ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id]));
+ (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]);
+ (explore (P_APP 1 :: p) t1);
+ (explore (P_APP 2 :: p) t2) ];
+ (tclTHEN
+ (clever_rewrite_gen p (mk_integer zero)
+ ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id]))
+ (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])]))
+ ]
+ | Kapp(S,[t']) ->
+ let rec is_number t =
+ try match destructurate_term t with
+ Kapp(S,[t]) -> is_number t
+ | Kapp(O,[]) -> true
+ | _ -> false
+ with e when catchable_exception e -> false
+ in
+ let rec loop p t =
+ try match destructurate_term t with
+ Kapp(S,[t]) ->
+ (tclTHEN
+ (clever_rewrite_gen p
+ (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |]))
+ ((Lazy.force coq_inj_S),[t]))
+ (loop (P_APP 1 :: p) t))
+ | _ -> explore p t
+ with e when catchable_exception e -> explore p t
+ in
+ if is_number t' then focused_simpl p else loop p t
+ | Kapp(Pred,[t]) ->
+ let t_minus_one =
+ mkApp (Lazy.force coq_minus, [| t;
+ mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in
+ tclTHEN
+ (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one
+ ((Lazy.force coq_pred_of_minus),[t]))
+ (explore p t_minus_one)
+ | Kapp(O,[]) -> focused_simpl p
+ | _ -> tclIDTAC
+ with e when catchable_exception e -> tclIDTAC
+
+ and loop = function
+ | [] -> tclIDTAC
+ | (i,t)::lit ->
+ begin try match destructurate_prop t with
+ Kapp(Le,[t1;t2]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]);
+ (explore [P_APP 1; P_TYPE] t1);
+ (explore [P_APP 2; P_TYPE] t2);
+ (reintroduce i);
+ (loop lit)
+ ]
+ | Kapp(Lt,[t1;t2]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]);
+ (explore [P_APP 1; P_TYPE] t1);
+ (explore [P_APP 2; P_TYPE] t2);
+ (reintroduce i);
+ (loop lit)
+ ]
+ | Kapp(Ge,[t1;t2]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]);
+ (explore [P_APP 1; P_TYPE] t1);
+ (explore [P_APP 2; P_TYPE] t2);
+ (reintroduce i);
+ (loop lit)
+ ]
+ | Kapp(Gt,[t1;t2]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]);
+ (explore [P_APP 1; P_TYPE] t1);
+ (explore [P_APP 2; P_TYPE] t2);
+ (reintroduce i);
+ (loop lit)
+ ]
+ | Kapp(Neq,[t1;t2]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]);
+ (explore [P_APP 1; P_TYPE] t1);
+ (explore [P_APP 2; P_TYPE] t2);
+ (reintroduce i);
+ (loop lit)
+ ]
+ | Kapp(Eq,[typ;t1;t2]) ->
+ if pf_conv_x gl typ (Lazy.force coq_nat) then
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]);
+ (explore [P_APP 2; P_TYPE] t1);
+ (explore [P_APP 3; P_TYPE] t2);
+ (reintroduce i);
+ (loop lit)
+ ]
+ else loop lit
+ | _ -> loop lit
+ with e when catchable_exception e -> loop lit end
+ in
+ loop (List.rev (pf_hyps_types gl)) gl
+
+let rec decidability gl t =
+ match destructurate_prop t with
+ | Kapp(Or,[t1;t2]) ->
+ mkApp (Lazy.force coq_dec_or, [| t1; t2;
+ decidability gl t1; decidability gl t2 |])
+ | Kapp(And,[t1;t2]) ->
+ mkApp (Lazy.force coq_dec_and, [| t1; t2;
+ decidability gl t1; decidability gl t2 |])
+ | Kapp(Iff,[t1;t2]) ->
+ 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 |])
+ | 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)
+ end
+ | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |])
+ | Kapp(Zle,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zle, [| t1;t2 |])
+ | Kapp(Zlt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zlt, [| t1;t2 |])
+ | Kapp(Zge,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zge, [| t1;t2 |])
+ | Kapp(Zgt,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zgt, [| t1;t2 |])
+ | Kapp(Le, [t1;t2]) -> mkApp (Lazy.force coq_dec_le, [| t1;t2 |])
+ | Kapp(Lt, [t1;t2]) -> mkApp (Lazy.force coq_dec_lt, [| t1;t2 |])
+ | Kapp(Ge, [t1;t2]) -> mkApp (Lazy.force coq_dec_ge, [| t1;t2 |])
+ | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |])
+ | Kapp(False,[]) -> Lazy.force coq_dec_False
+ | Kapp(True,[]) -> Lazy.force coq_dec_True
+ | Kapp(Other t,_::_) -> error
+ ("Omega: Unrecognized predicate or connective: "^t)
+ | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t)
+ | Kvar _ -> error "Omega: Can't solve a goal with proposition variables"
+ | _ -> error "Omega: Unrecognized proposition"
+
+let onClearedName id tac =
+ (* We cannot ensure that hyps can be cleared (because of dependencies), *)
+ (* so renaming may be necessary *)
+ tclTHEN
+ (tclTRY (clear [id]))
+ (fun gl ->
+ let id = fresh_id [] id gl in
+ tclTHEN (introduction id) (tac id) gl)
+
+let destructure_hyps gl =
+ let rec loop = function
+ | [] -> (tclTHEN nat_inject coq_omega)
+ | (i,body,t)::lit ->
+ begin try match destructurate_prop t with
+ | Kapp(False,[]) -> elim_id i
+ | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit
+ | Kapp(Or,[t1;t2]) ->
+ (tclTHENS
+ (elim_id i)
+ [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
+ onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
+ | Kapp(And,[t1;t2]) ->
+ tclTHENLIST [
+ (elim_id i);
+ (tclTRY (clear [i]));
+ (fun gl ->
+ let i1 = fresh_id [] (add_suffix i "_left") gl in
+ let i2 = fresh_id [] (add_suffix i "_right") gl in
+ tclTHENLIST [
+ (introduction i1);
+ (introduction i2);
+ (loop ((i1,None,t1)::(i2,None,t2)::lit)) ] gl)
+ ]
+ | 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)
+ ]
+ | Kimp(t1,t2) ->
+ if
+ is_Prop (pf_type_of gl t1) &
+ is_Prop (pf_type_of gl t2) &
+ closed0 t2
+ then
+ tclTHENLIST [
+ (generalize_tac [mkApp (Lazy.force coq_imp_simp,
+ [| t1; t2; decidability gl t1; mkVar i|])]);
+ (onClearedName i (fun i ->
+ (loop ((i,None,mk_or (mk_not t1) t2)::lit))))
+ ]
+ else
+ loop lit
+ | Kapp(Not,[t]) ->
+ begin match destructurate_prop t with
+ Kapp(Or,[t1;t2]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]);
+ (onClearedName i (fun i ->
+ (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
+ ]
+ | Kapp(And,[t1;t2]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_not_and, [| t1; t2;
+ decidability gl t1; mkVar i|])]);
+ (onClearedName i (fun i ->
+ (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit))))
+ ]
+ | Kapp(Iff,[t1;t2]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_not_iff, [| t1; t2;
+ decidability gl t1; decidability gl t2; 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) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_not_imp, [| t1; t2;
+ decidability gl t1;mkVar i |])]);
+ (onClearedName i (fun i ->
+ (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
+ ]
+ | Kapp(Not,[t]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_not_not, [| t;
+ decidability gl t; mkVar i |])]);
+ (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
+ ]
+ | Kapp(Zle, [t1;t2]) ->
+ tclTHENLIST [
+ (generalize_tac
+ [mkApp (Lazy.force coq_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(Eq,[typ;t1;t2]) ->
+ if !old_style_flag then begin
+ match destructurate_type (pf_nf gl typ) with
+ | Kapp(Nat,_) ->
+ tclTHENLIST [
+ (simplest_elim
+ (mkApp
+ (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])));
+ (onClearedName i (fun _ -> loop lit))
+ ]
+ | Kapp(Z,_) ->
+ tclTHENLIST [
+ (simplest_elim
+ (mkApp
+ (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])));
+ (onClearedName i (fun _ -> loop lit))
+ ]
+ | _ -> loop lit
+ end else begin
+ match destructurate_type (pf_nf gl typ) with
+ | Kapp(Nat,_) ->
+ (tclTHEN
+ (convert_hyp_no_check
+ (i,body,
+ (mkApp (Lazy.force coq_neq, [| t1;t2|]))))
+ (loop lit))
+ | Kapp(Z,_) ->
+ (tclTHEN
+ (convert_hyp_no_check
+ (i,body,
+ (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
+ (loop lit))
+ | _ -> loop lit
+ end
+ | _ -> loop lit
+ end
+ | _ -> loop lit
+ with e when catchable_exception e -> loop lit
+ end
+ in
+ loop (pf_hyps gl) gl
+
+let destructure_goal gl =
+ let concl = pf_concl gl in
+ let rec loop t =
+ match destructurate_prop t with
+ | Kapp(Not,[t]) ->
+ (tclTHEN
+ (tclTHEN (unfold sp_not) intro)
+ destructure_hyps)
+ | Kimp(a,b) -> (tclTHEN intro (loop b))
+ | Kapp(False,[]) -> destructure_hyps
+ | _ ->
+ (tclTHEN
+ (tclTHEN
+ (Tactics.refine
+ (mkApp (Lazy.force coq_dec_not_not, [| t;
+ decidability gl t; mkNewMeta () |])))
+ intro)
+ (destructure_hyps))
+ in
+ (loop concl) gl
+
+let destructure_goal = all_time (destructure_goal)
+
+let omega_solver gl =
+ Coqlib.check_required_library ["Coq";"omega";"Omega"];
+ let result = destructure_goal gl in
+ (* if !display_time_flag then begin text_time ();
+ flush Pervasives.stdout end; *)
+ result
diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
new file mode 100644
index 00000000..3bfdce7f
--- /dev/null
+++ b/plugins/omega/g_omega.ml4
@@ -0,0 +1,47 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(**************************************************************************)
+(* *)
+(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *)
+(* *)
+(* Pierre Crégut (CNET, Lannion, France) *)
+(* *)
+(**************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Coq_omega
+open Refiner
+
+let omega_tactic l =
+ let tacs = List.map
+ (function
+ | "nat" -> Tacinterp.interp <:tactic<zify_nat>>
+ | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
+ | "N" -> Tacinterp.interp <:tactic<zify_N>>
+ | "Z" -> Tacinterp.interp <:tactic<zify_op>>
+ | s -> Util.error ("No Omega knowledge base for type "^s))
+ (Util.list_uniquize (List.sort compare l))
+ in
+ tclTHEN
+ (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
+ omega_solver
+
+
+TACTIC EXTEND omega
+| [ "omega" ] -> [ omega_tactic [] ]
+END
+
+TACTIC EXTEND omega'
+| [ "omega" "with" ne_ident_list(l) ] ->
+ [ omega_tactic (List.map Names.string_of_id l) ]
+| [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ]
+END
+
diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml
new file mode 100644
index 00000000..11ab9c03
--- /dev/null
+++ b/plugins/omega/omega.ml
@@ -0,0 +1,716 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(**************************************************************************)
+(* *)
+(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *)
+(* *)
+(* Pierre Crégut (CNET, Lannion, France) *)
+(* *)
+(* 13/10/2002 : modified to cope with an external numbering of equations *)
+(* and hypothesis. Its use for Omega is not more complex and it makes *)
+(* things much simpler for the reflexive version where we should limit *)
+(* the number of source of numbering. *)
+(**************************************************************************)
+
+open Names
+
+module type INT = sig
+ type bigint
+ val less_than : bigint -> bigint -> bool
+ val add : bigint -> bigint -> bigint
+ val sub : bigint -> bigint -> bigint
+ val mult : bigint -> bigint -> bigint
+ val euclid : bigint -> bigint -> bigint * bigint
+ val neg : bigint -> bigint
+ val zero : bigint
+ val one : bigint
+ val to_string : bigint -> string
+end
+
+let debug = ref false
+
+module MakeOmegaSolver (Int:INT) = struct
+
+type bigint = Int.bigint
+let (<?) = Int.less_than
+let (<=?) x y = Int.less_than x y or x = y
+let (>?) x y = Int.less_than y x
+let (>=?) x y = Int.less_than y x or x = y
+let (=?) = (=)
+let (+) = Int.add
+let (-) = Int.sub
+let ( * ) = Int.mult
+let (/) x y = fst (Int.euclid x y)
+let (mod) x y = snd (Int.euclid x y)
+let zero = Int.zero
+let one = Int.one
+let two = one + one
+let negone = Int.neg one
+let abs x = if Int.less_than x zero then Int.neg x else x
+let string_of_bigint = Int.to_string
+let neg = Int.neg
+
+(* To ensure that polymorphic (<) is not used mistakenly on big integers *)
+(* Warning: do not use (=) either on big int *)
+let (<) = ((<) : int -> int -> bool)
+let (>) = ((>) : int -> int -> bool)
+let (<=) = ((<=) : int -> int -> bool)
+let (>=) = ((>=) : int -> int -> bool)
+
+let pp i = print_int i; print_newline (); flush stdout
+
+let push v l = l := v :: !l
+
+let rec pgcd x y = if y =? zero then x else pgcd y (x mod y)
+
+let pgcd_l = function
+ | [] -> failwith "pgcd_l"
+ | x :: l -> List.fold_left pgcd x l
+
+let floor_div a b =
+ match a >=? zero , b >? zero with
+ | true,true -> a / b
+ | false,false -> a / b
+ | true, false -> (a-one) / b - one
+ | false,true -> (a+one) / b - one
+
+type coeff = {c: bigint ; v: int}
+
+type linear = coeff list
+
+type eqn_kind = EQUA | INEQ | DISE
+
+type afine = {
+ (* a number uniquely identifying the equation *)
+ id: int ;
+ (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *)
+ kind: eqn_kind;
+ (* the variables and their coefficient *)
+ body: coeff list;
+ (* a constant *)
+ constant: bigint }
+
+type state_action = {
+ st_new_eq : afine;
+ st_def : afine;
+ st_orig : afine;
+ st_coef : bigint;
+ st_var : int }
+
+type action =
+ | DIVIDE_AND_APPROX of afine * afine * bigint * bigint
+ | NOT_EXACT_DIVIDE of afine * bigint
+ | FORGET_C of int
+ | EXACT_DIVIDE of afine * bigint
+ | SUM of int * (bigint * afine) * (bigint * afine)
+ | STATE of state_action
+ | HYP of afine
+ | FORGET of int * int
+ | FORGET_I of int * int
+ | CONTRADICTION of afine * afine
+ | NEGATE_CONTRADICT of afine * afine * bool
+ | MERGE_EQ of int * afine * int
+ | CONSTANT_NOT_NUL of int * bigint
+ | CONSTANT_NUL of int
+ | CONSTANT_NEG of int * bigint
+ | SPLIT_INEQ of afine * (int * action list) * (int * action list)
+ | WEAKEN of int * bigint
+
+exception UNSOLVABLE
+
+exception NO_CONTRADICTION
+
+let display_eq print_var (l,e) =
+ let _ =
+ List.fold_left
+ (fun not_first f ->
+ print_string
+ (if f.c <? zero then "- " else if not_first then "+ " else "");
+ let c = abs f.c in
+ if c =? one then
+ Printf.printf "%s " (print_var f.v)
+ else
+ Printf.printf "%s %s " (string_of_bigint c) (print_var f.v);
+ true)
+ false l
+ in
+ if e >? zero then
+ Printf.printf "+ %s " (string_of_bigint e)
+ else if e <? zero then
+ Printf.printf "- %s " (string_of_bigint (abs e))
+
+let rec trace_length l =
+ let action_length accu = function
+ | SPLIT_INEQ (_,(_,l1),(_,l2)) ->
+ accu + one + trace_length l1 + trace_length l2
+ | _ -> accu + one in
+ List.fold_left action_length zero l
+
+let operator_of_eq = function
+ | EQUA -> "=" | DISE -> "!=" | INEQ -> ">="
+
+let kind_of = function
+ | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation"
+
+let display_system print_var l =
+ List.iter
+ (fun { kind=b; body=e; constant=c; id=id} ->
+ Printf.printf "E%d: " id;
+ display_eq print_var (e,c);
+ Printf.printf "%s 0\n" (operator_of_eq b))
+ l;
+ print_string "------------------------\n\n"
+
+let display_inequations print_var l =
+ List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l;
+ print_string "------------------------\n\n"
+
+let sbi = string_of_bigint
+
+let rec display_action print_var = function
+ | act :: l -> begin match act with
+ | DIVIDE_AND_APPROX (e1,e2,k,d) ->
+ Printf.printf
+ "Inequation E%d is divided by %s and the constant coefficient is \
+ rounded by substracting %s.\n" e1.id (sbi k) (sbi d)
+ | NOT_EXACT_DIVIDE (e,k) ->
+ Printf.printf
+ "Constant in equation E%d is not divisible by the pgcd \
+ %s of its other coefficients.\n" e.id (sbi k)
+ | EXACT_DIVIDE (e,k) ->
+ Printf.printf
+ "Equation E%d is divided by the pgcd \
+ %s of its coefficients.\n" e.id (sbi k)
+ | WEAKEN (e,k) ->
+ Printf.printf
+ "To ensure a solution in the dark shadow \
+ the equation E%d is weakened by %s.\n" e (sbi k)
+ | SUM (e,(c1,e1),(c2,e2)) ->
+ Printf.printf
+ "We state %s E%d = %s %s E%d + %s %s E%d.\n"
+ (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2)
+ (kind_of e2.kind) e2.id
+ | STATE { st_new_eq = e } ->
+ Printf.printf "We define a new equation E%d: " e.id;
+ display_eq print_var (e.body,e.constant);
+ print_string (operator_of_eq e.kind); print_string " 0"
+ | HYP e ->
+ Printf.printf "We define E%d: " e.id;
+ display_eq print_var (e.body,e.constant);
+ print_string (operator_of_eq e.kind); print_string " 0\n"
+ | FORGET_C e -> Printf.printf "E%d is trivially satisfiable.\n" e
+ | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2
+ | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2
+ | MERGE_EQ (e,e1,e2) ->
+ Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e
+ | CONTRADICTION (e1,e2) ->
+ Printf.printf
+ "Equations E%d and E%d imply a contradiction on their \
+ 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
+ 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)
+ | CONSTANT_NEG(e,k) ->
+ Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k)
+ | CONSTANT_NUL e ->
+ Printf.printf "Inequation E%d states 0 != 0.\n" e
+ | SPLIT_INEQ (e,(e1,l1),(e2,l2)) ->
+ Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2;
+ display_action print_var l1;
+ print_newline ();
+ display_action print_var l2;
+ print_newline ()
+ end; display_action print_var l
+ | [] ->
+ flush stdout
+
+let default_print_var v = Printf.sprintf "X%d" v (* For debugging *)
+
+(*""*)
+let add_event, history, clear_history =
+ let accu = ref [] in
+ (fun (v:action) -> if !debug then display_action default_print_var [v]; push v accu),
+ (fun () -> !accu),
+ (fun () -> accu := [])
+
+let nf_linear = Sort.list (fun x y -> x.v > y.v)
+
+let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x))
+
+let map_eq_linear f =
+ let rec loop = function
+ | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l
+ | [] -> []
+ in
+ loop
+
+let map_eq_afine f e =
+ { id = e.id; kind = e.kind; body = map_eq_linear f e.body;
+ constant = f e.constant }
+
+let negate_eq = map_eq_afine (fun x -> neg x)
+
+let rec sum p0 p1 = match (p0,p1) with
+ | ([], l) -> l | (l, []) -> l
+ | (((x1::l1) as l1'), ((x2::l2) as l2')) ->
+ if x1.v = x2.v then
+ let c = x1.c + x2.c in
+ if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2
+ else if x1.v > x2.v then
+ x1 :: sum l1 l2'
+ else
+ x2 :: sum l1' l2
+
+let sum_afine new_eq_id eq1 eq2 =
+ { kind = eq1.kind; id = new_eq_id ();
+ body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant }
+
+exception FACTOR1
+
+let rec chop_factor_1 = function
+ | x :: l ->
+ if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l')
+ | [] -> raise FACTOR1
+
+exception CHOPVAR
+
+let rec chop_var v = function
+ | f :: l -> if f.v = v then f,l else let (f',l') = chop_var v l in (f',f::l')
+ | [] -> raise CHOPVAR
+
+let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) =
+ if e = [] then begin
+ match eq_flag with
+ | EQUA ->
+ if x =? zero then [] else begin
+ add_event (CONSTANT_NOT_NUL(id,x)); raise UNSOLVABLE
+ end
+ | DISE ->
+ if x <> zero then [] else begin
+ add_event (CONSTANT_NUL id); raise UNSOLVABLE
+ end
+ | INEQ ->
+ if x >=? zero then [] else begin
+ add_event (CONSTANT_NEG(id,x)); raise UNSOLVABLE
+ end
+ end else
+ let gcd = pgcd_l (List.map (fun f -> abs f.c) e) in
+ if eq_flag=EQUA & x mod gcd <> zero then begin
+ add_event (NOT_EXACT_DIVIDE (eq,gcd)); raise UNSOLVABLE
+ end else if eq_flag=DISE & x mod gcd <> zero then begin
+ add_event (FORGET_C eq.id); []
+ end else if gcd <> one then begin
+ let c = floor_div x gcd in
+ let d = x - c * gcd in
+ let new_eq = {id=id; kind=eq_flag; constant=c;
+ body=map_eq_linear (fun c -> c / gcd) e} in
+ add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd)
+ else DIVIDE_AND_APPROX(eq,new_eq,gcd,d));
+ [new_eq]
+ end else [eq]
+
+let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2
+ ({body=e1; constant=c1} as eq1) =
+ try
+ let (f,_) = chop_var v e1 in
+ let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c
+ else failwith "eliminate_with_in" in
+ let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in
+ add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res
+ with CHOPVAR -> eq1
+
+let omega_mod a b = a - b * floor_div (two * a + b) (two * b)
+let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 =
+ let e = original.body in
+ let sigma = new_var_id () in
+ let smallest,var =
+ try
+ List.fold_left (fun (v,p) c -> if v >? (abs c.c) then abs c.c,c.v else (v,p))
+ (abs (List.hd e).c, (List.hd e).v) (List.tl e)
+ with Failure "tl" -> display_system print_var [original] ; failwith "TL" in
+ let m = smallest + one in
+ let new_eq =
+ { constant = omega_mod original.constant m;
+ body = {c= neg m;v=sigma} ::
+ map_eq_linear (fun a -> omega_mod a m) original.body;
+ id = new_eq_id (); kind = EQUA } in
+ let definition =
+ { constant = neg (floor_div (two * original.constant + m) (two * m));
+ body = map_eq_linear (fun a -> neg (floor_div (two * a + m) (two * m)))
+ original.body;
+ id = new_eq_id (); kind = EQUA } in
+ add_event (STATE {st_new_eq = new_eq; st_def = definition;
+ st_orig = original; st_coef = m; st_var = sigma});
+ let new_eq = List.hd (normalize new_eq) in
+ let eliminated_var, def = chop_var var new_eq.body in
+ let other_equations =
+ Util.list_map_append
+ (fun e ->
+ normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in
+ let inequations =
+ Util.list_map_append
+ (fun e ->
+ normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in
+ let original' = eliminate_with_in new_eq_id eliminated_var new_eq original in
+ let mod_original = map_eq_afine (fun c -> c / m) original' in
+ add_event (EXACT_DIVIDE (original',m));
+ List.hd (normalize mod_original),other_equations,inequations
+
+let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) =
+ if !debug then display_system print_var (e::other);
+ try
+ let v,def = chop_factor_1 e.body in
+ (Util.list_map_append
+ (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) other,
+ Util.list_map_append
+ (fun e' -> normalize (eliminate_with_in new_eq_id v e e')) ineqs)
+ with FACTOR1 ->
+ eliminate_one_equation new_ids (banerjee_step new_ids e other ineqs)
+
+let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) =
+ let rec fst_eq_1 = function
+ (eq::l) ->
+ if List.exists (fun x -> abs x.c =? one) eq.body then eq,l
+ else let (eq',l') = fst_eq_1 l in (eq',eq::l')
+ | [] -> raise Not_found in
+ match sys_eq with
+ [] -> if !debug then display_system print_var sys_ineq; sys_ineq
+ | (e1::rest) ->
+ let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in
+ if eq.body = [] then
+ if eq.constant =? zero then begin
+ add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq)
+ end else begin
+ add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE
+ end
+ else
+ banerjee new_ids
+ (eliminate_one_equation new_ids (eq,other,sys_ineq))
+
+type kind = INVERTED | NORMAL
+
+let redundancy_elimination new_eq_id system =
+ let normal = function
+ ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED
+ | e -> e,NORMAL in
+ let table = Hashtbl.create 7 in
+ List.iter
+ (fun e ->
+ let ({body=ne} as nx) ,kind = normal e in
+ if ne = [] then
+ if nx.constant <? zero then begin
+ add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE
+ end else add_event (FORGET_C nx.id)
+ else
+ try
+ let (optnormal,optinvert) = Hashtbl.find table ne in
+ let final =
+ if kind = NORMAL then begin
+ match optnormal with
+ Some v ->
+ let kept =
+ if v.constant <? nx.constant
+ then begin add_event (FORGET (v.id,nx.id));v end
+ else begin add_event (FORGET (nx.id,v.id));nx end in
+ (Some(kept),optinvert)
+ | None -> Some nx,optinvert
+ end else begin
+ match optinvert with
+ Some v ->
+ let _kept =
+ if v.constant >? nx.constant
+ then begin add_event (FORGET_I (v.id,nx.id));v end
+ else begin add_event (FORGET_I (nx.id,v.id));nx end in
+ (optnormal,Some(if v.constant >? nx.constant then v else nx))
+ | None -> optnormal,Some nx
+ end in
+ begin match final with
+ (Some high, Some low) ->
+ if high.constant <? low.constant then begin
+ add_event(CONTRADICTION (high,negate_eq low));
+ raise UNSOLVABLE
+ end
+ | _ -> () end;
+ Hashtbl.remove table ne;
+ Hashtbl.add table ne final
+ with Not_found ->
+ Hashtbl.add table ne
+ (if kind = NORMAL then (Some nx,None) else (None,Some nx)))
+ system;
+ let accu_eq = ref [] in
+ let accu_ineq = ref [] in
+ Hashtbl.iter
+ (fun p0 p1 -> match (p0,p1) with
+ | (e, (Some x, Some y)) when x.constant =? y.constant ->
+ let id=new_eq_id () in
+ add_event (MERGE_EQ(id,x,y.id));
+ push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq
+ | (e, (optnorm,optinvert)) ->
+ begin match optnorm with
+ Some x -> push x accu_ineq | _ -> () end;
+ begin match optinvert with
+ Some x -> push (negate_eq x) accu_ineq | _ -> () end)
+ table;
+ !accu_eq,!accu_ineq
+
+exception SOLVED_SYSTEM
+
+let select_variable system =
+ let table = Hashtbl.create 7 in
+ let push v c=
+ try let r = Hashtbl.find table v in r := max !r (abs c)
+ with Not_found -> Hashtbl.add table v (ref (abs c)) in
+ List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system;
+ let vmin,cmin = ref (-1), ref zero in
+ let var_cpt = ref 0 in
+ Hashtbl.iter
+ (fun v ({contents = c}) ->
+ incr var_cpt;
+ if c <? !cmin or !vmin = (-1) then begin vmin := v; cmin := c end)
+ table;
+ if !var_cpt < 1 then raise SOLVED_SYSTEM;
+ !vmin
+
+let classify v system =
+ List.fold_left
+ (fun (not_occ,below,over) eq ->
+ try let f,eq' = chop_var v eq.body in
+ if f.c >=? zero then (not_occ,((f.c,eq) :: below),over)
+ else (not_occ,below,((neg f.c,eq) :: over))
+ with CHOPVAR -> (eq::not_occ,below,over))
+ ([],[],[]) system
+
+let product new_eq_id dark_shadow low high =
+ List.fold_left
+ (fun accu (a,eq1) ->
+ List.fold_left
+ (fun accu (b,eq2) ->
+ let eq =
+ sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1)
+ (map_eq_afine (fun c -> c * a) eq2) in
+ add_event(SUM(eq.id,(b,eq1),(a,eq2)));
+ match normalize eq with
+ | [eq] ->
+ let final_eq =
+ if dark_shadow then
+ let delta = (a - one) * (b - one) in
+ add_event(WEAKEN(eq.id,delta));
+ {id = eq.id; kind=INEQ; body = eq.body;
+ constant = eq.constant - delta}
+ else eq
+ in final_eq :: accu
+ | (e::_) -> failwith "Product dardk"
+ | [] -> accu)
+ accu high)
+ [] low
+
+let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system =
+ let v = select_variable system in
+ let (ineq_out, ineq_low,ineq_high) = classify v system in
+ let expanded = ineq_out @ product new_eq_id dark_shadow ineq_low ineq_high in
+ if !debug then display_system print_var expanded; expanded
+
+let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system =
+ if List.exists (fun e -> e.kind = DISE) system then
+ failwith "disequation in simplify";
+ clear_history ();
+ List.iter (fun e -> add_event (HYP e)) system;
+ let system = Util.list_map_append normalize system in
+ let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
+ let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in
+ let system = (eqs @ simp_eq,simp_ineq) in
+ let rec loop1a system =
+ let sys_ineq = banerjee new_ids system in
+ loop1b sys_ineq
+ and loop1b sys_ineq =
+ let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in
+ if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq)
+ in
+ let rec loop2 system =
+ try
+ let expanded = fourier_motzkin new_ids dark_shadow system in
+ loop2 (loop1b expanded)
+ with SOLVED_SYSTEM ->
+ if !debug then display_system print_var system; system
+ in
+ loop2 (loop1a system)
+
+let rec depend relie_on accu = function
+ | act :: l ->
+ begin match act with
+ | DIVIDE_AND_APPROX (e,_,_,_) ->
+ if List.mem e.id relie_on then depend relie_on (act::accu) l
+ else depend relie_on accu l
+ | EXACT_DIVIDE (e,_) ->
+ if List.mem e.id relie_on then depend relie_on (act::accu) l
+ else depend relie_on accu l
+ | WEAKEN (e,_) ->
+ if List.mem e relie_on then depend relie_on (act::accu) l
+ else depend relie_on accu l
+ | SUM (e,(_,e1),(_,e2)) ->
+ if List.mem e relie_on then
+ depend (e1.id::e2.id::relie_on) (act::accu) l
+ else
+ depend relie_on accu l
+ | STATE {st_new_eq=e;st_orig=o} ->
+ if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l
+ else depend relie_on accu l
+ | HYP e ->
+ if List.mem e.id relie_on then depend relie_on (act::accu) l
+ else depend relie_on accu l
+ | FORGET_C _ -> depend relie_on accu l
+ | FORGET _ -> depend relie_on accu l
+ | FORGET_I _ -> depend relie_on accu l
+ | MERGE_EQ (e,e1,e2) ->
+ if List.mem e relie_on then
+ depend (e1.id::e2::relie_on) (act::accu) l
+ else
+ depend relie_on accu l
+ | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l
+ | CONTRADICTION (e1,e2) ->
+ depend (e1.id::e2.id::relie_on) (act::accu) l
+ | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l
+ | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l
+ | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l
+ | NEGATE_CONTRADICT (e1,e2,_) ->
+ depend (e1.id::e2.id::relie_on) (act::accu) l
+ | SPLIT_INEQ _ -> failwith "depend"
+ end
+ | [] -> relie_on, accu
+
+(*
+let depend relie_on accu trace =
+ Printf.printf "Longueur de la trace initiale : %d\n"
+ (trace_length trace + trace_length accu);
+ let rel',trace' = depend relie_on accu trace in
+ Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace');
+ rel',trace'
+*)
+
+let solve (new_eq_id,new_eq_var,print_var) system =
+ try let _ = simplify new_eq_id false system in failwith "no contradiction"
+ with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ())))
+
+let negation (eqs,ineqs) =
+ let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in
+ let normal = function
+ | ({body=f::_} as e) when f.c <? zero -> negate_eq e, INVERTED
+ | e -> e,NORMAL in
+ let table = Hashtbl.create 7 in
+ List.iter (fun e ->
+ let {body=ne;constant=c} ,kind = normal e in
+ Hashtbl.add table (ne,c) (kind,e)) diseq;
+ List.iter (fun e ->
+ assert (e.kind = EQUA);
+ let {body=ne;constant=c},kind = normal e in
+ try
+ let (kind',e') = Hashtbl.find table (ne,c) in
+ add_event (NEGATE_CONTRADICT (e,e',kind=kind'));
+ raise UNSOLVABLE
+ with Not_found -> ()) eqs
+
+exception FULL_SOLUTION of action list * int list
+
+let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system =
+ clear_history ();
+ List.iter (fun e -> add_event (HYP e)) system;
+ (* Initial simplification phase *)
+ let rec loop1a system =
+ negation system;
+ let sys_ineq = banerjee new_ids system in
+ loop1b sys_ineq
+ and loop1b sys_ineq =
+ let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in
+ let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
+ if simp_eq = [] then dise @ simp_ineq
+ else loop1a (simp_eq,dise @ simp_ineq)
+ in
+ let rec loop2 system =
+ try
+ let expanded = fourier_motzkin new_ids false system in
+ loop2 (loop1b expanded)
+ with SOLVED_SYSTEM -> if !debug then display_system print_var system; system
+ in
+ let rec explode_diseq = function
+ | (de::diseq,ineqs,expl_map) ->
+ let id1 = new_eq_id ()
+ and id2 = new_eq_id () in
+ let e1 =
+ {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in
+ let e2 =
+ {id = id2; kind=INEQ; body = map_eq_linear neg de.body;
+ constant = neg de.constant - one} in
+ let new_sys =
+ List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys))
+ ineqs @
+ List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys))
+ ineqs
+ in
+ explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map)
+ | ([],ineqs,expl_map) -> ineqs,expl_map
+ in
+ try
+ let system = Util.list_map_append normalize system in
+ let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in
+ let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in
+ let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in
+ let system = (eqs @ simp_eq,simp_ineq @ dise) in
+ let system' = loop1a system in
+ let diseq,ineq = List.partition (fun e -> e.kind = DISE) system' in
+ let first_segment = history () in
+ let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in
+ let all_solutions =
+ List.map
+ (fun (decomp,sys) ->
+ clear_history ();
+ try let _ = loop2 sys in raise NO_CONTRADICTION
+ with UNSOLVABLE ->
+ let relie_on,path = depend [] [] (history ()) in
+ let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in
+ let red = List.map (fun (x,_,_) -> x) dc in
+ (red,relie_on,decomp,path))
+ sys_exploded
+ in
+ let max_count sys =
+ let tbl = Hashtbl.create 7 in
+ let augment x =
+ try incr (Hashtbl.find tbl x)
+ with Not_found -> Hashtbl.add tbl x (ref 1) in
+ let eq = ref (-1) and c = ref 0 in
+ List.iter (function
+ | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on))
+ | (l,_,_,_) -> List.iter augment l) sys;
+ Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl;
+ !eq
+ in
+ let rec solve systems =
+ try
+ let id = max_count systems in
+ let rec sign = function
+ | ((id',_,b)::l) -> if id=id' then b else sign l
+ | [] -> failwith "solve" in
+ let s1,s2 =
+ List.partition (fun (_,_,decomp,_) -> sign decomp) systems in
+ let s1' =
+ List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in
+ let s2' =
+ List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in
+ let (r1,relie1) = solve s1'
+ and (r2,relie2) = solve s2' in
+ let (eq,id1,id2) = List.assoc id explode_map in
+ [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2
+ with FULL_SOLUTION (x0,x1) -> (x0,x1)
+ in
+ let act,relie_on = solve all_solutions in
+ snd(depend relie_on act first_segment)
+ with UNSOLVABLE -> snd (depend [] [] (history ()))
+
+end
diff --git a/plugins/omega/omega_plugin.mllib b/plugins/omega/omega_plugin.mllib
new file mode 100644
index 00000000..2b387fdc
--- /dev/null
+++ b/plugins/omega/omega_plugin.mllib
@@ -0,0 +1,4 @@
+Omega
+Coq_omega
+G_omega
+Omega_plugin_mod
diff --git a/plugins/omega/vo.itarget b/plugins/omega/vo.itarget
new file mode 100644
index 00000000..9d9a77a8
--- /dev/null
+++ b/plugins/omega/vo.itarget
@@ -0,0 +1,4 @@
+OmegaLemmas.vo
+OmegaPlugin.vo
+Omega.vo
+PreOmega.vo
diff --git a/plugins/plugins.itarget b/plugins/plugins.itarget
new file mode 100644
index 00000000..56aa42b0
--- /dev/null
+++ b/plugins/plugins.itarget
@@ -0,0 +1,3 @@
+pluginsopt.otarget
+pluginsbyte.otarget
+pluginsvo.otarget \ No newline at end of file
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
new file mode 100644
index 00000000..1485c147
--- /dev/null
+++ b/plugins/pluginsbyte.itarget
@@ -0,0 +1,23 @@
+field/field_plugin.cma
+setoid_ring/newring_plugin.cma
+extraction/extraction_plugin.cma
+firstorder/ground_plugin.cma
+rtauto/rtauto_plugin.cma
+fourier/fourier_plugin.cma
+romega/romega_plugin.cma
+omega/omega_plugin.cma
+micromega/micromega_plugin.cma
+dp/dp_plugin.cma
+xml/xml_plugin.cma
+subtac/subtac_plugin.cma
+ring/ring_plugin.cma
+cc/cc_plugin.cma
+nsatz/nsatz_plugin.cma
+funind/recdef_plugin.cma
+syntax/ascii_syntax_plugin.cma
+syntax/nat_syntax_plugin.cma
+syntax/numbers_syntax_plugin.cma
+syntax/r_syntax_plugin.cma
+syntax/string_syntax_plugin.cma
+syntax/z_syntax_plugin.cma
+quote/quote_plugin.cma
diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget
new file mode 100644
index 00000000..5d502411
--- /dev/null
+++ b/plugins/pluginsdyn.itarget
@@ -0,0 +1,23 @@
+field/field_plugin.cmxs
+setoid_ring/newring_plugin.cmxs
+extraction/extraction_plugin.cmxs
+firstorder/ground_plugin.cmxs
+rtauto/rtauto_plugin.cmxs
+fourier/fourier_plugin.cmxs
+romega/romega_plugin.cmxs
+omega/omega_plugin.cmxs
+micromega/micromega_plugin.cmxs
+dp/dp_plugin.cmxs
+xml/xml_plugin.cmxs
+subtac/subtac_plugin.cmxs
+ring/ring_plugin.cmxs
+cc/cc_plugin.cmxs
+nsatz/nsatz_plugin.cmxs
+funind/recdef_plugin.cmxs
+syntax/ascii_syntax_plugin.cmxs
+syntax/nat_syntax_plugin.cmxs
+syntax/numbers_syntax_plugin.cmxs
+syntax/r_syntax_plugin.cmxs
+syntax/string_syntax_plugin.cmxs
+syntax/z_syntax_plugin.cmxs
+quote/quote_plugin.cmxs
diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget
new file mode 100644
index 00000000..2f72dab8
--- /dev/null
+++ b/plugins/pluginsopt.itarget
@@ -0,0 +1,23 @@
+field/field_plugin.cmxa
+setoid_ring/newring_plugin.cmxa
+extraction/extraction_plugin.cmxa
+firstorder/ground_plugin.cmxa
+rtauto/rtauto_plugin.cmxa
+fourier/fourier_plugin.cmxa
+romega/romega_plugin.cmxa
+omega/omega_plugin.cmxa
+micromega/micromega_plugin.cmxa
+dp/dp_plugin.cmxa
+xml/xml_plugin.cmxa
+subtac/subtac_plugin.cmxa
+ring/ring_plugin.cmxa
+cc/cc_plugin.cmxa
+nsatz/nsatz_plugin.cmxa
+funind/recdef_plugin.cmxa
+syntax/ascii_syntax_plugin.cmxa
+syntax/nat_syntax_plugin.cmxa
+syntax/numbers_syntax_plugin.cmxa
+syntax/r_syntax_plugin.cmxa
+syntax/string_syntax_plugin.cmxa
+syntax/z_syntax_plugin.cmxa
+quote/quote_plugin.cmxa
diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget
new file mode 100644
index 00000000..db56534c
--- /dev/null
+++ b/plugins/pluginsvo.itarget
@@ -0,0 +1,13 @@
+dp/vo.otarget
+field/vo.otarget
+fourier/vo.otarget
+funind/vo.otarget
+nsatz/vo.otarget
+micromega/vo.otarget
+omega/vo.otarget
+quote/vo.otarget
+ring/vo.otarget
+romega/vo.otarget
+rtauto/vo.otarget
+setoid_ring/vo.otarget
+extraction/vo.otarget \ No newline at end of file
diff --git a/plugins/quote/Quote.v b/plugins/quote/Quote.v
new file mode 100644
index 00000000..11726675
--- /dev/null
+++ b/plugins/quote/Quote.v
@@ -0,0 +1,87 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Declare ML Module "quote_plugin".
+
+(***********************************************************************
+ The "abstract" type index is defined to represent variables.
+
+ index : Set
+ index_eq : index -> bool
+ index_eq_prop: (n,m:index)(index_eq n m)=true -> n=m
+ index_lt : index -> bool
+ varmap : Type -> Type.
+ varmap_find : (A:Type)A -> index -> (varmap A) -> A.
+
+ The first arg. of varmap_find is the default value to take
+ if the object is not found in the varmap.
+
+ index_lt defines a total well-founded order, but we don't prove that.
+
+***********************************************************************)
+
+Set Implicit Arguments.
+Unset Boxed Definitions.
+
+Section variables_map.
+
+Variable A : Type.
+
+Inductive varmap : Type :=
+ | Empty_vm : varmap
+ | Node_vm : A -> varmap -> varmap -> varmap.
+
+Inductive index : Set :=
+ | Left_idx : index -> index
+ | Right_idx : index -> index
+ | End_idx : index.
+
+Fixpoint varmap_find (default_value:A) (i:index) (v:varmap) {struct v} : A :=
+ match i, v with
+ | End_idx, Node_vm x _ _ => x
+ | Right_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v2
+ | Left_idx i1, Node_vm x v1 v2 => varmap_find default_value i1 v1
+ | _, _ => default_value
+ end.
+
+Fixpoint index_eq (n m:index) {struct m} : bool :=
+ match n, m with
+ | End_idx, End_idx => true
+ | Left_idx n', Left_idx m' => index_eq n' m'
+ | Right_idx n', Right_idx m' => index_eq n' m'
+ | _, _ => false
+ end.
+
+Fixpoint index_lt (n m:index) {struct m} : bool :=
+ match n, m with
+ | End_idx, Left_idx _ => true
+ | End_idx, Right_idx _ => true
+ | Left_idx n', Right_idx m' => true
+ | Right_idx n', Right_idx m' => index_lt n' m'
+ | Left_idx n', Left_idx m' => index_lt n' m'
+ | _, _ => false
+ end.
+
+Lemma index_eq_prop : forall n m:index, index_eq n m = true -> n = m.
+ simple induction n; simple induction m; simpl in |- *; intros.
+ rewrite (H i0 H1); reflexivity.
+ discriminate.
+ discriminate.
+ discriminate.
+ rewrite (H i0 H1); reflexivity.
+ discriminate.
+ discriminate.
+ discriminate.
+ reflexivity.
+Qed.
+
+End variables_map.
+
+Unset Implicit Arguments.
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
new file mode 100644
index 00000000..bdeb9844
--- /dev/null
+++ b/plugins/quote/g_quote.ml4
@@ -0,0 +1,31 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Util
+open Tacexpr
+open Quote
+
+let make_cont k x =
+ let k = TacDynamic(dummy_loc, Tacinterp.tactic_in (fun _ -> fst 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
+
+TACTIC EXTEND quote
+ [ "quote" ident(f) ] -> [ quote f [] ]
+| [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ]
+| [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] ->
+ [ gen_quote (make_cont k) c f [] ]
+| [ "quote" ident(f) "[" ne_ident_list(lc) "]"
+ "in" constr(c) "using" tactic(k) ] ->
+ [ gen_quote (make_cont k) c f lc ]
+END
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
new file mode 100644
index 00000000..2e4d07d6
--- /dev/null
+++ b/plugins/quote/quote.ml
@@ -0,0 +1,504 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* The `Quote' tactic *)
+
+(* The basic idea is to automatize the inversion of interpetation functions
+ in 2-level approach
+
+ Examples are given in \texttt{theories/DEMOS/DemoQuote.v}
+
+ Suppose you have a langage \texttt{L} of 'abstract terms'
+ and a type \texttt{A} of 'concrete terms'
+ and a function \texttt{f : L -> (varmap A L) -> A}.
+
+ Then, the tactic \texttt{quote f} will replace an
+ expression \texttt{e} of type \texttt{A} by \texttt{(f vm t)}
+ such that \texttt{e} and \texttt{(f vm t)} are convertible.
+
+ The problem is then inverting the function \texttt{f}.
+
+ The tactic works when:
+
+ \begin{itemize}
+ \item L is a simple inductive datatype. The constructors of L may
+ have one of the three following forms:
+
+ \begin{enumerate}
+ \item ordinary recursive constructors like: \verb|Cplus : L -> L -> L|
+ \item variable leaf like: \verb|Cvar : index -> L|
+ \item constant leaf like \verb|Cconst : A -> L|
+ \end{enumerate}
+
+ The definition of \texttt{L} must contain at most one variable
+ leaf and at most one constant leaf.
+
+ When there are both a variable leaf and a constant leaf, there is
+ an ambiguity on inversion. The term t can be either the
+ interpretation of \texttt{(Cconst t)} or the interpretation of
+ (\texttt{Cvar}~$i$) in a variable map containing the binding $i
+ \rightarrow$~\texttt{t}. How to discriminate between these
+ choices?
+
+ To solve the dilemma, one gives to \texttt{quote} a list of
+ \emph{constant constructors}: a term will be considered as a
+ constant if it is either a constant constructor or the
+ application of a constant constructor to constants. For example
+ the list \verb+[S, O]+ defines the closed natural
+ numbers. \texttt{(S (S O))} is a constant when \texttt{(S x)} is
+ not.
+
+ The definition of constants vary for each application of the
+ tactic, so it can even be different for two applications of
+ \texttt{quote} with the same function.
+
+ \item \texttt{f} is a quite simple fixpoint on
+ \texttt{L}. In particular, \texttt{f} must verify:
+
+\begin{verbatim}
+ (f (Cvar i)) = (varmap_find vm default_value i)
+\end{verbatim}
+\begin{verbatim}
+ (f (Cconst c)) = c
+\end{verbatim}
+
+ where \texttt{index} and \texttt{varmap\_find} are those defined
+ the \texttt{Quote} module. \emph{The tactic won't work with
+ user's own variables map!!} It is mandatory to use the
+ variable map defined in module \texttt{Quote}.
+
+ \end{itemize}
+
+ The method to proceed is then clear:
+
+ \begin{itemize}
+ \item Start with an empty hashtable of "registed leafs"
+ that maps constr to integers and a "variable counter" equal to 0.
+ \item Try to match the term with every right hand side of the
+ definition of \texttt{f}.
+
+ If there is one match, returns the correponding left hand
+ side and call yourself recursively to get the arguments of this
+ left hand side.
+
+ If there is no match, we are at a leaf. That is the
+ interpretation of either a variable or a constant.
+
+ If it is a constant, return \texttt{Cconst} applied to that
+ constant.
+
+ If not, it is a variable. Look in the hashtable
+ if this leaf has been already encountered. If not, increment
+ the variable counter and add an entry to the hashtable; then
+ return \texttt{(Cvar !variables\_counter)}
+ \end{itemize}
+*)
+
+
+(*i*)
+open Pp
+open Util
+open Names
+open Term
+open Pattern
+open Matching
+open Tacmach
+open Tactics
+open Proof_trees
+open Tacexpr
+(*i*)
+
+(*s First, we need to access some Coq constants
+ We do that lazily, because this code can be linked before
+ the constants are loaded in the environment *)
+
+let constant dir s = Coqlib.gen_constant "Quote" ("quote"::dir) s
+
+let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm")
+let coq_Node_vm = lazy (constant ["Quote"] "Node_vm")
+let coq_varmap_find = lazy (constant ["Quote"] "varmap_find")
+let coq_Right_idx = lazy (constant ["Quote"] "Right_idx")
+let coq_Left_idx = lazy (constant ["Quote"] "Left_idx")
+let coq_End_idx = lazy (constant ["Quote"] "End_idx")
+
+(*s Then comes the stuff to decompose the body of interpetation function
+ and pre-compute the inversion data.
+
+For a function like:
+
+\begin{verbatim}
+ Fixpoint interp (vm:varmap Prop) (f:form) :=
+ match f with
+ | f_and f1 f1 f2 => (interp f1) /\ (interp f2)
+ | f_or f1 f1 f2 => (interp f1) \/ (interp f2)
+ | f_var i => varmap_find Prop default_v i vm
+ | f_const c => c
+ end.
+\end{verbatim}
+
+With the constant constructors \texttt{C1}, \dots, \texttt{Cn}, the
+corresponding scheme will be:
+
+\begin{verbatim}
+ {normal_lhs_rhs =
+ [ "(f_and ?1 ?2)", "?1 /\ ?2";
+ "(f_or ?1 ?2)", " ?1 \/ ?2";];
+ return_type = "Prop";
+ constants = Some [C1,...Cn];
+ variable_lhs = Some "(f_var ?1)";
+ constant_lhs = Some "(f_const ?1)"
+ }
+\end{verbatim}
+
+If there is no constructor for variables in the type \texttt{form},
+then [variable_lhs] is [None]. Idem for constants and
+[constant_lhs]. Both cannot be equal to [None].
+
+The metas in the RHS must correspond to those in the LHS (one cannot
+exchange ?1 and ?2 in the example above)
+
+*)
+
+module ConstrSet = Set.Make(
+ struct
+ type t = constr
+ let compare = (Pervasives.compare : t->t->int)
+ end)
+
+type inversion_scheme = {
+ normal_lhs_rhs : (constr * constr_pattern) list;
+ variable_lhs : constr option;
+ return_type : constr;
+ constants : ConstrSet.t;
+ constant_lhs : constr option }
+
+(*s [compute_ivs gl f cs] computes the inversion scheme associated to
+ [f:constr] with constants list [cs:constr list] in the context of
+ goal [gl]. This function uses the auxiliary functions
+ [i_can't_do_that], [decomp_term], [compute_lhs] and [compute_rhs]. *)
+
+let i_can't_do_that () = error "Quote: not a simple fixpoint"
+
+let decomp_term c = kind_of_term (strip_outer_cast c)
+
+(*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ...
+ ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive
+ type [typ] *)
+
+let coerce_meta_out id =
+ let s = string_of_id id in
+ int_of_string (String.sub s 1 (String.length s - 1))
+let coerce_meta_in n =
+ id_of_string ("M" ^ string_of_int n)
+
+let compute_lhs typ i nargsi =
+ match kind_of_term typ with
+ | Ind(sp,0) ->
+ let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in
+ mkApp (mkConstruct ((sp,0),i+1), argsi)
+ | _ -> i_can't_do_that ()
+
+(*s This function builds the pattern from the RHS. Recursive calls are
+ replaced by meta-variables ?i corresponding to those in the LHS *)
+
+let compute_rhs bodyi index_of_f =
+ let rec aux c =
+ match kind_of_term c with
+ | App (j, args) when j = mkRel (index_of_f) (* recursive call *) ->
+ let i = destRel (array_last args) in
+ PMeta (Some (coerce_meta_in i))
+ | App (f,args) ->
+ PApp (snd (pattern_of_constr Evd.empty f), Array.map aux args)
+ | Cast (c,_,_) -> aux c
+ | _ -> snd (pattern_of_constr Evd.empty c)
+ in
+ aux bodyi
+
+(*s Now the function [compute_ivs] itself *)
+
+let compute_ivs gl f cs =
+ let cst = try destConst f with _ -> i_can't_do_that () in
+ let body = Environ.constant_value (Global.env()) cst in
+ match decomp_term body with
+ | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) ->
+ let (args3, body3) = decompose_lam body2 in
+ let nargs3 = List.length args3 in
+ begin match decomp_term body3 with
+ | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *)
+ let n_lhs_rhs = ref []
+ and v_lhs = ref (None : constr option)
+ and c_lhs = ref (None : constr option) in
+ Array.iteri
+ (fun i ci ->
+ let argsi, bodyi = decompose_lam ci in
+ let nargsi = List.length argsi in
+ (* REL (narg3 + nargsi + 1) is f *)
+ (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *)
+ (* REL 1 to REL nargsi are argsi (reverse order) *)
+ (* First we test if the RHS is the RHS for constants *)
+ if bodyi = mkRel 1 then
+ c_lhs := Some (compute_lhs (snd (List.hd args3))
+ i nargsi)
+ (* Then we test if the RHS is the RHS for variables *)
+ else begin match decompose_app bodyi with
+ | vmf, [_; _; a3; a4 ]
+ when isRel a3 & isRel a4 &
+ pf_conv_x gl vmf
+ (Lazy.force coq_varmap_find)->
+ v_lhs := Some (compute_lhs
+ (snd (List.hd args3))
+ i nargsi)
+ (* Third case: this is a normal LHS-RHS *)
+ | _ ->
+ n_lhs_rhs :=
+ (compute_lhs (snd (List.hd args3)) i nargsi,
+ compute_rhs bodyi (nargs3 + nargsi + 1))
+ :: !n_lhs_rhs
+ end)
+ lci;
+
+ if !c_lhs = None & !v_lhs = None then i_can't_do_that ();
+
+ (* The Cases predicate is a lambda; we assume no dependency *)
+ let p = match kind_of_term p with
+ | Lambda (_,_,p) -> Termops.pop p
+ | _ -> p
+ in
+
+ { normal_lhs_rhs = List.rev !n_lhs_rhs;
+ variable_lhs = !v_lhs;
+ return_type = p;
+ constants = List.fold_right ConstrSet.add cs ConstrSet.empty;
+ constant_lhs = !c_lhs }
+
+ | _ -> i_can't_do_that ()
+ end
+ |_ -> i_can't_do_that ()
+
+(* TODO for that function:
+\begin{itemize}
+\item handle the case where the return type is an argument of the
+ function
+\item handle the case of simple mutual inductive (for example terms
+ and lists of terms) formulas with the corresponding mutual
+ recursvive interpretation functions.
+\end{itemize}
+*)
+
+(*s Stuff to build variables map, currently implemented as complete
+binary search trees (see file \texttt{Quote.v}) *)
+
+(* First the function to distinghish between constants (closed terms)
+ and variables (open terms) *)
+
+let rec closed_under cset t =
+ (ConstrSet.mem t cset) or
+ (match (kind_of_term t) with
+ | Cast(c,_,_) -> closed_under cset c
+ | App(f,l) -> closed_under cset f && array_for_all (closed_under cset) l
+ | _ -> false)
+
+(*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete
+ binary search tree containing the [ci], that is:
+
+\begin{verbatim}
+ c1
+ / \
+ c2 c3
+ / \
+ c4 c5
+\end{verbatim}
+
+The second argument is a constr (the common type of the [ci])
+*)
+
+let btree_of_array a ty =
+ let size_of_a = Array.length a in
+ let semi_size_of_a = size_of_a lsr 1 in
+ let node = Lazy.force coq_Node_vm
+ and empty = mkApp (Lazy.force coq_Empty_vm, [| ty |]) in
+ let rec aux n =
+ if n > size_of_a
+ then empty
+ else if n > semi_size_of_a
+ then mkApp (node, [| ty; a.(n-1); empty; empty |])
+ else mkApp (node, [| ty; a.(n-1); aux (2*n); aux (2*n+1) |])
+ in
+ aux 1
+
+(*s [btree_of_array] and [path_of_int] verify the following invariant:\\
+ {\tt (varmap\_find A dv }[(path_of_int n)] [(btree_of_array a ty)]
+ = [a.(n)]\\
+ [n] must be [> 0] *)
+
+let path_of_int n =
+ (* returns the list of digits of n in reverse order with
+ initial 1 removed *)
+ let rec digits_of_int n =
+ if n=1 then []
+ else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+ in
+ List.fold_right
+ (fun b c -> mkApp ((if b then Lazy.force coq_Right_idx
+ else Lazy.force coq_Left_idx),
+ [| c |]))
+ (List.rev (digits_of_int n))
+ (Lazy.force coq_End_idx)
+
+(*s The tactic works with a list of subterms sharing the same
+ variables map. We need to sort terms in order to avoid than
+ strange things happen during replacement of terms by their
+ 'abstract' counterparties. *)
+
+(* [subterm t t'] tests if constr [t'] occurs in [t] *)
+(* This function does not descend under binders (lambda and Cases) *)
+
+let rec subterm gl (t : constr) (t' : constr) =
+ (pf_conv_x gl t t') or
+ (match (kind_of_term t) with
+ | App (f,args) -> array_exists (fun t -> subterm gl t t') args
+ | Cast(t,_,_) -> (subterm gl t t')
+ | _ -> false)
+
+(*s We want to sort the list according to reverse subterm order. *)
+(* Since it's a partial order the algoritm of Sort.list won't work !! *)
+
+let rec sort_subterm gl l =
+ let rec insert c = function
+ | [] -> [c]
+ | (h::t as l) when c = h -> l (* Avoid doing the same work twice *)
+ | h::t -> if subterm gl c h then c::h::t else h::(insert c t)
+ in
+ match l with
+ | [] -> []
+ | h::t -> insert h (sort_subterm gl t)
+
+(*s Now we are able to do the inversion itself.
+ We destructurate the term and use an imperative hashtable
+ to store leafs that are already encountered.
+ The type of arguments is:\\
+ [ivs : inversion_scheme]\\
+ [lc: constr list]\\
+ [gl: goal sigma]\\ *)
+
+let quote_terms ivs lc gl =
+ Coqlib.check_required_library ["Coq";"quote";"Quote"];
+ let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+ let varlist = ref ([] : constr list) in (* list of variables *)
+ let counter = ref 1 in (* number of variables created + 1 *)
+ let rec aux c =
+ let rec auxl l =
+ match l with
+ | (lhs, rhs)::tail ->
+ begin try
+ let s1 = matches rhs c in
+ let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1
+ in
+ Termops.subst_meta s2 lhs
+ with PatternMatchingFailure -> auxl tail
+ end
+ | [] ->
+ begin match ivs.variable_lhs with
+ | None ->
+ begin match ivs.constant_lhs with
+ | Some c_lhs -> Termops.subst_meta [1, c] c_lhs
+ | None -> anomaly "invalid inversion scheme for quote"
+ end
+ | Some var_lhs ->
+ begin match ivs.constant_lhs with
+ | Some c_lhs when closed_under ivs.constants c ->
+ Termops.subst_meta [1, c] c_lhs
+ | _ ->
+ begin
+ try Hashtbl.find varhash c
+ with Not_found ->
+ let newvar =
+ Termops.subst_meta [1, (path_of_int !counter)]
+ var_lhs in
+ begin
+ incr counter;
+ varlist := c :: !varlist;
+ Hashtbl.add varhash c newvar;
+ newvar
+ end
+ end
+ end
+ end
+ in
+ auxl ivs.normal_lhs_rhs
+ in
+ let lp = List.map aux lc in
+ (lp, (btree_of_array (Array.of_list (List.rev !varlist))
+ ivs.return_type ))
+
+(*s actually we could "quote" a list of terms instead of a single
+ term. Ring for example needs that, but Ring doesn't use Quote
+ yet. *)
+
+let quote f lid gl =
+ let f = pf_global gl f in
+ let cl = List.map (pf_global gl) lid in
+ let ivs = compute_ivs gl f cl in
+ let (p, vm) = match quote_terms ivs [(pf_concl gl)] gl with
+ | [p], vm -> (p,vm)
+ | _ -> assert false
+ in
+ match ivs.variable_lhs with
+ | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast gl
+ | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast gl
+
+let gen_quote cont c f lid gl =
+ let f = pf_global gl f in
+ let cl = List.map (pf_global gl) lid in
+ let ivs = compute_ivs gl f cl in
+ let (p, vm) = match quote_terms ivs [c] gl with
+ | [p], vm -> (p,vm)
+ | _ -> assert false
+ in
+ match ivs.variable_lhs with
+ | None -> cont (mkApp (f, [| p |])) gl
+ | Some _ -> cont (mkApp (f, [| vm; p |])) gl
+
+(*i
+
+Just testing ...
+
+#use "include.ml";;
+open Quote;;
+
+let r = raw_constr_of_string;;
+
+let ivs = {
+ normal_lhs_rhs =
+ [ r "(f_and ?1 ?2)", r "?1/\?2";
+ r "(f_not ?1)", r "~?1"];
+ variable_lhs = Some (r "(f_atom ?1)");
+ return_type = r "Prop";
+ constants = ConstrSet.empty;
+ constant_lhs = (r "nat")
+};;
+
+let t1 = r "True/\(True /\ ~False)";;
+let t2 = r "True/\~~False";;
+
+quote_term ivs () t1;;
+quote_term ivs () t2;;
+
+let ivs2 =
+ normal_lhs_rhs =
+ [ r "(f_and ?1 ?2)", r "?1/\?2";
+ r "(f_not ?1)", r "~?1"
+ r "True", r "f_true"];
+ variable_lhs = Some (r "(f_atom ?1)");
+ return_type = r "Prop";
+ constants = ConstrSet.empty;
+ constant_lhs = (r "nat")
+
+i*)
diff --git a/plugins/quote/quote_plugin.mllib b/plugins/quote/quote_plugin.mllib
new file mode 100644
index 00000000..d1b3ccbe
--- /dev/null
+++ b/plugins/quote/quote_plugin.mllib
@@ -0,0 +1,3 @@
+Quote
+G_quote
+Quote_plugin_mod
diff --git a/plugins/quote/vo.itarget b/plugins/quote/vo.itarget
new file mode 100644
index 00000000..7a44fc5a
--- /dev/null
+++ b/plugins/quote/vo.itarget
@@ -0,0 +1 @@
+Quote.vo \ No newline at end of file
diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v
new file mode 100644
index 00000000..231b5fbb
--- /dev/null
+++ b/plugins/ring/LegacyArithRing.v
@@ -0,0 +1,90 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* Instantiation of the Ring tactic for the naturals of Arith $*)
+
+Require Import Bool.
+Require Export LegacyRing.
+Require Export Arith.
+Require Import Eqdep_dec.
+
+Open Local Scope nat_scope.
+
+Unboxed Fixpoint nateq (n m:nat) {struct m} : bool :=
+ match n, m with
+ | O, O => true
+ | S n', S m' => nateq n' m'
+ | _, _ => false
+ end.
+
+Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m.
+Proof.
+ simple induction n; simple induction m; intros; try contradiction.
+ trivial.
+ unfold Is_true in H1.
+ rewrite (H n1 H1).
+ trivial.
+Qed.
+
+Hint Resolve nateq_prop: arithring.
+
+Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq.
+ split; intros; auto with arith arithring.
+(* apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
+ trivial.*)
+Defined.
+
+
+Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].
+
+Goal forall n:nat, S n = 1 + n.
+intro; reflexivity.
+Save S_to_plus_one.
+
+(* Replace all occurrences of (S exp) by (plus (S O) exp), except when
+ exp is already O and only for those occurrences than can be reached by going
+ down plus and mult operations *)
+Ltac rewrite_S_to_plus_term t :=
+ match constr:t with
+ | 1 => constr:1
+ | (S ?X1) =>
+ let t1 := rewrite_S_to_plus_term X1 in
+ constr:(1 + t1)
+ | (?X1 + ?X2) =>
+ let t1 := rewrite_S_to_plus_term X1
+ with t2 := rewrite_S_to_plus_term X2 in
+ constr:(t1 + t2)
+ | (?X1 * ?X2) =>
+ let t1 := rewrite_S_to_plus_term X1
+ with t2 := rewrite_S_to_plus_term X2 in
+ constr:(t1 * t2)
+ | _ => constr:t
+ end.
+
+(* Apply S_to_plus on both sides of an equality *)
+Ltac rewrite_S_to_plus :=
+ match goal with
+ | |- (?X1 = ?X2) =>
+ try
+ let t1 :=
+ (**) (**)
+ rewrite_S_to_plus_term X1
+ with t2 := rewrite_S_to_plus_term X2 in
+ change (t1 = t2) in |- *
+ | |- (?X1 = ?X2) =>
+ try
+ let t1 :=
+ (**) (**)
+ rewrite_S_to_plus_term X1
+ with t2 := rewrite_S_to_plus_term X2 in
+ change (t1 = t2) in |- *
+ end.
+
+Ltac ring_nat := rewrite_S_to_plus; ring.
diff --git a/plugins/ring/LegacyNArithRing.v b/plugins/ring/LegacyNArithRing.v
new file mode 100644
index 00000000..ee9fb376
--- /dev/null
+++ b/plugins/ring/LegacyNArithRing.v
@@ -0,0 +1,46 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* Instantiation of the Ring tactic for the binary natural numbers *)
+
+Require Import Bool.
+Require Export LegacyRing.
+Require Export ZArith_base.
+Require Import NArith.
+Require Import Eqdep_dec.
+
+Unboxed Definition Neq (n m:N) :=
+ match (n ?= m)%N with
+ | Datatypes.Eq => true
+ | _ => false
+ end.
+
+Lemma Neq_prop : forall n m:N, Is_true (Neq n m) -> n = m.
+ intros n m H; unfold Neq in H.
+ apply Ncompare_Eq_eq.
+ destruct (n ?= m)%N; [ reflexivity | contradiction | contradiction ].
+Qed.
+
+Definition NTheory : Semi_Ring_Theory Nplus Nmult 1%N 0%N Neq.
+ split.
+ apply Nplus_comm.
+ apply Nplus_assoc.
+ apply Nmult_comm.
+ apply Nmult_assoc.
+ apply Nplus_0_l.
+ apply Nmult_1_l.
+ apply Nmult_0_l.
+ apply Nmult_plus_distr_r.
+(* apply Nplus_reg_l.*)
+ apply Neq_prop.
+Qed.
+
+Add Legacy Semi Ring
+ N Nplus Nmult 1%N 0%N Neq NTheory [ Npos 0%N xO xI 1%positive ].
diff --git a/plugins/ring/LegacyRing.v b/plugins/ring/LegacyRing.v
new file mode 100644
index 00000000..4ae85baf
--- /dev/null
+++ b/plugins/ring/LegacyRing.v
@@ -0,0 +1,37 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Export Bool.
+Require Export LegacyRing_theory.
+Require Export Quote.
+Require Export Ring_normalize.
+Require Export Ring_abstract.
+Declare ML Module "ring_plugin".
+
+(* As an example, we provide an instantation for bool. *)
+(* Other instatiations are given in ArithRing and ZArithRing in the
+ same directory *)
+
+Definition BoolTheory :
+ Ring_Theory xorb andb true false (fun b:bool => b) eqb.
+split; simpl in |- *.
+destruct n; destruct m; reflexivity.
+destruct n; destruct m; destruct p; reflexivity.
+destruct n; destruct m; reflexivity.
+destruct n; destruct m; destruct p; reflexivity.
+destruct n; reflexivity.
+destruct n; reflexivity.
+destruct n; reflexivity.
+destruct n; destruct m; destruct p; reflexivity.
+destruct x; destruct y; reflexivity || simpl in |- *; tauto.
+Defined.
+
+Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
+ [ true false ].
diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v
new file mode 100644
index 00000000..30d29515
--- /dev/null
+++ b/plugins/ring/LegacyRing_theory.v
@@ -0,0 +1,376 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Export Bool.
+
+Set Implicit Arguments.
+
+Section Theory_of_semi_rings.
+
+Variable A : Type.
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+(* There is also a "weakly decidable" equality on A. That means
+ that if (A_eq x y)=true then x=y but x=y can arise when
+ (A_eq x y)=false. On an abstract ring the function [x,y:A]false
+ is a good choice. The proof of A_eq_prop is in this case easy. *)
+Variable Aeq : A -> A -> bool.
+
+Infix "+" := Aplus (at level 50, left associativity).
+Infix "*" := Amult (at level 40, left associativity).
+Notation "0" := Azero.
+Notation "1" := Aone.
+
+Record Semi_Ring_Theory : Prop :=
+ {SR_plus_comm : forall n m:A, n + m = m + n;
+ SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
+ SR_mult_comm : forall n m:A, n * m = m * n;
+ SR_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
+ SR_plus_zero_left : forall n:A, 0 + n = n;
+ SR_mult_one_left : forall n:A, 1 * n = n;
+ SR_mult_zero_left : forall n:A, 0 * n = 0;
+ SR_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
+(* SR_plus_reg_left : forall n m p:A, n + m = n + p -> m = p;*)
+ SR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
+
+Variable T : Semi_Ring_Theory.
+
+Let plus_comm := SR_plus_comm T.
+Let plus_assoc := SR_plus_assoc T.
+Let mult_comm := SR_mult_comm T.
+Let mult_assoc := SR_mult_assoc T.
+Let plus_zero_left := SR_plus_zero_left T.
+Let mult_one_left := SR_mult_one_left T.
+Let mult_zero_left := SR_mult_zero_left T.
+Let distr_left := SR_distr_left T.
+(*Let plus_reg_left := SR_plus_reg_left T.*)
+
+Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
+ mult_one_left mult_zero_left distr_left (*plus_reg_left*).
+
+(* Lemmas whose form is x=y are also provided in form y=x because Auto does
+ not symmetry *)
+Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
+symmetry in |- *; eauto. Qed.
+
+Lemma SR_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
+symmetry in |- *; eauto. Qed.
+
+Lemma SR_plus_zero_left2 : forall n:A, n = 0 + n.
+symmetry in |- *; eauto. Qed.
+
+Lemma SR_mult_one_left2 : forall n:A, n = 1 * n.
+symmetry in |- *; eauto. Qed.
+
+Lemma SR_mult_zero_left2 : forall n:A, 0 = 0 * n.
+symmetry in |- *; eauto. Qed.
+
+Lemma SR_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
+symmetry in |- *; eauto. Qed.
+
+Lemma SR_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
+intros.
+rewrite plus_assoc.
+elim (plus_comm m n).
+rewrite <- plus_assoc.
+reflexivity.
+Qed.
+
+Lemma SR_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
+intros.
+rewrite mult_assoc.
+elim (mult_comm m n).
+rewrite <- mult_assoc.
+reflexivity.
+Qed.
+
+Hint Resolve SR_plus_permute SR_mult_permute.
+
+Lemma SR_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
+intros.
+repeat rewrite (mult_comm n).
+eauto.
+Qed.
+
+Lemma SR_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
+symmetry in |- *; apply SR_distr_right. Qed.
+
+Lemma SR_mult_zero_right : forall n:A, n * 0 = 0.
+intro; rewrite mult_comm; eauto.
+Qed.
+
+Lemma SR_mult_zero_right2 : forall n:A, 0 = n * 0.
+intro; rewrite mult_comm; eauto.
+Qed.
+
+Lemma SR_plus_zero_right : forall n:A, n + 0 = n.
+intro; rewrite plus_comm; eauto.
+Qed.
+Lemma SR_plus_zero_right2 : forall n:A, n = n + 0.
+intro; rewrite plus_comm; eauto.
+Qed.
+
+Lemma SR_mult_one_right : forall n:A, n * 1 = n.
+intro; elim mult_comm; auto.
+Qed.
+
+Lemma SR_mult_one_right2 : forall n:A, n = n * 1.
+intro; elim mult_comm; auto.
+Qed.
+(*
+Lemma SR_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
+intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n); eauto.
+Qed.
+*)
+End Theory_of_semi_rings.
+
+Section Theory_of_rings.
+
+Variable A : Type.
+
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aopp : A -> A.
+Variable Aeq : A -> A -> bool.
+
+Infix "+" := Aplus (at level 50, left associativity).
+Infix "*" := Amult (at level 40, left associativity).
+Notation "0" := Azero.
+Notation "1" := Aone.
+Notation "- x" := (Aopp x).
+
+Record Ring_Theory : Prop :=
+ {Th_plus_comm : forall n m:A, n + m = m + n;
+ Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p;
+ Th_mult_comm : forall n m:A, n * m = m * n;
+ Th_mult_assoc : forall n m p:A, n * (m * p) = n * m * p;
+ Th_plus_zero_left : forall n:A, 0 + n = n;
+ Th_mult_one_left : forall n:A, 1 * n = n;
+ Th_opp_def : forall n:A, n + - n = 0;
+ Th_distr_left : forall n m p:A, (n + m) * p = n * p + m * p;
+ Th_eq_prop : forall x y:A, Is_true (Aeq x y) -> x = y}.
+
+Variable T : Ring_Theory.
+
+Let plus_comm := Th_plus_comm T.
+Let plus_assoc := Th_plus_assoc T.
+Let mult_comm := Th_mult_comm T.
+Let mult_assoc := Th_mult_assoc T.
+Let plus_zero_left := Th_plus_zero_left T.
+Let mult_one_left := Th_mult_one_left T.
+Let opp_def := Th_opp_def T.
+Let distr_left := Th_distr_left T.
+
+Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
+ mult_one_left opp_def distr_left.
+
+(* Lemmas whose form is x=y are also provided in form y=x because Auto does
+ not symmetry *)
+Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p).
+symmetry in |- *; eauto. Qed.
+
+Lemma Th_plus_assoc2 : forall n m p:A, n + m + p = n + (m + p).
+symmetry in |- *; eauto. Qed.
+
+Lemma Th_plus_zero_left2 : forall n:A, n = 0 + n.
+symmetry in |- *; eauto. Qed.
+
+Lemma Th_mult_one_left2 : forall n:A, n = 1 * n.
+symmetry in |- *; eauto. Qed.
+
+Lemma Th_distr_left2 : forall n m p:A, n * p + m * p = (n + m) * p.
+symmetry in |- *; eauto. Qed.
+
+Lemma Th_opp_def2 : forall n:A, 0 = n + - n.
+symmetry in |- *; eauto. Qed.
+
+Lemma Th_plus_permute : forall n m p:A, n + (m + p) = m + (n + p).
+intros.
+rewrite plus_assoc.
+elim (plus_comm m n).
+rewrite <- plus_assoc.
+reflexivity.
+Qed.
+
+Lemma Th_mult_permute : forall n m p:A, n * (m * p) = m * (n * p).
+intros.
+rewrite mult_assoc.
+elim (mult_comm m n).
+rewrite <- mult_assoc.
+reflexivity.
+Qed.
+
+Hint Resolve Th_plus_permute Th_mult_permute.
+
+Lemma aux1 : forall a:A, a + a = a -> a = 0.
+intros.
+generalize (opp_def a).
+pattern a at 1 in |- *.
+rewrite <- H.
+rewrite <- plus_assoc.
+rewrite opp_def.
+elim plus_comm.
+rewrite plus_zero_left.
+trivial.
+Qed.
+
+Lemma Th_mult_zero_left : forall n:A, 0 * n = 0.
+intros.
+apply aux1.
+rewrite <- distr_left.
+rewrite plus_zero_left.
+reflexivity.
+Qed.
+Hint Resolve Th_mult_zero_left.
+
+Lemma Th_mult_zero_left2 : forall n:A, 0 = 0 * n.
+symmetry in |- *; eauto. Qed.
+
+Lemma aux2 : forall x y z:A, x + y = 0 -> x + z = 0 -> y = z.
+intros.
+rewrite <- (plus_zero_left y).
+elim H0.
+elim plus_assoc.
+elim (plus_comm y z).
+rewrite plus_assoc.
+rewrite H.
+rewrite plus_zero_left.
+reflexivity.
+Qed.
+
+Lemma Th_opp_mult_left : forall x y:A, - (x * y) = - x * y.
+intros.
+apply (aux2 (x:=(x * y)));
+ [ apply opp_def | rewrite <- distr_left; rewrite opp_def; auto ].
+Qed.
+Hint Resolve Th_opp_mult_left.
+
+Lemma Th_opp_mult_left2 : forall x y:A, - x * y = - (x * y).
+symmetry in |- *; eauto. Qed.
+
+Lemma Th_mult_zero_right : forall n:A, n * 0 = 0.
+intro; elim mult_comm; eauto.
+Qed.
+
+Lemma Th_mult_zero_right2 : forall n:A, 0 = n * 0.
+intro; elim mult_comm; eauto.
+Qed.
+
+Lemma Th_plus_zero_right : forall n:A, n + 0 = n.
+intro; rewrite plus_comm; eauto.
+Qed.
+
+Lemma Th_plus_zero_right2 : forall n:A, n = n + 0.
+intro; rewrite plus_comm; eauto.
+Qed.
+
+Lemma Th_mult_one_right : forall n:A, n * 1 = n.
+intro; elim mult_comm; eauto.
+Qed.
+
+Lemma Th_mult_one_right2 : forall n:A, n = n * 1.
+intro; elim mult_comm; eauto.
+Qed.
+
+Lemma Th_opp_mult_right : forall x y:A, - (x * y) = x * - y.
+intros; do 2 rewrite (mult_comm x); auto.
+Qed.
+
+Lemma Th_opp_mult_right2 : forall x y:A, x * - y = - (x * y).
+intros; do 2 rewrite (mult_comm x); auto.
+Qed.
+
+Lemma Th_plus_opp_opp : forall x y:A, - x + - y = - (x + y).
+intros.
+apply (aux2 (x:=(x + y)));
+ [ elim plus_assoc; rewrite (Th_plus_permute y (- x)); rewrite plus_assoc;
+ rewrite opp_def; rewrite plus_zero_left; auto
+ | auto ].
+Qed.
+
+Lemma Th_plus_permute_opp : forall n m p:A, - m + (n + p) = n + (- m + p).
+eauto. Qed.
+
+Lemma Th_opp_opp : forall n:A, - - n = n.
+intro; apply (aux2 (x:=(- n))); [ auto | elim plus_comm; auto ].
+Qed.
+Hint Resolve Th_opp_opp.
+
+Lemma Th_opp_opp2 : forall n:A, n = - - n.
+symmetry in |- *; eauto. Qed.
+
+Lemma Th_mult_opp_opp : forall x y:A, - x * - y = x * y.
+intros; rewrite <- Th_opp_mult_left; rewrite <- Th_opp_mult_right; auto.
+Qed.
+
+Lemma Th_mult_opp_opp2 : forall x y:A, x * y = - x * - y.
+symmetry in |- *; apply Th_mult_opp_opp. Qed.
+
+Lemma Th_opp_zero : - 0 = 0.
+rewrite <- (plus_zero_left (- 0)).
+auto. Qed.
+(*
+Lemma Th_plus_reg_left : forall n m p:A, n + m = n + p -> m = p.
+intros; generalize (f_equal (fun z => - n + z) H).
+repeat rewrite plus_assoc.
+rewrite (plus_comm (- n) n).
+rewrite opp_def.
+repeat rewrite Th_plus_zero_left; eauto.
+Qed.
+
+Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p.
+intros.
+eapply Th_plus_reg_left with n.
+rewrite (plus_comm n m).
+rewrite (plus_comm n p).
+auto.
+Qed.
+*)
+Lemma Th_distr_right : forall n m p:A, n * (m + p) = n * m + n * p.
+intros.
+repeat rewrite (mult_comm n).
+eauto.
+Qed.
+
+Lemma Th_distr_right2 : forall n m p:A, n * m + n * p = n * (m + p).
+symmetry in |- *; apply Th_distr_right.
+Qed.
+
+End Theory_of_rings.
+
+Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core.
+
+Unset Implicit Arguments.
+
+Definition Semi_Ring_Theory_of :
+ forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A)
+ (Aopp:A -> A) (Aeq:A -> A -> bool),
+ Ring_Theory Aplus Amult Aone Azero Aopp Aeq ->
+ Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
+intros until 1; case H.
+split; intros; simpl in |- *; eauto.
+Defined.
+
+(* Every ring can be viewed as a semi-ring : this property will be used
+ in Abstract_polynom. *)
+Coercion Semi_Ring_Theory_of : Ring_Theory >-> Semi_Ring_Theory.
+
+
+Section product_ring.
+
+End product_ring.
+
+Section power_ring.
+
+End power_ring.
diff --git a/plugins/ring/LegacyZArithRing.v b/plugins/ring/LegacyZArithRing.v
new file mode 100644
index 00000000..68a0dd27
--- /dev/null
+++ b/plugins/ring/LegacyZArithRing.v
@@ -0,0 +1,37 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* Instantiation of the Ring tactic for the binary integers of ZArith *)
+
+Require Export LegacyArithRing.
+Require Export ZArith_base.
+Require Import Eqdep_dec.
+Require Import LegacyRing.
+
+Unboxed Definition Zeq (x y:Z) :=
+ match (x ?= y)%Z with
+ | Datatypes.Eq => true
+ | _ => false
+ end.
+
+Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y.
+ intros x y H; unfold Zeq in H.
+ apply Zcompare_Eq_eq.
+ destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ].
+Qed.
+
+Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq.
+ split; intros; eauto with zarith.
+ apply Zeq_prop; assumption.
+Qed.
+
+(* NatConstants and NatTheory are defined in Ring_theory.v *)
+Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory
+ [ Zpos Zneg 0%Z xO xI 1%positive ].
diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v
new file mode 100644
index 00000000..2a9df21b
--- /dev/null
+++ b/plugins/ring/Ring_abstract.v
@@ -0,0 +1,706 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Import LegacyRing_theory.
+Require Import Quote.
+Require Import Ring_normalize.
+
+Unset Boxed Definitions.
+
+Section abstract_semi_rings.
+
+Inductive aspolynomial : Type :=
+ | ASPvar : index -> aspolynomial
+ | ASP0 : aspolynomial
+ | ASP1 : aspolynomial
+ | ASPplus : aspolynomial -> aspolynomial -> aspolynomial
+ | ASPmult : aspolynomial -> aspolynomial -> aspolynomial.
+
+Inductive abstract_sum : Type :=
+ | Nil_acs : abstract_sum
+ | Cons_acs : varlist -> abstract_sum -> abstract_sum.
+
+Fixpoint abstract_sum_merge (s1:abstract_sum) :
+ abstract_sum -> abstract_sum :=
+ match s1 with
+ | Cons_acs l1 t1 =>
+ (fix asm_aux (s2:abstract_sum) : abstract_sum :=
+ match s2 with
+ | Cons_acs l2 t2 =>
+ if varlist_lt l1 l2
+ then Cons_acs l1 (abstract_sum_merge t1 s2)
+ else Cons_acs l2 (asm_aux t2)
+ | Nil_acs => s1
+ end)
+ | Nil_acs => fun s2 => s2
+ end.
+
+Fixpoint abstract_varlist_insert (l1:varlist) (s2:abstract_sum) {struct s2} :
+ abstract_sum :=
+ match s2 with
+ | Cons_acs l2 t2 =>
+ if varlist_lt l1 l2
+ then Cons_acs l1 s2
+ else Cons_acs l2 (abstract_varlist_insert l1 t2)
+ | Nil_acs => Cons_acs l1 Nil_acs
+ end.
+
+Fixpoint abstract_sum_scalar (l1:varlist) (s2:abstract_sum) {struct s2} :
+ abstract_sum :=
+ match s2 with
+ | Cons_acs l2 t2 =>
+ abstract_varlist_insert (varlist_merge l1 l2)
+ (abstract_sum_scalar l1 t2)
+ | Nil_acs => Nil_acs
+ end.
+
+Fixpoint abstract_sum_prod (s1 s2:abstract_sum) {struct s1} : abstract_sum :=
+ match s1 with
+ | Cons_acs l1 t1 =>
+ abstract_sum_merge (abstract_sum_scalar l1 s2)
+ (abstract_sum_prod t1 s2)
+ | Nil_acs => Nil_acs
+ end.
+
+Fixpoint aspolynomial_normalize (p:aspolynomial) : abstract_sum :=
+ match p with
+ | ASPvar i => Cons_acs (Cons_var i Nil_var) Nil_acs
+ | ASP1 => Cons_acs Nil_var Nil_acs
+ | ASP0 => Nil_acs
+ | ASPplus l r =>
+ abstract_sum_merge (aspolynomial_normalize l)
+ (aspolynomial_normalize r)
+ | ASPmult l r =>
+ abstract_sum_prod (aspolynomial_normalize l) (aspolynomial_normalize r)
+ end.
+
+
+
+Variable A : Type.
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aeq : A -> A -> bool.
+Variable vm : varmap A.
+Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
+
+Fixpoint interp_asp (p:aspolynomial) : A :=
+ match p with
+ | ASPvar i => interp_var Azero vm i
+ | ASP0 => Azero
+ | ASP1 => Aone
+ | ASPplus l r => Aplus (interp_asp l) (interp_asp r)
+ | ASPmult l r => Amult (interp_asp l) (interp_asp r)
+ end.
+
+(* Local *) Definition iacs_aux :=
+ (fix iacs_aux (a:A) (s:abstract_sum) {struct s} : A :=
+ match s with
+ | Nil_acs => a
+ | Cons_acs l t =>
+ Aplus a (iacs_aux (interp_vl Amult Aone Azero vm l) t)
+ end).
+
+Definition interp_acs (s:abstract_sum) : A :=
+ match s with
+ | Cons_acs l t => iacs_aux (interp_vl Amult Aone Azero vm l) t
+ | Nil_acs => Azero
+ end.
+
+Hint Resolve (SR_plus_comm T).
+Hint Resolve (SR_plus_assoc T).
+Hint Resolve (SR_plus_assoc2 T).
+Hint Resolve (SR_mult_comm T).
+Hint Resolve (SR_mult_assoc T).
+Hint Resolve (SR_mult_assoc2 T).
+Hint Resolve (SR_plus_zero_left T).
+Hint Resolve (SR_plus_zero_left2 T).
+Hint Resolve (SR_mult_one_left T).
+Hint Resolve (SR_mult_one_left2 T).
+Hint Resolve (SR_mult_zero_left T).
+Hint Resolve (SR_mult_zero_left2 T).
+Hint Resolve (SR_distr_left T).
+Hint Resolve (SR_distr_left2 T).
+(*Hint Resolve (SR_plus_reg_left T).*)
+Hint Resolve (SR_plus_permute T).
+Hint Resolve (SR_mult_permute T).
+Hint Resolve (SR_distr_right T).
+Hint Resolve (SR_distr_right2 T).
+Hint Resolve (SR_mult_zero_right T).
+Hint Resolve (SR_mult_zero_right2 T).
+Hint Resolve (SR_plus_zero_right T).
+Hint Resolve (SR_plus_zero_right2 T).
+Hint Resolve (SR_mult_one_right T).
+Hint Resolve (SR_mult_one_right2 T).
+(*Hint Resolve (SR_plus_reg_right T).*)
+Hint Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+Remark iacs_aux_ok :
+ forall (x:A) (s:abstract_sum), iacs_aux x s = Aplus x (interp_acs s).
+Proof.
+ simple induction s; simpl in |- *; intros.
+ trivial.
+ reflexivity.
+Qed.
+
+Hint Extern 10 (_ = _ :>A) => rewrite iacs_aux_ok: core.
+
+Lemma abstract_varlist_insert_ok :
+ forall (l:varlist) (s:abstract_sum),
+ interp_acs (abstract_varlist_insert l s) =
+ Aplus (interp_vl Amult Aone Azero vm l) (interp_acs s).
+
+ simple induction s.
+ trivial.
+
+ simpl in |- *; intros.
+ elim (varlist_lt l v); simpl in |- *.
+ eauto.
+ rewrite iacs_aux_ok.
+ rewrite H; auto.
+
+Qed.
+
+Lemma abstract_sum_merge_ok :
+ forall x y:abstract_sum,
+ interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y).
+
+Proof.
+ simple induction x.
+ trivial.
+ simple induction y; intros.
+
+ auto.
+
+ simpl in |- *; elim (varlist_lt v v0); simpl in |- *.
+ repeat rewrite iacs_aux_ok.
+ rewrite H; simpl in |- *; auto.
+
+ simpl in H0.
+ repeat rewrite iacs_aux_ok.
+ rewrite H0. simpl in |- *; auto.
+Qed.
+
+Lemma abstract_sum_scalar_ok :
+ forall (l:varlist) (s:abstract_sum),
+ interp_acs (abstract_sum_scalar l s) =
+ Amult (interp_vl Amult Aone Azero vm l) (interp_acs s).
+Proof.
+ simple induction s.
+ simpl in |- *; eauto.
+
+ simpl in |- *; intros.
+ rewrite iacs_aux_ok.
+ rewrite abstract_varlist_insert_ok.
+ rewrite H.
+ rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+ auto.
+Qed.
+
+Lemma abstract_sum_prod_ok :
+ forall x y:abstract_sum,
+ interp_acs (abstract_sum_prod x y) = Amult (interp_acs x) (interp_acs y).
+
+Proof.
+ simple induction x.
+ intros; simpl in |- *; eauto.
+
+ destruct y as [| v0 a0]; intros.
+
+ simpl in |- *; rewrite H; eauto.
+
+ unfold abstract_sum_prod in |- *; fold abstract_sum_prod in |- *.
+ rewrite abstract_sum_merge_ok.
+ rewrite abstract_sum_scalar_ok.
+ rewrite H; simpl in |- *; auto.
+Qed.
+
+Theorem aspolynomial_normalize_ok :
+ forall x:aspolynomial, interp_asp x = interp_acs (aspolynomial_normalize x).
+Proof.
+ simple induction x; simpl in |- *; intros; trivial.
+ rewrite abstract_sum_merge_ok.
+ rewrite H; rewrite H0; eauto.
+ rewrite abstract_sum_prod_ok.
+ rewrite H; rewrite H0; eauto.
+Qed.
+
+End abstract_semi_rings.
+
+Section abstract_rings.
+
+(* In abstract polynomials there is no constants other
+ than 0 and 1. An abstract ring is a ring whose operations plus,
+ and mult are not functions but constructors. In other words,
+ when c1 and c2 are closed, (plus c1 c2) doesn't reduce to a closed
+ term. "closed" mean here "without plus and mult". *)
+
+(* this section is not parametrized by a (semi-)ring.
+ Nevertheless, they are two different types for semi-rings and rings
+ and there will be 2 correction theorems *)
+
+Inductive apolynomial : Type :=
+ | APvar : index -> apolynomial
+ | AP0 : apolynomial
+ | AP1 : apolynomial
+ | APplus : apolynomial -> apolynomial -> apolynomial
+ | APmult : apolynomial -> apolynomial -> apolynomial
+ | APopp : apolynomial -> apolynomial.
+
+(* A canonical "abstract" sum is a list of varlist with the sign "+" or "-".
+ Invariant : the list is sorted and there is no varlist is present
+ with both signs. +x +x +x -x is forbidden => the canonical form is +x+x *)
+
+Inductive signed_sum : Type :=
+ | Nil_varlist : signed_sum
+ | Plus_varlist : varlist -> signed_sum -> signed_sum
+ | Minus_varlist : varlist -> signed_sum -> signed_sum.
+
+Fixpoint signed_sum_merge (s1:signed_sum) : signed_sum -> signed_sum :=
+ match s1 with
+ | Plus_varlist l1 t1 =>
+ (fix ssm_aux (s2:signed_sum) : signed_sum :=
+ match s2 with
+ | Plus_varlist l2 t2 =>
+ if varlist_lt l1 l2
+ then Plus_varlist l1 (signed_sum_merge t1 s2)
+ else Plus_varlist l2 (ssm_aux t2)
+ | Minus_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then signed_sum_merge t1 t2
+ else
+ if varlist_lt l1 l2
+ then Plus_varlist l1 (signed_sum_merge t1 s2)
+ else Minus_varlist l2 (ssm_aux t2)
+ | Nil_varlist => s1
+ end)
+ | Minus_varlist l1 t1 =>
+ (fix ssm_aux2 (s2:signed_sum) : signed_sum :=
+ match s2 with
+ | Plus_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then signed_sum_merge t1 t2
+ else
+ if varlist_lt l1 l2
+ then Minus_varlist l1 (signed_sum_merge t1 s2)
+ else Plus_varlist l2 (ssm_aux2 t2)
+ | Minus_varlist l2 t2 =>
+ if varlist_lt l1 l2
+ then Minus_varlist l1 (signed_sum_merge t1 s2)
+ else Minus_varlist l2 (ssm_aux2 t2)
+ | Nil_varlist => s1
+ end)
+ | Nil_varlist => fun s2 => s2
+ end.
+
+Fixpoint plus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
+ signed_sum :=
+ match s2 with
+ | Plus_varlist l2 t2 =>
+ if varlist_lt l1 l2
+ then Plus_varlist l1 s2
+ else Plus_varlist l2 (plus_varlist_insert l1 t2)
+ | Minus_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then t2
+ else
+ if varlist_lt l1 l2
+ then Plus_varlist l1 s2
+ else Minus_varlist l2 (plus_varlist_insert l1 t2)
+ | Nil_varlist => Plus_varlist l1 Nil_varlist
+ end.
+
+Fixpoint minus_varlist_insert (l1:varlist) (s2:signed_sum) {struct s2} :
+ signed_sum :=
+ match s2 with
+ | Plus_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then t2
+ else
+ if varlist_lt l1 l2
+ then Minus_varlist l1 s2
+ else Plus_varlist l2 (minus_varlist_insert l1 t2)
+ | Minus_varlist l2 t2 =>
+ if varlist_lt l1 l2
+ then Minus_varlist l1 s2
+ else Minus_varlist l2 (minus_varlist_insert l1 t2)
+ | Nil_varlist => Minus_varlist l1 Nil_varlist
+ end.
+
+Fixpoint signed_sum_opp (s:signed_sum) : signed_sum :=
+ match s with
+ | Plus_varlist l2 t2 => Minus_varlist l2 (signed_sum_opp t2)
+ | Minus_varlist l2 t2 => Plus_varlist l2 (signed_sum_opp t2)
+ | Nil_varlist => Nil_varlist
+ end.
+
+
+Fixpoint plus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
+ signed_sum :=
+ match s2 with
+ | Plus_varlist l2 t2 =>
+ plus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
+ | Minus_varlist l2 t2 =>
+ minus_varlist_insert (varlist_merge l1 l2) (plus_sum_scalar l1 t2)
+ | Nil_varlist => Nil_varlist
+ end.
+
+Fixpoint minus_sum_scalar (l1:varlist) (s2:signed_sum) {struct s2} :
+ signed_sum :=
+ match s2 with
+ | Plus_varlist l2 t2 =>
+ minus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
+ | Minus_varlist l2 t2 =>
+ plus_varlist_insert (varlist_merge l1 l2) (minus_sum_scalar l1 t2)
+ | Nil_varlist => Nil_varlist
+ end.
+
+Fixpoint signed_sum_prod (s1 s2:signed_sum) {struct s1} : signed_sum :=
+ match s1 with
+ | Plus_varlist l1 t1 =>
+ signed_sum_merge (plus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
+ | Minus_varlist l1 t1 =>
+ signed_sum_merge (minus_sum_scalar l1 s2) (signed_sum_prod t1 s2)
+ | Nil_varlist => Nil_varlist
+ end.
+
+Fixpoint apolynomial_normalize (p:apolynomial) : signed_sum :=
+ match p with
+ | APvar i => Plus_varlist (Cons_var i Nil_var) Nil_varlist
+ | AP1 => Plus_varlist Nil_var Nil_varlist
+ | AP0 => Nil_varlist
+ | APplus l r =>
+ signed_sum_merge (apolynomial_normalize l) (apolynomial_normalize r)
+ | APmult l r =>
+ signed_sum_prod (apolynomial_normalize l) (apolynomial_normalize r)
+ | APopp q => signed_sum_opp (apolynomial_normalize q)
+ end.
+
+
+Variable A : Type.
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aopp : A -> A.
+Variable Aeq : A -> A -> bool.
+Variable vm : varmap A.
+Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
+
+(* Local *) Definition isacs_aux :=
+ (fix isacs_aux (a:A) (s:signed_sum) {struct s} : A :=
+ match s with
+ | Nil_varlist => a
+ | Plus_varlist l t =>
+ Aplus a (isacs_aux (interp_vl Amult Aone Azero vm l) t)
+ | Minus_varlist l t =>
+ Aplus a
+ (isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t)
+ end).
+
+Definition interp_sacs (s:signed_sum) : A :=
+ match s with
+ | Plus_varlist l t => isacs_aux (interp_vl Amult Aone Azero vm l) t
+ | Minus_varlist l t => isacs_aux (Aopp (interp_vl Amult Aone Azero vm l)) t
+ | Nil_varlist => Azero
+ end.
+
+Fixpoint interp_ap (p:apolynomial) : A :=
+ match p with
+ | APvar i => interp_var Azero vm i
+ | AP0 => Azero
+ | AP1 => Aone
+ | APplus l r => Aplus (interp_ap l) (interp_ap r)
+ | APmult l r => Amult (interp_ap l) (interp_ap r)
+ | APopp q => Aopp (interp_ap q)
+ end.
+
+Hint Resolve (Th_plus_comm T).
+Hint Resolve (Th_plus_assoc T).
+Hint Resolve (Th_plus_assoc2 T).
+Hint Resolve (Th_mult_comm T).
+Hint Resolve (Th_mult_assoc T).
+Hint Resolve (Th_mult_assoc2 T).
+Hint Resolve (Th_plus_zero_left T).
+Hint Resolve (Th_plus_zero_left2 T).
+Hint Resolve (Th_mult_one_left T).
+Hint Resolve (Th_mult_one_left2 T).
+Hint Resolve (Th_mult_zero_left T).
+Hint Resolve (Th_mult_zero_left2 T).
+Hint Resolve (Th_distr_left T).
+Hint Resolve (Th_distr_left2 T).
+(*Hint Resolve (Th_plus_reg_left T).*)
+Hint Resolve (Th_plus_permute T).
+Hint Resolve (Th_mult_permute T).
+Hint Resolve (Th_distr_right T).
+Hint Resolve (Th_distr_right2 T).
+Hint Resolve (Th_mult_zero_right2 T).
+Hint Resolve (Th_plus_zero_right T).
+Hint Resolve (Th_plus_zero_right2 T).
+Hint Resolve (Th_mult_one_right T).
+Hint Resolve (Th_mult_one_right2 T).
+(*Hint Resolve (Th_plus_reg_right T).*)
+Hint Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+Lemma isacs_aux_ok :
+ forall (x:A) (s:signed_sum), isacs_aux x s = Aplus x (interp_sacs s).
+Proof.
+ simple induction s; simpl in |- *; intros.
+ trivial.
+ reflexivity.
+ reflexivity.
+Qed.
+
+Hint Extern 10 (_ = _ :>A) => rewrite isacs_aux_ok: core.
+
+Ltac solve1 v v0 H H0 :=
+ simpl in |- *; elim (varlist_lt v v0); simpl in |- *; rewrite isacs_aux_ok;
+ [ rewrite H; simpl in |- *; auto | simpl in H0; rewrite H0; auto ].
+
+Lemma signed_sum_merge_ok :
+ forall x y:signed_sum,
+ interp_sacs (signed_sum_merge x y) = Aplus (interp_sacs x) (interp_sacs y).
+
+ simple induction x.
+ intro; simpl in |- *; auto.
+
+ simple induction y; intros.
+
+ auto.
+
+ solve1 v v0 H H0.
+
+ simpl in |- *; generalize (varlist_eq_prop v v0).
+ elim (varlist_eq v v0); simpl in |- *.
+
+ intro Heq; rewrite (Heq I).
+ rewrite H.
+ repeat rewrite isacs_aux_ok.
+ rewrite (Th_plus_permute T).
+ repeat rewrite (Th_plus_assoc T).
+ rewrite
+ (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0))
+ (interp_vl Amult Aone Azero vm v0)).
+ rewrite (Th_opp_def T).
+ rewrite (Th_plus_zero_left T).
+ reflexivity.
+
+ solve1 v v0 H H0.
+
+ simple induction y; intros.
+
+ auto.
+
+ simpl in |- *; generalize (varlist_eq_prop v v0).
+ elim (varlist_eq v v0); simpl in |- *.
+
+ intro Heq; rewrite (Heq I).
+ rewrite H.
+ repeat rewrite isacs_aux_ok.
+ rewrite (Th_plus_permute T).
+ repeat rewrite (Th_plus_assoc T).
+ rewrite (Th_opp_def T).
+ rewrite (Th_plus_zero_left T).
+ reflexivity.
+
+ solve1 v v0 H H0.
+
+ solve1 v v0 H H0.
+
+Qed.
+
+Ltac solve2 l v H :=
+ elim (varlist_lt l v); simpl in |- *; rewrite isacs_aux_ok;
+ [ auto | rewrite H; auto ].
+
+Lemma plus_varlist_insert_ok :
+ forall (l:varlist) (s:signed_sum),
+ interp_sacs (plus_varlist_insert l s) =
+ Aplus (interp_vl Amult Aone Azero vm l) (interp_sacs s).
+Proof.
+
+ simple induction s.
+ trivial.
+
+ simpl in |- *; intros.
+ solve2 l v H.
+
+ simpl in |- *; intros.
+ generalize (varlist_eq_prop l v).
+ elim (varlist_eq l v); simpl in |- *.
+
+ intro Heq; rewrite (Heq I).
+ repeat rewrite isacs_aux_ok.
+ repeat rewrite (Th_plus_assoc T).
+ rewrite (Th_opp_def T).
+ rewrite (Th_plus_zero_left T).
+ reflexivity.
+
+ solve2 l v H.
+
+Qed.
+
+Lemma minus_varlist_insert_ok :
+ forall (l:varlist) (s:signed_sum),
+ interp_sacs (minus_varlist_insert l s) =
+ Aplus (Aopp (interp_vl Amult Aone Azero vm l)) (interp_sacs s).
+Proof.
+
+ simple induction s.
+ trivial.
+
+ simpl in |- *; intros.
+ generalize (varlist_eq_prop l v).
+ elim (varlist_eq l v); simpl in |- *.
+
+ intro Heq; rewrite (Heq I).
+ repeat rewrite isacs_aux_ok.
+ repeat rewrite (Th_plus_assoc T).
+ rewrite
+ (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v))
+ (interp_vl Amult Aone Azero vm v)).
+ rewrite (Th_opp_def T).
+ auto.
+
+ simpl in |- *; intros.
+ solve2 l v H.
+
+ simpl in |- *; intros; solve2 l v H.
+
+Qed.
+
+Lemma signed_sum_opp_ok :
+ forall s:signed_sum, interp_sacs (signed_sum_opp s) = Aopp (interp_sacs s).
+Proof.
+
+ simple induction s; simpl in |- *; intros.
+
+ symmetry in |- *; apply (Th_opp_zero T).
+
+ repeat rewrite isacs_aux_ok.
+ rewrite H.
+ rewrite (Th_plus_opp_opp T).
+ reflexivity.
+
+ repeat rewrite isacs_aux_ok.
+ rewrite H.
+ rewrite <- (Th_plus_opp_opp T).
+ rewrite (Th_opp_opp T).
+ reflexivity.
+
+Qed.
+
+Lemma plus_sum_scalar_ok :
+ forall (l:varlist) (s:signed_sum),
+ interp_sacs (plus_sum_scalar l s) =
+ Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s).
+Proof.
+
+ simple induction s.
+ trivial.
+
+ simpl in |- *; intros.
+ rewrite plus_varlist_insert_ok.
+ rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+ repeat rewrite isacs_aux_ok.
+ rewrite H.
+ auto.
+
+ simpl in |- *; intros.
+ rewrite minus_varlist_insert_ok.
+ repeat rewrite isacs_aux_ok.
+ rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+ rewrite H.
+ rewrite (Th_distr_right T).
+ rewrite <- (Th_opp_mult_right T).
+ reflexivity.
+
+Qed.
+
+Lemma minus_sum_scalar_ok :
+ forall (l:varlist) (s:signed_sum),
+ interp_sacs (minus_sum_scalar l s) =
+ Aopp (Amult (interp_vl Amult Aone Azero vm l) (interp_sacs s)).
+Proof.
+
+ simple induction s; simpl in |- *; intros.
+
+ rewrite (Th_mult_zero_right T); symmetry in |- *; apply (Th_opp_zero T).
+
+ simpl in |- *; intros.
+ rewrite minus_varlist_insert_ok.
+ rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+ repeat rewrite isacs_aux_ok.
+ rewrite H.
+ rewrite (Th_distr_right T).
+ rewrite (Th_plus_opp_opp T).
+ reflexivity.
+
+ simpl in |- *; intros.
+ rewrite plus_varlist_insert_ok.
+ repeat rewrite isacs_aux_ok.
+ rewrite (varlist_merge_ok A Aplus Amult Aone Azero Aeq vm T).
+ rewrite H.
+ rewrite (Th_distr_right T).
+ rewrite <- (Th_opp_mult_right T).
+ rewrite <- (Th_plus_opp_opp T).
+ rewrite (Th_opp_opp T).
+ reflexivity.
+
+Qed.
+
+Lemma signed_sum_prod_ok :
+ forall x y:signed_sum,
+ interp_sacs (signed_sum_prod x y) = Amult (interp_sacs x) (interp_sacs y).
+Proof.
+
+ simple induction x.
+
+ simpl in |- *; eauto 1.
+
+ intros; simpl in |- *.
+ rewrite signed_sum_merge_ok.
+ rewrite plus_sum_scalar_ok.
+ repeat rewrite isacs_aux_ok.
+ rewrite H.
+ auto.
+
+ intros; simpl in |- *.
+ repeat rewrite isacs_aux_ok.
+ rewrite signed_sum_merge_ok.
+ rewrite minus_sum_scalar_ok.
+ rewrite H.
+ rewrite (Th_distr_left T).
+ rewrite (Th_opp_mult_left T).
+ reflexivity.
+
+Qed.
+
+Theorem apolynomial_normalize_ok :
+ forall p:apolynomial, interp_sacs (apolynomial_normalize p) = interp_ap p.
+Proof.
+ simple induction p; simpl in |- *; auto 1.
+ intros.
+ rewrite signed_sum_merge_ok.
+ rewrite H; rewrite H0; reflexivity.
+ intros.
+ rewrite signed_sum_prod_ok.
+ rewrite H; rewrite H0; reflexivity.
+ intros.
+ rewrite signed_sum_opp_ok.
+ rewrite H; reflexivity.
+Qed.
+
+End abstract_rings.
diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v
new file mode 100644
index 00000000..7aeee218
--- /dev/null
+++ b/plugins/ring/Ring_normalize.v
@@ -0,0 +1,902 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Import LegacyRing_theory.
+Require Import Quote.
+
+Set Implicit Arguments.
+Unset Boxed Definitions.
+
+Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
+Proof.
+ intros.
+ apply index_eq_prop.
+ generalize H.
+ case (index_eq n m); simpl in |- *; trivial; intros.
+ contradiction.
+Qed.
+
+Section semi_rings.
+
+Variable A : Type.
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aeq : A -> A -> bool.
+
+(* Section definitions. *)
+
+
+(******************************************)
+(* Normal abtract Polynomials *)
+(******************************************)
+(* DEFINITIONS :
+- A varlist is a sorted product of one or more variables : x, x*y*z
+- A monom is a constant, a varlist or the product of a constant by a varlist
+ variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
+- A canonical sum is either a monom or an ordered sum of monoms
+ (the order on monoms is defined later)
+- A normal polynomial it either a constant or a canonical sum or a constant
+ plus a canonical sum
+*)
+
+(* varlist is isomorphic to (list var), but we built a special inductive
+ for efficiency *)
+Inductive varlist : Type :=
+ | Nil_var : varlist
+ | Cons_var : index -> varlist -> varlist.
+
+Inductive canonical_sum : Type :=
+ | Nil_monom : canonical_sum
+ | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
+ | Cons_varlist : varlist -> canonical_sum -> canonical_sum.
+
+(* Order on monoms *)
+
+(* That's the lexicographic order on varlist, extended by :
+ - A constant is less than every monom
+ - The relation between two varlist is preserved by multiplication by a
+ constant.
+
+ Examples :
+ 3 < x < y
+ x*y < x*y*y*z
+ 2*x*y < x*y*y*z
+ x*y < 54*x*y*y*z
+ 4*x*y < 59*x*y*y*z
+*)
+
+Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
+ match x, y with
+ | Nil_var, Nil_var => true
+ | Cons_var i xrest, Cons_var j yrest =>
+ andb (index_eq i j) (varlist_eq xrest yrest)
+ | _, _ => false
+ end.
+
+Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
+ match x, y with
+ | Nil_var, Cons_var _ _ => true
+ | Cons_var i xrest, Cons_var j yrest =>
+ if index_lt i j
+ then true
+ else andb (index_eq i j) (varlist_lt xrest yrest)
+ | _, _ => false
+ end.
+
+(* merges two variables lists *)
+Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
+ match l1 with
+ | Cons_var v1 t1 =>
+ (fix vm_aux (l2:varlist) : varlist :=
+ match l2 with
+ | Cons_var v2 t2 =>
+ if index_lt v1 v2
+ then Cons_var v1 (varlist_merge t1 l2)
+ else Cons_var v2 (vm_aux t2)
+ | Nil_var => l1
+ end)
+ | Nil_var => fun l2 => l2
+ end.
+
+(* returns the sum of two canonical sums *)
+Fixpoint canonical_sum_merge (s1:canonical_sum) :
+ canonical_sum -> canonical_sum :=
+ match s1 with
+ | Cons_monom c1 l1 t1 =>
+ (fix csm_aux (s2:canonical_sum) : canonical_sum :=
+ match s2 with
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
+ else
+ if varlist_lt l1 l2
+ then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
+ else Cons_monom c2 l2 (csm_aux t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
+ else
+ if varlist_lt l1 l2
+ then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
+ else Cons_varlist l2 (csm_aux t2)
+ | Nil_monom => s1
+ end)
+ | Cons_varlist l1 t1 =>
+ (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
+ match s2 with
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
+ else
+ if varlist_lt l1 l2
+ then Cons_varlist l1 (canonical_sum_merge t1 s2)
+ else Cons_monom c2 l2 (csm_aux2 t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
+ else
+ if varlist_lt l1 l2
+ then Cons_varlist l1 (canonical_sum_merge t1 s2)
+ else Cons_varlist l2 (csm_aux2 t2)
+ | Nil_monom => s1
+ end)
+ | Nil_monom => fun s2 => s2
+ end.
+
+(* Insertion of a monom in a canonical sum *)
+Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
+ canonical_sum :=
+ match s2 with
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus c1 c2) l1 t2
+ else
+ if varlist_lt l1 l2
+ then Cons_monom c1 l1 s2
+ else Cons_monom c2 l2 (monom_insert c1 l1 t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus c1 Aone) l1 t2
+ else
+ if varlist_lt l1 l2
+ then Cons_monom c1 l1 s2
+ else Cons_varlist l2 (monom_insert c1 l1 t2)
+ | Nil_monom => Cons_monom c1 l1 Nil_monom
+ end.
+
+Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
+ canonical_sum :=
+ match s2 with
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus Aone c2) l1 t2
+ else
+ if varlist_lt l1 l2
+ then Cons_varlist l1 s2
+ else Cons_monom c2 l2 (varlist_insert l1 t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus Aone Aone) l1 t2
+ else
+ if varlist_lt l1 l2
+ then Cons_varlist l1 s2
+ else Cons_varlist l2 (varlist_insert l1 t2)
+ | Nil_monom => Cons_varlist l1 Nil_monom
+ end.
+
+(* Computes c0*s *)
+Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
+ canonical_sum :=
+ match s with
+ | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
+ | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
+ | Nil_monom => Nil_monom
+ end.
+
+(* Computes l0*s *)
+Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
+ canonical_sum :=
+ match s with
+ | Cons_monom c l t =>
+ monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
+ | Cons_varlist l t =>
+ varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
+ | Nil_monom => Nil_monom
+ end.
+
+(* Computes c0*l0*s *)
+Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
+ (s:canonical_sum) {struct s} : canonical_sum :=
+ match s with
+ | Cons_monom c l t =>
+ monom_insert (Amult c0 c) (varlist_merge l0 l)
+ (canonical_sum_scalar3 c0 l0 t)
+ | Cons_varlist l t =>
+ monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
+ | Nil_monom => Nil_monom
+ end.
+
+(* returns the product of two canonical sums *)
+Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
+ canonical_sum :=
+ match s1 with
+ | Cons_monom c1 l1 t1 =>
+ canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
+ (canonical_sum_prod t1 s2)
+ | Cons_varlist l1 t1 =>
+ canonical_sum_merge (canonical_sum_scalar2 l1 s2)
+ (canonical_sum_prod t1 s2)
+ | Nil_monom => Nil_monom
+ end.
+
+(* The type to represent concrete semi-ring polynomials *)
+Inductive spolynomial : Type :=
+ | SPvar : index -> spolynomial
+ | SPconst : A -> spolynomial
+ | SPplus : spolynomial -> spolynomial -> spolynomial
+ | SPmult : spolynomial -> spolynomial -> spolynomial.
+
+Fixpoint spolynomial_normalize (p:spolynomial) : canonical_sum :=
+ match p with
+ | SPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
+ | SPconst c => Cons_monom c Nil_var Nil_monom
+ | SPplus l r =>
+ canonical_sum_merge (spolynomial_normalize l) (spolynomial_normalize r)
+ | SPmult l r =>
+ canonical_sum_prod (spolynomial_normalize l) (spolynomial_normalize r)
+ end.
+
+(* Deletion of useless 0 and 1 in canonical sums *)
+Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
+ match s with
+ | Cons_monom c l t =>
+ if Aeq c Azero
+ then canonical_sum_simplify t
+ else
+ if Aeq c Aone
+ then Cons_varlist l (canonical_sum_simplify t)
+ else Cons_monom c l (canonical_sum_simplify t)
+ | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
+ | Nil_monom => Nil_monom
+ end.
+
+Definition spolynomial_simplify (x:spolynomial) :=
+ canonical_sum_simplify (spolynomial_normalize x).
+
+(* End definitions. *)
+
+(* Section interpretation. *)
+
+(*** Here a variable map is defined and the interpetation of a spolynom
+ acording to a certain variables map. Once again the choosen definition
+ is generic and could be changed ****)
+
+Variable vm : varmap A.
+
+(* Interpretation of list of variables
+ * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn)
+ * The unbound variables are mapped to 0. Normally this case sould
+ * never occur. Since we want only to prove correctness theorems, which form
+ * is : for any varmap and any spolynom ... this is a safe and pain-saving
+ * choice *)
+Definition interp_var (i:index) := varmap_find Azero i vm.
+
+(* Local *) Definition ivl_aux :=
+ (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
+ match t with
+ | Nil_var => interp_var x
+ | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
+ end).
+
+Definition interp_vl (l:varlist) :=
+ match l with
+ | Nil_var => Aone
+ | Cons_var x t => ivl_aux x t
+ end.
+
+(* Local *) Definition interp_m (c:A) (l:varlist) :=
+ match l with
+ | Nil_var => c
+ | Cons_var x t => Amult c (ivl_aux x t)
+ end.
+
+(* Local *) Definition ics_aux :=
+ (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
+ match s with
+ | Nil_monom => a
+ | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
+ | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
+ end).
+
+(* Interpretation of a canonical sum *)
+Definition interp_cs (s:canonical_sum) : A :=
+ match s with
+ | Nil_monom => Azero
+ | Cons_varlist l t => ics_aux (interp_vl l) t
+ | Cons_monom c l t => ics_aux (interp_m c l) t
+ end.
+
+Fixpoint interp_sp (p:spolynomial) : A :=
+ match p with
+ | SPconst c => c
+ | SPvar i => interp_var i
+ | SPplus p1 p2 => Aplus (interp_sp p1) (interp_sp p2)
+ | SPmult p1 p2 => Amult (interp_sp p1) (interp_sp p2)
+ end.
+
+
+(* End interpretation. *)
+
+Unset Implicit Arguments.
+
+(* Section properties. *)
+
+Variable T : Semi_Ring_Theory Aplus Amult Aone Azero Aeq.
+
+Hint Resolve (SR_plus_comm T).
+Hint Resolve (SR_plus_assoc T).
+Hint Resolve (SR_plus_assoc2 T).
+Hint Resolve (SR_mult_comm T).
+Hint Resolve (SR_mult_assoc T).
+Hint Resolve (SR_mult_assoc2 T).
+Hint Resolve (SR_plus_zero_left T).
+Hint Resolve (SR_plus_zero_left2 T).
+Hint Resolve (SR_mult_one_left T).
+Hint Resolve (SR_mult_one_left2 T).
+Hint Resolve (SR_mult_zero_left T).
+Hint Resolve (SR_mult_zero_left2 T).
+Hint Resolve (SR_distr_left T).
+Hint Resolve (SR_distr_left2 T).
+(*Hint Resolve (SR_plus_reg_left T).*)
+Hint Resolve (SR_plus_permute T).
+Hint Resolve (SR_mult_permute T).
+Hint Resolve (SR_distr_right T).
+Hint Resolve (SR_distr_right2 T).
+Hint Resolve (SR_mult_zero_right T).
+Hint Resolve (SR_mult_zero_right2 T).
+Hint Resolve (SR_plus_zero_right T).
+Hint Resolve (SR_plus_zero_right2 T).
+Hint Resolve (SR_mult_one_right T).
+Hint Resolve (SR_mult_one_right2 T).
+(*Hint Resolve (SR_plus_reg_right T).*)
+Hint Resolve refl_equal sym_equal trans_equal.
+(* Hints Resolve refl_eqT sym_eqT trans_eqT. *)
+Hint Immediate T.
+
+Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
+Proof.
+ simple induction x; simple induction y; contradiction || (try reflexivity).
+ simpl in |- *; intros.
+ generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
+ rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
+Qed.
+
+Remark ivl_aux_ok :
+ forall (v:varlist) (i:index),
+ ivl_aux i v = Amult (interp_var i) (interp_vl v).
+Proof.
+ simple induction v; simpl in |- *; intros.
+ trivial.
+ rewrite H; trivial.
+Qed.
+
+Lemma varlist_merge_ok :
+ forall x y:varlist,
+ interp_vl (varlist_merge x y) = Amult (interp_vl x) (interp_vl y).
+Proof.
+ simple induction x.
+ simpl in |- *; trivial.
+ simple induction y.
+ simpl in |- *; trivial.
+ simpl in |- *; intros.
+ elim (index_lt i i0); simpl in |- *; intros.
+
+ repeat rewrite ivl_aux_ok.
+ rewrite H. simpl in |- *.
+ rewrite ivl_aux_ok.
+ eauto.
+
+ repeat rewrite ivl_aux_ok.
+ rewrite H0.
+ rewrite ivl_aux_ok.
+ eauto.
+Qed.
+
+Remark ics_aux_ok :
+ forall (x:A) (s:canonical_sum), ics_aux x s = Aplus x (interp_cs s).
+Proof.
+ simple induction s; simpl in |- *; intros.
+ trivial.
+ reflexivity.
+ reflexivity.
+Qed.
+
+Remark interp_m_ok :
+ forall (x:A) (l:varlist), interp_m x l = Amult x (interp_vl l).
+Proof.
+ destruct l as [| i v].
+ simpl in |- *; trivial.
+ reflexivity.
+Qed.
+
+Lemma canonical_sum_merge_ok :
+ forall x y:canonical_sum,
+ interp_cs (canonical_sum_merge x y) = Aplus (interp_cs x) (interp_cs y).
+
+simple induction x; simpl in |- *.
+trivial.
+
+simple induction y; simpl in |- *; intros.
+(* monom and nil *)
+eauto.
+
+(* monom and monom *)
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+repeat rewrite interp_m_ok.
+rewrite (SR_distr_left T).
+repeat rewrite <- (SR_plus_assoc T).
+apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
+trivial.
+
+elim (varlist_lt v v0); simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
+
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+ eauto.
+
+(* monom and varlist *)
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+repeat rewrite interp_m_ok.
+rewrite (SR_distr_left T).
+repeat rewrite <- (SR_plus_assoc T).
+apply f_equal with (f := Aplus (Amult a (interp_vl v0))).
+rewrite (SR_mult_one_left T).
+trivial.
+
+elim (varlist_lt v v0); simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+ eauto.
+
+simple induction y; simpl in |- *; intros.
+(* varlist and nil *)
+trivial.
+
+(* varlist and monom *)
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+repeat rewrite interp_m_ok.
+rewrite (SR_distr_left T).
+repeat rewrite <- (SR_plus_assoc T).
+rewrite (SR_mult_one_left T).
+apply f_equal with (f := Aplus (interp_vl v0)).
+trivial.
+
+elim (varlist_lt v v0); simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+ eauto.
+
+(* varlist and varlist *)
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *; repeat rewrite ics_aux_ok; rewrite H.
+repeat rewrite interp_m_ok.
+rewrite (SR_distr_left T).
+repeat rewrite <- (SR_plus_assoc T).
+rewrite (SR_mult_one_left T).
+apply f_equal with (f := Aplus (interp_vl v0)).
+trivial.
+
+elim (varlist_lt v v0); simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite H; simpl in |- *; rewrite ics_aux_ok; eauto.
+rewrite ics_aux_ok; rewrite H0; repeat rewrite ics_aux_ok; simpl in |- *;
+ eauto.
+Qed.
+
+Lemma monom_insert_ok :
+ forall (a:A) (l:varlist) (s:canonical_sum),
+ interp_cs (monom_insert a l s) =
+ Aplus (Amult a (interp_vl l)) (interp_cs s).
+intros; generalize s; simple induction s0.
+
+simpl in |- *; rewrite interp_m_ok; trivial.
+
+simpl in |- *; intros.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
+ repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
+ eauto.
+elim (varlist_lt l v); simpl in |- *;
+ [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
+ | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
+ rewrite ics_aux_ok; eauto ].
+
+simpl in |- *; intros.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
+ repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
+ rewrite (SR_mult_one_left T); eauto.
+elim (varlist_lt l v); simpl in |- *;
+ [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
+ | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
+ rewrite ics_aux_ok; eauto ].
+Qed.
+
+Lemma varlist_insert_ok :
+ forall (l:varlist) (s:canonical_sum),
+ interp_cs (varlist_insert l s) = Aplus (interp_vl l) (interp_cs s).
+intros; generalize s; simple induction s0.
+
+simpl in |- *; trivial.
+
+simpl in |- *; intros.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
+ repeat rewrite ics_aux_ok; rewrite interp_m_ok; rewrite (SR_distr_left T);
+ rewrite (SR_mult_one_left T); eauto.
+elim (varlist_lt l v); simpl in |- *;
+ [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
+ | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
+ rewrite ics_aux_ok; eauto ].
+
+simpl in |- *; intros.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *; rewrite interp_m_ok;
+ repeat rewrite ics_aux_ok; rewrite (SR_distr_left T);
+ rewrite (SR_mult_one_left T); eauto.
+elim (varlist_lt l v); simpl in |- *;
+ [ repeat rewrite interp_m_ok; rewrite ics_aux_ok; eauto
+ | repeat rewrite interp_m_ok; rewrite ics_aux_ok; rewrite H;
+ rewrite ics_aux_ok; eauto ].
+Qed.
+
+Lemma canonical_sum_scalar_ok :
+ forall (a:A) (s:canonical_sum),
+ interp_cs (canonical_sum_scalar a s) = Amult a (interp_cs s).
+simple induction s.
+simpl in |- *; eauto.
+
+simpl in |- *; intros.
+repeat rewrite ics_aux_ok.
+repeat rewrite interp_m_ok.
+rewrite H.
+rewrite (SR_distr_right T).
+repeat rewrite <- (SR_mult_assoc T).
+reflexivity.
+
+simpl in |- *; intros.
+repeat rewrite ics_aux_ok.
+repeat rewrite interp_m_ok.
+rewrite H.
+rewrite (SR_distr_right T).
+repeat rewrite <- (SR_mult_assoc T).
+reflexivity.
+Qed.
+
+Lemma canonical_sum_scalar2_ok :
+ forall (l:varlist) (s:canonical_sum),
+ interp_cs (canonical_sum_scalar2 l s) = Amult (interp_vl l) (interp_cs s).
+simple induction s.
+simpl in |- *; trivial.
+
+simpl in |- *; intros.
+rewrite monom_insert_ok.
+repeat rewrite ics_aux_ok.
+repeat rewrite interp_m_ok.
+rewrite H.
+rewrite varlist_merge_ok.
+repeat rewrite (SR_distr_right T).
+repeat rewrite <- (SR_mult_assoc T).
+repeat rewrite <- (SR_plus_assoc T).
+rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
+reflexivity.
+
+simpl in |- *; intros.
+rewrite varlist_insert_ok.
+repeat rewrite ics_aux_ok.
+repeat rewrite interp_m_ok.
+rewrite H.
+rewrite varlist_merge_ok.
+repeat rewrite (SR_distr_right T).
+repeat rewrite <- (SR_mult_assoc T).
+repeat rewrite <- (SR_plus_assoc T).
+reflexivity.
+Qed.
+
+Lemma canonical_sum_scalar3_ok :
+ forall (c:A) (l:varlist) (s:canonical_sum),
+ interp_cs (canonical_sum_scalar3 c l s) =
+ Amult c (Amult (interp_vl l) (interp_cs s)).
+simple induction s.
+simpl in |- *; repeat rewrite (SR_mult_zero_right T); reflexivity.
+
+simpl in |- *; intros.
+rewrite monom_insert_ok.
+repeat rewrite ics_aux_ok.
+repeat rewrite interp_m_ok.
+rewrite H.
+rewrite varlist_merge_ok.
+repeat rewrite (SR_distr_right T).
+repeat rewrite <- (SR_mult_assoc T).
+repeat rewrite <- (SR_plus_assoc T).
+rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)).
+reflexivity.
+
+simpl in |- *; intros.
+rewrite monom_insert_ok.
+repeat rewrite ics_aux_ok.
+repeat rewrite interp_m_ok.
+rewrite H.
+rewrite varlist_merge_ok.
+repeat rewrite (SR_distr_right T).
+repeat rewrite <- (SR_mult_assoc T).
+repeat rewrite <- (SR_plus_assoc T).
+rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)).
+reflexivity.
+Qed.
+
+Lemma canonical_sum_prod_ok :
+ forall x y:canonical_sum,
+ interp_cs (canonical_sum_prod x y) = Amult (interp_cs x) (interp_cs y).
+simple induction x; simpl in |- *; intros.
+trivial.
+
+rewrite canonical_sum_merge_ok.
+rewrite canonical_sum_scalar3_ok.
+rewrite ics_aux_ok.
+rewrite interp_m_ok.
+rewrite H.
+rewrite (SR_mult_assoc T a (interp_vl v) (interp_cs y)).
+symmetry in |- *.
+eauto.
+
+rewrite canonical_sum_merge_ok.
+rewrite canonical_sum_scalar2_ok.
+rewrite ics_aux_ok.
+rewrite H.
+trivial.
+Qed.
+
+Theorem spolynomial_normalize_ok :
+ forall p:spolynomial, interp_cs (spolynomial_normalize p) = interp_sp p.
+simple induction p; simpl in |- *; intros.
+
+reflexivity.
+reflexivity.
+
+rewrite canonical_sum_merge_ok.
+rewrite H; rewrite H0.
+reflexivity.
+
+rewrite canonical_sum_prod_ok.
+rewrite H; rewrite H0.
+reflexivity.
+Qed.
+
+Lemma canonical_sum_simplify_ok :
+ forall s:canonical_sum, interp_cs (canonical_sum_simplify s) = interp_cs s.
+simple induction s.
+
+reflexivity.
+
+(* cons_monom *)
+simpl in |- *; intros.
+generalize (SR_eq_prop T a Azero).
+elim (Aeq a Azero).
+intro Heq; rewrite (Heq I).
+rewrite H.
+rewrite ics_aux_ok.
+rewrite interp_m_ok.
+rewrite (SR_mult_zero_left T).
+trivial.
+
+intros; simpl in |- *.
+generalize (SR_eq_prop T a Aone).
+elim (Aeq a Aone).
+intro Heq; rewrite (Heq I).
+simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite interp_m_ok.
+rewrite H.
+rewrite (SR_mult_one_left T).
+reflexivity.
+
+simpl in |- *.
+repeat rewrite ics_aux_ok.
+rewrite interp_m_ok.
+rewrite H.
+reflexivity.
+
+(* cons_varlist *)
+simpl in |- *; intros.
+repeat rewrite ics_aux_ok.
+rewrite H.
+reflexivity.
+
+Qed.
+
+Theorem spolynomial_simplify_ok :
+ forall p:spolynomial, interp_cs (spolynomial_simplify p) = interp_sp p.
+intro.
+unfold spolynomial_simplify in |- *.
+rewrite canonical_sum_simplify_ok.
+apply spolynomial_normalize_ok.
+Qed.
+
+(* End properties. *)
+End semi_rings.
+
+Implicit Arguments Cons_varlist.
+Implicit Arguments Cons_monom.
+Implicit Arguments SPconst.
+Implicit Arguments SPplus.
+Implicit Arguments SPmult.
+
+Section rings.
+
+(* Here the coercion between Ring and Semi-Ring will be useful *)
+
+Set Implicit Arguments.
+
+Variable A : Type.
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aopp : A -> A.
+Variable Aeq : A -> A -> bool.
+Variable vm : varmap A.
+Variable T : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
+
+Hint Resolve (Th_plus_comm T).
+Hint Resolve (Th_plus_assoc T).
+Hint Resolve (Th_plus_assoc2 T).
+Hint Resolve (Th_mult_comm T).
+Hint Resolve (Th_mult_assoc T).
+Hint Resolve (Th_mult_assoc2 T).
+Hint Resolve (Th_plus_zero_left T).
+Hint Resolve (Th_plus_zero_left2 T).
+Hint Resolve (Th_mult_one_left T).
+Hint Resolve (Th_mult_one_left2 T).
+Hint Resolve (Th_mult_zero_left T).
+Hint Resolve (Th_mult_zero_left2 T).
+Hint Resolve (Th_distr_left T).
+Hint Resolve (Th_distr_left2 T).
+(*Hint Resolve (Th_plus_reg_left T).*)
+Hint Resolve (Th_plus_permute T).
+Hint Resolve (Th_mult_permute T).
+Hint Resolve (Th_distr_right T).
+Hint Resolve (Th_distr_right2 T).
+Hint Resolve (Th_mult_zero_right T).
+Hint Resolve (Th_mult_zero_right2 T).
+Hint Resolve (Th_plus_zero_right T).
+Hint Resolve (Th_plus_zero_right2 T).
+Hint Resolve (Th_mult_one_right T).
+Hint Resolve (Th_mult_one_right2 T).
+(*Hint Resolve (Th_plus_reg_right T).*)
+Hint Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+(*** Definitions *)
+
+Inductive polynomial : Type :=
+ | Pvar : index -> polynomial
+ | Pconst : A -> polynomial
+ | Pplus : polynomial -> polynomial -> polynomial
+ | Pmult : polynomial -> polynomial -> polynomial
+ | Popp : polynomial -> polynomial.
+
+Fixpoint polynomial_normalize (x:polynomial) : canonical_sum A :=
+ match x with
+ | Pplus l r =>
+ canonical_sum_merge Aplus Aone (polynomial_normalize l)
+ (polynomial_normalize r)
+ | Pmult l r =>
+ canonical_sum_prod Aplus Amult Aone (polynomial_normalize l)
+ (polynomial_normalize r)
+ | Pconst c => Cons_monom c Nil_var (Nil_monom A)
+ | Pvar i => Cons_varlist (Cons_var i Nil_var) (Nil_monom A)
+ | Popp p =>
+ canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
+ (polynomial_normalize p)
+ end.
+
+Definition polynomial_simplify (x:polynomial) :=
+ canonical_sum_simplify Aone Azero Aeq (polynomial_normalize x).
+
+Fixpoint spolynomial_of (x:polynomial) : spolynomial A :=
+ match x with
+ | Pplus l r => SPplus (spolynomial_of l) (spolynomial_of r)
+ | Pmult l r => SPmult (spolynomial_of l) (spolynomial_of r)
+ | Pconst c => SPconst c
+ | Pvar i => SPvar A i
+ | Popp p => SPmult (SPconst (Aopp Aone)) (spolynomial_of p)
+ end.
+
+(*** Interpretation *)
+
+Fixpoint interp_p (p:polynomial) : A :=
+ match p with
+ | Pconst c => c
+ | Pvar i => varmap_find Azero i vm
+ | Pplus p1 p2 => Aplus (interp_p p1) (interp_p p2)
+ | Pmult p1 p2 => Amult (interp_p p1) (interp_p p2)
+ | Popp p1 => Aopp (interp_p p1)
+ end.
+
+(*** Properties *)
+
+Unset Implicit Arguments.
+
+Lemma spolynomial_of_ok :
+ forall p:polynomial,
+ interp_p p = interp_sp Aplus Amult Azero vm (spolynomial_of p).
+simple induction p; reflexivity || (simpl in |- *; intros).
+rewrite H; rewrite H0; reflexivity.
+rewrite H; rewrite H0; reflexivity.
+rewrite H.
+rewrite (Th_opp_mult_left2 T).
+rewrite (Th_mult_one_left T).
+reflexivity.
+Qed.
+
+Theorem polynomial_normalize_ok :
+ forall p:polynomial,
+ polynomial_normalize p =
+ spolynomial_normalize Aplus Amult Aone (spolynomial_of p).
+simple induction p; reflexivity || (simpl in |- *; intros).
+rewrite H; rewrite H0; reflexivity.
+rewrite H; rewrite H0; reflexivity.
+rewrite H; simpl in |- *.
+elim
+ (canonical_sum_scalar3 Aplus Amult Aone (Aopp Aone) Nil_var
+ (spolynomial_normalize Aplus Amult Aone (spolynomial_of p0)));
+ [ reflexivity
+ | simpl in |- *; intros; rewrite H0; reflexivity
+ | simpl in |- *; intros; rewrite H0; reflexivity ].
+Qed.
+
+Theorem polynomial_simplify_ok :
+ forall p:polynomial,
+ interp_cs Aplus Amult Aone Azero vm (polynomial_simplify p) = interp_p p.
+intro.
+unfold polynomial_simplify in |- *.
+rewrite spolynomial_of_ok.
+rewrite polynomial_normalize_ok.
+rewrite (canonical_sum_simplify_ok A Aplus Amult Aone Azero Aeq vm T).
+rewrite (spolynomial_normalize_ok A Aplus Amult Aone Azero Aeq vm T).
+reflexivity.
+Qed.
+
+End rings.
+
+Infix "+" := Pplus : ring_scope.
+Infix "*" := Pmult : ring_scope.
+Notation "- x" := (Popp x) : ring_scope.
+Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope.
+
+Delimit Scope ring_scope with ring.
diff --git a/plugins/ring/Setoid_ring.v b/plugins/ring/Setoid_ring.v
new file mode 100644
index 00000000..93b9bc7c
--- /dev/null
+++ b/plugins/ring/Setoid_ring.v
@@ -0,0 +1,14 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Export Setoid_ring_theory.
+Require Export Quote.
+Require Export Setoid_ring_normalize.
+Declare ML Module "ring_plugin".
diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v
new file mode 100644
index 00000000..9b4c46fe
--- /dev/null
+++ b/plugins/ring/Setoid_ring_normalize.v
@@ -0,0 +1,1165 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Import Setoid_ring_theory.
+Require Import Quote.
+
+Set Implicit Arguments.
+Unset Boxed Definitions.
+
+Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m.
+Proof.
+ simple induction n; simple induction m; simpl in |- *;
+ try reflexivity || contradiction.
+ intros; rewrite (H i0); trivial.
+ intros; rewrite (H i0); trivial.
+Qed.
+
+Section setoid.
+
+Variable A : Type.
+Variable Aequiv : A -> A -> Prop.
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aopp : A -> A.
+Variable Aeq : A -> A -> bool.
+
+Variable S : Setoid_Theory A Aequiv.
+
+Add Setoid A Aequiv S as Asetoid.
+
+Variable plus_morph :
+ forall a a0:A, Aequiv a a0 ->
+ forall a1 a2:A, Aequiv a1 a2 ->
+ Aequiv (Aplus a a1) (Aplus a0 a2).
+Variable mult_morph :
+ forall a a0:A, Aequiv a a0 ->
+ forall a1 a2:A, Aequiv a1 a2 ->
+ Aequiv (Amult a a1) (Amult a0 a2).
+Variable opp_morph : forall a a0:A, Aequiv a a0 -> Aequiv (Aopp a) (Aopp a0).
+
+Add Morphism Aplus : Aplus_ext.
+intros; apply plus_morph; assumption.
+Qed.
+
+Add Morphism Amult : Amult_ext.
+intros; apply mult_morph; assumption.
+Qed.
+
+Add Morphism Aopp : Aopp_ext.
+exact opp_morph.
+Qed.
+
+Let equiv_refl := Seq_refl A Aequiv S.
+Let equiv_sym := Seq_sym A Aequiv S.
+Let equiv_trans := Seq_trans A Aequiv S.
+
+Hint Resolve equiv_refl equiv_trans.
+Hint Immediate equiv_sym.
+
+Section semi_setoid_rings.
+
+(* Section definitions. *)
+
+
+(******************************************)
+(* Normal abtract Polynomials *)
+(******************************************)
+(* DEFINITIONS :
+- A varlist is a sorted product of one or more variables : x, x*y*z
+- A monom is a constant, a varlist or the product of a constant by a varlist
+ variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT.
+- A canonical sum is either a monom or an ordered sum of monoms
+ (the order on monoms is defined later)
+- A normal polynomial it either a constant or a canonical sum or a constant
+ plus a canonical sum
+*)
+
+(* varlist is isomorphic to (list var), but we built a special inductive
+ for efficiency *)
+Inductive varlist : Type :=
+ | Nil_var : varlist
+ | Cons_var : index -> varlist -> varlist.
+
+Inductive canonical_sum : Type :=
+ | Nil_monom : canonical_sum
+ | Cons_monom : A -> varlist -> canonical_sum -> canonical_sum
+ | Cons_varlist : varlist -> canonical_sum -> canonical_sum.
+
+(* Order on monoms *)
+
+(* That's the lexicographic order on varlist, extended by :
+ - A constant is less than every monom
+ - The relation between two varlist is preserved by multiplication by a
+ constant.
+
+ Examples :
+ 3 < x < y
+ x*y < x*y*y*z
+ 2*x*y < x*y*y*z
+ x*y < 54*x*y*y*z
+ 4*x*y < 59*x*y*y*z
+*)
+
+Fixpoint varlist_eq (x y:varlist) {struct y} : bool :=
+ match x, y with
+ | Nil_var, Nil_var => true
+ | Cons_var i xrest, Cons_var j yrest =>
+ andb (index_eq i j) (varlist_eq xrest yrest)
+ | _, _ => false
+ end.
+
+Fixpoint varlist_lt (x y:varlist) {struct y} : bool :=
+ match x, y with
+ | Nil_var, Cons_var _ _ => true
+ | Cons_var i xrest, Cons_var j yrest =>
+ if index_lt i j
+ then true
+ else andb (index_eq i j) (varlist_lt xrest yrest)
+ | _, _ => false
+ end.
+
+(* merges two variables lists *)
+Fixpoint varlist_merge (l1:varlist) : varlist -> varlist :=
+ match l1 with
+ | Cons_var v1 t1 =>
+ (fix vm_aux (l2:varlist) : varlist :=
+ match l2 with
+ | Cons_var v2 t2 =>
+ if index_lt v1 v2
+ then Cons_var v1 (varlist_merge t1 l2)
+ else Cons_var v2 (vm_aux t2)
+ | Nil_var => l1
+ end)
+ | Nil_var => fun l2 => l2
+ end.
+
+(* returns the sum of two canonical sums *)
+Fixpoint canonical_sum_merge (s1:canonical_sum) :
+ canonical_sum -> canonical_sum :=
+ match s1 with
+ | Cons_monom c1 l1 t1 =>
+ (fix csm_aux (s2:canonical_sum) : canonical_sum :=
+ match s2 with
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus c1 c2) l1 (canonical_sum_merge t1 t2)
+ else
+ if varlist_lt l1 l2
+ then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
+ else Cons_monom c2 l2 (csm_aux t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus c1 Aone) l1 (canonical_sum_merge t1 t2)
+ else
+ if varlist_lt l1 l2
+ then Cons_monom c1 l1 (canonical_sum_merge t1 s2)
+ else Cons_varlist l2 (csm_aux t2)
+ | Nil_monom => s1
+ end)
+ | Cons_varlist l1 t1 =>
+ (fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
+ match s2 with
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus Aone c2) l1 (canonical_sum_merge t1 t2)
+ else
+ if varlist_lt l1 l2
+ then Cons_varlist l1 (canonical_sum_merge t1 s2)
+ else Cons_monom c2 l2 (csm_aux2 t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus Aone Aone) l1 (canonical_sum_merge t1 t2)
+ else
+ if varlist_lt l1 l2
+ then Cons_varlist l1 (canonical_sum_merge t1 s2)
+ else Cons_varlist l2 (csm_aux2 t2)
+ | Nil_monom => s1
+ end)
+ | Nil_monom => fun s2 => s2
+ end.
+
+(* Insertion of a monom in a canonical sum *)
+Fixpoint monom_insert (c1:A) (l1:varlist) (s2:canonical_sum) {struct s2} :
+ canonical_sum :=
+ match s2 with
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus c1 c2) l1 t2
+ else
+ if varlist_lt l1 l2
+ then Cons_monom c1 l1 s2
+ else Cons_monom c2 l2 (monom_insert c1 l1 t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus c1 Aone) l1 t2
+ else
+ if varlist_lt l1 l2
+ then Cons_monom c1 l1 s2
+ else Cons_varlist l2 (monom_insert c1 l1 t2)
+ | Nil_monom => Cons_monom c1 l1 Nil_monom
+ end.
+
+Fixpoint varlist_insert (l1:varlist) (s2:canonical_sum) {struct s2} :
+ canonical_sum :=
+ match s2 with
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus Aone c2) l1 t2
+ else
+ if varlist_lt l1 l2
+ then Cons_varlist l1 s2
+ else Cons_monom c2 l2 (varlist_insert l1 t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq l1 l2
+ then Cons_monom (Aplus Aone Aone) l1 t2
+ else
+ if varlist_lt l1 l2
+ then Cons_varlist l1 s2
+ else Cons_varlist l2 (varlist_insert l1 t2)
+ | Nil_monom => Cons_varlist l1 Nil_monom
+ end.
+
+(* Computes c0*s *)
+Fixpoint canonical_sum_scalar (c0:A) (s:canonical_sum) {struct s} :
+ canonical_sum :=
+ match s with
+ | Cons_monom c l t => Cons_monom (Amult c0 c) l (canonical_sum_scalar c0 t)
+ | Cons_varlist l t => Cons_monom c0 l (canonical_sum_scalar c0 t)
+ | Nil_monom => Nil_monom
+ end.
+
+(* Computes l0*s *)
+Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} :
+ canonical_sum :=
+ match s with
+ | Cons_monom c l t =>
+ monom_insert c (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
+ | Cons_varlist l t =>
+ varlist_insert (varlist_merge l0 l) (canonical_sum_scalar2 l0 t)
+ | Nil_monom => Nil_monom
+ end.
+
+(* Computes c0*l0*s *)
+Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist)
+ (s:canonical_sum) {struct s} : canonical_sum :=
+ match s with
+ | Cons_monom c l t =>
+ monom_insert (Amult c0 c) (varlist_merge l0 l)
+ (canonical_sum_scalar3 c0 l0 t)
+ | Cons_varlist l t =>
+ monom_insert c0 (varlist_merge l0 l) (canonical_sum_scalar3 c0 l0 t)
+ | Nil_monom => Nil_monom
+ end.
+
+(* returns the product of two canonical sums *)
+Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} :
+ canonical_sum :=
+ match s1 with
+ | Cons_monom c1 l1 t1 =>
+ canonical_sum_merge (canonical_sum_scalar3 c1 l1 s2)
+ (canonical_sum_prod t1 s2)
+ | Cons_varlist l1 t1 =>
+ canonical_sum_merge (canonical_sum_scalar2 l1 s2)
+ (canonical_sum_prod t1 s2)
+ | Nil_monom => Nil_monom
+ end.
+
+(* The type to represent concrete semi-setoid-ring polynomials *)
+
+Inductive setspolynomial : Type :=
+ | SetSPvar : index -> setspolynomial
+ | SetSPconst : A -> setspolynomial
+ | SetSPplus : setspolynomial -> setspolynomial -> setspolynomial
+ | SetSPmult : setspolynomial -> setspolynomial -> setspolynomial.
+
+Fixpoint setspolynomial_normalize (p:setspolynomial) : canonical_sum :=
+ match p with
+ | SetSPplus l r =>
+ canonical_sum_merge (setspolynomial_normalize l)
+ (setspolynomial_normalize r)
+ | SetSPmult l r =>
+ canonical_sum_prod (setspolynomial_normalize l)
+ (setspolynomial_normalize r)
+ | SetSPconst c => Cons_monom c Nil_var Nil_monom
+ | SetSPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
+ end.
+
+Fixpoint canonical_sum_simplify (s:canonical_sum) : canonical_sum :=
+ match s with
+ | Cons_monom c l t =>
+ if Aeq c Azero
+ then canonical_sum_simplify t
+ else
+ if Aeq c Aone
+ then Cons_varlist l (canonical_sum_simplify t)
+ else Cons_monom c l (canonical_sum_simplify t)
+ | Cons_varlist l t => Cons_varlist l (canonical_sum_simplify t)
+ | Nil_monom => Nil_monom
+ end.
+
+Definition setspolynomial_simplify (x:setspolynomial) :=
+ canonical_sum_simplify (setspolynomial_normalize x).
+
+Variable vm : varmap A.
+
+Definition interp_var (i:index) := varmap_find Azero i vm.
+
+Definition ivl_aux :=
+ (fix ivl_aux (x:index) (t:varlist) {struct t} : A :=
+ match t with
+ | Nil_var => interp_var x
+ | Cons_var x' t' => Amult (interp_var x) (ivl_aux x' t')
+ end).
+
+Definition interp_vl (l:varlist) :=
+ match l with
+ | Nil_var => Aone
+ | Cons_var x t => ivl_aux x t
+ end.
+
+Definition interp_m (c:A) (l:varlist) :=
+ match l with
+ | Nil_var => c
+ | Cons_var x t => Amult c (ivl_aux x t)
+ end.
+
+Definition ics_aux :=
+ (fix ics_aux (a:A) (s:canonical_sum) {struct s} : A :=
+ match s with
+ | Nil_monom => a
+ | Cons_varlist l t => Aplus a (ics_aux (interp_vl l) t)
+ | Cons_monom c l t => Aplus a (ics_aux (interp_m c l) t)
+ end).
+
+Definition interp_setcs (s:canonical_sum) : A :=
+ match s with
+ | Nil_monom => Azero
+ | Cons_varlist l t => ics_aux (interp_vl l) t
+ | Cons_monom c l t => ics_aux (interp_m c l) t
+ end.
+
+Fixpoint interp_setsp (p:setspolynomial) : A :=
+ match p with
+ | SetSPconst c => c
+ | SetSPvar i => interp_var i
+ | SetSPplus p1 p2 => Aplus (interp_setsp p1) (interp_setsp p2)
+ | SetSPmult p1 p2 => Amult (interp_setsp p1) (interp_setsp p2)
+ end.
+
+(* End interpretation. *)
+
+Unset Implicit Arguments.
+
+(* Section properties. *)
+
+Variable T : Semi_Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aeq.
+
+Hint Resolve (SSR_plus_comm T).
+Hint Resolve (SSR_plus_assoc T).
+Hint Resolve (SSR_plus_assoc2 S T).
+Hint Resolve (SSR_mult_comm T).
+Hint Resolve (SSR_mult_assoc T).
+Hint Resolve (SSR_mult_assoc2 S T).
+Hint Resolve (SSR_plus_zero_left T).
+Hint Resolve (SSR_plus_zero_left2 S T).
+Hint Resolve (SSR_mult_one_left T).
+Hint Resolve (SSR_mult_one_left2 S T).
+Hint Resolve (SSR_mult_zero_left T).
+Hint Resolve (SSR_mult_zero_left2 S T).
+Hint Resolve (SSR_distr_left T).
+Hint Resolve (SSR_distr_left2 S T).
+Hint Resolve (SSR_plus_reg_left T).
+Hint Resolve (SSR_plus_permute S plus_morph T).
+Hint Resolve (SSR_mult_permute S mult_morph T).
+Hint Resolve (SSR_distr_right S plus_morph T).
+Hint Resolve (SSR_distr_right2 S plus_morph T).
+Hint Resolve (SSR_mult_zero_right S T).
+Hint Resolve (SSR_mult_zero_right2 S T).
+Hint Resolve (SSR_plus_zero_right S T).
+Hint Resolve (SSR_plus_zero_right2 S T).
+Hint Resolve (SSR_mult_one_right S T).
+Hint Resolve (SSR_mult_one_right2 S T).
+Hint Resolve (SSR_plus_reg_right S T).
+Hint Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+Lemma varlist_eq_prop : forall x y:varlist, Is_true (varlist_eq x y) -> x = y.
+Proof.
+ simple induction x; simple induction y; contradiction || (try reflexivity).
+ simpl in |- *; intros.
+ generalize (andb_prop2 _ _ H1); intros; elim H2; intros.
+ rewrite (index_eq_prop _ _ H3); rewrite (H v0 H4); reflexivity.
+Qed.
+
+Remark ivl_aux_ok :
+ forall (v:varlist) (i:index),
+ Aequiv (ivl_aux i v) (Amult (interp_var i) (interp_vl v)).
+Proof.
+ simple induction v; simpl in |- *; intros.
+ trivial.
+ rewrite (H i); trivial.
+Qed.
+
+Lemma varlist_merge_ok :
+ forall x y:varlist,
+ Aequiv (interp_vl (varlist_merge x y)) (Amult (interp_vl x) (interp_vl y)).
+Proof.
+ simple induction x.
+ simpl in |- *; trivial.
+ simple induction y.
+ simpl in |- *; trivial.
+ simpl in |- *; intros.
+ elim (index_lt i i0); simpl in |- *; intros.
+
+ rewrite (ivl_aux_ok v i).
+ rewrite (ivl_aux_ok v0 i0).
+ rewrite (ivl_aux_ok (varlist_merge v (Cons_var i0 v0)) i).
+ rewrite (H (Cons_var i0 v0)).
+ simpl in |- *.
+ rewrite (ivl_aux_ok v0 i0).
+ eauto.
+
+ rewrite (ivl_aux_ok v i).
+ rewrite (ivl_aux_ok v0 i0).
+ rewrite
+ (ivl_aux_ok
+ ((fix vm_aux (l2:varlist) : varlist :=
+ match l2 with
+ | Nil_var => Cons_var i v
+ | Cons_var v2 t2 =>
+ if index_lt i v2
+ then Cons_var i (varlist_merge v l2)
+ else Cons_var v2 (vm_aux t2)
+ end) v0) i0).
+ rewrite H0.
+ rewrite (ivl_aux_ok v i).
+ eauto.
+Qed.
+
+Remark ics_aux_ok :
+ forall (x:A) (s:canonical_sum),
+ Aequiv (ics_aux x s) (Aplus x (interp_setcs s)).
+Proof.
+ simple induction s; simpl in |- *; intros; trivial.
+Qed.
+
+Remark interp_m_ok :
+ forall (x:A) (l:varlist), Aequiv (interp_m x l) (Amult x (interp_vl l)).
+Proof.
+ destruct l as [| i v]; trivial.
+Qed.
+
+Hint Resolve ivl_aux_ok.
+Hint Resolve ics_aux_ok.
+Hint Resolve interp_m_ok.
+
+(* Hints Resolve ivl_aux_ok ics_aux_ok interp_m_ok. *)
+
+Lemma canonical_sum_merge_ok :
+ forall x y:canonical_sum,
+ Aequiv (interp_setcs (canonical_sum_merge x y))
+ (Aplus (interp_setcs x) (interp_setcs y)).
+Proof.
+simple induction x; simpl in |- *.
+trivial.
+
+simple induction y; simpl in |- *; intros.
+eauto.
+
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *.
+rewrite (ics_aux_ok (interp_m a v0) c).
+rewrite (ics_aux_ok (interp_m a0 v0) c0).
+rewrite (ics_aux_ok (interp_m (Aplus a a0) v0) (canonical_sum_merge c c0)).
+rewrite (H c0).
+rewrite (interp_m_ok (Aplus a a0) v0).
+rewrite (interp_m_ok a v0).
+rewrite (interp_m_ok a0 v0).
+setoid_replace (Amult (Aplus a a0) (interp_vl v0)) with
+ (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (Amult a (interp_vl v0)) (Amult a0 (interp_vl v0)))
+ (Aplus (interp_setcs c) (interp_setcs c0))) with
+ (Aplus (Amult a (interp_vl v0))
+ (Aplus (Amult a0 (interp_vl v0))
+ (Aplus (interp_setcs c) (interp_setcs c0))));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
+ (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))) with
+ (Aplus (Amult a (interp_vl v0))
+ (Aplus (interp_setcs c)
+ (Aplus (Amult a0 (interp_vl v0)) (interp_setcs c0))));
+ [ idtac | trivial ].
+auto.
+
+elim (varlist_lt v v0); simpl in |- *.
+intro.
+rewrite
+ (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_monom a0 v0 c0)))
+ .
+rewrite (ics_aux_ok (interp_m a v) c).
+rewrite (ics_aux_ok (interp_m a0 v0) c0).
+rewrite (H (Cons_monom a0 v0 c0)); simpl in |- *.
+rewrite (ics_aux_ok (interp_m a0 v0) c0); auto.
+
+intro.
+rewrite
+ (ics_aux_ok (interp_m a0 v0)
+ ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
+ match s2 with
+ | Nil_monom => Cons_monom a v c
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq v l2
+ then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
+ else
+ if varlist_lt v l2
+ then Cons_monom a v (canonical_sum_merge c s2)
+ else Cons_monom c2 l2 (csm_aux t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq v l2
+ then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
+ else
+ if varlist_lt v l2
+ then Cons_monom a v (canonical_sum_merge c s2)
+ else Cons_varlist l2 (csm_aux t2)
+ end) c0)).
+rewrite H0.
+rewrite (ics_aux_ok (interp_m a v) c);
+ rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *;
+ auto.
+
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *.
+rewrite (ics_aux_ok (interp_m (Aplus a Aone) v0) (canonical_sum_merge c c0));
+ rewrite (ics_aux_ok (interp_m a v0) c);
+ rewrite (ics_aux_ok (interp_vl v0) c0).
+rewrite (H c0).
+rewrite (interp_m_ok (Aplus a Aone) v0).
+rewrite (interp_m_ok a v0).
+setoid_replace (Amult (Aplus a Aone) (interp_vl v0)) with
+ (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (Amult a (interp_vl v0)) (Amult Aone (interp_vl v0)))
+ (Aplus (interp_setcs c) (interp_setcs c0))) with
+ (Aplus (Amult a (interp_vl v0))
+ (Aplus (Amult Aone (interp_vl v0))
+ (Aplus (interp_setcs c) (interp_setcs c0))));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (Amult a (interp_vl v0)) (interp_setcs c))
+ (Aplus (interp_vl v0) (interp_setcs c0))) with
+ (Aplus (Amult a (interp_vl v0))
+ (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
+ [ idtac | trivial ].
+setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0);
+ [ idtac | trivial ].
+auto.
+
+elim (varlist_lt v v0); simpl in |- *.
+intro.
+rewrite
+ (ics_aux_ok (interp_m a v) (canonical_sum_merge c (Cons_varlist v0 c0)))
+ ; rewrite (ics_aux_ok (interp_m a v) c);
+ rewrite (ics_aux_ok (interp_vl v0) c0).
+rewrite (H (Cons_varlist v0 c0)); simpl in |- *.
+rewrite (ics_aux_ok (interp_vl v0) c0).
+auto.
+
+intro.
+rewrite
+ (ics_aux_ok (interp_vl v0)
+ ((fix csm_aux (s2:canonical_sum) : canonical_sum :=
+ match s2 with
+ | Nil_monom => Cons_monom a v c
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq v l2
+ then Cons_monom (Aplus a c2) v (canonical_sum_merge c t2)
+ else
+ if varlist_lt v l2
+ then Cons_monom a v (canonical_sum_merge c s2)
+ else Cons_monom c2 l2 (csm_aux t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq v l2
+ then Cons_monom (Aplus a Aone) v (canonical_sum_merge c t2)
+ else
+ if varlist_lt v l2
+ then Cons_monom a v (canonical_sum_merge c s2)
+ else Cons_varlist l2 (csm_aux t2)
+ end) c0)); rewrite H0.
+rewrite (ics_aux_ok (interp_m a v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
+ simpl in |- *.
+auto.
+
+simple induction y; simpl in |- *; intros.
+trivial.
+
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0).
+intros; rewrite (H1 I).
+simpl in |- *.
+rewrite (ics_aux_ok (interp_m (Aplus Aone a) v0) (canonical_sum_merge c c0));
+ rewrite (ics_aux_ok (interp_vl v0) c);
+ rewrite (ics_aux_ok (interp_m a v0) c0); rewrite (H c0).
+rewrite (interp_m_ok (Aplus Aone a) v0); rewrite (interp_m_ok a v0).
+setoid_replace (Amult (Aplus Aone a) (interp_vl v0)) with
+ (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult a (interp_vl v0)))
+ (Aplus (interp_setcs c) (interp_setcs c0))) with
+ (Aplus (Amult Aone (interp_vl v0))
+ (Aplus (Amult a (interp_vl v0))
+ (Aplus (interp_setcs c) (interp_setcs c0))));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (interp_vl v0) (interp_setcs c))
+ (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))) with
+ (Aplus (interp_vl v0)
+ (Aplus (interp_setcs c)
+ (Aplus (Amult a (interp_vl v0)) (interp_setcs c0))));
+ [ idtac | trivial ].
+auto.
+
+elim (varlist_lt v v0); simpl in |- *; intros.
+rewrite
+ (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_monom a v0 c0)))
+ ; rewrite (ics_aux_ok (interp_vl v) c);
+ rewrite (ics_aux_ok (interp_m a v0) c0).
+rewrite (H (Cons_monom a v0 c0)); simpl in |- *.
+rewrite (ics_aux_ok (interp_m a v0) c0); auto.
+
+rewrite
+ (ics_aux_ok (interp_m a v0)
+ ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
+ match s2 with
+ | Nil_monom => Cons_varlist v c
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq v l2
+ then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
+ else
+ if varlist_lt v l2
+ then Cons_varlist v (canonical_sum_merge c s2)
+ else Cons_monom c2 l2 (csm_aux2 t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq v l2
+ then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
+ else
+ if varlist_lt v l2
+ then Cons_varlist v (canonical_sum_merge c s2)
+ else Cons_varlist l2 (csm_aux2 t2)
+ end) c0)); rewrite H0.
+rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_m a v0) c0);
+ simpl in |- *; auto.
+
+generalize (varlist_eq_prop v v0).
+elim (varlist_eq v v0); intros.
+rewrite (H1 I); simpl in |- *.
+rewrite
+ (ics_aux_ok (interp_m (Aplus Aone Aone) v0) (canonical_sum_merge c c0))
+ ; rewrite (ics_aux_ok (interp_vl v0) c);
+ rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H c0).
+rewrite (interp_m_ok (Aplus Aone Aone) v0).
+setoid_replace (Amult (Aplus Aone Aone) (interp_vl v0)) with
+ (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (Amult Aone (interp_vl v0)) (Amult Aone (interp_vl v0)))
+ (Aplus (interp_setcs c) (interp_setcs c0))) with
+ (Aplus (Amult Aone (interp_vl v0))
+ (Aplus (Amult Aone (interp_vl v0))
+ (Aplus (interp_setcs c) (interp_setcs c0))));
+ [ idtac | trivial ].
+setoid_replace
+ (Aplus (Aplus (interp_vl v0) (interp_setcs c))
+ (Aplus (interp_vl v0) (interp_setcs c0))) with
+ (Aplus (interp_vl v0)
+ (Aplus (interp_setcs c) (Aplus (interp_vl v0) (interp_setcs c0))));
+[ idtac | trivial ].
+setoid_replace (Amult Aone (interp_vl v0)) with (interp_vl v0); auto.
+
+elim (varlist_lt v v0); simpl in |- *.
+rewrite
+ (ics_aux_ok (interp_vl v) (canonical_sum_merge c (Cons_varlist v0 c0)))
+ ; rewrite (ics_aux_ok (interp_vl v) c);
+ rewrite (ics_aux_ok (interp_vl v0) c0); rewrite (H (Cons_varlist v0 c0));
+ simpl in |- *.
+rewrite (ics_aux_ok (interp_vl v0) c0); auto.
+
+rewrite
+ (ics_aux_ok (interp_vl v0)
+ ((fix csm_aux2 (s2:canonical_sum) : canonical_sum :=
+ match s2 with
+ | Nil_monom => Cons_varlist v c
+ | Cons_monom c2 l2 t2 =>
+ if varlist_eq v l2
+ then Cons_monom (Aplus Aone c2) v (canonical_sum_merge c t2)
+ else
+ if varlist_lt v l2
+ then Cons_varlist v (canonical_sum_merge c s2)
+ else Cons_monom c2 l2 (csm_aux2 t2)
+ | Cons_varlist l2 t2 =>
+ if varlist_eq v l2
+ then Cons_monom (Aplus Aone Aone) v (canonical_sum_merge c t2)
+ else
+ if varlist_lt v l2
+ then Cons_varlist v (canonical_sum_merge c s2)
+ else Cons_varlist l2 (csm_aux2 t2)
+ end) c0)); rewrite H0.
+rewrite (ics_aux_ok (interp_vl v) c); rewrite (ics_aux_ok (interp_vl v0) c0);
+ simpl in |- *; auto.
+Qed.
+
+Lemma monom_insert_ok :
+ forall (a:A) (l:varlist) (s:canonical_sum),
+ Aequiv (interp_setcs (monom_insert a l s))
+ (Aplus (Amult a (interp_vl l)) (interp_setcs s)).
+Proof.
+simple induction s; intros.
+simpl in |- *; rewrite (interp_m_ok a l); trivial.
+
+simpl in |- *; generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *.
+rewrite (ics_aux_ok (interp_m (Aplus a a0) v) c);
+ rewrite (ics_aux_ok (interp_m a0 v) c).
+rewrite (interp_m_ok (Aplus a a0) v); rewrite (interp_m_ok a0 v).
+setoid_replace (Amult (Aplus a a0) (interp_vl v)) with
+ (Aplus (Amult a (interp_vl v)) (Amult a0 (interp_vl v)));
+ [ idtac | trivial ].
+auto.
+
+elim (varlist_lt l v); simpl in |- *; intros.
+rewrite (ics_aux_ok (interp_m a0 v) c).
+rewrite (interp_m_ok a0 v); rewrite (interp_m_ok a l).
+auto.
+
+rewrite (ics_aux_ok (interp_m a0 v) (monom_insert a l c));
+ rewrite (ics_aux_ok (interp_m a0 v) c); rewrite H.
+auto.
+
+simpl in |- *.
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *.
+rewrite (ics_aux_ok (interp_m (Aplus a Aone) v) c);
+ rewrite (ics_aux_ok (interp_vl v) c).
+rewrite (interp_m_ok (Aplus a Aone) v).
+setoid_replace (Amult (Aplus a Aone) (interp_vl v)) with
+ (Aplus (Amult a (interp_vl v)) (Amult Aone (interp_vl v)));
+ [ idtac | trivial ].
+setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v);
+ [ idtac | trivial ].
+auto.
+
+elim (varlist_lt l v); simpl in |- *; intros; auto.
+rewrite (ics_aux_ok (interp_vl v) (monom_insert a l c)); rewrite H.
+rewrite (ics_aux_ok (interp_vl v) c); auto.
+Qed.
+
+Lemma varlist_insert_ok :
+ forall (l:varlist) (s:canonical_sum),
+ Aequiv (interp_setcs (varlist_insert l s))
+ (Aplus (interp_vl l) (interp_setcs s)).
+Proof.
+simple induction s; simpl in |- *; intros.
+trivial.
+
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *.
+rewrite (ics_aux_ok (interp_m (Aplus Aone a) v) c);
+ rewrite (ics_aux_ok (interp_m a v) c).
+rewrite (interp_m_ok (Aplus Aone a) v); rewrite (interp_m_ok a v).
+setoid_replace (Amult (Aplus Aone a) (interp_vl v)) with
+ (Aplus (Amult Aone (interp_vl v)) (Amult a (interp_vl v)));
+ [ idtac | trivial ].
+setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
+
+elim (varlist_lt l v); simpl in |- *; intros; auto.
+rewrite (ics_aux_ok (interp_m a v) (varlist_insert l c));
+ rewrite (ics_aux_ok (interp_m a v) c).
+rewrite (interp_m_ok a v).
+rewrite H; auto.
+
+generalize (varlist_eq_prop l v); elim (varlist_eq l v).
+intro Hr; rewrite (Hr I); simpl in |- *.
+rewrite (ics_aux_ok (interp_m (Aplus Aone Aone) v) c);
+ rewrite (ics_aux_ok (interp_vl v) c).
+rewrite (interp_m_ok (Aplus Aone Aone) v).
+setoid_replace (Amult (Aplus Aone Aone) (interp_vl v)) with
+ (Aplus (Amult Aone (interp_vl v)) (Amult Aone (interp_vl v)));
+ [ idtac | trivial ].
+setoid_replace (Amult Aone (interp_vl v)) with (interp_vl v); auto.
+
+elim (varlist_lt l v); simpl in |- *; intros; auto.
+rewrite (ics_aux_ok (interp_vl v) (varlist_insert l c)).
+rewrite H.
+rewrite (ics_aux_ok (interp_vl v) c); auto.
+Qed.
+
+Lemma canonical_sum_scalar_ok :
+ forall (a:A) (s:canonical_sum),
+ Aequiv (interp_setcs (canonical_sum_scalar a s))
+ (Amult a (interp_setcs s)).
+Proof.
+simple induction s; simpl in |- *; intros.
+trivial.
+
+rewrite (ics_aux_ok (interp_m (Amult a a0) v) (canonical_sum_scalar a c));
+ rewrite (ics_aux_ok (interp_m a0 v) c).
+rewrite (interp_m_ok (Amult a a0) v); rewrite (interp_m_ok a0 v).
+rewrite H.
+setoid_replace (Amult a (Aplus (Amult a0 (interp_vl v)) (interp_setcs c)))
+ with (Aplus (Amult a (Amult a0 (interp_vl v))) (Amult a (interp_setcs c)));
+ [ idtac | trivial ].
+auto.
+
+rewrite (ics_aux_ok (interp_m a v) (canonical_sum_scalar a c));
+ rewrite (ics_aux_ok (interp_vl v) c); rewrite H.
+rewrite (interp_m_ok a v).
+auto.
+Qed.
+
+Lemma canonical_sum_scalar2_ok :
+ forall (l:varlist) (s:canonical_sum),
+ Aequiv (interp_setcs (canonical_sum_scalar2 l s))
+ (Amult (interp_vl l) (interp_setcs s)).
+Proof.
+simple induction s; simpl in |- *; intros; auto.
+rewrite (monom_insert_ok a (varlist_merge l v) (canonical_sum_scalar2 l c)).
+rewrite (ics_aux_ok (interp_m a v) c).
+rewrite (interp_m_ok a v).
+rewrite H.
+rewrite (varlist_merge_ok l v).
+setoid_replace
+ (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c))) with
+ (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
+ (Amult (interp_vl l) (interp_setcs c)));
+ [ idtac | trivial ].
+auto.
+
+rewrite (varlist_insert_ok (varlist_merge l v) (canonical_sum_scalar2 l c)).
+rewrite (ics_aux_ok (interp_vl v) c).
+rewrite H.
+rewrite (varlist_merge_ok l v).
+auto.
+Qed.
+
+Lemma canonical_sum_scalar3_ok :
+ forall (c:A) (l:varlist) (s:canonical_sum),
+ Aequiv (interp_setcs (canonical_sum_scalar3 c l s))
+ (Amult c (Amult (interp_vl l) (interp_setcs s))).
+Proof.
+simple induction s; simpl in |- *; intros.
+rewrite (SSR_mult_zero_right S T (interp_vl l)).
+auto.
+
+rewrite
+ (monom_insert_ok (Amult c a) (varlist_merge l v)
+ (canonical_sum_scalar3 c l c0)).
+rewrite (ics_aux_ok (interp_m a v) c0).
+rewrite (interp_m_ok a v).
+rewrite H.
+rewrite (varlist_merge_ok l v).
+setoid_replace
+ (Amult (interp_vl l) (Aplus (Amult a (interp_vl v)) (interp_setcs c0))) with
+ (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
+ (Amult (interp_vl l) (interp_setcs c0)));
+ [ idtac | trivial ].
+setoid_replace
+ (Amult c
+ (Aplus (Amult (interp_vl l) (Amult a (interp_vl v)))
+ (Amult (interp_vl l) (interp_setcs c0)))) with
+ (Aplus (Amult c (Amult (interp_vl l) (Amult a (interp_vl v))))
+ (Amult c (Amult (interp_vl l) (interp_setcs c0))));
+ [ idtac | trivial ].
+setoid_replace (Amult (Amult c a) (Amult (interp_vl l) (interp_vl v))) with
+ (Amult c (Amult a (Amult (interp_vl l) (interp_vl v))));
+ [ idtac | trivial ].
+auto.
+
+rewrite
+ (monom_insert_ok c (varlist_merge l v) (canonical_sum_scalar3 c l c0))
+ .
+rewrite (ics_aux_ok (interp_vl v) c0).
+rewrite H.
+rewrite (varlist_merge_ok l v).
+setoid_replace
+ (Aplus (Amult c (Amult (interp_vl l) (interp_vl v)))
+ (Amult c (Amult (interp_vl l) (interp_setcs c0)))) with
+ (Amult c
+ (Aplus (Amult (interp_vl l) (interp_vl v))
+ (Amult (interp_vl l) (interp_setcs c0))));
+ [ idtac | trivial ].
+auto.
+Qed.
+
+Lemma canonical_sum_prod_ok :
+ forall x y:canonical_sum,
+ Aequiv (interp_setcs (canonical_sum_prod x y))
+ (Amult (interp_setcs x) (interp_setcs y)).
+Proof.
+simple induction x; simpl in |- *; intros.
+trivial.
+
+rewrite
+ (canonical_sum_merge_ok (canonical_sum_scalar3 a v y)
+ (canonical_sum_prod c y)).
+rewrite (canonical_sum_scalar3_ok a v y).
+rewrite (ics_aux_ok (interp_m a v) c).
+rewrite (interp_m_ok a v).
+rewrite (H y).
+setoid_replace (Amult a (Amult (interp_vl v) (interp_setcs y))) with
+ (Amult (Amult a (interp_vl v)) (interp_setcs y));
+ [ idtac | trivial ].
+setoid_replace
+ (Amult (Aplus (Amult a (interp_vl v)) (interp_setcs c)) (interp_setcs y))
+ with
+ (Aplus (Amult (Amult a (interp_vl v)) (interp_setcs y))
+ (Amult (interp_setcs c) (interp_setcs y)));
+ [ idtac | trivial ].
+trivial.
+
+rewrite
+ (canonical_sum_merge_ok (canonical_sum_scalar2 v y) (canonical_sum_prod c y))
+ .
+rewrite (canonical_sum_scalar2_ok v y).
+rewrite (ics_aux_ok (interp_vl v) c).
+rewrite (H y).
+trivial.
+Qed.
+
+Theorem setspolynomial_normalize_ok :
+ forall p:setspolynomial,
+ Aequiv (interp_setcs (setspolynomial_normalize p)) (interp_setsp p).
+Proof.
+simple induction p; simpl in |- *; intros; trivial.
+rewrite
+ (canonical_sum_merge_ok (setspolynomial_normalize s)
+ (setspolynomial_normalize s0)).
+rewrite H; rewrite H0; trivial.
+
+rewrite
+ (canonical_sum_prod_ok (setspolynomial_normalize s)
+ (setspolynomial_normalize s0)).
+rewrite H; rewrite H0; trivial.
+Qed.
+
+Lemma canonical_sum_simplify_ok :
+ forall s:canonical_sum,
+ Aequiv (interp_setcs (canonical_sum_simplify s)) (interp_setcs s).
+Proof.
+simple induction s; simpl in |- *; intros.
+trivial.
+
+generalize (SSR_eq_prop T a Azero).
+elim (Aeq a Azero).
+simpl in |- *.
+intros.
+rewrite (ics_aux_ok (interp_m a v) c).
+rewrite (interp_m_ok a v).
+rewrite (H0 I).
+setoid_replace (Amult Azero (interp_vl v)) with Azero;
+ [ idtac | trivial ].
+rewrite H.
+trivial.
+
+intros; simpl in |- *.
+generalize (SSR_eq_prop T a Aone).
+elim (Aeq a Aone).
+intros.
+rewrite (ics_aux_ok (interp_m a v) c).
+rewrite (interp_m_ok a v).
+rewrite (H1 I).
+simpl in |- *.
+rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
+rewrite H.
+auto.
+
+simpl in |- *.
+intros.
+rewrite (ics_aux_ok (interp_m a v) (canonical_sum_simplify c)).
+rewrite (ics_aux_ok (interp_m a v) c).
+rewrite H; trivial.
+
+rewrite (ics_aux_ok (interp_vl v) (canonical_sum_simplify c)).
+rewrite H.
+auto.
+Qed.
+
+Theorem setspolynomial_simplify_ok :
+ forall p:setspolynomial,
+ Aequiv (interp_setcs (setspolynomial_simplify p)) (interp_setsp p).
+Proof.
+intro.
+unfold setspolynomial_simplify in |- *.
+rewrite (canonical_sum_simplify_ok (setspolynomial_normalize p)).
+exact (setspolynomial_normalize_ok p).
+Qed.
+
+End semi_setoid_rings.
+
+Implicit Arguments Cons_varlist.
+Implicit Arguments Cons_monom.
+Implicit Arguments SetSPconst.
+Implicit Arguments SetSPplus.
+Implicit Arguments SetSPmult.
+
+
+
+Section setoid_rings.
+
+Set Implicit Arguments.
+
+Variable vm : varmap A.
+Variable T : Setoid_Ring_Theory Aequiv Aplus Amult Aone Azero Aopp Aeq.
+
+Hint Resolve (STh_plus_comm T).
+Hint Resolve (STh_plus_assoc T).
+Hint Resolve (STh_plus_assoc2 S T).
+Hint Resolve (STh_mult_comm T).
+Hint Resolve (STh_mult_assoc T).
+Hint Resolve (STh_mult_assoc2 S T).
+Hint Resolve (STh_plus_zero_left T).
+Hint Resolve (STh_plus_zero_left2 S T).
+Hint Resolve (STh_mult_one_left T).
+Hint Resolve (STh_mult_one_left2 S T).
+Hint Resolve (STh_mult_zero_left S plus_morph mult_morph T).
+Hint Resolve (STh_mult_zero_left2 S plus_morph mult_morph T).
+Hint Resolve (STh_distr_left T).
+Hint Resolve (STh_distr_left2 S T).
+Hint Resolve (STh_plus_reg_left S plus_morph T).
+Hint Resolve (STh_plus_permute S plus_morph T).
+Hint Resolve (STh_mult_permute S mult_morph T).
+Hint Resolve (STh_distr_right S plus_morph T).
+Hint Resolve (STh_distr_right2 S plus_morph T).
+Hint Resolve (STh_mult_zero_right S plus_morph mult_morph T).
+Hint Resolve (STh_mult_zero_right2 S plus_morph mult_morph T).
+Hint Resolve (STh_plus_zero_right S T).
+Hint Resolve (STh_plus_zero_right2 S T).
+Hint Resolve (STh_mult_one_right S T).
+Hint Resolve (STh_mult_one_right2 S T).
+Hint Resolve (STh_plus_reg_right S plus_morph T).
+Hint Resolve refl_equal sym_equal trans_equal.
+(*Hints Resolve refl_eqT sym_eqT trans_eqT.*)
+Hint Immediate T.
+
+
+(*** Definitions *)
+
+Inductive setpolynomial : Type :=
+ | SetPvar : index -> setpolynomial
+ | SetPconst : A -> setpolynomial
+ | SetPplus : setpolynomial -> setpolynomial -> setpolynomial
+ | SetPmult : setpolynomial -> setpolynomial -> setpolynomial
+ | SetPopp : setpolynomial -> setpolynomial.
+
+Fixpoint setpolynomial_normalize (x:setpolynomial) : canonical_sum :=
+ match x with
+ | SetPplus l r =>
+ canonical_sum_merge (setpolynomial_normalize l)
+ (setpolynomial_normalize r)
+ | SetPmult l r =>
+ canonical_sum_prod (setpolynomial_normalize l)
+ (setpolynomial_normalize r)
+ | SetPconst c => Cons_monom c Nil_var Nil_monom
+ | SetPvar i => Cons_varlist (Cons_var i Nil_var) Nil_monom
+ | SetPopp p =>
+ canonical_sum_scalar3 (Aopp Aone) Nil_var (setpolynomial_normalize p)
+ end.
+
+Definition setpolynomial_simplify (x:setpolynomial) :=
+ canonical_sum_simplify (setpolynomial_normalize x).
+
+Fixpoint setspolynomial_of (x:setpolynomial) : setspolynomial :=
+ match x with
+ | SetPplus l r => SetSPplus (setspolynomial_of l) (setspolynomial_of r)
+ | SetPmult l r => SetSPmult (setspolynomial_of l) (setspolynomial_of r)
+ | SetPconst c => SetSPconst c
+ | SetPvar i => SetSPvar i
+ | SetPopp p => SetSPmult (SetSPconst (Aopp Aone)) (setspolynomial_of p)
+ end.
+
+(*** Interpretation *)
+
+Fixpoint interp_setp (p:setpolynomial) : A :=
+ match p with
+ | SetPconst c => c
+ | SetPvar i => varmap_find Azero i vm
+ | SetPplus p1 p2 => Aplus (interp_setp p1) (interp_setp p2)
+ | SetPmult p1 p2 => Amult (interp_setp p1) (interp_setp p2)
+ | SetPopp p1 => Aopp (interp_setp p1)
+ end.
+
+(*** Properties *)
+
+Unset Implicit Arguments.
+
+Lemma setspolynomial_of_ok :
+ forall p:setpolynomial,
+ Aequiv (interp_setp p) (interp_setsp vm (setspolynomial_of p)).
+simple induction p; trivial; simpl in |- *; intros.
+rewrite H; rewrite H0; trivial.
+rewrite H; rewrite H0; trivial.
+rewrite H.
+rewrite
+ (STh_opp_mult_left2 S plus_morph mult_morph T Aone
+ (interp_setsp vm (setspolynomial_of s))).
+rewrite (STh_mult_one_left T (interp_setsp vm (setspolynomial_of s))).
+trivial.
+Qed.
+
+Theorem setpolynomial_normalize_ok :
+ forall p:setpolynomial,
+ setpolynomial_normalize p = setspolynomial_normalize (setspolynomial_of p).
+simple induction p; trivial; simpl in |- *; intros.
+rewrite H; rewrite H0; reflexivity.
+rewrite H; rewrite H0; reflexivity.
+rewrite H; simpl in |- *.
+elim
+ (canonical_sum_scalar3 (Aopp Aone) Nil_var
+ (setspolynomial_normalize (setspolynomial_of s)));
+ [ reflexivity
+ | simpl in |- *; intros; rewrite H0; reflexivity
+ | simpl in |- *; intros; rewrite H0; reflexivity ].
+Qed.
+
+Theorem setpolynomial_simplify_ok :
+ forall p:setpolynomial,
+ Aequiv (interp_setcs vm (setpolynomial_simplify p)) (interp_setp p).
+intro.
+unfold setpolynomial_simplify in |- *.
+rewrite (setspolynomial_of_ok p).
+rewrite setpolynomial_normalize_ok.
+rewrite
+ (canonical_sum_simplify_ok vm
+ (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
+ plus_morph mult_morph T)
+ (setspolynomial_normalize (setspolynomial_of p)))
+ .
+rewrite
+ (setspolynomial_normalize_ok vm
+ (Semi_Setoid_Ring_Theory_of A Aequiv S Aplus Amult Aone Azero Aopp Aeq
+ plus_morph mult_morph T) (setspolynomial_of p))
+ .
+trivial.
+Qed.
+
+End setoid_rings.
+
+End setoid.
diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v
new file mode 100644
index 00000000..2c2314af
--- /dev/null
+++ b/plugins/ring/Setoid_ring_theory.v
@@ -0,0 +1,427 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Export Bool.
+Require Export Setoid.
+
+Set Implicit Arguments.
+
+Section Setoid_rings.
+
+Variable A : Type.
+Variable Aequiv : A -> A -> Prop.
+
+Infix Local "==" := Aequiv (at level 70, no associativity).
+
+Variable S : Setoid_Theory A Aequiv.
+
+Add Setoid A Aequiv S as Asetoid.
+
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aopp : A -> A.
+Variable Aeq : A -> A -> bool.
+
+Infix "+" := Aplus (at level 50, left associativity).
+Infix "*" := Amult (at level 40, left associativity).
+Notation "0" := Azero.
+Notation "1" := Aone.
+Notation "- x" := (Aopp x).
+
+Variable plus_morph :
+ forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a + a1 == a0 + a2.
+Variable mult_morph :
+ forall a a0:A, a == a0 -> forall a1 a2:A, a1 == a2 -> a * a1 == a0 * a2.
+Variable opp_morph : forall a a0:A, a == a0 -> - a == - a0.
+
+Add Morphism Aplus : Aplus_ext.
+intros; apply plus_morph; assumption.
+Qed.
+
+Add Morphism Amult : Amult_ext.
+intros; apply mult_morph; assumption.
+Qed.
+
+Add Morphism Aopp : Aopp_ext.
+exact opp_morph.
+Qed.
+
+Section Theory_of_semi_setoid_rings.
+
+Record Semi_Setoid_Ring_Theory : Prop :=
+ {SSR_plus_comm : forall n m:A, n + m == m + n;
+ SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
+ SSR_mult_comm : forall n m:A, n * m == m * n;
+ SSR_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
+ SSR_plus_zero_left : forall n:A, 0 + n == n;
+ SSR_mult_one_left : forall n:A, 1 * n == n;
+ SSR_mult_zero_left : forall n:A, 0 * n == 0;
+ SSR_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
+ SSR_plus_reg_left : forall n m p:A, n + m == n + p -> m == p;
+ SSR_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
+
+Variable T : Semi_Setoid_Ring_Theory.
+
+Let plus_comm := SSR_plus_comm T.
+Let plus_assoc := SSR_plus_assoc T.
+Let mult_comm := SSR_mult_comm T.
+Let mult_assoc := SSR_mult_assoc T.
+Let plus_zero_left := SSR_plus_zero_left T.
+Let mult_one_left := SSR_mult_one_left T.
+Let mult_zero_left := SSR_mult_zero_left T.
+Let distr_left := SSR_distr_left T.
+Let plus_reg_left := SSR_plus_reg_left T.
+Let equiv_refl := Seq_refl A Aequiv S.
+Let equiv_sym := Seq_sym A Aequiv S.
+Let equiv_trans := Seq_trans A Aequiv S.
+
+Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
+ mult_one_left mult_zero_left distr_left plus_reg_left
+ equiv_refl (*equiv_sym*).
+Hint Immediate equiv_sym.
+
+(* Lemmas whose form is x=y are also provided in form y=x because
+ Auto does not symmetry *)
+Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
+auto. Qed.
+
+Lemma SSR_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
+auto. Qed.
+
+Lemma SSR_plus_zero_left2 : forall n:A, n == 0 + n.
+auto. Qed.
+
+Lemma SSR_mult_one_left2 : forall n:A, n == 1 * n.
+auto. Qed.
+
+Lemma SSR_mult_zero_left2 : forall n:A, 0 == 0 * n.
+auto. Qed.
+
+Lemma SSR_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
+auto. Qed.
+
+Lemma SSR_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
+intros.
+rewrite (plus_assoc n m p).
+rewrite (plus_comm n m).
+rewrite <- (plus_assoc m n p).
+trivial.
+Qed.
+
+Lemma SSR_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
+intros.
+rewrite (mult_assoc n m p).
+rewrite (mult_comm n m).
+rewrite <- (mult_assoc m n p).
+trivial.
+Qed.
+
+Hint Resolve SSR_plus_permute SSR_mult_permute.
+
+Lemma SSR_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
+intros.
+rewrite (mult_comm n (m + p)).
+rewrite (mult_comm n m).
+rewrite (mult_comm n p).
+auto.
+Qed.
+
+Lemma SSR_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
+intros.
+apply equiv_sym.
+apply SSR_distr_right.
+Qed.
+
+Lemma SSR_mult_zero_right : forall n:A, n * 0 == 0.
+intro; rewrite (mult_comm n 0); auto.
+Qed.
+
+Lemma SSR_mult_zero_right2 : forall n:A, 0 == n * 0.
+intro; rewrite (mult_comm n 0); auto.
+Qed.
+
+Lemma SSR_plus_zero_right : forall n:A, n + 0 == n.
+intro; rewrite (plus_comm n 0); auto.
+Qed.
+
+Lemma SSR_plus_zero_right2 : forall n:A, n == n + 0.
+intro; rewrite (plus_comm n 0); auto.
+Qed.
+
+Lemma SSR_mult_one_right : forall n:A, n * 1 == n.
+intro; rewrite (mult_comm n 1); auto.
+Qed.
+
+Lemma SSR_mult_one_right2 : forall n:A, n == n * 1.
+intro; rewrite (mult_comm n 1); auto.
+Qed.
+
+Lemma SSR_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
+intros n m p; rewrite (plus_comm m n); rewrite (plus_comm p n).
+intro; apply plus_reg_left with n; trivial.
+Qed.
+
+End Theory_of_semi_setoid_rings.
+
+Section Theory_of_setoid_rings.
+
+Record Setoid_Ring_Theory : Prop :=
+ {STh_plus_comm : forall n m:A, n + m == m + n;
+ STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p;
+ STh_mult_comm : forall n m:A, n * m == m * n;
+ STh_mult_assoc : forall n m p:A, n * (m * p) == n * m * p;
+ STh_plus_zero_left : forall n:A, 0 + n == n;
+ STh_mult_one_left : forall n:A, 1 * n == n;
+ STh_opp_def : forall n:A, n + - n == 0;
+ STh_distr_left : forall n m p:A, (n + m) * p == n * p + m * p;
+ STh_eq_prop : forall x y:A, Is_true (Aeq x y) -> x == y}.
+
+Variable T : Setoid_Ring_Theory.
+
+Let plus_comm := STh_plus_comm T.
+Let plus_assoc := STh_plus_assoc T.
+Let mult_comm := STh_mult_comm T.
+Let mult_assoc := STh_mult_assoc T.
+Let plus_zero_left := STh_plus_zero_left T.
+Let mult_one_left := STh_mult_one_left T.
+Let opp_def := STh_opp_def T.
+Let distr_left := STh_distr_left T.
+Let equiv_refl := Seq_refl A Aequiv S.
+Let equiv_sym := Seq_sym A Aequiv S.
+Let equiv_trans := Seq_trans A Aequiv S.
+
+Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left
+ mult_one_left opp_def distr_left equiv_refl equiv_sym.
+
+(* Lemmas whose form is x=y are also provided in form y=x because Auto does
+ not symmetry *)
+
+Lemma STh_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p).
+auto. Qed.
+
+Lemma STh_plus_assoc2 : forall n m p:A, n + m + p == n + (m + p).
+auto. Qed.
+
+Lemma STh_plus_zero_left2 : forall n:A, n == 0 + n.
+auto. Qed.
+
+Lemma STh_mult_one_left2 : forall n:A, n == 1 * n.
+auto. Qed.
+
+Lemma STh_distr_left2 : forall n m p:A, n * p + m * p == (n + m) * p.
+auto. Qed.
+
+Lemma STh_opp_def2 : forall n:A, 0 == n + - n.
+auto. Qed.
+
+Lemma STh_plus_permute : forall n m p:A, n + (m + p) == m + (n + p).
+intros.
+rewrite (plus_assoc n m p).
+rewrite (plus_comm n m).
+rewrite <- (plus_assoc m n p).
+trivial.
+Qed.
+
+Lemma STh_mult_permute : forall n m p:A, n * (m * p) == m * (n * p).
+intros.
+rewrite (mult_assoc n m p).
+rewrite (mult_comm n m).
+rewrite <- (mult_assoc m n p).
+trivial.
+Qed.
+
+Hint Resolve STh_plus_permute STh_mult_permute.
+
+Lemma Saux1 : forall a:A, a + a == a -> a == 0.
+intros.
+rewrite <- (plus_zero_left a).
+rewrite (plus_comm 0 a).
+setoid_replace (a + 0) with (a + (a + - a)) by auto.
+rewrite (plus_assoc a a (- a)).
+rewrite H.
+apply opp_def.
+Qed.
+
+Lemma STh_mult_zero_left : forall n:A, 0 * n == 0.
+intros.
+apply Saux1.
+rewrite <- (distr_left 0 0 n).
+rewrite (plus_zero_left 0).
+trivial.
+Qed.
+Hint Resolve STh_mult_zero_left.
+
+Lemma STh_mult_zero_left2 : forall n:A, 0 == 0 * n.
+auto.
+Qed.
+
+Lemma Saux2 : forall x y z:A, x + y == 0 -> x + z == 0 -> y == z.
+intros.
+rewrite <- (plus_zero_left y).
+rewrite <- H0.
+rewrite <- (plus_assoc x z y).
+rewrite (plus_comm z y).
+rewrite (plus_assoc x y z).
+rewrite H.
+auto.
+Qed.
+
+Lemma STh_opp_mult_left : forall x y:A, - (x * y) == - x * y.
+intros.
+apply Saux2 with (x * y); auto.
+rewrite <- (distr_left x (- x) y).
+rewrite (opp_def x).
+auto.
+Qed.
+Hint Resolve STh_opp_mult_left.
+
+Lemma STh_opp_mult_left2 : forall x y:A, - x * y == - (x * y).
+auto.
+Qed.
+
+Lemma STh_mult_zero_right : forall n:A, n * 0 == 0.
+intro; rewrite (mult_comm n 0); auto.
+Qed.
+
+Lemma STh_mult_zero_right2 : forall n:A, 0 == n * 0.
+intro; rewrite (mult_comm n 0); auto.
+Qed.
+
+Lemma STh_plus_zero_right : forall n:A, n + 0 == n.
+intro; rewrite (plus_comm n 0); auto.
+Qed.
+
+Lemma STh_plus_zero_right2 : forall n:A, n == n + 0.
+intro; rewrite (plus_comm n 0); auto.
+Qed.
+
+Lemma STh_mult_one_right : forall n:A, n * 1 == n.
+intro; rewrite (mult_comm n 1); auto.
+Qed.
+
+Lemma STh_mult_one_right2 : forall n:A, n == n * 1.
+intro; rewrite (mult_comm n 1); auto.
+Qed.
+
+Lemma STh_opp_mult_right : forall x y:A, - (x * y) == x * - y.
+intros.
+rewrite (mult_comm x y).
+rewrite (mult_comm x (- y)).
+auto.
+Qed.
+
+Lemma STh_opp_mult_right2 : forall x y:A, x * - y == - (x * y).
+intros.
+rewrite (mult_comm x y).
+rewrite (mult_comm x (- y)).
+auto.
+Qed.
+
+Lemma STh_plus_opp_opp : forall x y:A, - x + - y == - (x + y).
+intros.
+apply Saux2 with (x + y); auto.
+rewrite (STh_plus_permute (x + y) (- x) (- y)).
+rewrite <- (plus_assoc x y (- y)).
+rewrite (opp_def y); rewrite (STh_plus_zero_right x).
+rewrite (STh_opp_def2 x); trivial.
+Qed.
+
+Lemma STh_plus_permute_opp : forall n m p:A, - m + (n + p) == n + (- m + p).
+auto.
+Qed.
+
+Lemma STh_opp_opp : forall n:A, - - n == n.
+intro.
+apply Saux2 with (- n); auto.
+rewrite (plus_comm (- n) n); auto.
+Qed.
+Hint Resolve STh_opp_opp.
+
+Lemma STh_opp_opp2 : forall n:A, n == - - n.
+auto.
+Qed.
+
+Lemma STh_mult_opp_opp : forall x y:A, - x * - y == x * y.
+intros.
+rewrite (STh_opp_mult_left2 x (- y)).
+rewrite (STh_opp_mult_right2 x y).
+trivial.
+Qed.
+
+Lemma STh_mult_opp_opp2 : forall x y:A, x * y == - x * - y.
+intros.
+apply equiv_sym.
+apply STh_mult_opp_opp.
+Qed.
+
+Lemma STh_opp_zero : - 0 == 0.
+rewrite <- (plus_zero_left (- 0)).
+trivial.
+Qed.
+
+Lemma STh_plus_reg_left : forall n m p:A, n + m == n + p -> m == p.
+intros.
+rewrite <- (plus_zero_left m).
+rewrite <- (plus_zero_left p).
+rewrite <- (opp_def n).
+rewrite (plus_comm n (- n)).
+rewrite <- (plus_assoc (- n) n m).
+rewrite <- (plus_assoc (- n) n p).
+auto.
+Qed.
+
+Lemma STh_plus_reg_right : forall n m p:A, m + n == p + n -> m == p.
+intros.
+apply STh_plus_reg_left with n.
+rewrite (plus_comm n m); rewrite (plus_comm n p); assumption.
+Qed.
+
+Lemma STh_distr_right : forall n m p:A, n * (m + p) == n * m + n * p.
+intros.
+rewrite (mult_comm n (m + p)).
+rewrite (mult_comm n m).
+rewrite (mult_comm n p).
+trivial.
+Qed.
+
+Lemma STh_distr_right2 : forall n m p:A, n * m + n * p == n * (m + p).
+intros.
+apply equiv_sym.
+apply STh_distr_right.
+Qed.
+
+End Theory_of_setoid_rings.
+
+Hint Resolve STh_mult_zero_left STh_plus_reg_left: core.
+
+Unset Implicit Arguments.
+
+Definition Semi_Setoid_Ring_Theory_of :
+ Setoid_Ring_Theory -> Semi_Setoid_Ring_Theory.
+intros until 1; case H.
+split; intros; simpl in |- *; eauto.
+Defined.
+
+Coercion Semi_Setoid_Ring_Theory_of : Setoid_Ring_Theory >->
+ Semi_Setoid_Ring_Theory.
+
+
+
+Section product_ring.
+
+End product_ring.
+
+Section power_ring.
+
+End power_ring.
+
+End Setoid_rings.
diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4
new file mode 100644
index 00000000..d766e344
--- /dev/null
+++ b/plugins/ring/g_ring.ml4
@@ -0,0 +1,136 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Quote
+open Ring
+open Tacticals
+
+TACTIC EXTEND ring
+| [ "legacy" "ring" constr_list(l) ] -> [ polynom l ]
+END
+
+(* The vernac commands "Add Ring" and co *)
+
+let cset_of_constrarg_list l =
+ List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty
+
+VERNAC COMMAND EXTEND AddRing
+ [ "Add" "Legacy" "Ring"
+ constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
+ constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ]
+ -> [ add_theory true false false
+ (constr_of a)
+ None
+ None
+ None
+ (constr_of aplus)
+ (constr_of amult)
+ (constr_of aone)
+ (constr_of azero)
+ (Some (constr_of aopp))
+ (constr_of aeq)
+ (constr_of t)
+ (cset_of_constrarg_list l) ]
+
+| [ "Add" "Legacy" "Semi" "Ring"
+ constr(a) constr(aplus) constr(amult) constr(aone) constr(azero)
+ constr(aeq) constr(t) "[" ne_constr_list(l) "]" ]
+ -> [ add_theory false false false
+ (constr_of a)
+ None
+ None
+ None
+ (constr_of aplus)
+ (constr_of amult)
+ (constr_of aone)
+ (constr_of azero)
+ None
+ (constr_of aeq)
+ (constr_of t)
+ (cset_of_constrarg_list l) ]
+
+| [ "Add" "Legacy" "Abstract" "Ring"
+ constr(a) constr(aplus) constr(amult) constr(aone)
+ constr(azero) constr(aopp) constr(aeq) constr(t) ]
+ -> [ add_theory true true false
+ (constr_of a)
+ None
+ None
+ None
+ (constr_of aplus)
+ (constr_of amult)
+ (constr_of aone)
+ (constr_of azero)
+ (Some (constr_of aopp))
+ (constr_of aeq)
+ (constr_of t)
+ ConstrSet.empty ]
+
+| [ "Add" "Legacy" "Abstract" "Semi" "Ring"
+ constr(a) constr(aplus) constr(amult) constr(aone)
+ constr(azero) constr(aeq) constr(t) ]
+ -> [ add_theory false true false
+ (constr_of a)
+ None
+ None
+ None
+ (constr_of aplus)
+ (constr_of amult)
+ (constr_of aone)
+ (constr_of azero)
+ None
+ (constr_of aeq)
+ (constr_of t)
+ ConstrSet.empty ]
+
+| [ "Add" "Legacy" "Setoid" "Ring"
+ constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult)
+ constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm)
+ constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ]
+ -> [ add_theory true false true
+ (constr_of a)
+ (Some (constr_of aequiv))
+ (Some (constr_of asetth))
+ (Some {
+ plusm = (constr_of pm);
+ multm = (constr_of mm);
+ oppm = Some (constr_of om) })
+ (constr_of aplus)
+ (constr_of amult)
+ (constr_of aone)
+ (constr_of azero)
+ (Some (constr_of aopp))
+ (constr_of aeq)
+ (constr_of t)
+ (cset_of_constrarg_list l) ]
+
+| [ "Add" "Legacy" "Semi" "Setoid" "Ring"
+ constr(a) constr(aequiv) constr(asetth) constr(aplus)
+ constr(amult) constr(aone) constr(azero) constr(aeq)
+ constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ]
+ -> [ add_theory false false true
+ (constr_of a)
+ (Some (constr_of aequiv))
+ (Some (constr_of asetth))
+ (Some {
+ plusm = (constr_of pm);
+ multm = (constr_of mm);
+ oppm = None })
+ (constr_of aplus)
+ (constr_of amult)
+ (constr_of aone)
+ (constr_of azero)
+ None
+ (constr_of aeq)
+ (constr_of t)
+ (cset_of_constrarg_list l) ]
+END
diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml
new file mode 100644
index 00000000..1e3765da
--- /dev/null
+++ b/plugins/ring/ring.ml
@@ -0,0 +1,924 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* ML part of the Ring tactic *)
+
+open Pp
+open Util
+open Flags
+open Term
+open Names
+open Libnames
+open Nameops
+open Reductionops
+open Tacticals
+open Tacexpr
+open Tacmach
+open Proof_trees
+open Printer
+open Equality
+open Vernacinterp
+open Vernacexpr
+open Libobject
+open Closure
+open Tacred
+open Tactics
+open Pattern
+open Hiddentac
+open Nametab
+open Quote
+open Mod_subst
+
+let mt_evd = Evd.empty
+let constr_of c = Constrintern.interp_constr mt_evd (Global.env()) c
+
+let ring_dir = ["Coq";"ring"]
+let setoids_dir = ["Coq";"Setoids"]
+
+let ring_constant = Coqlib.gen_constant_in_modules "Ring"
+ [ring_dir@["LegacyRing_theory"];
+ ring_dir@["Setoid_ring_theory"];
+ ring_dir@["Ring_normalize"];
+ ring_dir@["Ring_abstract"];
+ setoids_dir@["Setoid"];
+ ring_dir@["Setoid_ring_normalize"]]
+
+(* Ring theory *)
+let coq_Ring_Theory = lazy (ring_constant "Ring_Theory")
+let coq_Semi_Ring_Theory = lazy (ring_constant "Semi_Ring_Theory")
+
+(* Setoid ring theory *)
+let coq_Setoid_Ring_Theory = lazy (ring_constant "Setoid_Ring_Theory")
+let coq_Semi_Setoid_Ring_Theory = lazy(ring_constant "Semi_Setoid_Ring_Theory")
+
+(* Ring normalize *)
+let coq_SPplus = lazy (ring_constant "SPplus")
+let coq_SPmult = lazy (ring_constant "SPmult")
+let coq_SPvar = lazy (ring_constant "SPvar")
+let coq_SPconst = lazy (ring_constant "SPconst")
+let coq_Pplus = lazy (ring_constant "Pplus")
+let coq_Pmult = lazy (ring_constant "Pmult")
+let coq_Pvar = lazy (ring_constant "Pvar")
+let coq_Pconst = lazy (ring_constant "Pconst")
+let coq_Popp = lazy (ring_constant "Popp")
+let coq_interp_sp = lazy (ring_constant "interp_sp")
+let coq_interp_p = lazy (ring_constant "interp_p")
+let coq_interp_cs = lazy (ring_constant "interp_cs")
+let coq_spolynomial_simplify = lazy (ring_constant "spolynomial_simplify")
+let coq_polynomial_simplify = lazy (ring_constant "polynomial_simplify")
+let coq_spolynomial_simplify_ok = lazy(ring_constant "spolynomial_simplify_ok")
+let coq_polynomial_simplify_ok = lazy (ring_constant "polynomial_simplify_ok")
+
+(* Setoid theory *)
+let coq_Setoid_Theory = lazy(ring_constant "Setoid_Theory")
+
+let coq_seq_refl = lazy(ring_constant "Seq_refl")
+let coq_seq_sym = lazy(ring_constant "Seq_sym")
+let coq_seq_trans = lazy(ring_constant "Seq_trans")
+
+(* Setoid Ring normalize *)
+let coq_SetSPplus = lazy (ring_constant "SetSPplus")
+let coq_SetSPmult = lazy (ring_constant "SetSPmult")
+let coq_SetSPvar = lazy (ring_constant "SetSPvar")
+let coq_SetSPconst = lazy (ring_constant "SetSPconst")
+let coq_SetPplus = lazy (ring_constant "SetPplus")
+let coq_SetPmult = lazy (ring_constant "SetPmult")
+let coq_SetPvar = lazy (ring_constant "SetPvar")
+let coq_SetPconst = lazy (ring_constant "SetPconst")
+let coq_SetPopp = lazy (ring_constant "SetPopp")
+let coq_interp_setsp = lazy (ring_constant "interp_setsp")
+let coq_interp_setp = lazy (ring_constant "interp_setp")
+let coq_interp_setcs = lazy (ring_constant "interp_setcs")
+let coq_setspolynomial_simplify =
+ lazy (ring_constant "setspolynomial_simplify")
+let coq_setpolynomial_simplify =
+ lazy (ring_constant "setpolynomial_simplify")
+let coq_setspolynomial_simplify_ok =
+ lazy (ring_constant "setspolynomial_simplify_ok")
+let coq_setpolynomial_simplify_ok =
+ lazy (ring_constant "setpolynomial_simplify_ok")
+
+(* Ring abstract *)
+let coq_ASPplus = lazy (ring_constant "ASPplus")
+let coq_ASPmult = lazy (ring_constant "ASPmult")
+let coq_ASPvar = lazy (ring_constant "ASPvar")
+let coq_ASP0 = lazy (ring_constant "ASP0")
+let coq_ASP1 = lazy (ring_constant "ASP1")
+let coq_APplus = lazy (ring_constant "APplus")
+let coq_APmult = lazy (ring_constant "APmult")
+let coq_APvar = lazy (ring_constant "APvar")
+let coq_AP0 = lazy (ring_constant "AP0")
+let coq_AP1 = lazy (ring_constant "AP1")
+let coq_APopp = lazy (ring_constant "APopp")
+let coq_interp_asp = lazy (ring_constant "interp_asp")
+let coq_interp_ap = lazy (ring_constant "interp_ap")
+let coq_interp_acs = lazy (ring_constant "interp_acs")
+let coq_interp_sacs = lazy (ring_constant "interp_sacs")
+let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize")
+let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize")
+let coq_aspolynomial_normalize_ok =
+ lazy (ring_constant "aspolynomial_normalize_ok")
+let coq_apolynomial_normalize_ok =
+ lazy (ring_constant "apolynomial_normalize_ok")
+
+(* Logic --> to be found in Coqlib *)
+open Coqlib
+
+let mkLApp(fc,v) = mkApp(Lazy.force fc, v)
+
+(*********** Useful types and functions ************)
+
+module OperSet =
+ Set.Make (struct
+ type t = global_reference
+ let compare = (Pervasives.compare : t->t->int)
+ end)
+
+type morph =
+ { plusm : constr;
+ multm : constr;
+ oppm : constr option;
+ }
+
+type theory =
+ { th_ring : bool; (* false for a semi-ring *)
+ th_abstract : bool;
+ th_setoid : bool; (* true for a setoid ring *)
+ th_equiv : constr option;
+ th_setoid_th : constr option;
+ th_morph : morph option;
+ th_a : constr; (* e.g. nat *)
+ th_plus : constr;
+ th_mult : constr;
+ th_one : constr;
+ th_zero : constr;
+ th_opp : constr option; (* None if semi-ring *)
+ th_eq : constr;
+ th_t : constr; (* e.g. NatTheory *)
+ th_closed : ConstrSet.t; (* e.g. [S; O] *)
+ (* Must be empty for an abstract ring *)
+ }
+
+(* Theories are stored in a table which is synchronised with the Reset
+ mechanism. *)
+
+module Cmap = Map.Make(struct type t = constr let compare = compare end)
+
+let theories_map = ref Cmap.empty
+
+let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map
+let theories_map_find c = Cmap.find c !theories_map
+let theories_map_mem c = Cmap.mem c !theories_map
+
+let _ =
+ Summary.declare_summary "tactic-ring-table"
+ { Summary.freeze_function = (fun () -> !theories_map);
+ Summary.unfreeze_function = (fun t -> theories_map := t);
+ Summary.init_function = (fun () -> theories_map := Cmap.empty) }
+
+(* declare a new type of object in the environment, "tactic-ring-theory"
+ The functions theory_to_obj and obj_to_theory do the conversions
+ between theories and environement objects. *)
+
+
+let subst_morph subst morph =
+ let plusm' = subst_mps subst morph.plusm in
+ let multm' = subst_mps subst morph.multm in
+ let oppm' = Option.smartmap (subst_mps subst) morph.oppm in
+ if plusm' == morph.plusm
+ && multm' == morph.multm
+ && oppm' == morph.oppm then
+ morph
+ else
+ { plusm = plusm' ;
+ multm = multm' ;
+ oppm = oppm' ;
+ }
+
+let subst_set subst cset =
+ let same = ref true in
+ let copy_subst c newset =
+ let c' = subst_mps subst c in
+ if not (c' == c) then same := false;
+ ConstrSet.add c' newset
+ in
+ let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in
+ if !same then cset else cset'
+
+let subst_theory subst th =
+ let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in
+ let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in
+ let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in
+ let th_a' = subst_mps subst th.th_a in
+ let th_plus' = subst_mps subst th.th_plus in
+ let th_mult' = subst_mps subst th.th_mult in
+ let th_one' = subst_mps subst th.th_one in
+ let th_zero' = subst_mps subst th.th_zero in
+ let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in
+ let th_eq' = subst_mps subst th.th_eq in
+ let th_t' = subst_mps subst th.th_t in
+ let th_closed' = subst_set subst th.th_closed in
+ if th_equiv' == th.th_equiv
+ && th_setoid_th' == th.th_setoid_th
+ && th_morph' == th.th_morph
+ && th_a' == th.th_a
+ && th_plus' == th.th_plus
+ && th_mult' == th.th_mult
+ && th_one' == th.th_one
+ && th_zero' == th.th_zero
+ && th_opp' == th.th_opp
+ && th_eq' == th.th_eq
+ && th_t' == th.th_t
+ && th_closed' == th.th_closed
+ then
+ th
+ else
+ { th_ring = th.th_ring ;
+ th_abstract = th.th_abstract ;
+ th_setoid = th.th_setoid ;
+ th_equiv = th_equiv' ;
+ th_setoid_th = th_setoid_th' ;
+ th_morph = th_morph' ;
+ th_a = th_a' ;
+ th_plus = th_plus' ;
+ th_mult = th_mult' ;
+ th_one = th_one' ;
+ th_zero = th_zero' ;
+ th_opp = th_opp' ;
+ th_eq = th_eq' ;
+ th_t = th_t' ;
+ th_closed = th_closed' ;
+ }
+
+
+let subst_th (subst,(c,th as obj)) =
+ let c' = subst_mps subst c in
+ let th' = subst_theory subst th in
+ if c' == c && th' == th then obj else
+ (c',th')
+
+
+let (theory_to_obj, obj_to_theory) =
+ let cache_th (_,(c, th)) = theories_map_add (c,th) in
+ declare_object {(default_object "tactic-ring-theory") with
+ open_function = (fun i o -> if i=1 then cache_th o);
+ cache_function = cache_th;
+ subst_function = subst_th;
+ classify_function = (fun x -> Substitute x) }
+
+(* from the set A, guess the associated theory *)
+(* With this simple solution, the theory to use is automatically guessed *)
+(* But only one theory can be declared for a given Set *)
+
+let guess_theory a =
+ try
+ theories_map_find a
+ with Not_found ->
+ errorlabstrm "Ring"
+ (str "No Declared Ring Theory for " ++
+ pr_lconstr a ++ fnl () ++
+ str "Use Add [Semi] Ring to declare it")
+
+(* Looks up an option *)
+
+let unbox = function
+ | Some w -> w
+ | None -> anomaly "Ring : Not in case of a setoid ring."
+
+(* Protects the convertibility test against undue exceptions when using it
+ with untyped terms *)
+
+let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false
+
+
+(* Add a Ring or a Semi-Ring to the database after a type verification *)
+
+let implement_theory env t th args =
+ is_conv env Evd.empty (Typing.type_of env Evd.empty t) (mkLApp (th, args))
+
+(* (\* The following test checks whether the provided morphism is the default *)
+(* one for the given operation. In principle the test is too strict, since *)
+(* it should possible to provide another proof for the same fact (proof *)
+(* irrelevance). In particular, the error message is be not very explicative. *\) *)
+let states_compatibility_for env plus mult opp morphs =
+ let check op compat = true in
+(* is_conv env Evd.empty (Setoid_replace.default_morphism op).Setoid_replace.lem *)
+(* compat in *)
+ check plus morphs.plusm &&
+ check mult morphs.multm &&
+ (match (opp,morphs.oppm) with
+ None, None -> true
+ | Some opp, Some compat -> check opp compat
+ | _,_ -> assert false)
+
+let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset =
+ if theories_map_mem a then errorlabstrm "Add Semi Ring"
+ (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++
+ pr_lconstr a);
+ let env = Global.env () in
+ if (want_ring & want_setoid & (
+ not (implement_theory env t coq_Setoid_Ring_Theory
+ [| a; (unbox aequiv); aplus; amult; aone; azero; (unbox aopp); aeq|])
+ ||
+ not (implement_theory env (unbox asetth) coq_Setoid_Theory
+ [| a; (unbox aequiv) |]) ||
+ not (states_compatibility_for env aplus amult aopp (unbox amorph))
+ )) then
+ errorlabstrm "addring" (str "Not a valid Setoid-Ring theory");
+ if (not want_ring & want_setoid & (
+ not (implement_theory env t coq_Semi_Setoid_Ring_Theory
+ [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) ||
+ not (implement_theory env (unbox asetth) coq_Setoid_Theory
+ [| a; (unbox aequiv) |]) ||
+ not (states_compatibility_for env aplus amult aopp (unbox amorph))))
+ then
+ errorlabstrm "addring" (str "Not a valid Semi-Setoid-Ring theory");
+ if (want_ring & not want_setoid &
+ not (implement_theory env t coq_Ring_Theory
+ [| a; aplus; amult; aone; azero; (unbox aopp); aeq |])) then
+ errorlabstrm "addring" (str "Not a valid Ring theory");
+ if (not want_ring & not want_setoid &
+ not (implement_theory env t coq_Semi_Ring_Theory
+ [| a; aplus; amult; aone; azero; aeq |])) then
+ errorlabstrm "addring" (str "Not a valid Semi-Ring theory");
+ Lib.add_anonymous_leaf
+ (theory_to_obj
+ (a, { th_ring = want_ring;
+ th_abstract = want_abstract;
+ th_setoid = want_setoid;
+ th_equiv = aequiv;
+ th_setoid_th = asetth;
+ th_morph = amorph;
+ th_a = a;
+ th_plus = aplus;
+ th_mult = amult;
+ th_one = aone;
+ th_zero = azero;
+ th_opp = aopp;
+ th_eq = aeq;
+ th_t = t;
+ th_closed = cset }))
+
+(******** The tactic itself *********)
+
+(*
+ gl : goal sigma
+ th : semi-ring theory (concrete)
+ cl : constr list [c1; c2; ...]
+
+Builds
+ - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
+ where c'i is convertible with ci and
+ c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_spolynom gl th lc =
+ let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+ let varlist = ref ([] : constr list) in (* list of variables *)
+ let counter = ref 1 in (* number of variables created + 1 *)
+ (* aux creates the spolynom p by a recursive destructuration of c
+ and builds the varmap with side-effects *)
+ let rec aux c =
+ match (kind_of_term (strip_outer_cast c)) with
+ | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+ mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |])
+ | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+ mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |])
+ | _ when closed_under th.th_closed c ->
+ mkLApp(coq_SPconst, [|th.th_a; c |])
+ | _ ->
+ try Hashtbl.find varhash c
+ with Not_found ->
+ let newvar =
+ mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in
+ begin
+ incr counter;
+ varlist := c :: !varlist;
+ Hashtbl.add varhash c newvar;
+ newvar
+ end
+ in
+ let lp = List.map aux lc in
+ let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
+ List.map
+ (fun p ->
+ (mkLApp (coq_interp_sp,
+ [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
+ mkLApp (coq_interp_cs,
+ [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
+ pf_reduce cbv_betadeltaiota gl
+ (mkLApp (coq_spolynomial_simplify,
+ [| th.th_a; th.th_plus; th.th_mult;
+ th.th_one; th.th_zero;
+ th.th_eq; p|])) |]),
+ mkLApp (coq_spolynomial_simplify_ok,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
+ th.th_eq; v; th.th_t; p |])))
+ lp
+
+(*
+ gl : goal sigma
+ th : ring theory (concrete)
+ cl : constr list [c1; c2; ...]
+
+Builds
+ - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
+ where c'i is convertible with ci and
+ c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_polynom gl th lc =
+ let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+ let varlist = ref ([] : constr list) in (* list of variables *)
+ let counter = ref 1 in (* number of variables created + 1 *)
+ let rec aux c =
+ match (kind_of_term (strip_outer_cast c)) with
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+ mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |])
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+ mkLApp(coq_Pmult, [|th.th_a; aux c1; aux c2 |])
+ (* The special case of Zminus *)
+ | App (binop, [|c1; c2|])
+ when safe_pf_conv_x gl c
+ (mkApp (th.th_plus, [|c1; mkApp(unbox th.th_opp, [|c2|])|])) ->
+ mkLApp(coq_Pplus,
+ [|th.th_a; aux c1;
+ mkLApp(coq_Popp, [|th.th_a; aux c2|]) |])
+ | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
+ mkLApp(coq_Popp, [|th.th_a; aux c1|])
+ | _ when closed_under th.th_closed c ->
+ mkLApp(coq_Pconst, [|th.th_a; c |])
+ | _ ->
+ try Hashtbl.find varhash c
+ with Not_found ->
+ let newvar =
+ mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in
+ begin
+ incr counter;
+ varlist := c :: !varlist;
+ Hashtbl.add varhash c newvar;
+ newvar
+ end
+ in
+ let lp = List.map aux lc in
+ let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
+ List.map
+ (fun p ->
+ (mkLApp(coq_interp_p,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
+ (unbox th.th_opp); v; p |])),
+ mkLApp(coq_interp_cs,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
+ pf_reduce cbv_betadeltaiota gl
+ (mkLApp(coq_polynomial_simplify,
+ [| th.th_a; th.th_plus; th.th_mult;
+ th.th_one; th.th_zero;
+ (unbox th.th_opp); th.th_eq; p |])) |]),
+ mkLApp(coq_polynomial_simplify_ok,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
+ (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))
+ lp
+
+(*
+ gl : goal sigma
+ th : semi-ring theory (abstract)
+ cl : constr list [c1; c2; ...]
+
+Builds
+ - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
+ where c'i is convertible with ci and
+ c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_aspolynom gl th lc =
+ let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+ let varlist = ref ([] : constr list) in (* list of variables *)
+ let counter = ref 1 in (* number of variables created + 1 *)
+ (* aux creates the aspolynom p by a recursive destructuration of c
+ and builds the varmap with side-effects *)
+ let rec aux c =
+ match (kind_of_term (strip_outer_cast c)) with
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+ mkLApp(coq_ASPplus, [| aux c1; aux c2 |])
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+ mkLApp(coq_ASPmult, [| aux c1; aux c2 |])
+ | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0
+ | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1
+ | _ ->
+ try Hashtbl.find varhash c
+ with Not_found ->
+ let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in
+ begin
+ incr counter;
+ varlist := c :: !varlist;
+ Hashtbl.add varhash c newvar;
+ newvar
+ end
+ in
+ let lp = List.map aux lc in
+ let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in
+ List.map
+ (fun p ->
+ (mkLApp(coq_interp_asp,
+ [| th.th_a; th.th_plus; th.th_mult;
+ th.th_one; th.th_zero; v; p |]),
+ mkLApp(coq_interp_acs,
+ [| th.th_a; th.th_plus; th.th_mult;
+ th.th_one; th.th_zero; v;
+ pf_reduce cbv_betadeltaiota gl
+ (mkLApp(coq_aspolynomial_normalize,[|p|])) |]),
+ mkLApp(coq_spolynomial_simplify_ok,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
+ th.th_eq; v; th.th_t; p |])))
+ lp
+
+(*
+ gl : goal sigma
+ th : ring theory (abstract)
+ cl : constr list [c1; c2; ...]
+
+Builds
+ - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
+ where c'i is convertible with ci and
+ c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_apolynom gl th lc =
+ let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+ let varlist = ref ([] : constr list) in (* list of variables *)
+ let counter = ref 1 in (* number of variables created + 1 *)
+ let rec aux c =
+ match (kind_of_term (strip_outer_cast c)) with
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+ mkLApp(coq_APplus, [| aux c1; aux c2 |])
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+ mkLApp(coq_APmult, [| aux c1; aux c2 |])
+ (* The special case of Zminus *)
+ | App (binop, [|c1; c2|])
+ when safe_pf_conv_x gl c
+ (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) ->
+ mkLApp(coq_APplus,
+ [|aux c1; mkLApp(coq_APopp,[|aux c2|]) |])
+ | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
+ mkLApp(coq_APopp, [| aux c1 |])
+ | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0
+ | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1
+ | _ ->
+ try Hashtbl.find varhash c
+ with Not_found ->
+ let newvar =
+ mkLApp(coq_APvar, [| path_of_int !counter |]) in
+ begin
+ incr counter;
+ varlist := c :: !varlist;
+ Hashtbl.add varhash c newvar;
+ newvar
+ end
+ in
+ let lp = List.map aux lc in
+ let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
+ List.map
+ (fun p ->
+ (mkLApp(coq_interp_ap,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_one;
+ th.th_zero; (unbox th.th_opp); v; p |]),
+ mkLApp(coq_interp_sacs,
+ [| th.th_a; th.th_plus; th.th_mult;
+ th.th_one; th.th_zero; (unbox th.th_opp); v;
+ pf_reduce cbv_betadeltaiota gl
+ (mkLApp(coq_apolynomial_normalize, [|p|])) |]),
+ mkLApp(coq_apolynomial_normalize_ok,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero;
+ (unbox th.th_opp); th.th_eq; v; th.th_t; p |])))
+ lp
+
+(*
+ gl : goal sigma
+ th : setoid ring theory (concrete)
+ cl : constr list [c1; c2; ...]
+
+Builds
+ - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
+ where c'i is convertible with ci and
+ c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_setpolynom gl th lc =
+ let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+ let varlist = ref ([] : constr list) in (* list of variables *)
+ let counter = ref 1 in (* number of variables created + 1 *)
+ let rec aux c =
+ match (kind_of_term (strip_outer_cast c)) with
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+ mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |])
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+ mkLApp(coq_SetPmult, [|th.th_a; aux c1; aux c2 |])
+ (* The special case of Zminus *)
+ | App (binop, [|c1; c2|])
+ when safe_pf_conv_x gl c
+ (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|])|])) ->
+ mkLApp(coq_SetPplus,
+ [| th.th_a; aux c1;
+ mkLApp(coq_SetPopp, [|th.th_a; aux c2|]) |])
+ | App (unop, [|c1|]) when safe_pf_conv_x gl unop (unbox th.th_opp) ->
+ mkLApp(coq_SetPopp, [| th.th_a; aux c1 |])
+ | _ when closed_under th.th_closed c ->
+ mkLApp(coq_SetPconst, [| th.th_a; c |])
+ | _ ->
+ try Hashtbl.find varhash c
+ with Not_found ->
+ let newvar =
+ mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in
+ begin
+ incr counter;
+ varlist := c :: !varlist;
+ Hashtbl.add varhash c newvar;
+ newvar
+ end
+ in
+ let lp = List.map aux lc in
+ let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
+ List.map
+ (fun p ->
+ (mkLApp(coq_interp_setp,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_zero;
+ (unbox th.th_opp); v; p |]),
+ mkLApp(coq_interp_setcs,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
+ pf_reduce cbv_betadeltaiota gl
+ (mkLApp(coq_setpolynomial_simplify,
+ [| th.th_a; th.th_plus; th.th_mult;
+ th.th_one; th.th_zero;
+ (unbox th.th_opp); th.th_eq; p |])) |]),
+ mkLApp(coq_setpolynomial_simplify_ok,
+ [| th.th_a; (unbox th.th_equiv); th.th_plus;
+ th.th_mult; th.th_one; th.th_zero;(unbox th.th_opp);
+ th.th_eq; (unbox th.th_setoid_th);
+ (unbox th.th_morph).plusm; (unbox th.th_morph).multm;
+ (unbox (unbox th.th_morph).oppm); v; th.th_t; p |])))
+ lp
+
+(*
+ gl : goal sigma
+ th : semi setoid ring theory (concrete)
+ cl : constr list [c1; c2; ...]
+
+Builds
+ - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ]
+ where c'i is convertible with ci and
+ c'i_eq_c''i is a proof of equality of c'i and c''i
+
+*)
+
+let build_setspolynom gl th lc =
+ let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in
+ let varlist = ref ([] : constr list) in (* list of variables *)
+ let counter = ref 1 in (* number of variables created + 1 *)
+ let rec aux c =
+ match (kind_of_term (strip_outer_cast c)) with
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus ->
+ mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |])
+ | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult ->
+ mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |])
+ | _ when closed_under th.th_closed c ->
+ mkLApp(coq_SetSPconst, [| th.th_a; c |])
+ | _ ->
+ try Hashtbl.find varhash c
+ with Not_found ->
+ let newvar =
+ mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in
+ begin
+ incr counter;
+ varlist := c :: !varlist;
+ Hashtbl.add varhash c newvar;
+ newvar
+ end
+ in
+ let lp = List.map aux lc in
+ let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in
+ List.map
+ (fun p ->
+ (mkLApp(coq_interp_setsp,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]),
+ mkLApp(coq_interp_setcs,
+ [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v;
+ pf_reduce cbv_betadeltaiota gl
+ (mkLApp(coq_setspolynomial_simplify,
+ [| th.th_a; th.th_plus; th.th_mult;
+ th.th_one; th.th_zero;
+ th.th_eq; p |])) |]),
+ mkLApp(coq_setspolynomial_simplify_ok,
+ [| th.th_a; (unbox th.th_equiv); th.th_plus;
+ th.th_mult; th.th_one; th.th_zero; th.th_eq;
+ (unbox th.th_setoid_th);
+ (unbox th.th_morph).plusm;
+ (unbox th.th_morph).multm; v; th.th_t; p |])))
+ lp
+
+module SectionPathSet =
+ Set.Make(struct
+ type t = full_path
+ let compare = Pervasives.compare
+ end)
+
+(* Avec l'uniformisation des red_kind, on perd ici sur la structure
+ SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *)
+let constants_to_unfold =
+(* List.fold_right SectionPathSet.add *)
+ let transform s =
+ let sp = path_of_string s in
+ let dir, id = repr_path sp in
+ Libnames.encode_con dir id
+ in
+ List.map transform
+ [ "Coq.ring.Ring_normalize.interp_cs";
+ "Coq.ring.Ring_normalize.interp_var";
+ "Coq.ring.Ring_normalize.interp_vl";
+ "Coq.ring.Ring_abstract.interp_acs";
+ "Coq.ring.Ring_abstract.interp_sacs";
+ "Coq.quote.Quote.varmap_find";
+ (* anciennement des Local devenus Definition *)
+ "Coq.ring.Ring_normalize.ics_aux";
+ "Coq.ring.Ring_normalize.ivl_aux";
+ "Coq.ring.Ring_normalize.interp_m";
+ "Coq.ring.Ring_abstract.iacs_aux";
+ "Coq.ring.Ring_abstract.isacs_aux";
+ "Coq.ring.Setoid_ring_normalize.interp_cs";
+ "Coq.ring.Setoid_ring_normalize.interp_var";
+ "Coq.ring.Setoid_ring_normalize.interp_vl";
+ "Coq.ring.Setoid_ring_normalize.ics_aux";
+ "Coq.ring.Setoid_ring_normalize.ivl_aux";
+ "Coq.ring.Setoid_ring_normalize.interp_m";
+ ]
+(* SectionPathSet.empty *)
+
+(* Unfolds the functions interp and find_btree in the term c of goal gl *)
+open RedFlags
+let polynom_unfold_tac =
+ let flags =
+ (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in
+ reduct_in_concl (cbv_norm_flags flags,DEFAULTcast)
+
+let polynom_unfold_tac_in_term gl =
+ let flags =
+ (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold)))
+ in
+ cbv_norm_flags flags (pf_env gl) (project gl)
+
+(* lc : constr list *)
+(* th : theory associated to t *)
+(* op : clause (None for conclusion or Some id for hypothesis id) *)
+(* gl : goal *)
+(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i))
+ where the ring R, the Ring theory RC, the varmap v and the polynomials p_i
+ are guessed and such that c_i = (interp R RC v p_i) *)
+let raw_polynom th op lc gl =
+ (* first we sort the terms : if t' is a subterm of t it must appear
+ after t in the list. This is to avoid that the normalization of t'
+ modifies t in a non-desired way *)
+ let lc = sort_subterm gl lc in
+ let ltriplets =
+ if th.th_setoid then
+ if th.th_ring
+ then build_setpolynom gl th lc
+ else build_setspolynom gl th lc
+ else
+ if th.th_ring then
+ if th.th_abstract
+ then build_apolynom gl th lc
+ else build_polynom gl th lc
+ else
+ if th.th_abstract
+ then build_aspolynom gl th lc
+ else build_spolynom gl th lc in
+ let polynom_tac =
+ List.fold_right2
+ (fun ci (c'i, c''i, c'i_eq_c''i) tac ->
+ let c'''i =
+ if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i
+ in
+ if !term_quality && safe_pf_conv_x gl c'''i ci then
+ tac (* convertible terms *)
+ else if th.th_setoid
+ then
+ (tclORELSE
+ (tclORELSE
+ (h_exact c'i_eq_c''i)
+ (h_exact (mkLApp(coq_seq_sym,
+ [| th.th_a; (unbox th.th_equiv);
+ (unbox th.th_setoid_th);
+ c'''i; ci; c'i_eq_c''i |]))))
+ (tclTHENS
+ (tclORELSE
+ (Equality.general_rewrite true
+ Termops.all_occurrences false c'i_eq_c''i)
+ (Equality.general_rewrite false
+ Termops.all_occurrences false c'i_eq_c''i))
+ [tac]))
+ else
+ (tclORELSE
+ (tclORELSE
+ (h_exact c'i_eq_c''i)
+ (h_exact (mkApp(build_coq_eq_sym (),
+ [|th.th_a; c'''i; ci; c'i_eq_c''i |]))))
+ (tclTHENS
+ (elim_type
+ (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |])))
+ [ tac;
+ h_exact c'i_eq_c''i ]))
+)
+ lc ltriplets polynom_unfold_tac
+ in
+ polynom_tac gl
+
+let guess_eq_tac th =
+ (tclORELSE reflexivity
+ (tclTHEN
+ polynom_unfold_tac
+ (tclTHEN
+ (* Normalized sums associate on the right *)
+ (tclREPEAT
+ (tclTHENFIRST
+ (apply (mkApp(build_coq_f_equal2 (),
+ [| th.th_a; th.th_a; th.th_a;
+ th.th_plus |])))
+ reflexivity))
+ (tclTRY
+ (tclTHENLAST
+ (apply (mkApp(build_coq_f_equal2 (),
+ [| th.th_a; th.th_a; th.th_a;
+ th.th_plus |])))
+ reflexivity)))))
+
+let guess_equiv_tac th =
+ (tclORELSE (apply (mkLApp(coq_seq_refl,
+ [| th.th_a; (unbox th.th_equiv);
+ (unbox th.th_setoid_th)|])))
+ (tclTHEN
+ polynom_unfold_tac
+ (tclREPEAT
+ (tclORELSE
+ (apply (unbox th.th_morph).plusm)
+ (apply (unbox th.th_morph).multm)))))
+
+let match_with_equiv c = match (kind_of_term c) with
+ | App (e,a) ->
+ if (List.mem e []) (* (Setoid_replace.equiv_list ())) *)
+ then Some (decompose_app c)
+ else None
+ | _ -> None
+
+let polynom lc gl =
+ Coqlib.check_required_library ["Coq";"ring";"LegacyRing"];
+ match lc with
+ (* If no argument is given, try to recognize either an equality or
+ a declared relation with arguments c1 ... cn,
+ do "Ring c1 c2 ... cn" and then try to apply the simplification
+ theorems declared for the relation *)
+ | [] ->
+ (try
+ match Hipattern.match_with_equation (pf_concl gl) with
+ | _,_,Hipattern.PolymorphicLeibnizEq (t,c1,c2) ->
+ let th = guess_theory t in
+ (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
+ | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2)
+ when safe_pf_conv_x gl t1 t2 ->
+ let th = guess_theory t1 in
+ (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl
+ | _ -> raise Exit
+ with Hipattern.NoEquationFound | Exit ->
+ (match match_with_equiv (pf_concl gl) with
+ | Some (equiv, c1::args) ->
+ let t = (pf_type_of gl c1) in
+ let th = (guess_theory t) in
+ if List.exists
+ (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args
+ then
+ errorlabstrm "Ring :"
+ (str" All terms must have the same type");
+ (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl
+ | _ -> errorlabstrm "polynom :"
+ (str" This goal is not an equality nor a setoid equivalence")))
+ (* Elsewhere, guess the theory, check that all terms have the same type
+ and apply raw_polynom *)
+ | c :: lc' ->
+ let t = pf_type_of gl c in
+ let th = guess_theory t in
+ if List.exists
+ (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc'
+ then
+ errorlabstrm "Ring :"
+ (str" All terms must have the same type");
+ (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl
diff --git a/plugins/ring/ring_plugin.mllib b/plugins/ring/ring_plugin.mllib
new file mode 100644
index 00000000..3c5f995f
--- /dev/null
+++ b/plugins/ring/ring_plugin.mllib
@@ -0,0 +1,3 @@
+Ring
+G_ring
+Ring_plugin_mod
diff --git a/plugins/ring/vo.itarget b/plugins/ring/vo.itarget
new file mode 100644
index 00000000..da387be8
--- /dev/null
+++ b/plugins/ring/vo.itarget
@@ -0,0 +1,10 @@
+LegacyArithRing.vo
+LegacyNArithRing.vo
+LegacyRing_theory.vo
+LegacyRing.vo
+LegacyZArithRing.vo
+Ring_abstract.vo
+Ring_normalize.vo
+Setoid_ring_normalize.vo
+Setoid_ring_theory.vo
+Setoid_ring.vo
diff --git a/plugins/romega/README b/plugins/romega/README
new file mode 100644
index 00000000..86c9e58a
--- /dev/null
+++ b/plugins/romega/README
@@ -0,0 +1,6 @@
+This work was done for the RNRT Project Calife.
+As such it is distributed under the LGPL licence.
+
+Report bugs to :
+ pierre.cregut@francetelecom.com
+
diff --git a/plugins/romega/ROmega.v b/plugins/romega/ROmega.v
new file mode 100644
index 00000000..3ddb6bed
--- /dev/null
+++ b/plugins/romega/ROmega.v
@@ -0,0 +1,14 @@
+(*************************************************************************
+
+ PROJET RNRT Calife - 2001
+ Author: Pierre Crégut - France Télécom R&D
+ Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+Require Import ReflOmegaCore.
+Require Export Setoid.
+Require Export PreOmega.
+Require Export ZArith_base.
+Require Import OmegaPlugin.
+Declare ML Module "romega_plugin". \ No newline at end of file
diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v
new file mode 100644
index 00000000..c82abfc8
--- /dev/null
+++ b/plugins/romega/ReflOmegaCore.v
@@ -0,0 +1,3216 @@
+(* -*- coding: utf-8 -*- *)
+(*************************************************************************
+
+ PROJET RNRT Calife - 2001
+ Author: Pierre Crégut - France Télécom R&D
+ Licence du projet : LGPL version 2.1
+
+ *************************************************************************)
+
+Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable ZArith_base.
+Delimit Scope Int_scope with I.
+
+(* Abstract Integers. *)
+
+Module Type Int.
+
+ Parameter int : Set.
+
+ Parameter zero : int.
+ Parameter one : int.
+ Parameter plus : int -> int -> int.
+ Parameter opp : int -> int.
+ Parameter minus : int -> int -> int.
+ Parameter mult : int -> int -> int.
+
+ Notation "0" := zero : Int_scope.
+ Notation "1" := one : Int_scope.
+ Infix "+" := plus : Int_scope.
+ Infix "-" := minus : Int_scope.
+ Infix "*" := mult : Int_scope.
+ Notation "- x" := (opp x) : Int_scope.
+
+ Open Scope Int_scope.
+
+ (* First, int is a ring: *)
+ Axiom ring : @ring_theory int 0 1 plus mult minus opp (@eq int).
+
+ (* int should also be ordered: *)
+
+ Parameter le : int -> int -> Prop.
+ Parameter lt : int -> int -> Prop.
+ Parameter ge : int -> int -> Prop.
+ Parameter gt : int -> int -> Prop.
+ Notation "x <= y" := (le x y): Int_scope.
+ Notation "x < y" := (lt x y) : Int_scope.
+ Notation "x >= y" := (ge x y) : Int_scope.
+ Notation "x > y" := (gt x y): Int_scope.
+ Axiom le_lt_iff : forall i j, (i<=j) <-> ~(j<i).
+ Axiom ge_le_iff : forall i j, (i>=j) <-> (j<=i).
+ Axiom gt_lt_iff : forall i j, (i>j) <-> (j<i).
+
+ (* Basic properties of this order *)
+ Axiom lt_trans : forall i j k, i<j -> j<k -> i<k.
+ Axiom lt_not_eq : forall i j, i<j -> i<>j.
+
+ (* Compatibilities *)
+ Axiom lt_0_1 : 0<1.
+ Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l.
+ Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i).
+ Axiom mult_lt_compat_l :
+ forall i j k, 0 < k -> i < j -> k*i<k*j.
+
+ (* We should have a way to decide the equality and the order*)
+ Parameter compare : int -> int -> comparison.
+ Infix "?=" := compare (at level 70, no associativity) : Int_scope.
+ Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j.
+ Axiom compare_Lt : forall i j, compare i j = Lt <-> i<j.
+ Axiom compare_Gt : forall i j, compare i j = Gt <-> i>j.
+
+ (* Up to here, these requirements could be fulfilled
+ by any totally ordered ring. Let's now be int-specific: *)
+ Axiom le_lt_int : forall x y, x<y <-> x<=y+-(1).
+
+ (* Btw, lt_0_1 could be deduced from this last axiom *)
+
+End Int.
+
+
+
+(* Of course, Z is a model for our abstract int *)
+
+Module Z_as_Int <: Int.
+
+ Open Scope Z_scope.
+
+ Definition int := Z.
+ Definition zero := 0.
+ Definition one := 1.
+ Definition plus := Zplus.
+ Definition opp := Zopp.
+ Definition minus := Zminus.
+ Definition mult := Zmult.
+
+ Lemma ring : @ring_theory int zero one plus mult minus opp (@eq int).
+ Proof.
+ constructor.
+ exact Zplus_0_l.
+ exact Zplus_comm.
+ exact Zplus_assoc.
+ exact Zmult_1_l.
+ exact Zmult_comm.
+ exact Zmult_assoc.
+ exact Zmult_plus_distr_l.
+ unfold minus, Zminus; auto.
+ exact Zplus_opp_r.
+ Qed.
+
+ Definition le := Zle.
+ Definition lt := Zlt.
+ Definition ge := Zge.
+ Definition gt := Zgt.
+ Lemma le_lt_iff : forall i j, (i<=j) <-> ~(j<i).
+ Proof.
+ split; intros.
+ apply Zle_not_lt; auto.
+ rewrite <- Zge_iff_le.
+ apply Znot_lt_ge; auto.
+ Qed.
+ Definition ge_le_iff := Zge_iff_le.
+ Definition gt_lt_iff := Zgt_iff_lt.
+
+ Definition lt_trans := Zlt_trans.
+ Definition lt_not_eq := Zlt_not_eq.
+
+ Definition lt_0_1 := Zlt_0_1.
+ Definition plus_le_compat := Zplus_le_compat.
+ Definition mult_lt_compat_l := Zmult_lt_compat_l.
+ Lemma opp_le_compat : forall i j, i<=j -> (-j)<=(-i).
+ Proof.
+ unfold Zle; intros; rewrite <- Zcompare_opp; auto.
+ Qed.
+
+ Definition compare := Zcompare.
+ Definition compare_Eq := Zcompare_Eq_iff_eq.
+ Lemma compare_Lt : forall i j, compare i j = Lt <-> i<j.
+ Proof. intros; unfold compare, Zlt; intuition. Qed.
+ Lemma compare_Gt : forall i j, compare i j = Gt <-> i>j.
+ Proof. intros; unfold compare, Zgt; intuition. Qed.
+
+ Lemma le_lt_int : forall x y, x<y <-> x<=y+-(1).
+ Proof.
+ intros; split; intros.
+ generalize (Zlt_left _ _ H); simpl; intros.
+ apply Zle_left_rev; auto.
+ apply Zlt_0_minus_lt.
+ generalize (Zplus_le_lt_compat x (y+-1) (-x) (-x+1) H).
+ rewrite Zplus_opp_r.
+ rewrite <-Zplus_assoc.
+ rewrite (Zplus_permute (-1)).
+ simpl in *.
+ rewrite Zplus_0_r.
+ intro H'; apply H'.
+ replace (-x+1) with (Zsucc (-x)); auto.
+ apply Zlt_succ.
+ Qed.
+
+End Z_as_Int.
+
+
+
+
+Module IntProperties (I:Int).
+ Import I.
+
+ (* Primo, some consequences of being a ring theory... *)
+
+ Definition two := 1+1.
+ Notation "2" := two : Int_scope.
+
+ (* Aliases for properties packed in the ring record. *)
+
+ Definition plus_assoc := ring.(Radd_assoc).
+ Definition plus_comm := ring.(Radd_comm).
+ Definition plus_0_l := ring.(Radd_0_l).
+ Definition mult_assoc := ring.(Rmul_assoc).
+ Definition mult_comm := ring.(Rmul_comm).
+ Definition mult_1_l := ring.(Rmul_1_l).
+ Definition mult_plus_distr_r := ring.(Rdistr_l).
+ Definition opp_def := ring.(Ropp_def).
+ Definition minus_def := ring.(Rsub_def).
+
+ Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l
+ mult_plus_distr_r opp_def minus_def.
+
+ (* More facts about plus *)
+
+ Lemma plus_0_r : forall x, x+0 = x.
+ Proof. intros; rewrite plus_comm; apply plus_0_l. Qed.
+
+ Lemma plus_0_r_reverse : forall x, x = x+0.
+ Proof. intros; symmetry; apply plus_0_r. Qed.
+
+ Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z).
+ Proof. intros; symmetry; apply plus_assoc. Qed.
+
+ Lemma plus_permute : forall x y z, x+(y+z) = y+(x+z).
+ Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed.
+
+ Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z.
+ Proof.
+ intros.
+ rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x).
+ now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute.
+ Qed.
+
+ (* More facts about mult *)
+
+ Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z).
+ Proof. intros; symmetry; apply mult_assoc. Qed.
+
+ Lemma mult_plus_distr_l : forall x y z, x*(y+z)=x*y+x*z.
+ Proof.
+ intros.
+ rewrite (mult_comm x (y+z)), (mult_comm x y), (mult_comm x z).
+ apply mult_plus_distr_r.
+ Qed.
+
+ Lemma mult_0_l : forall x, 0*x = 0.
+ Proof.
+ intros.
+ generalize (mult_plus_distr_r 0 1 x).
+ rewrite plus_0_l, mult_1_l, plus_comm; intros.
+ apply plus_reg_l with x.
+ rewrite <- H.
+ apply plus_0_r_reverse.
+ Qed.
+
+
+ (* More facts about opp *)
+
+ Definition plus_opp_r := opp_def.
+
+ Lemma plus_opp_l : forall x, -x + x = 0.
+ Proof. intros; now rewrite plus_comm, opp_def. Qed.
+
+ Lemma mult_opp_comm : forall x y, - x * y = x * - y.
+ Proof.
+ intros.
+ apply plus_reg_l with (x*y).
+ rewrite <- mult_plus_distr_l, <- mult_plus_distr_r.
+ now rewrite opp_def, opp_def, mult_0_l, mult_comm, mult_0_l.
+ Qed.
+
+ Lemma opp_eq_mult_neg_1 : forall x, -x = x * -(1).
+ Proof.
+ intros; now rewrite mult_comm, mult_opp_comm, mult_1_l.
+ Qed.
+
+ Lemma opp_involutive : forall x, -(-x) = x.
+ Proof.
+ intros.
+ apply plus_reg_l with (-x).
+ now rewrite opp_def, plus_comm, opp_def.
+ Qed.
+
+ Lemma opp_plus_distr : forall x y, -(x+y) = -x + -y.
+ Proof.
+ intros.
+ apply plus_reg_l with (x+y).
+ rewrite opp_def.
+ rewrite plus_permute.
+ do 2 rewrite plus_assoc.
+ now rewrite (plus_comm (-x)), opp_def, plus_0_l, opp_def.
+ Qed.
+
+ Lemma opp_mult_distr_r : forall x y, -(x*y) = x * -y.
+ Proof.
+ intros.
+ rewrite <- mult_opp_comm.
+ apply plus_reg_l with (x*y).
+ now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l.
+ Qed.
+
+ Lemma egal_left : forall n m, n=m -> n+-m = 0.
+ Proof. intros; subst; apply opp_def. Qed.
+
+ Lemma ne_left_2 : forall x y : int, x<>y -> 0<>(x + - y).
+ Proof.
+ intros; contradict H.
+ apply (plus_reg_l (-y)).
+ now rewrite plus_opp_l, plus_comm, H.
+ Qed.
+
+ (* Special lemmas for factorisation. *)
+
+ Lemma red_factor0 : forall n, n = n*1.
+ Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed.
+
+ Lemma red_factor1 : forall n, n+n = n*2.
+ Proof.
+ intros; unfold two.
+ now rewrite mult_comm, mult_plus_distr_r, mult_1_l.
+ Qed.
+
+ Lemma red_factor2 : forall n m, n + n*m = n * (1+m).
+ Proof.
+ intros; rewrite mult_plus_distr_l.
+ f_equal; now rewrite mult_comm, mult_1_l.
+ Qed.
+
+ Lemma red_factor3 : forall n m, n*m + n = n*(1+m).
+ Proof. intros; now rewrite plus_comm, red_factor2. Qed.
+
+ Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p).
+ Proof.
+ intros; now rewrite mult_plus_distr_l.
+ Qed.
+
+ Lemma red_factor5 : forall n m , n * 0 + m = m.
+ Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed.
+
+ Definition red_factor6 := plus_0_r_reverse.
+
+
+ (* Specialized distributivities *)
+
+ Hint Rewrite mult_plus_distr_l mult_plus_distr_r mult_assoc : int.
+ Hint Rewrite <- plus_assoc : int.
+
+ Lemma OMEGA10 :
+ forall v c1 c2 l1 l2 k1 k2 : int,
+ (v * c1 + l1) * k1 + (v * c2 + l2) * k2 =
+ v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2).
+ Proof.
+ intros; autorewrite with int; f_equal; now rewrite plus_permute.
+ Qed.
+
+ Lemma OMEGA11 :
+ forall v1 c1 l1 l2 k1 : int,
+ (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2).
+ Proof.
+ intros; now autorewrite with int.
+ Qed.
+
+ Lemma OMEGA12 :
+ forall v2 c2 l1 l2 k2 : int,
+ l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2).
+ Proof.
+ intros; autorewrite with int; now rewrite plus_permute.
+ Qed.
+
+ Lemma OMEGA13 :
+ forall v l1 l2 x : int,
+ v * -x + l1 + (v * x + l2) = l1 + l2.
+ Proof.
+ intros; autorewrite with int.
+ rewrite plus_permute; f_equal.
+ rewrite plus_assoc.
+ now rewrite <- mult_plus_distr_l, plus_opp_l, mult_comm, mult_0_l, plus_0_l.
+ Qed.
+
+ Lemma OMEGA15 :
+ forall v c1 c2 l1 l2 k2 : int,
+ v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2).
+ Proof.
+ intros; autorewrite with int; f_equal; now rewrite plus_permute.
+ Qed.
+
+ Lemma OMEGA16 : forall v c l k : int, (v * c + l) * k = v * (c * k) + l * k.
+ Proof.
+ intros; now autorewrite with int.
+ Qed.
+
+ Lemma sum1 : forall a b c d : int, 0 = a -> 0 = b -> 0 = a * c + b * d.
+ Proof.
+ intros; elim H; elim H0; simpl in |- *; auto.
+ now rewrite mult_0_l, mult_0_l, plus_0_l.
+ Qed.
+
+
+ (* Secondo, some results about order (and equality) *)
+
+ Lemma lt_irrefl : forall n, ~ n<n.
+ Proof.
+ intros n H.
+ elim (lt_not_eq _ _ H); auto.
+ Qed.
+
+ Lemma lt_antisym : forall n m, n<m -> m<n -> False.
+ Proof.
+ intros; elim (lt_irrefl _ (lt_trans _ _ _ H H0)); auto.
+ Qed.
+
+ Lemma lt_le_weak : forall n m, n<m -> n<=m.
+ Proof.
+ intros; rewrite le_lt_iff; intro H'; eapply lt_antisym; eauto.
+ Qed.
+
+ Lemma le_refl : forall n, n<=n.
+ Proof.
+ intros; rewrite le_lt_iff; apply lt_irrefl; auto.
+ Qed.
+
+ Lemma le_antisym : forall n m, n<=m -> m<=n -> n=m.
+ Proof.
+ intros n m; do 2 rewrite le_lt_iff; intros.
+ rewrite <- compare_Lt in H0.
+ rewrite <- gt_lt_iff, <- compare_Gt in H.
+ rewrite <- compare_Eq.
+ destruct compare; intuition.
+ Qed.
+
+ Lemma lt_eq_lt_dec : forall n m, { n<m }+{ n=m }+{ m<n }.
+ Proof.
+ intros.
+ generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m).
+ destruct compare; [ left; right | left; left | right ]; intuition.
+ rewrite gt_lt_iff in H1; intuition.
+ Qed.
+
+ Lemma lt_dec : forall n m: int, { n<m } + { ~n<m }.
+ Proof.
+ intros.
+ generalize (compare_Lt n m)(compare_Eq n m)(compare_Gt n m).
+ destruct compare; [ right | left | right ]; intuition discriminate.
+ Qed.
+
+ Lemma lt_le_iff : forall n m, (n<m) <-> ~(m<=n).
+ Proof.
+ intros.
+ rewrite le_lt_iff.
+ destruct (lt_dec n m); intuition.
+ Qed.
+
+ Lemma le_dec : forall n m: int, { n<=m } + { ~n<=m }.
+ Proof.
+ intros; destruct (lt_dec m n); [right|left]; rewrite le_lt_iff; intuition.
+ Qed.
+
+ Lemma le_lt_dec : forall n m, { n<=m } + { m<n }.
+ Proof.
+ intros; destruct (le_dec n m); [left|right]; auto; now rewrite lt_le_iff.
+ Qed.
+
+
+ Definition beq i j := match compare i j with Eq => true | _ => false end.
+
+ Lemma beq_iff : forall i j, beq i j = true <-> i=j.
+ Proof.
+ intros; unfold beq; generalize (compare_Eq i j).
+ destruct compare; intuition discriminate.
+ Qed.
+
+ Lemma beq_true : forall i j, beq i j = true -> i=j.
+ Proof.
+ intros.
+ rewrite <- beq_iff; auto.
+ Qed.
+
+ Lemma beq_false : forall i j, beq i j = false -> i<>j.
+ Proof.
+ intros.
+ intro H'.
+ rewrite <- beq_iff in H'; rewrite H' in H; discriminate.
+ Qed.
+
+ Lemma eq_dec : forall n m:int, { n=m } + { n<>m }.
+ Proof.
+ intros; generalize (beq_iff n m); destruct beq; [left|right]; intuition.
+ Qed.
+
+ Definition bgt i j := match compare i j with Gt => true | _ => false end.
+
+ Lemma bgt_iff : forall i j, bgt i j = true <-> i>j.
+ Proof.
+ intros; unfold bgt; generalize (compare_Gt i j).
+ destruct compare; intuition discriminate.
+ Qed.
+
+ Lemma bgt_true : forall i j, bgt i j = true -> i>j.
+ Proof. intros; now rewrite <- bgt_iff. Qed.
+
+ Lemma bgt_false : forall i j, bgt i j = false -> i<=j.
+ Proof.
+ intros.
+ rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H.
+ Qed.
+
+ Lemma le_is_lt_or_eq : forall n m, n<=m -> { n<m } + { n=m }.
+ Proof.
+ intros.
+ destruct (eq_dec n m) as [H'|H'].
+ right; intuition.
+ left; rewrite lt_le_iff.
+ contradict H'.
+ apply le_antisym; auto.
+ Qed.
+
+ Lemma le_neq_lt : forall n m, n<=m -> n<>m -> n<m.
+ Proof.
+ intros.
+ destruct (le_is_lt_or_eq _ _ H); intuition.
+ Qed.
+
+ Lemma le_trans : forall n m p, n<=m -> m<=p -> n<=p.
+ Proof.
+ intros n m p; do 3 rewrite le_lt_iff; intros A B C.
+ destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto.
+ generalize (lt_trans _ _ _ H C); intuition.
+ Qed.
+
+ (* order and operations *)
+
+ Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0.
+ Proof.
+ intros.
+ pattern 0 at 2; rewrite <- (mult_0_l (-(1))).
+ rewrite <- opp_eq_mult_neg_1.
+ split; intros.
+ apply opp_le_compat; auto.
+ rewrite <-(opp_involutive 0), <-(opp_involutive n).
+ apply opp_le_compat; auto.
+ Qed.
+
+ Lemma le_0_neg' : forall n, n <= 0 <-> 0 <= -n.
+ Proof.
+ intros; rewrite le_0_neg, opp_involutive; intuition.
+ Qed.
+
+ Lemma plus_le_reg_r : forall n m p, n + p <= m + p -> n <= m.
+ Proof.
+ intros.
+ replace n with ((n+p)+-p).
+ replace m with ((m+p)+-p).
+ apply plus_le_compat; auto.
+ apply le_refl.
+ now rewrite <- plus_assoc, opp_def, plus_0_r.
+ now rewrite <- plus_assoc, opp_def, plus_0_r.
+ Qed.
+
+ Lemma plus_le_lt_compat : forall n m p q, n<=m -> p<q -> n+p<m+q.
+ Proof.
+ intros.
+ apply le_neq_lt.
+ apply plus_le_compat; auto.
+ apply lt_le_weak; auto.
+ rewrite lt_le_iff in H0.
+ contradict H0.
+ apply plus_le_reg_r with m.
+ rewrite (plus_comm q m), <-H0, (plus_comm p m).
+ apply plus_le_compat; auto.
+ apply le_refl; auto.
+ Qed.
+
+ Lemma plus_lt_compat : forall n m p q, n<m -> p<q -> n+p<m+q.
+ Proof.
+ intros.
+ apply plus_le_lt_compat; auto.
+ apply lt_le_weak; auto.
+ Qed.
+
+ Lemma opp_lt_compat : forall n m, n<m -> -m < -n.
+ Proof.
+ intros n m; do 2 rewrite lt_le_iff; intros H; contradict H.
+ rewrite <-(opp_involutive m), <-(opp_involutive n).
+ apply opp_le_compat; auto.
+ Qed.
+
+ Lemma lt_0_neg : forall n, 0 < n <-> -n < 0.
+ Proof.
+ intros.
+ pattern 0 at 2; rewrite <- (mult_0_l (-(1))).
+ rewrite <- opp_eq_mult_neg_1.
+ split; intros.
+ apply opp_lt_compat; auto.
+ rewrite <-(opp_involutive 0), <-(opp_involutive n).
+ apply opp_lt_compat; auto.
+ Qed.
+
+ Lemma lt_0_neg' : forall n, n < 0 <-> 0 < -n.
+ Proof.
+ intros; rewrite lt_0_neg, opp_involutive; intuition.
+ Qed.
+
+ Lemma mult_lt_0_compat : forall n m, 0 < n -> 0 < m -> 0 < n*m.
+ Proof.
+ intros.
+ rewrite <- (mult_0_l n), mult_comm.
+ apply mult_lt_compat_l; auto.
+ Qed.
+
+ Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0.
+ Proof.
+ intros.
+ destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto;
+ destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; exfalso.
+
+ rewrite lt_0_neg' in Hn.
+ rewrite lt_0_neg' in Hm.
+ generalize (mult_lt_0_compat _ _ Hn Hm).
+ rewrite <- opp_mult_distr_r, mult_comm, <- opp_mult_distr_r, opp_involutive.
+ rewrite mult_comm, H.
+ exact (lt_irrefl 0).
+
+ rewrite lt_0_neg' in Hn.
+ generalize (mult_lt_0_compat _ _ Hn Hm).
+ rewrite mult_comm, <- opp_mult_distr_r, mult_comm.
+ rewrite H.
+ rewrite opp_eq_mult_neg_1, mult_0_l.
+ exact (lt_irrefl 0).
+
+ rewrite lt_0_neg' in Hm.
+ generalize (mult_lt_0_compat _ _ Hn Hm).
+ rewrite <- opp_mult_distr_r.
+ rewrite H.
+ rewrite opp_eq_mult_neg_1, mult_0_l.
+ exact (lt_irrefl 0).
+
+ generalize (mult_lt_0_compat _ _ Hn Hm).
+ rewrite H.
+ exact (lt_irrefl 0).
+ Qed.
+
+ Lemma mult_le_compat :
+ forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l.
+ Proof.
+ intros.
+ destruct (le_is_lt_or_eq _ _ H1).
+
+ apply le_trans with (i*l).
+ destruct (le_is_lt_or_eq _ _ H0); [ | subst; apply le_refl].
+ apply lt_le_weak.
+ apply mult_lt_compat_l; auto.
+
+ generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros.
+ rewrite (mult_comm i), (mult_comm j).
+ destruct (le_is_lt_or_eq _ _ H0);
+ [ | subst; do 2 rewrite mult_0_l; apply le_refl].
+ destruct (le_is_lt_or_eq _ _ H);
+ [ | subst; apply le_refl].
+ apply lt_le_weak.
+ apply mult_lt_compat_l; auto.
+
+ subst i.
+ rewrite mult_0_l.
+ generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros.
+ destruct (le_is_lt_or_eq _ _ H);
+ [ | subst; rewrite mult_0_l; apply le_refl].
+ destruct (le_is_lt_or_eq _ _ H0);
+ [ | subst; rewrite mult_comm, mult_0_l; apply le_refl].
+ apply lt_le_weak.
+ apply mult_lt_0_compat; auto.
+ Qed.
+
+ Lemma sum5 :
+ forall a b c d : int, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d.
+ Proof.
+ intros.
+ subst b; rewrite mult_0_l, plus_0_r.
+ contradict H.
+ symmetry in H; destruct (mult_integral _ _ H); congruence.
+ Qed.
+
+ Lemma one_neq_zero : 1 <> 0.
+ Proof.
+ red; intro.
+ symmetry in H.
+ apply (lt_not_eq 0 1); auto.
+ apply lt_0_1.
+ Qed.
+
+ Lemma minus_one_neq_zero : -(1) <> 0.
+ Proof.
+ apply lt_not_eq.
+ rewrite <- lt_0_neg.
+ apply lt_0_1.
+ Qed.
+
+ Lemma le_left : forall n m, n <= m -> 0 <= m + - n.
+ Proof.
+ intros.
+ rewrite <- (opp_def m).
+ apply plus_le_compat.
+ apply le_refl.
+ apply opp_le_compat; auto.
+ Qed.
+
+ Lemma OMEGA2 : forall x y, 0 <= x -> 0 <= y -> 0 <= x + y.
+ Proof.
+ intros.
+ replace 0 with (0+0).
+ apply plus_le_compat; auto.
+ rewrite plus_0_l; auto.
+ Qed.
+
+ Lemma OMEGA8 : forall x y, 0 <= x -> 0 <= y -> x = - y -> x = 0.
+ Proof.
+ intros.
+ assert (y=-x).
+ subst x; symmetry; apply opp_involutive.
+ clear H1; subst y.
+ destruct (eq_dec 0 x) as [H'|H']; auto.
+ assert (H'':=le_neq_lt _ _ H H').
+ generalize (plus_le_lt_compat _ _ _ _ H0 H'').
+ rewrite plus_opp_l, plus_0_l.
+ intros.
+ elim (lt_not_eq _ _ H1); auto.
+ Qed.
+
+ Lemma sum2 :
+ forall a b c d : int, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d.
+ Proof.
+ intros.
+ subst a; rewrite mult_0_l, plus_0_l.
+ rewrite <- (mult_0_l 0).
+ apply mult_le_compat; auto; apply le_refl.
+ Qed.
+
+ Lemma sum3 :
+ forall a b c d : int,
+ 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d.
+ Proof.
+ intros.
+ rewrite <- (plus_0_l 0).
+ apply plus_le_compat; auto.
+ rewrite <- (mult_0_l 0).
+ apply mult_le_compat; auto; apply le_refl.
+ rewrite <- (mult_0_l 0).
+ apply mult_le_compat; auto; apply le_refl.
+ Qed.
+
+ Lemma sum4 : forall k : int, k>0 -> 0 <= k.
+ Proof.
+ intros k; rewrite gt_lt_iff; apply lt_le_weak.
+ Qed.
+
+ (* Lemmas specific to integers (they use lt_le_int) *)
+
+ Lemma lt_left : forall n m, n < m -> 0 <= m + -(1) + - n.
+ Proof.
+ intros; apply le_left.
+ now rewrite <- le_lt_int.
+ Qed.
+
+ Lemma lt_left_inv : forall x y, 0 <= y + -(1) + - x -> x < y.
+ Proof.
+ intros.
+ generalize (plus_le_compat _ _ _ _ H (le_refl x)); clear H.
+ now rewrite plus_0_l, <-plus_assoc, plus_opp_l, plus_0_r, le_lt_int.
+ Qed.
+
+ Lemma OMEGA4 : forall x y z, x > 0 -> y > x -> z * y + x <> 0.
+ Proof.
+ intros.
+ intro H'.
+ rewrite gt_lt_iff in H,H0.
+ destruct (lt_eq_lt_dec z 0) as [[G|G]|G].
+
+ rewrite lt_0_neg' in G.
+ generalize (plus_le_lt_compat _ _ _ _ (le_refl (z*y)) H0).
+ rewrite H'.
+ pattern y at 2; rewrite <-(mult_1_l y), <-mult_plus_distr_r.
+ intros.
+ rewrite le_lt_int in G.
+ rewrite <- opp_plus_distr in G.
+ assert (0 < y) by (apply lt_trans with x; auto).
+ generalize (mult_le_compat _ _ _ _ G (lt_le_weak _ _ H2) (le_refl 0) (le_refl 0)).
+ rewrite mult_0_l, mult_comm, <- opp_mult_distr_r, mult_comm, <-le_0_neg', le_lt_iff.
+ intuition.
+
+ subst; rewrite mult_0_l, plus_0_l in H'; subst.
+ apply (lt_not_eq _ _ H); auto.
+
+ apply (lt_not_eq 0 (z*y+x)); auto.
+ rewrite <- (plus_0_l 0).
+ apply plus_lt_compat; auto.
+ apply mult_lt_0_compat; auto.
+ apply lt_trans with x; auto.
+ Qed.
+
+ Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1).
+ Proof.
+ intros.
+ do 2 rewrite <- le_lt_int.
+ rewrite <- opp_eq_mult_neg_1.
+ destruct (lt_eq_lt_dec 0 x) as [[H'|H']|H'].
+ auto.
+ congruence.
+ right.
+ rewrite <-(mult_0_l (-(1))), <-(opp_eq_mult_neg_1 0).
+ apply opp_lt_compat; auto.
+ Qed.
+
+ Lemma mult_le_approx :
+ forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m.
+ Proof.
+ intros n m p.
+ do 2 rewrite gt_lt_iff.
+ do 2 rewrite le_lt_iff; intros.
+ contradict H1.
+ rewrite lt_0_neg' in H1.
+ rewrite lt_0_neg'.
+ rewrite opp_plus_distr.
+ rewrite mult_comm, opp_mult_distr_r.
+ rewrite le_lt_int.
+ rewrite <- plus_assoc, (plus_comm (-p)), plus_assoc.
+ apply lt_left.
+ rewrite le_lt_int.
+ rewrite le_lt_int in H0.
+ apply le_trans with (n+-(1)); auto.
+ apply plus_le_compat; [ | apply le_refl ].
+ rewrite le_lt_int in H1.
+ generalize (mult_le_compat _ _ _ _ (lt_le_weak _ _ H) H1 (le_refl 0) (le_refl 0)).
+ rewrite mult_0_l.
+ rewrite mult_plus_distr_l.
+ rewrite <- opp_eq_mult_neg_1.
+ intros.
+ generalize (plus_le_compat _ _ _ _ (le_refl n) H2).
+ now rewrite plus_permute, opp_def, plus_0_r, plus_0_r.
+ Qed.
+
+ (* Some decidabilities *)
+
+ Lemma dec_eq : forall i j:int, decidable (i=j).
+ Proof.
+ red; intros; destruct (eq_dec i j); auto.
+ Qed.
+
+ Lemma dec_ne : forall i j:int, decidable (i<>j).
+ Proof.
+ red; intros; destruct (eq_dec i j); auto.
+ Qed.
+
+ Lemma dec_le : forall i j:int, decidable (i<=j).
+ Proof.
+ red; intros; destruct (le_dec i j); auto.
+ Qed.
+
+ Lemma dec_lt : forall i j:int, decidable (i<j).
+ Proof.
+ red; intros; destruct (lt_dec i j); auto.
+ Qed.
+
+ Lemma dec_ge : forall i j:int, decidable (i>=j).
+ Proof.
+ red; intros; rewrite ge_le_iff; destruct (le_dec j i); auto.
+ Qed.
+
+ Lemma dec_gt : forall i j:int, decidable (i>j).
+ Proof.
+ red; intros; rewrite gt_lt_iff; destruct (lt_dec j i); auto.
+ Qed.
+
+End IntProperties.
+
+
+
+
+Module IntOmega (I:Int).
+Import I.
+Module IP:=IntProperties(I).
+Import IP.
+
+(* \subsubsection{Definition of reified integer expressions}
+ Terms are either:
+ \begin{itemize}
+ \item integers [Tint]
+ \item variables [Tvar]
+ \item operation over integers (addition, product, opposite, subtraction)
+ The last two are translated in additions and products. *)
+
+Inductive term : Set :=
+ | Tint : int -> term
+ | Tplus : term -> term -> term
+ | Tmult : term -> term -> term
+ | Tminus : term -> term -> term
+ | Topp : term -> term
+ | 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].
+
+Infix "+" := Tplus : romega_scope.
+Infix "*" := Tmult : romega_scope.
+Infix "-" := Tminus : romega_scope.
+Notation "- x" := (Topp x) : romega_scope.
+Notation "[ x ]" := (Tvar x) (at level 0) : romega_scope.
+
+(* \subsubsection{Definition of reified goals} *)
+
+(* Very restricted definition of handled predicates that should be extended
+ to cover a wider set of operations.
+ Taking care of negations and disequations require solving more than a
+ goal in parallel. This is a major improvement over previous versions. *)
+
+Inductive proposition : Set :=
+ | EqTerm : term -> term -> proposition (* equality between terms *)
+ | LeqTerm : term -> term -> proposition (* less or equal on terms *)
+ | TrueTerm : proposition (* true *)
+ | FalseTerm : proposition (* false *)
+ | Tnot : proposition -> proposition (* negation *)
+ | GeqTerm : term -> term -> proposition
+ | GtTerm : term -> term -> proposition
+ | LtTerm : term -> term -> proposition
+ | NeqTerm : term -> term -> proposition
+ | Tor : proposition -> proposition -> proposition
+ | Tand : proposition -> proposition -> proposition
+ | Timp : proposition -> proposition -> proposition
+ | Tprop : nat -> proposition.
+
+(* Definition of goals as a list of hypothesis *)
+Notation hyps := (list proposition).
+
+(* Definition of lists of subgoals (set of open goals) *)
+Notation lhyps := (list hyps).
+
+(* a single goal packed in a subgoal list *)
+Notation singleton := (fun a : hyps => a :: nil).
+
+(* an absurd goal *)
+Definition absurd := FalseTerm :: nil.
+
+(* \subsubsection{Traces for merging equations}
+ This inductive type describes how the monomial of two equations should be
+ merged when the equations are added.
+
+ For [F_equal], both equations have the same head variable and coefficient
+ must be added, furthermore if coefficients are opposite, [F_cancel] should
+ be used to collapse the term. [F_left] and [F_right] indicate which monomial
+ should be put first in the result *)
+
+Inductive t_fusion : Set :=
+ | F_equal : t_fusion
+ | F_cancel : t_fusion
+ | F_left : t_fusion
+ | F_right : t_fusion.
+
+(* \subsubsection{Rewriting steps to normalize terms} *)
+Inductive step : Set :=
+ (* apply the rewriting steps to both subterms of an operation *)
+ | C_DO_BOTH : step -> step -> step
+ (* apply the rewriting step to the first branch *)
+ | C_LEFT : step -> step
+ (* apply the rewriting step to the second branch *)
+ | C_RIGHT : step -> step
+ (* apply two steps consecutively to a term *)
+ | C_SEQ : step -> step -> step
+ (* empty step *)
+ | C_NOP : step
+ (* the following operations correspond to actual rewriting *)
+ | C_OPP_PLUS : step
+ | C_OPP_OPP : step
+ | C_OPP_MULT_R : step
+ | C_OPP_ONE : step
+ (* This is a special step that reduces the term (computation) *)
+ | C_REDUCE : step
+ | C_MULT_PLUS_DISTR : step
+ | C_MULT_OPP_LEFT : step
+ | C_MULT_ASSOC_R : step
+ | C_PLUS_ASSOC_R : step
+ | C_PLUS_ASSOC_L : step
+ | C_PLUS_PERMUTE : step
+ | C_PLUS_COMM : step
+ | C_RED0 : step
+ | C_RED1 : step
+ | C_RED2 : step
+ | C_RED3 : step
+ | C_RED4 : step
+ | C_RED5 : step
+ | C_RED6 : step
+ | C_MULT_ASSOC_REDUCED : step
+ | C_MINUS : step
+ | C_MULT_COMM : step.
+
+(* \subsubsection{Omega steps} *)
+(* The following inductive type describes steps as they can be found in
+ the trace coming from the decision procedure Omega. *)
+
+Inductive t_omega : Set :=
+ (* n = 0 and n!= 0 *)
+ | O_CONSTANT_NOT_NUL : nat -> t_omega
+ | O_CONSTANT_NEG : nat -> t_omega
+ (* division and approximation of an equation *)
+ | O_DIV_APPROX : int -> int -> term -> nat -> t_omega -> nat -> t_omega
+ (* no solution because no exact division *)
+ | O_NOT_EXACT_DIVIDE : int -> int -> term -> nat -> nat -> t_omega
+ (* exact division *)
+ | O_EXACT_DIVIDE : int -> term -> nat -> t_omega -> nat -> t_omega
+ | O_SUM : int -> nat -> int -> nat -> list t_fusion -> t_omega -> t_omega
+ | O_CONTRADICTION : nat -> nat -> nat -> t_omega
+ | O_MERGE_EQ : nat -> nat -> nat -> t_omega -> t_omega
+ | O_SPLIT_INEQ : nat -> nat -> t_omega -> t_omega -> t_omega
+ | O_CONSTANT_NUL : nat -> t_omega
+ | O_NEGATE_CONTRADICT : nat -> nat -> t_omega
+ | O_NEGATE_CONTRADICT_INV : nat -> nat -> nat -> t_omega
+ | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega.
+
+(* \subsubsection{Rules for normalizing the hypothesis} *)
+(* These rules indicate how to normalize useful propositions
+ of each useful hypothesis before the decomposition of hypothesis.
+ The rules include the inversion phase for negation removal. *)
+
+Inductive p_step : Set :=
+ | P_LEFT : p_step -> p_step
+ | P_RIGHT : p_step -> p_step
+ | P_INVERT : step -> p_step
+ | P_STEP : step -> p_step
+ | P_NOP : p_step.
+
+(* List of normalizations to perform : with a constructor of type
+ [p_step] allowing to visit both left and right branches, we would be
+ able to restrict to only one normalization by hypothesis.
+ And since all hypothesis are useful (otherwise they wouldn't be included),
+ we would be able to replace [h_step] by a simple list. *)
+
+Inductive h_step : Set :=
+ pair_step : nat -> p_step -> h_step.
+
+(* \subsubsection{Rules for decomposing the hypothesis} *)
+(* 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. *)
+
+Inductive direction : Set :=
+ | D_left : direction
+ | D_right : direction
+ | D_mono : direction.
+
+(* This type allows to extract useful components from hypothesis, either
+ hypothesis generated by splitting a disjonction, or equations.
+ The last constructor indicates how to solve the obtained system
+ via the use of the trace type of Omega [t_omega] *)
+
+Inductive e_step : Set :=
+ | E_SPLIT : nat -> list direction -> e_step -> e_step -> e_step
+ | E_EXTRACT : nat -> list direction -> e_step -> e_step
+ | E_SOLVE : t_omega -> e_step.
+
+(* \subsection{Efficient decidable equality} *)
+(* For each reified data-type, we define an efficient equality test.
+ It is not the one produced by [Decide Equality].
+
+ Then we prove two theorem allowing to eliminate such equalities :
+ \begin{verbatim}
+ (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2.
+ (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2.
+ \end{verbatim} *)
+
+(* \subsubsection{Reified terms} *)
+
+Open Scope romega_scope.
+
+Fixpoint eq_term (t1 t2 : term) {struct t2} : bool :=
+ match t1, t2 with
+ | Tint st1, Tint st2 => beq st1 st2
+ | (st11 + st12), (st21 + st22) => eq_term st11 st21 && eq_term st12 st22
+ | (st11 * st12), (st21 * st22) => eq_term st11 st21 && eq_term st12 st22
+ | (st11 - st12), (st21 - st22) => eq_term st11 st21 && eq_term st12 st22
+ | (- st1), (- st2) => eq_term st1 st2
+ | [st1], [st2] => beq_nat st1 st2
+ | _, _ => false
+ end.
+
+Close Scope romega_scope.
+
+Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2.
+Proof.
+ simple induction t1; intros until t2; case t2; simpl in *;
+ try (intros; discriminate; fail);
+ [ intros; elim beq_true with (1 := H); trivial
+ | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
+ elim H with (1 := H4); elim H0 with (1 := H5);
+ trivial
+ | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
+ elim H with (1 := H4); elim H0 with (1 := H5);
+ trivial
+ | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5;
+ elim H with (1 := H4); elim H0 with (1 := H5);
+ trivial
+ | intros t21 H3; elim H with (1 := H3); trivial
+ | intros; elim beq_nat_true with (1 := H); trivial ].
+Qed.
+
+Ltac trivial_case := unfold not in |- *; intros; discriminate.
+
+Theorem eq_term_false :
+ forall t1 t2 : term, eq_term t1 t2 = false -> t1 <> t2.
+Proof.
+ simple induction t1;
+ [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
+ intros; elim beq_false with (1 := H); simplify_eq H0;
+ auto
+ | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
+ intros t21 t22 H3; unfold not in |- *; intro H4;
+ elim andb_false_elim with (1 := H3); intros H5;
+ [ elim H1 with (1 := H5); simplify_eq H4; auto
+ | elim H2 with (1 := H5); simplify_eq H4; auto ]
+ | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
+ intros t21 t22 H3; unfold not in |- *; intro H4;
+ elim andb_false_elim with (1 := H3); intros H5;
+ [ elim H1 with (1 := H5); simplify_eq H4; auto
+ | elim H2 with (1 := H5); simplify_eq H4; auto ]
+ | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *;
+ intros t21 t22 H3; unfold not in |- *; intro H4;
+ elim andb_false_elim with (1 := H3); intros H5;
+ [ elim H1 with (1 := H5); simplify_eq H4; auto
+ | elim H2 with (1 := H5); simplify_eq H4; auto ]
+ | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3;
+ unfold not in |- *; intro H4; elim H1 with (1 := H3);
+ simplify_eq H4; auto
+ | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
+ intros; elim beq_nat_false with (1 := H); simplify_eq H0;
+ auto ].
+Qed.
+
+(* \subsubsection{Tactiques pour éliminer ces tests}
+
+ Si on se contente de faire un [Case (eq_typ t1 t2)] on perd
+ totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2].
+
+ Initialement, les développements avaient été réalisés avec les
+ tests rendus par [Decide Equality], c'est à dire un test rendant
+ des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un
+ tel test préserve bien l'information voulue mais calculatoirement de
+ telles fonctions sont trop lentes. *)
+
+(* Les tactiques définies si après se comportent exactement comme si on
+ avait utilisé le test précédent et fait une elimination dessus. *)
+
+Ltac elim_eq_term t1 t2 :=
+ pattern (eq_term t1 t2) in |- *; apply bool_eq_ind; intro Aux;
+ [ generalize (eq_term_true t1 t2 Aux); clear Aux
+ | generalize (eq_term_false t1 t2 Aux); clear Aux ].
+
+Ltac elim_beq t1 t2 :=
+ pattern (beq t1 t2) in |- *; apply bool_eq_ind; intro Aux;
+ [ generalize (beq_true t1 t2 Aux); clear Aux
+ | generalize (beq_false t1 t2 Aux); clear Aux ].
+
+Ltac elim_bgt t1 t2 :=
+ pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux;
+ [ generalize (bgt_true t1 t2 Aux); clear Aux
+ | generalize (bgt_false t1 t2 Aux); clear Aux ].
+
+
+(* \subsection{Interprétations}
+ \subsubsection{Interprétation des termes dans Z} *)
+
+Fixpoint interp_term (env : list int) (t : term) {struct t} : int :=
+ match t with
+ | Tint x => x
+ | (t1 + t2)%term => interp_term env t1 + interp_term env t2
+ | (t1 * t2)%term => interp_term env t1 * interp_term env t2
+ | (t1 - t2)%term => interp_term env t1 - interp_term env t2
+ | (- t)%term => - interp_term env t
+ | [n]%term => nth n env 0
+ end.
+
+(* \subsubsection{Interprétation des prédicats} *)
+
+Fixpoint interp_proposition (envp : list Prop) (env : list int)
+ (p : proposition) {struct p} : Prop :=
+ match p with
+ | EqTerm t1 t2 => interp_term env t1 = interp_term env t2
+ | LeqTerm t1 t2 => interp_term env t1 <= interp_term env t2
+ | TrueTerm => True
+ | FalseTerm => False
+ | Tnot p' => ~ interp_proposition envp env p'
+ | GeqTerm t1 t2 => interp_term env t1 >= interp_term env t2
+ | GtTerm t1 t2 => interp_term env t1 > interp_term env t2
+ | LtTerm t1 t2 => interp_term env t1 < interp_term env t2
+ | NeqTerm t1 t2 => (interp_term env t1)<>(interp_term env t2)
+ | Tor p1 p2 =>
+ interp_proposition envp env p1 \/ interp_proposition envp env p2
+ | Tand p1 p2 =>
+ interp_proposition envp env p1 /\ interp_proposition envp env p2
+ | Timp p1 p2 =>
+ interp_proposition envp env p1 -> interp_proposition envp env p2
+ | Tprop n => nth n envp True
+ end.
+
+(* \subsubsection{Inteprétation des listes d'hypothèses}
+ \paragraph{Sous forme de conjonction}
+ Interprétation sous forme d'une conjonction d'hypothèses plus faciles
+ à manipuler individuellement *)
+
+Fixpoint interp_hyps (envp : list Prop) (env : list int)
+ (l : hyps) {struct l} : Prop :=
+ match l with
+ | nil => True
+ | p' :: l' => interp_proposition envp env p' /\ interp_hyps envp env l'
+ end.
+
+(* \paragraph{sous forme de but}
+ C'est cette interpétation que l'on utilise sur le but (car on utilise
+ [Generalize] et qu'une conjonction est forcément lourde (répétition des
+ types dans les conjonctions intermédiaires) *)
+
+Fixpoint interp_goal_concl (c : proposition) (envp : list Prop)
+ (env : list int) (l : hyps) {struct l} : Prop :=
+ match l with
+ | nil => interp_proposition envp env c
+ | p' :: l' =>
+ interp_proposition envp env p' -> interp_goal_concl c envp env l'
+ end.
+
+Notation interp_goal := (interp_goal_concl FalseTerm).
+
+(* Les théorèmes qui suivent assurent la correspondance entre les deux
+ interprétations. *)
+
+Theorem goal_to_hyps :
+ forall (envp : list Prop) (env : list int) (l : hyps),
+ (interp_hyps envp env l -> False) -> interp_goal envp env l.
+Proof.
+ simple induction l;
+ [ simpl in |- *; auto
+ | simpl in |- *; intros a l1 H1 H2 H3; apply H1; intro H4; apply H2; auto ].
+Qed.
+
+Theorem hyps_to_goal :
+ forall (envp : list Prop) (env : list int) (l : hyps),
+ interp_goal envp env l -> interp_hyps envp env l -> False.
+Proof.
+ simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
+Qed.
+
+(* \subsection{Manipulations sur les hypothèses} *)
+
+(* \subsubsection{Définitions de base de stabilité pour la réflexion} *)
+(* Une opération laisse un terme stable si l'égalité est préservée *)
+Definition term_stable (f : term -> term) :=
+ forall (e : list int) (t : term), interp_term e t = interp_term e (f t).
+
+(* Une opération est valide sur une hypothèse, si l'hypothèse implique le
+ résultat de l'opération. \emph{Attention : cela ne concerne que des
+ opérations sur les hypothèses et non sur les buts (contravariance)}.
+ On définit la validité pour une opération prenant une ou deux propositions
+ en argument (cela suffit pour omega). *)
+
+Definition valid1 (f : proposition -> proposition) :=
+ forall (ep : list Prop) (e : list int) (p1 : proposition),
+ interp_proposition ep e p1 -> interp_proposition ep e (f p1).
+
+Definition valid2 (f : proposition -> proposition -> proposition) :=
+ forall (ep : list Prop) (e : list int) (p1 p2 : proposition),
+ interp_proposition ep e p1 ->
+ interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2).
+
+(* Dans cette notion de validité, la fonction prend directement une
+ liste de propositions et rend une nouvelle liste de proposition.
+ On reste contravariant *)
+
+Definition valid_hyps (f : hyps -> hyps) :=
+ forall (ep : list Prop) (e : list int) (lp : hyps),
+ interp_hyps ep e lp -> interp_hyps ep e (f lp).
+
+(* Enfin ce théorème élimine la contravariance et nous ramène à une
+ opération sur les buts *)
+
+Theorem valid_goal :
+ forall (ep : list Prop) (env : list int) (l : hyps) (a : hyps -> hyps),
+ valid_hyps a -> interp_goal ep env (a l) -> interp_goal ep env l.
+Proof.
+ intros; simpl in |- *; apply goal_to_hyps; intro H1;
+ apply (hyps_to_goal ep env (a l) H0); apply H; assumption.
+Qed.
+
+(* \subsubsection{Généralisation a des listes de buts (disjonctions)} *)
+
+
+Fixpoint interp_list_hyps (envp : list Prop) (env : list int)
+ (l : lhyps) {struct l} : Prop :=
+ match l with
+ | nil => False
+ | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l'
+ end.
+
+Fixpoint interp_list_goal (envp : list Prop) (env : list int)
+ (l : lhyps) {struct l} : Prop :=
+ match l with
+ | nil => True
+ | h :: l' => interp_goal envp env h /\ interp_list_goal envp env l'
+ end.
+
+Theorem list_goal_to_hyps :
+ forall (envp : list Prop) (env : list int) (l : lhyps),
+ (interp_list_hyps envp env l -> False) -> interp_list_goal envp env l.
+Proof.
+ simple induction l; simpl in |- *;
+ [ auto
+ | intros h1 l1 H H1; split;
+ [ apply goal_to_hyps; intro H2; apply H1; auto
+ | apply H; intro H2; apply H1; auto ] ].
+Qed.
+
+Theorem list_hyps_to_goal :
+ forall (envp : list Prop) (env : list int) (l : lhyps),
+ interp_list_goal envp env l -> interp_list_hyps envp env l -> False.
+Proof.
+ simple induction l; simpl in |- *;
+ [ auto
+ | intros h1 l1 H (H1, H2) H3; elim H3; intro H4;
+ [ apply hyps_to_goal with (1 := H1); assumption | auto ] ].
+Qed.
+
+Definition valid_list_hyps (f : hyps -> lhyps) :=
+ forall (ep : list Prop) (e : list int) (lp : hyps),
+ interp_hyps ep e lp -> interp_list_hyps ep e (f lp).
+
+Definition valid_list_goal (f : hyps -> lhyps) :=
+ forall (ep : list Prop) (e : list int) (lp : hyps),
+ interp_list_goal ep e (f lp) -> interp_goal ep e lp.
+
+Theorem goal_valid :
+ forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f.
+Proof.
+ unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps;
+ intro H2; apply list_hyps_to_goal with (1 := H1);
+ apply (H ep e lp); assumption.
+Qed.
+
+Theorem append_valid :
+ forall (ep : list Prop) (e : list int) (l1 l2 : lhyps),
+ interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 ->
+ interp_list_hyps ep e (l1 ++ l2).
+Proof.
+ intros ep e; simple induction l1;
+ [ simpl in |- *; intros l2 [H| H]; [ contradiction | trivial ]
+ | simpl in |- *; intros h1 t1 HR l2 [[H| H]| H];
+ [ auto
+ | right; apply (HR l2); left; trivial
+ | right; apply (HR l2); right; trivial ] ].
+
+Qed.
+
+(* \subsubsection{Opérateurs valides sur les hypothèses} *)
+
+(* Extraire une hypothèse de la liste *)
+Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm.
+
+Theorem nth_valid :
+ forall (ep : list Prop) (e : list int) (i : nat) (l : hyps),
+ interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l).
+Proof.
+ unfold nth_hyps in |- *; simple induction i;
+ [ simple induction l; simpl in |- *; [ auto | intros; elim H0; auto ]
+ | intros n H; simple induction l;
+ [ simpl in |- *; trivial
+ | intros; simpl in |- *; apply H; elim H1; auto ] ].
+Qed.
+
+(* Appliquer une opération (valide) sur deux hypothèses extraites de
+ la liste et ajouter le résultat à la liste. *)
+Definition apply_oper_2 (i j : nat)
+ (f : proposition -> proposition -> proposition) (l : hyps) :=
+ f (nth_hyps i l) (nth_hyps j l) :: l.
+
+Theorem apply_oper_2_valid :
+ forall (i j : nat) (f : proposition -> proposition -> proposition),
+ valid2 f -> valid_hyps (apply_oper_2 i j f).
+Proof.
+ intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *;
+ intros lp Hlp; split; [ apply Hf; apply nth_valid; assumption | assumption ].
+Qed.
+
+(* Modifier une hypothèse par application d'une opération valide *)
+
+Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition)
+ (l : hyps) {struct i} : hyps :=
+ match l with
+ | nil => nil (A:=proposition)
+ | p :: l' =>
+ match i with
+ | O => f p :: l'
+ | S j => p :: apply_oper_1 j f l'
+ end
+ end.
+
+Theorem apply_oper_1_valid :
+ forall (i : nat) (f : proposition -> proposition),
+ valid1 f -> valid_hyps (apply_oper_1 i f).
+Proof.
+ unfold valid_hyps in |- *; intros i f Hf ep e; elim i;
+ [ intro lp; case lp;
+ [ simpl in |- *; trivial
+ | simpl in |- *; intros p l' (H1, H2); split;
+ [ apply Hf with (1 := H1) | assumption ] ]
+ | intros n Hrec lp; case lp;
+ [ simpl in |- *; auto
+ | simpl in |- *; intros p l' (H1, H2); split;
+ [ assumption | apply Hrec; assumption ] ] ].
+Qed.
+
+(* \subsubsection{Manipulations de termes} *)
+(* Les fonctions suivantes permettent d'appliquer une fonction de
+ réécriture sur un sous terme du terme principal. Avec la composition,
+ cela permet de construire des réécritures complexes proches des
+ tactiques de conversion *)
+
+Definition apply_left (f : term -> term) (t : term) :=
+ match t with
+ | (x + y)%term => (f x + y)%term
+ | (x * y)%term => (f x * y)%term
+ | (- x)%term => (- f x)%term
+ | x => x
+ end.
+
+Definition apply_right (f : term -> term) (t : term) :=
+ match t with
+ | (x + y)%term => (x + f y)%term
+ | (x * y)%term => (x * f y)%term
+ | x => x
+ end.
+
+Definition apply_both (f g : term -> term) (t : term) :=
+ match t with
+ | (x + y)%term => (f x + g y)%term
+ | (x * y)%term => (f x * g y)%term
+ | x => x
+ end.
+
+(* Les théorèmes suivants montrent la stabilité (conditionnée) des
+ fonctions. *)
+
+Theorem apply_left_stable :
+ forall f : term -> term, term_stable f -> term_stable (apply_left f).
+Proof.
+ unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+ intros; elim H; trivial.
+Qed.
+
+Theorem apply_right_stable :
+ forall f : term -> term, term_stable f -> term_stable (apply_right f).
+Proof.
+ unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+ intros t0 t1; elim H; trivial.
+Qed.
+
+Theorem apply_both_stable :
+ forall f g : term -> term,
+ term_stable f -> term_stable g -> term_stable (apply_both f g).
+Proof.
+ unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *;
+ intros t0 t1; elim H1; elim H2; trivial.
+Qed.
+
+Theorem compose_term_stable :
+ forall f g : term -> term,
+ term_stable f -> term_stable g -> term_stable (fun t : term => f (g t)).
+Proof.
+ unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg.
+Qed.
+
+(* \subsection{Les règles de réécriture} *)
+(* Chacune des règles de réécriture est accompagnée par sa preuve de
+ stabilité. Toutes ces preuves ont la même forme : il faut analyser
+ suivant la forme du terme (élimination de chaque Case). On a besoin d'une
+ élimination uniquement dans les cas d'utilisation d'égalité décidable.
+
+ Cette tactique itère la décomposition des Case. Elle est
+ constituée de deux fonctions s'appelant mutuellement :
+ \begin{itemize}
+ \item une fonction d'enrobage qui lance la recherche sur le but,
+ \item une fonction récursive qui décompose ce but. Quand elle a trouvé un
+ Case, elle l'élimine.
+ \end{itemize}
+ Les motifs sur les cas sont très imparfaits et dans certains cas, il
+ semble que cela ne marche pas. On aimerait plutot un motif de la
+ forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on
+ utilise le bon type.
+
+ Chaque élimination introduit correctement exactement le nombre d'hypothèses
+ nécessaires et conserve dans le cas d'une égalité la connaissance du
+ résultat du test en faisant la réécriture. Pour un test de comparaison,
+ on conserve simplement le résultat.
+
+ Cette fonction déborde très largement la résolution des réécritures
+ simples et fait une bonne partie des preuves des pas de Omega.
+*)
+
+(* \subsubsection{La tactique pour prouver la stabilité} *)
+
+Ltac loop t :=
+ match t with
+ (* Global *)
+ | (?X1 = ?X2) => loop X1 || loop X2
+ | (_ -> ?X1) => loop X1
+ (* Interpretations *)
+ | (interp_hyps _ _ ?X1) => loop X1
+ | (interp_list_hyps _ _ ?X1) => loop X1
+ | (interp_proposition _ _ ?X1) => loop X1
+ | (interp_term _ ?X1) => loop X1
+ (* Propositions *)
+ | (EqTerm ?X1 ?X2) => loop X1 || loop X2
+ | (LeqTerm ?X1 ?X2) => loop X1 || loop X2
+ (* Termes *)
+ | (?X1 + ?X2)%term => loop X1 || loop X2
+ | (?X1 - ?X2)%term => loop X1 || loop X2
+ | (?X1 * ?X2)%term => loop X1 || loop X2
+ | (- ?X1)%term => loop X1
+ | (Tint ?X1) => loop X1
+ (* Eliminations *)
+ | match ?X1 with
+ | EqTerm x x0 => _
+ | LeqTerm x x0 => _
+ | TrueTerm => _
+ | FalseTerm => _
+ | Tnot x => _
+ | GeqTerm x x0 => _
+ | GtTerm x x0 => _
+ | LtTerm x x0 => _
+ | NeqTerm x x0 => _
+ | Tor x x0 => _
+ | Tand x x0 => _
+ | Timp x x0 => _
+ | Tprop x => _
+ end => destruct X1; auto; Simplify
+ | match ?X1 with
+ | Tint x => _
+ | (x + x0)%term => _
+ | (x * x0)%term => _
+ | (x - x0)%term => _
+ | (- x)%term => _
+ | [x]%term => _
+ end => destruct X1; auto; Simplify
+ | (if beq ?X1 ?X2 then _ else _) =>
+ let H := fresh "H" in
+ elim_beq X1 X2; intro H; try (rewrite H in *; clear H);
+ simpl in |- *; auto; Simplify
+ | (if bgt ?X1 ?X2 then _ else _) =>
+ let H := fresh "H" in
+ elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify
+ | (if eq_term ?X1 ?X2 then _ else _) =>
+ let H := fresh "H" in
+ elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H);
+ simpl in |- *; auto; Simplify
+ | (if _ && _ then _ else _) => rewrite andb_if; Simplify
+ | (if negb _ then _ else _) => rewrite negb_if; Simplify
+ | _ => fail
+ end
+
+with Simplify := match goal with
+ | |- ?X1 => try loop X1
+ | _ => idtac
+ end.
+
+Ltac prove_stable x th :=
+ match constr:x with
+ | ?X1 =>
+ unfold term_stable, X1 in |- *; intros; Simplify; simpl in |- *;
+ apply th
+ end.
+
+(* \subsubsection{Les règles elle mêmes} *)
+Definition Tplus_assoc_l (t : term) :=
+ match t with
+ | (n + (m + p))%term => (n + m + p)%term
+ | _ => t
+ end.
+
+Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l.
+Proof.
+ prove_stable Tplus_assoc_l (ring.(Radd_assoc)).
+Qed.
+
+Definition Tplus_assoc_r (t : term) :=
+ match t with
+ | (n + m + p)%term => (n + (m + p))%term
+ | _ => t
+ end.
+
+Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r.
+Proof.
+ prove_stable Tplus_assoc_r plus_assoc_reverse.
+Qed.
+
+Definition Tmult_assoc_r (t : term) :=
+ match t with
+ | (n * m * p)%term => (n * (m * p))%term
+ | _ => t
+ end.
+
+Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r.
+Proof.
+ prove_stable Tmult_assoc_r mult_assoc_reverse.
+Qed.
+
+Definition Tplus_permute (t : term) :=
+ match t with
+ | (n + (m + p))%term => (m + (n + p))%term
+ | _ => t
+ end.
+
+Theorem Tplus_permute_stable : term_stable Tplus_permute.
+Proof.
+ prove_stable Tplus_permute plus_permute.
+Qed.
+
+Definition Tplus_comm (t : term) :=
+ match t with
+ | (x + y)%term => (y + x)%term
+ | _ => t
+ end.
+
+Theorem Tplus_comm_stable : term_stable Tplus_comm.
+Proof.
+ prove_stable Tplus_comm plus_comm.
+Qed.
+
+Definition Tmult_comm (t : term) :=
+ match t with
+ | (x * y)%term => (y * x)%term
+ | _ => t
+ end.
+
+Theorem Tmult_comm_stable : term_stable Tmult_comm.
+Proof.
+ prove_stable Tmult_comm mult_comm.
+Qed.
+
+Definition T_OMEGA10 (t : term) :=
+ match t with
+ | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term =>
+ if eq_term v v'
+ then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term
+ else t
+ | _ => t
+ end.
+
+Theorem T_OMEGA10_stable : term_stable T_OMEGA10.
+Proof.
+ prove_stable T_OMEGA10 OMEGA10.
+Qed.
+
+Definition T_OMEGA11 (t : term) :=
+ match t with
+ | ((v1 * Tint c1 + l1) * Tint k1 + l2)%term =>
+ (v1 * Tint (c1 * k1) + (l1 * Tint k1 + l2))%term
+ | _ => t
+ end.
+
+Theorem T_OMEGA11_stable : term_stable T_OMEGA11.
+Proof.
+ prove_stable T_OMEGA11 OMEGA11.
+Qed.
+
+Definition T_OMEGA12 (t : term) :=
+ match t with
+ | (l1 + (v2 * Tint c2 + l2) * Tint k2)%term =>
+ (v2 * Tint (c2 * k2) + (l1 + l2 * Tint k2))%term
+ | _ => t
+ end.
+
+Theorem T_OMEGA12_stable : term_stable T_OMEGA12.
+Proof.
+ prove_stable T_OMEGA12 OMEGA12.
+Qed.
+
+Definition T_OMEGA13 (t : term) :=
+ match t with
+ | (v * Tint x + l1 + (v' * Tint x' + l2))%term =>
+ if eq_term v v' && beq x (-x')
+ then (l1+l2)%term
+ else t
+ | _ => t
+ end.
+
+Theorem T_OMEGA13_stable : term_stable T_OMEGA13.
+Proof.
+ unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *;
+ apply OMEGA13.
+Qed.
+
+Definition T_OMEGA15 (t : term) :=
+ match t with
+ | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term =>
+ if eq_term v v'
+ then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term
+ else t
+ | _ => t
+ end.
+
+Theorem T_OMEGA15_stable : term_stable T_OMEGA15.
+Proof.
+ prove_stable T_OMEGA15 OMEGA15.
+Qed.
+
+Definition T_OMEGA16 (t : term) :=
+ match t with
+ | ((v * Tint c + l) * Tint k)%term => (v * Tint (c * k) + l * Tint k)%term
+ | _ => t
+ end.
+
+
+Theorem T_OMEGA16_stable : term_stable T_OMEGA16.
+Proof.
+ prove_stable T_OMEGA16 OMEGA16.
+Qed.
+
+Definition Tred_factor5 (t : term) :=
+ match t with
+ | (x * Tint c + y)%term => if beq c 0 then y else t
+ | _ => t
+ end.
+
+Theorem Tred_factor5_stable : term_stable Tred_factor5.
+Proof.
+ prove_stable Tred_factor5 red_factor5.
+Qed.
+
+Definition Topp_plus (t : term) :=
+ match t with
+ | (- (x + y))%term => (- x + - y)%term
+ | _ => t
+ end.
+
+Theorem Topp_plus_stable : term_stable Topp_plus.
+Proof.
+ prove_stable Topp_plus opp_plus_distr.
+Qed.
+
+
+Definition Topp_opp (t : term) :=
+ match t with
+ | (- - x)%term => x
+ | _ => t
+ end.
+
+Theorem Topp_opp_stable : term_stable Topp_opp.
+Proof.
+ prove_stable Topp_opp opp_involutive.
+Qed.
+
+Definition Topp_mult_r (t : term) :=
+ match t with
+ | (- (x * Tint k))%term => (x * Tint (- k))%term
+ | _ => t
+ end.
+
+Theorem Topp_mult_r_stable : term_stable Topp_mult_r.
+Proof.
+ prove_stable Topp_mult_r opp_mult_distr_r.
+Qed.
+
+Definition Topp_one (t : term) :=
+ match t with
+ | (- x)%term => (x * Tint (-(1)))%term
+ | _ => t
+ end.
+
+Theorem Topp_one_stable : term_stable Topp_one.
+Proof.
+ prove_stable Topp_one opp_eq_mult_neg_1.
+Qed.
+
+Definition Tmult_plus_distr (t : term) :=
+ match t with
+ | ((n + m) * p)%term => (n * p + m * p)%term
+ | _ => t
+ end.
+
+Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr.
+Proof.
+ prove_stable Tmult_plus_distr mult_plus_distr_r.
+Qed.
+
+Definition Tmult_opp_left (t : term) :=
+ match t with
+ | (- x * Tint y)%term => (x * Tint (- y))%term
+ | _ => t
+ end.
+
+Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left.
+Proof.
+ prove_stable Tmult_opp_left mult_opp_comm.
+Qed.
+
+Definition Tmult_assoc_reduced (t : term) :=
+ match t with
+ | (n * Tint m * Tint p)%term => (n * Tint (m * p))%term
+ | _ => t
+ end.
+
+Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced.
+Proof.
+ prove_stable Tmult_assoc_reduced mult_assoc_reverse.
+Qed.
+
+Definition Tred_factor0 (t : term) := (t * Tint 1)%term.
+
+Theorem Tred_factor0_stable : term_stable Tred_factor0.
+Proof.
+ prove_stable Tred_factor0 red_factor0.
+Qed.
+
+Definition Tred_factor1 (t : term) :=
+ match t with
+ | (x + y)%term =>
+ if eq_term x y
+ then (x * Tint 2)%term
+ else t
+ | _ => t
+ end.
+
+Theorem Tred_factor1_stable : term_stable Tred_factor1.
+Proof.
+ prove_stable Tred_factor1 red_factor1.
+Qed.
+
+Definition Tred_factor2 (t : term) :=
+ match t with
+ | (x + y * Tint k)%term =>
+ if eq_term x y
+ then (x * Tint (1 + k))%term
+ else t
+ | _ => t
+ end.
+
+Theorem Tred_factor2_stable : term_stable Tred_factor2.
+Proof.
+ prove_stable Tred_factor2 red_factor2.
+Qed.
+
+Definition Tred_factor3 (t : term) :=
+ match t with
+ | (x * Tint k + y)%term =>
+ if eq_term x y
+ then (x * Tint (1 + k))%term
+ else t
+ | _ => t
+ end.
+
+Theorem Tred_factor3_stable : term_stable Tred_factor3.
+Proof.
+ prove_stable Tred_factor3 red_factor3.
+Qed.
+
+
+Definition Tred_factor4 (t : term) :=
+ match t with
+ | (x * Tint k1 + y * Tint k2)%term =>
+ if eq_term x y
+ then (x * Tint (k1 + k2))%term
+ else t
+ | _ => t
+ end.
+
+Theorem Tred_factor4_stable : term_stable Tred_factor4.
+Proof.
+ prove_stable Tred_factor4 red_factor4.
+Qed.
+
+Definition Tred_factor6 (t : term) := (t + Tint 0)%term.
+
+Theorem Tred_factor6_stable : term_stable Tred_factor6.
+Proof.
+ prove_stable Tred_factor6 red_factor6.
+Qed.
+
+Definition Tminus_def (t : term) :=
+ match t with
+ | (x - y)%term => (x + - y)%term
+ | _ => t
+ end.
+
+Theorem Tminus_def_stable : term_stable Tminus_def.
+Proof.
+ prove_stable Tminus_def minus_def.
+Qed.
+
+(* \subsection{Fonctions de réécriture complexes} *)
+
+(* \subsubsection{Fonction de réduction} *)
+(* Cette fonction réduit un terme dont la forme normale est un entier. Il
+ suffit pour cela d'échanger le constructeur [Tint] avec les opérateurs
+ réifiés. La réduction est ``gratuite''. *)
+
+Fixpoint reduce (t : term) : term :=
+ match t with
+ | (x + y)%term =>
+ match reduce x with
+ | Tint x' =>
+ match reduce y with
+ | Tint y' => Tint (x' + y')
+ | y' => (Tint x' + y')%term
+ end
+ | x' => (x' + reduce y)%term
+ end
+ | (x * y)%term =>
+ match reduce x with
+ | Tint x' =>
+ match reduce y with
+ | Tint y' => Tint (x' * y')
+ | y' => (Tint x' * y')%term
+ end
+ | x' => (x' * reduce y)%term
+ end
+ | (x - y)%term =>
+ match reduce x with
+ | Tint x' =>
+ match reduce y with
+ | Tint y' => Tint (x' - y')
+ | y' => (Tint x' - y')%term
+ end
+ | x' => (x' - reduce y)%term
+ end
+ | (- x)%term =>
+ match reduce x with
+ | Tint x' => Tint (- x')
+ | x' => (- x')%term
+ end
+ | _ => t
+ end.
+
+Theorem reduce_stable : term_stable reduce.
+Proof.
+ unfold term_stable in |- *; intros e t; elim t; auto;
+ try
+ (intros t0 H0 t1 H1; simpl in |- *; rewrite H0; rewrite H1;
+ (case (reduce t0);
+ [ intro z0; case (reduce t1); intros; auto
+ | intros; auto
+ | intros; auto
+ | intros; auto
+ | intros; auto
+ | intros; auto ])); intros t0 H0; simpl in |- *;
+ rewrite H0; case (reduce t0); intros; auto.
+Qed.
+
+(* \subsubsection{Fusions}
+ \paragraph{Fusion de deux équations} *)
+(* On donne une somme de deux équations qui sont supposées normalisées.
+ Cette fonction prend une trace de fusion en argument et transforme
+ le terme en une équation normalisée. C'est une version très simplifiée
+ du moteur de réécriture [rewrite]. *)
+
+Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term :=
+ match trace with
+ | nil => reduce t
+ | step :: trace' =>
+ match step with
+ | F_equal => apply_right (fusion trace') (T_OMEGA10 t)
+ | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA10 t))
+ | F_left => apply_right (fusion trace') (T_OMEGA11 t)
+ | F_right => apply_right (fusion trace') (T_OMEGA12 t)
+ end
+ end.
+
+Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t).
+Proof.
+ simple induction t; simpl in |- *;
+ [ exact reduce_stable
+ | intros stp l H; case stp;
+ [ apply compose_term_stable;
+ [ apply apply_right_stable; assumption | exact T_OMEGA10_stable ]
+ | unfold term_stable in |- *; intros e t1; rewrite T_OMEGA10_stable;
+ rewrite Tred_factor5_stable; apply H
+ | apply compose_term_stable;
+ [ apply apply_right_stable; assumption | exact T_OMEGA11_stable ]
+ | apply compose_term_stable;
+ [ apply apply_right_stable; assumption | exact T_OMEGA12_stable ] ] ].
+Qed.
+
+(* \paragraph{Fusion de deux équations dont une sans coefficient} *)
+
+Definition fusion_right (trace : list t_fusion) (t : term) : term :=
+ match trace with
+ | nil => reduce t (* Il faut mettre un compute *)
+ | step :: trace' =>
+ match step with
+ | F_equal => apply_right (fusion trace') (T_OMEGA15 t)
+ | F_cancel => fusion trace' (Tred_factor5 (T_OMEGA15 t))
+ | F_left => apply_right (fusion trace') (Tplus_assoc_r t)
+ | F_right => apply_right (fusion trace') (T_OMEGA12 t)
+ end
+ end.
+
+(* \paragraph{Fusion avec annihilation} *)
+(* Normalement le résultat est une constante *)
+
+Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term :=
+ match trace with
+ | O => reduce t
+ | S trace' => fusion_cancel trace' (T_OMEGA13 t)
+ end.
+
+Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t).
+Proof.
+ unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace;
+ [ exact (reduce_stable e)
+ | intros n H t; elim H; exact (T_OMEGA13_stable e t) ].
+Qed.
+
+(* \subsubsection{Opérations affines sur une équation} *)
+(* \paragraph{Multiplication scalaire et somme d'une constante} *)
+
+Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term :=
+ match trace with
+ | O => reduce t
+ | S trace' => apply_right (scalar_norm_add trace') (T_OMEGA11 t)
+ end.
+
+Theorem scalar_norm_add_stable :
+ forall t : nat, term_stable (scalar_norm_add t).
+Proof.
+ unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace;
+ [ exact reduce_stable
+ | intros n H e t; elim apply_right_stable;
+ [ exact (T_OMEGA11_stable e t) | exact H ] ].
+Qed.
+
+(* \paragraph{Multiplication scalaire} *)
+Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term :=
+ match trace with
+ | O => reduce t
+ | S trace' => apply_right (scalar_norm trace') (T_OMEGA16 t)
+ end.
+
+Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t).
+Proof.
+ unfold term_stable, scalar_norm in |- *; intros trace; elim trace;
+ [ exact reduce_stable
+ | intros n H e t; elim apply_right_stable;
+ [ exact (T_OMEGA16_stable e t) | exact H ] ].
+Qed.
+
+(* \paragraph{Somme d'une constante} *)
+Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term :=
+ match trace with
+ | O => reduce t
+ | S trace' => apply_right (add_norm trace') (Tplus_assoc_r t)
+ end.
+
+Theorem add_norm_stable : forall t : nat, term_stable (add_norm t).
+Proof.
+ unfold term_stable, add_norm in |- *; intros trace; elim trace;
+ [ exact reduce_stable
+ | intros n H e t; elim apply_right_stable;
+ [ exact (Tplus_assoc_r_stable e t) | exact H ] ].
+Qed.
+
+(* \subsection{La fonction de normalisation des termes (moteur de réécriture)} *)
+
+
+Fixpoint rewrite (s : step) : term -> term :=
+ match s with
+ | C_DO_BOTH s1 s2 => apply_both (rewrite s1) (rewrite s2)
+ | C_LEFT s => apply_left (rewrite s)
+ | C_RIGHT s => apply_right (rewrite s)
+ | C_SEQ s1 s2 => fun t : term => rewrite s2 (rewrite s1 t)
+ | C_NOP => fun t : term => t
+ | C_OPP_PLUS => Topp_plus
+ | C_OPP_OPP => Topp_opp
+ | C_OPP_MULT_R => Topp_mult_r
+ | C_OPP_ONE => Topp_one
+ | C_REDUCE => reduce
+ | C_MULT_PLUS_DISTR => Tmult_plus_distr
+ | C_MULT_OPP_LEFT => Tmult_opp_left
+ | C_MULT_ASSOC_R => Tmult_assoc_r
+ | C_PLUS_ASSOC_R => Tplus_assoc_r
+ | C_PLUS_ASSOC_L => Tplus_assoc_l
+ | C_PLUS_PERMUTE => Tplus_permute
+ | C_PLUS_COMM => Tplus_comm
+ | C_RED0 => Tred_factor0
+ | C_RED1 => Tred_factor1
+ | C_RED2 => Tred_factor2
+ | C_RED3 => Tred_factor3
+ | C_RED4 => Tred_factor4
+ | C_RED5 => Tred_factor5
+ | C_RED6 => Tred_factor6
+ | C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced
+ | C_MINUS => Tminus_def
+ | C_MULT_COMM => Tmult_comm
+ end.
+
+Theorem rewrite_stable : forall s : step, term_stable (rewrite s).
+Proof.
+ simple induction s; simpl in |- *;
+ [ intros; apply apply_both_stable; auto
+ | intros; apply apply_left_stable; auto
+ | intros; apply apply_right_stable; auto
+ | unfold term_stable in |- *; intros; elim H0; apply H
+ | unfold term_stable in |- *; auto
+ | exact Topp_plus_stable
+ | exact Topp_opp_stable
+ | exact Topp_mult_r_stable
+ | exact Topp_one_stable
+ | exact reduce_stable
+ | exact Tmult_plus_distr_stable
+ | exact Tmult_opp_left_stable
+ | exact Tmult_assoc_r_stable
+ | exact Tplus_assoc_r_stable
+ | exact Tplus_assoc_l_stable
+ | exact Tplus_permute_stable
+ | exact Tplus_comm_stable
+ | exact Tred_factor0_stable
+ | exact Tred_factor1_stable
+ | exact Tred_factor2_stable
+ | exact Tred_factor3_stable
+ | exact Tred_factor4_stable
+ | exact Tred_factor5_stable
+ | exact Tred_factor6_stable
+ | exact Tmult_assoc_reduced_stable
+ | exact Tminus_def_stable
+ | exact Tmult_comm_stable ].
+Qed.
+
+(* \subsection{tactiques de résolution d'un but omega normalisé}
+ Trace de la procédure
+\subsubsection{Tactiques générant une contradiction}
+\paragraph{[O_CONSTANT_NOT_NUL]} *)
+
+Definition constant_not_nul (i : nat) (h : hyps) :=
+ match nth_hyps i h with
+ | EqTerm (Tint Nul) (Tint n) =>
+ if beq n Nul then h else absurd
+ | _ => h
+ end.
+
+Theorem constant_not_nul_valid :
+ forall i : nat, valid_hyps (constant_not_nul i).
+Proof.
+ unfold valid_hyps, constant_not_nul in |- *; intros;
+ generalize (nth_valid ep e i lp); Simplify; simpl in |- *.
+
+ elim_beq i1 i0; auto; simpl in |- *; intros H1 H2;
+ elim H1; symmetry in |- *; auto.
+Qed.
+
+(* \paragraph{[O_CONSTANT_NEG]} *)
+
+Definition constant_neg (i : nat) (h : hyps) :=
+ match nth_hyps i h with
+ | LeqTerm (Tint Nul) (Tint Neg) =>
+ if bgt Nul Neg then absurd else h
+ | _ => h
+ end.
+
+Theorem constant_neg_valid : forall i : nat, valid_hyps (constant_neg i).
+Proof.
+ unfold valid_hyps, constant_neg in |- *; intros;
+ generalize (nth_valid ep e i lp); Simplify; simpl in |- *.
+ rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition.
+Qed.
+
+(* \paragraph{[NOT_EXACT_DIVIDE]} *)
+Definition not_exact_divide (k1 k2 : int) (body : term)
+ (t i : nat) (l : hyps) :=
+ match nth_hyps i l with
+ | EqTerm (Tint Nul) b =>
+ if beq Nul 0 &&
+ eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b &&
+ bgt k2 0 &&
+ bgt k1 k2
+ then absurd
+ else l
+ | _ => l
+ end.
+
+Theorem not_exact_divide_valid :
+ forall (k1 k2 : int) (body : term) (t i : nat),
+ valid_hyps (not_exact_divide k1 k2 body t i).
+Proof.
+ unfold valid_hyps, not_exact_divide in |- *; intros;
+ generalize (nth_valid ep e i lp); Simplify.
+ rewrite (scalar_norm_add_stable t e), <-H1.
+ do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros.
+ absurd (interp_term e body * k1 + k2 = 0);
+ [ now apply OMEGA4 | symmetry; auto ].
+Qed.
+
+(* \paragraph{[O_CONTRADICTION]} *)
+
+Definition contradiction (t i j : nat) (l : hyps) :=
+ match nth_hyps i l with
+ | LeqTerm (Tint Nul) b1 =>
+ match nth_hyps j l with
+ | LeqTerm (Tint Nul') b2 =>
+ match fusion_cancel t (b1 + b2)%term with
+ | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k
+ then absurd
+ else l
+ | _ => l
+ end
+ | _ => l
+ end
+ | _ => l
+ end.
+
+Theorem contradiction_valid :
+ forall t i j : nat, valid_hyps (contradiction t i j).
+Proof.
+ unfold valid_hyps, contradiction in |- *; intros t i j ep e l H;
+ generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
+ case (nth_hyps i l); auto; intros t1 t2; case t1;
+ auto; case (nth_hyps j l);
+ auto; intros t3 t4; case t3; auto;
+ simpl in |- *; intros z z' H1 H2;
+ generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term)));
+ pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *;
+ case (fusion_cancel t (t2 + t4)%term); simpl in |- *;
+ auto; intro k; elim (fusion_cancel_stable t); simpl in |- *.
+ Simplify; intro H3.
+ generalize (OMEGA2 _ _ H2 H1); rewrite H3.
+ rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition.
+Qed.
+
+(* \paragraph{[O_NEGATE_CONTRADICT]} *)
+
+Definition negate_contradict (i1 i2 : nat) (h : hyps) :=
+ match nth_hyps i1 h with
+ | EqTerm (Tint Nul) b1 =>
+ match nth_hyps i2 h with
+ | NeqTerm (Tint Nul') b2 =>
+ if beq Nul 0 && beq Nul' 0 && eq_term b1 b2
+ then absurd
+ else h
+ | _ => h
+ end
+ | NeqTerm (Tint Nul) b1 =>
+ match nth_hyps i2 h with
+ | EqTerm (Tint Nul') b2 =>
+ if beq Nul 0 && beq Nul' 0 && eq_term b1 b2
+ then absurd
+ else h
+ | _ => h
+ end
+ | _ => h
+ end.
+
+Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
+ match nth_hyps i1 h with
+ | EqTerm (Tint Nul) b1 =>
+ match nth_hyps i2 h with
+ | NeqTerm (Tint Nul') b2 =>
+ if beq Nul 0 && beq Nul' 0 &&
+ eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term)
+ then absurd
+ else h
+ | _ => h
+ end
+ | NeqTerm (Tint Nul) b1 =>
+ match nth_hyps i2 h with
+ | EqTerm (Tint Nul') b2 =>
+ if beq Nul 0 && beq Nul' 0 &&
+ eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term)
+ then absurd
+ else h
+ | _ => h
+ end
+ | _ => h
+ end.
+
+Theorem negate_contradict_valid :
+ forall i j : nat, valid_hyps (negate_contradict i j).
+Proof.
+ unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H;
+ generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
+ case (nth_hyps i l); auto; intros t1 t2; case t1;
+ auto; intros z; auto; case (nth_hyps j l);
+ auto; intros t3 t4; case t3; auto; intros z';
+ auto; simpl in |- *; intros H1 H2; Simplify.
+Qed.
+
+Theorem negate_contradict_inv_valid :
+ forall t i j : nat, valid_hyps (negate_contradict_inv t i j).
+Proof.
+ unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H;
+ generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H);
+ case (nth_hyps i l); auto; intros t1 t2; case t1;
+ auto; intros z; auto; case (nth_hyps j l);
+ auto; intros t3 t4; case t3; auto; intros z';
+ auto; simpl in |- *; intros H1 H2; Simplify;
+ [
+ rewrite <- scalar_norm_stable in H2; simpl in *;
+ elim (mult_integral (interp_term e t4) (-(1))); intuition;
+ elim minus_one_neq_zero; auto
+ |
+ elim H2; clear H2;
+ rewrite <- scalar_norm_stable; simpl in *;
+ now rewrite <- H1, mult_0_l
+ ].
+Qed.
+
+(* \subsubsection{Tactiques générant une nouvelle équation} *)
+(* \paragraph{[O_SUM]}
+ C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant
+ les opérateurs de comparaison des deux arguments) d'où une
+ preuve un peu compliquée. On utilise quelques lemmes qui sont des
+ généralisations des théorèmes utilisés par OMEGA. *)
+
+Definition sum (k1 k2 : int) (trace : list t_fusion)
+ (prop1 prop2 : proposition) :=
+ match prop1 with
+ | EqTerm (Tint Null) b1 =>
+ match prop2 with
+ | EqTerm (Tint Null') b2 =>
+ if beq Null 0 && beq Null' 0
+ then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
+ else TrueTerm
+ | LeqTerm (Tint Null') b2 =>
+ if beq Null 0 && beq Null' 0 && bgt k2 0
+ then LeqTerm (Tint 0)
+ (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
+ else TrueTerm
+ | _ => TrueTerm
+ end
+ | LeqTerm (Tint Null) b1 =>
+ if beq Null 0 && bgt k1 0
+ then match prop2 with
+ | EqTerm (Tint Null') b2 =>
+ if beq Null' 0 then
+ LeqTerm (Tint 0)
+ (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
+ else TrueTerm
+ | LeqTerm (Tint Null') b2 =>
+ if beq Null' 0 && bgt k2 0
+ then LeqTerm (Tint 0)
+ (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
+ else TrueTerm
+ | _ => TrueTerm
+ end
+ else TrueTerm
+ | NeqTerm (Tint Null) b1 =>
+ match prop2 with
+ | EqTerm (Tint Null') b2 =>
+ if beq Null 0 && beq Null' 0 && (negb (beq k1 0))
+ then NeqTerm (Tint 0)
+ (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
+ else TrueTerm
+ | _ => TrueTerm
+ end
+ | _ => TrueTerm
+ end.
+
+
+Theorem sum_valid :
+ forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t).
+Proof.
+ unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *;
+ Simplify; simpl in |- *; auto; try elim (fusion_stable t);
+ simpl in |- *; intros;
+ [ apply sum1; assumption
+ | apply sum2; try assumption; apply sum4; assumption
+ | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption
+ | apply sum3; try assumption; apply sum4; assumption
+ | apply sum5; auto ].
+Qed.
+
+(* \paragraph{[O_EXACT_DIVIDE]}
+ c'est une oper1 valide mais on préfère une substitution a ce point la *)
+
+Definition exact_divide (k : int) (body : term) (t : nat)
+ (prop : proposition) :=
+ match prop with
+ | EqTerm (Tint Null) b =>
+ if beq Null 0 &&
+ eq_term (scalar_norm t (body * Tint k)%term) b &&
+ negb (beq k 0)
+ then EqTerm (Tint 0) body
+ else TrueTerm
+ | NeqTerm (Tint Null) b =>
+ if beq Null 0 &&
+ eq_term (scalar_norm t (body * Tint k)%term) b &&
+ negb (beq k 0)
+ then NeqTerm (Tint 0) body
+ else TrueTerm
+ | _ => TrueTerm
+ end.
+
+Theorem exact_divide_valid :
+ forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n).
+Proof.
+ unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1;
+ Simplify; simpl; auto; subst;
+ rewrite <- scalar_norm_stable; simpl; intros;
+ [ destruct (mult_integral _ _ (sym_eq H0)); intuition
+ | contradict H0; rewrite <- H0, mult_0_l; auto
+ ].
+Qed.
+
+
+(* \paragraph{[O_DIV_APPROX]}
+ La preuve reprend le schéma de la précédente mais on
+ est sur une opération de type valid1 et non sur une opération terminale. *)
+
+Definition divide_and_approx (k1 k2 : int) (body : term)
+ (t : nat) (prop : proposition) :=
+ match prop with
+ | LeqTerm (Tint Null) b =>
+ if beq Null 0 &&
+ eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b &&
+ bgt k1 0 &&
+ bgt k1 k2
+ then LeqTerm (Tint 0) body
+ else prop
+ | _ => prop
+ end.
+
+Theorem divide_and_approx_valid :
+ forall (k1 k2 : int) (body : term) (t : nat),
+ valid1 (divide_and_approx k1 k2 body t).
+Proof.
+ unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1;
+ Simplify; simpl; auto; subst;
+ elim (scalar_norm_add_stable t e); simpl in |- *.
+ intro H2; apply mult_le_approx with (3 := H2); assumption.
+Qed.
+
+(* \paragraph{[MERGE_EQ]} *)
+
+Definition merge_eq (t : nat) (prop1 prop2 : proposition) :=
+ match prop1 with
+ | LeqTerm (Tint Null) b1 =>
+ match prop2 with
+ | LeqTerm (Tint Null') b2 =>
+ if beq Null 0 && beq Null' 0 &&
+ eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term)
+ then EqTerm (Tint 0) b1
+ else TrueTerm
+ | _ => TrueTerm
+ end
+ | _ => TrueTerm
+ end.
+
+Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n).
+Proof.
+ unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *;
+ auto; elim (scalar_norm_stable n e); simpl in |- *;
+ intros; symmetry in |- *; apply OMEGA8 with (2 := H0);
+ [ assumption | elim opp_eq_mult_neg_1; trivial ].
+Qed.
+
+
+
+(* \paragraph{[O_CONSTANT_NUL]} *)
+
+Definition constant_nul (i : nat) (h : hyps) :=
+ match nth_hyps i h with
+ | NeqTerm (Tint Null) (Tint Null') =>
+ if beq Null Null' then absurd else h
+ | _ => h
+ end.
+
+Theorem constant_nul_valid : forall i : nat, valid_hyps (constant_nul i).
+Proof.
+ unfold valid_hyps, constant_nul in |- *; intros;
+ generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
+ intro H1; absurd (0 = 0); intuition.
+Qed.
+
+(* \paragraph{[O_STATE]} *)
+
+Definition state (m : int) (s : step) (prop1 prop2 : proposition) :=
+ match prop1 with
+ | EqTerm (Tint Null) b1 =>
+ match prop2 with
+ | EqTerm b2 b3 =>
+ if beq Null 0
+ then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term)
+ else TrueTerm
+ | _ => TrueTerm
+ end
+ | _ => TrueTerm
+ end.
+
+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 |- *;
+ intros H1 H2; elim H1.
+ now rewrite H2, plus_opp_l, plus_0_l, mult_0_l.
+Qed.
+
+(* \subsubsection{Tactiques générant plusieurs but}
+ \paragraph{[O_SPLIT_INEQ]}
+ La seule pour le moment (tant que la normalisation n'est pas réfléchie). *)
+
+Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps)
+ (l : hyps) :=
+ match nth_hyps i l with
+ | NeqTerm (Tint Null) b1 =>
+ if beq Null 0 then
+ f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++
+ f2
+ (LeqTerm (Tint 0)
+ (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l)
+ else l :: nil
+ | _ => l :: nil
+ end.
+
+Theorem split_ineq_valid :
+ forall (i t : nat) (f1 f2 : hyps -> lhyps),
+ valid_list_hyps f1 ->
+ valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2).
+Proof.
+ unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H;
+ generalize (nth_valid _ _ i _ H); case (nth_hyps i lp);
+ simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *;
+ auto; intros z; simpl in |- *; auto; intro H3.
+ Simplify.
+ apply append_valid; elim (OMEGA19 (interp_term e t2));
+ [ intro H4; left; apply H1; simpl in |- *; elim (add_norm_stable t);
+ simpl in |- *; auto
+ | intro H4; right; apply H2; simpl in |- *; elim (scalar_norm_add_stable t);
+ simpl in |- *; auto
+ | generalize H3; unfold not in |- *; intros E1 E2; apply E1;
+ symmetry in |- *; trivial ].
+Qed.
+
+
+(* \subsection{La fonction de rejeu de la trace} *)
+
+Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps :=
+ match t with
+ | O_CONSTANT_NOT_NUL n => singleton (constant_not_nul n l)
+ | O_CONSTANT_NEG n => singleton (constant_neg n l)
+ | O_DIV_APPROX k1 k2 body t cont n =>
+ execute_omega cont (apply_oper_1 n (divide_and_approx k1 k2 body t) l)
+ | O_NOT_EXACT_DIVIDE k1 k2 body t i =>
+ singleton (not_exact_divide k1 k2 body t i l)
+ | O_EXACT_DIVIDE k body t cont n =>
+ execute_omega cont (apply_oper_1 n (exact_divide k body t) l)
+ | O_SUM k1 i1 k2 i2 t cont =>
+ execute_omega cont (apply_oper_2 i1 i2 (sum k1 k2 t) l)
+ | O_CONTRADICTION t i j => singleton (contradiction t i j l)
+ | O_MERGE_EQ t i1 i2 cont =>
+ execute_omega cont (apply_oper_2 i1 i2 (merge_eq t) l)
+ | O_SPLIT_INEQ t i cont1 cont2 =>
+ split_ineq i t (execute_omega cont1) (execute_omega cont2) l
+ | O_CONSTANT_NUL i => singleton (constant_nul i l)
+ | O_NEGATE_CONTRADICT i j => singleton (negate_contradict i j l)
+ | O_NEGATE_CONTRADICT_INV t i j =>
+ singleton (negate_contradict_inv t i j l)
+ | O_STATE m s i1 i2 cont =>
+ execute_omega cont (apply_oper_2 i1 i2 (state m s) l)
+ end.
+
+Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t).
+Proof.
+ simple induction t; simpl in |- *;
+ [ unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
+ apply (constant_not_nul_valid n ep e lp H)
+ | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
+ apply (constant_neg_valid n ep e lp H)
+ | unfold valid_list_hyps, valid_hyps in |- *;
+ intros k1 k2 body n t' Ht' m ep e lp H; apply Ht';
+ apply
+ (apply_oper_1_valid m (divide_and_approx k1 k2 body n)
+ (divide_and_approx_valid k1 k2 body n) ep e lp H)
+ | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
+ apply (not_exact_divide_valid i i0 t0 n n0 ep e lp H)
+ | unfold valid_list_hyps, valid_hyps in |- *;
+ intros k body n t' Ht' m ep e lp H; apply Ht';
+ apply
+ (apply_oper_1_valid m (exact_divide k body n)
+ (exact_divide_valid k body n) ep e lp H)
+ | unfold valid_list_hyps, valid_hyps in |- *;
+ intros k1 i1 k2 i2 trace t' Ht' ep e lp H; apply Ht';
+ apply
+ (apply_oper_2_valid i1 i2 (sum k1 k2 trace) (sum_valid k1 k2 trace) ep e
+ lp H)
+ | unfold valid_list_hyps in |- *; simpl in |- *; intros; left;
+ apply (contradiction_valid n n0 n1 ep e lp H)
+ | unfold valid_list_hyps, valid_hyps in |- *;
+ intros trace i1 i2 t' Ht' ep e lp H; apply Ht';
+ apply
+ (apply_oper_2_valid i1 i2 (merge_eq trace) (merge_eq_valid trace) ep e
+ lp H)
+ | intros t' i k1 H1 k2 H2; unfold valid_list_hyps in |- *; simpl in |- *;
+ intros ep e lp H;
+ apply
+ (split_ineq_valid i t' (execute_omega k1) (execute_omega k2) H1 H2 ep e
+ lp H)
+ | unfold valid_list_hyps in |- *; simpl in |- *; intros i ep e lp H; left;
+ apply (constant_nul_valid i ep e lp H)
+ | unfold valid_list_hyps in |- *; simpl in |- *; intros i j ep e lp H; left;
+ apply (negate_contradict_valid i j ep e lp H)
+ | unfold valid_list_hyps in |- *; simpl in |- *; intros n i j ep e lp H;
+ left; apply (negate_contradict_inv_valid n i j ep e lp H)
+ | unfold valid_list_hyps, valid_hyps in |- *;
+ intros m s i1 i2 t' Ht' ep e lp H; apply Ht';
+ apply (apply_oper_2_valid i1 i2 (state m s) (state_valid m s) ep e lp H) ].
+Qed.
+
+
+(* \subsection{Les opérations globales sur le but}
+ \subsubsection{Normalisation} *)
+
+Definition move_right (s : step) (p : proposition) :=
+ match p with
+ | EqTerm t1 t2 => EqTerm (Tint 0) (rewrite s (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)
+ | p => p
+ end.
+
+Theorem move_right_valid : forall s : step, valid1 (move_right s).
+Proof.
+ unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *;
+ elim (rewrite_stable s e); simpl in |- *;
+ [ symmetry in |- *; apply egal_left; assumption
+ | 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 ].
+Qed.
+
+Definition do_normalize (i : nat) (s : step) := apply_oper_1 i (move_right s).
+
+Theorem do_normalize_valid :
+ forall (i : nat) (s : step), valid_hyps (do_normalize i s).
+Proof.
+ intros; unfold do_normalize in |- *; apply apply_oper_1_valid;
+ apply move_right_valid.
+Qed.
+
+Fixpoint do_normalize_list (l : list step) (i : nat)
+ (h : hyps) {struct l} : hyps :=
+ match l with
+ | s :: l' => do_normalize_list l' (S i) (do_normalize i s h)
+ | nil => h
+ end.
+
+Theorem do_normalize_list_valid :
+ forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i).
+Proof.
+ simple induction l; simpl in |- *; unfold valid_hyps in |- *;
+ [ auto
+ | intros a l' Hl' i ep e lp H; unfold valid_hyps in Hl'; apply Hl';
+ apply (do_normalize_valid i a ep e lp); assumption ].
+Qed.
+
+Theorem normalize_goal :
+ forall (s : list step) (ep : list Prop) (env : list int) (l : hyps),
+ interp_goal ep env (do_normalize_list s 0 l) -> interp_goal ep env l.
+Proof.
+ intros; apply valid_goal with (2 := H); apply do_normalize_list_valid.
+Qed.
+
+(* \subsubsection{Exécution de la trace} *)
+
+Theorem execute_goal :
+ forall (t : t_omega) (ep : list Prop) (env : list int) (l : hyps),
+ interp_list_goal ep env (execute_omega t l) -> interp_goal ep env l.
+Proof.
+ intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H).
+Qed.
+
+
+Theorem append_goal :
+ forall (ep : list Prop) (e : list int) (l1 l2 : lhyps),
+ interp_list_goal ep e l1 /\ interp_list_goal ep e l2 ->
+ interp_list_goal ep e (l1 ++ l2).
+Proof.
+ intros ep e; simple induction l1;
+ [ simpl in |- *; intros l2 (H1, H2); assumption
+ | simpl in |- *; intros h1 t1 HR l2 ((H1, H2), H3); split; auto ].
+Qed.
+
+(* A simple decidability checker : if the proposition belongs to the
+ simple grammar describe below then it is decidable. Proof is by
+ induction and uses well known theorem about arithmetic and propositional
+ calculus *)
+
+Fixpoint decidability (p : proposition) : bool :=
+ match p with
+ | EqTerm _ _ => true
+ | LeqTerm _ _ => true
+ | GeqTerm _ _ => true
+ | GtTerm _ _ => true
+ | LtTerm _ _ => true
+ | NeqTerm _ _ => true
+ | FalseTerm => true
+ | TrueTerm => true
+ | Tnot t => decidability t
+ | Tand t1 t2 => decidability t1 && decidability t2
+ | Timp t1 t2 => decidability t1 && decidability t2
+ | Tor t1 t2 => decidability t1 && decidability t2
+ | Tprop _ => false
+ end.
+
+Theorem decidable_correct :
+ forall (ep : list Prop) (e : list int) (p : proposition),
+ decidability p = true -> decidable (interp_proposition ep e p).
+Proof.
+ simple induction p; simpl in |- *; intros;
+ [ apply dec_eq
+ | apply dec_le
+ | left; auto
+ | right; unfold not in |- *; auto
+ | apply dec_not; auto
+ | apply dec_ge
+ | apply dec_gt
+ | apply dec_lt
+ | apply dec_ne
+ | apply dec_or; elim andb_prop with (1 := H1); auto
+ | apply dec_and; elim andb_prop with (1 := H1); auto
+ | apply dec_imp; elim andb_prop with (1 := H1); auto
+ | discriminate H ].
+Qed.
+
+(* An interpretation function for a complete goal with an explicit
+ conclusion. We use an intermediate fixpoint. *)
+
+Fixpoint interp_full_goal (envp : list Prop) (env : list int)
+ (c : proposition) (l : hyps) {struct l} : Prop :=
+ match l with
+ | nil => interp_proposition envp env c
+ | p' :: l' =>
+ interp_proposition envp env p' -> interp_full_goal envp env c l'
+ end.
+
+Definition interp_full (ep : list Prop) (e : list int)
+ (lc : hyps * proposition) : Prop :=
+ match lc with
+ | (l, c) => interp_full_goal ep e c l
+ end.
+
+(* Relates the interpretation of a complete goal with the interpretation
+ of its hypothesis and conclusion *)
+
+Theorem interp_full_false :
+ forall (ep : list Prop) (e : list int) (l : hyps) (c : proposition),
+ (interp_hyps ep e l -> interp_proposition ep e c) -> interp_full ep e (l, c).
+Proof.
+ simple induction l; unfold interp_full in |- *; simpl in |- *;
+ [ auto | intros a l1 H1 c H2 H3; apply H1; auto ].
+Qed.
+
+(* Push the conclusion in the list of hypothesis using a double negation
+ If the decidability cannot be "proven", then just forget about the
+ conclusion (equivalent of replacing it with false) *)
+
+Definition to_contradict (lc : hyps * proposition) :=
+ match lc with
+ | (l, c) => if decidability c then Tnot c :: l else l
+ end.
+
+(* The previous operation is valid in the sense that the new list of
+ hypothesis implies the original goal *)
+
+Theorem to_contradict_valid :
+ forall (ep : list Prop) (e : list int) (lc : hyps * proposition),
+ interp_goal ep e (to_contradict lc) -> interp_full ep e lc.
+Proof.
+ intros ep e lc; case lc; intros l c; simpl in |- *;
+ pattern (decidability c) in |- *; apply bool_eq_ind;
+ [ simpl in |- *; intros H H1; apply interp_full_false; intros H2;
+ apply not_not;
+ [ apply decidable_correct; assumption
+ | unfold not at 1 in |- *; intro H3; apply hyps_to_goal with (2 := H2);
+ auto ]
+ | intros H1 H2; apply interp_full_false; intro H3;
+ elim hyps_to_goal with (1 := H2); assumption ].
+Qed.
+
+(* [map_cons x l] adds [x] at the head of each list in [l] (which is a list
+ of lists *)
+
+Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} :
+ list (list A) :=
+ match l with
+ | nil => nil
+ | l :: ll => (x :: l) :: map_cons A x ll
+ end.
+
+(* This function breaks up a list of hypothesis in a list of simpler
+ list of hypothesis that together implie the original one. The goal
+ of all this is to transform the goal in a list of solvable problems.
+ Note that :
+ - we need a way to drive the analysis as some hypotheis may not
+ require a split.
+ - this procedure must be perfectly mimicked by the ML part otherwise
+ hypothesis will get desynchronised and this will be a mess.
+ *)
+
+Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps :=
+ match nn with
+ | O => ll :: nil
+ | S n =>
+ match ll with
+ | nil => nil :: nil
+ | Tor p1 p2 :: l =>
+ destructure_hyps n (p1 :: l) ++ destructure_hyps n (p2 :: l)
+ | Tand p1 p2 :: l => destructure_hyps n (p1 :: p2 :: l)
+ | Timp p1 p2 :: l =>
+ if decidability p1
+ then
+ destructure_hyps n (Tnot p1 :: l) ++ destructure_hyps n (p2 :: l)
+ else map_cons _ (Timp p1 p2) (destructure_hyps n l)
+ | Tnot p :: l =>
+ match p with
+ | Tnot p1 =>
+ if decidability p1
+ then destructure_hyps n (p1 :: l)
+ else map_cons _ (Tnot (Tnot p1)) (destructure_hyps n l)
+ | Tor p1 p2 => destructure_hyps n (Tnot p1 :: Tnot p2 :: l)
+ | Tand p1 p2 =>
+ if decidability p1
+ then
+ destructure_hyps n (Tnot p1 :: l) ++
+ destructure_hyps n (Tnot p2 :: l)
+ else map_cons _ (Tnot p) (destructure_hyps n l)
+ | _ => map_cons _ (Tnot p) (destructure_hyps n l)
+ end
+ | x :: l => map_cons _ x (destructure_hyps n l)
+ end
+ end.
+
+Theorem map_cons_val :
+ forall (ep : list Prop) (e : list int) (p : proposition) (l : lhyps),
+ interp_proposition ep e p ->
+ interp_list_hyps ep e l -> interp_list_hyps ep e (map_cons _ p l).
+Proof.
+ simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ].
+Qed.
+
+Hint Resolve map_cons_val append_valid decidable_correct.
+
+Theorem destructure_hyps_valid :
+ forall n : nat, valid_list_hyps (destructure_hyps n).
+Proof.
+ simple induction n;
+ [ unfold valid_list_hyps in |- *; simpl in |- *; auto
+ | unfold valid_list_hyps at 2 in |- *; intros n1 H ep e lp; case lp;
+ [ simpl in |- *; auto
+ | intros p l; case p;
+ try
+ (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
+ auto);
+ [ intro p'; case p';
+ try
+ (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
+ auto);
+ [ simpl in |- *; intros p1 (H1, H2);
+ pattern (decidability p1) in |- *; apply bool_eq_ind;
+ intro H3;
+ [ apply H; simpl in |- *; split;
+ [ apply not_not; auto | assumption ]
+ | auto ]
+ | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *;
+ elim not_or with (1 := H1); auto
+ | simpl in |- *; intros p1 p2 (H1, H2);
+ pattern (decidability p1) in |- *; apply bool_eq_ind;
+ intro H3;
+ [ apply append_valid; elim not_and with (2 := H1);
+ [ intro; left; apply H; simpl in |- *; auto
+ | intro; right; apply H; simpl in |- *; auto
+ | auto ]
+ | auto ] ]
+ | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid;
+ (elim H1; intro H3; simpl in |- *; [ left | right ]);
+ apply H; simpl in |- *; auto
+ | simpl in |- *; intros; apply H; simpl in |- *; tauto
+ | simpl in |- *; intros p1 p2 (H1, H2);
+ pattern (decidability p1) in |- *; apply bool_eq_ind;
+ intro H3;
+ [ apply append_valid; elim imp_simp with (2 := H1);
+ [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto
+ | intro H4; right; simpl in |- *; apply H; simpl in |- *; auto
+ | auto ]
+ | auto ] ] ] ].
+Qed.
+
+Definition prop_stable (f : proposition -> proposition) :=
+ forall (ep : list Prop) (e : list int) (p : proposition),
+ interp_proposition ep e p <-> interp_proposition ep e (f p).
+
+Definition p_apply_left (f : proposition -> proposition)
+ (p : proposition) :=
+ match p with
+ | Timp x y => Timp (f x) y
+ | Tor x y => Tor (f x) y
+ | Tand x y => Tand (f x) y
+ | Tnot x => Tnot (f x)
+ | x => x
+ end.
+
+Theorem p_apply_left_stable :
+ forall f : proposition -> proposition,
+ prop_stable f -> prop_stable (p_apply_left f).
+Proof.
+ unfold prop_stable in |- *; intros f H ep e p; split;
+ (case p; simpl in |- *; auto; intros p1; elim (H ep e p1); tauto).
+Qed.
+
+Definition p_apply_right (f : proposition -> proposition)
+ (p : proposition) :=
+ match p with
+ | Timp x y => Timp x (f y)
+ | Tor x y => Tor x (f y)
+ | Tand x y => Tand x (f y)
+ | Tnot x => Tnot (f x)
+ | x => x
+ end.
+
+Theorem p_apply_right_stable :
+ forall f : proposition -> proposition,
+ prop_stable f -> prop_stable (p_apply_right f).
+Proof.
+ unfold prop_stable in |- *; intros f H ep e p; split;
+ (case p; simpl in |- *; auto;
+ [ intros p1; elim (H ep e p1); tauto
+ | intros p1 p2; elim (H ep e p2); tauto
+ | intros p1 p2; elim (H ep e p2); tauto
+ | intros p1 p2; elim (H ep e p2); tauto ]).
+Qed.
+
+Definition p_invert (f : proposition -> proposition)
+ (p : proposition) :=
+ match p with
+ | EqTerm x y => Tnot (f (NeqTerm x y))
+ | LeqTerm x y => Tnot (f (GtTerm x y))
+ | GeqTerm x y => Tnot (f (LtTerm x y))
+ | GtTerm x y => Tnot (f (LeqTerm x y))
+ | LtTerm x y => Tnot (f (GeqTerm x y))
+ | NeqTerm x y => Tnot (f (EqTerm x y))
+ | x => x
+ end.
+
+Theorem p_invert_stable :
+ forall f : proposition -> proposition,
+ prop_stable f -> prop_stable (p_invert f).
+Proof.
+ unfold prop_stable in |- *; intros f H ep e p; split;
+ (case p; simpl in |- *; auto;
+ [ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *;
+ generalize (dec_eq (interp_term e t1) (interp_term e t2));
+ unfold decidable in |- *; tauto
+ | intros t1 t2; elim (H ep e (GtTerm t1 t2)); simpl in |- *;
+ generalize (dec_gt (interp_term e t1) (interp_term e t2));
+ unfold decidable in |- *; rewrite le_lt_iff, <- gt_lt_iff; tauto
+ | intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *;
+ generalize (dec_lt (interp_term e t1) (interp_term e t2));
+ unfold decidable in |- *; rewrite ge_le_iff, le_lt_iff; tauto
+ | intros t1 t2; elim (H ep e (LeqTerm t1 t2)); simpl in |- *;
+ generalize (dec_gt (interp_term e t1) (interp_term e t2));
+ unfold decidable in |- *; repeat rewrite le_lt_iff;
+ repeat rewrite gt_lt_iff; tauto
+ | intros t1 t2; elim (H ep e (GeqTerm t1 t2)); simpl in |- *;
+ generalize (dec_lt (interp_term e t1) (interp_term e t2));
+ unfold decidable in |- *; repeat rewrite ge_le_iff;
+ repeat rewrite le_lt_iff; tauto
+ | intros t1 t2; elim (H ep e (EqTerm t1 t2)); simpl in |- *;
+ generalize (dec_eq (interp_term e t1) (interp_term e t2));
+ unfold decidable; tauto ]).
+Qed.
+
+Theorem move_right_stable : forall s : step, prop_stable (move_right s).
+Proof.
+ unfold move_right, prop_stable in |- *; intros s ep e p; split;
+ [ Simplify; simpl in |- *; elim (rewrite_stable s e); simpl in |- *;
+ [ symmetry in |- *; apply egal_left; assumption
+ | intro; apply le_left; assumption
+ | intro; apply le_left; rewrite <- ge_le_iff; assumption
+ | intro; apply lt_left; rewrite <- gt_lt_iff; assumption
+ | intro; apply lt_left; assumption
+ | intro; apply ne_left_2; assumption ]
+ | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s);
+ simpl in |- *; intro H1;
+ [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1;
+ rewrite plus_permute; rewrite plus_opp_r;
+ rewrite plus_0_r; trivial
+ | apply (fun a b => plus_le_reg_r a b (- interp_term e t));
+ rewrite plus_opp_r; assumption
+ | rewrite ge_le_iff;
+ apply (fun a b => plus_le_reg_r a b (- interp_term e t0));
+ rewrite plus_opp_r; assumption
+ | rewrite gt_lt_iff; apply lt_left_inv; assumption
+ | apply lt_left_inv; assumption
+ | unfold not in |- *; intro H2; apply H1;
+ rewrite H2; rewrite plus_opp_r; trivial ] ].
+Qed.
+
+
+Fixpoint p_rewrite (s : p_step) : proposition -> proposition :=
+ match s with
+ | P_LEFT s => p_apply_left (p_rewrite s)
+ | P_RIGHT s => p_apply_right (p_rewrite s)
+ | P_STEP s => move_right s
+ | P_INVERT s => p_invert (move_right s)
+ | P_NOP => fun p : proposition => p
+ end.
+
+Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s).
+Proof.
+ simple induction s; simpl in |- *;
+ [ intros; apply p_apply_left_stable; trivial
+ | intros; apply p_apply_right_stable; trivial
+ | intros; apply p_invert_stable; apply move_right_stable
+ | apply move_right_stable
+ | unfold prop_stable in |- *; simpl in |- *; intros; split; auto ].
+Qed.
+
+Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps :=
+ match l with
+ | nil => lh
+ | pair_step i s :: r => normalize_hyps r (apply_oper_1 i (p_rewrite s) lh)
+ end.
+
+Theorem normalize_hyps_valid :
+ forall l : list h_step, valid_hyps (normalize_hyps l).
+Proof.
+ simple induction l; unfold valid_hyps in |- *; simpl in |- *;
+ [ auto
+ | intros n_s r; case n_s; intros n s H ep e lp H1; apply H;
+ apply apply_oper_1_valid;
+ [ unfold valid1 in |- *; intros ep1 e1 p1 H2;
+ elim (p_rewrite_stable s ep1 e1 p1); auto
+ | assumption ] ].
+Qed.
+
+Theorem normalize_hyps_goal :
+ forall (s : list h_step) (ep : list Prop) (env : list int) (l : hyps),
+ interp_goal ep env (normalize_hyps s l) -> interp_goal ep env l.
+Proof.
+ intros; apply valid_goal with (2 := H); apply normalize_hyps_valid.
+Qed.
+
+Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} :
+ proposition :=
+ match s with
+ | D_left :: l =>
+ match p with
+ | Tand x y => extract_hyp_pos l x
+ | _ => p
+ end
+ | D_right :: l =>
+ match p with
+ | Tand x y => extract_hyp_pos l y
+ | _ => p
+ end
+ | D_mono :: l => match p with
+ | Tnot x => extract_hyp_neg l x
+ | _ => p
+ end
+ | _ => p
+ end
+
+ with extract_hyp_neg (s : list direction) (p : proposition) {struct s} :
+ proposition :=
+ match s with
+ | D_left :: l =>
+ match p with
+ | Tor x y => extract_hyp_neg l x
+ | Timp x y => if decidability x then extract_hyp_pos l x else Tnot p
+ | _ => Tnot p
+ end
+ | D_right :: l =>
+ match p with
+ | Tor x y => extract_hyp_neg l y
+ | Timp x y => extract_hyp_neg l y
+ | _ => Tnot p
+ end
+ | D_mono :: l =>
+ match p with
+ | Tnot x => if decidability x then extract_hyp_pos l x else Tnot p
+ | _ => Tnot p
+ end
+ | _ =>
+ match p with
+ | Tnot x => if decidability x then x else Tnot p
+ | _ => Tnot p
+ end
+ end.
+
+Definition co_valid1 (f : proposition -> proposition) :=
+ forall (ep : list Prop) (e : list int) (p1 : proposition),
+ interp_proposition ep e (Tnot p1) -> interp_proposition ep e (f p1).
+
+Theorem extract_valid :
+ forall s : list direction,
+ valid1 (extract_hyp_pos s) /\ co_valid1 (extract_hyp_neg s).
+Proof.
+ unfold valid1, co_valid1 in |- *; simple induction s;
+ [ split;
+ [ simpl in |- *; auto
+ | intros ep e p1; case p1; simpl in |- *; auto; intro p;
+ pattern (decidability p) in |- *; apply bool_eq_ind;
+ [ intro H; generalize (decidable_correct ep e p H);
+ unfold decidable in |- *; tauto
+ | simpl in |- *; auto ] ]
+ | intros a s' (H1, H2); simpl in H2; split; intros ep e p; case a; auto;
+ case p; auto; simpl in |- *; intros;
+ (apply H1; tauto) ||
+ (apply H2; tauto) ||
+ (pattern (decidability p0) in |- *; apply bool_eq_ind;
+ [ intro H3; generalize (decidable_correct ep e p0 H3);
+ unfold decidable in |- *; intro H4; apply H1;
+ tauto
+ | intro; tauto ]) ].
+Qed.
+
+Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps :=
+ match s with
+ | E_SPLIT i dl s1 s2 =>
+ match extract_hyp_pos dl (nth_hyps i h) with
+ | Tor x y => decompose_solve s1 (x :: h) ++ decompose_solve s2 (y :: h)
+ | Tnot (Tand x y) =>
+ if decidability x
+ then
+ decompose_solve s1 (Tnot x :: h) ++
+ decompose_solve s2 (Tnot y :: h)
+ else h :: nil
+ | Timp x y =>
+ if decidability x then
+ decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h)
+ else h::nil
+ | _ => h :: nil
+ end
+ | E_EXTRACT i dl s1 =>
+ decompose_solve s1 (extract_hyp_pos dl (nth_hyps i h) :: h)
+ | E_SOLVE t => execute_omega t h
+ end.
+
+Theorem decompose_solve_valid :
+ forall s : e_step, valid_list_goal (decompose_solve s).
+Proof.
+ intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s;
+ simpl in |- *; intros;
+ [ cut (interp_proposition ep e1 (extract_hyp_pos l (nth_hyps n lp)));
+ [ case (extract_hyp_pos l (nth_hyps n lp)); simpl in |- *; auto;
+ [ intro p; case p; simpl in |- *; auto; intros p1 p2 H2;
+ pattern (decidability p1) in |- *; apply bool_eq_ind;
+ [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4;
+ apply append_valid; elim H4; intro H5;
+ [ right; apply H0; simpl in |- *; tauto
+ | left; apply H; simpl in |- *; tauto ]
+ | simpl in |- *; auto ]
+ | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2;
+ [ intros H3; left; apply H; simpl in |- *; auto
+ | intros H3; right; apply H0; simpl in |- *; auto ]
+ | intros p1 p2 H2;
+ pattern (decidability p1) in |- *; apply bool_eq_ind;
+ [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4;
+ apply append_valid; elim H4; intro H5;
+ [ right; apply H0; simpl in |- *; tauto
+ | left; apply H; simpl in |- *; tauto ]
+ | simpl in |- *; auto ] ]
+ | elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto ]
+ | intros; apply H; simpl in |- *; split;
+ [ elim (extract_valid l); intros H2 H3; apply H2; apply nth_valid; auto
+ | auto ]
+ | apply omega_valid with (1 := H) ].
+Qed.
+
+(* \subsection{La dernière étape qui élimine tous les séquents inutiles} *)
+
+Definition valid_lhyps (f : lhyps -> lhyps) :=
+ forall (ep : list Prop) (e : list int) (lp : lhyps),
+ interp_list_hyps ep e lp -> interp_list_hyps ep e (f lp).
+
+Fixpoint reduce_lhyps (lp : lhyps) : lhyps :=
+ match lp with
+ | (FalseTerm :: nil) :: lp' => reduce_lhyps lp'
+ | x :: lp' => x :: reduce_lhyps lp'
+ | nil => nil (A:=hyps)
+ end.
+
+Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps.
+Proof.
+ unfold valid_lhyps in |- *; intros ep e lp; elim lp;
+ [ simpl in |- *; auto
+ | intros a l HR; elim a;
+ [ simpl in |- *; tauto
+ | intros a1 l1; case l1; case a1; simpl in |- *; try tauto ] ].
+Qed.
+
+Theorem do_reduce_lhyps :
+ forall (envp : list Prop) (env : list int) (l : lhyps),
+ interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l.
+Proof.
+ intros envp env l H; apply list_goal_to_hyps; intro H1;
+ apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid;
+ assumption.
+Qed.
+
+Definition concl_to_hyp (p : proposition) :=
+ if decidability p then Tnot p else TrueTerm.
+
+Definition do_concl_to_hyp :
+ forall (envp : list Prop) (env : list int) (c : proposition) (l : hyps),
+ interp_goal envp env (concl_to_hyp c :: l) ->
+ interp_goal_concl c envp env l.
+Proof.
+ simpl in |- *; intros envp env c l; induction l as [| a l Hrecl];
+ [ simpl in |- *; unfold concl_to_hyp in |- *;
+ pattern (decidability c) in |- *; apply bool_eq_ind;
+ [ intro H; generalize (decidable_correct envp env c H);
+ unfold decidable in |- *; simpl in |- *; tauto
+ | simpl in |- *; intros H1 H2; elim H2; trivial ]
+ | simpl in |- *; tauto ].
+Qed.
+
+Definition omega_tactic (t1 : e_step) (t2 : list h_step)
+ (c : proposition) (l : hyps) :=
+ reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))).
+
+Theorem do_omega :
+ forall (t1 : e_step) (t2 : list h_step) (envp : list Prop)
+ (env : list int) (c : proposition) (l : hyps),
+ interp_list_goal envp env (omega_tactic t1 t2 c l) ->
+ interp_goal_concl c envp env l.
+Proof.
+ unfold omega_tactic in |- *; intros; apply do_concl_to_hyp;
+ apply (normalize_hyps_goal t2); apply (decompose_solve_valid t1);
+ apply do_reduce_lhyps; assumption.
+Qed.
+
+End IntOmega.
+
+(* For now, the above modular construction is instanciated on Z,
+ in order to retrieve the initial ROmega. *)
+
+Module ZOmega := IntOmega(Z_as_Int).
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
new file mode 100644
index 00000000..f4368a1b
--- /dev/null
+++ b/plugins/romega/const_omega.ml
@@ -0,0 +1,352 @@
+(*************************************************************************
+
+ PROJET RNRT Calife - 2001
+ Author: Pierre Crégut - France Télécom R&D
+ Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+let module_refl_name = "ReflOmegaCore"
+let module_refl_path = ["Coq"; "romega"; module_refl_name]
+
+type result =
+ Kvar of string
+ | Kapp of string * Term.constr list
+ | Kimp of Term.constr * Term.constr
+ | Kufo;;
+
+let destructurate t =
+ let c, args = Term.decompose_app t in
+ 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)
+ | Term.Construct csp , args ->
+ Kapp (Names.string_of_id
+ (Nametab.basename_of_global (Libnames.ConstructRef csp)),
+ args)
+ | Term.Ind isp, args ->
+ Kapp (Names.string_of_id
+ (Nametab.basename_of_global (Libnames.IndRef isp)),
+ args)
+ | Term.Var id,[] -> Kvar(Names.string_of_id id)
+ | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
+ | Term.Prod (Names.Name _,_,_),[] ->
+ Util.error "Omega: Not a quantifier-free goal"
+ | _ -> Kufo
+
+exception Destruct
+
+let dest_const_apply t =
+ let f,args = Term.decompose_app t in
+ let ref =
+ match Term.kind_of_term f with
+ | Term.Const sp -> Libnames.ConstRef sp
+ | Term.Construct csp -> Libnames.ConstructRef csp
+ | Term.Ind isp -> Libnames.IndRef isp
+ | _ -> raise Destruct
+ in Nametab.basename_of_global ref, args
+
+let logic_dir = ["Coq";"Logic";"Decidable"]
+
+let coq_modules =
+ Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules
+ @ [["Coq"; "Lists"; "List"]]
+ @ [module_refl_path]
+ @ [module_refl_path@["ZOmega"]]
+
+
+let init_constant = Coqlib.gen_constant_in_modules "Omega" Coqlib.init_modules
+let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules
+
+(* Logic *)
+let coq_eq = lazy(init_constant "eq")
+let coq_refl_equal = lazy(init_constant "eq_refl")
+let coq_and = lazy(init_constant "and")
+let coq_not = lazy(init_constant "not")
+let coq_or = lazy(init_constant "or")
+let coq_True = lazy(init_constant "True")
+let coq_False = lazy(init_constant "False")
+let coq_I = lazy(init_constant "I")
+
+(* ReflOmegaCore/ZOmega *)
+
+let coq_h_step = lazy (constant "h_step")
+let coq_pair_step = lazy (constant "pair_step")
+let coq_p_left = lazy (constant "P_LEFT")
+let coq_p_right = lazy (constant "P_RIGHT")
+let coq_p_invert = lazy (constant "P_INVERT")
+let coq_p_step = lazy (constant "P_STEP")
+
+let coq_t_int = lazy (constant "Tint")
+let coq_t_plus = lazy (constant "Tplus")
+let coq_t_mult = lazy (constant "Tmult")
+let coq_t_opp = lazy (constant "Topp")
+let coq_t_minus = lazy (constant "Tminus")
+let coq_t_var = lazy (constant "Tvar")
+
+let coq_proposition = lazy (constant "proposition")
+let coq_p_eq = lazy (constant "EqTerm")
+let coq_p_leq = lazy (constant "LeqTerm")
+let coq_p_geq = lazy (constant "GeqTerm")
+let coq_p_lt = lazy (constant "LtTerm")
+let coq_p_gt = lazy (constant "GtTerm")
+let coq_p_neq = lazy (constant "NeqTerm")
+let coq_p_true = lazy (constant "TrueTerm")
+let coq_p_false = lazy (constant "FalseTerm")
+let coq_p_not = lazy (constant "Tnot")
+let coq_p_or = lazy (constant "Tor")
+let coq_p_and = lazy (constant "Tand")
+let coq_p_imp = lazy (constant "Timp")
+let coq_p_prop = lazy (constant "Tprop")
+
+(* Constructors for shuffle tactic *)
+let coq_t_fusion = lazy (constant "t_fusion")
+let coq_f_equal = lazy (constant "F_equal")
+let coq_f_cancel = lazy (constant "F_cancel")
+let coq_f_left = lazy (constant "F_left")
+let coq_f_right = lazy (constant "F_right")
+
+(* Constructors for reordering tactics *)
+let coq_c_do_both = lazy (constant "C_DO_BOTH")
+let coq_c_do_left = lazy (constant "C_LEFT")
+let coq_c_do_right = lazy (constant "C_RIGHT")
+let coq_c_do_seq = lazy (constant "C_SEQ")
+let coq_c_nop = lazy (constant "C_NOP")
+let coq_c_opp_plus = lazy (constant "C_OPP_PLUS")
+let coq_c_opp_opp = lazy (constant "C_OPP_OPP")
+let coq_c_opp_mult_r = lazy (constant "C_OPP_MULT_R")
+let coq_c_opp_one = lazy (constant "C_OPP_ONE")
+let coq_c_reduce = lazy (constant "C_REDUCE")
+let coq_c_mult_plus_distr = lazy (constant "C_MULT_PLUS_DISTR")
+let coq_c_opp_left = lazy (constant "C_MULT_OPP_LEFT")
+let coq_c_mult_assoc_r = lazy (constant "C_MULT_ASSOC_R")
+let coq_c_plus_assoc_r = lazy (constant "C_PLUS_ASSOC_R")
+let coq_c_plus_assoc_l = lazy (constant "C_PLUS_ASSOC_L")
+let coq_c_plus_permute = lazy (constant "C_PLUS_PERMUTE")
+let coq_c_plus_comm = lazy (constant "C_PLUS_COMM")
+let coq_c_red0 = lazy (constant "C_RED0")
+let coq_c_red1 = lazy (constant "C_RED1")
+let coq_c_red2 = lazy (constant "C_RED2")
+let coq_c_red3 = lazy (constant "C_RED3")
+let coq_c_red4 = lazy (constant "C_RED4")
+let coq_c_red5 = lazy (constant "C_RED5")
+let coq_c_red6 = lazy (constant "C_RED6")
+let coq_c_mult_opp_left = lazy (constant "C_MULT_OPP_LEFT")
+let coq_c_mult_assoc_reduced = lazy (constant "C_MULT_ASSOC_REDUCED")
+let coq_c_minus = lazy (constant "C_MINUS")
+let coq_c_mult_comm = lazy (constant "C_MULT_COMM")
+
+let coq_s_constant_not_nul = lazy (constant "O_CONSTANT_NOT_NUL")
+let coq_s_constant_neg = lazy (constant "O_CONSTANT_NEG")
+let coq_s_div_approx = lazy (constant "O_DIV_APPROX")
+let coq_s_not_exact_divide = lazy (constant "O_NOT_EXACT_DIVIDE")
+let coq_s_exact_divide = lazy (constant "O_EXACT_DIVIDE")
+let coq_s_sum = lazy (constant "O_SUM")
+let coq_s_state = lazy (constant "O_STATE")
+let coq_s_contradiction = lazy (constant "O_CONTRADICTION")
+let coq_s_merge_eq = lazy (constant "O_MERGE_EQ")
+let coq_s_split_ineq =lazy (constant "O_SPLIT_INEQ")
+let coq_s_constant_nul =lazy (constant "O_CONSTANT_NUL")
+let coq_s_negate_contradict =lazy (constant "O_NEGATE_CONTRADICT")
+let coq_s_negate_contradict_inv =lazy (constant "O_NEGATE_CONTRADICT_INV")
+
+(* construction for the [extract_hyp] tactic *)
+let coq_direction = lazy (constant "direction")
+let coq_d_left = lazy (constant "D_left")
+let coq_d_right = lazy (constant "D_right")
+let coq_d_mono = lazy (constant "D_mono")
+
+let coq_e_split = lazy (constant "E_SPLIT")
+let coq_e_extract = lazy (constant "E_EXTRACT")
+let coq_e_solve = lazy (constant "E_SOLVE")
+
+let coq_interp_sequent = lazy (constant "interp_goal_concl")
+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
+ else Term.mkApp (Lazy.force coq_c_do_left, [|t |] )
+
+let do_right t =
+ if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop
+ else Term.mkApp (Lazy.force coq_c_do_right, [|t |])
+
+let do_both t1 t2 =
+ if t1 = Lazy.force coq_c_nop then do_right t2
+ else if t2 = Lazy.force coq_c_nop then do_left t1
+ else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |])
+
+let do_seq t1 t2 =
+ if t1 = Lazy.force coq_c_nop then t2
+ else if t2 = Lazy.force coq_c_nop then t1
+ else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |])
+
+let rec do_list = function
+ | [] -> Lazy.force coq_c_nop
+ | [x] -> x
+ | (x::l) -> do_seq x (do_list l)
+
+(* Nat *)
+
+let coq_S = lazy(init_constant "S")
+let coq_O = lazy(init_constant "O")
+
+let rec mk_nat = function
+ | 0 -> Lazy.force coq_O
+ | n -> Term.mkApp (Lazy.force coq_S, [| mk_nat (n-1) |])
+
+(* Lists *)
+
+let coq_cons = lazy (constant "cons")
+let coq_nil = lazy (constant "nil")
+
+let mk_list typ l =
+ let rec loop = function
+ | [] ->
+ Term.mkApp (Lazy.force coq_nil, [|typ|])
+ | (step :: l) ->
+ Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in
+ loop l
+
+let mk_plist l = mk_list Term.mkProp l
+
+let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l
+
+
+type parse_term =
+ | Tplus of Term.constr * Term.constr
+ | Tmult of Term.constr * Term.constr
+ | Tminus of Term.constr * Term.constr
+ | Topp of Term.constr
+ | Tsucc of Term.constr
+ | Tnum of Bigint.bigint
+ | Tother
+
+type parse_rel =
+ | Req of Term.constr * Term.constr
+ | Rne of Term.constr * Term.constr
+ | Rlt of Term.constr * Term.constr
+ | Rle of Term.constr * Term.constr
+ | Rgt of Term.constr * Term.constr
+ | Rge of Term.constr * Term.constr
+ | Rtrue
+ | Rfalse
+ | Rnot of Term.constr
+ | Ror of Term.constr * Term.constr
+ | Rand of Term.constr * Term.constr
+ | Rimp of Term.constr * Term.constr
+ | Riff of Term.constr * Term.constr
+ | Rother
+
+let parse_logic_rel c =
+ try match destructurate c with
+ | Kapp("True",[]) -> Rtrue
+ | Kapp("False",[]) -> Rfalse
+ | Kapp("not",[t]) -> Rnot t
+ | Kapp("or",[t1;t2]) -> Ror (t1,t2)
+ | Kapp("and",[t1;t2]) -> Rand (t1,t2)
+ | Kimp(t1,t2) -> Rimp (t1,t2)
+ | Kapp("iff",[t1;t2]) -> Riff (t1,t2)
+ | _ -> Rother
+ with e when Logic.catchable_exception e -> Rother
+
+
+module type Int = sig
+ val typ : Term.constr Lazy.t
+ val plus : Term.constr Lazy.t
+ val mult : Term.constr Lazy.t
+ val opp : Term.constr Lazy.t
+ val minus : Term.constr Lazy.t
+
+ val mk : Bigint.bigint -> Term.constr
+ val parse_term : Term.constr -> parse_term
+ val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel
+ (* check whether t is built only with numbers and + * - *)
+ val is_scalar : Term.constr -> bool
+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 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 recognize t =
+ let rec loop t =
+ let f,l = dest_const_apply t in
+ match Names.string_of_id f,l with
+ "xI",[t] -> Bigint.add Bigint.one (Bigint.mult Bigint.two (loop t))
+ | "xO",[t] -> Bigint.mult Bigint.two (loop t)
+ | "xH",[] -> Bigint.one
+ | _ -> failwith "not a number" in
+ let f,l = dest_const_apply t in
+ match Names.string_of_id f,l with
+ "Zpos",[t] -> loop t
+ | "Zneg",[t] -> Bigint.neg (loop t)
+ | "Z0",[] -> Bigint.zero
+ | _ -> failwith "not a number";;
+
+let rec mk_positive n =
+ if n=Bigint.one then Lazy.force coq_xH
+ else
+ let (q,r) = Bigint.euclid n Bigint.two in
+ Term.mkApp
+ ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI),
+ [| mk_positive q |])
+
+let mk_Z n =
+ if n = Bigint.zero then Lazy.force coq_Z0
+ else if Bigint.is_strictly_pos n then
+ Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |])
+ else
+ Term.mkApp (Lazy.force coq_Zneg, [| mk_positive (Bigint.neg n) |])
+
+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(("Zpos"|"Zneg"|"Z0"),_) ->
+ (try Tnum (recognize t) with _ -> Tother)
+ | _ -> Tother
+ with e when Logic.catchable_exception e -> Tother
+
+let parse_rel gl t =
+ try match destructurate t with
+ | 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)
+ | _ -> 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(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true
+ | _ -> false in
+ try aux t with _ -> false
+
+end
diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli
new file mode 100644
index 00000000..b8db71e4
--- /dev/null
+++ b/plugins/romega/const_omega.mli
@@ -0,0 +1,176 @@
+(*************************************************************************
+
+ PROJET RNRT Calife - 2001
+ Author: Pierre Crégut - France Télécom R&D
+ Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+
+(** Coq objects used in romega *)
+
+(* from Logic *)
+val coq_refl_equal : Term.constr lazy_t
+val coq_and : Term.constr lazy_t
+val coq_not : Term.constr lazy_t
+val coq_or : Term.constr lazy_t
+val coq_True : Term.constr lazy_t
+val coq_False : Term.constr lazy_t
+val coq_I : Term.constr lazy_t
+
+(* from ReflOmegaCore/ZOmega *)
+val coq_h_step : Term.constr lazy_t
+val coq_pair_step : Term.constr lazy_t
+val coq_p_left : Term.constr lazy_t
+val coq_p_right : Term.constr lazy_t
+val coq_p_invert : Term.constr lazy_t
+val coq_p_step : Term.constr lazy_t
+
+val coq_t_int : Term.constr lazy_t
+val coq_t_plus : Term.constr lazy_t
+val coq_t_mult : Term.constr lazy_t
+val coq_t_opp : Term.constr lazy_t
+val coq_t_minus : Term.constr lazy_t
+val coq_t_var : Term.constr lazy_t
+
+val coq_proposition : Term.constr lazy_t
+val coq_p_eq : Term.constr lazy_t
+val coq_p_leq : Term.constr lazy_t
+val coq_p_geq : Term.constr lazy_t
+val coq_p_lt : Term.constr lazy_t
+val coq_p_gt : Term.constr lazy_t
+val coq_p_neq : Term.constr lazy_t
+val coq_p_true : Term.constr lazy_t
+val coq_p_false : Term.constr lazy_t
+val coq_p_not : Term.constr lazy_t
+val coq_p_or : Term.constr lazy_t
+val coq_p_and : Term.constr lazy_t
+val coq_p_imp : Term.constr lazy_t
+val coq_p_prop : Term.constr lazy_t
+
+val coq_f_equal : Term.constr lazy_t
+val coq_f_cancel : Term.constr lazy_t
+val coq_f_left : Term.constr lazy_t
+val coq_f_right : Term.constr lazy_t
+
+val coq_c_do_both : Term.constr lazy_t
+val coq_c_do_left : Term.constr lazy_t
+val coq_c_do_right : Term.constr lazy_t
+val coq_c_do_seq : Term.constr lazy_t
+val coq_c_nop : Term.constr lazy_t
+val coq_c_opp_plus : Term.constr lazy_t
+val coq_c_opp_opp : Term.constr lazy_t
+val coq_c_opp_mult_r : Term.constr lazy_t
+val coq_c_opp_one : Term.constr lazy_t
+val coq_c_reduce : Term.constr lazy_t
+val coq_c_mult_plus_distr : Term.constr lazy_t
+val coq_c_opp_left : Term.constr lazy_t
+val coq_c_mult_assoc_r : Term.constr lazy_t
+val coq_c_plus_assoc_r : Term.constr lazy_t
+val coq_c_plus_assoc_l : Term.constr lazy_t
+val coq_c_plus_permute : Term.constr lazy_t
+val coq_c_plus_comm : Term.constr lazy_t
+val coq_c_red0 : Term.constr lazy_t
+val coq_c_red1 : Term.constr lazy_t
+val coq_c_red2 : Term.constr lazy_t
+val coq_c_red3 : Term.constr lazy_t
+val coq_c_red4 : Term.constr lazy_t
+val coq_c_red5 : Term.constr lazy_t
+val coq_c_red6 : Term.constr lazy_t
+val coq_c_mult_opp_left : Term.constr lazy_t
+val coq_c_mult_assoc_reduced : Term.constr lazy_t
+val coq_c_minus : Term.constr lazy_t
+val coq_c_mult_comm : Term.constr lazy_t
+
+val coq_s_constant_not_nul : Term.constr lazy_t
+val coq_s_constant_neg : Term.constr lazy_t
+val coq_s_div_approx : Term.constr lazy_t
+val coq_s_not_exact_divide : Term.constr lazy_t
+val coq_s_exact_divide : Term.constr lazy_t
+val coq_s_sum : Term.constr lazy_t
+val coq_s_state : Term.constr lazy_t
+val coq_s_contradiction : Term.constr lazy_t
+val coq_s_merge_eq : Term.constr lazy_t
+val coq_s_split_ineq : Term.constr lazy_t
+val coq_s_constant_nul : Term.constr lazy_t
+val coq_s_negate_contradict : Term.constr lazy_t
+val coq_s_negate_contradict_inv : Term.constr lazy_t
+
+val coq_direction : Term.constr lazy_t
+val coq_d_left : Term.constr lazy_t
+val coq_d_right : Term.constr lazy_t
+val coq_d_mono : Term.constr lazy_t
+
+val coq_e_split : Term.constr lazy_t
+val coq_e_extract : Term.constr lazy_t
+val coq_e_solve : Term.constr lazy_t
+
+val coq_interp_sequent : Term.constr lazy_t
+val coq_do_omega : Term.constr lazy_t
+
+(** Building expressions *)
+
+val do_left : Term.constr -> Term.constr
+val do_right : Term.constr -> Term.constr
+val do_both : Term.constr -> Term.constr -> Term.constr
+val do_seq : Term.constr -> Term.constr -> Term.constr
+val do_list : Term.constr list -> Term.constr
+
+val mk_nat : int -> Term.constr
+val mk_list : Term.constr -> Term.constr list -> Term.constr
+val mk_plist : Term.types list -> Term.types
+val mk_shuffle_list : Term.constr list -> Term.constr
+
+(** Analyzing a coq term *)
+
+(* The generic result shape of the analysis of a term.
+ One-level depth, except when a number is found *)
+type parse_term =
+ Tplus of Term.constr * Term.constr
+ | Tmult of Term.constr * Term.constr
+ | Tminus of Term.constr * Term.constr
+ | Topp of Term.constr
+ | Tsucc of Term.constr
+ | Tnum of Bigint.bigint
+ | Tother
+
+(* The generic result shape of the analysis of a relation.
+ One-level depth. *)
+type parse_rel =
+ Req of Term.constr * Term.constr
+ | Rne of Term.constr * Term.constr
+ | Rlt of Term.constr * Term.constr
+ | Rle of Term.constr * Term.constr
+ | Rgt of Term.constr * Term.constr
+ | Rge of Term.constr * Term.constr
+ | Rtrue
+ | Rfalse
+ | Rnot of Term.constr
+ | Ror of Term.constr * Term.constr
+ | Rand of Term.constr * Term.constr
+ | Rimp of Term.constr * Term.constr
+ | Riff of Term.constr * Term.constr
+ | Rother
+
+(* A module factorizing what we should now about the number representation *)
+module type Int =
+ sig
+ (* the coq type of the numbers *)
+ val typ : Term.constr Lazy.t
+ (* the operations on the numbers *)
+ val plus : Term.constr Lazy.t
+ val mult : Term.constr Lazy.t
+ val opp : Term.constr Lazy.t
+ val minus : Term.constr Lazy.t
+ (* building a coq number *)
+ val mk : Bigint.bigint -> Term.constr
+ (* parsing a term (one level, except if a number is found) *)
+ val parse_term : Term.constr -> parse_term
+ (* parsing a relation expression, including = < <= >= > *)
+ val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel
+ (* Is a particular term only made of numbers and + * - ? *)
+ val is_scalar : Term.constr -> bool
+ end
+
+(* Currently, we only use Z numbers *)
+module Z : Int
diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
new file mode 100644
index 00000000..2db86e00
--- /dev/null
+++ b/plugins/romega/g_romega.ml4
@@ -0,0 +1,42 @@
+(*************************************************************************
+
+ PROJET RNRT Calife - 2001
+ Author: Pierre Crégut - France Télécom R&D
+ Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+open Refl_omega
+open Refiner
+
+let romega_tactic l =
+ let tacs = List.map
+ (function
+ | "nat" -> Tacinterp.interp <:tactic<zify_nat>>
+ | "positive" -> Tacinterp.interp <:tactic<zify_positive>>
+ | "N" -> Tacinterp.interp <:tactic<zify_N>>
+ | "Z" -> Tacinterp.interp <:tactic<zify_op>>
+ | s -> Util.error ("No ROmega knowledge base for type "^s))
+ (Util.list_uniquize (List.sort compare l))
+ in
+ tclTHEN
+ (tclREPEAT (tclPROGRESS (tclTHENLIST tacs)))
+ (tclTHEN
+ (* because of the contradiction process in (r)omega,
+ we'd better leave as little as possible in the conclusion,
+ for an easier decidability argument. *)
+ Tactics.intros
+ total_reflexive_omega_tactic)
+
+
+TACTIC EXTEND romega
+| [ "romega" ] -> [ romega_tactic [] ]
+END
+
+TACTIC EXTEND romega'
+| [ "romega" "with" ne_ident_list(l) ] ->
+ [ romega_tactic (List.map Names.string_of_id l) ]
+| [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ]
+END
diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
new file mode 100644
index 00000000..570bb187
--- /dev/null
+++ b/plugins/romega/refl_omega.ml
@@ -0,0 +1,1299 @@
+(*************************************************************************
+
+ PROJET RNRT Calife - 2001
+ Author: Pierre Crégut - France Télécom R&D
+ Licence : LGPL version 2.1
+
+ *************************************************************************)
+
+open Util
+open Const_omega
+module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
+open OmegaSolver
+
+(* \section{Useful functions and flags} *)
+(* Especially useful debugging functions *)
+let debug = ref false
+
+let show_goal gl =
+ if !debug then Pp.ppnl (Tacmach.pr_gls gl); Tacticals.tclIDTAC gl
+
+let pp i = print_int i; print_newline (); flush stdout
+
+(* More readable than the prefix notation *)
+let (>>) = Tacticals.tclTHEN
+
+let mkApp = Term.mkApp
+
+(* \section{Types}
+ \subsection{How to walk in a term}
+ To represent how to get to a proposition. Only choice points are
+ kept (branch to choose in a disjunction and identifier of the disjunctive
+ connector) *)
+type direction = Left of int | Right of int
+
+(* Step to find a proposition (operators are at most binary). A list is
+ a path *)
+type occ_step = O_left | O_right | O_mono
+type occ_path = occ_step list
+
+(* chemin identifiant une proposition sous forme du nom de l'hypothèse et
+ d'une liste de pas à partir de la racine de l'hypothèse *)
+type occurence = {o_hyp : Names.identifier; o_path : occ_path}
+
+(* \subsection{refiable formulas} *)
+type oformula =
+ (* integer *)
+ | Oint of Bigint.bigint
+ (* recognized binary and unary operations *)
+ | Oplus of oformula * oformula
+ | Omult of oformula * oformula
+ | Ominus of oformula * oformula
+ | Oopp of oformula
+ (* an atome in the environment *)
+ | Oatom of int
+ (* weird expression that cannot be translated *)
+ | Oufo of oformula
+
+(* Operators for comparison recognized by Omega *)
+type comparaison = Eq | Leq | Geq | Gt | Lt | Neq
+
+(* Type des prédicats réifiés (fragment de calcul propositionnel. Les
+ * quantifications sont externes au langage) *)
+type oproposition =
+ Pequa of Term.constr * oequation
+ | Ptrue
+ | Pfalse
+ | Pnot of oproposition
+ | Por of int * oproposition * oproposition
+ | Pand of int * oproposition * oproposition
+ | Pimp of int * oproposition * oproposition
+ | Pprop of Term.constr
+
+(* Les équations ou proposiitions atomiques utiles du calcul *)
+and oequation = {
+ e_comp: comparaison; (* comparaison *)
+ e_left: oformula; (* formule brute gauche *)
+ e_right: oformula; (* formule brute droite *)
+ e_trace: Term.constr; (* tactique de normalisation *)
+ e_origin: occurence; (* l'hypothèse dont vient le terme *)
+ e_negated: bool; (* vrai si apparait en position nié
+ après normalisation *)
+ e_depends: direction list; (* liste des points de disjonction dont
+ dépend l'accès à l'équation avec la
+ direction (branche) pour y accéder *)
+ e_omega: afine (* la fonction normalisée *)
+ }
+
+(* \subsection{Proof context}
+ This environment codes
+ \begin{itemize}
+ \item the terms and propositions that are given as
+ parameters of the reified proof (and are represented as variables in the
+ reified goals)
+ \item translation functions linking the decision procedure and the Coq proof
+ \end{itemize} *)
+
+type environment = {
+ (* La liste des termes non reifies constituant l'environnement global *)
+ mutable terms : Term.constr list;
+ (* La meme chose pour les propositions *)
+ mutable props : Term.constr list;
+ (* Les variables introduites par omega *)
+ mutable om_vars : (oformula * int) list;
+ (* Traduction des indices utilisés ici en les indices finaux utilisés par
+ * la tactique Omega après dénombrement des variables utiles *)
+ real_indices : (int,int) Hashtbl.t;
+ mutable cnt_connectors : int;
+ equations : (int,oequation) Hashtbl.t;
+ constructors : (int, occurence) Hashtbl.t
+}
+
+(* \subsection{Solution tree}
+ Définition d'une solution trouvée par Omega sous la forme d'un identifiant,
+ d'un ensemble d'équation dont dépend la solution et d'une trace *)
+(* La liste des dépendances est triée et sans redondance *)
+type solution = {
+ s_index : int;
+ s_equa_deps : int list;
+ s_trace : action list }
+
+(* Arbre de solution résolvant complètement un ensemble de systèmes *)
+type solution_tree =
+ Leaf of solution
+ (* un noeud interne représente un point de branchement correspondant à
+ l'élimination d'un connecteur générant plusieurs buts
+ (typ. disjonction). Le premier argument
+ est l'identifiant du connecteur *)
+ | Tree of int * solution_tree * solution_tree
+
+(* Représentation de l'environnement extrait du but initial sous forme de
+ chemins pour extraire des equations ou d'hypothèses *)
+
+type context_content =
+ CCHyp of occurence
+ | CCEqua of int
+
+(* \section{Specific utility functions to handle base types} *)
+(* Nom arbitraire de l'hypothèse codant la négation du but final *)
+let id_concl = Names.id_of_string "__goal__"
+
+(* Initialisation de l'environnement de réification de la tactique *)
+let new_environment () = {
+ terms = []; props = []; om_vars = []; cnt_connectors = 0;
+ real_indices = Hashtbl.create 7;
+ equations = Hashtbl.create 7;
+ constructors = Hashtbl.create 7;
+}
+
+(* Génération d'un nom d'équation *)
+let new_connector_id env =
+ env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors
+
+(* Calcul de la branche complémentaire *)
+let barre = function Left x -> Right x | Right x -> Left x
+
+(* Identifiant associé à une branche *)
+let indice = function Left x | Right x -> x
+
+(* Affichage de l'environnement de réification (termes et propositions) *)
+let print_env_reification env =
+ let rec loop c i = function
+ [] -> Printf.printf " ===============================\n\n"
+ | t :: l ->
+ Printf.printf " (%c%02d) := " c i;
+ Pp.ppnl (Printer.pr_lconstr t);
+ Pp.flush_all ();
+ loop c (succ i) l in
+ print_newline ();
+ Printf.printf " ENVIRONMENT OF PROPOSITIONS :\n\n"; loop 'P' 0 env.props;
+ Printf.printf " ENVIRONMENT OF TERMS :\n\n"; loop 'V' 0 env.terms
+
+
+(* \subsection{Gestion des environnements de variable pour Omega} *)
+(* generation d'identifiant d'equation pour Omega *)
+
+let new_omega_eq, rst_omega_eq =
+ let cpt = ref 0 in
+ (function () -> incr cpt; !cpt),
+ (function () -> cpt:=0)
+
+(* generation d'identifiant de variable pour Omega *)
+
+let new_omega_var, rst_omega_var =
+ let cpt = ref 0 in
+ (function () -> incr cpt; !cpt),
+ (function () -> cpt:=0)
+
+(* Affichage des variables d'un système *)
+
+let display_omega_var i = Printf.sprintf "OV%d" i
+
+(* Recherche la variable codant un terme pour Omega et crée la variable dans
+ l'environnement si il n'existe pas. Cas ou la variable dans Omega représente
+ le terme d'un monome (le plus souvent un atome) *)
+
+let intern_omega env t =
+ begin try List.assoc t env.om_vars
+ with Not_found ->
+ let v = new_omega_var () in
+ env.om_vars <- (t,v) :: env.om_vars; v
+ end
+
+(* Ajout forcé d'un lien entre un terme et une variable Cas où la
+ variable est créée par Omega et où il faut la lier après coup à un atome
+ réifié introduit de force *)
+let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars
+
+(* Récupère le terme associé à une variable *)
+let unintern_omega env id =
+ let rec loop = function
+ [] -> failwith "unintern"
+ | ((t,j)::l) -> if id = j then t else loop l in
+ loop env.om_vars
+
+(* \subsection{Gestion des environnements de variable pour la réflexion}
+ Gestion des environnements de traduction entre termes des constructions
+ non réifiés et variables des termes reifies. Attention il s'agit de
+ l'environnement initial contenant tout. Il faudra le réduire après
+ calcul des variables utiles. *)
+
+let add_reified_atom t env =
+ try list_index0 t env.terms
+ with Not_found ->
+ let i = List.length env.terms in
+ env.terms <- env.terms @ [t]; i
+
+let get_reified_atom env =
+ try List.nth env.terms with _ -> failwith "get_reified_atom"
+
+(* \subsection{Gestion de l'environnement de proposition pour Omega} *)
+(* ajout d'une proposition *)
+let add_prop env t =
+ try list_index0 t env.props
+ with Not_found ->
+ let i = List.length env.props in env.props <- env.props @ [t]; i
+
+(* accès a une proposition *)
+let get_prop v env = try List.nth v env with _ -> failwith "get_prop"
+
+(* \subsection{Gestion du nommage des équations} *)
+(* Ajout d'une equation dans l'environnement de reification *)
+let add_equation env e =
+ let id = e.e_omega.id in
+ try let _ = Hashtbl.find env.equations id in ()
+ with Not_found -> Hashtbl.add env.equations id e
+
+(* accès a une equation *)
+let get_equation env id =
+ try Hashtbl.find env.equations id
+ with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e
+
+(* Affichage des termes réifiés *)
+let rec oprint ch = function
+ | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n)
+ | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2
+ | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2
+ | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2
+ | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1
+ | Oatom n -> Printf.fprintf ch "V%02d" n
+ | Oufo x -> Printf.fprintf ch "?"
+
+let rec pprint ch = function
+ Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) ->
+ let connector =
+ match comp with
+ Eq -> "=" | Leq -> "<=" | Geq -> ">="
+ | Gt -> ">" | Lt -> "<" | Neq -> "!=" in
+ Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2
+ | Ptrue -> Printf.fprintf ch "TT"
+ | Pfalse -> Printf.fprintf ch "FF"
+ | Pnot t -> Printf.fprintf ch "not(%a)" pprint t
+ | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2
+ | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2
+ | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2
+ | Pprop c -> Printf.fprintf ch "Prop"
+
+let rec weight env = function
+ | Oint _ -> -1
+ | Oopp c -> weight env c
+ | Omult(c,_) -> weight env c
+ | Oplus _ -> failwith "weight"
+ | Ominus _ -> failwith "weight minus"
+ | Oufo _ -> -1
+ | Oatom _ as c -> (intern_omega env c)
+
+(* \section{Passage entre oformules et représentation interne de Omega} *)
+
+(* \subsection{Oformula vers Omega} *)
+
+let omega_of_oformula env kind =
+ let rec loop accu = function
+ | Oplus(Omult(v,Oint n),r) ->
+ loop ({v=intern_omega env v; c=n} :: accu) r
+ | Oint n ->
+ let id = new_omega_eq () in
+ (*i tag_equation name id; i*)
+ {kind = kind; body = List.rev accu;
+ constant = n; id = id}
+ | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in
+ loop []
+
+(* \subsection{Omega vers Oformula} *)
+
+let rec oformula_of_omega env af =
+ let rec loop = function
+ | ({v=v; c=n}::r) ->
+ Oplus(Omult(unintern_omega env v,Oint n),loop r)
+ | [] -> Oint af.constant in
+ loop af.body
+
+let app f v = mkApp(Lazy.force f,v)
+
+(* \subsection{Oformula vers COQ reel} *)
+
+let rec coq_of_formula env t =
+ let rec loop = function
+ | Oplus (t1,t2) -> app Z.plus [| loop t1; loop t2 |]
+ | Oopp t -> app Z.opp [| loop t |]
+ | Omult(t1,t2) -> app Z.mult [| loop t1; loop t2 |]
+ | Oint v -> Z.mk v
+ | Oufo t -> loop t
+ | Oatom var ->
+ (* attention ne traite pas les nouvelles variables si on ne les
+ * met pas dans env.term *)
+ get_reified_atom env var
+ | Ominus(t1,t2) -> app Z.minus [| loop t1; loop t2 |] in
+ loop t
+
+(* \subsection{Oformula vers COQ reifié} *)
+
+let reified_of_atom env i =
+ try Hashtbl.find env.real_indices i
+ with Not_found ->
+ Printf.printf "Atome %d non trouvé\n" i;
+ Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices;
+ raise Not_found
+
+let rec reified_of_formula env = function
+ | Oplus (t1,t2) ->
+ app coq_t_plus [| reified_of_formula env t1; reified_of_formula env t2 |]
+ | Oopp t ->
+ app coq_t_opp [| reified_of_formula env t |]
+ | Omult(t1,t2) ->
+ app coq_t_mult [| reified_of_formula env t1; reified_of_formula env t2 |]
+ | Oint v -> app coq_t_int [| Z.mk v |]
+ | Oufo t -> reified_of_formula env t
+ | Oatom i -> app coq_t_var [| mk_nat (reified_of_atom env i) |]
+ | Ominus(t1,t2) ->
+ app coq_t_minus [| reified_of_formula env t1; reified_of_formula env t2 |]
+
+let reified_of_formula env f =
+ begin try reified_of_formula env f with e -> oprint stderr f; raise e end
+
+let rec reified_of_proposition env = function
+ Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) ->
+ app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |]
+ | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) ->
+ app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |]
+ | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) ->
+ app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |]
+ | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) ->
+ app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |]
+ | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) ->
+ app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |]
+ | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) ->
+ app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |]
+ | Ptrue -> Lazy.force coq_p_true
+ | Pfalse -> Lazy.force coq_p_false
+ | Pnot t ->
+ app coq_p_not [| reified_of_proposition env t |]
+ | Por (_,t1,t2) ->
+ app coq_p_or
+ [| reified_of_proposition env t1; reified_of_proposition env t2 |]
+ | Pand(_,t1,t2) ->
+ app coq_p_and
+ [| reified_of_proposition env t1; reified_of_proposition env t2 |]
+ | Pimp(_,t1,t2) ->
+ app coq_p_imp
+ [| reified_of_proposition env t1; reified_of_proposition env t2 |]
+ | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |]
+
+let reified_of_proposition env f =
+ begin try reified_of_proposition env f
+ with e -> pprint stderr f; raise e end
+
+(* \subsection{Omega vers COQ réifié} *)
+
+let reified_of_omega env body constant =
+ let coeff_constant =
+ app coq_t_int [| Z.mk constant |] in
+ let mk_coeff {c=c; v=v} t =
+ let coef =
+ app coq_t_mult
+ [| reified_of_formula env (unintern_omega env v);
+ app coq_t_int [| Z.mk c |] |] in
+ app coq_t_plus [|coef; t |] in
+ List.fold_right mk_coeff body coeff_constant
+
+let reified_of_omega env body c =
+ begin try
+ reified_of_omega env body c
+ with e ->
+ display_eq display_omega_var (body,c); raise e
+ end
+
+(* \section{Opérations sur les équations}
+Ces fonctions préparent les traces utilisées par la tactique réfléchie
+pour faire des opérations de normalisation sur les équations. *)
+
+(* \subsection{Extractions des variables d'une équation} *)
+(* Extraction des variables d'une équation. *)
+(* Chaque fonction retourne une liste triée sans redondance *)
+
+let (@@) = list_merge_uniq compare
+
+let rec vars_of_formula = function
+ | Oint _ -> []
+ | Oplus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2)
+ | Omult (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2)
+ | Ominus (e1,e2) -> (vars_of_formula e1) @@ (vars_of_formula e2)
+ | Oopp e -> vars_of_formula e
+ | Oatom i -> [i]
+ | Oufo _ -> []
+
+let rec vars_of_equations = function
+ | [] -> []
+ | e::l ->
+ (vars_of_formula e.e_left) @@
+ (vars_of_formula e.e_right) @@
+ (vars_of_equations l)
+
+let rec vars_of_prop = function
+ | Pequa(_,e) -> vars_of_equations [e]
+ | Pnot p -> vars_of_prop p
+ | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2)
+ | Pand(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2)
+ | Pimp(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2)
+ | Pprop _ | Ptrue | Pfalse -> []
+
+(* \subsection{Multiplication par un scalaire} *)
+
+let rec scalar n = function
+ Oplus(t1,t2) ->
+ let tac1,t1' = scalar n t1 and
+ tac2,t2' = scalar n t2 in
+ do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2],
+ Oplus(t1',t2')
+ | Oopp t ->
+ do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n))
+ | Omult(t1,Oint x) ->
+ do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x))
+ | Omult(t1,t2) ->
+ Util.error "Omega: Can't solve a goal with non-linear products"
+ | (Oatom _ as t) -> do_list [], Omult(t,Oint n)
+ | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i)
+ | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n))
+ | Ominus _ -> failwith "scalar minus"
+
+(* \subsection{Propagation de l'inversion} *)
+
+let rec negate = function
+ Oplus(t1,t2) ->
+ let tac1,t1' = negate t1 and
+ tac2,t2' = negate t2 in
+ do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)],
+ Oplus(t1',t2')
+ | Oopp t ->
+ do_list [Lazy.force coq_c_opp_opp], t
+ | Omult(t1,Oint x) ->
+ do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x))
+ | Omult(t1,t2) ->
+ Util.error "Omega: Can't solve a goal with non-linear products"
+ | (Oatom _ as t) ->
+ do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone))
+ | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i)
+ | Oufo c -> do_list [], Oufo (Oopp c)
+ | Ominus _ -> failwith "negate minus"
+
+let rec norm l = (List.length l)
+
+(* \subsection{Mélange (fusion) de deux équations} *)
+(* \subsubsection{Version avec coefficients} *)
+let rec shuffle_path k1 e1 k2 e2 =
+ let rec loop = function
+ (({c=c1;v=v1}::l1) as l1'),
+ (({c=c2;v=v2}::l2) as l2') ->
+ if v1 = v2 then
+ if k1*c1 + k2 * c2 = zero then (
+ Lazy.force coq_f_cancel :: loop (l1,l2))
+ else (
+ Lazy.force coq_f_equal :: loop (l1,l2) )
+ else if v1 > v2 then (
+ Lazy.force coq_f_left :: loop(l1,l2'))
+ else (
+ Lazy.force coq_f_right :: loop(l1',l2))
+ | ({c=c1;v=v1}::l1), [] ->
+ Lazy.force coq_f_left :: loop(l1,[])
+ | [],({c=c2;v=v2}::l2) ->
+ Lazy.force coq_f_right :: loop([],l2)
+ | [],[] -> flush stdout; [] in
+ mk_shuffle_list (loop (e1,e2))
+
+(* \subsubsection{Version sans coefficients} *)
+let rec shuffle env (t1,t2) =
+ match t1,t2 with
+ Oplus(l1,r1), Oplus(l2,r2) ->
+ if weight env l1 > weight env l2 then
+ let l_action,t' = shuffle env (r1,t2) in
+ do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t')
+ else
+ let l_action,t' = shuffle env (t1,r2) in
+ do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t')
+ | Oplus(l1,r1), t2 ->
+ if weight env l1 > weight env t2 then
+ let (l_action,t') = shuffle env (r1,t2) in
+ do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t')
+ else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1)
+ | t1,Oplus(l2,r2) ->
+ if weight env l2 > weight env t1 then
+ let (l_action,t') = shuffle env (t1,r2) in
+ do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t')
+ else do_list [],Oplus(t1,t2)
+ | Oint t1,Oint t2 ->
+ do_list [Lazy.force coq_c_reduce], Oint(t1+t2)
+ | t1,t2 ->
+ if weight env t1 < weight env t2 then
+ do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1)
+ else do_list [],Oplus(t1,t2)
+
+(* \subsection{Fusion avec réduction} *)
+
+let shrink_pair f1 f2 =
+ begin match f1,f2 with
+ Oatom v,Oatom _ ->
+ Lazy.force coq_c_red1, Omult(Oatom v,Oint two)
+ | Oatom v, Omult(_,c2) ->
+ Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one))
+ | Omult (v1,c1),Oatom v ->
+ Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one))
+ | Omult (Oatom v,c1),Omult (v2,c2) ->
+ Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2))
+ | t1,t2 ->
+ oprint stdout t1; print_newline (); oprint stdout t2; print_newline ();
+ flush Pervasives.stdout; Util.error "shrink.1"
+ end
+
+(* \subsection{Calcul d'une sous formule constante} *)
+
+let reduce_factor = function
+ Oatom v ->
+ let r = Omult(Oatom v,Oint one) in
+ [Lazy.force coq_c_red0],r
+ | Omult(Oatom v,Oint n) as f -> [],f
+ | Omult(Oatom v,c) ->
+ let rec compute = function
+ Oint n -> n
+ | Oplus(t1,t2) -> compute t1 + compute t2
+ | _ -> Util.error "condense.1" in
+ [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
+ | t -> Util.error "reduce_factor.1"
+
+(* \subsection{Réordonnancement} *)
+
+let rec condense env = function
+ Oplus(f1,(Oplus(f2,r) as t)) ->
+ if weight env f1 = weight env f2 then begin
+ let shrink_tac,t = shrink_pair f1 f2 in
+ let assoc_tac = Lazy.force coq_c_plus_assoc_l in
+ let tac_list,t' = condense env (Oplus(t,r)) in
+ assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t'
+ end else begin
+ let tac,f = reduce_factor f1 in
+ let tac',t' = condense env t in
+ [do_both (do_list tac) (do_list tac')], Oplus(f,t')
+ end
+ | Oplus(f1,Oint n) ->
+ let tac,f1' = reduce_factor f1 in
+ [do_left (do_list tac)],Oplus(f1',Oint n)
+ | Oplus(f1,f2) ->
+ if weight env f1 = weight env f2 then begin
+ let tac_shrink,t = shrink_pair f1 f2 in
+ let tac,t' = condense env t in
+ tac_shrink :: tac,t'
+ end else begin
+ let tac,f = reduce_factor f1 in
+ let tac',t' = condense env f2 in
+ [do_both (do_list tac) (do_list tac')],Oplus(f,t')
+ end
+ | (Oint _ as t)-> [],t
+ | t ->
+ let tac,t' = reduce_factor t in
+ let final = Oplus(t',Oint zero) in
+ tac @ [Lazy.force coq_c_red6], final
+
+(* \subsection{Elimination des zéros} *)
+
+let rec clear_zero = function
+ Oplus(Omult(Oatom v,Oint n),r) when n=zero ->
+ let tac',t = clear_zero r in
+ Lazy.force coq_c_red5 :: tac',t
+ | Oplus(f,r) ->
+ let tac,t = clear_zero r in
+ (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t)
+ | t -> [],t;;
+
+(* \subsection{Transformation des hypothèses} *)
+
+let rec reduce env = function
+ Oplus(t1,t2) ->
+ let t1', trace1 = reduce env t1 in
+ let t2', trace2 = reduce env t2 in
+ let trace3,t' = shuffle env (t1',t2') in
+ t', do_list [do_both trace1 trace2; trace3]
+ | Ominus(t1,t2) ->
+ let t,trace = reduce env (Oplus(t1, Oopp t2)) in
+ t, do_list [Lazy.force coq_c_minus; trace]
+ | Omult(t1,t2) as t ->
+ let t1', trace1 = reduce env t1 in
+ let t2', trace2 = reduce env t2 in
+ begin match t1',t2' with
+ | (_, Oint n) ->
+ let tac,t' = scalar n t1' in
+ t', do_list [do_both trace1 trace2; tac]
+ | (Oint n,_) ->
+ let tac,t' = scalar n t2' in
+ t', do_list [do_both trace1 trace2; Lazy.force coq_c_mult_comm; tac]
+ | _ -> Oufo t, Lazy.force coq_c_nop
+ end
+ | Oopp t ->
+ let t',trace = reduce env t in
+ let trace',t'' = negate t' in
+ t'', do_list [do_left trace; trace']
+ | (Oint _ | Oatom _ | Oufo _) as t -> t, Lazy.force coq_c_nop
+
+let normalize_linear_term env t =
+ let t1,trace1 = reduce env t in
+ let trace2,t2 = condense env t1 in
+ let trace3,t3 = clear_zero t2 in
+ do_list [trace1; do_list trace2; do_list trace3], t3
+
+(* Cette fonction reproduit très exactement le comportement de [p_invert] *)
+let negate_oper = function
+ Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq
+
+let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) =
+ let mk_step t1 t2 f kind =
+ let t = f t1 t2 in
+ let trace, oterm = normalize_linear_term env t in
+ let equa = omega_of_oformula env kind oterm in
+ { e_comp = oper; e_left = t1; e_right = t2;
+ e_negated = negated; e_depends = depends;
+ e_origin = { o_hyp = origin; o_path = List.rev path };
+ e_trace = trace; e_omega = equa } in
+ try match (if negated then (negate_oper oper) else oper) with
+ | Eq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) EQUA
+ | Neq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) DISE
+ | Leq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o2,Oopp o1)) INEQ
+ | Geq -> mk_step t1 t2 (fun o1 o2 -> Oplus (o1,Oopp o2)) INEQ
+ | Lt ->
+ mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1))
+ INEQ
+ | Gt ->
+ mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2))
+ INEQ
+ with e when Logic.catchable_exception e -> raise e
+
+(* \section{Compilation des hypothèses} *)
+
+let rec oformula_of_constr env t =
+ match Z.parse_term t with
+ | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2
+ | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2
+ | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 ->
+ binop env (fun x y -> Omult(x,y)) t1 t2
+ | Topp t -> Oopp(oformula_of_constr env t)
+ | Tsucc t -> Oplus(oformula_of_constr env t, Oint one)
+ | Tnum n -> Oint n
+ | _ -> Oatom (add_reified_atom t env)
+
+and binop env c t1 t2 =
+ let t1' = oformula_of_constr env t1 in
+ let t2' = oformula_of_constr env t2 in
+ c t1' t2'
+
+and binprop env (neg2,depends,origin,path)
+ add_to_depends neg1 gl c t1 t2 =
+ let i = new_connector_id env in
+ let depends1 = if add_to_depends then Left i::depends else depends in
+ let depends2 = if add_to_depends then Right i::depends else depends in
+ if add_to_depends then
+ Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path};
+ let t1' =
+ oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in
+ let t2' =
+ oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in
+ (* On numérote le connecteur dans l'environnement. *)
+ c i t1' t2'
+
+and mk_equation env ctxt c connector t1 t2 =
+ let t1' = oformula_of_constr env t1 in
+ let t2' = oformula_of_constr env t2 in
+ (* On ajoute l'equation dans l'environnement. *)
+ let omega = normalize_equation env ctxt (connector,t1',t2') in
+ add_equation env omega;
+ Pequa (c,omega)
+
+and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c =
+ match Z.parse_rel gl c with
+ | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2
+ | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2
+ | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2
+ | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2
+ | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2
+ | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2
+ | Rtrue -> Ptrue
+ | Rfalse -> Pfalse
+ | Rnot t ->
+ let t' =
+ oproposition_of_constr
+ env (not negated, depends, origin,(O_mono::path)) gl t in
+ Pnot t'
+ | Ror (t1,t2) ->
+ binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2
+ | Rand (t1,t2) ->
+ binprop env ctxt negated negated gl
+ (fun i x y -> Pand(i,x,y)) t1 t2
+ | Rimp (t1,t2) ->
+ binprop env ctxt (not negated) (not negated) gl
+ (fun i x y -> Pimp(i,x,y)) t1 t2
+ | Riff (t1,t2) ->
+ binprop env ctxt negated negated gl
+ (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1)
+ | _ -> Pprop c
+
+(* Destructuration des hypothèses et de la conclusion *)
+
+let reify_gl env gl =
+ let concl = Tacmach.pf_concl gl in
+ let t_concl =
+ Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in
+ if !debug then begin
+ Printf.printf "REIFED PROBLEM\n\n";
+ Printf.printf " CONCL: "; pprint stdout t_concl; Printf.printf "\n"
+ end;
+ let rec loop = function
+ (i,t) :: lhyps ->
+ let t' = oproposition_of_constr env (false,[],i,[]) gl t in
+ if !debug then begin
+ Printf.printf " %s: " (Names.string_of_id i);
+ pprint stdout t';
+ Printf.printf "\n"
+ end;
+ (i,t') :: loop lhyps
+ | [] ->
+ if !debug then print_env_reification env;
+ [] in
+ let t_lhyps = loop (Tacmach.pf_hyps_types gl) in
+ (id_concl,t_concl) :: t_lhyps
+
+let rec destructurate_pos_hyp orig list_equations list_depends = function
+ | Pequa (_,e) -> [e :: list_equations]
+ | Ptrue | Pfalse | Pprop _ -> [list_equations]
+ | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t
+ | Por (i,t1,t2) ->
+ let s1 =
+ destructurate_pos_hyp orig list_equations (i::list_depends) t1 in
+ let s2 =
+ destructurate_pos_hyp orig list_equations (i::list_depends) t2 in
+ s1 @ s2
+ | Pand(i,t1,t2) ->
+ let list_s1 =
+ destructurate_pos_hyp orig list_equations (list_depends) t1 in
+ let rec loop = function
+ le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll
+ | [] -> [] in
+ loop list_s1
+ | Pimp(i,t1,t2) ->
+ let s1 =
+ destructurate_neg_hyp orig list_equations (i::list_depends) t1 in
+ let s2 =
+ destructurate_pos_hyp orig list_equations (i::list_depends) t2 in
+ s1 @ s2
+
+and destructurate_neg_hyp orig list_equations list_depends = function
+ | Pequa (_,e) -> [e :: list_equations]
+ | Ptrue | Pfalse | Pprop _ -> [list_equations]
+ | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t
+ | Pand (i,t1,t2) ->
+ let s1 =
+ destructurate_neg_hyp orig list_equations (i::list_depends) t1 in
+ let s2 =
+ destructurate_neg_hyp orig list_equations (i::list_depends) t2 in
+ s1 @ s2
+ | Por(_,t1,t2) ->
+ let list_s1 =
+ destructurate_neg_hyp orig list_equations list_depends t1 in
+ let rec loop = function
+ le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll
+ | [] -> [] in
+ loop list_s1
+ | Pimp(_,t1,t2) ->
+ let list_s1 =
+ destructurate_pos_hyp orig list_equations list_depends t1 in
+ let rec loop = function
+ le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll
+ | [] -> [] in
+ loop list_s1
+
+let destructurate_hyps syst =
+ let rec loop = function
+ (i,t) :: l ->
+ let l_syst1 = destructurate_pos_hyp i [] [] t in
+ let l_syst2 = loop l in
+ list_cartesian (@) l_syst1 l_syst2
+ | [] -> [[]] in
+ loop syst
+
+(* \subsection{Affichage d'un système d'équation} *)
+
+(* Affichage des dépendances de système *)
+let display_depend = function
+ Left i -> Printf.printf " L%d" i
+ | Right i -> Printf.printf " R%d" i
+
+let display_systems syst_list =
+ let display_omega om_e =
+ Printf.printf " E%d : %a %s 0\n"
+ om_e.id
+ (fun _ -> display_eq display_omega_var)
+ (om_e.body, om_e.constant)
+ (operator_of_eq om_e.kind) in
+
+ let display_equation oformula_eq =
+ pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline ();
+ display_omega oformula_eq.e_omega;
+ Printf.printf " Depends on:";
+ List.iter display_depend oformula_eq.e_depends;
+ Printf.printf "\n Path: %s"
+ (String.concat ""
+ (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M")
+ oformula_eq.e_origin.o_path));
+ Printf.printf "\n Origin: %s (negated : %s)\n\n"
+ (Names.string_of_id oformula_eq.e_origin.o_hyp)
+ (if oformula_eq.e_negated then "yes" else "no") in
+
+ let display_system syst =
+ Printf.printf "=SYSTEM===================================\n";
+ List.iter display_equation syst in
+ List.iter display_system syst_list
+
+(* Extraction des prédicats utilisées dans une trace. Permet ensuite le
+ calcul des hypothèses *)
+
+let rec hyps_used_in_trace = function
+ | act :: l ->
+ begin match act with
+ | HYP e -> [e.id] @@ (hyps_used_in_trace l)
+ | SPLIT_INEQ (_,(_,act1),(_,act2)) ->
+ hyps_used_in_trace act1 @@ hyps_used_in_trace act2
+ | _ -> hyps_used_in_trace l
+ end
+ | [] -> []
+
+(* Extraction des variables déclarées dans une équation. Permet ensuite
+ de les déclarer dans l'environnement de la procédure réflexive et
+ éviter les créations de variable au vol *)
+
+let rec variable_stated_in_trace = function
+ | act :: l ->
+ begin match act with
+ | STATE action ->
+ (*i nlle_equa: afine, def: afine, eq_orig: afine, i*)
+ (*i coef: int, var:int i*)
+ action :: variable_stated_in_trace l
+ | SPLIT_INEQ (_,(_,act1),(_,act2)) ->
+ variable_stated_in_trace act1 @ variable_stated_in_trace act2
+ | _ -> variable_stated_in_trace l
+ end
+ | [] -> []
+;;
+
+let add_stated_equations env tree =
+ (* Il faut trier les variables par ordre d'introduction pour ne pas risquer
+ de définir dans le mauvais ordre *)
+ let stated_equations =
+ let cmpvar x y = Pervasives.(-) x.st_var y.st_var in
+ let rec loop = function
+ | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2)
+ | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace)
+ in loop tree
+ in
+ let add_env st =
+ (* On retransforme la définition de v en formule reifiée *)
+ let v_def = oformula_of_omega env st.st_def in
+ (* Notez que si l'ordre de création des variables n'est pas respecté,
+ * ca va planter *)
+ let coq_v = coq_of_formula env v_def in
+ let v = add_reified_atom coq_v env in
+ (* Le terme qu'il va falloir introduire *)
+ let term_to_generalize = app coq_refl_equal [|Lazy.force Z.typ; coq_v|] in
+ (* sa représentation sous forme d'équation mais non réifié car on n'a pas
+ * l'environnement pour le faire correctement *)
+ let term_to_reify = (v_def,Oatom v) in
+ (* enregistre le lien entre la variable omega et la variable Coq *)
+ intern_omega_force env (Oatom v) st.st_var;
+ (v, term_to_generalize,term_to_reify,st.st_def.id) in
+ List.map add_env stated_equations
+
+(* Calcule la liste des éclatements à réaliser sur les hypothèses
+ nécessaires pour extraire une liste d'équations donnée *)
+
+(* PL: experimentally, the result order of the following function seems
+ _very_ crucial for efficiency. No idea why. Do not remove the List.rev
+ or modify the current semantics of Util.list_union (some elements of first
+ arg, then second arg), unless you know what you're doing. *)
+
+let rec get_eclatement env = function
+ i :: r ->
+ let l = try (get_equation env i).e_depends with Not_found -> [] in
+ list_union (List.rev l) (get_eclatement env r)
+ | [] -> []
+
+let select_smaller l =
+ let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in
+ try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller"
+
+let filter_compatible_systems required systems =
+ let rec select = function
+ (x::l) ->
+ if List.mem x required then select l
+ else if List.mem (barre x) required then failwith "Exit"
+ else x :: select l
+ | [] -> [] in
+ map_succeed (function (sol,splits) -> (sol,select splits)) systems
+
+let rec equas_of_solution_tree = function
+ Tree(_,t1,t2) -> (equas_of_solution_tree t1)@@(equas_of_solution_tree t2)
+ | Leaf s -> s.s_equa_deps
+
+(* [really_useful_prop] pushes useless props in a new Pprop variable *)
+(* Things get shorter, but may also get wrong, since a Prop is considered
+ to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance
+ Pfalse is decidable. So should not be used on conclusion (??) *)
+
+let really_useful_prop l_equa c =
+ let rec real_of = function
+ Pequa(t,_) -> t
+ | Ptrue -> app coq_True [||]
+ | Pfalse -> app coq_False [||]
+ | Pnot t1 -> app coq_not [|real_of t1|]
+ | Por(_,t1,t2) -> app coq_or [|real_of t1; real_of t2|]
+ | Pand(_,t1,t2) -> app coq_and [|real_of t1; real_of t2|]
+ (* Attention : implications sur le lifting des variables à comprendre ! *)
+ | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2)
+ | Pprop t -> t in
+ let rec loop c =
+ match c with
+ Pequa(_,e) ->
+ if List.mem e.e_omega.id l_equa then Some c else None
+ | Ptrue -> None
+ | Pfalse -> None
+ | Pnot t1 ->
+ begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end
+ | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2
+ | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2
+ | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2
+ | Pprop t -> None
+ and binop f t1 t2 =
+ begin match loop t1, loop t2 with
+ None, None -> None
+ | Some t1',Some t2' -> Some (f(t1',t2'))
+ | Some t1',None -> Some (f(t1',Pprop (real_of t2)))
+ | None,Some t2' -> Some (f(Pprop (real_of t1),t2'))
+ end in
+ match loop c with
+ None -> Pprop (real_of c)
+ | Some t -> t
+
+let rec display_solution_tree ch = function
+ Leaf t ->
+ output_string ch
+ (Printf.sprintf "%d[%s]"
+ t.s_index
+ (String.concat " " (List.map string_of_int t.s_equa_deps)))
+ | Tree(i,t1,t2) ->
+ Printf.fprintf ch "S%d(%a,%a)" i
+ display_solution_tree t1 display_solution_tree t2
+
+let rec solve_with_constraints all_solutions path =
+ let rec build_tree sol buf = function
+ [] -> Leaf sol
+ | (Left i :: remainder) ->
+ Tree(i,
+ build_tree sol (Left i :: buf) remainder,
+ solve_with_constraints all_solutions (List.rev(Right i :: buf)))
+ | (Right i :: remainder) ->
+ Tree(i,
+ solve_with_constraints all_solutions (List.rev (Left i :: buf)),
+ build_tree sol (Right i :: buf) remainder) in
+ let weighted = filter_compatible_systems path all_solutions in
+ let (winner_sol,winner_deps) =
+ try select_smaller weighted
+ with e ->
+ Printf.printf "%d - %d\n"
+ (List.length weighted) (List.length all_solutions);
+ List.iter display_depend path; raise e in
+ build_tree winner_sol (List.rev path) winner_deps
+
+let find_path {o_hyp=id;o_path=p} env =
+ let rec loop_path = function
+ ([],l) -> Some l
+ | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2)
+ | _ -> None in
+ let rec loop_id i = function
+ CCHyp{o_hyp=id';o_path=p'} :: l when id = id' ->
+ begin match loop_path (p',p) with
+ Some r -> i,r
+ | None -> loop_id (succ i) l
+ end
+ | _ :: l -> loop_id (succ i) l
+ | [] -> failwith "find_path" in
+ loop_id 0 env
+
+let mk_direction_list l =
+ let trans = function
+ O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in
+ mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l)
+
+
+(* \section{Rejouer l'historique} *)
+
+let get_hyp env_hyp i =
+ try list_index0 (CCEqua i) env_hyp
+ with Not_found -> failwith (Printf.sprintf "get_hyp %d" i)
+
+let replay_history env env_hyp =
+ let rec loop env_hyp t =
+ match t with
+ | CONTRADICTION (e1,e2) :: l ->
+ let trace = mk_nat (List.length e1.body) in
+ mkApp (Lazy.force coq_s_contradiction,
+ [| trace ; mk_nat (get_hyp env_hyp e1.id);
+ mk_nat (get_hyp env_hyp e2.id) |])
+ | DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
+ mkApp (Lazy.force coq_s_div_approx,
+ [| Z.mk k; Z.mk d;
+ reified_of_omega env e2.body e2.constant;
+ mk_nat (List.length e2.body);
+ loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |])
+ | NOT_EXACT_DIVIDE (e1,k) :: l ->
+ let e2_constant = floor_div e1.constant k in
+ let d = e1.constant - e2_constant * k in
+ let e2_body = map_eq_linear (fun c -> c / k) e1.body in
+ mkApp (Lazy.force coq_s_not_exact_divide,
+ [|Z.mk k; Z.mk d;
+ reified_of_omega env e2_body e2_constant;
+ mk_nat (List.length e2_body);
+ mk_nat (get_hyp env_hyp e1.id)|])
+ | EXACT_DIVIDE (e1,k) :: l ->
+ let e2_body =
+ map_eq_linear (fun c -> c / k) e1.body in
+ let e2_constant = floor_div e1.constant k in
+ mkApp (Lazy.force coq_s_exact_divide,
+ [|Z.mk k;
+ reified_of_omega env e2_body e2_constant;
+ mk_nat (List.length e2_body);
+ loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|])
+ | (MERGE_EQ(e3,e1,e2)) :: l ->
+ let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2 in
+ mkApp (Lazy.force coq_s_merge_eq,
+ [| mk_nat (List.length e1.body);
+ mk_nat n1; mk_nat n2;
+ loop (CCEqua e3:: env_hyp) l |])
+ | SUM(e3,(k1,e1),(k2,e2)) :: l ->
+ let n1 = get_hyp env_hyp e1.id
+ and n2 = get_hyp env_hyp e2.id in
+ let trace = shuffle_path k1 e1.body k2 e2.body in
+ mkApp (Lazy.force coq_s_sum,
+ [| Z.mk k1; mk_nat n1; Z.mk k2;
+ mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |])
+ | CONSTANT_NOT_NUL(e,k) :: l ->
+ mkApp (Lazy.force coq_s_constant_not_nul,
+ [| mk_nat (get_hyp env_hyp e) |])
+ | CONSTANT_NEG(e,k) :: l ->
+ mkApp (Lazy.force coq_s_constant_neg,
+ [| mk_nat (get_hyp env_hyp e) |])
+ | STATE {st_new_eq=new_eq; st_def =def;
+ st_orig=orig; st_coef=m;
+ st_var=sigma } :: l ->
+ let n1 = get_hyp env_hyp orig.id
+ and n2 = get_hyp env_hyp def.id in
+ let v = unintern_omega env sigma in
+ let o_def = oformula_of_omega env def in
+ let o_orig = oformula_of_omega env orig in
+ let body =
+ Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in
+ let trace,_ = normalize_linear_term env body in
+ mkApp (Lazy.force coq_s_state,
+ [| Z.mk m; trace; mk_nat n1; mk_nat n2;
+ loop (CCEqua new_eq.id :: env_hyp) l |])
+ | HYP _ :: l -> loop env_hyp l
+ | CONSTANT_NUL e :: l ->
+ mkApp (Lazy.force coq_s_constant_nul,
+ [| mk_nat (get_hyp env_hyp e) |])
+ | NEGATE_CONTRADICT(e1,e2,true) :: l ->
+ mkApp (Lazy.force coq_s_negate_contradict,
+ [| mk_nat (get_hyp env_hyp e1.id);
+ mk_nat (get_hyp env_hyp e2.id) |])
+ | NEGATE_CONTRADICT(e1,e2,false) :: l ->
+ mkApp (Lazy.force coq_s_negate_contradict_inv,
+ [| mk_nat (List.length e2.body);
+ mk_nat (get_hyp env_hyp e1.id);
+ mk_nat (get_hyp env_hyp e2.id) |])
+ | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l ->
+ let i = get_hyp env_hyp e.id in
+ let r1 = loop (CCEqua e1 :: env_hyp) l1 in
+ let r2 = loop (CCEqua e2 :: env_hyp) l2 in
+ mkApp (Lazy.force coq_s_split_ineq,
+ [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |])
+ | (FORGET_C _ | FORGET _ | FORGET_I _) :: l ->
+ loop env_hyp l
+ | (WEAKEN _ ) :: l -> failwith "not_treated"
+ | [] -> failwith "no contradiction"
+ in loop env_hyp
+
+let rec decompose_tree env ctxt = function
+ Tree(i,left,right) ->
+ let org =
+ try Hashtbl.find env.constructors i
+ with Not_found ->
+ failwith (Printf.sprintf "Cannot find constructor %d" i) in
+ let (index,path) = find_path org ctxt in
+ let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in
+ let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in
+ app coq_e_split
+ [| mk_nat index;
+ mk_direction_list path;
+ decompose_tree env (left_hyp::ctxt) left;
+ decompose_tree env (right_hyp::ctxt) right |]
+ | Leaf s ->
+ decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps
+and decompose_tree_hyps trace env ctxt = function
+ [] -> app coq_e_solve [| replay_history env ctxt trace |]
+ | (i::l) ->
+ let equation =
+ try Hashtbl.find env.equations i
+ with Not_found ->
+ failwith (Printf.sprintf "Cannot find equation %d" i) in
+ let (index,path) = find_path equation.e_origin ctxt in
+ let full_path = if equation.e_negated then path @ [O_mono] else path in
+ let cont =
+ decompose_tree_hyps trace env
+ (CCEqua equation.e_omega.id :: ctxt) l in
+ app coq_e_extract [|mk_nat index;
+ mk_direction_list full_path;
+ cont |]
+
+(* \section{La fonction principale} *)
+ (* Cette fonction construit la
+trace pour la procédure de décision réflexive. A partir des résultats
+de l'extraction des systèmes, elle lance la résolution par Omega, puis
+l'extraction d'un ensemble minimal de solutions permettant la
+résolution globale du système et enfin construit la trace qui permet
+de faire rejouer cette solution par la tactique réflexive. *)
+
+let resolution env full_reified_goal systems_list =
+ let num = ref 0 in
+ let solve_system list_eq =
+ let index = !num in
+ let system = List.map (fun eq -> eq.e_omega) list_eq in
+ let trace =
+ simplify_strong
+ (new_omega_eq,new_omega_var,display_omega_var)
+ system in
+ (* calcule les hypotheses utilisées pour la solution *)
+ let vars = hyps_used_in_trace trace in
+ let splits = get_eclatement env vars in
+ if !debug then begin
+ Printf.printf "SYSTEME %d\n" index;
+ display_action display_omega_var trace;
+ print_string "\n Depend :";
+ List.iter (fun i -> Printf.printf " %d" i) vars;
+ print_string "\n Split points :";
+ List.iter display_depend splits;
+ Printf.printf "\n------------------------------------\n"
+ end;
+ incr num;
+ {s_index = index; s_trace = trace; s_equa_deps = vars}, splits in
+ if !debug then Printf.printf "\n====================================\n";
+ let all_solutions = List.map solve_system systems_list in
+ let solution_tree = solve_with_constraints all_solutions [] in
+ if !debug then begin
+ display_solution_tree stdout solution_tree;
+ print_newline()
+ end;
+ (* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *)
+ let useful_equa_id = equas_of_solution_tree solution_tree in
+ (* recupere explicitement ces equations *)
+ let equations = List.map (get_equation env) useful_equa_id in
+ let l_hyps' = list_uniquize (List.map (fun e -> e.e_origin.o_hyp) equations) in
+ let l_hyps = id_concl :: list_remove id_concl l_hyps' in
+ let useful_hyps =
+ List.map (fun id -> List.assoc id full_reified_goal) l_hyps in
+ let useful_vars =
+ let really_useful_vars = vars_of_equations equations in
+ let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in
+ really_useful_vars @@ concl_vars
+ in
+ (* variables a introduire *)
+ let to_introduce = add_stated_equations env solution_tree in
+ let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in
+ let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in
+ let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in
+ (* L'environnement de base se construit en deux morceaux :
+ - les variables des équations utiles (et de la conclusion)
+ - les nouvelles variables declarées durant les preuves *)
+ let all_vars_env = useful_vars @ stated_vars in
+ let basic_env =
+ let rec loop i = function
+ var :: l ->
+ let t = get_reified_atom env var in
+ Hashtbl.add env.real_indices var i; t :: loop (succ i) l
+ | [] -> [] in
+ loop 0 all_vars_env in
+ let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in
+ (* On peut maintenant généraliser le but : env est a jour *)
+ let l_reified_stated =
+ List.map (fun (_,_,(l,r),_) ->
+ app coq_p_eq [| reified_of_formula env l;
+ reified_of_formula env r |])
+ to_introduce in
+ let reified_concl =
+ match useful_hyps with
+ (Pnot p) :: _ -> reified_of_proposition env p
+ | _ -> reified_of_proposition env Pfalse in
+ let l_reified_terms =
+ (List.map
+ (fun p ->
+ reified_of_proposition env (really_useful_prop useful_equa_id p))
+ (List.tl useful_hyps)) in
+ let env_props_reified = mk_plist env.props in
+ let reified_goal =
+ mk_list (Lazy.force coq_proposition)
+ (l_reified_stated @ l_reified_terms) in
+ let reified =
+ app coq_interp_sequent
+ [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in
+ let normalize_equation e =
+ let rec loop = function
+ [] -> app (if e.e_negated then coq_p_invert else coq_p_step)
+ [| e.e_trace |]
+ | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |]
+ | (O_right :: l) -> app coq_p_right [| loop l |] in
+ let correct_index =
+ let i = list_index0 e.e_origin.o_hyp l_hyps in
+ (* PL: it seems that additionnally introduced hyps are in the way during
+ normalization, hence this index shifting... *)
+ if i=0 then 0 else Pervasives.(+) i (List.length to_introduce)
+ in
+ app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in
+ let normalization_trace =
+ mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in
+
+ let initial_context =
+ List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in
+ let context =
+ CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in
+ let decompose_tactic = decompose_tree env context solution_tree in
+
+ Tactics.generalize
+ (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >>
+ Tactics.change_in_concl None reified >>
+ Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >>
+ show_goal >>
+ Tactics.normalise_vm_in_concl >>
+ (*i Alternatives to the previous line:
+ - Normalisation without VM:
+ Tactics.normalise_in_concl
+ - Skip the conversion check and rely directly on the QED:
+ Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >>
+ i*)
+ Tactics.apply (Lazy.force coq_I)
+
+let total_reflexive_omega_tactic gl =
+ Coqlib.check_required_library ["Coq";"romega";"ROmega"];
+ rst_omega_eq ();
+ rst_omega_var ();
+ try
+ let env = new_environment () in
+ let full_reified_goal = reify_gl env gl in
+ let systems_list = destructurate_hyps full_reified_goal in
+ if !debug then display_systems systems_list;
+ resolution env full_reified_goal systems_list gl
+ with NO_CONTRADICTION -> Util.error "ROmega can't solve this system"
+
+
+(*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*)
+
+
diff --git a/plugins/romega/romega_plugin.mllib b/plugins/romega/romega_plugin.mllib
new file mode 100644
index 00000000..1625009d
--- /dev/null
+++ b/plugins/romega/romega_plugin.mllib
@@ -0,0 +1,4 @@
+Const_omega
+Refl_omega
+G_romega
+Romega_plugin_mod
diff --git a/plugins/romega/vo.itarget b/plugins/romega/vo.itarget
new file mode 100644
index 00000000..f7a3c41c
--- /dev/null
+++ b/plugins/romega/vo.itarget
@@ -0,0 +1,2 @@
+ReflOmegaCore.vo
+ROmega.vo
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
new file mode 100644
index 00000000..c06f6991
--- /dev/null
+++ b/plugins/rtauto/Bintree.v
@@ -0,0 +1,489 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+Require Export List.
+Require Export BinPos.
+
+Unset Boxed Definitions.
+
+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.
+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.
+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 =>
+match n with O => Some x
+| S m => Lget A m q
+end end .
+
+Implicit Arguments Lget [A].
+
+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.
+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.
+Qed.
+
+Lemma Lget_map : forall (A B:Set) (f:A -> B) i l,
+Lget i (List.map f l) =
+match Lget i l with Some a =>
+Some (f a) | None => None end.
+induction i;intros [ | x l ] ;trivial.
+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.
+induction l;simpl Lget;simpl length.
+intros [ | i];simpl;reflexivity.
+intros [ | i];simpl.
+reflexivity.
+auto.
+Qed.
+
+Lemma Lget_app_Some : forall (A:Set) l delta i (a: A),
+Lget i l = Some a ->
+Lget i (l ++ delta) = Some a.
+induction l;destruct i;simpl;try congruence;auto.
+Qed.
+
+Section Store.
+
+Variable A:Type.
+
+Inductive Poption : Type:=
+ PSome : A -> Poption
+| PNone : Poption.
+
+Inductive Tree : Type :=
+ Tempty : Tree
+ | Branch0 : Tree -> Tree -> Tree
+ | Branch1 : A -> Tree -> Tree -> Tree.
+
+Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption :=
+ match T with
+ Tempty => PNone
+ | Branch0 T1 T2 =>
+ match p with
+ xI pp => Tget pp T2
+ | xO pp => Tget pp T1
+ | xH => PNone
+ end
+ | Branch1 a T1 T2 =>
+ match p with
+ xI pp => Tget pp T2
+ | xO pp => Tget pp T1
+ | xH => PSome a
+ end
+end.
+
+Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree :=
+ match T with
+ | Tempty =>
+ match p with
+ | xI pp => Branch0 Tempty (Tadd pp a Tempty)
+ | xO pp => Branch0 (Tadd pp a Tempty) Tempty
+ | xH => Branch1 a Tempty Tempty
+ end
+ | Branch0 T1 T2 =>
+ match p with
+ | xI pp => Branch0 T1 (Tadd pp a T2)
+ | xO pp => Branch0 (Tadd pp a T1) T2
+ | xH => Branch1 a T1 T2
+ end
+ | Branch1 b T1 T2 =>
+ match p with
+ | xI pp => Branch1 b T1 (Tadd pp a T2)
+ | xO pp => Branch1 b (Tadd pp a T1) T2
+ | xH => Branch1 a T1 T2
+ end
+ end.
+
+Definition mkBranch0 (T1 T2:Tree) :=
+ match T1,T2 with
+ Tempty ,Tempty => Tempty
+ | _,_ => Branch0 T1 T2
+ end.
+
+Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree :=
+ match T with
+ | Tempty => Tempty
+ | Branch0 T1 T2 =>
+ match p with
+ | xI pp => mkBranch0 T1 (Tremove pp T2)
+ | xO pp => mkBranch0 (Tremove pp T1) T2
+ | xH => T
+ end
+ | Branch1 b T1 T2 =>
+ match p with
+ | xI pp => Branch1 b T1 (Tremove pp T2)
+ | xO pp => Branch1 b (Tremove pp T1) T2
+ | xH => mkBranch0 T1 T2
+ end
+ end.
+
+
+Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone.
+destruct p;reflexivity.
+Qed.
+
+Theorem Tget_Tadd: forall i j a T,
+ Tget i (Tadd j a T) =
+ match (i ?= j) Eq with
+ Eq => PSome a
+ | Lt => Tget i T
+ | Gt => Tget i T
+ end.
+intros i j.
+caseq ((i ?= j) Eq).
+intro H;rewrite (Pcompare_Eq_eq _ _ H);intros a;clear i H.
+induction j;destruct T;simpl;try (apply IHj);congruence.
+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.
+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.
+
+Record Store : Type :=
+mkStore {index:positive;contents:Tree}.
+
+Definition empty := mkStore xH Tempty.
+
+Definition push a S :=
+mkStore (Psucc (index S)) (Tadd (index S) a (contents S)).
+
+Definition get i S := Tget i (contents S).
+
+Lemma get_empty : forall i, get i empty = PNone.
+intro i; case i; unfold empty,get; simpl;reflexivity.
+Qed.
+
+Inductive Full : Store -> Type:=
+ F_empty : Full empty
+ | 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.
+intros S W;induction W.
+unfold empty,index,get,contents;intros;apply Tget_Tempty.
+unfold index,get,push;simpl contents.
+intros i e;rewrite Tget_Tadd.
+rewrite (Gt_Psucc _ _ e).
+unfold get in IHW.
+apply IHW;apply Gt_Psucc;assumption.
+Qed.
+
+Theorem get_Full_Eq : forall S, Full S -> get (index S) S = PNone.
+intros [index0 contents0] F.
+case F.
+unfold empty,index,get,contents;intros;apply Tget_Tempty.
+unfold index,get,push;simpl contents.
+intros a S.
+rewrite Tget_Tadd.
+rewrite Psucc_Gt.
+intro W.
+change (get (Psucc (index S)) S =PNone).
+apply get_Full_Gt; auto.
+apply Psucc_Gt.
+Qed.
+
+Theorem get_push_Full :
+ forall i a S, Full S ->
+ get i (push a S) =
+ match (i ?= index S) Eq with
+ Eq => PSome a
+ | Lt => get i S
+ | Gt => PNone
+end.
+intros i a S F.
+caseq ((i ?= index S) Eq).
+intro e;rewrite (Pcompare_Eq_eq _ _ e).
+destruct S;unfold get,push,index;simpl contents;rewrite Tget_Tadd.
+rewrite Pcompare_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.
+unfold get,push;simpl index;simpl contents.
+rewrite Tget_Tadd;intro e;rewrite e.
+change (get i S=PNone).
+apply get_Full_Gt;auto.
+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.
+intros i a S F x H.
+caseq ((i ?= index S) Eq);intro test.
+rewrite (Pcompare_Eq_eq _ _ test) in H.
+rewrite (get_Full_Eq _ F) in H;congruence.
+rewrite <- H.
+rewrite (get_push_Full i a).
+rewrite test;reflexivity.
+assumption.
+rewrite (get_Full_Gt _ F) in H;congruence.
+Qed.
+
+Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty.
+intros [ind cont] F one; inversion F.
+reflexivity.
+simpl index in one;assert (h:=Psucc_not_one (index S)).
+congruence.
+Qed.
+
+Lemma push_not_empty: forall a S, (push a S) <> empty.
+intros a [ind cont];unfold push,empty.
+simpl;intro H;injection H; intros _ ; apply Psucc_not_one.
+Qed.
+
+Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
+match F with
+F_empty => False
+| F_push a SS FF => x=a \/ In x SS FF
+end.
+
+Lemma get_In : forall (x:A) (S:Store) (F:Full S) i ,
+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.
+left;congruence.
+right;eauto.
+congruence.
+Qed.
+
+End Store.
+
+Implicit Arguments PNone [A].
+Implicit Arguments PSome [A].
+
+Implicit Arguments Tempty [A].
+Implicit Arguments Branch0 [A].
+Implicit Arguments Branch1 [A].
+
+Implicit Arguments Tget [A].
+Implicit Arguments Tadd [A].
+
+Implicit Arguments Tget_Tempty [A].
+Implicit Arguments Tget_Tadd [A].
+
+Implicit Arguments mkStore [A].
+Implicit Arguments index [A].
+Implicit Arguments contents [A].
+
+Implicit Arguments empty [A].
+Implicit Arguments get [A].
+Implicit Arguments push [A].
+
+Implicit Arguments get_empty [A].
+Implicit Arguments get_push_Full [A].
+
+Implicit Arguments Full [A].
+Implicit Arguments F_empty [A].
+Implicit Arguments F_push [A].
+Implicit Arguments In [A].
+
+Section Map.
+
+Variables A B:Set.
+
+Variable f: A -> B.
+
+Fixpoint Tmap (T: Tree A) : Tree B :=
+match T with
+Tempty => Tempty
+| Branch0 t1 t2 => Branch0 (Tmap t1) (Tmap t2)
+| Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2)
+end.
+
+Lemma Tget_Tmap: forall T i,
+Tget i (Tmap T)= match Tget i T with PNone => PNone
+| PSome a => PSome (f a) end.
+induction T;intro i;case i;simpl;auto.
+Defined.
+
+Lemma Tmap_Tadd: forall i a T,
+Tmap (Tadd i a T) = Tadd i (f a) (Tmap T).
+induction i;intros a T;case T;simpl;intros;try (rewrite IHi);simpl;reflexivity.
+Defined.
+
+Definition map (S:Store A) : Store B :=
+mkStore (index S) (Tmap (contents S)).
+
+Lemma get_map: forall i S,
+get i (map S)= match get i S with PNone => PNone
+| PSome a => PSome (f a) end.
+destruct S;unfold get,map,contents,index;apply Tget_Tmap.
+Defined.
+
+Lemma map_push: forall a S,
+map (push a S) = push (f a) (map S).
+intros a S.
+case S.
+unfold push,map,contents,index.
+intros;rewrite Tmap_Tadd;reflexivity.
+Defined.
+
+Theorem Full_map : forall S, Full S -> Full (map S).
+intros S F.
+induction F.
+exact F_empty.
+rewrite map_push;constructor 2;assumption.
+Defined.
+
+End Map.
+
+Implicit Arguments Tmap [A B].
+Implicit Arguments map [A B].
+Implicit Arguments Full_map [A B f].
+
+Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).
diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v
new file mode 100644
index 00000000..0d1d09c7
--- /dev/null
+++ b/plugins/rtauto/Rtauto.v
@@ -0,0 +1,400 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+
+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:=
+ Atom : positive -> form
+| Arrow : form -> form -> form
+| Bot
+| Conjunct : form -> form -> form
+| Disjunct : form -> form -> form.
+
+Notation "[ n ]":=(Atom n).
+Notation "A =>> B":= (Arrow A B) (at level 59, right associativity).
+Notation "#" := Bot.
+Notation "A //\\ B" := (Conjunct A B) (at level 57, left associativity).
+Notation "A \\// B" := (Disjunct A B) (at level 58, left associativity).
+
+Definition ctx := Store form.
+
+Fixpoint pos_eq (m n:positive) {struct m} :bool :=
+match m with
+ xI mm => match n with xI nn => pos_eq mm nn | _ => false end
+| xO mm => match n with xO nn => pos_eq mm nn | _ => false end
+| xH => match n with xH => true | _ => false end
+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).
+Qed.
+
+Fixpoint form_eq (p q:form) {struct p} :bool :=
+match p with
+ Atom m => match q with Atom n => pos_eq m n | _ => false end
+| Arrow p1 p2 =>
+match q with
+ Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2
+| _ => false end
+| Bot => match q with Bot => true | _ => false end
+| Conjunct p1 p2 =>
+match q with
+ Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2
+| _ => false
+end
+| Disjunct p1 p2 =>
+match q with
+ Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2
+| _ => false
+end
+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.
+intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
+caseq (form_eq p1 q1);clean.
+intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
+caseq (form_eq p1 q1);clean.
+intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence.
+Qed.
+
+Implicit Arguments form_eq_refl [p q].
+
+Section with_env.
+
+Variable env:Store Prop.
+
+Fixpoint interp_form (f:form): Prop :=
+match f with
+[n]=> match get n env with PNone => True | PSome P => P end
+| A =>> B => (interp_form A) -> (interp_form B)
+| # => False
+| A //\\ B => (interp_form A) /\ (interp_form B)
+| A \\// B => (interp_form A) \/ (interp_form B)
+end.
+
+Notation "[[ A ]]" := (interp_form A).
+
+Fixpoint interp_ctx (hyps:ctx) (F:Full hyps) (G:Prop) {struct F} : Prop :=
+match F with
+ F_empty => G
+| F_push H hyps0 F0 => interp_ctx hyps0 F0 ([[H]] -> G)
+end.
+
+Require Export BinPos.
+
+Ltac wipe := intros;simpl;constructor.
+
+Lemma compose0 :
+forall hyps F (A:Prop),
+ A ->
+ (interp_ctx hyps F A).
+induction F;intros A H;simpl;auto.
+Qed.
+
+Lemma compose1 :
+forall hyps F (A B:Prop),
+ (A -> B) ->
+ (interp_ctx hyps F A) ->
+ (interp_ctx hyps F B).
+induction F;intros A B H;simpl;auto.
+apply IHF;auto.
+Qed.
+
+Theorem compose2 :
+forall hyps F (A B C:Prop),
+ (A -> B -> C) ->
+ (interp_ctx hyps F A) ->
+ (interp_ctx hyps F B) ->
+ (interp_ctx hyps F C).
+induction F;intros A B C H;simpl;auto.
+apply IHF;auto.
+Qed.
+
+Theorem compose3 :
+forall hyps F (A B C D:Prop),
+ (A -> B -> C -> D) ->
+ (interp_ctx hyps F A) ->
+ (interp_ctx hyps F B) ->
+ (interp_ctx hyps F C) ->
+ (interp_ctx hyps F D).
+induction F;intros A B C D H;simpl;auto.
+apply IHF;auto.
+Qed.
+
+Lemma weaken : forall hyps F f G,
+ (interp_ctx hyps F G) ->
+ (interp_ctx (hyps\f) (F_push f hyps F) G).
+induction F;simpl;intros;auto.
+apply compose1 with ([[a]]-> G);auto.
+Qed.
+
+Theorem project_In : forall hyps F g,
+In g hyps F ->
+interp_ctx hyps F [[g]].
+induction F;simpl.
+contradiction.
+intros g H;destruct H.
+subst;apply compose0;simpl;trivial.
+apply compose1 with [[g]];auto.
+Qed.
+
+Theorem project : forall hyps F p g,
+get p hyps = PSome g->
+interp_ctx hyps F [[g]].
+intros hyps F p g e; apply project_In.
+apply get_In with p;assumption.
+Qed.
+
+Implicit Arguments project [hyps p g].
+
+Inductive proof:Set :=
+ Ax : positive -> proof
+| I_Arrow : proof -> proof
+| E_Arrow : positive -> positive -> proof -> proof
+| D_Arrow : positive -> proof -> proof -> proof
+| E_False : positive -> proof
+| I_And: proof -> proof -> proof
+| E_And: positive -> proof -> proof
+| D_And: positive -> proof -> proof
+| I_Or_l: proof -> proof
+| I_Or_r: proof -> proof
+| E_Or: positive -> proof -> proof -> proof
+| D_Or: positive -> proof -> proof
+| Cut: form -> proof -> proof -> proof.
+
+Notation "hyps \ A" := (push A hyps) (at level 72,left associativity).
+
+Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool :=
+ match P with
+ Ax i =>
+ match get i hyps with
+ PSome F => form_eq F gl
+ | _ => false
+ end
+| I_Arrow p =>
+ match gl with
+ A =>> B => check_proof (hyps \ A) B p
+ | _ => false
+ end
+| E_Arrow i j p =>
+ match get i hyps,get j hyps with
+ PSome A,PSome (B =>>C) =>
+ form_eq A B && check_proof (hyps \ C) (gl) p
+ | _,_ => false
+ end
+| D_Arrow i p1 p2 =>
+ match get i hyps with
+ PSome ((A =>>B)=>>C) =>
+ (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2)
+ | _ => false
+ end
+| E_False i =>
+ match get i hyps with
+ PSome # => true
+ | _ => false
+ end
+| I_And p1 p2 =>
+ match gl with
+ A //\\ B =>
+ check_proof hyps A p1 && check_proof hyps B p2
+ | _ => false
+ end
+| E_And i p =>
+ match get i hyps with
+ PSome (A //\\ B) => check_proof (hyps \ A \ B) gl p
+ | _=> false
+ end
+| D_And i p =>
+ match get i hyps with
+ PSome (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p
+ | _=> false
+ end
+| I_Or_l p =>
+ match gl with
+ (A \\// B) => check_proof hyps A p
+ | _ => false
+ end
+| I_Or_r p =>
+ match gl with
+ (A \\// B) => check_proof hyps B p
+ | _ => false
+ end
+| E_Or i p1 p2 =>
+ match get i hyps with
+ PSome (A \\// B) =>
+ check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2
+ | _=> false
+ end
+| D_Or i p =>
+ match get i hyps with
+ PSome (A \\// B =>> C) =>
+ (check_proof (hyps \ A=>>C \ B=>>C) gl p)
+ | _=> false
+ end
+| Cut A p1 p2 =>
+ check_proof hyps A p1 && check_proof (hyps \ A) gl p2
+end.
+
+Theorem interp_proof:
+forall p hyps F gl,
+check_proof hyps gl p = true -> interp_ctx hyps F [[gl]].
+
+induction p;intros hyps F gl.
+
+(* cas Axiom *)
+Focus 1.
+simpl;caseq (get p hyps);clean.
+intros f nth_f e;rewrite <- (form_eq_refl e).
+apply project with p;trivial.
+
+(* Cas Arrow_Intro *)
+Focus 1.
+destruct gl;clean.
+simpl;intros.
+change (interp_ctx (hyps\gl1) (F_push gl1 hyps F) [[gl2]]).
+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.
+intros f0 ef0;destruct f0;clean.
+caseq (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);
+clear check_p1 IHp p p0 p1 ef ef0.
+simpl.
+apply compose3.
+rewrite (form_eq_refl e).
+auto.
+
+(* cas Arrow_Destruct *)
+Focus 1.
+simpl;caseq (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.
+intros check_p1 check_p2.
+generalize (project F ef)
+(IHp1 (hyps \ f1_2 =>> f2 \ f1_1)
+(F_push f1_1 (hyps \ f1_2 =>> f2)
+ (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1)
+(IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2).
+simpl;apply compose3;auto.
+
+(* Cas False_Elim *)
+Focus 1.
+simpl;caseq (get p hyps);clean.
+intros f ef;destruct f;clean.
+intros _; generalize (project F ef).
+apply compose1;apply False_ind.
+
+(* Cas And_Intro *)
+Focus 1.
+simpl;destruct gl;clean.
+caseq (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.
+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).
+simpl;apply compose2;intros [h1 h2];auto.
+
+(* cas And_Destruct *)
+Focus 1.
+simpl;caseq (get p hyps);clean.
+intros f ef;destruct f;clean.
+destruct f1;clean.
+intro H;generalize (project F ef)
+(IHp (hyps \ f1_1 =>> f1_2 =>> f2)
+(F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl.
+apply compose2;auto.
+
+(* cas Or_Intro_left *)
+Focus 1.
+destruct gl;clean.
+intro Hp;generalize (IHp hyps F gl1 Hp).
+apply compose1;simpl;auto.
+
+(* cas Or_Intro_right *)
+Focus 1.
+destruct gl;clean.
+intro Hp;generalize (IHp hyps F gl2 Hp).
+apply compose1;simpl;auto.
+
+(* cas Or_elim *)
+Focus 1.
+simpl;caseq (get p1 hyps);clean.
+intros f ef;destruct f;clean.
+caseq (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);
+simpl;apply compose3;simpl;intro h;destruct h;auto.
+
+(* cas Or_Destruct *)
+Focus 1.
+simpl;caseq (get p hyps);clean.
+intros f ef;destruct f;clean.
+destruct f1;clean.
+intro check_p0;generalize (project F ef)
+(IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2)
+(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2)
+ (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl.
+apply compose2;auto.
+
+(* cas Cut *)
+Focus 1.
+simpl;caseq (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);
+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.
+change (interp_ctx empty F_empty [[gl]]) ;
+apply interp_proof with prf;assumption.
+trivial.
+Qed.
+
+End with_env.
+
+(*
+(* A small example *)
+Parameters A B C D:Prop.
+Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
+exact (Reflect (empty \ A \ B \ C)
+([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3])
+(I_Arrow (E_And 1 (E_Or 3
+ (I_Or_l (I_And (Ax 2) (Ax 4)))
+ (I_Or_r (I_And (Ax 2) (Ax 4))))))).
+Qed.
+Print toto.
+*)
diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4
new file mode 100644
index 00000000..4cbe8436
--- /dev/null
+++ b/plugins/rtauto/g_rtauto.ml4
@@ -0,0 +1,16 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$*)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+TACTIC EXTEND rtauto
+ [ "rtauto" ] -> [ Refl_tauto.rtauto_tac ]
+END
+
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
new file mode 100644
index 00000000..562e2e3b
--- /dev/null
+++ b/plugins/rtauto/proof_search.ml
@@ -0,0 +1,546 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Term
+open Util
+open Goptions
+
+type s_info=
+ {mutable created_steps : int; (* node count*)
+ mutable pruned_steps : int;
+ mutable created_branches : int; (* path count *)
+ mutable pruned_branches : int;
+ mutable created_hyps : int; (* hyps count *)
+ mutable pruned_hyps : int;
+ mutable branch_failures : int;
+ mutable branch_successes : int;
+ mutable nd_branching : int}
+
+let s_info=
+ {created_steps = 0; (* node count*)
+ pruned_steps = 0;
+ created_branches = 0; (* path count *)
+ pruned_branches = 0;
+ created_hyps = 0; (* hyps count *)
+ pruned_hyps = 0;
+ branch_failures = 0;
+ branch_successes = 0;
+ nd_branching = 0}
+
+let reset_info () =
+ s_info.created_steps <- 0; (* node count*)
+ s_info.pruned_steps <- 0;
+ s_info.created_branches <- 0; (* path count *)
+ s_info.pruned_branches <- 0;
+ s_info.created_hyps <- 0; (* hyps count *)
+ s_info.pruned_hyps <- 0;
+ s_info.branch_failures <- 0;
+ s_info.branch_successes <- 0;
+ s_info.nd_branching <- 0
+
+let pruning = ref true
+
+let opt_pruning=
+ {optsync=true;
+ optname="Rtauto Pruning";
+ optkey=["Rtauto";"Pruning"];
+ optread=(fun () -> !pruning);
+ optwrite=(fun b -> pruning:=b)}
+
+let _ = declare_bool_option opt_pruning
+
+type form=
+ Atom of int
+ | Arrow of form * form
+ | Bot
+ | Conjunct of form * form
+ | Disjunct of form * form
+
+type tag=int
+
+let decomp_form=function
+ Atom i -> Some (i,[])
+ | Arrow (f1,f2) -> Some (-1,[f1;f2])
+ | Bot -> Some (-2,[])
+ | Conjunct (f1,f2) -> Some (-3,[f1;f2])
+ | Disjunct (f1,f2) -> Some (-4,[f1;f2])
+
+module Fmap=Map.Make(struct type t=form let compare=compare end)
+
+type sequent =
+ {rev_hyps: form Intmap.t;
+ norev_hyps: form Intmap.t;
+ size:int;
+ left:int Fmap.t;
+ right:(int*form) list Fmap.t;
+ cnx:(int*int*form*form) list;
+ abs:int option;
+ gl:form}
+
+let add_one_arrow i f1 f2 m=
+ try Fmap.add f1 ((i,f2)::(Fmap.find f1 m)) m with
+ Not_found ->
+ Fmap.add f1 [i,f2] m
+
+type proof =
+ Ax of int
+ | I_Arrow of proof
+ | E_Arrow of int*int*proof
+ | D_Arrow of int*proof*proof
+ | E_False of int
+ | I_And of proof*proof
+ | E_And of int*proof
+ | D_And of int*proof
+ | I_Or_l of proof
+ | I_Or_r of proof
+ | E_Or of int*proof*proof
+ | D_Or of int*proof
+ | Pop of int*proof
+
+type rule =
+ SAx of int
+ | SI_Arrow
+ | SE_Arrow of int*int
+ | SD_Arrow of int
+ | SE_False of int
+ | SI_And
+ | SE_And of int
+ | SD_And of int
+ | SI_Or_l
+ | SI_Or_r
+ | SE_Or of int
+ | SD_Or of int
+
+let add_step s sub =
+ match s,sub with
+ SAx i,[] -> Ax i
+ | SI_Arrow,[p] -> I_Arrow p
+ | SE_Arrow(i,j),[p] -> E_Arrow (i,j,p)
+ | SD_Arrow i,[p1;p2] -> D_Arrow (i,p1,p2)
+ | SE_False i,[] -> E_False i
+ | SI_And,[p1;p2] -> I_And(p1,p2)
+ | SE_And i,[p] -> E_And(i,p)
+ | SD_And i,[p] -> D_And(i,p)
+ | SI_Or_l,[p] -> I_Or_l p
+ | SI_Or_r,[p] -> I_Or_r p
+ | SE_Or i,[p1;p2] -> E_Or(i,p1,p2)
+ | SD_Or i,[p] -> D_Or(i,p)
+ | _,_ -> anomaly "add_step: wrong arity"
+
+type 'a with_deps =
+ {dep_it:'a;
+ dep_goal:bool;
+ dep_hyps:Intset.t}
+
+type slice=
+ {proofs_done:proof list;
+ proofs_todo:sequent with_deps list;
+ step:rule;
+ needs_goal:bool;
+ needs_hyps:Intset.t;
+ changes_goal:bool;
+ creates_hyps:Intset.t}
+
+type state =
+ Complete of proof
+ | Incomplete of sequent * slice list
+
+let project = function
+ Complete prf -> prf
+ | Incomplete (_,_) -> anomaly "not a successful state"
+
+let pop n prf =
+ let nprf=
+ match prf.dep_it with
+ Pop (i,p) -> Pop (i+n,p)
+ | p -> Pop(n,p) in
+ {prf with dep_it = nprf}
+
+let rec fill stack proof =
+ match stack with
+ [] -> Complete proof.dep_it
+ | slice::super ->
+ if
+ !pruning &&
+ slice.proofs_done=[] &&
+ not (slice.changes_goal && proof.dep_goal) &&
+ not (Intset.exists
+ (fun i -> Intset.mem i proof.dep_hyps)
+ slice.creates_hyps)
+ then
+ begin
+ s_info.pruned_steps<-s_info.pruned_steps+1;
+ s_info.pruned_branches<- s_info.pruned_branches +
+ List.length slice.proofs_todo;
+ let created_here=Intset.cardinal slice.creates_hyps in
+ s_info.pruned_hyps<-s_info.pruned_hyps+
+ List.fold_left
+ (fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps)
+ created_here slice.proofs_todo;
+ fill super (pop (Intset.cardinal slice.creates_hyps) proof)
+ end
+ else
+ let dep_hyps=
+ Intset.union slice.needs_hyps
+ (Intset.diff proof.dep_hyps slice.creates_hyps) in
+ let dep_goal=
+ slice.needs_goal ||
+ ((not slice.changes_goal) && proof.dep_goal) in
+ let proofs_done=
+ proof.dep_it::slice.proofs_done in
+ match slice.proofs_todo with
+ [] ->
+ fill super {dep_it =
+ add_step slice.step (List.rev proofs_done);
+ dep_goal = dep_goal;
+ dep_hyps = dep_hyps}
+ | current::next ->
+ let nslice=
+ {proofs_done=proofs_done;
+ proofs_todo=next;
+ step=slice.step;
+ needs_goal=dep_goal;
+ needs_hyps=dep_hyps;
+ changes_goal=current.dep_goal;
+ creates_hyps=current.dep_hyps} in
+ Incomplete (current.dep_it,nslice::super)
+
+let append stack (step,subgoals) =
+ s_info.created_steps<-s_info.created_steps+1;
+ match subgoals with
+ [] ->
+ s_info.branch_successes<-s_info.branch_successes+1;
+ fill stack {dep_it=add_step step.dep_it [];
+ dep_goal=step.dep_goal;
+ dep_hyps=step.dep_hyps}
+ | hd :: next ->
+ s_info.created_branches<-
+ s_info.created_branches+List.length next;
+ let slice=
+ {proofs_done=[];
+ proofs_todo=next;
+ step=step.dep_it;
+ needs_goal=step.dep_goal;
+ needs_hyps=step.dep_hyps;
+ changes_goal=hd.dep_goal;
+ creates_hyps=hd.dep_hyps} in
+ Incomplete(hd.dep_it,slice::stack)
+
+let embed seq=
+ {dep_it=seq;
+ dep_goal=false;
+ dep_hyps=Intset.empty}
+
+let change_goal seq gl=
+ {seq with
+ dep_it={seq.dep_it with gl=gl};
+ dep_goal=true}
+
+let add_hyp seqwd f=
+ s_info.created_hyps<-s_info.created_hyps+1;
+ let seq=seqwd.dep_it in
+ let num = seq.size+1 in
+ let left = Fmap.add f num seq.left in
+ let cnx,right=
+ try
+ let l=Fmap.find f seq.right in
+ List.fold_right (fun (i,f0) l0 -> (num,i,f,f0)::l0) l seq.cnx,
+ Fmap.remove f seq.right
+ with Not_found -> seq.cnx,seq.right in
+ let nseq=
+ match f with
+ Bot ->
+ {seq with
+ left=left;
+ right=right;
+ size=num;
+ abs=Some num;
+ cnx=cnx}
+ | Atom _ ->
+ {seq with
+ size=num;
+ left=left;
+ right=right;
+ cnx=cnx}
+ | Conjunct (_,_) | Disjunct (_,_) ->
+ {seq with
+ rev_hyps=Intmap.add num f seq.rev_hyps;
+ size=num;
+ left=left;
+ right=right;
+ cnx=cnx}
+ | Arrow (f1,f2) ->
+ let ncnx,nright=
+ try
+ let i = Fmap.find f1 seq.left in
+ (i,num,f1,f2)::cnx,right
+ with Not_found ->
+ cnx,(add_one_arrow num f1 f2 right) in
+ match f1 with
+ Conjunct (_,_) | Disjunct (_,_) ->
+ {seq with
+ rev_hyps=Intmap.add num f seq.rev_hyps;
+ size=num;
+ left=left;
+ right=nright;
+ cnx=ncnx}
+ | Arrow(_,_) ->
+ {seq with
+ norev_hyps=Intmap.add num f seq.norev_hyps;
+ size=num;
+ left=left;
+ right=nright;
+ cnx=ncnx}
+ | _ ->
+ {seq with
+ size=num;
+ left=left;
+ right=nright;
+ cnx=ncnx} in
+ {seqwd with
+ dep_it=nseq;
+ dep_hyps=Intset.add num seqwd.dep_hyps}
+
+exception Here_is of (int*form)
+
+let choose m=
+ try
+ Intmap.iter (fun i f -> raise (Here_is (i,f))) m;
+ raise Not_found
+ with
+ Here_is (i,f) -> (i,f)
+
+
+let search_or seq=
+ match seq.gl with
+ Disjunct (f1,f2) ->
+ [{dep_it = SI_Or_l;
+ dep_goal = true;
+ dep_hyps = Intset.empty},
+ [change_goal (embed seq) f1];
+ {dep_it = SI_Or_r;
+ dep_goal = true;
+ dep_hyps = Intset.empty},
+ [change_goal (embed seq) f2]]
+ | _ -> []
+
+let search_norev seq=
+ let goals=ref (search_or seq) in
+ let add_one i f=
+ match f with
+ Arrow (Arrow (f1,f2),f3) ->
+ let nseq =
+ {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in
+ goals:=
+ ({dep_it=SD_Arrow(i);
+ dep_goal=false;
+ dep_hyps=Intset.singleton i},
+ [add_hyp
+ (add_hyp
+ (change_goal (embed nseq) f2)
+ (Arrow(f2,f3)))
+ f1;
+ add_hyp (embed nseq) f3]):: !goals
+ | _ -> anomaly "search_no_rev: can't happen" in
+ Intmap.iter add_one seq.norev_hyps;
+ List.rev !goals
+
+let search_in_rev_hyps seq=
+ try
+ let i,f=choose seq.rev_hyps in
+ let make_step step=
+ {dep_it=step;
+ dep_goal=false;
+ dep_hyps=Intset.singleton i} in
+ let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in
+ match f with
+ Conjunct (f1,f2) ->
+ [make_step (SE_And(i)),
+ [add_hyp (add_hyp (embed nseq) f1) f2]]
+ | Disjunct (f1,f2) ->
+ [make_step (SE_Or(i)),
+ [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]]
+ | Arrow (Conjunct (f1,f2),f0) ->
+ [make_step (SD_And(i)),
+ [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]]
+ | Arrow (Disjunct (f1,f2),f0) ->
+ [make_step (SD_Or(i)),
+ [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]]
+ | _ -> anomaly "search_in_rev_hyps: can't happen"
+ with
+ Not_found -> search_norev seq
+
+let search_rev seq=
+ match seq.cnx with
+ (i,j,f1,f2)::next ->
+ let nseq=
+ match f1 with
+ Conjunct (_,_) | Disjunct (_,_) ->
+ {seq with cnx=next;
+ rev_hyps=Intmap.remove j seq.rev_hyps}
+ | Arrow (_,_) ->
+ {seq with cnx=next;
+ norev_hyps=Intmap.remove j seq.norev_hyps}
+ | _ ->
+ {seq with cnx=next} in
+ [{dep_it=SE_Arrow(i,j);
+ dep_goal=false;
+ dep_hyps=Intset.add i (Intset.singleton j)},
+ [add_hyp (embed nseq) f2]]
+ | [] ->
+ match seq.gl with
+ Arrow (f1,f2) ->
+ [{dep_it=SI_Arrow;
+ dep_goal=true;
+ dep_hyps=Intset.empty},
+ [add_hyp (change_goal (embed seq) f2) f1]]
+ | Conjunct (f1,f2) ->
+ [{dep_it=SI_And;
+ dep_goal=true;
+ dep_hyps=Intset.empty},[change_goal (embed seq) f1;
+ change_goal (embed seq) f2]]
+ | _ -> search_in_rev_hyps seq
+
+let search_all seq=
+ match seq.abs with
+ Some i ->
+ [{dep_it=SE_False (i);
+ dep_goal=false;
+ dep_hyps=Intset.singleton i},[]]
+ | None ->
+ try
+ let ax = Fmap.find seq.gl seq.left in
+ [{dep_it=SAx (ax);
+ dep_goal=true;
+ dep_hyps=Intset.singleton ax},[]]
+ with Not_found -> search_rev seq
+
+let bare_sequent = embed
+ {rev_hyps=Intmap.empty;
+ norev_hyps=Intmap.empty;
+ size=0;
+ left=Fmap.empty;
+ right=Fmap.empty;
+ cnx=[];
+ abs=None;
+ gl=Bot}
+
+let init_state hyps gl=
+ let init = change_goal bare_sequent gl in
+ let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in
+ Incomplete (goal.dep_it,[])
+
+let success= function
+ Complete _ -> true
+ | Incomplete (_,_) -> false
+
+let branching = function
+ Incomplete (seq,stack) ->
+ check_for_interrupt ();
+ let successors = search_all seq in
+ let _ =
+ match successors with
+ [] -> s_info.branch_failures<-s_info.branch_failures+1
+ | _::next ->
+ s_info.nd_branching<-s_info.nd_branching+List.length next in
+ List.map (append stack) successors
+ | Complete prf -> anomaly "already succeeded"
+
+open Pp
+
+let rec pp_form =
+ function
+ Arrow(f1,f2) -> (pp_or f1) ++ (str " -> ") ++ (pp_form f2)
+ | f -> pp_or f
+and pp_or = function
+ Disjunct(f1,f2) ->
+ (pp_or f1) ++ (str " \\/ ") ++ (pp_and f2)
+ | f -> pp_and f
+and pp_and = function
+ Conjunct(f1,f2) ->
+ (pp_and f1) ++ (str " /\\ ") ++ (pp_atom f2)
+ | f -> pp_atom f
+and pp_atom= function
+ Bot -> str "#"
+ | Atom n -> int n
+ | f -> str "(" ++ hv 2 (pp_form f) ++ str ")"
+
+let pr_form f = msg (pp_form f)
+
+let pp_intmap map =
+ let pp=ref (str "") in
+ Intmap.iter (fun i obj -> pp:= (!pp ++
+ pp_form obj ++ cut ())) map;
+ str "{ " ++ v 0 (!pp) ++ str " }"
+
+let pp_list pp_obj l=
+let pp=ref (str "") in
+ List.iter (fun o -> pp := !pp ++ (pp_obj o) ++ str ", ") l;
+ str "[ " ++ !pp ++ str "]"
+
+let pp_mapint map =
+ let pp=ref (str "") in
+ Fmap.iter (fun obj l -> pp:= (!pp ++
+ pp_form obj ++ str " => " ++
+ pp_list (fun (i,f) -> pp_form f) l ++
+ cut ()) ) map;
+ str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close ()
+
+let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2
+
+let pp_gl gl= cut () ++
+ str "{ " ++ vb 0 ++
+ begin
+ match gl.abs with
+ None -> str ""
+ | Some i -> str "ABSURD" ++ cut ()
+ end ++
+ str "rev =" ++ pp_intmap gl.rev_hyps ++ cut () ++
+ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++
+ str "arrows=" ++ pp_mapint gl.right ++ cut () ++
+ str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++
+ str "goal =" ++ pp_form gl.gl ++ str " }" ++ close ()
+
+let pp =
+ function
+ Incomplete(gl,ctx) -> msgnl (pp_gl gl)
+ | _ -> msg (str "<complete>")
+
+let pp_info () =
+ let count_info =
+ if !pruning then
+ str "Proof steps : " ++
+ int s_info.created_steps ++ str " created / " ++
+ int s_info.pruned_steps ++ str " pruned" ++ fnl () ++
+ str "Proof branches : " ++
+ int s_info.created_branches ++ str " created / " ++
+ int s_info.pruned_branches ++ str " pruned" ++ fnl () ++
+ str "Hypotheses : " ++
+ int s_info.created_hyps ++ str " created / " ++
+ int s_info.pruned_hyps ++ str " pruned" ++ fnl ()
+ else
+ str "Pruning is off" ++ fnl () ++
+ str "Proof steps : " ++
+ int s_info.created_steps ++ str " created" ++ fnl () ++
+ str "Proof branches : " ++
+ int s_info.created_branches ++ str " created" ++ fnl () ++
+ str "Hypotheses : " ++
+ int s_info.created_hyps ++ str " created" ++ fnl () in
+ msgnl
+ ( str "Proof-search statistics :" ++ fnl () ++
+ count_info ++
+ str "Branch ends: " ++
+ int s_info.branch_successes ++ str " successes / " ++
+ int s_info.branch_failures ++ str " failures" ++ fnl () ++
+ str "Non-deterministic choices : " ++
+ int s_info.nd_branching ++ str " branches")
+
+
+
diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli
new file mode 100644
index 00000000..e52f6bbd
--- /dev/null
+++ b/plugins/rtauto/proof_search.mli
@@ -0,0 +1,49 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+type form=
+ Atom of int
+ | Arrow of form * form
+ | Bot
+ | Conjunct of form * form
+ | Disjunct of form * form
+
+type proof =
+ Ax of int
+ | I_Arrow of proof
+ | E_Arrow of int*int*proof
+ | D_Arrow of int*proof*proof
+ | E_False of int
+ | I_And of proof*proof
+ | E_And of int*proof
+ | D_And of int*proof
+ | I_Or_l of proof
+ | I_Or_r of proof
+ | E_Or of int*proof*proof
+ | D_Or of int*proof
+ | Pop of int*proof
+
+type state
+
+val project: state -> proof
+
+val init_state : ('a * form * 'b) list -> form -> state
+
+val branching: state -> state list
+
+val success: state -> bool
+
+val pp: state -> unit
+
+val pr_form : form -> unit
+
+val reset_info : unit -> unit
+
+val pp_info : unit -> unit
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
new file mode 100644
index 00000000..23cb0705
--- /dev/null
+++ b/plugins/rtauto/refl_tauto.ml
@@ -0,0 +1,337 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+module Search = Explore.Make(Proof_search)
+
+open Util
+open Term
+open Termops
+open Names
+open Evd
+open Tacmach
+open Proof_search
+
+let force count lazc = incr count;Lazy.force lazc
+
+let step_count = ref 0
+
+let node_count = ref 0
+
+let logic_constant =
+ Coqlib.gen_constant "refl_tauto" ["Init";"Logic"]
+
+let li_False = lazy (destInd (logic_constant "False"))
+let li_and = lazy (destInd (logic_constant "and"))
+let li_or = lazy (destInd (logic_constant "or"))
+
+let data_constant =
+ Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"]
+
+let l_true_equals_true =
+ lazy (mkApp(logic_constant "refl_equal",
+ [|data_constant "bool";data_constant "true"|]))
+
+let pos_constant =
+ Coqlib.gen_constant "refl_tauto" ["NArith";"BinPos"]
+
+let l_xI = lazy (pos_constant "xI")
+let l_xO = lazy (pos_constant "xO")
+let l_xH = lazy (pos_constant "xH")
+
+let store_constant =
+ Coqlib.gen_constant "refl_tauto" ["rtauto";"Bintree"]
+
+let l_empty = lazy (store_constant "empty")
+let l_push = lazy (store_constant "push")
+
+let constant=
+ Coqlib.gen_constant "refl_tauto" ["rtauto";"Rtauto"]
+
+let l_Reflect = lazy (constant "Reflect")
+
+let l_Atom = lazy (constant "Atom")
+let l_Arrow = lazy (constant "Arrow")
+let l_Bot = lazy (constant "Bot")
+let l_Conjunct = lazy (constant "Conjunct")
+let l_Disjunct = lazy (constant "Disjunct")
+
+let l_Ax = lazy (constant "Ax")
+let l_I_Arrow = lazy (constant "I_Arrow")
+let l_E_Arrow = lazy (constant "E_Arrow")
+let l_D_Arrow = lazy (constant "D_Arrow")
+let l_E_False = lazy (constant "E_False")
+let l_I_And = lazy (constant "I_And")
+let l_E_And = lazy (constant "E_And")
+let l_D_And = lazy (constant "D_And")
+let l_I_Or_l = lazy (constant "I_Or_l")
+let l_I_Or_r = lazy (constant "I_Or_r")
+let l_E_Or = lazy (constant "E_Or")
+let l_D_Or = lazy (constant "D_Or")
+
+
+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))
+
+type atom_env=
+ {mutable next:int;
+ mutable env:(constr*int) list}
+
+let make_atom atom_env term=
+ try
+ let (_,i)=
+ List.find (fun (t,_)-> eq_constr term t) atom_env.env
+ in Atom i
+ with Not_found ->
+ let i=atom_env.next in
+ atom_env.env <- (term,i)::atom_env.env;
+ atom_env.next<- i + 1;
+ Atom i
+
+let rec make_form atom_env gls term =
+ let normalize=special_nf gls in
+ let cciterm=special_whd gls term in
+ match kind_of_term cciterm with
+ Prod(_,a,b) ->
+ if not (dependent (mkRel 1) b) &&
+ Retyping.get_sort_family_of
+ (pf_env gls) (Tacmach.project gls) a = InProp
+ then
+ let fa=make_form atom_env gls a in
+ let fb=make_form atom_env gls b in
+ Arrow (fa,fb)
+ else
+ make_atom atom_env (normalize term)
+ | Cast(a,_,_) ->
+ make_form atom_env gls a
+ | Ind ind ->
+ if ind = Lazy.force li_False then
+ Bot
+ else
+ make_atom atom_env (normalize term)
+ | App(hd,argv) when Array.length argv = 2 ->
+ begin
+ try
+ let ind = destInd hd in
+ if ind = Lazy.force li_and then
+ let fa=make_form atom_env gls argv.(0) in
+ let fb=make_form atom_env gls argv.(1) in
+ Conjunct (fa,fb)
+ else if ind = Lazy.force li_or then
+ let fa=make_form atom_env gls argv.(0) in
+ let fb=make_form atom_env gls argv.(1) in
+ Disjunct (fa,fb)
+ else make_atom atom_env (normalize term)
+ with Invalid_argument _ -> make_atom atom_env (normalize term)
+ end
+ | _ -> make_atom atom_env (normalize term)
+
+let rec make_hyps atom_env gls lenv = function
+ [] -> []
+ | (_,Some body,typ)::rest ->
+ make_hyps atom_env gls (typ::body::lenv) rest
+ | (id,None,typ)::rest ->
+ let hrec=
+ make_hyps atom_env gls (typ::lenv) rest in
+ if List.exists (dependent (mkVar id)) lenv ||
+ (Retyping.get_sort_family_of
+ (pf_env gls) (Tacmach.project gls) typ <> InProp)
+ then
+ hrec
+ else
+ (id,make_form atom_env gls typ)::hrec
+
+let rec build_pos n =
+ if n<=1 then force node_count l_xH
+ else if n land 1 = 0 then
+ mkApp (force node_count l_xO,[|build_pos (n asr 1)|])
+ else
+ mkApp (force node_count l_xI,[|build_pos (n asr 1)|])
+
+let rec build_form = function
+ Atom n -> mkApp (force node_count l_Atom,[|build_pos n|])
+ | Arrow (f1,f2) ->
+ mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|])
+ | Bot -> force node_count l_Bot
+ | Conjunct (f1,f2) ->
+ mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|])
+ | Disjunct (f1,f2) ->
+ mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|])
+
+let rec decal k = function
+ [] -> k
+ | (start,delta)::rest ->
+ if k>start then
+ k - delta
+ else
+ decal k rest
+
+let add_pop size d pops=
+ match pops with
+ [] -> [size+d,d]
+ | (_,sum)::_ -> (size+sum,sum+d)::pops
+
+let rec build_proof pops size =
+ function
+ Ax i ->
+ mkApp (force step_count l_Ax,
+ [|build_pos (decal i pops)|])
+ | I_Arrow p ->
+ mkApp (force step_count l_I_Arrow,
+ [|build_proof pops (size + 1) p|])
+ | E_Arrow(i,j,p) ->
+ mkApp (force step_count l_E_Arrow,
+ [|build_pos (decal i pops);
+ build_pos (decal j pops);
+ build_proof pops (size + 1) p|])
+ | D_Arrow(i,p1,p2) ->
+ mkApp (force step_count l_D_Arrow,
+ [|build_pos (decal i pops);
+ build_proof pops (size + 2) p1;
+ build_proof pops (size + 1) p2|])
+ | E_False i ->
+ mkApp (force step_count l_E_False,
+ [|build_pos (decal i pops)|])
+ | I_And(p1,p2) ->
+ mkApp (force step_count l_I_And,
+ [|build_proof pops size p1;
+ build_proof pops size p2|])
+ | E_And(i,p) ->
+ mkApp (force step_count l_E_And,
+ [|build_pos (decal i pops);
+ build_proof pops (size + 2) p|])
+ | D_And(i,p) ->
+ mkApp (force step_count l_D_And,
+ [|build_pos (decal i pops);
+ build_proof pops (size + 1) p|])
+ | I_Or_l(p) ->
+ mkApp (force step_count l_I_Or_l,
+ [|build_proof pops size p|])
+ | I_Or_r(p) ->
+ mkApp (force step_count l_I_Or_r,
+ [|build_proof pops size p|])
+ | E_Or(i,p1,p2) ->
+ mkApp (force step_count l_E_Or,
+ [|build_pos (decal i pops);
+ build_proof pops (size + 1) p1;
+ build_proof pops (size + 1) p2|])
+ | D_Or(i,p) ->
+ mkApp (force step_count l_D_Or,
+ [|build_pos (decal i pops);
+ build_proof pops (size + 2) p|])
+ | Pop(d,p) ->
+ build_proof (add_pop size d pops) size p
+
+let build_env gamma=
+ List.fold_right (fun (p,_) e ->
+ mkApp(force node_count l_push,[|mkProp;p;e|]))
+ gamma.env (mkApp (force node_count l_empty,[|mkProp|]))
+
+open Goptions
+
+let verbose = ref false
+
+let opt_verbose=
+ {optsync=true;
+ optname="Rtauto Verbose";
+ optkey=["Rtauto";"Verbose"];
+ optread=(fun () -> !verbose);
+ optwrite=(fun b -> verbose:=b)}
+
+let _ = declare_bool_option opt_verbose
+
+let check = ref false
+
+let opt_check=
+ {optsync=true;
+ optname="Rtauto Check";
+ optkey=["Rtauto";"Check"];
+ optread=(fun () -> !check);
+ optwrite=(fun b -> check:=b)}
+
+let _ = declare_bool_option opt_check
+
+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 _=
+ 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 formula=
+ List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in
+ let search_fun =
+ if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then
+ Search.debug_depth_first
+ else
+ Search.depth_first in
+ let _ =
+ begin
+ reset_info ();
+ if !verbose then
+ msgnl (str "Starting proof-search ...");
+ end in
+ let search_start_time = System.get_time () in
+ let prf =
+ try project (search_fun (init_state [] formula))
+ with Not_found ->
+ errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in
+ let search_end_time = System.get_time () in
+ let _ = if !verbose then
+ begin
+ msgnl (str "Proof tree found in " ++
+ System.fmt_time_difference search_start_time search_end_time);
+ pp_info ();
+ msgnl (str "Building proof term ... ")
+ end in
+ let build_start_time=System.get_time () in
+ let _ = step_count := 0; node_count := 0 in
+ let main = mkApp (force node_count l_Reflect,
+ [|build_env gamma;
+ build_form formula;
+ build_proof [] 0 prf|]) in
+ let term=
+ Term.applist (main,List.rev_map (fun (id,_) -> mkVar id) hyps) in
+ let build_end_time=System.get_time () in
+ let _ = if !verbose then
+ begin
+ msgnl (str "Proof term built in " ++
+ System.fmt_time_difference build_start_time build_end_time ++
+ fnl () ++
+ str "Proof size : " ++ int !step_count ++
+ str " steps" ++ fnl () ++
+ str "Proof term size : " ++ int (!step_count+ !node_count) ++
+ str " nodes (constants)" ++ fnl () ++
+ str "Giving proof term to Coq ... ")
+ end in
+ let tac_start_time = System.get_time () in
+ let result=
+ if !check then
+ Tactics.exact_check term gls
+ else
+ Tactics.exact_no_check term gls in
+ let tac_end_time = System.get_time () in
+ let _ =
+ if !check then msgnl (str "Proof term type-checking is on");
+ if !verbose then
+ msgnl (str "Internal tactic executed in " ++
+ System.fmt_time_difference tac_start_time tac_end_time) in
+ result
+
diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
new file mode 100644
index 00000000..a6d68a22
--- /dev/null
+++ b/plugins/rtauto/refl_tauto.mli
@@ -0,0 +1,26 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* $Id$ *)
+
+(* raises Not_found if no proof is found *)
+
+type atom_env=
+ {mutable next:int;
+ mutable env:(Term.constr*int) list}
+
+val make_form : atom_env ->
+ Proof_type.goal Tacmach.sigma -> Term.types -> Proof_search.form
+
+val make_hyps :
+ atom_env ->
+ Proof_type.goal Tacmach.sigma ->
+ Term.types list ->
+ (Names.identifier * Term.types option * Term.types) list ->
+ (Names.identifier * Proof_search.form) list
+
+val rtauto_tac : Proof_type.tactic
diff --git a/plugins/rtauto/rtauto_plugin.mllib b/plugins/rtauto/rtauto_plugin.mllib
new file mode 100644
index 00000000..0e346044
--- /dev/null
+++ b/plugins/rtauto/rtauto_plugin.mllib
@@ -0,0 +1,4 @@
+Proof_search
+Refl_tauto
+G_rtauto
+Rtauto_plugin_mod
diff --git a/plugins/rtauto/vo.itarget b/plugins/rtauto/vo.itarget
new file mode 100644
index 00000000..4c9364ad
--- /dev/null
+++ b/plugins/rtauto/vo.itarget
@@ -0,0 +1,2 @@
+Bintree.vo
+Rtauto.vo
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
new file mode 100644
index 00000000..e5a4c8d1
--- /dev/null
+++ b/plugins/setoid_ring/ArithRing.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Import Mult.
+Require Import BinNat.
+Require Import Nnat.
+Require Export Ring.
+Set Implicit Arguments.
+
+Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat).
+ Proof.
+ constructor. exact plus_0_l. exact plus_comm. exact plus_assoc.
+ exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc.
+ exact mult_plus_distr_r.
+ Qed.
+
+Lemma nat_morph_N :
+ semi_morph 0 1 plus mult (eq (A:=nat))
+ 0%N 1%N Nplus Nmult Neq_bool nat_of_N.
+Proof.
+ constructor;trivial.
+ exact nat_of_Nplus.
+ exact nat_of_Nmult.
+ intros x y H;rewrite (Neq_bool_ok _ _ H);trivial.
+Qed.
+
+Ltac natcst t :=
+ match isnatcst t with
+ true => constr:(N_of_nat t)
+ | _ => constr:InitialRing.NotConstant
+ end.
+
+Ltac Ss_to_add f acc :=
+ match f with
+ | S ?f1 => Ss_to_add f1 (S acc)
+ | _ => constr:(acc + f)%nat
+ end.
+
+Ltac natprering :=
+ match goal with
+ |- context C [S ?p] =>
+ match p with
+ O => fail 1 (* avoid replacing 1 with 1+0 ! *)
+ | p => match isnatcst p with
+ | true => fail 1
+ | false => let v := Ss_to_add p (S 0) in
+ fold v; natprering
+ end
+ end
+ | _ => idtac
+ end.
+
+Add Ring natr : natSRth
+ (morphism nat_morph_N, constants [natcst], preprocess [natprering]).
+
diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v
new file mode 100644
index 00000000..d403c9ef
--- /dev/null
+++ b/plugins/setoid_ring/BinList.v
@@ -0,0 +1,93 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Set Implicit Arguments.
+Require Import BinPos.
+Require Export List.
+Require Export ListTactics.
+Open Local Scope positive_scope.
+
+Section MakeBinList.
+ Variable A : Type.
+ Variable default : A.
+
+ Fixpoint jump (p:positive) (l:list A) {struct p} : list A :=
+ match p with
+ | xH => tail l
+ | xO p => jump p (jump p l)
+ | xI p => jump p (jump p (tail l))
+ end.
+
+ Fixpoint nth (p:positive) (l:list A) {struct p} : A:=
+ match p with
+ | xH => hd default l
+ | xO p => nth p (jump p l)
+ | xI p => nth p (jump p (tail l))
+ end.
+
+ Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l).
+ Proof.
+ induction j;simpl;intros.
+ repeat rewrite IHj;trivial.
+ repeat rewrite IHj;trivial.
+ trivial.
+ Qed.
+
+ Lemma jump_Psucc : forall j l,
+ (jump (Psucc j) l) = (jump 1 (jump j l)).
+ Proof.
+ induction j;simpl;intros.
+ repeat rewrite IHj;simpl;repeat rewrite jump_tl;trivial.
+ repeat rewrite jump_tl;trivial.
+ trivial.
+ Qed.
+
+ Lemma jump_Pplus : forall i j l,
+ (jump (i + j) l) = (jump i (jump j l)).
+ Proof.
+ induction i;intros.
+ rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
+ rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+ repeat rewrite IHi.
+ rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial.
+ rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+ repeat rewrite IHi;trivial.
+ rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite jump_Psucc;trivial.
+ Qed.
+
+ Lemma jump_Pdouble_minus_one : forall i l,
+ (jump (Pdouble_minus_one i) (tail l)) = (jump i (jump i l)).
+ Proof.
+ induction i;intros;simpl.
+ repeat rewrite jump_tl;trivial.
+ rewrite IHi. do 2 rewrite <- jump_tl;rewrite IHi;trivial.
+ trivial.
+ Qed.
+
+
+ Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l).
+ Proof.
+ induction p;simpl;intros.
+ rewrite <-jump_tl;rewrite IHp;trivial.
+ rewrite <-jump_tl;rewrite IHp;trivial.
+ trivial.
+ Qed.
+
+ Lemma nth_Pdouble_minus_one :
+ forall p l, nth (Pdouble_minus_one p) (tail l) = nth p (jump p l).
+ Proof.
+ induction p;simpl;intros.
+ repeat rewrite jump_tl;trivial.
+ rewrite jump_Pdouble_minus_one.
+ repeat rewrite <- jump_tl;rewrite IHp;trivial.
+ trivial.
+ Qed.
+
+End MakeBinList.
+
+
diff --git a/plugins/setoid_ring/Field.v b/plugins/setoid_ring/Field.v
new file mode 100644
index 00000000..a944ba5f
--- /dev/null
+++ b/plugins/setoid_ring/Field.v
@@ -0,0 +1,10 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Export Field_theory.
+Require Export Field_tac.
diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v
new file mode 100644
index 00000000..9d82d1fd
--- /dev/null
+++ b/plugins/setoid_ring/Field_tac.v
@@ -0,0 +1,571 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Import Ring_tac BinList Ring_polynom InitialRing.
+Require Export Field_theory.
+
+ (* syntaxification *)
+ Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv :=
+ let rec mkP t :=
+ let f :=
+ match Cst t with
+ | InitialRing.NotConstant =>
+ match t with
+ | (radd ?t1 ?t2) =>
+ fun _ =>
+ let e1 := mkP t1 in
+ let e2 := mkP t2 in constr:(FEadd e1 e2)
+ | (rmul ?t1 ?t2) =>
+ fun _ =>
+ let e1 := mkP t1 in
+ let e2 := mkP t2 in constr:(FEmul e1 e2)
+ | (rsub ?t1 ?t2) =>
+ fun _ =>
+ let e1 := mkP t1 in
+ let e2 := mkP t2 in constr:(FEsub e1 e2)
+ | (ropp ?t1) =>
+ fun _ => let e1 := mkP t1 in constr:(FEopp e1)
+ | (rdiv ?t1 ?t2) =>
+ fun _ =>
+ let e1 := mkP t1 in
+ let e2 := mkP t2 in constr:(FEdiv e1 e2)
+ | (rinv ?t1) =>
+ fun _ => let e1 := mkP t1 in constr:(FEinv e1)
+ | (rpow ?t1 ?n) =>
+ match CstPow n with
+ | InitialRing.NotConstant =>
+ fun _ =>
+ let p := Find_at t fv in
+ constr:(@FEX C p)
+ | ?c => fun _ => let e1 := mkP t1 in constr:(FEpow e1 c)
+ end
+ | _ =>
+ fun _ =>
+ let p := Find_at t fv in
+ constr:(@FEX C p)
+ end
+ | ?c => fun _ => constr:(FEc c)
+ end in
+ f ()
+ in mkP t.
+
+Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
+ let rec TFV t fv :=
+ match Cst t with
+ | InitialRing.NotConstant =>
+ match t with
+ | (add ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+ | (mul ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+ | (sub ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+ | (opp ?t1) => TFV t1 fv
+ | (div ?t1 ?t2) => TFV t2 ltac:(TFV t1 fv)
+ | (inv ?t1) => TFV t1 fv
+ | (pow ?t1 ?n) =>
+ match CstPow n with
+ | InitialRing.NotConstant =>
+ AddFvTail t fv
+ | _ => TFV t1 fv
+ end
+ | _ => AddFvTail t fv
+ end
+ | _ => fv
+ end
+ in TFV t fv.
+
+(* packaging the field structure *)
+
+(* TODO: inline PackField into field_lookup *)
+Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post :=
+ let FLD :=
+ match type of L1 with
+ | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
+ ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] =>
+ (fun proj =>
+ proj Cst_tac Pow_tac pre post
+ req radd rmul rsub ropp rdiv rinv rpow C L1 L2 L3 L4 cond_ok)
+ | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
+ end in
+ F FLD.
+
+Ltac get_FldPre FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ pre).
+
+Ltac get_FldPost FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ post).
+
+Ltac get_L1 FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ L1).
+
+Ltac get_SimplifyEqLemma FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ L2).
+
+Ltac get_SimplifyLemma FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ L3).
+
+Ltac get_L4 FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ L4).
+
+Ltac get_CondLemma FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ cond_ok).
+
+Ltac get_FldEq FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ req).
+
+Ltac get_FldCarrier FLD :=
+ let req := get_FldEq FLD in
+ relation_carrier req.
+
+Ltac get_RingFV FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ FV Cst_tac Pow_tac radd rmul rsub ropp rpow).
+
+Ltac get_FFV FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ FFV Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+
+Ltac get_RingMeta FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow).
+
+Ltac get_Meta FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ mkFieldexpr C Cst_tac Pow_tac radd rmul rsub ropp rdiv rinv rpow).
+
+Ltac get_Hyp_tac FLD :=
+ FLD ltac:
+ (fun Cst_tac Pow_tac pre post req radd rmul rsub ropp rdiv rinv rpow C
+ L1 L2 L3 L4 cond_ok =>
+ let mkPol := mkPolexpr C Cst_tac Pow_tac radd rmul rsub ropp rpow in
+ fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
+
+Ltac get_FEeval FLD :=
+ let L1 := get_L1 FLD in
+ match type of L1 with
+ | context
+ [(@FEeval
+ ?R ?r0 ?add ?mul ?sub ?opp ?div ?inv ?C ?phi ?Cpow ?powphi ?pow _ _)] =>
+ constr:(@FEeval R r0 add mul sub opp div inv C phi Cpow powphi pow)
+ | _ => fail 1 "field anomaly: bad correctness lemma (get_FEeval)"
+ end.
+
+(* simplifying the non-zero condition... *)
+
+Ltac fold_field_cond req :=
+ let rec fold_concl t :=
+ match t with
+ ?x /\ ?y =>
+ let fx := fold_concl x in let fy := fold_concl y in constr:(fx/\fy)
+ | req ?x ?y -> False => constr:(~ req x y)
+ | _ => t
+ end in
+ let ft := fold_concl Get_goal in
+ change ft.
+
+Ltac simpl_PCond FLD :=
+ let req := get_FldEq FLD in
+ let lemma := get_CondLemma FLD in
+ try apply lemma;
+ protect_fv "field_cond";
+ fold_field_cond req;
+ try exact I.
+
+Ltac simpl_PCond_BEURK FLD :=
+ let req := get_FldEq FLD in
+ let lemma := get_CondLemma FLD in
+ apply lemma;
+ protect_fv "field_cond";
+ fold_field_cond req.
+
+(* Rewriting (field_simplify) *)
+Ltac Field_norm_gen f n FLD lH rl :=
+ let mkFV := get_RingFV FLD in
+ let mkFFV := get_FFV FLD in
+ let mkFE := get_Meta FLD in
+ let fv0 := FV_hypo_tac mkFV ltac:(get_FldEq FLD) lH in
+ let lemma_tac fv kont :=
+ let lemma := get_SimplifyLemma FLD in
+ (* reify equations of the context *)
+ let lpe := get_Hyp_tac FLD fv lH in
+ let vlpe := fresh "hyps" in
+ pose (vlpe := lpe);
+ let prh := proofHyp_tac lH in
+ (* compute the normal form of the reified hyps *)
+ let vlmp := fresh "hyps'" in
+ let vlmp_eq := fresh "hyps_eq" in
+ let mk_monpol := get_MonPol lemma in
+ compute_assertion vlmp_eq vlmp (mk_monpol vlpe);
+ (* partially instantiate the lemma *)
+ let lem := fresh "f_rw_lemma" in
+ (assert (lem := lemma n vlpe fv prh vlmp vlmp_eq)
+ || fail "type error when building the rewriting lemma");
+ (* continuation will call main_tac for all reified terms *)
+ kont lem;
+ (* at the end, cleanup *)
+ (clear lem vlmp_eq vlmp vlpe||idtac"Field_norm_gen:cleanup failed") in
+ (* each instance of the lemma is simplified then passed to f *)
+ let main_tac H := protect_fv "field" in H; f H in
+ (* generate and use equations for each expression *)
+ ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl;
+ try simpl_PCond FLD.
+
+Ltac Field_simplify_gen f FLD lH rl :=
+ get_FldPre FLD ();
+ Field_norm_gen f ring_subst_niter FLD lH rl;
+ get_FldPost FLD ().
+
+Ltac Field_simplify :=
+ Field_simplify_gen ltac:(fun H => rewrite H).
+
+Tactic Notation (at level 0) "field_simplify" constr_list(rl) :=
+ let G := Get_goal in
+ field_lookup (PackField Field_simplify) [] rl G.
+
+Tactic Notation (at level 0)
+ "field_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+ let G := Get_goal in
+ field_lookup (PackField Field_simplify) [lH] rl G.
+
+Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):=
+ let G := Get_goal in
+ let t := type of H in
+ let g := fresh "goal" in
+ set (g:= G);
+ revert H;
+ field_lookup (PackField Field_simplify) [] rl t;
+ intro H;
+ unfold g;clear g.
+
+Tactic Notation "field_simplify"
+ "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):=
+ let G := Get_goal in
+ let t := type of H in
+ let g := fresh "goal" in
+ set (g:= G);
+ revert H;
+ field_lookup (PackField Field_simplify) [lH] rl t;
+ intro H;
+ unfold g;clear g.
+
+(*
+Ltac Field_simplify_in hyp:=
+ Field_simplify_gen ltac:(fun H => rewrite H in hyp).
+
+Tactic Notation (at level 0)
+ "field_simplify" constr_list(rl) "in" hyp(h) :=
+ let t := type of h in
+ field_lookup (Field_simplify_in h) [] rl t.
+
+Tactic Notation (at level 0)
+ "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) :=
+ let t := type of h in
+ field_lookup (Field_simplify_in h) [lH] rl t.
+*)
+
+(** Generic tactic for solving equations *)
+
+Ltac Field_Scheme Simpl_tac n lemma FLD lH :=
+ let req := get_FldEq FLD in
+ let mkFV := get_RingFV FLD in
+ let mkFFV := get_FFV FLD in
+ let mkFE := get_Meta FLD in
+ let Main_eq t1 t2 :=
+ let fv := FV_hypo_tac mkFV req lH in
+ let fv := mkFFV t1 fv in
+ let fv := mkFFV t2 fv in
+ let lpe := get_Hyp_tac FLD fv lH in
+ let prh := proofHyp_tac lH in
+ let vlpe := fresh "list_hyp" in
+ let fe1 := mkFE t1 fv in
+ let fe2 := mkFE t2 fv in
+ pose (vlpe := lpe);
+ let nlemma := fresh "field_lemma" in
+ (assert (nlemma := lemma n fv vlpe fe1 fe2 prh)
+ || fail "field anomaly:failed to build lemma");
+ ProveLemmaHyps nlemma
+ ltac:(fun ilemma =>
+ apply ilemma
+ || fail "field anomaly: failed in applying lemma";
+ [ Simpl_tac | simpl_PCond FLD]);
+ clear nlemma;
+ subst vlpe in
+ OnEquation req Main_eq.
+
+(* solve completely a field equation, leaving non-zero conditions to be
+ proved (field) *)
+
+Ltac FIELD FLD lH rl :=
+ let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in
+ let lemma := get_L1 FLD in
+ get_FldPre FLD ();
+ Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH;
+ try exact I;
+ get_FldPost FLD().
+
+Tactic Notation (at level 0) "field" :=
+ let G := Get_goal in
+ field_lookup (PackField FIELD) [] G.
+
+Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
+ let G := Get_goal in
+ field_lookup (PackField FIELD) [lH] G.
+
+(* transforms a field equation to an equivalent (simplified) ring equation,
+ and leaves non-zero conditions to be proved (field_simplify_eq) *)
+Ltac FIELD_SIMPL FLD lH rl :=
+ let Simpl := (protect_fv "field") in
+ let lemma := get_SimplifyEqLemma FLD in
+ get_FldPre FLD ();
+ Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH;
+ get_FldPost FLD ().
+
+Tactic Notation (at level 0) "field_simplify_eq" :=
+ let G := Get_goal in
+ field_lookup (PackField FIELD_SIMPL) [] G.
+
+Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" :=
+ let G := Get_goal in
+ field_lookup (PackField FIELD_SIMPL) [lH] G.
+
+(* Same as FIELD_SIMPL but in hypothesis *)
+
+Ltac Field_simplify_eq n FLD lH :=
+ let req := get_FldEq FLD in
+ let mkFV := get_RingFV FLD in
+ let mkFFV := get_FFV FLD in
+ let mkFE := get_Meta FLD in
+ let lemma := get_L4 FLD in
+ let hyp := fresh "hyp" in
+ intro hyp;
+ OnEquationHyp req hyp ltac:(fun t1 t2 =>
+ let fv := FV_hypo_tac mkFV req lH in
+ let fv := mkFFV t1 fv in
+ let fv := mkFFV t2 fv in
+ let lpe := get_Hyp_tac FLD fv lH in
+ let prh := proofHyp_tac lH in
+ let fe1 := mkFE t1 fv in
+ let fe2 := mkFE t2 fv in
+ let vlpe := fresh "vlpe" in
+ ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh)
+ ltac:(fun ilemma =>
+ match type of ilemma with
+ | req _ _ -> _ -> ?EQ =>
+ let tmp := fresh "tmp" in
+ assert (tmp : EQ);
+ [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD]
+ | protect_fv "field" in tmp; revert tmp ];
+ clear hyp
+ end)).
+
+Ltac FIELD_SIMPL_EQ FLD lH rl :=
+ get_FldPre FLD ();
+ Field_simplify_eq Ring_tac.ring_subst_niter FLD lH;
+ get_FldPost FLD ().
+
+Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) :=
+ let t := type of H in
+ generalize H;
+ field_lookup (PackField FIELD_SIMPL_EQ) [] t;
+ [ try exact I
+ | clear H;intro H].
+
+
+Tactic Notation (at level 0)
+ "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) :=
+ let t := type of H in
+ generalize H;
+ field_lookup (PackField FIELD_SIMPL_EQ) [lH] t;
+ [ try exact I
+ |clear H;intro H].
+
+(* More generic tactics to build variants of field *)
+
+(* This tactic reifies c and pass to F:
+ - the FLD structure gathering all info in the field DB
+ - the atom list
+ - the expression (FExpr)
+ *)
+Ltac gen_with_field F c :=
+ let MetaExpr FLD _ rl :=
+ let R := get_FldCarrier FLD in
+ let mkFFV := get_FFV FLD in
+ let mkFE := get_Meta FLD in
+ let csr :=
+ match rl with
+ | List.cons ?r _ => r
+ | _ => fail 1 "anomaly: ill-formed list"
+ end in
+ let fv := mkFFV csr (@List.nil R) in
+ let expr := mkFE csr fv in
+ F FLD fv expr in
+ field_lookup (PackField MetaExpr) [] (c=c).
+
+
+(* pushes the equation expr = ope(expr) in the goal, and
+ discharge it with field *)
+Ltac prove_field_eqn ope FLD fv expr :=
+ let res := ope expr in
+ let expr' := fresh "input_expr" in
+ pose (expr' := expr);
+ let res' := fresh "result" in
+ pose (res' := res);
+ let lemma := get_L1 FLD in
+ let lemma :=
+ constr:(lemma O fv List.nil expr' res' I List.nil (refl_equal _)) in
+ let ty := type of lemma in
+ let lhs := match ty with
+ forall _, ?lhs=_ -> _ => lhs
+ end in
+ let rhs := match ty with
+ forall _, _=_ -> forall _, ?rhs=_ -> _ => rhs
+ end in
+ let lhs' := fresh "lhs" in let lhs_eq := fresh "lhs_eq" in
+ let rhs' := fresh "rhs" in let rhs_eq := fresh "rhs_eq" in
+ compute_assertion lhs_eq lhs' lhs;
+ compute_assertion rhs_eq rhs' rhs;
+ let H := fresh "fld_eqn" in
+ refine (_ (lemma lhs' lhs_eq rhs' rhs_eq _ _));
+ (* main goal *)
+ [intro H;protect_fv "field" in H; revert H
+ (* ring-nf(lhs') = ring-nf(rhs') *)
+ | vm_compute; reflexivity || fail "field cannot prove this equality"
+ (* denominator condition *)
+ | simpl_PCond FLD];
+ clear lhs_eq rhs_eq; subst lhs' rhs'.
+
+Ltac prove_with_field ope c :=
+ gen_with_field ltac:(prove_field_eqn ope) c.
+
+(* Prove an equation x=ope(x) and rewrite with it *)
+Ltac prove_rw ope x :=
+ prove_with_field ope x;
+ [ let H := fresh "Heq_maple" in
+ intro H; rewrite H; clear H
+ |..].
+
+(* Apply ope (FExpr->FExpr) on an expression *)
+Ltac reduce_field_expr ope kont FLD fv expr :=
+ let evfun := get_FEeval FLD in
+ let res := ope expr in
+ let c := (eval simpl_field_expr in (evfun fv res)) in
+ kont c.
+
+(* Hack to let a Ltac return a term in the context of a primitive tactic *)
+Ltac return_term x := generalize (refl_equal x).
+Ltac get_term :=
+ match goal with
+ | |- ?x = _ -> _ => x
+ end.
+
+(* Turn an operation on field expressions (FExpr) into a reduction
+ on terms (in the field carrier). Because of field_lookup,
+ the tactic cannot return a term directly, so it is returned
+ via the conclusion of the goal (return_term). *)
+Ltac reduce_field_ope ope c :=
+ gen_with_field ltac:(reduce_field_expr ope return_term) c.
+
+
+(* Adding a new field *)
+
+Ltac ring_of_field f :=
+ match type of f with
+ | almost_field_theory _ _ _ _ _ _ _ _ _ => constr:(AF_AR f)
+ | field_theory _ _ _ _ _ _ _ _ _ => constr:(F_R f)
+ | semi_field_theory _ _ _ _ _ _ _ => constr:(SF_SR f)
+ end.
+
+Ltac coerce_to_almost_field set ext f :=
+ match type of f with
+ | almost_field_theory _ _ _ _ _ _ _ _ _ => f
+ | field_theory _ _ _ _ _ _ _ _ _ => constr:(F2AF set ext f)
+ | semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
+ end.
+
+Ltac field_elements set ext fspec pspec sspec dspec rk :=
+ let afth := coerce_to_almost_field set ext fspec in
+ let rspec := ring_of_field fspec in
+ ring_elements set ext rspec pspec sspec dspec rk
+ ltac:(fun arth ext_r morph p_spec s_spec d_spec f => f afth ext_r morph p_spec s_spec d_spec).
+
+Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk :=
+ let get_lemma :=
+ match pspec with None => fun x y => x | _ => fun x y => y end in
+ let simpl_eq_lemma := get_lemma
+ Field_simplify_eq_correct Field_simplify_eq_pow_correct in
+ let simpl_eq_in_lemma := get_lemma
+ Field_simplify_eq_in_correct Field_simplify_eq_pow_in_correct in
+ let rw_lemma := get_lemma
+ Field_rw_correct Field_rw_pow_correct in
+ field_elements set ext fspec pspec sspec dspec rk
+ ltac:(fun afth ext_r morph p_spec s_spec d_spec =>
+ match morph with
+ | _ =>
+ let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in
+ match p_spec with
+ | mkhypo ?pp_spec =>
+ let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in
+ match s_spec with
+ | mkhypo ?ss_spec =>
+ let field_ok3 := constr:(field_ok2 _ ss_spec) in
+ match d_spec with
+ | mkhypo ?dd_spec =>
+ let field_ok := constr:(field_ok3 _ dd_spec) in
+ let mk_lemma lemma :=
+ constr:(lemma _ _ _ _ _ _ _ _ _ _
+ set ext_r inv_m afth
+ _ _ _ _ _ _ _ _ _ morph
+ _ _ _ pp_spec _ ss_spec _ dd_spec) in
+ let field_simpl_eq_ok := mk_lemma simpl_eq_lemma in
+ let field_simpl_ok := mk_lemma rw_lemma in
+ let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in
+ let cond1_ok :=
+ constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in
+ let cond2_ok :=
+ constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in
+ (fun f =>
+ f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in
+ cond1_ok cond2_ok)
+ | _ => fail 4 "field: bad coefficiant division specification"
+ end
+ | _ => fail 3 "field: bad sign specification"
+ end
+ | _ => fail 2 "field: bad power specification"
+ end
+ | _ => fail 1 "field internal error : field_lemmas, please report"
+ end).
diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v
new file mode 100644
index 00000000..9617d409
--- /dev/null
+++ b/plugins/setoid_ring/Field_theory.v
@@ -0,0 +1,1946 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Ring.
+Import Ring_polynom Ring_tac Ring_theory InitialRing Setoid List.
+Require Import ZArith_base.
+(*Require Import Omega.*)
+Set Implicit Arguments.
+
+Section MakeFieldPol.
+
+(* Field elements *)
+ Variable R:Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+ Variable (rdiv : R -> R -> R) (rinv : R -> R).
+ Variable req : R -> R -> Prop.
+
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "x / y" := (rdiv x y).
+ Notation "- x" := (ropp x). Notation "/ x" := (rinv x).
+ Notation "x == y" := (req x y) (at level 70, no associativity).
+
+ (* Equality properties *)
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable SRinv_ext : forall p q, p == q -> / p == / q.
+
+ (* Field properties *)
+ Record almost_field_theory : Prop := mk_afield {
+ AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req;
+ AF_1_neq_0 : ~ 1 == 0;
+ AFdiv_def : forall p q, p / q == p * / q;
+ AFinv_l : forall p, ~ p == 0 -> / p * p == 1
+ }.
+
+Section AlmostField.
+
+ Variable AFth : almost_field_theory.
+ Let ARth := AFth.(AF_AR).
+ Let rI_neq_rO := AFth.(AF_1_neq_0).
+ Let rdiv_def := AFth.(AFdiv_def).
+ Let rinv_l := AFth.(AFinv_l).
+
+ (* Coefficients *)
+ Variable C: Type.
+ Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool.
+ Variable phi : C -> R.
+
+ Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+ cO cI cadd cmul csub copp ceqb phi.
+
+Lemma ceqb_rect : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
+ (phi c1 == phi c2 -> P x) -> P y -> P (if ceqb c1 c2 then x else y).
+Proof.
+intros.
+generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
+case (ceqb c1 c2); auto.
+Qed.
+
+
+ (* C notations *)
+ Notation "x +! y" := (cadd x y) (at level 50).
+ Notation "x *! y " := (cmul x y) (at level 40).
+ Notation "x -! y " := (csub x y) (at level 50).
+ Notation "-! x" := (copp x) (at level 35).
+ Notation " x ?=! y" := (ceqb x y) (at level 70, no associativity).
+ Notation "[ x ]" := (phi x) (at level 0).
+
+
+ (* Useful tactics *)
+ Add Setoid R req Rsth as R_set1.
+ Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed.
+ Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed.
+
+Let eq_trans := Setoid.Seq_trans _ _ Rsth.
+Let eq_sym := Setoid.Seq_sym _ _ Rsth.
+Let eq_refl := Setoid.Seq_refl _ _ Rsth.
+
+Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) .
+Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe)
+ (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext.
+Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth)
+ (ARmul_1_l ARth) (ARmul_0_l ARth)
+ (ARmul_comm ARth) (ARmul_assoc ARth) (ARdistr_l ARth)
+ (ARopp_mul_l ARth) (ARopp_add ARth)
+ (ARsub_def ARth) .
+
+ (* Power coefficients *)
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R.
+ Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+ (* sign function *)
+ Variable get_sign : C -> option C.
+ Variable get_sign_spec : sign_theory copp ceqb get_sign.
+
+ Variable cdiv:C -> C -> C*C.
+ Variable cdiv_th : div_theory req cadd cmul phi cdiv.
+
+Notation NPEeval := (PEeval rO radd rmul rsub ropp phi Cp_phi rpow).
+Notation Nnorm:= (norm_subst cO cI cadd cmul csub copp ceqb cdiv).
+
+Notation NPphi_dev := (Pphi_dev rO rI radd rmul rsub ropp cO cI ceqb phi get_sign).
+Notation NPphi_pow := (Pphi_pow rO rI radd rmul rsub ropp cO cI ceqb phi Cp_phi rpow get_sign).
+
+(* add abstract semi-ring to help with some proofs *)
+Add Ring Rring : (ARth_SRth ARth).
+
+
+(* additional ring properties *)
+
+Lemma rsub_0_l : forall r, 0 - r == - r.
+intros; rewrite (ARsub_def ARth) in |- *;ring.
+Qed.
+
+Lemma rsub_0_r : forall r, r - 0 == r.
+intros; rewrite (ARsub_def ARth) in |- *.
+rewrite (ARopp_zero Rsth Reqe ARth) in |- *; ring.
+Qed.
+
+(***************************************************************************
+
+ Properties of division
+
+ ***************************************************************************)
+
+Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p.
+intros p q H.
+rewrite rdiv_def in |- *.
+transitivity (/ q * q * p); [ ring | idtac ].
+rewrite rinv_l in |- *; auto.
+Qed.
+Hint Resolve rdiv_simpl .
+
+Theorem SRdiv_ext:
+ forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 -> p1 / q1 == p2 / q2.
+intros p1 p2 H q1 q2 H0.
+transitivity (p1 * / q1); auto.
+transitivity (p2 * / q2); auto.
+Qed.
+Hint Resolve SRdiv_ext .
+
+ Add Morphism rdiv : rdiv_ext. exact SRdiv_ext. Qed.
+
+Lemma rmul_reg_l : forall p q1 q2,
+ ~ p == 0 -> p * q1 == p * q2 -> q1 == q2.
+intros.
+rewrite <- (@rdiv_simpl q1 p) in |- *; trivial.
+rewrite <- (@rdiv_simpl q2 p) in |- *; trivial.
+repeat rewrite rdiv_def in |- *.
+repeat rewrite (ARmul_assoc ARth) in |- *.
+auto.
+Qed.
+
+Theorem field_is_integral_domain : forall r1 r2,
+ ~ r1 == 0 -> ~ r2 == 0 -> ~ r1 * r2 == 0.
+Proof.
+red in |- *; intros.
+apply H0.
+transitivity (1 * r2); auto.
+transitivity (/ r1 * r1 * r2); auto.
+rewrite <- (ARmul_assoc ARth) in |- *.
+rewrite H1 in |- *.
+apply ARmul_0_r with (1 := Rsth) (2 := ARth).
+Qed.
+
+Theorem ropp_neq_0 : forall r,
+ ~ -(1) == 0 -> ~ r == 0 -> ~ -r == 0.
+intros.
+setoid_replace (- r) with (- (1) * r).
+ apply field_is_integral_domain; trivial.
+ rewrite <- (ARopp_mul_l ARth) in |- *.
+ rewrite (ARmul_1_l ARth) in |- *.
+ reflexivity.
+Qed.
+
+Theorem rdiv_r_r : forall r, ~ r == 0 -> r / r == 1.
+intros.
+rewrite (AFdiv_def AFth) in |- *.
+rewrite (ARmul_comm ARth) in |- *.
+apply (AFinv_l AFth).
+trivial.
+Qed.
+
+Theorem rdiv1: forall r, r == r / 1.
+intros r; transitivity (1 * (r / 1)); auto.
+Qed.
+
+Theorem rdiv2:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r4 == 0 ->
+ r1 / r2 + r3 / r4 == (r1 * r4 + r3 * r2) / (r2 * r4).
+Proof.
+intros r1 r2 r3 r4 H H0.
+assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
+apply rmul_reg_l with (r2 * r4); trivial.
+rewrite rdiv_simpl in |- *; trivial.
+rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
+apply (Radd_ext Reqe).
+ transitivity (r2 * (r1 / r2) * r4); [ ring | auto ].
+ transitivity (r2 * (r4 * (r3 / r4))); auto.
+ transitivity (r2 * r3); auto.
+Qed.
+
+
+Theorem rdiv2b:
+ forall r1 r2 r3 r4 r5,
+ ~ (r2*r5) == 0 ->
+ ~ (r4*r5) == 0 ->
+ r1 / (r2*r5) + r3 / (r4*r5) == (r1 * r4 + r3 * r2) / (r2 * (r4 * r5)).
+Proof.
+intros r1 r2 r3 r4 r5 H H0.
+assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring).
+assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring).
+assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring).
+assert (HH4: ~ r2 * (r4 * r5) == 0)
+ by complete (repeat apply field_is_integral_domain; trivial).
+apply rmul_reg_l with (r2 * (r4 * r5)); trivial.
+rewrite rdiv_simpl in |- *; trivial.
+rewrite (ARdistr_r Rsth Reqe ARth) in |- *.
+apply (Radd_ext Reqe).
+ transitivity ((r2 * r5) * (r1 / (r2 * r5)) * r4); [ ring | auto ].
+ transitivity ((r4 * r5) * (r3 / (r4 * r5)) * r2); [ ring | auto ].
+Qed.
+
+Theorem rdiv5: forall r1 r2, - (r1 / r2) == - r1 / r2.
+intros r1 r2.
+transitivity (- (r1 * / r2)); auto.
+transitivity (- r1 * / r2); auto.
+Qed.
+Hint Resolve rdiv5 .
+
+Theorem rdiv3:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r4 == 0 ->
+ r1 / r2 - r3 / r4 == (r1 * r4 - r3 * r2) / (r2 * r4).
+intros r1 r2 r3 r4 H H0.
+assert (~ r2 * r4 == 0) by (apply field_is_integral_domain; trivial).
+transitivity (r1 / r2 + - (r3 / r4)); auto.
+transitivity (r1 / r2 + - r3 / r4); auto.
+transitivity ((r1 * r4 + - r3 * r2) / (r2 * r4)); auto.
+apply rdiv2; auto.
+apply SRdiv_ext; auto.
+transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
+Qed.
+
+
+Theorem rdiv3b:
+ forall r1 r2 r3 r4 r5,
+ ~ (r2 * r5) == 0 ->
+ ~ (r4 * r5) == 0 ->
+ r1 / (r2*r5) - r3 / (r4*r5) == (r1 * r4 - r3 * r2) / (r2 * (r4 * r5)).
+Proof.
+intros r1 r2 r3 r4 r5 H H0.
+transitivity (r1 / (r2 * r5) + - (r3 / (r4 * r5))); auto.
+transitivity (r1 / (r2 * r5) + - r3 / (r4 * r5)); auto.
+transitivity ((r1 * r4 + - r3 * r2) / (r2 * (r4 * r5))).
+apply rdiv2b; auto; try ring.
+apply (SRdiv_ext); auto.
+transitivity (r1 * r4 + - (r3 * r2)); symmetry; auto.
+Qed.
+
+Theorem rdiv6:
+ forall r1 r2,
+ ~ r1 == 0 -> ~ r2 == 0 -> / (r1 / r2) == r2 / r1.
+intros r1 r2 H H0.
+assert (~ r1 / r2 == 0) as Hk.
+ intros H1; case H.
+ transitivity (r2 * (r1 / r2)); auto.
+ rewrite H1 in |- *; ring.
+ apply rmul_reg_l with (r1 / r2); auto.
+ transitivity (/ (r1 / r2) * (r1 / r2)); auto.
+ transitivity 1; auto.
+ repeat rewrite rdiv_def in |- *.
+ transitivity (/ r1 * r1 * (/ r2 * r2)); [ idtac | ring ].
+ repeat rewrite rinv_l in |- *; auto.
+Qed.
+Hint Resolve rdiv6 .
+
+ Theorem rdiv4:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r4 == 0 ->
+ (r1 / r2) * (r3 / r4) == (r1 * r3) / (r2 * r4).
+Proof.
+intros r1 r2 r3 r4 H H0.
+assert (~ r2 * r4 == 0) by complete (apply field_is_integral_domain; trivial).
+apply rmul_reg_l with (r2 * r4); trivial.
+rewrite rdiv_simpl in |- *; trivial.
+transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ].
+repeat rewrite rdiv_simpl in |- *; trivial.
+Qed.
+
+ Theorem rdiv4b:
+ forall r1 r2 r3 r4 r5 r6,
+ ~ r2 * r5 == 0 ->
+ ~ r4 * r6 == 0 ->
+ ((r1 * r6) / (r2 * r5)) * ((r3 * r5) / (r4 * r6)) == (r1 * r3) / (r2 * r4).
+Proof.
+intros r1 r2 r3 r4 r5 r6 H H0.
+rewrite rdiv4; auto.
+transitivity ((r5 * r6) * (r1 * r3) / ((r5 * r6) * (r2 * r4))).
+apply SRdiv_ext; ring.
+assert (HH: ~ r5*r6 == 0).
+ apply field_is_integral_domain.
+ intros H1; case H; rewrite H1; ring.
+ intros H1; case H0; rewrite H1; ring.
+rewrite <- rdiv4 ; auto.
+ rewrite rdiv_r_r; auto.
+
+ apply field_is_integral_domain.
+ intros H1; case H; rewrite H1; ring.
+ intros H1; case H0; rewrite H1; ring.
+Qed.
+
+
+Theorem rdiv7:
+ forall r1 r2 r3 r4,
+ ~ r2 == 0 ->
+ ~ r3 == 0 ->
+ ~ r4 == 0 ->
+ (r1 / r2) / (r3 / r4) == (r1 * r4) / (r2 * r3).
+Proof.
+intros.
+rewrite (rdiv_def (r1 / r2)) in |- *.
+rewrite rdiv6 in |- *; trivial.
+apply rdiv4; trivial.
+Qed.
+
+Theorem rdiv7b:
+ forall r1 r2 r3 r4 r5 r6,
+ ~ r2 * r6 == 0 ->
+ ~ r3 * r5 == 0 ->
+ ~ r4 * r6 == 0 ->
+ ((r1 * r5) / (r2 * r6)) / ((r3 * r5) / (r4 * r6)) == (r1 * r4) / (r2 * r3).
+Proof.
+intros.
+rewrite rdiv7; auto.
+transitivity ((r5 * r6) * (r1 * r4) / ((r5 * r6) * (r2 * r3))).
+apply SRdiv_ext; ring.
+assert (HH: ~ r5*r6 == 0).
+ apply field_is_integral_domain.
+ intros H2; case H0; rewrite H2; ring.
+ intros H2; case H1; rewrite H2; ring.
+rewrite <- rdiv4 ; auto.
+rewrite rdiv_r_r; auto.
+ apply field_is_integral_domain.
+ intros H2; case H; rewrite H2; ring.
+ intros H2; case H0; rewrite H2; ring.
+Qed.
+
+
+Theorem rdiv8: forall r1 r2, ~ r2 == 0 -> r1 == 0 -> r1 / r2 == 0.
+intros r1 r2 H H0.
+transitivity (r1 * / r2); auto.
+transitivity (0 * / r2); auto.
+Qed.
+
+
+Theorem cross_product_eq : forall r1 r2 r3 r4,
+ ~ r2 == 0 -> ~ r4 == 0 -> r1 * r4 == r3 * r2 -> r1 / r2 == r3 / r4.
+intros.
+transitivity (r1 / r2 * (r4 / r4)).
+ rewrite rdiv_r_r in |- *; trivial.
+ symmetry in |- *.
+ apply (ARmul_1_r Rsth ARth).
+ rewrite rdiv4 in |- *; trivial.
+ rewrite H1 in |- *.
+ rewrite (ARmul_comm ARth r2 r4) in |- *.
+ rewrite <- rdiv4 in |- *; trivial.
+ rewrite rdiv_r_r in |- * by trivial.
+ apply (ARmul_1_r Rsth ARth).
+Qed.
+
+(***************************************************************************
+
+ Some equality test
+
+ ***************************************************************************)
+
+Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool :=
+ match p1, p2 with
+ xH, xH => true
+ | xO p3, xO p4 => positive_eq p3 p4
+ | xI p3, xI p4 => positive_eq p3 p4
+ | _, _ => false
+ end.
+
+Theorem positive_eq_correct:
+ forall p1 p2, if positive_eq p1 p2 then p1 = p2 else p1 <> p2.
+intros p1; elim p1;
+ (try (intros p2; case p2; simpl; auto; intros; discriminate)).
+intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
+generalize (rec p4); case (positive_eq p3 p4); auto.
+intros H1; apply f_equal with ( f := xI ); auto.
+intros H1 H2; case H1; injection H2; auto.
+intros p3 rec p2; case p2; simpl; auto; (try (intros; discriminate)); intros p4.
+generalize (rec p4); case (positive_eq p3 p4); auto.
+intros H1; apply f_equal with ( f := xO ); auto.
+intros H1 H2; case H1; injection H2; auto.
+Qed.
+
+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
+ | 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
+ | _, _ => false
+ end.
+
+Add Morphism (pow_pos rmul) with signature req ==> eq ==> req as pow_morph.
+intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH].
+Qed.
+
+Add Morphism (pow_N rI rmul) with signature req ==> eq ==> req as pow_N_morph.
+intros x y H [|p];simpl;auto. apply pow_morph;trivial.
+Qed.
+(*
+Lemma rpow_morph : forall x y n, x == y ->rpow x (Cp_phi n) == rpow y (Cp_phi n).
+Proof.
+ intros; repeat rewrite pow_th.(rpow_pow_N).
+ destruct n;simpl. apply eq_refl.
+ induction p;simpl;try rewrite IHp;try rewrite H; apply eq_refl.
+Qed.
+*)
+Theorem PExpr_eq_semi_correct:
+ forall l e1 e2, PExpr_eq e1 e2 = true -> NPEeval l e1 == NPEeval l e2.
+intros l e1; elim e1.
+intros c1; intros e2; elim e2; simpl; (try (intros; discriminate)).
+intros c2; apply (morph_eq CRmorph).
+intros p1; intros e2; elim e2; simpl; (try (intros; discriminate)).
+intros p2; generalize (positive_eq_correct p1 p2); case (positive_eq p1 p2);
+ (try (intros; discriminate)); intros H; rewrite H; auto.
+intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
+intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
+ (try (intros; discriminate)); auto.
+intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
+intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
+ (try (intros; discriminate)); auto.
+intros e3 rec1 e5 rec2 e2; case e2; simpl; (try (intros; discriminate)).
+intros e4 e6; generalize (rec1 e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); generalize (rec2 e6); case (PExpr_eq e5 e6);
+ (try (intros; discriminate)); auto.
+intros e3 rec e2; (case e2; simpl; (try (intros; discriminate))).
+intros e4; generalize (rec e4); case (PExpr_eq e3 e4);
+ (try (intros; discriminate)); auto.
+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.
+Qed.
+
+(* add *)
+Definition NPEadd e1 e2 :=
+ match e1, e2 with
+ PEc c1, PEc c2 => PEc (cadd c1 c2)
+ | PEc c, _ => if ceqb c cO then e2 else PEadd e1 e2
+ | _, PEc c => if ceqb c cO then e1 else PEadd e1 e2
+ (* Peut t'on factoriser ici ??? *)
+ | _, _ => PEadd e1 e2
+ end.
+
+Theorem NPEadd_correct:
+ forall l e1 e2, NPEeval l (NPEadd e1 e2) == NPEeval l (PEadd e1 e2).
+Proof.
+intros l e1 e2.
+destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;try apply eq_refl;
+ try (ring [(morph0 CRmorph)]).
+ apply (morph_add CRmorph).
+Qed.
+
+Definition NPEpow x n :=
+ match n with
+ | N0 => PEc cI
+ | Npos p =>
+ if positive_eq 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)
+ | _ => PEpow x n
+ end
+ end.
+
+Theorem NPEpow_correct : forall l e n,
+ NPEeval l (NPEpow e n) == NPEeval l (PEpow 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.
+ 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)].
+ induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp].
+Qed.
+
+(* mul *)
+Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C :=
+ match x, y with
+ PEc c1, PEc c2 => PEc (cmul c1 c2)
+ | PEc c, _ =>
+ if ceqb c cI then y else if ceqb c cO then PEc cO else PEmul x y
+ | _, PEc c =>
+ if ceqb c cI then x else if ceqb c cO then PEc cO else PEmul x y
+ | PEpow e1 n1, PEpow e2 n2 =>
+ if N_eq n1 n2 then NPEpow (NPEmul e1 e2) n1 else PEmul x y
+ | _, _ => PEmul x y
+ end.
+
+Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p.
+induction p;simpl;auto;try ring [IHp].
+Qed.
+
+Theorem NPEmul_correct : forall l e1 e2,
+ NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2).
+induction e1;destruct e2; simpl in |- *;try reflexivity;
+ repeat apply ceqb_rect;
+ 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).
+rewrite NPEpow_correct. simpl.
+repeat rewrite pow_th.(rpow_pow_N).
+rewrite IHe1;rewrite <- H;destruct n;simpl;try ring.
+apply pow_pos_mul.
+simpl;auto.
+Qed.
+
+(* sub *)
+Definition NPEsub e1 e2 :=
+ match e1, e2 with
+ PEc c1, PEc c2 => PEc (csub c1 c2)
+ | PEc c, _ => if ceqb c cO then PEopp e2 else PEsub e1 e2
+ | _, PEc c => if ceqb c cO then e1 else PEsub e1 e2
+ (* Peut-on factoriser ici *)
+ | _, _ => PEsub e1 e2
+ end.
+
+Theorem NPEsub_correct:
+ forall l e1 e2, NPEeval l (NPEsub e1 e2) == NPEeval l (PEsub e1 e2).
+intros l e1 e2.
+destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect;
+ try (intro eq_c; rewrite eq_c in |- *); simpl in |- *;
+ try rewrite (morph0 CRmorph) in |- *; try reflexivity;
+ try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r).
+apply (morph_sub CRmorph).
+Qed.
+
+(* opp *)
+Definition NPEopp e1 :=
+ match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end.
+
+Theorem NPEopp_correct:
+ forall l e1, NPEeval l (NPEopp e1) == NPEeval l (PEopp e1).
+intros l e1; case e1; simpl; auto.
+intros; apply (morph_opp CRmorph).
+Qed.
+
+(* simplification *)
+Fixpoint PExpr_simp (e : PExpr C) : PExpr C :=
+ match e with
+ PEadd e1 e2 => NPEadd (PExpr_simp e1) (PExpr_simp e2)
+ | PEmul e1 e2 => NPEmul (PExpr_simp e1) (PExpr_simp e2)
+ | PEsub e1 e2 => NPEsub (PExpr_simp e1) (PExpr_simp e2)
+ | PEopp e1 => NPEopp (PExpr_simp e1)
+ | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1
+ | _ => e
+ end.
+
+Theorem PExpr_simp_correct:
+ forall l e, NPEeval l (PExpr_simp e) == NPEeval l e.
+intros l e; elim e; simpl; auto.
+intros e1 He1 e2 He2.
+transitivity (NPEeval l (PEadd (PExpr_simp e1) (PExpr_simp e2))); auto.
+apply NPEadd_correct.
+simpl; auto.
+intros e1 He1 e2 He2.
+transitivity (NPEeval l (PEsub (PExpr_simp e1) (PExpr_simp e2))); auto.
+apply NPEsub_correct.
+simpl; auto.
+intros e1 He1 e2 He2.
+transitivity (NPEeval l (PEmul (PExpr_simp e1) (PExpr_simp e2))); auto.
+apply NPEmul_correct.
+simpl; auto.
+intros e1 He1.
+transitivity (NPEeval l (PEopp (PExpr_simp e1))); auto.
+apply NPEopp_correct.
+simpl; auto.
+intros e1 He1 n;simpl.
+rewrite NPEpow_correct;simpl.
+repeat rewrite pow_th.(rpow_pow_N).
+rewrite He1;auto.
+Qed.
+
+
+(****************************************************************************
+
+ Datastructure
+
+ ***************************************************************************)
+
+(* The input: syntax of a field expression *)
+
+Inductive FExpr : Type :=
+ FEc: C -> FExpr
+ | FEX: positive -> FExpr
+ | FEadd: FExpr -> FExpr -> FExpr
+ | FEsub: FExpr -> FExpr -> FExpr
+ | FEmul: FExpr -> FExpr -> FExpr
+ | FEopp: FExpr -> FExpr
+ | FEinv: FExpr -> FExpr
+ | FEdiv: FExpr -> FExpr -> FExpr
+ | FEpow: FExpr -> N -> FExpr .
+
+Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
+ match pe with
+ | FEc c => phi c
+ | FEX x => BinList.nth 0 x l
+ | FEadd x y => FEeval l x + FEeval l y
+ | FEsub x y => FEeval l x - FEeval l y
+ | FEmul x y => FEeval l x * FEeval l y
+ | FEopp x => - FEeval l x
+ | FEinv x => / FEeval l x
+ | FEdiv x y => FEeval l x / FEeval l y
+ | FEpow x n => rpow (FEeval l x) (Cp_phi n)
+ end.
+
+Strategy expand [FEeval].
+
+(* The result of the normalisation *)
+
+Record linear : Type := mk_linear {
+ num : PExpr C;
+ denum : PExpr C;
+ condition : list (PExpr C) }.
+
+(***************************************************************************
+
+ Semantics and properties of side condition
+
+ ***************************************************************************)
+
+Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop :=
+ match le with
+ | nil => True
+ | e1 :: nil => ~ req (NPEeval l e1) rO
+ | e1 :: l1 => ~ req (NPEeval l e1) rO /\ PCond l l1
+ end.
+
+Theorem PCond_cons_inv_l :
+ forall l a l1, PCond l (a::l1) -> ~ NPEeval l a == 0.
+intros l a l1 H.
+destruct l1; simpl in H |- *; trivial.
+destruct H; trivial.
+Qed.
+
+Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) -> PCond l l1.
+intros l a l1 H.
+destruct l1; simpl in H |- *; trivial.
+destruct H; trivial.
+Qed.
+
+Theorem PCond_app_inv_l: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l1.
+intros l l1 l2; elim l1; simpl app in |- *.
+ simpl in |- *; auto.
+ destruct l0; simpl in *.
+ destruct l2; firstorder.
+ firstorder.
+Qed.
+
+Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l2.
+intros l l1 l2; elim l1; simpl app; auto.
+intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ).
+Qed.
+
+(* An unsatisfiable condition: issued when a division by zero is detected *)
+Definition absurd_PCond := cons (PEc cO) nil.
+
+Lemma absurd_PCond_bottom : forall l, ~ PCond l absurd_PCond.
+unfold absurd_PCond in |- *; simpl in |- *.
+red in |- *; intros.
+apply H.
+apply (morph0 CRmorph).
+Qed.
+
+(***************************************************************************
+
+ Normalisation
+
+ ***************************************************************************)
+
+Fixpoint isIn (e1:PExpr C) (p1:positive)
+ (e2:PExpr C) (p2:positive) {struct e2}: option (N * PExpr C) :=
+ match e2 with
+ | PEmul e3 e4 =>
+ match isIn e1 p1 e3 p2 with
+ | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2)))
+ | Some (Npos p, e5) =>
+ match isIn e1 p e4 p2 with
+ | Some (n, e6) => Some (n, NPEmul e5 e6)
+ | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2)))
+ end
+ | None =>
+ match isIn e1 p1 e4 p2 with
+ | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5)
+ | None => None
+ end
+ end
+ | PEpow e3 N0 => None
+ | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2)
+ | _ =>
+ if PExpr_eq e1 e2 then
+ match Zminus (Zpos p1) (Zpos p2) with
+ | Zpos p => Some (Npos p, PEc cI)
+ | Z0 => Some (N0, PEc cI)
+ | Zneg p => Some (N0, NPEpow e2 (Npos p))
+ end
+ else None
+ end.
+
+ Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end.
+ Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end.
+
+ Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext)
+ ARth.(ARmul_comm) ARth.(ARmul_assoc)).
+
+ Lemma isIn_correct_aux : forall l e1 e2 p1 p2,
+ match
+ (if PExpr_eq e1 e2 then
+ match Zminus (Zpos p1) (Zpos p2) with
+ | Zpos p => Some (Npos p, PEc cI)
+ | Z0 => Some (N0, PEc cI)
+ | Zneg p => Some (N0, NPEpow e2 (Npos p))
+ end
+ else None)
+ with
+ | Some(n, e3) =>
+ NPEeval l (PEpow e2 (Npos p2)) ==
+ NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
+ (Zpos p1 > NtoZ n)%Z
+ | _ => True
+ end.
+Proof.
+ intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2);
+ case (PExpr_eq e1 e2); simpl; auto; intros H.
+ case_eq ((p1 ?= p2)%positive Eq);intros;simpl.
+ repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _).
+ rewrite (Pcompare_Eq_eq _ _ H0).
+ rewrite H by trivial. ring [ (morph1 CRmorph)].
+ fold (NPEpow e2 (Npos (p2 - p1))).
+ rewrite NPEpow_correct;simpl.
+ repeat rewrite pow_th.(rpow_pow_N);simpl.
+ rewrite H;trivial. split. 2:refine (refl_equal _).
+ rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial.
+ repeat rewrite pow_th.(rpow_pow_N);simpl.
+ rewrite H;trivial.
+ change (ZtoN
+ match (p1 ?= p1 - p2)%positive Eq with
+ | Eq => 0
+ | Lt => Zneg (p1 - p2 - p1)
+ | Gt => Zpos (p1 - (p1 - p2))
+ end) with (ZtoN (Zpos p1 - Zpos (p1 -p2))).
+ replace (Zpos (p1 - p2)) with (Zpos p1 - Zpos p2)%Z.
+ split.
+ repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth).
+ rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl.
+ ring [ (morph1 CRmorph)].
+ assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _).
+ apply Zplus_gt_reg_l with (Zpos p2).
+ rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z.
+ apply Zplus_gt_compat_r. refine (refl_equal _).
+ simpl;rewrite H0;trivial.
+Qed.
+
+Lemma pow_pos_pow_pos : forall x p1 p2, pow_pos rmul (pow_pos rmul x p1) p2 == pow_pos rmul x (p1*p2).
+induction p1;simpl;intros;repeat rewrite pow_pos_mul;repeat rewrite pow_pos_plus;simpl.
+ring [(IHp1 p2)]. ring [(IHp1 p2)]. auto.
+Qed.
+
+
+Theorem isIn_correct: forall l e1 p1 e2 p2,
+ match isIn e1 p1 e2 p2 with
+ | Some(n, e3) =>
+ NPEeval l (PEpow e2 (Npos p2)) ==
+ NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\
+ (Zpos p1 > NtoZ n)%Z
+ | _ => True
+ end.
+Proof.
+Opaque NPEpow.
+intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros;
+ try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn.
+generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3.
+destruct n.
+ simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl.
+ repeat rewrite pow_th.(rpow_pow_N);simpl.
+ rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial].
+ generalize (H0 p4 p2);clear H0;destruct (isIn e1 p4 p0 p2). destruct p5.
+ 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.
+ rewrite pow_pos_mul. rewrite H1;rewrite H3.
+ assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
+ (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) ==
+ pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) *
+ NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H.
+ rewrite <- pow_pos_plus. rewrite Pplus_minus.
+ split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial.
+ 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.
+ 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.
+ split. 2:exact H.
+ rewrite pow_pos_mul. simpl;rewrite H1;rewrite H3.
+ assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *
+ (pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p5) ==
+ pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) *
+ NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0.
+ rewrite <- pow_pos_plus.
+ replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive.
+ rewrite NPEmul_correct. simpl;ring.
+ assert
+ (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z.
+ change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z).
+ rewrite <- Zplus_assoc. rewrite (Zplus_assoc (- Zpos p4)).
+ simpl. rewrite Pcompare_refl. simpl. reflexivity.
+ unfold Zminus, Zopp in H0. simpl in H0.
+ rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial.
+ 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.
+ 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.
+ generalize (H0 p1 p2);clear H0;destruct (isIn e1 p1 p0 p2). destruct p3.
+ destruct n;simpl. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl.
+ repeat rewrite pow_th.(rpow_pow_N);simpl.
+ intros (H1,H2);split;trivial. rewrite pow_pos_mul;ring [H1].
+ 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.
+ trivial.
+ destruct n. trivial.
+ generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3.
+ destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl.
+ intros (H1,H2);split. rewrite pow_pos_pow_pos. trivial. trivial.
+ repeat rewrite pow_th.(rpow_pow_N). simpl.
+ intros (H1,H2);split;trivial.
+ rewrite pow_pos_pow_pos;trivial.
+ trivial.
+Qed.
+
+Record rsplit : Type := mk_rsplit {
+ rsplit_left : PExpr C;
+ rsplit_common : PExpr C;
+ rsplit_right : PExpr C}.
+
+(* Stupid name clash *)
+Notation left := rsplit_left.
+Notation right := rsplit_right.
+Notation common := rsplit_common.
+
+Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit :=
+ match e1 with
+ | PEmul e3 e4 =>
+ let r1 := split_aux e3 p e2 in
+ let r2 := split_aux e4 p (right r1) in
+ mk_rsplit (NPEmul (left r1) (left r2))
+ (NPEmul (common r1) (common r2))
+ (right r2)
+ | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2
+ | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2
+ | _ =>
+ match isIn e1 p e2 xH with
+ | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3
+ | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
+ | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2
+ end
+ end.
+
+Lemma split_aux_correct_1 : forall l e1 p e2,
+ let res := match isIn e1 p e2 xH with
+ | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3
+ | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3
+ | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2
+ end in
+ NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left res) (common res))
+ /\
+ NPEeval l e2 == NPEeval l (NPEmul (right res) (common res)).
+Proof.
+ intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH).
+ destruct (isIn e1 p e2 1). destruct p0.
+ Opaque NPEpow NPEmul.
+ destruct n;simpl;
+ (repeat rewrite NPEmul_correct;simpl;
+ repeat rewrite NPEpow_correct;simpl;
+ repeat rewrite pow_th.(rpow_pow_N);simpl).
+ intros (H, Hgt);split;try ring [H CRmorph.(morph1)].
+ intros (H, Hgt). unfold Zgt in Hgt;simpl in Hgt;rewrite Hgt in H.
+ simpl in H;split;try ring [H].
+ rewrite <- pow_pos_plus. rewrite Pplus_minus. reflexivity. trivial.
+ simpl;intros. repeat rewrite NPEmul_correct;simpl.
+ rewrite NPEpow_correct;simpl. split;ring [CRmorph.(morph1)].
+Qed.
+
+Theorem split_aux_correct: forall l e1 p e2,
+ NPEeval l (PEpow e1 (Npos p)) ==
+ NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2)))
+/\
+ NPEeval l e2 == NPEeval l (NPEmul (right (split_aux e1 p e2))
+ (common (split_aux e1 p e2))).
+Proof.
+intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl.
+generalize (IHe1_1 k e2); clear IHe1_1.
+generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2.
+simpl. repeat (rewrite NPEmul_correct;simpl).
+repeat rewrite pow_th.(rpow_pow_N);simpl.
+intros (H1,H2) (H3,H4);split.
+rewrite pow_pos_mul. rewrite H1;rewrite H3. ring.
+rewrite H4;rewrite H2;ring.
+destruct n;simpl.
+split. repeat rewrite pow_th.(rpow_pow_N);simpl.
+rewrite NPEmul_correct. simpl.
+ induction k;simpl;try ring [CRmorph.(morph1)]; ring [IHk CRmorph.(morph1)].
+ rewrite NPEmul_correct;simpl. ring [CRmorph.(morph1)].
+generalize (IHe1 (p*k)%positive e2);clear IHe1;simpl.
+repeat rewrite NPEmul_correct;simpl.
+repeat rewrite pow_th.(rpow_pow_N);simpl.
+rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2].
+Qed.
+
+Definition split e1 e2 := split_aux e1 xH e2.
+
+Theorem split_correct_l: forall l e1 e2,
+ NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2))
+ (common (split e1 e2))).
+Proof.
+intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl.
+rewrite pow_th.(rpow_pow_N);simpl;auto.
+Qed.
+
+Theorem split_correct_r: forall l e1 e2,
+ NPEeval l e2 == NPEeval l (NPEmul (right (split e1 e2))
+ (common (split e1 e2))).
+Proof.
+intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto.
+Qed.
+
+Fixpoint Fnorm (e : FExpr) : linear :=
+ match e with
+ | FEc c => mk_linear (PEc c) (PEc cI) nil
+ | FEX x => mk_linear (PEX C x) (PEc cI) nil
+ | FEadd e1 e2 =>
+ let x := Fnorm e1 in
+ let y := Fnorm e2 in
+ let s := split (denum x) (denum y) in
+ mk_linear
+ (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
+ (NPEmul (left s) (NPEmul (right s) (common s)))
+ (condition x ++ condition y)
+
+ | FEsub e1 e2 =>
+ let x := Fnorm e1 in
+ let y := Fnorm e2 in
+ let s := split (denum x) (denum y) in
+ mk_linear
+ (NPEsub (NPEmul (num x) (right s)) (NPEmul (num y) (left s)))
+ (NPEmul (left s) (NPEmul (right s) (common s)))
+ (condition x ++ condition y)
+ | FEmul e1 e2 =>
+ let x := Fnorm e1 in
+ let y := Fnorm e2 in
+ let s1 := split (num x) (denum y) in
+ let s2 := split (num y) (denum x) in
+ mk_linear (NPEmul (left s1) (left s2))
+ (NPEmul (right s2) (right s1))
+ (condition x ++ condition y)
+ | FEopp e1 =>
+ let x := Fnorm e1 in
+ mk_linear (NPEopp (num x)) (denum x) (condition x)
+ | FEinv e1 =>
+ let x := Fnorm e1 in
+ mk_linear (denum x) (num x) (num x :: condition x)
+ | FEdiv e1 e2 =>
+ let x := Fnorm e1 in
+ let y := Fnorm e2 in
+ let s1 := split (num x) (num y) in
+ let s2 := split (denum x) (denum y) in
+ mk_linear (NPEmul (left s1) (right s2))
+ (NPEmul (left s2) (right s1))
+ (num y :: condition x ++ condition y)
+ | FEpow e1 n =>
+ let x := Fnorm e1 in
+ mk_linear (NPEpow (num x) n) (NPEpow (denum x) n) (condition x)
+ end.
+
+
+(* Example *)
+(*
+Eval compute
+ in (Fnorm
+ (FEdiv
+ (FEc cI)
+ (FEadd (FEinv (FEX xH%positive)) (FEinv (FEX (xO xH)%positive))))).
+*)
+
+ Lemma pow_pos_not_0 : forall x, ~x==0 -> forall p, ~pow_pos rmul x p == 0.
+Proof.
+ induction p;simpl.
+ intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H).
+ apply IHp.
+ rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp).
+ reflexivity.
+ rewrite H1. ring. rewrite Hp;ring.
+ intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp).
+ reflexivity. rewrite Hp;ring. trivial.
+Qed.
+
+Theorem Pcond_Fnorm:
+ forall l e,
+ PCond l (condition (Fnorm e)) -> ~ NPEeval l (denum (Fnorm e)) == 0.
+intros l e; elim e.
+ simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
+ simpl in |- *; intros _ _; rewrite (morph1 CRmorph) in |- *; exact rI_neq_rO.
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+ simpl condition in Hcond.
+ simpl denum in |- *.
+ rewrite NPEmul_correct in |- *.
+ simpl in |- *.
+ apply field_is_integral_domain.
+ intros HH; case Hrec1; auto.
+ apply PCond_app_inv_l with (1 := Hcond).
+ rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
+ rewrite NPEmul_correct; simpl; rewrite HH; ring.
+ intros HH; case Hrec2; auto.
+ apply PCond_app_inv_r with (1 := Hcond).
+ rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+ simpl condition in Hcond.
+ simpl denum in |- *.
+ rewrite NPEmul_correct in |- *.
+ simpl in |- *.
+ apply field_is_integral_domain.
+ intros HH; case Hrec1; auto.
+ apply PCond_app_inv_l with (1 := Hcond).
+ rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
+ rewrite NPEmul_correct; simpl; rewrite HH; ring.
+ intros HH; case Hrec2; auto.
+ apply PCond_app_inv_r with (1 := Hcond).
+ rewrite (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))); auto.
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+ simpl condition in Hcond.
+ simpl denum in |- *.
+ rewrite NPEmul_correct in |- *.
+ simpl in |- *.
+ apply field_is_integral_domain.
+ intros HH; apply Hrec1.
+ apply PCond_app_inv_l with (1 := Hcond).
+ rewrite (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))).
+ rewrite NPEmul_correct; simpl; rewrite HH; ring.
+ intros HH; apply Hrec2.
+ apply PCond_app_inv_r with (1 := Hcond).
+ rewrite (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2))).
+ rewrite NPEmul_correct; simpl; rewrite HH; ring.
+ intros e1 Hrec1 Hcond.
+ simpl condition in Hcond.
+ simpl denum in |- *.
+ auto.
+ intros e1 Hrec1 Hcond.
+ simpl condition in Hcond.
+ simpl denum in |- *.
+ apply PCond_cons_inv_l with (1:=Hcond).
+ intros e1 Hrec1 e2 Hrec2 Hcond.
+ simpl condition in Hcond.
+ simpl denum in |- *.
+ rewrite NPEmul_correct in |- *.
+ simpl in |- *.
+ apply field_is_integral_domain.
+ intros HH; apply Hrec1.
+ specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1.
+ apply PCond_app_inv_l with (1 := Hcond1).
+ rewrite (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2))).
+ rewrite NPEmul_correct; simpl; rewrite HH; ring.
+ intros HH; apply PCond_cons_inv_l with (1:=Hcond).
+ rewrite (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2))).
+ rewrite NPEmul_correct; simpl; rewrite HH; ring.
+ simpl;intros e1 Hrec1 n Hcond.
+ rewrite NPEpow_correct.
+ simpl;rewrite pow_th.(rpow_pow_N).
+ destruct n;simpl;intros.
+ apply AFth.(AF_1_neq_0). apply pow_pos_not_0;auto.
+Qed.
+Hint Resolve Pcond_Fnorm.
+
+
+(***************************************************************************
+
+ Main theorem
+
+ ***************************************************************************)
+
+Theorem Fnorm_FEeval_PEeval:
+ forall l fe,
+ PCond l (condition (Fnorm fe)) ->
+ FEeval l fe == NPEeval l (num (Fnorm fe)) / NPEeval l (denum (Fnorm fe)).
+Proof.
+intros l fe; elim fe; simpl.
+intros c H; rewrite CRmorph.(morph1); apply rdiv1.
+intros p H; rewrite CRmorph.(morph1); apply rdiv1.
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+rewrite NPEadd_correct; simpl.
+repeat rewrite NPEmul_correct; simpl.
+generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
+ (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2; rewrite U1; rewrite U2.
+apply rdiv2b; auto.
+ rewrite <- U1; auto.
+ rewrite <- U2; auto.
+
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+rewrite NPEsub_correct; simpl.
+repeat rewrite NPEmul_correct; simpl.
+generalize (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
+ (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2; rewrite U1; rewrite U2.
+apply rdiv3b; auto.
+ rewrite <- U1; auto.
+ rewrite <- U2; auto.
+
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+repeat rewrite NPEmul_correct; simpl.
+generalize (split_correct_l l (num (Fnorm e1)) (denum (Fnorm e2)))
+ (split_correct_r l (num (Fnorm e1)) (denum (Fnorm e2)))
+ (split_correct_l l (num (Fnorm e2)) (denum (Fnorm e1)))
+ (split_correct_r l (num (Fnorm e2)) (denum (Fnorm e1))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3;
+ rewrite U4; simpl.
+apply rdiv4b; auto.
+ rewrite <- U4; auto.
+ rewrite <- U2; auto.
+
+intros e1 He1 HH.
+rewrite NPEopp_correct; simpl; rewrite (He1 HH); apply rdiv5; auto.
+
+intros e1 He1 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_cons_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); apply rdiv6; auto.
+apply PCond_cons_inv_l with ( 1 := HH ).
+
+intros e1 He1 e2 He2 HH.
+assert (HH1: PCond l (condition (Fnorm e1))).
+apply PCond_app_inv_l with (condition (Fnorm e2)).
+apply PCond_cons_inv_r with ( 1 := HH ).
+assert (HH2: PCond l (condition (Fnorm e2))).
+apply PCond_app_inv_r with (condition (Fnorm e1)).
+apply PCond_cons_inv_r with ( 1 := HH ).
+rewrite (He1 HH1); rewrite (He2 HH2).
+repeat rewrite NPEmul_correct;simpl.
+generalize (split_correct_l l (num (Fnorm e1)) (num (Fnorm e2)))
+ (split_correct_r l (num (Fnorm e1)) (num (Fnorm e2)))
+ (split_correct_l l (denum (Fnorm e1)) (denum (Fnorm e2)))
+ (split_correct_r l (denum (Fnorm e1)) (denum (Fnorm e2))).
+repeat rewrite NPEmul_correct; simpl.
+intros U1 U2 U3 U4; rewrite U1; rewrite U2; rewrite U3;
+ rewrite U4; simpl.
+apply rdiv7b; auto.
+ rewrite <- U3; auto.
+ rewrite <- U2; auto.
+apply PCond_cons_inv_l with ( 1 := HH ).
+ rewrite <- U4; auto.
+
+intros e1 He1 n Hcond;assert (He1' := He1 Hcond);clear He1.
+repeat rewrite NPEpow_correct;simpl;repeat rewrite pow_th.(rpow_pow_N).
+rewrite He1';clear He1'.
+destruct n;simpl. apply rdiv1.
+generalize (NPEeval l (num (Fnorm e1))) (NPEeval l (denum (Fnorm e1)))
+ (Pcond_Fnorm _ _ Hcond).
+intros r r0 Hdiff;induction p;simpl.
+repeat (rewrite <- rdiv4;trivial).
+rewrite IHp. reflexivity.
+apply pow_pos_not_0;trivial.
+apply pow_pos_not_0;trivial.
+intro Hp. apply (pow_pos_not_0 Hdiff p).
+rewrite (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p) 0).
+ reflexivity. apply pow_pos_not_0;trivial. ring [Hp].
+rewrite <- rdiv4;trivial.
+rewrite IHp;reflexivity.
+apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
+reflexivity.
+Qed.
+
+Theorem Fnorm_crossproduct:
+ forall l fe1 fe2,
+ let nfe1 := Fnorm fe1 in
+ let nfe2 := Fnorm fe2 in
+ NPEeval l (PEmul (num nfe1) (denum nfe2)) ==
+ NPEeval l (PEmul (num nfe2) (denum nfe1)) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2.
+rewrite Fnorm_FEeval_PEeval in |- * by
+ apply PCond_app_inv_l with (1 := Hcond).
+ rewrite Fnorm_FEeval_PEeval in |- * by
+ apply PCond_app_inv_r with (1 := Hcond).
+ apply cross_product_eq; trivial.
+ apply Pcond_Fnorm.
+ apply PCond_app_inv_l with (1 := Hcond).
+ apply Pcond_Fnorm.
+ apply PCond_app_inv_r with (1 := Hcond).
+Qed.
+
+(* Correctness lemmas of reflexive tactics *)
+Notation Ninterp_PElist := (interp_PElist rO radd rmul rsub ropp req phi Cp_phi rpow).
+Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv).
+
+Theorem Fnorm_correct:
+ forall n l lpe fe,
+ Ninterp_PElist l lpe ->
+ Peq ceqb (Nnorm n (Nmk_monpol_list lpe) (num (Fnorm fe))) (Pc cO) = true ->
+ PCond l (condition (Fnorm fe)) -> FEeval l fe == 0.
+intros n l lpe fe Hlpe H H1;
+ apply eq_trans with (1 := Fnorm_FEeval_PEeval l fe H1).
+apply rdiv8; auto.
+transitivity (NPEeval l (PEc cO)); auto.
+rewrite (norm_subst_ok Rsth Reqe ARth CRmorph pow_th cdiv_th n l lpe);auto.
+change (NPEeval l (PEc cO)) with (Pphi 0 radd rmul phi l (Pc cO)).
+apply (Peq_ok Rsth Reqe CRmorph);auto.
+simpl. apply (morph0 CRmorph); auto.
+Qed.
+
+(* simplify a field expression into a fraction *)
+(* TODO: simplify when den is constant... *)
+Definition display_linear l num den :=
+ NPphi_dev l num / NPphi_dev l den.
+
+Definition display_pow_linear l num den :=
+ NPphi_pow l num / NPphi_pow l den.
+
+Theorem Field_rw_correct :
+ forall n lpe l,
+ Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall fe nfe, Fnorm fe = nfe ->
+ PCond l (condition nfe) ->
+ FEeval l fe == display_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
+Proof.
+ intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
+ apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
+ unfold display_linear; apply SRdiv_ext;
+ eapply (ring_rw_correct Rsth Reqe ARth CRmorph);eauto.
+Qed.
+
+Theorem Field_rw_pow_correct :
+ forall n lpe l,
+ Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall fe nfe, Fnorm fe = nfe ->
+ PCond l (condition nfe) ->
+ FEeval l fe == display_pow_linear l (Nnorm n lmp (num nfe)) (Nnorm n lmp (denum nfe)).
+Proof.
+ intros n lpe l Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp.
+ apply eq_trans with (1 := Fnorm_FEeval_PEeval _ _ H).
+ unfold display_pow_linear; apply SRdiv_ext;
+ eapply (ring_rw_pow_correct Rsth Reqe ARth CRmorph);eauto.
+Qed.
+
+Theorem Field_correct :
+ forall n l lpe fe1 fe2, Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ Peq ceqb (Nnorm n lmp (PEmul (num nfe1) (denum nfe2)))
+ (Nnorm n lmp (PEmul (num nfe2) (denum nfe1))) = true ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros n l lpe fe1 fe2 Hlpe lmp eq_lmp nfe1 eq1 nfe2 eq2 Hnorm Hcond; subst nfe1 nfe2 lmp.
+apply Fnorm_crossproduct; trivial.
+eapply (ring_correct Rsth Reqe ARth CRmorph); eauto.
+Qed.
+
+(* simplify a field equation : generate the crossproduct and simplify
+ polynomials *)
+Theorem Field_simplify_eq_old_correct :
+ forall l fe1 fe2 nfe1 nfe2,
+ Fnorm fe1 = nfe1 ->
+ Fnorm fe2 = nfe2 ->
+ NPphi_dev l (Nnorm O nil (PEmul (num nfe1) (denum nfe2))) ==
+ NPphi_dev l (Nnorm O nil (PEmul (num nfe2) (denum nfe1))) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2.
+apply Fnorm_crossproduct; trivial.
+match goal with
+ [ |- NPEeval l ?x == NPEeval l ?y] =>
+ rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
+ O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x)));
+ rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec
+ O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y)))
+ end.
+trivial.
+Qed.
+
+Theorem Field_simplify_eq_correct :
+ forall n l lpe fe1 fe2,
+ Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den ->
+ NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
+ NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
+ subst nfe1 nfe2 den lmp.
+apply Fnorm_crossproduct; trivial.
+simpl in |- *.
+rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite NPEmul_correct in |- *.
+rewrite NPEmul_correct in |- *.
+simpl in |- *.
+repeat rewrite (ARmul_assoc ARth) in |- *.
+rewrite <-(
+ let x := PEmul (num (Fnorm fe1))
+ (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
+ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
+ Hlpe (refl_equal (Nmk_monpol_list lpe))
+ x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+rewrite <-(
+ let x := (PEmul (num (Fnorm fe2))
+ (rsplit_left
+ (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
+ ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
+ Hlpe (refl_equal (Nmk_monpol_list lpe))
+ x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+simpl in Hcrossprod.
+rewrite Hcrossprod in |- *.
+reflexivity.
+Qed.
+
+Theorem Field_simplify_eq_pow_correct :
+ forall n l lpe fe1 fe2,
+ Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den ->
+ NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) ==
+ NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ FEeval l fe1 == FEeval l fe2.
+Proof.
+intros n l lpe fe1 fe2 Hlpe lmp Hlmp nfe1 eq1 nfe2 eq2 den eq3 Hcrossprod Hcond;
+ subst nfe1 nfe2 den lmp.
+apply Fnorm_crossproduct; trivial.
+simpl in |- *.
+rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite (split_correct_r l (denum (Fnorm fe1)) (denum (Fnorm fe2))) in |- *.
+rewrite NPEmul_correct in |- *.
+rewrite NPEmul_correct in |- *.
+simpl in |- *.
+repeat rewrite (ARmul_assoc ARth) in |- *.
+rewrite <-(
+ let x := PEmul (num (Fnorm fe1))
+ (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in
+ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
+ Hlpe (refl_equal (Nmk_monpol_list lpe))
+ x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+rewrite <-(
+ let x := (PEmul (num (Fnorm fe2))
+ (rsplit_left
+ (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in
+ ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l
+ Hlpe (refl_equal (Nmk_monpol_list lpe))
+ x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod.
+simpl in Hcrossprod.
+rewrite Hcrossprod in |- *.
+reflexivity.
+Qed.
+
+Theorem Field_simplify_eq_pow_in_correct :
+ forall n l lpe fe1 fe2,
+ Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den ->
+ forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
+ forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ FEeval l fe1 == FEeval l fe2 ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ NPphi_pow l np1 ==
+ NPphi_pow l np2.
+Proof.
+ intros. subst nfe1 nfe2 lmp np1 np2.
+ repeat rewrite (Pphi_pow_ok Rsth Reqe ARth CRmorph pow_th get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
+ assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
+ assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
+ apply (@rmul_reg_l (NPEeval l (rsplit_common den))).
+ intro Heq;apply N1.
+ rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+ rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
+ repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
+ repeat rewrite <- ARth.(ARmul_assoc).
+ change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
+ (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
+ change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
+ (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
+ repeat rewrite <- NPEmul_correct. rewrite <- H3. rewrite <- split_correct_l.
+ rewrite <- split_correct_r.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
+ ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
+ ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
+ rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
+ rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (AFth.(AFdiv_def)).
+ repeat rewrite <- Fnorm_FEeval_PEeval ; trivial.
+ apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
+Qed.
+
+Theorem Field_simplify_eq_in_correct :
+forall n l lpe fe1 fe2,
+ Ninterp_PElist l lpe ->
+ forall lmp, Nmk_monpol_list lpe = lmp ->
+ forall nfe1, Fnorm fe1 = nfe1 ->
+ forall nfe2, Fnorm fe2 = nfe2 ->
+ forall den, split (denum nfe1) (denum nfe2) = den ->
+ forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 ->
+ forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 ->
+ FEeval l fe1 == FEeval l fe2 ->
+ PCond l (condition nfe1 ++ condition nfe2) ->
+ NPphi_dev l np1 ==
+ NPphi_dev l np2.
+Proof.
+ intros. subst nfe1 nfe2 lmp np1 np2.
+ repeat rewrite (Pphi_dev_ok Rsth Reqe ARth CRmorph get_sign_spec).
+ repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl.
+ assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)).
+ assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)).
+ apply (@rmul_reg_l (NPEeval l (rsplit_common den))).
+ intro Heq;apply N1.
+ rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))).
+ rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq].
+ repeat rewrite (ARth.(ARmul_comm) (NPEeval l (rsplit_common den))).
+ repeat rewrite <- ARth.(ARmul_assoc).
+ change (NPEeval l (rsplit_right den) * NPEeval l (rsplit_common den)) with
+ (NPEeval l (PEmul (rsplit_right den) (rsplit_common den))).
+ change (NPEeval l (rsplit_left den) * NPEeval l (rsplit_common den)) with
+ (NPEeval l (PEmul (rsplit_left den) (rsplit_common den))).
+ repeat rewrite <- NPEmul_correct;rewrite <- H3. rewrite <- split_correct_l.
+ rewrite <- split_correct_r.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe2)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe2))));trivial.
+ ring [Heq]. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
+ apply (@rmul_reg_l (/NPEeval l (denum (Fnorm fe1)))).
+ intro Heq; apply AFth.(AF_1_neq_0).
+ rewrite <- (@AFinv_l AFth (NPEeval l (denum (Fnorm fe1))));trivial.
+ ring [Heq]. repeat rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe1)))).
+ repeat rewrite <- (ARth.(ARmul_assoc)).
+ repeat rewrite <- (AFth.(AFdiv_def)). rewrite rdiv_r_r by trivial.
+ rewrite (AFth.(AFdiv_def)). ring_simplify. unfold SRopp.
+ rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))).
+ repeat rewrite <- (AFth.(AFdiv_def)).
+ repeat rewrite <- Fnorm_FEeval_PEeval;trivial.
+ apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
+Qed.
+
+
+Section Fcons_impl.
+
+Variable Fcons : PExpr C -> list (PExpr C) -> list (PExpr C).
+
+Hypothesis PCond_fcons_inv : forall l a l1,
+ PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+
+Fixpoint Fapp (l m:list (PExpr C)) {struct l} : list (PExpr C) :=
+ match l with
+ | nil => m
+ | cons a l1 => Fcons a (Fapp l1 m)
+ end.
+
+Lemma fcons_correct : forall l l1,
+ PCond l (Fapp l1 nil) -> PCond l l1.
+induction l1; simpl in |- *; intros.
+ trivial.
+ elim PCond_fcons_inv with (1 := H); intros.
+ destruct l1; auto.
+Qed.
+
+End Fcons_impl.
+
+Section Fcons_simpl.
+
+(* Some general simpifications of the condition: eliminate duplicates,
+ split multiplications *)
+
+Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
+ match l with
+ nil => cons e nil
+ | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1)
+ end.
+
+Theorem PFcons_fcons_inv:
+ forall l a l1, PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a l1; elim l1; simpl Fcons; auto.
+simpl; auto.
+intros a0 l0.
+generalize (PExpr_eq_semi_correct l a a0); case (PExpr_eq a a0).
+intros H H0 H1; split; auto.
+rewrite H; auto.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+intros H H0 H1;
+ assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
+split.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+apply H0.
+generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
+generalize Hp; case l0; simpl; intuition.
+Qed.
+
+(* equality of normal forms rather than syntactic equality *)
+Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) :=
+ match l with
+ nil => cons e nil
+ | cons a l1 =>
+ if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l
+ else cons a (Fcons0 e l1)
+ end.
+
+Theorem PFcons0_fcons_inv:
+ forall l a l1, PCond l (Fcons0 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a l1; elim l1; simpl Fcons0; auto.
+simpl; auto.
+intros a0 l0.
+generalize (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th O l nil a a0). simpl.
+ case (Peq ceqb (Nnorm O nil a) (Nnorm O nil a0)).
+intros H H0 H1; split; auto.
+rewrite H; auto.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+intros H H0 H1;
+ assert (Hp: ~ NPEeval l a0 == 0 /\ (~ NPEeval l a == 0 /\ PCond l l0)).
+split.
+generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto.
+apply H0.
+generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto.
+clear get_sign get_sign_spec.
+generalize Hp; case l0; simpl; intuition.
+Qed.
+
+(* split factorized denominators *)
+Fixpoint Fcons00 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
+ match e with
+ PEmul e1 e2 => Fcons00 e1 (Fcons00 e2 l)
+ | PEpow e1 _ => Fcons00 e1 l
+ | _ => Fcons0 e l
+ end.
+
+Theorem PFcons00_fcons_inv:
+ forall l a l1, PCond l (Fcons00 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
+ intros p H p0 H0 l1 H1.
+ simpl in H1.
+ case (H _ H1); intros H2 H3.
+ case (H0 _ H3); intros H4 H5; split; auto.
+ simpl in |- *.
+ apply field_is_integral_domain; trivial.
+ simpl;intros. rewrite pow_th.(rpow_pow_N).
+ destruct (H _ H0);split;auto.
+ destruct n;simpl. apply AFth.(AF_1_neq_0).
+ apply pow_pos_not_0;trivial.
+Qed.
+
+Definition Pcond_simpl_gen :=
+ fcons_correct _ PFcons00_fcons_inv.
+
+
+(* Specific case when the equality test of coefs is complete w.r.t. the
+ field equality: non-zero coefs can be eliminated, and opposite can
+ be simplified (if -1 <> 0) *)
+
+Hypothesis ceqb_complete : forall c1 c2, phi c1 == phi c2 -> ceqb c1 c2 = true.
+
+Lemma ceqb_rect_complete : forall c1 c2 (A:Type) (x y:A) (P:A->Type),
+ (phi c1 == phi c2 -> P x) ->
+ (~ phi c1 == phi c2 -> P y) ->
+ P (if ceqb c1 c2 then x else y).
+Proof.
+intros.
+generalize (fun h => X (morph_eq CRmorph c1 c2 h)).
+generalize (@ceqb_complete c1 c2).
+case (c1 ?=! c2); auto; intros.
+apply X0.
+red in |- *; intro.
+absurd (false = true); auto; discriminate.
+Qed.
+
+Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) :=
+ match e with
+ PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l)
+ | PEpow e _ => Fcons1 e l
+ | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l
+ | PEc c => if ceqb c cO then absurd_PCond else l
+ | _ => Fcons0 e l
+ end.
+
+Theorem PFcons1_fcons_inv:
+ forall l a l1, PCond l (Fcons1 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail).
+ simpl in |- *; intros c l1.
+ apply ceqb_rect_complete; intros.
+ elim (@absurd_PCond_bottom l H0).
+ split; trivial.
+ rewrite <- (morph0 CRmorph) in |- *; trivial.
+ intros p H p0 H0 l1 H1.
+ simpl in H1.
+ case (H _ H1); intros H2 H3.
+ case (H0 _ H3); intros H4 H5; split; auto.
+ simpl in |- *.
+ apply field_is_integral_domain; trivial.
+ simpl in |- *; intros p H l1.
+ apply ceqb_rect_complete; intros.
+ elim (@absurd_PCond_bottom l H1).
+ destruct (H _ H1).
+ split; trivial.
+ apply ropp_neq_0; trivial.
+ rewrite (morph_opp CRmorph) in H0.
+ rewrite (morph1 CRmorph) in H0.
+ rewrite (morph0 CRmorph) in H0.
+ trivial.
+ intros;simpl. destruct (H _ H0);split;trivial.
+ rewrite pow_th.(rpow_pow_N). destruct n;simpl.
+ apply AFth.(AF_1_neq_0). apply pow_pos_not_0;trivial.
+Qed.
+
+Definition Fcons2 e l := Fcons1 (PExpr_simp e) l.
+
+Theorem PFcons2_fcons_inv:
+ forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1.
+unfold Fcons2 in |- *; intros l a l1 H; split;
+ case (PFcons1_fcons_inv l (PExpr_simp a) l1); auto.
+intros H1 H2 H3; case H1.
+transitivity (NPEeval l a); trivial.
+apply PExpr_simp_correct.
+Qed.
+
+Definition Pcond_simpl_complete :=
+ fcons_correct _ PFcons2_fcons_inv.
+
+End Fcons_simpl.
+
+End AlmostField.
+
+Section FieldAndSemiField.
+
+ Record field_theory : Prop := mk_field {
+ F_R : ring_theory rO rI radd rmul rsub ropp req;
+ F_1_neq_0 : ~ 1 == 0;
+ Fdiv_def : forall p q, p / q == p * / q;
+ Finv_l : forall p, ~ p == 0 -> / p * p == 1
+ }.
+
+ Definition F2AF f :=
+ mk_afield
+ (Rth_ARth Rsth Reqe f.(F_R)) f.(F_1_neq_0) f.(Fdiv_def) f.(Finv_l).
+
+ Record semi_field_theory : Prop := mk_sfield {
+ SF_SR : semi_ring_theory rO rI radd rmul req;
+ SF_1_neq_0 : ~ 1 == 0;
+ SFdiv_def : forall p q, p / q == p * / q;
+ SFinv_l : forall p, ~ p == 0 -> / p * p == 1
+ }.
+
+End FieldAndSemiField.
+
+End MakeFieldPol.
+
+ Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth
+ (sf:semi_field_theory rO rI radd rmul rdiv rinv req) :=
+ mk_afield _ _
+ (SRth_ARth Rsth sf.(SF_SR))
+ sf.(SF_1_neq_0)
+ sf.(SFdiv_def)
+ sf.(SFinv_l).
+
+
+Section Complete.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable (rdiv : R -> R -> R) (rinv : R -> R).
+ Variable req : R -> R -> Prop.
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x / y " := (rdiv x y). Notation "/ x" := (rinv x).
+ Notation "x == y" := (req x y) (at level 70, no associativity).
+ Variable Rsth : Setoid_Theory R req.
+ Add Setoid R req Rsth as R_setoid3.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed.
+
+Section AlmostField.
+
+ Variable AFth : almost_field_theory rO rI radd rmul rsub ropp rdiv rinv req.
+ Let ARth := AFth.(AF_AR).
+ Let rI_neq_rO := AFth.(AF_1_neq_0).
+ Let rdiv_def := AFth.(AFdiv_def).
+ Let rinv_l := AFth.(AFinv_l).
+
+Hypothesis S_inj : forall x y, 1+x==1+y -> x==y.
+
+Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
+
+Lemma add_inj_r : forall p x y,
+ gen_phiPOS1 rI radd rmul p + x == gen_phiPOS1 rI radd rmul p + y -> x==y.
+intros p x y.
+elim p using Pind; simpl in |- *; intros.
+ apply S_inj; trivial.
+ apply H.
+ apply S_inj.
+ repeat rewrite (ARadd_assoc ARth) in |- *.
+ rewrite <- (ARgen_phiPOS_Psucc Rsth Reqe ARth) in |- *; trivial.
+Qed.
+
+Lemma gen_phiPOS_inj : forall x y,
+ gen_phiPOS rI radd rmul x == gen_phiPOS rI radd rmul y ->
+ x = y.
+intros x y.
+repeat rewrite <- (same_gen Rsth Reqe ARth) in |- *.
+ElimPcompare x y; intro.
+ intros.
+ apply Pcompare_Eq_eq; trivial.
+ intro.
+ elim gen_phiPOS_not_0 with (y - x)%positive.
+ apply add_inj_r with x.
+ symmetry in |- *.
+ rewrite (ARadd_0_r Rsth ARth) in |- *.
+ rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+ rewrite Pplus_minus in |- *; trivial.
+ change Eq with (CompOpp Eq) in |- *.
+ rewrite <- Pcompare_antisym in |- *; trivial.
+ rewrite H in |- *; trivial.
+ intro.
+ elim gen_phiPOS_not_0 with (x - y)%positive.
+ apply add_inj_r with y.
+ rewrite (ARadd_0_r Rsth ARth) in |- *.
+ rewrite <- (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+ rewrite Pplus_minus in |- *; trivial.
+Qed.
+
+
+Lemma gen_phiN_inj : forall x y,
+ gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
+ x = y.
+destruct x; destruct y; simpl in |- *; intros; trivial.
+ elim gen_phiPOS_not_0 with p.
+ symmetry in |- *.
+ rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
+ elim gen_phiPOS_not_0 with p.
+ rewrite (same_gen Rsth Reqe ARth) in |- *; trivial.
+ rewrite gen_phiPOS_inj with (1 := H) in |- *; trivial.
+Qed.
+
+Lemma gen_phiN_complete : forall x y,
+ gen_phiN rO rI radd rmul x == gen_phiN rO rI radd rmul y ->
+ Neq_bool x y = true.
+intros.
+ replace y with x.
+ unfold Neq_bool in |- *.
+ rewrite Ncompare_refl in |- *; trivial.
+ apply gen_phiN_inj; trivial.
+Qed.
+
+End AlmostField.
+
+Section Field.
+
+ Variable Fth : field_theory rO rI radd rmul rsub ropp rdiv rinv req.
+ Let Rth := Fth.(F_R).
+ Let rI_neq_rO := Fth.(F_1_neq_0).
+ Let rdiv_def := Fth.(Fdiv_def).
+ Let rinv_l := Fth.(Finv_l).
+ Let AFth := F2AF Rsth Reqe Fth.
+ Let ARth := Rth_ARth Rsth Reqe Rth.
+
+Lemma ring_S_inj : forall x y, 1+x==1+y -> x==y.
+intros.
+transitivity (x + (1 + - (1))).
+ rewrite (Ropp_def Rth) in |- *.
+ symmetry in |- *.
+ apply (ARadd_0_r Rsth ARth).
+ transitivity (y + (1 + - (1))).
+ repeat rewrite <- (ARplus_assoc ARth) in |- *.
+ repeat rewrite (ARadd_assoc ARth) in |- *.
+ apply (Radd_ext Reqe).
+ repeat rewrite <- (ARadd_comm ARth 1) in |- *.
+ trivial.
+ reflexivity.
+ rewrite (Ropp_def Rth) in |- *.
+ apply (ARadd_0_r Rsth ARth).
+Qed.
+
+
+ Hypothesis gen_phiPOS_not_0 : forall p, ~ gen_phiPOS1 rI radd rmul p == 0.
+
+Let gen_phiPOS_inject :=
+ gen_phiPOS_inj AFth ring_S_inj gen_phiPOS_not_0.
+
+Lemma gen_phiPOS_discr_sgn : forall x y,
+ ~ gen_phiPOS rI radd rmul x == - gen_phiPOS rI radd rmul y.
+red in |- *; intros.
+apply gen_phiPOS_not_0 with (y + x)%positive.
+rewrite (ARgen_phiPOS_add Rsth Reqe ARth) in |- *.
+transitivity (gen_phiPOS1 1 radd rmul y + - gen_phiPOS1 1 radd rmul y).
+ apply (Radd_ext Reqe); trivial.
+ reflexivity.
+ rewrite (same_gen Rsth Reqe ARth) in |- *.
+ rewrite (same_gen Rsth Reqe ARth) in |- *.
+ trivial.
+ apply (Ropp_def Rth).
+Qed.
+
+Lemma gen_phiZ_inj : forall x y,
+ gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
+ x = y.
+destruct x; destruct y; simpl in |- *; intros.
+ trivial.
+ elim gen_phiPOS_not_0 with p.
+ rewrite (same_gen Rsth Reqe ARth) in |- *.
+ symmetry in |- *; trivial.
+ elim gen_phiPOS_not_0 with p.
+ rewrite (same_gen Rsth Reqe ARth) in |- *.
+ rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
+ rewrite <- H in |- *.
+ apply (ARopp_zero Rsth Reqe ARth).
+ elim gen_phiPOS_not_0 with p.
+ rewrite (same_gen Rsth Reqe ARth) in |- *.
+ trivial.
+ rewrite gen_phiPOS_inject with (1 := H) in |- *; trivial.
+ elim gen_phiPOS_discr_sgn with (1 := H).
+ elim gen_phiPOS_not_0 with p.
+ rewrite (same_gen Rsth Reqe ARth) in |- *.
+ rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
+ rewrite H in |- *.
+ apply (ARopp_zero Rsth Reqe ARth).
+ elim gen_phiPOS_discr_sgn with p0 p.
+ symmetry in |- *; trivial.
+ replace p0 with p; trivial.
+ apply gen_phiPOS_inject.
+ rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p)) in |- *.
+ rewrite <- (Ropp_opp Rsth Reqe Rth (gen_phiPOS 1 radd rmul p0)) in |- *.
+ rewrite H in |- *; trivial.
+ reflexivity.
+Qed.
+
+Lemma gen_phiZ_complete : forall x y,
+ gen_phiZ rO rI radd rmul ropp x == gen_phiZ rO rI radd rmul ropp y ->
+ Zeq_bool x y = true.
+intros.
+ replace y with x.
+ unfold Zeq_bool in |- *.
+ rewrite Zcompare_refl in |- *; trivial.
+ apply gen_phiZ_inj; trivial.
+Qed.
+
+End Field.
+
+End Complete.
diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
new file mode 100644
index 00000000..b5384f80
--- /dev/null
+++ b/plugins/setoid_ring/InitialRing.v
@@ -0,0 +1,908 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Import ZArith_base.
+Require Import Zpow_def.
+Require Import BinInt.
+Require Import BinNat.
+Require Import Setoid.
+Require Import Ring_theory.
+Require Import Ring_polynom.
+Require Import ZOdiv_def.
+Import List.
+
+Set Implicit Arguments.
+
+Import RingSyntax.
+
+(* 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).
+Proof (Eqsth Z).
+
+Lemma Zeqe : ring_eq_ext Zplus Zmult Zopp (@eq Z).
+Proof (Eq_ext Zplus Zmult Zopp).
+
+Lemma Zth : ring_theory Z0 (Zpos xH) Zplus Zmult Zminus Zopp (@eq Z).
+Proof.
+ constructor. exact Zplus_0_l. exact Zplus_comm. exact Zplus_assoc.
+ exact Zmult_1_l. exact Zmult_comm. exact Zmult_assoc.
+ exact Zmult_plus_distr_l. trivial. exact Zminus_diag.
+Qed.
+
+(** Two generic morphisms from Z to (abrbitrary) rings, *)
+(**second one is more convenient for proofs but they are ext. equal*)
+Section ZMORPHISM.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop.
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+ Variable Rsth : Setoid_Theory R req.
+ Add Setoid R req Rsth as R_setoid3.
+ Ltac rrefl := gen_reflexivity Rsth.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Add Morphism radd : radd_ext3. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext3. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext3. exact (Ropp_ext Reqe). Qed.
+
+ 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.
+
+ Lemma get_signZ_th : sign_theory Zopp Zeq_bool get_signZ.
+ Proof.
+ constructor.
+ destruct c;intros;try discriminate.
+ injection H;clear H;intros H1;subst c'.
+ simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial.
+ Qed.
+
+
+ Section ALMOST_RING.
+ Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
+ Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac norm := gen_srewrite Rsth Reqe ARth.
+ Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+
+ Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x.
+ Proof.
+ induction x;simpl.
+ rewrite IHx;destruct x;simpl;norm.
+ rewrite IHx;destruct x;simpl;norm.
+ rrefl.
+ Qed.
+
+ Lemma ARgen_phiPOS_Psucc : forall x,
+ gen_phiPOS1 (Psucc x) == 1 + (gen_phiPOS1 x).
+ Proof.
+ induction x;simpl;norm.
+ rewrite IHx;norm.
+ add_push 1;rrefl.
+ 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;rrefl.
+ rewrite IHx;norm;add_push (gen_phiPOS1 y);rrefl.
+ rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl.
+ rewrite IHx;norm;add_push(gen_phiPOS1 y); add_push 1;rrefl.
+ rewrite IHx;norm;add_push(gen_phiPOS1 y);rrefl.
+ add_push 1;rrefl.
+ rewrite ARgen_phiPOS_Psucc;norm;add_push 1;rrefl.
+ 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;rrefl.
+ Qed.
+
+ End ALMOST_RING.
+
+ Variable Rth : ring_theory 0 1 radd rmul rsub ropp req.
+ Let ARth := Rth_ARth Rsth Reqe Rth.
+ Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac norm := gen_srewrite Rsth Reqe ARth.
+ Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+
+(*morphisms are extensionaly equal*)
+ Lemma same_genZ : forall x, [x] == gen_phiZ1 x.
+ Proof.
+ destruct x;simpl; try rewrite (same_gen ARth);rrefl.
+ Qed.
+
+ Lemma gen_Zeqb_ok : forall x y,
+ Zeq_bool x y = true -> [x] == [y].
+ Proof.
+ intros x y H.
+ assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1.
+ 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.
+ 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 (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 (ARgen_phiPOS_add ARth);simpl;norm.
+ add_push (gen_phiPOS1 h);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.
+ 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.
+ rewrite (ARgen_phiPOS_add ARth); norm.
+ 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 ARth);try (norm;fail).
+ rewrite (Ropp_opp Rsth Reqe Rth);rrefl.
+ Qed.
+
+ Lemma gen_phiZ_ext : forall x y : Z, x = y -> [x] == [y].
+ Proof. intros;subst;rrefl. Qed.
+
+(*proof that [.] satisfies morphism specifications*)
+ Lemma gen_phiZ_morph :
+ ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH)
+ Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ.
+ Proof.
+ assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH)
+ Zplus Zmult Zeq_bool gen_phiZ).
+ apply mkRmorph;simpl;try rrefl.
+ apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok.
+ apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext).
+ Qed.
+
+End ZMORPHISM.
+
+(** N is a semi-ring and a setoid*)
+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 Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@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.
+Qed.
+
+Definition Nsub := SRsub Nplus.
+Definition Nopp := (@SRopp N).
+
+Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N).
+Proof (SReqe_Reqe Nseqe).
+
+Lemma Nath :
+ almost_ring_theory N0 (Npos xH) Nplus Nmult 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.
+
+(**Same as above : definition of two,extensionaly equal, generic morphisms *)
+(**from N to any semi-ring*)
+Section NMORPHISM.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul: R->R->R).
+ Variable req : R -> R -> Prop.
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Variable Rsth : Setoid_Theory R req.
+ Add Setoid R req Rsth as R_setoid4.
+ Ltac rrefl := gen_reflexivity Rsth.
+ Variable SReqe : sring_eq_ext radd rmul req.
+ Variable SRth : semi_ring_theory 0 1 radd rmul req.
+ Let ARth := SRth_ARth Rsth SRth.
+ Let Reqe := SReqe_Reqe SReqe.
+ Let ropp := (@SRopp R).
+ Let rsub := (@SRsub R radd).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ 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.
+
+ Definition gen_phiN1 x :=
+ match x with
+ | N0 => 0
+ | Npos x => gen_phiPOS1 1 radd rmul x
+ end.
+
+ Definition gen_phiN x :=
+ match x with
+ | N0 => 0
+ | Npos x => gen_phiPOS 1 radd rmul x
+ end.
+ Notation "[ x ]" := (gen_phiN x).
+
+ Lemma same_genN : forall x, [x] == gen_phiN1 x.
+ Proof.
+ destruct x;simpl. rrefl.
+ rewrite (same_gen Rsth Reqe ARth);rrefl.
+ Qed.
+
+ Lemma gen_phiN_add : forall x y, [x + y] == [x] + [y].
+ Proof.
+ intros x y;repeat rewrite same_genN.
+ destruct x;destruct y;simpl;norm.
+ apply (ARgen_phiPOS_add Rsth Reqe ARth).
+ Qed.
+
+ Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y].
+ Proof.
+ intros x y;repeat rewrite same_genN.
+ destruct x;destruct y;simpl;norm.
+ apply (ARgen_phiPOS_mult Rsth Reqe ARth).
+ Qed.
+
+ Lemma gen_phiN_sub : forall x y, [Nsub x y] == [x] - [y].
+ Proof. exact gen_phiN_add. Qed.
+
+(*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.
+ Proof.
+ constructor;intros;simpl; try rrefl.
+ apply gen_phiN_add. apply gen_phiN_sub. apply gen_phiN_mult.
+ rewrite (Neq_bool_ok x y);trivial. rrefl.
+ Qed.
+
+End NMORPHISM.
+
+(* Words on N : initial structure for almost-rings. *)
+Definition Nword := list N.
+Definition NwO : Nword := nil.
+Definition NwI : Nword := 1%N :: nil.
+
+Definition Nwcons n (w : Nword) : Nword :=
+ match w, n with
+ | nil, 0%N => nil
+ | _, _ => n :: w
+ end.
+
+Fixpoint Nwadd (w1 w2 : Nword) {struct w1} : Nword :=
+ match w1, w2 with
+ | n1::w1', n2:: w2' => (n1+n2)%N :: Nwadd w1' w2'
+ | nil, _ => w2
+ | _, nil => w1
+ end.
+
+Definition Nwopp (w:Nword) : Nword := Nwcons 0%N w.
+
+Definition Nwsub w1 w2 := Nwadd w1 (Nwopp w2).
+
+Fixpoint Nwscal (n : N) (w : Nword) {struct w} : Nword :=
+ match w with
+ | m :: w' => (n*m)%N :: Nwscal n w'
+ | nil => nil
+ end.
+
+Fixpoint Nwmul (w1 w2 : Nword) {struct w1} : Nword :=
+ match w1 with
+ | 0%N::w1' => Nwopp (Nwmul w1' w2)
+ | n1::w1' => Nwsub (Nwscal n1 w2) (Nwmul w1' w2)
+ | nil => nil
+ end.
+Fixpoint Nw_is0 (w : Nword) : bool :=
+ match w with
+ | nil => true
+ | 0%N :: w' => Nw_is0 w'
+ | _ => false
+ end.
+
+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
+ | nil, _ => Nw_is0 w2
+ | _, nil => Nw_is0 w1
+ end.
+
+Section NWORDMORPHISM.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop.
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+ Variable Rsth : Setoid_Theory R req.
+ Add Setoid R req Rsth as R_setoid5.
+ Ltac rrefl := gen_reflexivity Rsth.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Add Morphism radd : radd_ext5. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext5. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext5. exact (Ropp_ext Reqe). Qed.
+
+ Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
+ Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac norm := gen_srewrite Rsth Reqe ARth.
+ Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+
+ Fixpoint gen_phiNword (w : Nword) : R :=
+ match w with
+ | nil => 0
+ | n :: nil => gen_phiN rO rI radd rmul n
+ | N0 :: w' => - gen_phiNword w'
+ | n::w' => gen_phiN rO rI radd rmul n - gen_phiNword w'
+ end.
+
+ Lemma gen_phiNword0_ok : forall w, Nw_is0 w = true -> gen_phiNword w == 0.
+Proof.
+induction w; simpl in |- *; intros; auto.
+ reflexivity.
+
+ destruct a.
+ destruct w.
+ reflexivity.
+
+ rewrite IHw in |- *; trivial.
+ apply (ARopp_zero Rsth Reqe ARth).
+
+ discriminate.
+Qed.
+
+ Lemma gen_phiNword_cons : forall w n,
+ gen_phiNword (n::w) == gen_phiN rO rI radd rmul n - gen_phiNword w.
+induction w.
+ destruct n; simpl in |- *; norm.
+
+ intros.
+ destruct n; norm.
+Qed.
+
+ Lemma gen_phiNword_Nwcons : forall w n,
+ gen_phiNword (Nwcons n w) == gen_phiN rO rI radd rmul n - gen_phiNword w.
+destruct w; intros.
+ destruct n; norm.
+
+ unfold Nwcons in |- *.
+ rewrite gen_phiNword_cons in |- *.
+ reflexivity.
+Qed.
+
+ Lemma gen_phiNword_ok : forall w1 w2,
+ Nweq_bool w1 w2 = true -> gen_phiNword w1 == gen_phiNword w2.
+induction w1; intros.
+ simpl in |- *.
+ rewrite (gen_phiNword0_ok _ H) in |- *.
+ reflexivity.
+
+ rewrite gen_phiNword_cons in |- *.
+ destruct w2.
+ simpl in H.
+ destruct a; try discriminate.
+ rewrite (gen_phiNword0_ok _ H) in |- *.
+ norm.
+
+ simpl in H.
+ rewrite gen_phiNword_cons in |- *.
+ case_eq (Neq_bool a n); intros.
+ rewrite H0 in H.
+ rewrite <- (Neq_bool_ok _ _ H0) in |- *.
+ rewrite (IHw1 _ H) in |- *.
+ reflexivity.
+
+ rewrite H0 in H; discriminate H.
+Qed.
+
+
+Lemma Nwadd_ok : forall x y,
+ gen_phiNword (Nwadd x y) == gen_phiNword x + gen_phiNword y.
+induction x; intros.
+ simpl in |- *.
+ norm.
+
+ destruct y.
+ simpl Nwadd; norm.
+
+ simpl Nwadd in |- *.
+ repeat rewrite gen_phiNword_cons in |- *.
+ rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- * by
+ (destruct Reqe; constructor; trivial).
+
+ rewrite IHx in |- *.
+ norm.
+ add_push (- gen_phiNword x); reflexivity.
+Qed.
+
+Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x.
+simpl in |- *.
+unfold Nwopp in |- *; simpl in |- *.
+intros.
+rewrite gen_phiNword_Nwcons in |- *; norm.
+Qed.
+
+Lemma Nwscal_ok : forall n x,
+ gen_phiNword (Nwscal n x) == gen_phiN rO rI radd rmul n * gen_phiNword x.
+induction x; intros.
+ norm.
+
+ simpl Nwscal in |- *.
+ repeat rewrite gen_phiNword_cons in |- *.
+ rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- *
+ by (destruct Reqe; constructor; trivial).
+
+ rewrite IHx in |- *.
+ norm.
+Qed.
+
+Lemma Nwmul_ok : forall x y,
+ gen_phiNword (Nwmul x y) == gen_phiNword x * gen_phiNword y.
+induction x; intros.
+ norm.
+
+ destruct a.
+ simpl Nwmul in |- *.
+ rewrite Nwopp_ok in |- *.
+ rewrite IHx in |- *.
+ rewrite gen_phiNword_cons in |- *.
+ norm.
+
+ simpl Nwmul in |- *.
+ unfold Nwsub in |- *.
+ rewrite Nwadd_ok in |- *.
+ rewrite Nwscal_ok in |- *.
+ rewrite Nwopp_ok in |- *.
+ rewrite IHx in |- *.
+ rewrite gen_phiNword_cons in |- *.
+ norm.
+Qed.
+
+(* Proof that [.] satisfies morphism specifications *)
+ Lemma gen_phiNword_morph :
+ ring_morph 0 1 radd rmul rsub ropp req
+ NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword.
+constructor.
+ reflexivity.
+
+ reflexivity.
+
+ exact Nwadd_ok.
+
+ intros.
+ unfold Nwsub in |- *.
+ rewrite Nwadd_ok in |- *.
+ rewrite Nwopp_ok in |- *.
+ norm.
+
+ exact Nwmul_ok.
+
+ exact Nwopp_ok.
+
+ exact gen_phiNword_ok.
+Qed.
+
+End NWORDMORPHISM.
+
+Section GEN_DIV.
+
+ Variables (R : Type) (rO : R) (rI : R) (radd : R -> R -> R)
+ (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R)
+ (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C)
+ (cadd : C -> C -> C) (cmul : C -> C -> C) (csub : C -> C -> C)
+ (copp : C -> C) (ceqb : C -> C -> bool) (phi : C -> R).
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
+ Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi.
+
+ (* Useful tactics *)
+ Add Setoid R req Rsth as R_set1.
+ Ltac rrefl := gen_reflexivity Rsth.
+ Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed.
+ Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
+
+ Definition triv_div x y :=
+ if ceqb x y then (cI, cO)
+ else (cO, x).
+
+ Ltac Esimpl :=repeat (progress (
+ match goal with
+ | |- context [phi cO] => rewrite (morph0 morph)
+ | |- context [phi cI] => rewrite (morph1 morph)
+ | |- context [phi (cadd ?x ?y)] => rewrite ((morph_add morph) x y)
+ | |- context [phi (cmul ?x ?y)] => rewrite ((morph_mul morph) x y)
+ | |- context [phi (csub ?x ?y)] => rewrite ((morph_sub morph) x y)
+ | |- context [phi (copp ?x)] => rewrite ((morph_opp morph) x)
+ end)).
+
+ Lemma triv_div_th : Ring_theory.div_theory req cadd cmul phi triv_div.
+ Proof.
+ constructor.
+ intros a b;unfold triv_div.
+ assert (X:= morph.(morph_eq) a b);destruct (ceqb a b).
+ Esimpl.
+ rewrite X; trivial.
+ rsimpl.
+ Esimpl; rsimpl.
+Qed.
+
+ Variable zphi : Z -> R.
+
+ Lemma Ztriv_div_th : div_theory req Zplus Zmult zphi ZOdiv_eucl.
+ Proof.
+ constructor.
+ intros; generalize (ZOdiv_eucl_correct a b); case ZOdiv_eucl; intros; subst.
+ rewrite Zmult_comm; rsimpl.
+ Qed.
+
+ Variable nphi : N -> R.
+
+ Lemma Ntriv_div_th : div_theory req Nplus Nmult nphi Ndiv_eucl.
+ constructor.
+ intros; generalize (Ndiv_eucl_correct a b); case Ndiv_eucl; intros; subst.
+ rewrite Nmult_comm; rsimpl.
+ Qed.
+
+End GEN_DIV.
+
+ (* syntaxification of constants in an abstract ring:
+ the inverse of gen_phiPOS *)
+ Ltac inv_gen_phi_pos rI add mul t :=
+ let rec inv_cst t :=
+ match t with
+ rI => constr:1%positive
+ | (add rI rI) => constr:2%positive
+ | (add rI (add rI rI)) => constr:3%positive
+ | (mul (add rI rI) ?p) => (* 2p *)
+ match inv_cst p with
+ NotConstant => constr:NotConstant
+ | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *)
+ | ?p => constr:(xO p)
+ end
+ | (add rI (mul (add rI rI) ?p)) => (* 1+2p *)
+ match inv_cst p with
+ NotConstant => constr:NotConstant
+ | 1%positive => constr:NotConstant
+ | ?p => constr:(xI p)
+ end
+ | _ => constr:NotConstant
+ end in
+ inv_cst t.
+
+(* The (partial) inverse of gen_phiNword *)
+ Ltac inv_gen_phiNword rO rI add mul opp t :=
+ match t with
+ rO => constr:NwO
+ | _ =>
+ match inv_gen_phi_pos rI add mul t with
+ NotConstant => constr:NotConstant
+ | ?p => constr:(Npos p::nil)
+ end
+ end.
+
+
+(* The inverse of gen_phiN *)
+ Ltac inv_gen_phiN rO rI add mul t :=
+ match t with
+ rO => constr:0%N
+ | _ =>
+ match inv_gen_phi_pos rI add mul t with
+ NotConstant => constr:NotConstant
+ | ?p => constr:(Npos p)
+ end
+ end.
+
+(* The inverse of gen_phiZ *)
+ Ltac inv_gen_phiZ rO rI add mul opp t :=
+ match t with
+ rO => constr:0%Z
+ | (opp ?p) =>
+ match inv_gen_phi_pos rI add mul p with
+ NotConstant => constr:NotConstant
+ | ?p => constr:(Zneg p)
+ end
+ | _ =>
+ match inv_gen_phi_pos rI add mul t with
+ NotConstant => constr:NotConstant
+ | ?p => constr:(Zpos p)
+ end
+ end.
+
+(* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above
+ are only optimisations that directly returns the reifid constant
+ instead of resorting to the constant propagation of the simplification
+ algorithm. *)
+Ltac inv_gen_phi rO rI cO cI t :=
+ match t with
+ | rO => cO
+ | rI => cI
+ end.
+
+(* A simple tactic recognizing no constant *)
+ Ltac inv_morph_nothing t := constr:NotConstant.
+
+Ltac coerce_to_almost_ring set ext rspec :=
+ match type of rspec with
+ | ring_theory _ _ _ _ _ _ _ => constr:(Rth_ARth set ext rspec)
+ | semi_ring_theory _ _ _ _ _ => constr:(SRth_ARth set rspec)
+ | almost_ring_theory _ _ _ _ _ _ _ => rspec
+ | _ => fail 1 "not a valid ring theory"
+ end.
+
+Ltac coerce_to_ring_ext ext :=
+ match type of ext with
+ | ring_eq_ext _ _ _ _ => ext
+ | sring_eq_ext _ _ _ => constr:(SReqe_Reqe ext)
+ | _ => fail 1 "not a valid ring_eq_ext theory"
+ end.
+
+Ltac abstract_ring_morphism set ext rspec :=
+ match type of rspec with
+ | ring_theory _ _ _ _ _ _ _ => constr:(gen_phiZ_morph set ext rspec)
+ | semi_ring_theory _ _ _ _ _ => constr:(gen_phiN_morph set ext rspec)
+ | almost_ring_theory _ _ _ _ _ _ _ =>
+ constr:(gen_phiNword_morph set ext rspec)
+ | _ => fail 1 "bad ring structure"
+ end.
+
+Record hypo : Type := mkhypo {
+ hypo_type : Type;
+ hypo_proof : hypo_type
+ }.
+
+Ltac gen_ring_pow set arth pspec :=
+ match pspec with
+ | None =>
+ match type of arth with
+ | @almost_ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req =>
+ constr:(mkhypo (@pow_N_th R rI rmul req set))
+ | _ => fail 1 "gen_ring_pow"
+ end
+ | Some ?t => constr:(t)
+ end.
+
+Ltac gen_ring_sign morph sspec :=
+ match sspec with
+ | None =>
+ match type of morph with
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
+ Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi =>
+ constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th)
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
+ ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi =>
+ constr:(mkhypo (@get_sign_None_th C copp ceqb))
+ | _ => fail 2 "ring anomaly : default_sign_spec"
+ end
+ | Some ?t => constr:(t)
+ end.
+
+Ltac default_div_spec set reqe arth morph :=
+ match type of morph with
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
+ Z ?c0 ?c1 Zplus Zmult ?csub ?copp ?ceq_b ?phi =>
+ constr:(mkhypo (Ztriv_div_th set phi))
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
+ N ?c0 ?c1 Nplus Nmult ?csub ?copp ?ceq_b ?phi =>
+ constr:(mkhypo (Ntriv_div_th set phi))
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
+ ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi =>
+ constr:(mkhypo (triv_div_th set reqe arth morph))
+ | _ => fail 1 "ring anomaly : default_sign_spec"
+ end.
+
+Ltac gen_ring_div set reqe arth morph dspec :=
+ match dspec with
+ | None => default_div_spec set reqe arth morph
+ | Some ?t => constr:(t)
+ end.
+
+Ltac ring_elements set ext rspec pspec sspec dspec rk :=
+ let arth := coerce_to_almost_ring set ext rspec in
+ let ext_r := coerce_to_ring_ext ext in
+ let morph :=
+ match rk with
+ | Abstract => abstract_ring_morphism set ext rspec
+ | @Computational ?reqb_ok =>
+ match type of arth with
+ | almost_ring_theory ?rO ?rI ?add ?mul ?sub ?opp _ =>
+ constr:(IDmorph rO rI add mul sub opp set _ reqb_ok)
+ | _ => fail 2 "ring anomaly"
+ end
+ | @Morphism ?m =>
+ match type of m with
+ | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m
+ | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ =>
+ constr:(SRmorph_Rmorph set m)
+ | _ => fail 2 "ring anomaly"
+ end
+ | _ => fail 1 "ill-formed ring kind"
+ end in
+ let p_spec := gen_ring_pow set arth pspec in
+ let s_spec := gen_ring_sign morph sspec in
+ let d_spec := gen_ring_div set ext_r arth morph dspec in
+ fun f => f arth ext_r morph p_spec s_spec d_spec.
+
+(* Given a ring structure and the kind of morphism,
+ returns 2 lemmas (one for ring, and one for ring_simplify). *)
+
+ Ltac ring_lemmas set ext rspec pspec sspec dspec rk :=
+ let gen_lemma2 :=
+ match pspec with
+ | None => constr:(ring_rw_correct)
+ | Some _ => constr:(ring_rw_pow_correct)
+ end in
+ ring_elements set ext rspec pspec sspec dspec rk
+ ltac:(fun arth ext_r morph p_spec s_spec d_spec =>
+ match type of morph with
+ | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req
+ ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi =>
+ let gen_lemma2_0 :=
+ constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth
+ C c0 c1 cadd cmul csub copp ceq_b phi morph) in
+ match p_spec with
+ | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec =>
+ let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in
+ match d_spec with
+ | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec =>
+ let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in
+ match s_spec with
+ | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec =>
+ let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in
+ let lemma1 :=
+ constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in
+ fun f => f arth ext_r morph lemma1 lemma2
+ | _ => fail 4 "ring: bad sign specification"
+ end
+ | _ => fail 3 "ring: bad coefficiant division specification"
+ end
+ | _ => fail 2 "ring: bad power specification"
+ end
+ | _ => fail 1 "ring internal error: ring_lemmas, please report"
+ end).
+
+(* Tactic for constant *)
+Ltac isnatcst t :=
+ match t with
+ O => constr:true
+ | S ?p => isnatcst p
+ | _ => constr:false
+ end.
+
+Ltac isPcst t :=
+ match t with
+ | xI ?p => isPcst p
+ | xO ?p => isPcst p
+ | xH => constr:true
+ (* nat -> positive *)
+ | P_of_succ_nat ?n => isnatcst n
+ | _ => constr:false
+ end.
+
+Ltac isNcst t :=
+ match t with
+ N0 => constr:true
+ | Npos ?p => isPcst p
+ | _ => constr:false
+ end.
+
+Ltac isZcst t :=
+ match t with
+ Z0 => constr:true
+ | Zpos ?p => isPcst p
+ | Zneg ?p => isPcst p
+ (* injection nat -> Z *)
+ | Z_of_nat ?n => isnatcst n
+ (* injection N -> Z *)
+ | Z_of_N ?n => isNcst n
+ (* *)
+ | _ => constr:false
+ end.
+
+
+
+
+
diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
new file mode 100644
index 00000000..0ba519fd
--- /dev/null
+++ b/plugins/setoid_ring/NArithRing.v
@@ -0,0 +1,21 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Export Ring.
+Require Import BinPos BinNat.
+Import InitialRing.
+
+Set Implicit Arguments.
+
+Ltac Ncst t :=
+ match isNcst t with
+ true => t
+ | _ => constr:NotConstant
+ end.
+
+Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]).
diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v
new file mode 100644
index 00000000..56473adb
--- /dev/null
+++ b/plugins/setoid_ring/RealField.v
@@ -0,0 +1,134 @@
+Require Import Nnat.
+Require Import ArithRing.
+Require Export Ring Field.
+Require Import Rdefinitions.
+Require Import Rpow_def.
+Require Import Raxioms.
+
+Open Local Scope R_scope.
+
+Lemma RTheory : ring_theory 0 1 Rplus Rmult Rminus Ropp (eq (A:=R)).
+Proof.
+constructor.
+ intro; apply Rplus_0_l.
+ exact Rplus_comm.
+ symmetry in |- *; apply Rplus_assoc.
+ intro; apply Rmult_1_l.
+ exact Rmult_comm.
+ symmetry in |- *; apply Rmult_assoc.
+ intros m n p.
+ rewrite Rmult_comm in |- *.
+ rewrite (Rmult_comm n p) in |- *.
+ rewrite (Rmult_comm m p) in |- *.
+ apply Rmult_plus_distr_l.
+ reflexivity.
+ exact Rplus_opp_r.
+Qed.
+
+Lemma Rfield : field_theory 0 1 Rplus Rmult Rminus Ropp Rdiv Rinv (eq(A:=R)).
+Proof.
+constructor.
+ exact RTheory.
+ exact R1_neq_R0.
+ reflexivity.
+ exact Rinv_l.
+Qed.
+
+Lemma Rlt_n_Sn : forall x, x < x + 1.
+Proof.
+intro.
+elim archimed with x; intros.
+destruct H0.
+ apply Rlt_trans with (IZR (up x)); trivial.
+ replace (IZR (up x)) with (x + (IZR (up x) - x))%R.
+ apply Rplus_lt_compat_l; trivial.
+ unfold Rminus in |- *.
+ rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
+ rewrite <- Rplus_assoc in |- *.
+ rewrite Rplus_opp_r in |- *.
+ apply Rplus_0_l.
+ elim H0.
+ unfold Rminus in |- *.
+ rewrite (Rplus_comm (IZR (up x)) (- x)) in |- *.
+ rewrite <- Rplus_assoc in |- *.
+ rewrite Rplus_opp_r in |- *.
+ rewrite Rplus_0_l in |- *; trivial.
+Qed.
+
+Notation Rset := (Eqsth R).
+Notation Rext := (Eq_ext Rplus Rmult Ropp).
+
+Lemma Rlt_0_2 : 0 < 2.
+apply Rlt_trans with (0 + 1).
+ apply Rlt_n_Sn.
+ rewrite Rplus_comm in |- *.
+ apply Rplus_lt_compat_l.
+ replace 1 with (0 + 1).
+ apply Rlt_n_Sn.
+ apply Rplus_0_l.
+Qed.
+
+Lemma Rgen_phiPOS : forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x > 0.
+unfold Rgt in |- *.
+induction x; simpl in |- *; intros.
+ apply Rlt_trans with (1 + 0).
+ rewrite Rplus_comm in |- *.
+ apply Rlt_n_Sn.
+ apply Rplus_lt_compat_l.
+ rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
+ rewrite Rmult_comm in |- *.
+ apply Rmult_lt_compat_l.
+ apply Rlt_0_2.
+ trivial.
+ rewrite <- (Rmul_0_l Rset Rext RTheory 2) in |- *.
+ rewrite Rmult_comm in |- *.
+ apply Rmult_lt_compat_l.
+ apply Rlt_0_2.
+ trivial.
+ replace 1 with (0 + 1).
+ apply Rlt_n_Sn.
+ apply Rplus_0_l.
+Qed.
+
+
+Lemma Rgen_phiPOS_not_0 :
+ forall x, InitialRing.gen_phiPOS1 1 Rplus Rmult x <> 0.
+red in |- *; intros.
+specialize (Rgen_phiPOS x).
+rewrite H in |- *; intro.
+apply (Rlt_asym 0 0); trivial.
+Qed.
+
+Lemma Zeq_bool_complete : forall x y,
+ InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x =
+ InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y ->
+ Zeq_bool x y = true.
+Proof gen_phiZ_complete Rset Rext Rfield Rgen_phiPOS_not_0.
+
+Lemma Rdef_pow_add : forall (x:R) (n m:nat), pow x (n + m) = pow x n * pow x m.
+Proof.
+ intros x n; elim n; simpl in |- *; auto with real.
+ intros n0 H' m; rewrite H'; auto with real.
+Qed.
+
+Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R)) nat_of_N pow.
+Proof.
+ constructor. destruct n. reflexivity.
+ simpl. induction p;simpl.
+ rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity.
+ unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial.
+ rewrite Rmult_comm;apply Rmult_1_l.
+Qed.
+
+Ltac Rpow_tac t :=
+ match isnatcst t with
+ | false => constr:(InitialRing.NotConstant)
+ | _ => constr:(N_of_nat t)
+ end.
+
+Add Field RField : Rfield
+ (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]).
+
+
+
+
diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
new file mode 100644
index 00000000..d01b1625
--- /dev/null
+++ b/plugins/setoid_ring/Ring.v
@@ -0,0 +1,44 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Import Bool.
+Require Export Ring_theory.
+Require Export Ring_base.
+Require Export InitialRing.
+Require Export Ring_tac.
+
+Lemma BoolTheory :
+ ring_theory false true xorb andb xorb (fun b:bool => b) (eq(A:=bool)).
+split; simpl in |- *.
+destruct x; reflexivity.
+destruct x; destruct y; reflexivity.
+destruct x; destruct y; destruct z; reflexivity.
+reflexivity.
+destruct x; destruct y; reflexivity.
+destruct x; destruct y; reflexivity.
+destruct x; destruct y; destruct z; reflexivity.
+reflexivity.
+destruct x; reflexivity.
+Qed.
+
+Definition bool_eq (b1 b2:bool) :=
+ if b1 then b2 else negb b2.
+
+Lemma bool_eq_ok : forall b1 b2, bool_eq b1 b2 = true -> b1 = b2.
+destruct b1; destruct b2; auto.
+Qed.
+
+Ltac bool_cst t :=
+ let t := eval hnf in t in
+ match t with
+ true => constr:true
+ | false => constr:false
+ | _ => constr:NotConstant
+ end.
+
+Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/plugins/setoid_ring/Ring_base.v b/plugins/setoid_ring/Ring_base.v
new file mode 100644
index 00000000..fd9dd8d0
--- /dev/null
+++ b/plugins/setoid_ring/Ring_base.v
@@ -0,0 +1,17 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* This module gathers the necessary base to build an instance of the
+ ring tactic. Abstract rings need more theory, depending on
+ ZArith_base. *)
+
+Require Import Quote.
+Declare ML Module "newring_plugin".
+Require Export Ring_theory.
+Require Export Ring_tac.
+Require Import InitialRing.
diff --git a/plugins/setoid_ring/Ring_equiv.v b/plugins/setoid_ring/Ring_equiv.v
new file mode 100644
index 00000000..945f6c68
--- /dev/null
+++ b/plugins/setoid_ring/Ring_equiv.v
@@ -0,0 +1,74 @@
+Require Import Setoid_ring_theory.
+Require Import LegacyRing_theory.
+Require Import Ring_theory.
+
+Set Implicit Arguments.
+
+Section Old2New.
+
+Variable A : Type.
+
+Variable Aplus : A -> A -> A.
+Variable Amult : A -> A -> A.
+Variable Aone : A.
+Variable Azero : A.
+Variable Aopp : A -> A.
+Variable Aeq : A -> A -> bool.
+Variable R : Ring_Theory Aplus Amult Aone Azero Aopp Aeq.
+
+Let Aminus := fun x y => Aplus x (Aopp y).
+
+Lemma ring_equiv1 :
+ ring_theory Azero Aone Aplus Amult Aminus Aopp (eq (A:=A)).
+Proof.
+destruct R.
+split; eauto.
+Qed.
+
+End Old2New.
+
+Section New2OldRing.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable Rth : ring_theory rO rI radd rmul rsub ropp (eq (A:=R)).
+
+ Variable reqb : R -> R -> bool.
+ Variable reqb_ok : forall x y, reqb x y = true -> x = y.
+
+ Lemma ring_equiv2 :
+ Ring_Theory radd rmul rI rO ropp reqb.
+Proof.
+elim Rth; intros; constructor; eauto.
+intros.
+apply reqb_ok.
+destruct (reqb x y); trivial; intros.
+elim H.
+Qed.
+
+ Definition default_eqb : R -> R -> bool := fun x y => false.
+ Lemma default_eqb_ok : forall x y, default_eqb x y = true -> x = y.
+Proof.
+discriminate 1.
+Qed.
+
+End New2OldRing.
+
+Section New2OldSemiRing.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul: R->R->R).
+ Variable SRth : semi_ring_theory rO rI radd rmul (eq (A:=R)).
+
+ Variable reqb : R -> R -> bool.
+ Variable reqb_ok : forall x y, reqb x y = true -> x = y.
+
+ Lemma sring_equiv2 :
+ Semi_Ring_Theory radd rmul rI rO reqb.
+Proof.
+elim SRth; intros; constructor; eauto.
+intros.
+apply reqb_ok.
+destruct (reqb x y); trivial; intros.
+elim H.
+Qed.
+
+End New2OldSemiRing.
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
new file mode 100644
index 00000000..faa83ded
--- /dev/null
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -0,0 +1,1781 @@
+(************************************************************************)
+(* V * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinList.
+Require Import BinPos.
+Require Import BinNat.
+Require Import BinInt.
+Require Export Ring_theory.
+
+Open Local Scope positive_scope.
+Import RingSyntax.
+
+Section MakeRingPol.
+
+ (* Ring elements *)
+ Variable R:Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R).
+ Variable req : R -> R -> Prop.
+
+ (* Ring properties *)
+ Variable Rsth : Setoid_Theory R req.
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req.
+
+ (* Coefficients *)
+ Variable C: Type.
+ Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool.
+ Variable phi : C -> R.
+ Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req
+ cO cI cadd cmul csub copp ceqb phi.
+
+ (* Power coefficients *)
+ Variable Cpow : Set.
+ Variable Cp_phi : N -> Cpow.
+ Variable rpow : R -> Cpow -> R.
+ Variable pow_th : power_theory rI rmul req Cp_phi rpow.
+
+ (* division is ok *)
+ Variable cdiv: C -> C -> C * C.
+ Variable div_th: div_theory req cadd cmul phi cdiv.
+
+
+ (* R notations *)
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+
+ (* C notations *)
+ Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
+ Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
+ Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+
+ (* Useful tactics *)
+ Add Setoid R req Rsth as R_set1.
+ Ltac rrefl := gen_reflexivity Rsth.
+ Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed.
+ Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed.
+ Ltac rsimpl := gen_srewrite Rsth Reqe ARth.
+ Ltac add_push := gen_add_push radd Rsth Reqe ARth.
+ Ltac mul_push := gen_mul_push rmul Rsth Reqe ARth.
+
+ (* Definition of multivariable polynomials with coefficients in C :
+ Type [Pol] represents [X1 ... Xn].
+ The representation is Horner's where a [n] variable polynomial
+ (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients
+ are polynomials with [n-1] variables (C[X2..Xn]).
+ There are several optimisations to make the repr compacter:
+ - [Pc c] is the constant polynomial of value c
+ == c*X1^0*..*Xn^0
+ - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables.
+ variable indices are shifted of j in Q.
+ == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn}
+ - [PX P i Q] is an optimised Horner form of P*X^i + Q
+ with P not the null polynomial
+ == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn}
+
+ In addition:
+ - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden
+ since they can be represented by the simpler form (PX P (i+j) Q)
+ - (Pinj i (Pinj j P)) is (Pinj (i+j) P)
+ - (Pinj i (Pc c)) is (Pc c)
+ *)
+
+ Inductive Pol : Type :=
+ | Pc : C -> Pol
+ | Pinj : positive -> Pol -> Pol
+ | PX : Pol -> positive -> Pol -> Pol.
+
+ Definition P0 := Pc cO.
+ Definition P1 := Pc cI.
+
+ Fixpoint Peq (P P' : Pol) {struct P'} : bool :=
+ match P, P' with
+ | Pc c, Pc c' => c ?=! c'
+ | Pinj j Q, Pinj j' Q' =>
+ match Pcompare j j' Eq with
+ | Eq => Peq Q Q'
+ | _ => false
+ end
+ | PX P i Q, PX P' i' Q' =>
+ match Pcompare i i' Eq with
+ | Eq => if Peq P P' then Peq Q Q' else false
+ | _ => false
+ end
+ | _, _ => false
+ end.
+
+ Notation " P ?== P' " := (Peq P P').
+
+ Definition mkPinj j P :=
+ match P with
+ | Pc _ => P
+ | Pinj j' Q => Pinj ((j + j'):positive) Q
+ | _ => Pinj j P
+ end.
+
+ Definition mkPinj_pred j P:=
+ match j with
+ | xH => P
+ | xO j => Pinj (Pdouble_minus_one j) P
+ | xI j => Pinj (xO j) P
+ end.
+
+ Definition mkPX P i Q :=
+ match P with
+ | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q
+ | Pinj _ _ => PX P i Q
+ | PX P' i' Q' => if Q' ?== P0 then PX P' (i' + i) Q else PX P i Q
+ end.
+
+ Definition mkXi i := PX P1 i P0.
+
+ Definition mkX := mkXi 1.
+
+ (** Opposite of addition *)
+
+ Fixpoint Popp (P:Pol) : Pol :=
+ match P with
+ | Pc c => Pc (-! c)
+ | Pinj j Q => Pinj j (Popp Q)
+ | PX P i Q => PX (Popp P) i (Popp Q)
+ end.
+
+ Notation "-- P" := (Popp P).
+
+ (** Addition et subtraction *)
+
+ Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol :=
+ match P with
+ | Pc c1 => Pc (c1 +! c)
+ | Pinj j Q => Pinj j (PaddC Q c)
+ | PX P i Q => PX P i (PaddC Q c)
+ end.
+
+ Fixpoint PsubC (P:Pol) (c:C) {struct P} : Pol :=
+ match P with
+ | Pc c1 => Pc (c1 -! c)
+ | Pinj j Q => Pinj j (PsubC Q c)
+ | PX P i Q => PX P i (PsubC Q c)
+ end.
+
+ Section PopI.
+
+ Variable Pop : Pol -> Pol -> Pol.
+ Variable Q : Pol.
+
+ Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol :=
+ match P with
+ | Pc c => mkPinj j (PaddC Q c)
+ | Pinj j' Q' =>
+ match ZPminus j' j with
+ | Zpos k => mkPinj j (Pop (Pinj k Q') Q)
+ | Z0 => mkPinj j (Pop Q' Q)
+ | Zneg k => mkPinj j' (PaddI k Q')
+ end
+ | PX P i Q' =>
+ match j with
+ | xH => PX P i (Pop Q' Q)
+ | xO j => PX P i (PaddI (Pdouble_minus_one j) Q')
+ | xI j => PX P i (PaddI (xO j) Q')
+ end
+ end.
+
+ Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol :=
+ match P with
+ | Pc c => mkPinj j (PaddC (--Q) c)
+ | Pinj j' Q' =>
+ match ZPminus j' j with
+ | Zpos k => mkPinj j (Pop (Pinj k Q') Q)
+ | Z0 => mkPinj j (Pop Q' Q)
+ | Zneg k => mkPinj j' (PsubI k Q')
+ end
+ | PX P i Q' =>
+ match j with
+ | xH => PX P i (Pop Q' Q)
+ | xO j => PX P i (PsubI (Pdouble_minus_one j) Q')
+ | xI j => PX P i (PsubI (xO j) Q')
+ end
+ end.
+
+ Variable P' : Pol.
+
+ Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol :=
+ match P with
+ | Pc c => PX P' i' P
+ | Pinj j Q' =>
+ match j with
+ | xH => PX P' i' Q'
+ | xO j => PX P' i' (Pinj (Pdouble_minus_one j) Q')
+ | xI j => PX P' i' (Pinj (xO j) Q')
+ end
+ | PX P i Q' =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+ | Z0 => mkPX (Pop P P') i Q'
+ | Zneg k => mkPX (PaddX k P) i Q'
+ end
+ end.
+
+ Fixpoint PsubX (i':positive) (P:Pol) {struct P} : Pol :=
+ match P with
+ | Pc c => PX (--P') i' P
+ | Pinj j Q' =>
+ match j with
+ | xH => PX (--P') i' Q'
+ | xO j => PX (--P') i' (Pinj (Pdouble_minus_one j) Q')
+ | xI j => PX (--P') i' (Pinj (xO j) Q')
+ end
+ | PX P i Q' =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Pop (PX P k P0) P') i' Q'
+ | Z0 => mkPX (Pop P P') i Q'
+ | Zneg k => mkPX (PsubX k P) i Q'
+ end
+ end.
+
+
+ End PopI.
+
+ Fixpoint Padd (P P': Pol) {struct P'} : Pol :=
+ match P' with
+ | Pc c' => PaddC P c'
+ | Pinj j' Q' => PaddI Padd Q' j' P
+ | PX P' i' Q' =>
+ match P with
+ | Pc c => PX P' i' (PaddC Q' c)
+ | Pinj j Q =>
+ match j with
+ | xH => PX P' i' (Padd Q Q')
+ | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q')
+ | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q')
+ end
+ | PX P i Q =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q')
+ | Z0 => mkPX (Padd P P') i (Padd Q Q')
+ | Zneg k => mkPX (PaddX Padd P' k P) i (Padd Q Q')
+ end
+ end
+ end.
+ Notation "P ++ P'" := (Padd P P').
+
+ Fixpoint Psub (P P': Pol) {struct P'} : Pol :=
+ match P' with
+ | Pc c' => PsubC P c'
+ | Pinj j' Q' => PsubI Psub Q' j' P
+ | PX P' i' Q' =>
+ match P with
+ | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c)
+ | Pinj j Q =>
+ match j with
+ | xH => PX (--P') i' (Psub Q Q')
+ | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q')
+ | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q')
+ end
+ | PX P i Q =>
+ match ZPminus i i' with
+ | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q')
+ | Z0 => mkPX (Psub P P') i (Psub Q Q')
+ | Zneg k => mkPX (PsubX Psub P' k P) i (Psub Q Q')
+ end
+ end
+ end.
+ Notation "P -- P'" := (Psub P P').
+
+ (** Multiplication *)
+
+ Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol :=
+ match P with
+ | Pc c' => Pc (c' *! c)
+ | Pinj j Q => mkPinj j (PmulC_aux Q c)
+ | PX P i Q => mkPX (PmulC_aux P c) i (PmulC_aux Q c)
+ end.
+
+ Definition PmulC P c :=
+ if c ?=! cO then P0 else
+ if c ?=! cI then P else PmulC_aux P c.
+
+ Section PmulI.
+ Variable Pmul : Pol -> Pol -> Pol.
+ Variable Q : Pol.
+ Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol :=
+ match P with
+ | Pc c => mkPinj j (PmulC Q c)
+ | Pinj j' Q' =>
+ match ZPminus j' j with
+ | Zpos k => mkPinj j (Pmul (Pinj k Q') Q)
+ | Z0 => mkPinj j (Pmul Q' Q)
+ | Zneg k => mkPinj j' (PmulI k Q')
+ end
+ | PX P' i' Q' =>
+ match j with
+ | xH => mkPX (PmulI xH P') i' (Pmul Q' Q)
+ | xO j' => mkPX (PmulI j P') i' (PmulI (Pdouble_minus_one j') Q')
+ | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q')
+ end
+ end.
+
+ End PmulI.
+(* A symmetric version of the multiplication *)
+
+ Fixpoint Pmul (P P'' : Pol) {struct P''} : Pol :=
+ match P'' with
+ | Pc c => PmulC P c
+ | Pinj j' Q' => PmulI Pmul Q' j' P
+ | PX P' i' Q' =>
+ match P with
+ | Pc c => PmulC P'' c
+ | Pinj j Q =>
+ let QQ' :=
+ match j with
+ | xH => Pmul Q Q'
+ | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q'
+ | xI j => Pmul (Pinj (xO j) Q) Q'
+ end in
+ mkPX (Pmul P P') i' QQ'
+ | PX P i Q=>
+ let QQ' := Pmul Q Q' in
+ let PQ' := PmulI Pmul Q' xH P in
+ let QP' := Pmul (mkPinj xH Q) P' in
+ let PP' := Pmul P P' in
+ (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ'
+ end
+ end.
+
+(* Non symmetric *)
+(*
+ Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol :=
+ match P' with
+ | Pc c' => PmulC P c'
+ | Pinj j' Q' => PmulI Pmul_aux Q' j' P
+ | PX P' i' Q' =>
+ (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P)
+ end.
+
+ Definition Pmul P P' :=
+ match P with
+ | Pc c => PmulC P' c
+ | Pinj j Q => PmulI Pmul_aux Q j P'
+ | PX P i Q =>
+ (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P')
+ end.
+*)
+ Notation "P ** P'" := (Pmul P P').
+
+ Fixpoint Psquare (P:Pol) : Pol :=
+ match P with
+ | Pc c => Pc (c *! c)
+ | Pinj j Q => Pinj j (Psquare Q)
+ | PX P i Q =>
+ let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in
+ let Q2 := Psquare Q in
+ let P2 := Psquare P in
+ mkPX (mkPX P2 i P0 ++ twoPQ) i Q2
+ end.
+
+ (** Monomial **)
+
+ Inductive Mon: Set :=
+ mon0: Mon
+ | zmon: positive -> Mon -> Mon
+ | vmon: positive -> Mon -> Mon.
+
+ Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R :=
+ match M with
+ mon0 => rI
+ | zmon j M1 => Mphi (jump j l) M1
+ | vmon i M1 =>
+ let x := hd 0 l in
+ let xi := pow_pos rmul x i in
+ (Mphi (tail l) M1) * xi
+ end.
+
+ Definition mkZmon j M :=
+ match M with mon0 => mon0 | _ => zmon j M end.
+
+ Definition zmon_pred j M :=
+ match j with xH => M | _ => mkZmon (Ppred j) M end.
+
+ Definition mkVmon i M :=
+ match M with
+ | mon0 => vmon i mon0
+ | zmon j m => vmon i (zmon_pred j m)
+ | vmon i' m => vmon (i+i') m
+ end.
+
+ Fixpoint CFactor (P: Pol) (c: C) {struct P}: Pol * Pol :=
+ match P with
+ | Pc c1 => let (q,r) := cdiv c1 c in (Pc r, Pc q)
+ | Pinj j1 P1 =>
+ let (R,S) := CFactor P1 c in
+ (mkPinj j1 R, mkPinj j1 S)
+ | PX P1 i Q1 =>
+ let (R1, S1) := CFactor P1 c in
+ let (R2, S2) := CFactor Q1 c in
+ (mkPX R1 i R2, mkPX S1 i S2)
+ end.
+
+ Fixpoint MFactor (P: Pol) (c: C) (M: Mon) {struct P}: Pol * Pol :=
+ match P, M with
+ _, mon0 =>
+ if (ceqb c cI) then (Pc cO, P) else
+(* if (ceqb c (copp cI)) then (Pc cO, Popp P) else Not in almost ring *)
+ CFactor P c
+ | Pc _, _ => (P, Pc cO)
+ | Pinj j1 P1, zmon j2 M1 =>
+ match (j1 ?= j2) Eq 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
+ (mkPinj j1 R, mkPinj j1 S)
+ | Gt => (P, Pc cO)
+ end
+ | Pinj _ _, vmon _ _ => (P, Pc cO)
+ | PX P1 i Q1, zmon j M1 =>
+ let M2 := zmon_pred j M1 in
+ let (R1, S1) := MFactor P1 c M in
+ 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
+ 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
+ (mkPX R1 i Q1, S1)
+ | Gt => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in
+ (mkPX R1 i Q1, mkPX S1 (i-j) (Pc cO))
+ end
+ end.
+
+ Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol :=
+ let (c,M1) := cM1 in
+ let (Q1,R1) := MFactor P1 c M1 in
+ match R1 with
+ (Pc c) => if c ?=! cO then None
+ else Some (Padd Q1 (Pmul P2 R1))
+ | _ => Some (Padd Q1 (Pmul P2 R1))
+ end.
+
+ Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol :=
+ match POneSubst P1 cM1 P2 with
+ Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end
+ | _ => P1
+ end.
+
+ Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol :=
+ match POneSubst P1 cM1 P2 with
+ Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end
+ | _ => None
+ end.
+
+ Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}:
+ Pol :=
+ match LM1 with
+ cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n
+ | _ => P1
+ end.
+
+ Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol :=
+ match LM1 with
+ cons (M1,P2) LM2 =>
+ match PNSubst P1 M1 P2 n with
+ Some P3 => Some (PSubstL1 P3 LM2 n)
+ | None => PSubstL P1 LM2 n
+ end
+ | _ => None
+ end.
+
+ Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol :=
+ match PSubstL P1 LM1 n with
+ Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end
+ | _ => P1
+ end.
+
+ (** Evaluation of a polynomial towards R *)
+
+ Fixpoint Pphi(l:list R) (P:Pol) {struct P} : R :=
+ match P with
+ | Pc c => [c]
+ | Pinj j Q => Pphi (jump j l) Q
+ | PX P i Q =>
+ let x := hd 0 l in
+ let xi := pow_pos rmul x i in
+ (Pphi l P) * xi + (Pphi (tail l) Q)
+ 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 (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+ replace (ZPminus (xI x) (xO y)) with (Zdouble_plus_one (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_plus_one;rewrite H;trivial.
+ apply Pplus_xI_double_minus_one.
+ simpl;trivial.
+ replace (ZPminus (xO x) (xI y)) with (Zdouble_minus_one (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble_minus_one;rewrite H;trivial.
+ apply Pplus_xI_double_minus_one.
+ replace (ZPminus (xO x) (xO y)) with (Zdouble (ZPminus x y));trivial.
+ assert (H := IHx y);destruct (ZPminus x y);unfold Zdouble;rewrite H;trivial.
+ replace (ZPminus (xO x) xH) with (Zpos (Pdouble_minus_one x));trivial.
+ rewrite <- Pplus_one_succ_l.
+ rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+ replace (ZPminus xH (xI y)) with (Zneg (xO y));trivial.
+ replace (ZPminus xH (xO y)) with (Zneg (Pdouble_minus_one y));trivial.
+ rewrite <- Pplus_one_succ_l.
+ rewrite Psucc_o_double_minus_one_eq_xO;trivial.
+ simpl;trivial.
+ 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 (morph_eq CRmorph);trivial.
+ assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+ try discriminate H.
+ rewrite (IHP P' H); rewrite H1;trivial;rrefl.
+ assert (H1 := Pcompare_Eq_eq p p0); destruct ((p ?= p0)%positive Eq);
+ try discriminate H.
+ rewrite H1;trivial. clear H1.
+ assert (H1 := IHP1 P'1);assert (H2 := IHP2 P'2);
+ destruct (P2 ?== P'1);[destruct (P3 ?== P'2); [idtac|discriminate H]
+ |discriminate H].
+ rewrite (H1 H);rewrite (H2 H);rrefl.
+ Qed.
+
+ Lemma Pphi0 : forall l, P0@l == 0.
+ Proof.
+ intros;simpl;apply (morph0 CRmorph).
+ Qed.
+
+ Lemma Pphi1 : forall l, P1@l == 1.
+ Proof.
+ intros;simpl;apply (morph1 CRmorph).
+ Qed.
+
+ Lemma mkPinj_ok : forall j l P, (mkPinj j P)@l == P@(jump j l).
+ Proof.
+ intros j l p;destruct p;simpl;rsimpl.
+ rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl.
+ Qed.
+
+ Let pow_pos_Pplus :=
+ pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc).
+
+ Lemma mkPX_ok : forall l P i Q,
+ (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l).
+ Proof.
+ intros l P i Q;unfold mkPX.
+ destruct P;try (simpl;rrefl).
+ assert (H := morph_eq CRmorph c cO);destruct (c ?=! cO);simpl;try rrefl.
+ rewrite (H (refl_equal true));rewrite (morph0 CRmorph).
+ rewrite mkPinj_ok;rsimpl;simpl;rrefl.
+ assert (H := @Peq_ok P3 P0);destruct (P3 ?== P0);simpl;try rrefl.
+ rewrite (H (refl_equal true));trivial.
+ rewrite Pphi0. rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+ Ltac Esimpl :=
+ repeat (progress (
+ match goal with
+ | |- context [?P@?l] =>
+ match P with
+ | P0 => rewrite (Pphi0 l)
+ | P1 => rewrite (Pphi1 l)
+ | (mkPinj ?j ?P) => rewrite (mkPinj_ok j l P)
+ | (mkPX ?P ?i ?Q) => rewrite (mkPX_ok l P i Q)
+ end
+ | |- context [[?c]] =>
+ match c with
+ | cO => rewrite (morph0 CRmorph)
+ | cI => rewrite (morph1 CRmorph)
+ | ?x +! ?y => rewrite ((morph_add CRmorph) x y)
+ | ?x *! ?y => rewrite ((morph_mul CRmorph) x y)
+ | ?x -! ?y => rewrite ((morph_sub CRmorph) x y)
+ | -! ?x => rewrite ((morph_opp CRmorph) x)
+ end
+ end));
+ rsimpl; simpl.
+
+ Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c].
+ Proof.
+ induction P;simpl;intros;Esimpl;trivial.
+ rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PsubC_ok : forall c P l, (PsubC P c)@l == P@l - [c].
+ Proof.
+ induction P;simpl;intros.
+ Esimpl.
+ rewrite IHP;rsimpl.
+ rewrite IHP2;rsimpl.
+ Qed.
+
+ Lemma PmulC_aux_ok : forall c P l, (PmulC_aux P c)@l == P@l * [c].
+ Proof.
+ induction P;simpl;intros;Esimpl;trivial.
+ rewrite IHP1;rewrite IHP2;rsimpl.
+ mul_push ([c]);rrefl.
+ Qed.
+
+ Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c].
+ Proof.
+ intros c P l; unfold PmulC.
+ assert (H:= morph_eq CRmorph c cO);destruct (c ?=! cO).
+ rewrite (H (refl_equal true));Esimpl.
+ assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+ rewrite (H1 (refl_equal true));Esimpl.
+ apply PmulC_aux_ok.
+ Qed.
+
+ Lemma Popp_ok : forall P l, (--P)@l == - P@l.
+ Proof.
+ induction P;simpl;intros.
+ Esimpl.
+ apply IHP.
+ rewrite IHP1;rewrite IHP2;rsimpl.
+ Qed.
+
+ Ltac Esimpl2 :=
+ Esimpl;
+ repeat (progress (
+ match goal with
+ | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l)
+ | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l)
+ | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l)
+ | |- context [(--?P)@?l] => rewrite (Popp_ok P l)
+ end)); Esimpl.
+
+ Lemma Padd_ok : forall P' P l, (P ++ P')@l == P@l + P'@l.
+ Proof.
+ induction P';simpl;intros;Esimpl2.
+ generalize P p l;clear P p l.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARadd_comm ARth).
+ assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+ rewrite H;Esimpl. rewrite IHP';rrefl.
+ rewrite H;Esimpl. rewrite IHP';Esimpl.
+ rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
+ rewrite H;Esimpl. rewrite IHP.
+ rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
+ destruct p0;simpl.
+ rewrite IHP2;simpl;rsimpl.
+ rewrite IHP2;simpl.
+ rewrite jump_Pdouble_minus_one;rsimpl.
+ rewrite IHP';rsimpl.
+ destruct P;simpl.
+ Esimpl2;add_push [c];rrefl.
+ destruct p0;simpl;Esimpl2.
+ rewrite IHP'2;simpl.
+ rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+ rewrite IHP'2;simpl.
+ rewrite jump_Pdouble_minus_one;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));rrefl.
+ rewrite IHP'2;rsimpl. add_push (P @ (tail l));rrefl.
+ assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+ rewrite IHP'1;rewrite IHP'2;rsimpl.
+ add_push (P3 @ (tail l));rewrite H;rrefl.
+ rewrite IHP'1;rewrite IHP'2;simpl;Esimpl.
+ rewrite H;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;rsimpl.
+ add_push (P3 @ (tail l));rrefl.
+ assert (forall P k l,
+ (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k).
+ induction P;simpl;intros;try apply (ARadd_comm ARth).
+ destruct p2;simpl;try apply (ARadd_comm ARth).
+ rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth).
+ assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2.
+ rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl.
+ rewrite IHP'1;simpl;Esimpl.
+ rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;Esimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;rsimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite H0;rsimpl.
+ add_push (P3 @ (tail l)).
+ rewrite H;rewrite Pplus_comm.
+ rewrite IHP'2;rewrite pow_pos_Pplus;rsimpl.
+ add_push (P3 @ (tail l));rrefl.
+ Qed.
+
+ Lemma Psub_ok : forall P' P l, (P -- P')@l == P@l - P'@l.
+ Proof.
+ induction P';simpl;intros;Esimpl2;trivial.
+ generalize P p l;clear P p l.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARadd_comm ARth).
+ assert (H := ZPminus_spec p p0);destruct (ZPminus p p0).
+ rewrite H;Esimpl. rewrite IHP';rsimpl.
+ rewrite H;Esimpl. rewrite IHP';Esimpl.
+ rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
+ rewrite H;Esimpl. rewrite IHP.
+ rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl.
+ destruct p0;simpl.
+ rewrite IHP2;simpl;rsimpl.
+ rewrite IHP2;simpl.
+ rewrite jump_Pdouble_minus_one;rsimpl.
+ rewrite IHP';rsimpl.
+ destruct P;simpl.
+ repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl.
+ destruct p0;simpl;Esimpl2.
+ rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial.
+ add_push (P @ (jump p0 (jump p0 (tail l))));rrefl.
+ rewrite IHP'2;simpl;rewrite jump_Pdouble_minus_one;rsimpl.
+ add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl.
+ rewrite IHP'2;rsimpl;add_push (P @ (tail l));rrefl.
+ assert (H := ZPminus_spec p0 p);destruct (ZPminus p0 p);Esimpl2.
+ rewrite IHP'1; rewrite IHP'2;rsimpl.
+ add_push (P3 @ (tail l));rewrite H;rrefl.
+ rewrite IHP'1; rewrite IHP'2;rsimpl;simpl;Esimpl.
+ rewrite H;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;rsimpl.
+ add_push (P3 @ (tail l));rrefl.
+ assert (forall P k l,
+ (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k).
+ induction P;simpl;intros.
+ rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial.
+ destruct p2;simpl;rewrite Popp_ok;rsimpl.
+ apply (ARadd_comm ARth);trivial.
+ rewrite jump_Pdouble_minus_one;apply (ARadd_comm ARth);trivial.
+ apply (ARadd_comm ARth);trivial.
+ assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2;rsimpl.
+ rewrite IHP'1;rsimpl;add_push (P5 @ (tail l0));rewrite H1;rrefl.
+ rewrite IHP'1;rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;Esimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite IHP1;rewrite H1;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;simpl;rsimpl.
+ add_push (P5 @ (tail l0));rrefl.
+ rewrite H0;rsimpl.
+ rewrite IHP'2;rsimpl;add_push (P3 @ (tail l)).
+ rewrite H;rewrite Pplus_comm.
+ rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+(* Proof for the symmetriv version *)
+
+ Lemma PmulI_ok :
+ forall P',
+ (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) ->
+ forall (P : Pol) (p : positive) (l : list R),
+ (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARmul_comm ARth).
+ assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+ rewrite H1; rewrite H;rrefl.
+ rewrite H1; rewrite H.
+ rewrite Pplus_comm.
+ rewrite jump_Pplus;simpl;rrefl.
+ rewrite H1;rewrite Pplus_comm.
+ rewrite jump_Pplus;rewrite IHP;rrefl.
+ destruct p0;Esimpl2.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
+ rewrite IHP1;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p).
+ rewrite H;rrefl.
+ Qed.
+
+(*
+ Lemma PmulI_ok :
+ forall P',
+ (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) ->
+ forall (P : Pol) (p : positive) (l : list R),
+ (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l).
+ Proof.
+ induction P;simpl;intros.
+ Esimpl2;apply (ARmul_comm ARth).
+ assert (H1 := ZPminus_spec p p0);destruct (ZPminus p p0);Esimpl2.
+ rewrite H1; rewrite H;rrefl.
+ rewrite H1; rewrite H.
+ rewrite Pplus_comm.
+ rewrite jump_Pplus;simpl;rrefl.
+ rewrite H1;rewrite Pplus_comm.
+ rewrite jump_Pplus;rewrite IHP;rrefl.
+ destruct p0;Esimpl2.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p);rrefl.
+ rewrite IHP1;rewrite IHP2;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p); rewrite jump_Pdouble_minus_one;rrefl.
+ rewrite IHP1;simpl;rsimpl.
+ mul_push (pow_pos rmul (hd 0 l) p).
+ rewrite H;rrefl.
+ Qed.
+
+ Lemma Pmul_aux_ok : forall P' P l,(Pmul_aux P P')@l == P@l * P'@l.
+ Proof.
+ induction P';simpl;intros.
+ Esimpl2;trivial.
+ apply PmulI_ok;trivial.
+ rewrite Padd_ok;Esimpl2.
+ rewrite (PmulI_ok P'2 IHP'2). rewrite IHP'1. rrefl.
+ Qed.
+*)
+
+(* Proof for the symmetric version *)
+ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+ intros P P';generalize P;clear P;induction P';simpl;intros.
+ apply PmulC_ok. apply PmulI_ok;trivial.
+ destruct P.
+ rewrite (ARmul_comm ARth);Esimpl2;Esimpl2.
+ Esimpl2. rewrite IHP'1;Esimpl2.
+ assert (match p0 with
+ | xI j => Pinj (xO j) P ** P'2
+ | xO j => Pinj (Pdouble_minus_one j) P ** P'2
+ | 1 => P ** P'2
+ end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)).
+ destruct p0;simpl;rewrite IHP'2;Esimpl.
+ rewrite jump_Pdouble_minus_one;Esimpl.
+ rewrite H;Esimpl.
+ rewrite Padd_ok; Esimpl2. rewrite Padd_ok; Esimpl2.
+ repeat (rewrite IHP'1 || rewrite IHP'2);simpl.
+ rewrite PmulI_ok;trivial.
+ mul_push (P'1@l). simpl. mul_push (P'2 @ (tail l)). Esimpl.
+ Qed.
+
+(*
+Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
+ Proof.
+ destruct P;simpl;intros.
+ Esimpl2;apply (ARmul_comm ARth).
+ rewrite (PmulI_ok P (Pmul_aux_ok P)).
+ apply (ARmul_comm ARth).
+ rewrite Padd_ok; Esimpl2.
+ rewrite (PmulI_ok P3 (Pmul_aux_ok P3));trivial.
+ rewrite Pmul_aux_ok;mul_push (P' @ l).
+ rewrite (ARmul_comm ARth (P' @ l));rrefl.
+ Qed.
+*)
+
+ Lemma Psquare_ok : forall P l, (Psquare P)@l == P@l * P@l.
+ Proof.
+ induction P;simpl;intros;Esimpl2.
+ apply IHP. rewrite Padd_ok. rewrite Pmul_ok;Esimpl2.
+ rewrite IHP1;rewrite IHP2.
+ mul_push (pow_pos rmul (hd 0 l) p). mul_push (P2@l).
+ rrefl.
+ Qed.
+
+
+ Lemma mkZmon_ok: forall M j l,
+ Mphi l (mkZmon j M) == Mphi l (zmon j M).
+ intros M j l; case M; simpl; intros; rsimpl.
+ Qed.
+
+ Lemma zmon_pred_ok : forall M j l,
+ Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M).
+ Proof.
+ destruct j; simpl;intros auto; rsimpl.
+ rewrite mkZmon_ok;rsimpl.
+ rewrite mkZmon_ok;simpl. rewrite jump_Pdouble_minus_one; rsimpl.
+ Qed.
+
+ Lemma mkVmon_ok : forall M i l, Mphi l (mkVmon i M) == Mphi l M*pow_pos rmul (hd 0 l) i.
+ Proof.
+ destruct M;simpl;intros;rsimpl.
+ rewrite zmon_pred_ok;simpl;rsimpl.
+ rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl.
+ Qed.
+
+ Lemma Mcphi_ok: forall P c l,
+ let (Q,R) := CFactor P c in
+ P@l == Q@l + (phi c) * (R@l).
+ Proof.
+ intros P; elim P; simpl; auto; clear P.
+ intros c c1 l; generalize (div_th.(div_eucl_th) c c1); case cdiv.
+ intros q r H; rewrite H.
+ Esimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ intros i P Hrec c l.
+ generalize (Hrec c (jump i l)); case CFactor.
+ intros R1 S1; Esimpl; auto.
+ intros Q1 Qrec i R1 Rrec c l.
+ generalize (Qrec c l); case CFactor; intros S1 S2 HS.
+ generalize (Rrec c (tail l)); case CFactor; intros S3 S4 HS1.
+ rewrite HS; rewrite HS1; Esimpl.
+ apply (Radd_ext Reqe); rsimpl.
+ repeat rewrite <- (ARadd_assoc ARth).
+ apply (Radd_ext Reqe); rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ Qed.
+
+ Lemma Mphi_ok: forall P (cM: C * Mon) l,
+ let (c,M) := cM in
+ let (Q,R) := MFactor P c M in
+ P@l == Q@l + (phi c) * (Mphi l M) * (R@l).
+ Proof.
+ intros P; elim P; simpl; auto; clear P.
+ intros c (c1, M) l; case M; simpl; auto.
+ assert (H1:= morph_eq CRmorph c1 cI);destruct (c1 ?=! cI).
+ rewrite (H1 (refl_equal true));Esimpl.
+ try rewrite (morph0 CRmorph); rsimpl.
+ generalize (div_th.(div_eucl_th) c c1); case (cdiv c c1).
+ intros q r H; rewrite H; clear H H1.
+ Esimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ intros p m; Esimpl.
+ intros p m; Esimpl.
+ intros i P Hrec (c,M) l; case M; simpl; clear M.
+ assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+ rewrite (H1 (refl_equal true));Esimpl.
+ Esimpl.
+ generalize (Mcphi_ok P c (jump i l)); case CFactor.
+ intros R1 Q1 HH; rewrite HH; Esimpl.
+ intros j M.
+ case_eq ((i ?= j) Eq); intros He; simpl.
+ rewrite (Pcompare_Eq_eq _ _ He).
+ generalize (Hrec (c, M) (jump j l)); case (MFactor P c M);
+ simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+ generalize (Hrec (c, (zmon (j -i) M)) (jump i l));
+ case (MFactor P c (zmon (j -i) M)); simpl.
+ intros P2 Q2 H; repeat rewrite mkPinj_ok; auto.
+ rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)).
+ rewrite Pplus_comm; rewrite jump_Pplus; auto.
+ rewrite (morph0 CRmorph); rsimpl.
+ intros P2 m; rewrite (morph0 CRmorph); rsimpl.
+
+ intros P2 Hrec1 i Q2 Hrec2 (c, M) l; case M; simpl; auto.
+ assert (H1:= morph_eq CRmorph c cI);destruct (c ?=! cI).
+ rewrite (H1 (refl_equal true));Esimpl.
+ Esimpl.
+ generalize (Mcphi_ok P2 c l); case CFactor.
+ intros S1 S2 HS.
+ generalize (Mcphi_ok Q2 c (tail l)); case CFactor.
+ intros S3 S4 HS1; Esimpl; rewrite HS; rewrite HS1.
+ rsimpl.
+ apply (Radd_ext Reqe); rsimpl.
+ repeat rewrite <- (ARadd_assoc ARth).
+ apply (Radd_ext Reqe); rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ intros j M1.
+ generalize (Hrec1 (c,zmon j M1) l);
+ case (MFactor P2 c (zmon j M1)).
+ intros R1 S1 H1.
+ generalize (Hrec2 (c, zmon_pred j M1) (List.tail l));
+ case (MFactor Q2 c (zmon_pred j M1)); simpl.
+ intros R2 S2 H2; rewrite H1; rewrite H2.
+ repeat rewrite mkPX_ok; simpl.
+ rsimpl.
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ rewrite zmon_pred_ok;rsimpl.
+ intros j M1.
+ case_eq ((i ?= j) Eq); intros He; simpl.
+ rewrite (Pcompare_Eq_eq _ _ He).
+ generalize (Hrec1 (c, mkZmon xH M1) l); case (MFactor P2 c (mkZmon xH M1));
+ simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+ rewrite H; rewrite mkPX_ok; rsimpl.
+ repeat (rewrite <-(ARadd_assoc ARth)).
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ rewrite mkZmon_ok.
+ apply rmul_ext; rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ generalize (Hrec1 (c, vmon (j - i) M1) l);
+ case (MFactor P2 c (vmon (j - i) M1));
+ simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+ rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto.
+ rewrite mkPX_ok; rsimpl.
+ repeat (rewrite <-(ARadd_assoc ARth)).
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ apply rmul_ext; rsimpl.
+ rewrite <- (ARmul_comm ARth (Mphi (tail l) M1)); rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ apply rmul_ext; rsimpl.
+ rewrite <- pow_pos_Pplus.
+ rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl.
+ generalize (Hrec1 (c, mkZmon 1 M1) l);
+ case (MFactor P2 c (mkZmon 1 M1));
+ simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto.
+ rewrite H; rsimpl.
+ rewrite mkPX_ok; rsimpl.
+ repeat (rewrite <-(ARadd_assoc ARth)).
+ apply radd_ext; rsimpl.
+ rewrite (ARadd_comm ARth); rsimpl.
+ apply radd_ext; rsimpl.
+ rewrite mkZmon_ok.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ rewrite mkPX_ok; simpl; rsimpl.
+ rewrite (morph0 CRmorph); rsimpl.
+ repeat (rewrite <-(ARmul_assoc ARth)).
+ rewrite (ARmul_comm ARth (Q3@l)); rsimpl.
+ apply rmul_ext; rsimpl.
+ rewrite (ARmul_comm ARth); rsimpl.
+ repeat (rewrite <- (ARmul_assoc ARth)).
+ apply rmul_ext; rsimpl.
+ rewrite <- pow_pos_Pplus.
+ rewrite (Pplus_minus _ _ He); rsimpl.
+ Qed.
+
+(* Proof for the symmetric version *)
+
+ Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+ POneSubst P1 M1 P2 = Some P3 -> phi (fst M1) * Mphi l (snd M1) == P2@l -> P1@l == P3@l.
+ Proof.
+ intros P2 (cc,M1) P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 (cc, M1) l); case (MFactor P2 cc M1); simpl; auto.
+ intros Q1 R1; case R1.
+ intros c H; rewrite H.
+ generalize (morph_eq CRmorph c cO);
+ case (c ?=! cO); simpl; auto.
+ intros H1 H2; rewrite H1; auto; rsimpl.
+ discriminate.
+ intros _ H1 H2; injection H1; intros; subst.
+ rewrite H2; rsimpl.
+ (* new version *)
+ rewrite Padd_ok; rewrite PmulC_ok; rsimpl.
+ intros i P5 H; rewrite H.
+ intros HH H1; injection HH; intros; subst; rsimpl.
+ rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl.
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+ assert (P4 = Q1 ++ P3 ** PX i P5 P6).
+ injection H2; intros; subst;trivial.
+ rewrite H;rewrite Padd_ok;rewrite Pmul_ok;rsimpl.
+ Qed.
+(*
+ Lemma POneSubst_ok: forall P1 M1 P2 P3 l,
+ POneSubst P1 M1 P2 = Some P3 -> Mphi l M1 == P2@l -> P1@l == P3@l.
+Proof.
+ intros P2 M1 P3 P4 l; unfold POneSubst.
+ generalize (Mphi_ok P2 M1 l); case (MFactor P2 M1); simpl; auto.
+ intros Q1 R1; case R1.
+ intros c H; rewrite H.
+ generalize (morph_eq CRmorph c cO);
+ case (c ?=! cO); simpl; auto.
+ intros H1 H2; rewrite H1; auto; rsimpl.
+ discriminate.
+ intros _ H1 H2; injection H1; intros; subst.
+ rewrite H2; rsimpl.
+ rewrite Padd_ok; rewrite Pmul_ok; rsimpl.
+ intros i P5 H; rewrite H.
+ intros HH H1; injection HH; intros; subst; rsimpl.
+ rewrite Padd_ok; rewrite Pmul_ok. rewrite H1; rsimpl.
+ intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3.
+ injection H2; intros; subst; rsimpl.
+ rewrite Padd_ok.
+ rewrite Pmul_ok; rsimpl.
+ Qed.
+*)
+ Lemma PNSubst1_ok: forall n P1 M1 P2 l,
+ [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l.
+ Proof.
+ intros n; elim n; simpl; auto.
+ intros P2 M1 P3 l H.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+ intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl.
+ intros n1 Hrec P2 M1 P3 l H.
+ generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l);
+ case (POneSubst P2 M1 P3); [idtac | intros; rsimpl].
+ intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl.
+ Qed.
+
+ Lemma PNSubst_ok: forall n P1 M1 P2 l P3,
+ PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l.
+ Proof.
+ intros n P2 (cc, M1) P3 l P4; unfold PNSubst.
+ generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l);
+ case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate].
+ intros P5 H1; case n; try (intros; discriminate).
+ intros n1 H2; injection H2; intros; subst.
+ rewrite <- PNSubst1_ok; auto.
+ Qed.
+
+ Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop :=
+ match LM1 with
+ cons (M1,P2) LM2 => ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l)
+ | _ => True
+ end.
+
+ Lemma PSubstL1_ok: forall n LM1 P1 l,
+ MPcond LM1 l -> P1@l == (PSubstL1 P1 LM1 n)@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+ intros; rsimpl.
+ intros (M2,P2) LM2 Hrec P3 l [H H1].
+ rewrite <- Hrec; auto.
+ apply PNSubst1_ok; auto.
+ Qed.
+
+ Lemma PSubstL_ok: forall n LM1 P1 P2 l,
+ PSubstL P1 LM1 n = Some P2 -> MPcond LM1 l -> P1@l == P2@l.
+ Proof.
+ intros n LM1; elim LM1; simpl; auto.
+ intros; discriminate.
+ intros (M2,P2) LM2 Hrec P3 P4 l.
+ generalize (PNSubst_ok n P3 M2 P2); case (PNSubst P3 M2 P2 n).
+ intros P5 H0 H1 [H2 H3]; injection H1; intros; subst.
+ rewrite <- PSubstL1_ok; auto.
+ intros l1 H [H1 H2]; auto.
+ Qed.
+
+ Lemma PNSubstL_ok: forall m n LM1 P1 l,
+ MPcond LM1 l -> P1@l == (PNSubstL P1 LM1 m n)@l.
+ Proof.
+ intros m; elim m; simpl; auto.
+ intros n LM1 P2 l H; generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+ case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ intros m1 Hrec n LM1 P2 l H.
+ generalize (fun P3 => @PSubstL_ok n LM1 P2 P3 l);
+ case (PSubstL P2 LM1 n); intros; rsimpl; auto.
+ rewrite <- Hrec; auto.
+ Qed.
+
+ (** Definition of polynomial expressions *)
+
+ 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.
+
+ (** evaluation of polynomial expressions towards R *)
+ Definition mk_X j := mkPinj_pred j mkX.
+
+ (** evaluation of polynomial expressions towards R *)
+
+ Fixpoint PEeval (l:list R) (pe:PExpr) {struct pe} : R :=
+ match pe with
+ | PEc c => phi 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].
+
+ (** Correctness proofs *)
+
+ Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l.
+ Proof.
+ destruct p;simpl;intros;Esimpl;trivial.
+ rewrite <-jump_tl;rewrite nth_jump;rrefl.
+ rewrite <- nth_jump.
+ rewrite nth_Pdouble_minus_one;rrefl.
+ Qed.
+
+ Ltac Esimpl3 :=
+ repeat match goal with
+ | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l)
+ | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l)
+ end;Esimpl2;try rrefl;try apply (ARadd_comm ARth).
+
+(* Power using the chinise algorithm *)
+(*Section POWER.
+ Variable subst_l : Pol -> Pol.
+ Fixpoint Ppow_pos (P:Pol) (p:positive){struct p} : Pol :=
+ match p with
+ | xH => P
+ | xO p => subst_l (Psquare (Ppow_pos P p))
+ | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p)))
+ end.
+
+ Definition Ppow_N P n :=
+ match n with
+ | N0 => P1
+ | Npos p => Ppow_pos P p
+ end.
+
+ Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l.
+ Proof.
+ intros l subst_l_ok P.
+ induction p;simpl;intros;try rrefl;try rewrite subst_l_ok.
+ repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+ repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl.
+ Qed.
+
+ Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+ Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed.
+
+ End POWER. *)
+
+Section POWER.
+ Variable subst_l : Pol -> Pol.
+ Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol :=
+ match p with
+ | xH => subst_l (Pmul res P)
+ | xO p => Ppow_pos (Ppow_pos res P p) P p
+ | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P)
+ end.
+
+ Definition Ppow_N P n :=
+ match n with
+ | N0 => P1
+ | Npos p => Ppow_pos P1 P p
+ end.
+
+ Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l.
+ Proof.
+ intros l subst_l_ok res P p. generalize res;clear res.
+ induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp.
+ rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl.
+ Qed.
+
+ Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) ->
+ forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l.
+ Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl. Qed.
+
+ End POWER.
+
+ (** Normalization and rewriting *)
+
+ Section NORM_SUBST_REC.
+ Variable n : nat.
+ Variable lmp:list (C*Mon*Pol).
+ Let subst_l P := PNSubstL P lmp n n.
+ Let Pmul_subst P1 P2 := subst_l (Pmul P1 P2).
+ Let Ppow_subst := Ppow_N subst_l.
+
+ Fixpoint norm_aux (pe:PExpr) : Pol :=
+ match pe with
+ | PEc c => Pc c
+ | PEX j => mk_X j
+ | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1)
+ | PEadd pe1 (PEopp pe2) =>
+ Psub (norm_aux pe1) (norm_aux pe2)
+ | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2)
+ | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2)
+ | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2)
+ | PEopp pe1 => Popp (norm_aux pe1)
+ | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n
+ end.
+
+ Definition norm_subst pe := subst_l (norm_aux pe).
+
+ (*
+ Fixpoint norm_subst (pe:PExpr) : Pol :=
+ match pe with
+ | PEc c => Pc c
+ | PEX j => subst_l (mk_X j)
+ | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1)
+ | PEadd pe1 (PEopp pe2) =>
+ Psub (norm_subst pe1) (norm_subst pe2)
+ | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2)
+ | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2)
+ | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2)
+ | PEopp pe1 => Popp (norm_subst pe1)
+ | PEpow pe1 n => Ppow_subst (norm_subst pe1) n
+ end.
+
+ Lemma norm_subst_spec :
+ forall l pe, MPcond lmp l ->
+ PEeval l pe == (norm_subst pe)@l.
+ Proof.
+ intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l).
+ unfold subst_l;intros.
+ rewrite <- PNSubstL_ok;trivial. rrefl.
+ assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l).
+ intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl.
+ induction pe;simpl;Esimpl3.
+ rewrite subst_l_ok;apply mkX_ok.
+ rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
+ rewrite IHpe1;rewrite IHpe2;rrefl.
+ rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl.
+ rewrite IHpe;rrefl.
+ unfold Ppow_subst. rewrite Ppow_N_ok. trivial.
+ rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+ induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
+ repeat rewrite Pmul_ok;rrefl.
+ Qed.
+*)
+ Lemma norm_aux_spec :
+ forall l pe, MPcond lmp l ->
+ PEeval l pe == (norm_aux pe)@l.
+ Proof.
+ intros.
+ induction pe;simpl;Esimpl3.
+ apply mkX_ok.
+ rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3.
+ rewrite IHpe1;rewrite IHpe2;rrefl.
+ rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
+ rewrite IHpe;rrefl.
+ rewrite Ppow_N_ok by (intros;rrefl).
+ rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3.
+ induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok;
+ repeat rewrite Pmul_ok;rrefl.
+ Qed.
+
+ Lemma norm_subst_spec :
+ forall l pe, MPcond lmp l ->
+ PEeval l pe == (norm_subst pe)@l.
+ Proof.
+ intros;unfold norm_subst.
+ unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial.
+ Qed.
+
+ End NORM_SUBST_REC.
+
+ Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {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.
+
+ Fixpoint mon_of_pol (P:Pol) : option (C * Mon) :=
+ match P with
+ | Pc c => if (c ?=! cO) then None else Some (c, mon0)
+ | Pinj j P =>
+ match mon_of_pol P with
+ | None => None
+ | Some (c,m) => Some (c, mkZmon j m)
+ end
+ | PX P i Q =>
+ if Peq Q P0 then
+ match mon_of_pol P with
+ | None => None
+ | Some (c,m) => Some (c, mkVmon i m)
+ end
+ else None
+ end.
+
+ Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) :=
+ match lpe with
+ | nil => nil
+ | (me,pe)::lpe =>
+ match mon_of_pol (norm_subst 0 nil me) with
+ | None => mk_monpol_list lpe
+ | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe
+ end
+ end.
+
+ Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m ->
+ forall l, [fst m] * Mphi l (snd m) == P@l.
+ Proof.
+ induction P;simpl;intros;Esimpl.
+ assert (H1 := (morph_eq CRmorph) c cO).
+ destruct (c ?=! cO).
+ discriminate.
+ inversion H;trivial;Esimpl.
+ generalize H;clear H;case_eq (mon_of_pol P).
+ intros (c1,P2) H0 H1; inversion H1; Esimpl.
+ generalize (IHP (c1, P2) H0 (jump p l)).
+ rewrite mkZmon_ok;simpl;auto.
+ intros; discriminate.
+ generalize H;clear H;change match P3 with
+ | Pc c => c ?=! cO
+ | Pinj _ _ => false
+ | PX _ _ _ => false
+ end with (P3 ?== P0).
+ assert (H := Peq_ok P3 P0).
+ destruct (P3 ?== P0).
+ case_eq (mon_of_pol P2);try intros (cc, pp); intros.
+ inversion H1.
+ simpl.
+ rewrite mkVmon_ok;simpl.
+ rewrite H;trivial;Esimpl.
+ generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl.
+ discriminate.
+ intros;discriminate.
+ Qed.
+
+ Lemma interp_PElist_ok : forall l lpe,
+ interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l.
+ Proof.
+ induction lpe;simpl. trivial.
+ destruct a;simpl;intros.
+ assert (HH:=mon_of_pol_ok (norm_subst 0 nil p));
+ destruct (mon_of_pol (norm_subst 0 nil p)).
+ split.
+ rewrite <- norm_subst_spec by exact I.
+ destruct lpe;try destruct H;rewrite <- H;
+ rewrite (norm_subst_spec 0 nil); try exact I;apply HH;trivial.
+ apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0.
+ apply IHlpe. destruct lpe;simpl;trivial. destruct H. exact H0.
+ Qed.
+
+ Lemma norm_subst_ok : forall n l lpe pe,
+ interp_PElist l lpe ->
+ PEeval l pe == (norm_subst n (mk_monpol_list lpe) pe)@l.
+ Proof.
+ intros;apply norm_subst_spec. apply interp_PElist_ok;trivial.
+ Qed.
+
+ Lemma ring_correct : forall n l lpe pe1 pe2,
+ interp_PElist l lpe ->
+ (let lmp := mk_monpol_list lpe in
+ norm_subst n lmp pe1 ?== norm_subst n lmp pe2) = true ->
+ PEeval l pe1 == PEeval l pe2.
+ Proof.
+ simpl;intros.
+ do 2 (rewrite (norm_subst_ok n l lpe);trivial).
+ apply Peq_ok;trivial.
+ Qed.
+
+
+
+ (** Generic evaluation of polynomial towards R avoiding parenthesis *)
+ Variable get_sign : C -> option C.
+ Variable get_sign_spec : sign_theory copp ceqb get_sign.
+
+
+ Section EVALUATION.
+
+ (* [mkpow x p] = x^p *)
+ Variable mkpow : R -> positive -> R.
+ (* [mkpow x p] = -(x^p) *)
+ Variable mkopp_pow : R -> positive -> R.
+ (* [mkmult_pow r x p] = r * x^p *)
+ Variable mkmult_pow : R -> R -> positive -> R.
+
+ Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R :=
+ match lm with
+ | nil => r
+ | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t
+ end.
+
+ Definition mkmult1 lm :=
+ match lm with
+ | nil => 1
+ | cons (x,p) t => mkmult_rec (mkpow x p) t
+ end.
+
+ Definition mkmultm1 lm :=
+ match lm with
+ | nil => ropp rI
+ | cons (x,p) t => mkmult_rec (mkopp_pow x p) t
+ end.
+
+ Definition mkmult_c_pos c lm :=
+ if c ?=! cI then mkmult1 (rev' lm)
+ else mkmult_rec [c] (rev' lm).
+
+ Definition mkmult_c c lm :=
+ match get_sign c with
+ | None => mkmult_c_pos c lm
+ | Some c' =>
+ if c' ?=! cI then mkmultm1 (rev' lm)
+ else mkmult_rec [c] (rev' lm)
+ end.
+
+ Definition mkadd_mult rP c lm :=
+ match get_sign c with
+ | None => rP + mkmult_c_pos c lm
+ | Some c' => rP - mkmult_c_pos c' lm
+ end.
+
+ Definition add_pow_list (r:R) n l :=
+ match n with
+ | N0 => l
+ | Npos p => (r,p)::l
+ end.
+
+ Fixpoint add_mult_dev
+ (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R :=
+ match P with
+ | Pc c =>
+ let lm := add_pow_list (hd 0 fv) n lm in
+ mkadd_mult rP c lm
+ | Pinj j Q =>
+ add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
+ | PX P i Q =>
+ let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in
+ if Q ?== P0 then rP
+ else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm)
+ end.
+
+ Fixpoint mult_dev (P:Pol) (fv : list R) (n:N)
+ (lm:list (R*positive)) {struct P} : R :=
+ (* P@l * (hd 0 l)^n * lm *)
+ match P with
+ | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm)
+ | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm)
+ | PX P i Q =>
+ let rP := mult_dev P fv (Nplus (Npos i) n) lm in
+ if Q ?== P0 then rP
+ else
+ let lmq := add_pow_list (hd 0 fv) n lm in
+ add_mult_dev rP Q (tail fv) N0 lmq
+ end.
+
+ Definition Pphi_avoid fv P := mult_dev P fv N0 nil.
+
+ Fixpoint r_list_pow (l:list (R*positive)) : R :=
+ match l with
+ | nil => rI
+ | cons (r,p) l => pow_pos rmul r p * r_list_pow l
+ end.
+
+ Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p.
+ Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p).
+ Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p.
+
+ Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm.
+ Proof.
+ induction lm;intros;simpl;Esimpl.
+ destruct a as (x,p);Esimpl.
+ rewrite IHlm. rewrite mkmult_pow_spec. Esimpl.
+ Qed.
+
+ Lemma mkmult1_ok : forall lm, mkmult1 lm == r_list_pow lm.
+ Proof.
+ destruct lm;simpl;Esimpl.
+ destruct p. rewrite mkmult_rec_ok;rewrite mkpow_spec;Esimpl.
+ Qed.
+
+ Lemma mkmultm1_ok : forall lm, mkmultm1 lm == - r_list_pow lm.
+ Proof.
+ destruct lm;simpl;Esimpl.
+ destruct p;rewrite mkmult_rec_ok. rewrite mkopp_pow_spec;Esimpl.
+ Qed.
+
+ Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l.
+ Proof.
+ assert
+ (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l).
+ induction l;intros;simpl;Esimpl.
+ destruct a;rewrite IHl;Esimpl.
+ rewrite (ARmul_comm ARth (pow_pos rmul r p)). rrefl.
+ intros;unfold rev'. rewrite H;simpl;Esimpl.
+ Qed.
+
+ Lemma mkmult_c_pos_ok : forall c lm, mkmult_c_pos c lm == [c]* r_list_pow lm.
+ Proof.
+ intros;unfold mkmult_c_pos;simpl.
+ assert (H := (morph_eq CRmorph) c cI).
+ rewrite <- r_list_pow_rev; destruct (c ?=! cI).
+ rewrite H;trivial;Esimpl.
+ apply mkmult1_ok. apply mkmult_rec_ok.
+ Qed.
+
+ Lemma mkmult_c_ok : forall c lm, mkmult_c c lm == [c] * r_list_pow lm.
+ Proof.
+ intros;unfold mkmult_c;simpl.
+ case_eq (get_sign c);intros.
+ assert (H1 := (morph_eq CRmorph) c0 cI).
+ destruct (c0 ?=! cI).
+ rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H)). Esimpl. rewrite H1;trivial.
+ rewrite <- r_list_pow_rev;trivial;Esimpl.
+ apply mkmultm1_ok.
+ rewrite <- r_list_pow_rev; apply mkmult_rec_ok.
+ apply mkmult_c_pos_ok.
+Qed.
+
+ Lemma mkadd_mult_ok : forall rP c lm, mkadd_mult rP c lm == rP + [c]*r_list_pow lm.
+ Proof.
+ intros;unfold mkadd_mult.
+ case_eq (get_sign c);intros.
+ rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl.
+ rewrite mkmult_c_pos_ok;Esimpl.
+ rewrite mkmult_c_pos_ok;Esimpl.
+ Qed.
+
+ Lemma add_pow_list_ok :
+ forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l.
+ Proof.
+ destruct n;simpl;intros;Esimpl.
+ Qed.
+
+ Lemma add_mult_dev_ok : forall P rP fv n lm,
+ add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
+ Proof.
+ induction P;simpl;intros.
+ rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl.
+ rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl.
+ change (match P3 with
+ | Pc c => c ?=! cO
+ | Pinj _ _ => false
+ | PX _ _ _ => false
+ end) with (Peq P3 P0).
+ change match n with
+ | N0 => Npos p
+ | Npos q => Npos (p + q)
+ end with (Nplus (Npos p) n);trivial.
+ assert (H := Peq_ok P3 P0).
+ destruct (P3 ?== P0).
+ rewrite (H (refl_equal true)).
+ rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+ rewrite IHP2.
+ rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+ Qed.
+
+ Lemma mult_dev_ok : forall P fv n lm,
+ mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm.
+ Proof.
+ induction P;simpl;intros;Esimpl.
+ rewrite mkmult_c_ok;rewrite add_pow_list_ok;Esimpl.
+ rewrite IHP. simpl;rewrite add_pow_list_ok;Esimpl.
+ change (match P3 with
+ | Pc c => c ?=! cO
+ | Pinj _ _ => false
+ | PX _ _ _ => false
+ end) with (Peq P3 P0).
+ change match n with
+ | N0 => Npos p
+ | Npos q => Npos (p + q)
+ end with (Nplus (Npos p) n);trivial.
+ assert (H := Peq_ok P3 P0).
+ destruct (P3 ?== P0).
+ rewrite (H (refl_equal true)).
+ rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+ rewrite add_mult_dev_ok. rewrite IHP1; rewrite add_pow_list_ok.
+ destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl.
+ Qed.
+
+ Lemma Pphi_avoid_ok : forall P fv, Pphi_avoid fv P == P@fv.
+ Proof.
+ unfold Pphi_avoid;intros;rewrite mult_dev_ok;simpl;Esimpl.
+ Qed.
+
+ End EVALUATION.
+
+ Definition Pphi_pow :=
+ let mkpow x p :=
+ match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in
+ let mkopp_pow x p := ropp (mkpow x p) in
+ let mkmult_pow r x p := rmul r (mkpow x p) in
+ Pphi_avoid mkpow mkopp_pow mkmult_pow.
+
+ Lemma local_mkpow_ok :
+ forall (r : R) (p : positive),
+ match p with
+ | xI _ => rpow r (Cp_phi (Npos p))
+ | xO _ => rpow r (Cp_phi (Npos p))
+ | 1 => r
+ end == pow_pos rmul r p.
+ Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed.
+
+ Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv.
+ Proof.
+ unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl.
+ Qed.
+
+ Lemma ring_rw_pow_correct : forall n lH l,
+ interp_PElist l lH ->
+ forall lmp, mk_monpol_list lH = lmp ->
+ forall pe npe, norm_subst n lmp pe = npe ->
+ PEeval l pe == Pphi_pow l npe.
+ Proof.
+ intros n lH l H1 lmp Heq1 pe npe Heq2.
+ rewrite Pphi_pow_ok. rewrite <- Heq2;rewrite <- Heq1.
+ apply norm_subst_ok. trivial.
+ Qed.
+
+ Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R :=
+ match p with
+ | xH => r*x
+ | xO p => mkmult_pow (mkmult_pow r x p) x p
+ | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p
+ end.
+
+ Definition mkpow x p :=
+ match p with
+ | xH => x
+ | xO p => mkmult_pow x x (Pdouble_minus_one p)
+ | xI p => mkmult_pow x x (xO p)
+ end.
+
+ Definition mkopp_pow x p :=
+ match p with
+ | xH => -x
+ | xO p => mkmult_pow (-x) x (Pdouble_minus_one p)
+ | xI p => mkmult_pow (-x) x (xO p)
+ end.
+
+ Definition Pphi_dev := Pphi_avoid mkpow mkopp_pow mkmult_pow.
+
+ Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p.
+ Proof.
+ induction p;intros;simpl;Esimpl.
+ repeat rewrite IHp;Esimpl.
+ repeat rewrite IHp;Esimpl.
+ Qed.
+
+ Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p.
+ Proof.
+ destruct p;simpl;intros;Esimpl.
+ repeat rewrite mkmult_pow_ok;Esimpl.
+ rewrite mkmult_pow_ok;Esimpl.
+ pattern x at 1;replace x with (pow_pos rmul x 1).
+ rewrite <- pow_pos_Pplus.
+ rewrite <- Pplus_one_succ_l.
+ rewrite Psucc_o_double_minus_one_eq_xO.
+ simpl;Esimpl.
+ trivial.
+ Qed.
+
+ Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p.
+ Proof.
+ destruct p;simpl;intros;Esimpl.
+ repeat rewrite mkmult_pow_ok;Esimpl.
+ rewrite mkmult_pow_ok;Esimpl.
+ pattern x at 1;replace x with (pow_pos rmul x 1).
+ rewrite <- pow_pos_Pplus.
+ rewrite <- Pplus_one_succ_l.
+ rewrite Psucc_o_double_minus_one_eq_xO.
+ simpl;Esimpl.
+ trivial.
+ Qed.
+
+ Lemma Pphi_dev_ok : forall P fv, Pphi_dev fv P == P@fv.
+ Proof.
+ unfold Pphi_dev;intros;apply Pphi_avoid_ok.
+ intros;apply mkpow_ok.
+ intros;apply mkopp_pow_ok.
+ intros;apply mkmult_pow_ok.
+ Qed.
+
+ Lemma ring_rw_correct : forall n lH l,
+ interp_PElist l lH ->
+ forall lmp, mk_monpol_list lH = lmp ->
+ forall pe npe, norm_subst n lmp pe = npe ->
+ PEeval l pe == Pphi_dev l npe.
+ Proof.
+ intros n lH l H1 lmp Heq1 pe npe Heq2.
+ rewrite Pphi_dev_ok. rewrite <- Heq2;rewrite <- Heq1.
+ apply norm_subst_ok. trivial.
+ Qed.
+
+
+End MakeRingPol.
+
diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v
new file mode 100644
index 00000000..d33e9a82
--- /dev/null
+++ b/plugins/setoid_ring/Ring_tac.v
@@ -0,0 +1,434 @@
+Set Implicit Arguments.
+Require Import Setoid.
+Require Import BinPos.
+Require Import Ring_polynom.
+Require Import BinList.
+Require Import InitialRing.
+Require Import Quote.
+Declare ML Module "newring_plugin".
+
+
+(* adds a definition t' on the normal form of t and an hypothesis id
+ stating that t = t' (tries to produces a proof as small as possible) *)
+Ltac compute_assertion eqn t' t :=
+ let nft := eval vm_compute in t in
+ pose (t' := nft);
+ assert (eqn : t = t');
+ [vm_cast_no_check (refl_equal t')|idtac].
+
+Ltac relation_carrier req :=
+ let ty := type of req in
+ match eval hnf in ty with
+ ?R -> _ => R
+ | _ => fail 1000 "Equality has no relation type"
+ end.
+
+Ltac Get_goal := match goal with [|- ?G] => G end.
+
+(********************************************************************)
+(* Tacticals to build reflexive tactics *)
+
+Ltac OnEquation req :=
+ match goal with
+ | |- req ?lhs ?rhs => (fun f => f lhs rhs)
+ | _ => (fun _ => fail "Goal is not an equation (of expected equality)")
+ end.
+
+Ltac OnEquationHyp req h :=
+ match type of h with
+ | req ?lhs ?rhs => fun f => f lhs rhs
+ | _ => (fun _ => fail "Hypothesis is not an equation (of expected equality)")
+ end.
+
+(* Note: auxiliary subgoals in reverse order *)
+Ltac OnMainSubgoal H ty :=
+ match ty with
+ | _ -> ?ty' =>
+ let subtac := OnMainSubgoal H ty' in
+ fun kont => lapply H; [clear H; intro H; subtac kont | idtac]
+ | _ => (fun kont => kont())
+ end.
+
+(* A generic pattern to have reflexive tactics do some computation:
+ lemmas of the form [forall x', x=x' -> P(x')] are understood as:
+ compute the normal form of x, instantiate x' with it, prove
+ hypothesis x=x' with vm_compute and reflexivity, and pass the
+ instantiated lemma to the continuation.
+ *)
+Ltac ProveLemmaHyp lemma :=
+ match type of lemma with
+ forall x', ?x = x' -> _ =>
+ (fun kont =>
+ let x' := fresh "res" in
+ let H := fresh "res_eq" in
+ compute_assertion H x' x;
+ let lemma' := constr:(lemma x' H) in
+ kont lemma';
+ (clear H||idtac"ProveLemmaHyp: cleanup failed");
+ subst x')
+ | _ => (fun _ => fail "ProveLemmaHyp: lemma not of the expected form")
+ end.
+
+Ltac ProveLemmaHyps lemma :=
+ match type of lemma with
+ forall x', ?x = x' -> _ =>
+ (fun kont =>
+ let x' := fresh "res" in
+ let H := fresh "res_eq" in
+ compute_assertion H x' x;
+ let lemma' := constr:(lemma x' H) in
+ ProveLemmaHyps lemma' kont;
+ (clear H||idtac"ProveLemmaHyps: cleanup failed");
+ subst x')
+ | _ => (fun kont => kont lemma)
+ end.
+
+(*
+Ltac ProveLemmaHyps lemma := (* expects a continuation *)
+ let try_step := ProveLemmaHyp lemma in
+ (fun kont =>
+ try_step ltac:(fun lemma' => ProveLemmaHyps lemma' kont) ||
+ kont lemma).
+*)
+Ltac ApplyLemmaThen lemma expr kont :=
+ let lem := constr:(lemma expr) in
+ ProveLemmaHyp lem ltac:(fun lem' =>
+ let Heq := fresh "thm" in
+ assert (Heq:=lem');
+ OnMainSubgoal Heq ltac:(type of Heq) ltac:(fun _ => kont Heq);
+ (clear Heq||idtac"ApplyLemmaThen: cleanup failed")).
+(*
+Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg :=
+ let pe :=
+ match type of (lemma expr) with
+ forall pe', ?pe = pe' -> _ => pe
+ | _ => fail 1 "ApplyLemmaThenAndCont: cannot find norm expression"
+ end in
+ let pe' := fresh "expr_nf" in
+ let nf_pe := fresh "pe_eq" in
+ compute_assertion nf_pe pe' pe;
+ let Heq := fresh "thm" in
+ (assert (Heq:=lemma pe pe' H) || fail "anomaly: failed to apply lemma");
+ clear nf_pe;
+ OnMainSubgoal Heq ltac:(type of Heq)
+ ltac:(try tac Heq; clear Heq pe';CONT_tac cont_arg)).
+*)
+Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac :=
+ ApplyLemmaThen lemma expr
+ ltac:(fun lemma' => try tac lemma'; CONT_tac()).
+
+(* General scheme of reflexive tactics using of correctness lemma
+ that involves normalisation of one expression
+ - [FV_tac term fv] is a tactic that adds the atomic expressions
+ of [term] into [fv]
+ - [SYN_tac term fv] reifies [term] given the list of atomic expressions
+ - [LEMMA_tac fv kont] computes the correctness lemma and passes it to
+ continuation kont
+ - [MAIN_tac H] process H which is the conclusion of the correctness lemma
+ instantiated with each reified term
+ - [fv] is the initial value of atomic expressions (to be completed by
+ the reification of the terms
+ - [terms] the list (a constr of type list) of terms to reify and process.
+ *)
+Ltac ReflexiveRewriteTactic
+ FV_tac SYN_tac LEMMA_tac MAIN_tac fv terms :=
+ (* extend the atom list *)
+ let fv := list_fold_left FV_tac fv terms in
+ let RW_tac lemma :=
+ let fcons term CONT_tac :=
+ let expr := SYN_tac term fv in
+ let main H :=
+ match type of H with
+ | (?req _ ?rhs) => change (req term rhs) in H
+ end;
+ MAIN_tac H in
+ (ApplyLemmaThenAndCont lemma expr main CONT_tac) in
+ (* rewrite steps *)
+ lazy_list_fold_right fcons ltac:(fun _=>idtac) terms in
+ LEMMA_tac fv RW_tac.
+
+(********************************************************)
+
+Ltac FV_hypo_tac mkFV req lH :=
+ let R := relation_carrier req in
+ let FV_hypo_l_tac h :=
+ match h with @mkhypo (req ?pe _) _ => mkFV pe end in
+ let FV_hypo_r_tac h :=
+ match h with @mkhypo (req _ ?pe) _ => mkFV pe end in
+ let fv := list_fold_right FV_hypo_l_tac (@nil R) lH in
+ list_fold_right FV_hypo_r_tac fv lH.
+
+Ltac mkHyp_tac C req Reify lH :=
+ let mkHyp h res :=
+ match h with
+ | @mkhypo (req ?r1 ?r2) _ =>
+ let pe1 := Reify r1 in
+ let pe2 := Reify r2 in
+ constr:(cons (pe1,pe2) res)
+ | _ => fail 1 "hypothesis is not a ring equality"
+ end in
+ list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH.
+
+Ltac proofHyp_tac lH :=
+ let get_proof h :=
+ match h with
+ | @mkhypo _ ?p => p
+ end in
+ let rec bh l :=
+ match l with
+ | nil => constr:(I)
+ | cons ?h nil => get_proof h
+ | cons ?h ?tl =>
+ let l := get_proof h in
+ let r := bh tl in
+ constr:(conj l r)
+ end in
+ bh lH.
+
+Ltac get_MonPol lemma :=
+ match type of lemma with
+ | context [(mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _)] =>
+ constr:(mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb)
+ | _ => fail 1 "ring/field anomaly: bad correctness lemma (get_MonPol)"
+ end.
+
+(********************************************************)
+
+(* Building the atom list of a ring expression *)
+Ltac FV Cst CstPow add mul sub opp pow t fv :=
+ let rec TFV t fv :=
+ let f :=
+ match Cst t with
+ | NotConstant =>
+ match t with
+ | (add ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
+ | (mul ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
+ | (sub ?t1 ?t2) => fun _ => TFV t2 ltac:(TFV t1 fv)
+ | (opp ?t1) => fun _ => TFV t1 fv
+ | (pow ?t1 ?n) =>
+ match CstPow n with
+ | InitialRing.NotConstant => fun _ => AddFvTail t fv
+ | _ => fun _ => TFV t1 fv
+ end
+ | _ => fun _ => AddFvTail t fv
+ end
+ | _ => fun _ => fv
+ end in
+ f()
+ in TFV t fv.
+
+ (* syntaxification of ring expressions *)
+Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv :=
+ let rec mkP t :=
+ let f :=
+ match Cst t with
+ | InitialRing.NotConstant =>
+ match t with
+ | (radd ?t1 ?t2) =>
+ fun _ =>
+ let e1 := mkP t1 in
+ let e2 := mkP t2 in constr:(PEadd e1 e2)
+ | (rmul ?t1 ?t2) =>
+ fun _ =>
+ let e1 := mkP t1 in
+ let e2 := mkP t2 in constr:(PEmul e1 e2)
+ | (rsub ?t1 ?t2) =>
+ fun _ =>
+ let e1 := mkP t1 in
+ let e2 := mkP t2 in constr:(PEsub e1 e2)
+ | (ropp ?t1) =>
+ fun _ =>
+ let e1 := mkP t1 in constr:(PEopp e1)
+ | (rpow ?t1 ?n) =>
+ match CstPow n with
+ | InitialRing.NotConstant =>
+ fun _ => let p := Find_at t fv in constr:(PEX C p)
+ | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c)
+ end
+ | _ =>
+ fun _ => let p := Find_at t fv in constr:(PEX C p)
+ end
+ | ?c => fun _ => constr:(@PEc C c)
+ end in
+ f ()
+ in mkP t.
+
+(* packaging the ring structure *)
+
+Ltac PackRing F req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post :=
+ let RNG :=
+ match type of lemma1 with
+ | context
+ [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
+ (fun proj => proj
+ cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2)
+ | _ => fail 1 "field anomaly: bad correctness lemma (parse)"
+ end in
+ F RNG.
+
+Ltac get_Carrier RNG :=
+ RNG ltac:(fun cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+ R).
+
+Ltac get_Eq RNG :=
+ RNG ltac:(fun cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+ req).
+
+Ltac get_Pre RNG :=
+ RNG ltac:(fun cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+ pre).
+
+Ltac get_Post RNG :=
+ RNG ltac:(fun cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+ post).
+
+Ltac get_NormLemma RNG :=
+ RNG ltac:(fun cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+ lemma1).
+
+Ltac get_SimplifyLemma RNG :=
+ RNG ltac:(fun cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+ lemma2).
+
+Ltac get_RingFV RNG :=
+ RNG ltac:(fun cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+ FV cst_tac pow_tac add mul sub opp pow).
+
+Ltac get_RingMeta RNG :=
+ RNG ltac:(fun cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+ mkPolexpr C cst_tac pow_tac add mul sub opp pow).
+
+Ltac get_RingHypTac RNG :=
+ RNG ltac:(fun cst_tac pow_tac pre post
+ R req add mul sub opp C Cpow powphi pow lemma1 lemma2 =>
+ let mkPol := mkPolexpr C cst_tac pow_tac add mul sub opp pow in
+ fun fv lH => mkHyp_tac C req ltac:(fun t => mkPol t fv) lH).
+
+(* ring tactics *)
+
+Definition ring_subst_niter := (10*10*10)%nat.
+
+Ltac Ring RNG lemma lH :=
+ let req := get_Eq RNG in
+ OnEquation req ltac:(fun lhs rhs =>
+ let mkFV := get_RingFV RNG in
+ let mkPol := get_RingMeta RNG in
+ let mkHyp := get_RingHypTac RNG in
+ let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in
+ let fv := mkFV lhs fv in
+ let fv := mkFV rhs fv in
+ check_fv fv;
+ let pe1 := mkPol lhs fv in
+ let pe2 := mkPol rhs fv in
+ let lpe := mkHyp fv lH in
+ let vlpe := fresh "hyp_list" in
+ let vfv := fresh "fv_list" in
+ pose (vlpe := lpe);
+ pose (vfv := fv);
+ (apply (lemma vfv vlpe pe1 pe2)
+ || fail "typing error while applying ring");
+ [ ((let prh := proofHyp_tac lH in exact prh)
+ || idtac "can not automatically proof hypothesis :";
+ idtac " maybe a left member of a hypothesis is not a monomial")
+ | vm_compute;
+ (exact (refl_equal true) || fail "not a valid ring equation")]).
+
+Ltac Ring_norm_gen f RNG lemma lH rl :=
+ let mkFV := get_RingFV RNG in
+ let mkPol := get_RingMeta RNG in
+ let mkHyp := get_RingHypTac RNG in
+ let mk_monpol := get_MonPol lemma in
+ let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in
+ let lemma_tac fv kont :=
+ let lpe := mkHyp fv lH in
+ let vlpe := fresh "list_hyp" in
+ let vlmp := fresh "list_hyp_norm" in
+ let vlmp_eq := fresh "list_hyp_norm_eq" in
+ let prh := proofHyp_tac lH in
+ pose (vlpe := lpe);
+ compute_assertion vlmp_eq vlmp (mk_monpol vlpe);
+ let H := fresh "ring_lemma" in
+ (assert (H := lemma vlpe fv prh vlmp vlmp_eq)
+ || fail "type error when build the rewriting lemma");
+ clear vlmp_eq;
+ kont H;
+ (clear H||idtac"Ring_norm_gen: cleanup failed");
+ subst vlpe vlmp in
+ let simpl_ring H := (protect_fv "ring" in H; f H) in
+ ReflexiveRewriteTactic mkFV mkPol lemma_tac simpl_ring fv rl.
+
+Ltac Ring_gen RNG lH rl :=
+ let lemma := get_NormLemma RNG in
+ get_Pre RNG ();
+ Ring RNG (lemma ring_subst_niter) lH.
+
+Tactic Notation (at level 0) "ring" :=
+ let G := Get_goal in
+ ring_lookup (PackRing Ring_gen) [] G.
+
+Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" :=
+ let G := Get_goal in
+ ring_lookup (PackRing Ring_gen) [lH] G.
+
+(* Simplification *)
+
+Ltac Ring_simplify_gen f RNG lH rl :=
+ let lemma := get_SimplifyLemma RNG in
+ let l := fresh "to_rewrite" in
+ pose (l:= rl);
+ generalize (refl_equal l);
+ unfold l at 2;
+ get_Pre RNG ();
+ let rl :=
+ match goal with
+ | [|- l = ?RL -> _ ] => RL
+ | _ => fail 1 "ring_simplify anomaly: bad goal after pre"
+ end in
+ let Heq := fresh "Heq" in
+ intros Heq;clear Heq l;
+ Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl;
+ get_Post RNG ().
+
+Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H).
+
+Tactic Notation (at level 0) "ring_simplify" constr_list(rl) :=
+ let G := Get_goal in
+ ring_lookup (PackRing Ring_simplify) [] rl G.
+
+Tactic Notation (at level 0)
+ "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
+ let G := Get_goal in
+ ring_lookup (PackRing Ring_simplify) [lH] rl G.
+
+(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *)
+
+Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):=
+ let G := Get_goal in
+ let t := type of H in
+ let g := fresh "goal" in
+ set (g:= G);
+ generalize H;clear H;
+ ring_lookup (PackRing Ring_simplify) [] rl t;
+ intro H;
+ unfold g;clear g.
+
+Tactic Notation
+ "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):=
+ let G := Get_goal in
+ let t := type of H in
+ let g := fresh "goal" in
+ set (g:= G);
+ generalize H;clear H;
+ ring_lookup (PackRing Ring_simplify) [lH] rl t;
+ intro H;
+ unfold g;clear g.
+
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
new file mode 100644
index 00000000..b3250a51
--- /dev/null
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -0,0 +1,608 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Import Setoid.
+Require Import BinPos.
+Require Import BinNat.
+
+Set Implicit Arguments.
+
+Module RingSyntax.
+Reserved Notation "x ?=! y" (at level 70, no associativity).
+Reserved Notation "x +! y " (at level 50, left associativity).
+Reserved Notation "x -! y" (at level 50, left associativity).
+Reserved Notation "x *! y" (at level 40, left associativity).
+Reserved Notation "-! x" (at level 35, right associativity).
+
+Reserved Notation "[ x ]" (at level 0).
+
+Reserved Notation "x ?== y" (at level 70, no associativity).
+Reserved Notation "x -- y" (at level 50, left associativity).
+Reserved Notation "x ** y" (at level 40, left associativity).
+Reserved Notation "-- x" (at level 35, right associativity).
+
+Reserved Notation "x == y" (at level 70, no associativity).
+End RingSyntax.
+Import RingSyntax.
+
+Section Power.
+ Variable R:Type.
+ Variable rI : R.
+ Variable rmul : R -> R -> R.
+ Variable req : R -> R -> Prop.
+ Variable Rsth : Setoid_Theory R req.
+ Notation "x * y " := (rmul x y).
+ Notation "x == y" := (req x y).
+
+ Hypothesis mul_ext :
+ forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2.
+ Hypothesis mul_comm : forall x y, x * y == y * x.
+ Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z.
+ Add Setoid R req Rsth as R_set_Power.
+ Add Morphism rmul : rmul_ext_Power. exact mul_ext. Qed.
+
+
+ Fixpoint pow_pos (x:R) (i:positive) {struct i}: R :=
+ match i with
+ | xH => x
+ | xO i => let p := pow_pos x i in rmul p p
+ | xI i => let p := pow_pos x i in rmul x (rmul p p)
+ end.
+
+ Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j.
+ Proof.
+ induction j;simpl.
+ rewrite IHj.
+ rewrite (mul_comm x (pow_pos x j *pow_pos x j)).
+ setoid_rewrite (mul_comm x (pow_pos x j)) at 2.
+ repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+ repeat rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+ apply (Seq_refl _ _ Rsth).
+ 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 mul_assoc. apply (Seq_refl _ _ Rsth).
+ rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
+ repeat rewrite IHi;rewrite mul_assoc. apply (Seq_refl _ _ Rsth).
+ rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;rewrite pow_pos_Psucc;
+ simpl. apply (Seq_refl _ _ Rsth).
+ Qed.
+
+ Definition pow_N (x:R) (p:N) :=
+ match p with
+ | N0 => rI
+ | Npos p => pow_pos x p
+ end.
+
+ 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; apply (Seq_refl _ _ Rsth).
+ Qed.
+
+End Power.
+
+Section DEFINITIONS.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop.
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+
+ (** Semi Ring *)
+ Record semi_ring_theory : Prop := mk_srt {
+ SRadd_0_l : forall n, 0 + n == n;
+ SRadd_comm : forall n m, n + m == m + n ;
+ SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p;
+ SRmul_1_l : forall n, 1*n == n;
+ SRmul_0_l : forall n, 0*n == 0;
+ SRmul_comm : forall n m, n*m == m*n;
+ SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p;
+ SRdistr_l : forall n m p, (n + m)*p == n*p + m*p
+ }.
+
+ (** Almost Ring *)
+(*Almost ring are no ring : Ropp_def is missing **)
+ Record almost_ring_theory : Prop := mk_art {
+ ARadd_0_l : forall x, 0 + x == x;
+ ARadd_comm : forall x y, x + y == y + x;
+ ARadd_assoc : forall x y z, x + (y + z) == (x + y) + z;
+ ARmul_1_l : forall x, 1 * x == x;
+ ARmul_0_l : forall x, 0 * x == 0;
+ ARmul_comm : forall x y, x * y == y * x;
+ ARmul_assoc : forall x y z, x * (y * z) == (x * y) * z;
+ ARdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z);
+ ARopp_mul_l : forall x y, -(x * y) == -x * y;
+ ARopp_add : forall x y, -(x + y) == -x + -y;
+ ARsub_def : forall x y, x - y == x + -y
+ }.
+
+ (** Ring *)
+ Record ring_theory : Prop := mk_rt {
+ Radd_0_l : forall x, 0 + x == x;
+ Radd_comm : forall x y, x + y == y + x;
+ Radd_assoc : forall x y z, x + (y + z) == (x + y) + z;
+ Rmul_1_l : forall x, 1 * x == x;
+ Rmul_comm : forall x y, x * y == y * x;
+ Rmul_assoc : forall x y z, x * (y * z) == (x * y) * z;
+ Rdistr_l : forall x y z, (x + y) * z == (x * z) + (y * z);
+ Rsub_def : forall x y, x - y == x + -y;
+ Ropp_def : forall x, x + (- x) == 0
+ }.
+
+ (** Equality is extensional *)
+
+ Record sring_eq_ext : Prop := mk_seqe {
+ (* SRing operators are compatible with equality *)
+ SRadd_ext :
+ forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
+ SRmul_ext :
+ forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2
+ }.
+
+ Record ring_eq_ext : Prop := mk_reqe {
+ (* Ring operators are compatible with equality *)
+ Radd_ext :
+ forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 + y1 == x2 + y2;
+ Rmul_ext :
+ forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2;
+ Ropp_ext : forall x1 x2, x1 == x2 -> -x1 == -x2
+ }.
+
+ (** Interpretation morphisms definition*)
+ Section MORPHISM.
+ Variable C:Type.
+ Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C).
+ Variable ceqb : C->C->bool.
+ (* [phi] est un morphisme de [C] dans [R] *)
+ Variable phi : C -> R.
+ Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y).
+ Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x).
+ Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+
+(*for semi rings*)
+ Record semi_morph : Prop := mkRmorph {
+ Smorph0 : [cO] == 0;
+ Smorph1 : [cI] == 1;
+ Smorph_add : forall x y, [x +! y] == [x]+[y];
+ Smorph_mul : forall x y, [x *! y] == [x]*[y];
+ Smorph_eq : forall x y, x?=!y = true -> [x] == [y]
+ }.
+
+(* for rings*)
+ Record ring_morph : Prop := mkmorph {
+ morph0 : [cO] == 0;
+ morph1 : [cI] == 1;
+ morph_add : forall x y, [x +! y] == [x]+[y];
+ morph_sub : forall x y, [x -! y] == [x]-[y];
+ morph_mul : forall x y, [x *! y] == [x]*[y];
+ morph_opp : forall x, [-!x] == -[x];
+ morph_eq : forall x y, x?=!y = true -> [x] == [y]
+ }.
+
+ Section SIGN.
+ Variable get_sign : C -> option C.
+ Record sign_theory : Prop := mksign_th {
+ sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true
+ }.
+ End SIGN.
+
+ Definition get_sign_None (c:C) := @None C.
+
+ Lemma get_sign_None_th : sign_theory get_sign_None.
+ Proof. constructor;intros;discriminate. Qed.
+
+ Section DIV.
+ Variable cdiv: C -> C -> C*C.
+ Record div_theory : Prop := mkdiv_th {
+ div_eucl_th : forall a b, let (q,r) := cdiv a b in [a] == [b *! q +! r]
+ }.
+ End DIV.
+
+ End MORPHISM.
+
+ (** Identity is a morphism *)
+ Variable Rsth : Setoid_Theory R req.
+ Add Setoid R req Rsth as R_setoid1.
+ Variable reqb : R->R->bool.
+ Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y.
+ Definition IDphi (x:R) := x.
+ Lemma IDmorph : ring_morph rO rI radd rmul rsub ropp reqb IDphi.
+ Proof.
+ apply (mkmorph rO rI radd rmul rsub ropp reqb IDphi);intros;unfold IDphi;
+ try apply (Seq_refl _ _ Rsth);auto.
+ Qed.
+
+ (** 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, req (rpow r (Cp_phi n)) (pow_N rI rmul r n)
+ }.
+
+ End POWER.
+
+ Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth).
+
+
+End DEFINITIONS.
+
+
+
+Section ALMOST_RING.
+ Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop.
+ Notation "0" := rO. Notation "1" := rI.
+ Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y).
+ Notation "x - y " := (rsub x y). Notation "- x" := (ropp x).
+ Notation "x == y" := (req x y).
+
+ (** Leibniz equality leads to a setoid theory and is extensional*)
+ Lemma Eqsth : Setoid_Theory R (@eq R).
+ Proof. constructor;red;intros;subst;trivial. Qed.
+
+ Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R).
+ Proof. constructor;intros;subst;trivial. Qed.
+
+ Lemma Eq_ext : ring_eq_ext radd rmul ropp (@eq R).
+ Proof. constructor;intros;subst;trivial. Qed.
+
+ Variable Rsth : Setoid_Theory R req.
+ Add Setoid R req Rsth as R_setoid2.
+ Ltac sreflexivity := apply (Seq_refl _ _ Rsth).
+
+ Section SEMI_RING.
+ Variable SReqe : sring_eq_ext radd rmul req.
+ Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed.
+ Add Morphism rmul : rmul_ext1. exact (SRmul_ext SReqe). Qed.
+ Variable SRth : semi_ring_theory 0 1 radd rmul req.
+
+ (** Every semi ring can be seen as an almost ring, by taking :
+ -x = x and x - y = x + y *)
+ Definition SRopp (x:R) := x. Notation "- x" := (SRopp x).
+
+ Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y).
+
+ Lemma SRopp_ext : forall x y, x == y -> -x == -y.
+ Proof. intros x y H;exact H. Qed.
+
+ Lemma SReqe_Reqe : ring_eq_ext radd rmul SRopp req.
+ Proof.
+ constructor. exact (SRadd_ext SReqe). exact (SRmul_ext SReqe).
+ exact SRopp_ext.
+ Qed.
+
+ Lemma SRopp_mul_l : forall x y, -(x * y) == -x * y.
+ Proof. intros;sreflexivity. Qed.
+
+ Lemma SRopp_add : forall x y, -(x + y) == -x + -y.
+ Proof. intros;sreflexivity. Qed.
+
+
+ Lemma SRsub_def : forall x y, x - y == x + -y.
+ Proof. intros;sreflexivity. Qed.
+
+ Lemma SRth_ARth : almost_ring_theory 0 1 radd rmul SRsub SRopp req.
+ Proof (mk_art 0 1 radd rmul SRsub SRopp req
+ (SRadd_0_l SRth) (SRadd_comm SRth) (SRadd_assoc SRth)
+ (SRmul_1_l SRth) (SRmul_0_l SRth)
+ (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth)
+ SRopp_mul_l SRopp_add SRsub_def).
+
+ (** Identity morphism for semi-ring equipped with their almost-ring structure*)
+ Variable reqb : R->R->bool.
+
+ Hypothesis morph_req : forall x y, (reqb x y) = true -> x == y.
+
+ Definition SRIDmorph : ring_morph 0 1 radd rmul SRsub SRopp req
+ 0 1 radd rmul SRsub SRopp reqb (@IDphi R).
+ Proof.
+ apply mkmorph;intros;try sreflexivity. unfold IDphi;auto.
+ Qed.
+
+ (* a semi_morph can be extended to a ring_morph for the almost_ring derived
+ from a semi_ring, provided the ring is a setoid (we only need
+ reflexivity) *)
+ Variable C : Type.
+ Variable (cO cI : C) (cadd cmul: C->C->C).
+ Variable (ceqb : C -> C -> bool).
+ Variable phi : C -> R.
+ Variable Smorph : semi_morph rO rI radd rmul req cO cI cadd cmul ceqb phi.
+
+ Lemma SRmorph_Rmorph :
+ ring_morph rO rI radd rmul SRsub SRopp req
+ cO cI cadd cmul cadd (fun x => x) ceqb phi.
+ Proof.
+ case Smorph; intros; constructor; auto.
+ unfold SRopp in |- *; intros.
+ setoid_reflexivity.
+ Qed.
+
+ End SEMI_RING.
+
+ Variable Reqe : ring_eq_ext radd rmul ropp req.
+ Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed.
+ Add Morphism rmul : rmul_ext2. exact (Rmul_ext Reqe). Qed.
+ Add Morphism ropp : ropp_ext2. exact (Ropp_ext Reqe). Qed.
+
+ Section RING.
+ Variable Rth : ring_theory 0 1 radd rmul rsub ropp req.
+
+ (** Rings are almost rings*)
+ Lemma Rmul_0_l : forall x, 0 * x == 0.
+ Proof.
+ intro x; setoid_replace (0*x) with ((0+1)*x + -x).
+ rewrite (Radd_0_l Rth); rewrite (Rmul_1_l Rth).
+ rewrite (Ropp_def Rth);sreflexivity.
+
+ rewrite (Rdistr_l Rth);rewrite (Rmul_1_l Rth).
+ rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
+ rewrite (Radd_comm Rth); rewrite (Radd_0_l Rth);sreflexivity.
+ Qed.
+
+ Lemma Ropp_mul_l : forall x y, -(x * y) == -x * y.
+ Proof.
+ intros x y;rewrite <-(Radd_0_l Rth (- x * y)).
+ rewrite (Radd_comm Rth).
+ rewrite <-(Ropp_def Rth (x*y)).
+ rewrite (Radd_assoc Rth).
+ rewrite <- (Rdistr_l Rth).
+ rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth).
+ rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity.
+ Qed.
+
+ Lemma Ropp_add : forall x y, -(x + y) == -x + -y.
+ Proof.
+ intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))).
+ rewrite <- ((Ropp_def Rth) x).
+ rewrite <- ((Radd_0_l Rth) (x + - x + - (x + y))).
+ rewrite <- ((Ropp_def Rth) y).
+ rewrite ((Radd_comm Rth) x).
+ rewrite ((Radd_comm Rth) y).
+ rewrite <- ((Radd_assoc Rth) (-y)).
+ rewrite <- ((Radd_assoc Rth) (- x)).
+ rewrite ((Radd_assoc Rth) y).
+ rewrite ((Radd_comm Rth) y).
+ rewrite <- ((Radd_assoc Rth) (- x)).
+ rewrite ((Radd_assoc Rth) y).
+ rewrite ((Radd_comm Rth) y);rewrite (Ropp_def Rth).
+ rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth).
+ apply (Radd_comm Rth).
+ Qed.
+
+ Lemma Ropp_opp : forall x, - -x == x.
+ Proof.
+ intros x; rewrite <- (Radd_0_l Rth (- -x)).
+ rewrite <- (Ropp_def Rth x).
+ rewrite <- (Radd_assoc Rth); rewrite (Ropp_def Rth).
+ rewrite ((Radd_comm Rth) x);apply (Radd_0_l Rth).
+ Qed.
+
+ Lemma Rth_ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
+ Proof
+ (mk_art 0 1 radd rmul rsub ropp req (Radd_0_l Rth) (Radd_comm Rth) (Radd_assoc Rth)
+ (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth)
+ Ropp_mul_l Ropp_add (Rsub_def Rth)).
+
+ (** Every semi morphism between two rings is a morphism*)
+ Variable C : Type.
+ Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C).
+ Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool).
+ Variable phi : C -> R.
+ Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y).
+ Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
+ Notation "x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
+ Variable Csth : Setoid_Theory C ceq.
+ Variable Ceqe : ring_eq_ext cadd cmul copp ceq.
+ Add Setoid C ceq Csth as C_setoid.
+ Add Morphism cadd : cadd_ext. exact (Radd_ext Ceqe). Qed.
+ Add Morphism cmul : cmul_ext. exact (Rmul_ext Ceqe). Qed.
+ Add Morphism copp : copp_ext. exact (Ropp_ext Ceqe). Qed.
+ Variable Cth : ring_theory cO cI cadd cmul csub copp ceq.
+ Variable Smorph : semi_morph 0 1 radd rmul req cO cI cadd cmul ceqb phi.
+ Variable phi_ext : forall x y, ceq x y -> [x] == [y].
+ Add Morphism phi : phi_ext1. exact phi_ext. Qed.
+ Lemma Smorph_opp : forall x, [-!x] == -[x].
+ Proof.
+ intros x;rewrite <- (Rth.(Radd_0_l) [-!x]).
+ rewrite <- ((Ropp_def Rth) [x]).
+ rewrite ((Radd_comm Rth) [x]).
+ rewrite <- (Radd_assoc Rth).
+ rewrite <- (Smorph_add Smorph).
+ rewrite (Ropp_def Cth).
+ rewrite (Smorph0 Smorph).
+ rewrite (Radd_comm Rth (-[x])).
+ apply (Radd_0_l Rth);sreflexivity.
+ Qed.
+
+ Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y].
+ Proof.
+ intros x y; rewrite (Rsub_def Cth);rewrite (Rsub_def Rth).
+ rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity.
+ Qed.
+
+ Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req
+ cO cI cadd cmul csub copp ceqb phi.
+ Proof
+ (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi
+ (Smorph0 Smorph) (Smorph1 Smorph)
+ (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp
+ (Smorph_eq Smorph)).
+
+ End RING.
+
+ (** Useful lemmas on almost ring *)
+ Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
+
+ Lemma ARth_SRth : semi_ring_theory 0 1 radd rmul req.
+Proof.
+elim ARth; intros.
+constructor; trivial.
+Qed.
+
+ Lemma ARsub_ext :
+ forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2.
+ Proof.
+ intros.
+ setoid_replace (x1 - y1) with (x1 + -y1).
+ setoid_replace (x2 - y2) with (x2 + -y2).
+ rewrite H;rewrite H0;sreflexivity.
+ apply (ARsub_def ARth).
+ apply (ARsub_def ARth).
+ Qed.
+ Add Morphism rsub : rsub_ext. exact ARsub_ext. Qed.
+
+ Ltac mrewrite :=
+ repeat first
+ [ rewrite (ARadd_0_l ARth)
+ | rewrite <- ((ARadd_comm ARth) 0)
+ | rewrite (ARmul_1_l ARth)
+ | rewrite <- ((ARmul_comm ARth) 1)
+ | rewrite (ARmul_0_l ARth)
+ | rewrite <- ((ARmul_comm ARth) 0)
+ | rewrite (ARdistr_l ARth)
+ | sreflexivity
+ | match goal with
+ | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y))
+ end].
+
+ Lemma ARadd_0_r : forall x, (x + 0) == x.
+ Proof. intros; mrewrite. Qed.
+
+ Lemma ARmul_1_r : forall x, x * 1 == x.
+ Proof. intros;mrewrite. Qed.
+
+ Lemma ARmul_0_r : forall x, x * 0 == 0.
+ Proof. intros;mrewrite. Qed.
+
+ Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y.
+ Proof.
+ intros;mrewrite.
+ repeat rewrite (ARth.(ARmul_comm) z);sreflexivity.
+ Qed.
+
+ Lemma ARadd_assoc1 : forall x y z, (x + y) + z == (y + z) + x.
+ Proof.
+ intros;rewrite <-(ARth.(ARadd_assoc) x).
+ rewrite (ARth.(ARadd_comm) x);sreflexivity.
+ Qed.
+
+ Lemma ARadd_assoc2 : forall x y z, (y + x) + z == (y + z) + x.
+ Proof.
+ intros; repeat rewrite <- (ARadd_assoc ARth);
+ rewrite ((ARadd_comm ARth) x); sreflexivity.
+ Qed.
+
+ Lemma ARmul_assoc1 : forall x y z, (x * y) * z == (y * z) * x.
+ Proof.
+ intros;rewrite <-((ARmul_assoc ARth) x).
+ rewrite ((ARmul_comm ARth) x);sreflexivity.
+ Qed.
+
+ Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x.
+ Proof.
+ intros; repeat rewrite <- (ARmul_assoc ARth);
+ rewrite ((ARmul_comm ARth) x); sreflexivity.
+ Qed.
+
+ Lemma ARopp_mul_r : forall x y, - (x * y) == x * -y.
+ Proof.
+ intros;rewrite ((ARmul_comm ARth) x y);
+ rewrite (ARopp_mul_l ARth); apply (ARmul_comm ARth).
+ Qed.
+
+ Lemma ARopp_zero : -0 == 0.
+ Proof.
+ rewrite <- (ARmul_0_r 0); rewrite (ARopp_mul_l ARth).
+ repeat rewrite ARmul_0_r; sreflexivity.
+ Qed.
+
+
+
+End ALMOST_RING.
+
+
+Section AddRing.
+
+(* Variable R : Type.
+ Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R).
+ Variable req : R -> R -> Prop. *)
+
+Inductive ring_kind : Type :=
+| Abstract
+| Computational
+ (R:Type)
+ (req : R -> R -> Prop)
+ (reqb : R -> R -> bool)
+ (_ : forall x y, (reqb x y) = true -> req x y)
+| Morphism
+ (R : Type)
+ (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R)
+ (req : R -> R -> Prop)
+ (C : Type)
+ (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C)
+ (ceqb : C->C->bool)
+ phi
+ (_ : ring_morph rO rI radd rmul rsub ropp req
+ cO cI cadd cmul csub copp ceqb phi).
+
+
+End AddRing.
+
+
+(** Some simplification tactics*)
+Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth).
+
+Ltac gen_srewrite 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)
+ | progress rewrite (ARopp_add ARth)
+ | progress rewrite (ARsub_def ARth)
+ | progress rewrite <- (ARopp_mul_l ARth)
+ | progress rewrite <- (ARopp_mul_r Rsth Reqe ARth) ].
+
+Ltac gen_add_push add Rsth Reqe ARth x :=
+ repeat (match goal with
+ | |- context [add (add ?y x) ?z] =>
+ progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z)
+ | |- context [add (add x ?y) ?z] =>
+ progress rewrite (ARadd_assoc1 Rsth ARth x y z)
+ end).
+
+Ltac gen_mul_push mul Rsth Reqe ARth x :=
+ repeat (match goal with
+ | |- context [mul (mul ?y x) ?z] =>
+ progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z)
+ | |- context [mul (mul x ?y) ?z] =>
+ progress rewrite (ARmul_assoc1 Rsth ARth x y z)
+ end).
+
diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
new file mode 100644
index 00000000..4cb5a05a
--- /dev/null
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -0,0 +1,60 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+Require Export Ring.
+Require Import ZArith_base.
+Require Import Zpow_def.
+
+Import InitialRing.
+
+Set Implicit Arguments.
+
+Ltac Zcst t :=
+ match isZcst t with
+ true => t
+ | _ => constr:NotConstant
+ end.
+
+Ltac isZpow_coef t :=
+ match t with
+ | Zpos ?p => isPcst p
+ | Z0 => constr:true
+ | _ => constr:false
+ end.
+
+Definition N_of_Z x :=
+ match x with
+ | Zpos p => Npos p
+ | _ => N0
+ end.
+
+Ltac Zpow_tac t :=
+ match isZpow_coef t with
+ | true => constr:(N_of_Z t)
+ | _ => constr:NotConstant
+ end.
+
+Ltac Zpower_neg :=
+ repeat match goal with
+ | [|- ?G] =>
+ match G with
+ | context c [Zpower _ (Zneg _)] =>
+ let t := context c [Z0] in
+ change t
+ end
+ end.
+
+Add Ring Zr : Zth
+ (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
+ power_tac Zpower_theory [Zpow_tac],
+ (* The two following option are not needed, it is the default chose when the set of
+ coefficiant is usual ring Z *)
+ div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)),
+ sign get_signZ_th).
+
+
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4
new file mode 100644
index 00000000..535dbdbd
--- /dev/null
+++ b/plugins/setoid_ring/newring.ml4
@@ -0,0 +1,1164 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(*i $Id$ i*)
+
+open Pp
+open Util
+open Names
+open Term
+open Closure
+open Environ
+open Libnames
+open Tactics
+open Rawterm
+open Termops
+open Tacticals
+open Tacexpr
+open Pcoq
+open Tactic
+open Constr
+open Proof_type
+open Coqlib
+open Tacmach
+open Mod_subst
+open Tacinterp
+open Libobject
+open Printer
+open Declare
+open Decl_kinds
+open Entries
+
+(****************************************************************************)
+(* controlled reduction *)
+
+let mark_arg i c = mkEvar(i,[|c|])
+let unmark_arg f c =
+ match destEvar c with
+ | (i,[|c|]) -> f i c
+ | _ -> assert false
+
+type protect_flag = Eval|Prot|Rec
+
+let tag_arg tag_rec map subs i c =
+ match map i with
+ Eval -> mk_clos subs c
+ | Prot -> mk_atom c
+ | Rec -> if i = -1 then mk_clos subs c else tag_rec c
+
+let rec mk_clos_but f_map subs t =
+ match f_map t with
+ | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t
+ | None ->
+ (match kind_of_term t with
+ App(f,args) -> mk_clos_app_but f_map subs f args 0
+ | Prod _ -> mk_clos_deep (mk_clos_but f_map) subs t
+ | _ -> mk_atom t)
+
+and mk_clos_app_but f_map subs f args n =
+ if n >= Array.length args then mk_atom(mkApp(f, args))
+ else
+ let fargs, args' = array_chop n args in
+ let f' = mkApp(f,fargs) in
+ match f_map f' with
+ Some map ->
+ mk_clos_deep
+ (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s'))
+ subs
+ (mkApp (mark_arg (-1) f', Array.mapi mark_arg args'))
+ | None -> mk_clos_app_but f_map subs f args (n+1)
+
+
+let interp_map l c =
+ try
+ let (im,am) = List.assoc c l in
+ Some(fun i ->
+ if List.mem i im then Eval
+ else if List.mem i am then Prot
+ else if i = -1 then Eval
+ else Rec)
+ with Not_found -> None
+
+let interp_map l t =
+ try Some(List.assoc 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
+let lookup_map map =
+ try Stringmap.find map !protect_maps
+ with Not_found ->
+ errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
+
+let protect_red map env sigma c =
+ kl (create_clos_infos betadeltaiota env)
+ (mk_clos_but (lookup_map map c) (Esubst.ESID 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));;
+
+
+TACTIC EXTEND protect_fv
+ [ "protect_fv" string(map) "in" ident(id) ] ->
+ [ protect_tac_in map id ]
+| [ "protect_fv" string(map) ] ->
+ [ protect_tac map ]
+END;;
+
+(****************************************************************************)
+
+let closed_term t l =
+ let l = List.map constr_of_global l in
+ let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in
+ if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt())
+;;
+
+TACTIC EXTEND closed_term
+ [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
+ [ closed_term t l ]
+END
+;;
+
+TACTIC EXTEND echo
+| [ "echo" constr(t) ] ->
+ [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ]
+END;;
+
+(*
+let closed_term_ast l =
+ TacFun([Some(id_of_string"t")],
+ TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
+ [Genarg.in_gen Genarg.wit_constr (mkVar(id_of_string"t"));
+ Genarg.in_gen (Genarg.wit_list1 Genarg.wit_ref) l])))
+*)
+let closed_term_ast l =
+ let l = List.map (fun gr -> ArgArg(dummy_loc,gr)) l in
+ TacFun([Some(id_of_string"t")],
+ TacAtom(dummy_loc,TacExtend(dummy_loc,"closed_term",
+ [Genarg.in_gen Genarg.globwit_constr (RVar(dummy_loc,id_of_string"t"),None);
+ Genarg.in_gen (Genarg.wit_list1 Genarg.globwit_ref) l])))
+(*
+let _ = add_tacdef false ((dummy_loc,id_of_string"ring_closed_term"
+*)
+
+(****************************************************************************)
+
+let ic c =
+ let env = Global.env() and sigma = Evd.empty in
+ Constrintern.interp_constr sigma env c
+
+let ty c = Typing.type_of (Global.env()) Evd.empty c
+
+let decl_constant na c =
+ mkConst(declare_constant (id_of_string na) (DefinitionEntry
+ { const_entry_body = c;
+ const_entry_type = None;
+ const_entry_opaque = true;
+ const_entry_boxed = true},
+ IsProof Lemma))
+
+(* Calling a global tactic *)
+let ltac_call tac (args:glob_tactic_arg list) =
+ TacArg(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))
+
+let ltac_letin (x, e1) e2 =
+ TacLetIn(false,[(dummy_loc,id_of_string x),e1],e2)
+
+let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) =
+ Tacinterp.eval_tactic
+ (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args))
+
+let ltac_record flds =
+ TacFun([Some(id_of_string"proj")], ltac_lcall "proj" 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 exec_tactic env n f args =
+ let lid = list_tabulate(fun i -> id_of_string("x"^string_of_int i)) n in
+ let res = ref [||] in
+ let get_res ist =
+ let l = List.map (fun id -> List.assoc id ist.lfun) lid in
+ res := Array.of_list l;
+ TacId[] in
+ let getter =
+ Tacexp(TacFun(List.map(fun id -> Some id) lid,
+ glob_tactic(tacticIn get_res))) in
+ let _ =
+ Tacinterp.eval_tactic(ltac_call f (args@[getter])) (dummy_goal env) in
+ !res
+
+let constr_of = function
+ | VConstr ([],c) -> c
+ | _ -> failwith "Ring.exec_tactic: anomaly"
+
+let stdlib_modules =
+ [["Coq";"Setoids";"Setoid"];
+ ["Coq";"Lists";"List"];
+ ["Coq";"Init";"Datatypes"];
+ ["Coq";"Init";"Logic"];
+ ]
+
+let coq_constant c =
+ lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)
+
+let coq_mk_Setoid = coq_constant "Build_Setoid_Theory"
+let coq_cons = coq_constant "cons"
+let coq_nil = coq_constant "nil"
+let coq_None = coq_constant "None"
+let coq_Some = coq_constant "Some"
+let coq_eq = coq_constant "eq"
+
+let lapp f args = mkApp(Lazy.force f,args)
+
+let dest_rel0 t =
+ match kind_of_term t with
+ | App(f,args) when Array.length args >= 2 ->
+ let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in
+ if closed0 rel then
+ (rel,args.(Array.length args - 2),args.(Array.length args - 1))
+ else error "ring: cannot find relation (not closed)"
+ | _ -> error "ring: cannot find relation"
+
+let rec dest_rel t =
+ match kind_of_term t with
+ | Prod(_,_,c) -> dest_rel c
+ | _ -> dest_rel0 t
+
+(****************************************************************************)
+(* Library linking *)
+
+let plugin_dir = "setoid_ring"
+
+let cdir = ["Coq";plugin_dir]
+let plugin_modules =
+ List.map (fun d -> cdir@d)
+ [["Ring_theory"];["Ring_polynom"]; ["Ring_tac"];["InitialRing"];
+ ["Field_tac"]; ["Field_theory"]
+ ]
+
+let my_constant c =
+ lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c)
+
+let new_ring_path =
+ make_dirpath (List.map id_of_string ["Ring_tac";plugin_dir;"Coq"])
+let ltac s =
+ lazy(make_kn (MPfile new_ring_path) (make_dirpath []) (mk_label s))
+let znew_ring_path =
+ make_dirpath (List.map id_of_string ["InitialRing";plugin_dir;"Coq"])
+let zltac s =
+ lazy(make_kn (MPfile znew_ring_path) (make_dirpath []) (mk_label s))
+
+let mk_cst l s = lazy (Coqlib.gen_constant "newring" l s);;
+let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;;
+
+(* Ring theory *)
+
+(* almost_ring defs *)
+let coq_almost_ring_theory = my_constant "almost_ring_theory"
+
+(* setoid and morphism utilities *)
+let coq_eq_setoid = my_constant "Eqsth"
+let coq_eq_morph = my_constant "Eq_ext"
+let coq_eq_smorph = my_constant "Eq_s_ext"
+
+(* ring -> almost_ring utilities *)
+let coq_ring_theory = my_constant "ring_theory"
+let coq_mk_reqe = my_constant "mk_reqe"
+
+(* semi_ring -> almost_ring utilities *)
+let coq_semi_ring_theory = my_constant "semi_ring_theory"
+let coq_mk_seqe = my_constant "mk_seqe"
+
+let ltac_inv_morph_gen = zltac"inv_gen_phi"
+let ltac_inv_morphZ = zltac"inv_gen_phiZ"
+let ltac_inv_morphN = zltac"inv_gen_phiN"
+let ltac_inv_morphNword = zltac"inv_gen_phiNword"
+let coq_abstract = my_constant"Abstract"
+let coq_comp = my_constant"Computational"
+let coq_morph = my_constant"Morphism"
+
+(* morphism *)
+let coq_ring_morph = my_constant "ring_morph"
+let coq_semi_morph = my_constant "semi_morph"
+
+(* power function *)
+let ltac_inv_morph_nothing = zltac"inv_morph_nothing"
+let coq_pow_N_pow_N = my_constant "pow_N_pow_N"
+
+(* hypothesis *)
+let coq_mkhypo = my_constant "mkhypo"
+let coq_hypo = my_constant "hypo"
+
+(* Equality: do not evaluate but make recursive call on both sides *)
+let map_with_eq arg_map c =
+ let (req,_,_) = dest_rel c in
+ interp_map
+ ((req,(function -1->Prot|_->Rec))::
+ List.map (fun (c,map) -> (Lazy.force c,map)) arg_map)
+
+let _ = add_map "ring"
+ (map_with_eq
+ [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+ coq_nil, (function -1->Eval|_ -> Prot);
+ (* Pphi_dev: evaluate polynomial and coef operations, protect
+ ring operations and make recursive call on the var map *)
+ pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
+ pol_cst "Pphi_pow",
+ (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
+ (* PEeval: evaluate morphism and polynomial, protect ring
+ operations and make recursive call on the var map *)
+ pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)])
+
+(****************************************************************************)
+(* Ring database *)
+
+type ring_info =
+ { ring_carrier : types;
+ ring_req : constr;
+ ring_setoid : constr;
+ ring_ext : constr;
+ ring_morph : constr;
+ ring_th : constr;
+ ring_cst_tac : glob_tactic_expr;
+ ring_pow_tac : glob_tactic_expr;
+ ring_lemma1 : constr;
+ ring_lemma2 : constr;
+ ring_pre_tac : glob_tactic_expr;
+ ring_post_tac : glob_tactic_expr }
+
+module Cmap = Map.Make(struct type t = constr let compare = compare end)
+
+let from_carrier = ref Cmap.empty
+let from_relation = ref Cmap.empty
+let from_name = ref Spmap.empty
+
+let ring_for_carrier r = Cmap.find r !from_carrier
+let ring_for_relation rel = Cmap.find rel !from_relation
+
+
+let find_ring_structure env sigma l =
+ match l with
+ | t::cl' ->
+ let ty = Retyping.get_type_of env sigma t in
+ let check c =
+ let ty' = Retyping.get_type_of env sigma c in
+ if not (Reductionops.is_conv env sigma ty ty') then
+ errorlabstrm "ring"
+ (str"arguments of ring_simplify do not have all the same type")
+ in
+ List.iter check cl';
+ (try ring_for_carrier ty
+ with Not_found ->
+ errorlabstrm "ring"
+ (str"cannot find a declared ring structure over"++
+ spc()++str"\""++pr_constr ty++str"\""))
+ | [] -> assert false
+(*
+ let (req,_,_) = dest_rel cl in
+ (try ring_for_relation req
+ with Not_found ->
+ errorlabstrm "ring"
+ (str"cannot find a declared ring structure for equality"++
+ spc()++str"\""++pr_constr req++str"\"")) *)
+
+let _ =
+ Summary.declare_summary "tactic-new-ring-table"
+ { Summary.freeze_function =
+ (fun () -> !from_carrier,!from_relation,!from_name);
+ Summary.unfreeze_function =
+ (fun (ct,rt,nt) ->
+ from_carrier := ct; from_relation := rt; from_name := nt);
+ Summary.init_function =
+ (fun () ->
+ from_carrier := Cmap.empty; from_relation := Cmap.empty;
+ from_name := Spmap.empty) }
+
+let add_entry (sp,_kn) e =
+(* let _ = ty e.ring_lemma1 in
+ let _ = ty e.ring_lemma2 in
+*)
+ from_carrier := Cmap.add e.ring_carrier e !from_carrier;
+ from_relation := Cmap.add e.ring_req e !from_relation;
+ from_name := Spmap.add sp e !from_name
+
+
+let subst_th (subst,th) =
+ let c' = subst_mps subst th.ring_carrier in
+ let eq' = subst_mps subst th.ring_req in
+ let set' = subst_mps subst th.ring_setoid in
+ let ext' = subst_mps subst th.ring_ext in
+ let morph' = subst_mps subst th.ring_morph in
+ let th' = subst_mps subst th.ring_th in
+ let thm1' = subst_mps subst th.ring_lemma1 in
+ let thm2' = subst_mps subst th.ring_lemma2 in
+ let tac'= subst_tactic subst th.ring_cst_tac in
+ let pow_tac'= subst_tactic subst th.ring_pow_tac in
+ let pretac'= subst_tactic subst th.ring_pre_tac in
+ let posttac'= subst_tactic subst th.ring_post_tac in
+ if c' == th.ring_carrier &&
+ eq' == th.ring_req &&
+ set' = th.ring_setoid &&
+ ext' == th.ring_ext &&
+ morph' == th.ring_morph &&
+ th' == th.ring_th &&
+ thm1' == th.ring_lemma1 &&
+ thm2' == th.ring_lemma2 &&
+ tac' == th.ring_cst_tac &&
+ pow_tac' == th.ring_pow_tac &&
+ pretac' == th.ring_pre_tac &&
+ posttac' == th.ring_post_tac then th
+ else
+ { ring_carrier = c';
+ ring_req = eq';
+ ring_setoid = set';
+ ring_ext = ext';
+ ring_morph = morph';
+ ring_th = th';
+ ring_cst_tac = tac';
+ ring_pow_tac = pow_tac';
+ ring_lemma1 = thm1';
+ ring_lemma2 = thm2';
+ ring_pre_tac = pretac';
+ ring_post_tac = posttac' }
+
+
+let (theory_to_obj, obj_to_theory) =
+ let cache_th (name,th) = add_entry name th in
+ declare_object
+ {(default_object "tactic-new-ring-theory") with
+ open_function = (fun i o -> if i=1 then cache_th o);
+ cache_function = cache_th;
+ subst_function = subst_th;
+ classify_function = (fun x -> Substitute x)}
+
+
+let setoid_of_relation env a r =
+ let evm = Evd.empty in
+ try
+ lapp coq_mk_Setoid
+ [|a ; r ;
+ Rewrite.get_reflexive_proof env evm a r ;
+ Rewrite.get_symmetric_proof env evm a r ;
+ Rewrite.get_transitive_proof env evm a r |]
+ with Not_found ->
+ error "cannot find setoid relation"
+
+let op_morph r add mul opp req m1 m2 m3 =
+ lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |]
+
+let op_smorph r add mul req m1 m2 =
+ lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |]
+
+(* let default_ring_equality (r,add,mul,opp,req) = *)
+(* let is_setoid = function *)
+(* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *)
+(* eq_constr req rel (\* Qu: use conversion ? *\) *)
+(* | _ -> false in *)
+(* match default_relation_for_carrier ~filter:is_setoid r with *)
+(* Leibniz _ -> *)
+(* let setoid = lapp coq_eq_setoid [|r|] in *)
+(* let op_morph = *)
+(* match opp with *)
+(* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *)
+(* | None -> lapp coq_eq_smorph [|r;add;mul|] in *)
+(* (setoid,op_morph) *)
+(* | Relation rel -> *)
+(* let setoid = setoid_of_relation rel in *)
+(* let is_endomorphism = function *)
+(* { args=args } -> List.for_all *)
+(* (function (var,Relation rel) -> *)
+(* var=None && eq_constr req rel *)
+(* | _ -> false) args in *)
+(* let add_m = *)
+(* try default_morphism ~filter:is_endomorphism add *)
+(* with Not_found -> *)
+(* error "ring addition should be declared as a morphism" in *)
+(* let mul_m = *)
+(* try default_morphism ~filter:is_endomorphism mul *)
+(* with Not_found -> *)
+(* error "ring multiplication should be declared as a morphism" in *)
+(* let op_morph = *)
+(* match opp with *)
+(* | Some opp -> *)
+(* (let opp_m = *)
+(* try default_morphism ~filter:is_endomorphism opp *)
+(* with Not_found -> *)
+(* error "ring opposite should be declared as a morphism" in *)
+(* let op_morph = *)
+(* op_morph r add mul opp req add_m.lem mul_m.lem opp_m.lem in *)
+(* msgnl *)
+(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *)
+(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *)
+(* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *)
+(* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *)
+(* str"\""); *)
+(* op_morph) *)
+(* | None -> *)
+(* (msgnl *)
+(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *)
+(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *)
+(* str"\""++spc()++str"and \""++ *)
+(* pr_constr mul_m.morphism_theory++str"\""); *)
+(* op_smorph r add mul req add_m.lem mul_m.lem) in *)
+(* (setoid,op_morph) *)
+
+let ring_equality (r,add,mul,opp,req) =
+ match kind_of_term req with
+ | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) ->
+ let setoid = lapp coq_eq_setoid [|r|] in
+ let op_morph =
+ match opp with
+ Some opp -> lapp coq_eq_morph [|r;add;mul;opp|]
+ | None -> lapp coq_eq_smorph [|r;add;mul|] in
+ (setoid,op_morph)
+ | _ ->
+ let setoid = setoid_of_relation (Global.env ()) r req in
+ let signature = [Some (r,req);Some (r,req)],Some(r,req) in
+ let add_m, add_m_lem =
+ try Rewrite.default_morphism signature add
+ with Not_found ->
+ error "ring addition should be declared as a morphism" in
+ let mul_m, mul_m_lem =
+ try Rewrite.default_morphism signature mul
+ with Not_found ->
+ error "ring multiplication should be declared as a morphism" in
+ let op_morph =
+ match opp with
+ | Some opp ->
+ (let opp_m,opp_m_lem =
+ try Rewrite.default_morphism ([Some(r,req)],Some(r,req)) opp
+ with Not_found ->
+ error "ring opposite should be declared as a morphism" in
+ let op_morph =
+ op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in
+ Flags.if_verbose
+ msgnl
+ (str"Using setoid \""++pr_constr req++str"\""++spc()++
+ str"and morphisms \""++pr_constr add_m_lem ++
+ str"\","++spc()++ str"\""++pr_constr mul_m_lem++
+ str"\""++spc()++str"and \""++pr_constr opp_m_lem++
+ str"\"");
+ op_morph)
+ | None ->
+ (Flags.if_verbose
+ msgnl
+ (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++
+ str"and morphisms \""++pr_constr add_m_lem ++
+ str"\""++spc()++str"and \""++
+ pr_constr mul_m_lem++str"\"");
+ op_smorph r add mul req add_m_lem mul_m_lem) in
+ (setoid,op_morph)
+
+let build_setoid_params r add mul opp req eqth =
+ match eqth with
+ Some th -> th
+ | None -> ring_equality (r,add,mul,opp,req)
+
+let dest_ring env sigma th_spec =
+ let th_typ = Retyping.get_type_of env sigma th_spec in
+ match kind_of_term th_typ with
+ App(f,[|r;zero;one;add;mul;sub;opp;req|])
+ when f = Lazy.force coq_almost_ring_theory ->
+ (None,r,zero,one,add,mul,Some sub,Some opp,req)
+ | App(f,[|r;zero;one;add;mul;req|])
+ when f = Lazy.force coq_semi_ring_theory ->
+ (Some true,r,zero,one,add,mul,None,None,req)
+ | App(f,[|r;zero;one;add;mul;sub;opp;req|])
+ when f = Lazy.force coq_ring_theory ->
+ (Some false,r,zero,one,add,mul,Some sub,Some opp,req)
+ | _ -> error "bad ring structure"
+
+
+let dest_morph env sigma m_spec =
+ let m_typ = Retyping.get_type_of env sigma m_spec in
+ 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 ->
+ (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 ->
+ (c,czero,cone,cadd,cmul,None,None,ceqb,phi)
+ | _ -> error "bad morphism structure"
+
+
+type coeff_spec =
+ Computational of constr (* equality test *)
+ | Abstract (* coeffs = Z *)
+ | Morphism of constr (* general morphism *)
+
+
+let reflect_coeff rkind =
+ (* We build an ill-typed terms on purpose... *)
+ match rkind with
+ Abstract -> Lazy.force coq_abstract
+ | Computational c -> lapp coq_comp [|c|]
+ | Morphism m -> lapp coq_morph [|m|]
+
+type cst_tac_spec =
+ CstTac of raw_tactic_expr
+ | Closed of reference list
+
+let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
+ match cst_tac with
+ Some (CstTac t) -> Tacinterp.glob_tactic t
+ | Some (Closed lc) ->
+ closed_term_ast (List.map Smartlocate.global_with_alias lc)
+ | None ->
+ (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]))
+ | 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]))
+ | 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]))
+ | 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]))
+ | 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])))
+
+let make_hyp env c =
+ let t = Retyping.get_type_of env Evd.empty c in
+ lapp coq_mkhypo [|t;c|]
+
+let make_hyp_list env lH =
+ let carrier = Lazy.force coq_hypo in
+ List.fold_right
+ (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH
+ (lapp coq_nil [|carrier|])
+
+let interp_power env pow =
+ let carrier = Lazy.force coq_hypo in
+ 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|])
+ | Some (tac, spec) ->
+ let tac =
+ match tac with
+ | CstTac t -> Tacinterp.glob_tactic t
+ | Closed lc ->
+ closed_term_ast (List.map Smartlocate.global_with_alias lc) in
+ let spec = make_hyp env (ic spec) in
+ (tac, lapp coq_Some [|carrier; spec|])
+
+let interp_sign env sign =
+ let carrier = Lazy.force coq_hypo in
+ match sign with
+ | None -> lapp coq_None [|carrier|]
+ | Some spec ->
+ let spec = make_hyp env (ic spec) in
+ lapp coq_Some [|carrier;spec|]
+ (* Same remark on ill-typed terms ... *)
+
+let interp_div env div =
+ let carrier = Lazy.force coq_hypo in
+ match div with
+ | None -> lapp coq_None [|carrier|]
+ | Some spec ->
+ let spec = make_hyp env (ic spec) in
+ lapp coq_Some [|carrier;spec|]
+ (* Same remark on ill-typed terms ... *)
+
+let add_theory name rth eqth morphth cst_tac (pre,post) power sign div =
+ check_required_library (cdir@["Ring_base"]);
+ let env = Global.env() in
+ let sigma = Evd.empty in
+ let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in
+ let (sth,ext) = build_setoid_params r add mul opp req eqth in
+ let (pow_tac, pspec) = interp_power env power in
+ let sspec = interp_sign env sign in
+ let dspec = interp_div env div in
+ let rk = reflect_coeff morphth in
+ let params =
+ exec_tactic env 5 (zltac "ring_lemmas")
+ (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in
+ let lemma1 = constr_of params.(3) in
+ let lemma2 = constr_of params.(4) in
+
+ let lemma1 = decl_constant (string_of_id name^"_ring_lemma1") lemma1 in
+ let lemma2 = decl_constant (string_of_id name^"_ring_lemma2") lemma2 in
+ let cst_tac =
+ interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
+ let pretac =
+ match pre with
+ Some t -> Tacinterp.glob_tactic t
+ | _ -> TacId [] in
+ let posttac =
+ match post with
+ Some t -> Tacinterp.glob_tactic t
+ | _ -> TacId [] in
+ let _ =
+ Lib.add_leaf name
+ (theory_to_obj
+ { ring_carrier = r;
+ ring_req = req;
+ ring_setoid = sth;
+ ring_ext = constr_of params.(1);
+ ring_morph = constr_of params.(2);
+ ring_th = constr_of params.(0);
+ ring_cst_tac = cst_tac;
+ ring_pow_tac = pow_tac;
+ ring_lemma1 = lemma1;
+ ring_lemma2 = lemma2;
+ ring_pre_tac = pretac;
+ ring_post_tac = posttac }) in
+ ()
+
+type ring_mod =
+ Ring_kind of coeff_spec
+ | Const_tac of cst_tac_spec
+ | Pre_tac of raw_tactic_expr
+ | Post_tac of raw_tactic_expr
+ | Setoid of Topconstr.constr_expr * Topconstr.constr_expr
+ | Pow_spec of cst_tac_spec * Topconstr.constr_expr
+ (* Syntaxification tactic , correctness lemma *)
+ | Sign_spec of Topconstr.constr_expr
+ | Div_spec of Topconstr.constr_expr
+
+
+VERNAC ARGUMENT EXTEND ring_mod
+ | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational (ic eq_test)) ]
+ | [ "abstract" ] -> [ Ring_kind Abstract ]
+ | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism (ic morph)) ]
+ | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
+ | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
+ | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
+ | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
+ | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
+ | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
+ | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
+ [ Pow_spec (Closed l, pow_spec) ]
+ | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
+ [ Pow_spec (CstTac cst_tac, pow_spec) ]
+ | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
+END
+
+let set_once s r v =
+ if !r = None then r := Some v else error (s^" cannot be set twice")
+
+let process_ring_mods l =
+ let kind = ref None in
+ let set = ref None in
+ let cst_tac = ref None in
+ let pre = ref None in
+ let post = ref None in
+ let sign = ref None in
+ let power = ref None in
+ let div = ref None in
+ List.iter(function
+ Ring_kind k -> set_once "ring kind" kind k
+ | Const_tac t -> set_once "tactic recognizing constants" cst_tac t
+ | Pre_tac t -> set_once "preprocess tactic" pre t
+ | Post_tac t -> set_once "postprocess tactic" post t
+ | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext)
+ | Pow_spec(t,spec) -> set_once "power" power (t,spec)
+ | Sign_spec t -> set_once "sign" sign t
+ | Div_spec t -> set_once "div" div t) l;
+ let k = match !kind with Some k -> k | None -> Abstract in
+ (k, !set, !cst_tac, !pre, !post, !power, !sign, !div)
+
+VERNAC COMMAND EXTEND AddSetoidRing
+ | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
+ [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
+ add_theory id (ic t) set k cst (pre,post) power sign div]
+END
+
+(*****************************************************************************)
+(* The tactics consist then only in a lookup in the ring database and
+ call the appropriate ltac. *)
+
+let make_args_list rl t =
+ match rl with
+ | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2]
+ | _ -> rl
+
+let make_term_list carrier rl =
+ List.fold_right
+ (fun x l -> lapp coq_cons [|carrier;x;l|]) rl
+ (lapp coq_nil [|carrier|])
+
+let ltac_ring_structure e =
+ let req = carg e.ring_req in
+ let sth = carg e.ring_setoid in
+ let ext = carg e.ring_ext in
+ let morph = carg e.ring_morph in
+ let th = carg e.ring_th in
+ let cst_tac = Tacexp e.ring_cst_tac in
+ let pow_tac = Tacexp e.ring_pow_tac in
+ let lemma1 = carg e.ring_lemma1 in
+ let lemma2 = carg e.ring_lemma2 in
+ let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in
+ let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
+ [req;sth;ext;morph;th;cst_tac;pow_tac;
+ lemma1;lemma2;pretac;posttac]
+
+let ring_lookup (f:glob_tactic_expr) lH rl t gl =
+ let env = pf_env gl in
+ let sigma = project gl in
+ let rl = make_args_list rl t in
+ let e = find_ring_structure env sigma rl in
+ let rl = carg (make_term_list e.ring_carrier rl) in
+ let lH = carg (make_hyp_list env lH) in
+ let ring = ltac_ring_structure e in
+ ltac_apply f (ring@[lH;rl]) 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]
+END
+
+
+
+(***********************************************************************)
+
+let new_field_path =
+ make_dirpath (List.map id_of_string ["Field_tac";plugin_dir;"Coq"])
+
+let field_ltac s =
+ lazy(make_kn (MPfile new_field_path) (make_dirpath []) (mk_label s))
+
+
+let _ = add_map "field"
+ (map_with_eq
+ [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+ coq_nil, (function -1->Eval|_ -> Prot);
+ (* display_linear: evaluate polynomials and coef operations, protect
+ field operations and make recursive call on the var map *)
+ my_constant "display_linear",
+ (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot);
+ my_constant "display_pow_linear",
+ (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot);
+ (* Pphi_dev: evaluate polynomial and coef operations, protect
+ ring operations and make recursive call on the var map *)
+ pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot);
+ pol_cst "Pphi_pow",
+ (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot);
+ (* PEeval: evaluate morphism and polynomial, protect ring
+ operations and make recursive call on the var map *)
+ pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot);
+ (* FEeval: evaluate morphism, protect field
+ operations and make recursive call on the var map *)
+ my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);;
+
+let _ = add_map "field_cond"
+ (map_with_eq
+ [coq_cons,(function -1->Eval|2->Rec|_->Prot);
+ coq_nil, (function -1->Eval|_ -> Prot);
+ (* PCond: evaluate morphism and denum list, protect ring
+ operations and make recursive call on the var map *)
+ my_constant "PCond", (function -1|8|10|13->Eval|12->Rec|_->Prot)]);;
+(* (function -1|8|10->Eval|9->Rec|_->Prot)]);;*)
+
+
+let _ = Redexpr.declare_reduction "simpl_field_expr"
+ (protect_red "field")
+
+
+
+let afield_theory = my_constant "almost_field_theory"
+let field_theory = my_constant "field_theory"
+let sfield_theory = my_constant "semi_field_theory"
+let af_ar = my_constant"AF_AR"
+let f_r = my_constant"F_R"
+let sf_sr = my_constant"SF_SR"
+let dest_field env sigma th_spec =
+ let th_typ = Retyping.get_type_of env sigma th_spec in
+ match kind_of_term th_typ with
+ | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
+ when f = Lazy.force afield_theory ->
+ let rth = lapp af_ar
+ [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
+ (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
+ | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|])
+ when f = Lazy.force field_theory ->
+ let rth =
+ lapp f_r
+ [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in
+ (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth)
+ | App(f,[|r;zero;one;add;mul;div;inv;req|])
+ when f = Lazy.force sfield_theory ->
+ let rth = lapp sf_sr
+ [|r;zero;one;add;mul;div;inv;req;th_spec|] in
+ (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
+ | _ -> error "bad field structure"
+
+type field_info =
+ { field_carrier : types;
+ field_req : constr;
+ field_cst_tac : glob_tactic_expr;
+ field_pow_tac : glob_tactic_expr;
+ field_ok : constr;
+ field_simpl_eq_ok : constr;
+ field_simpl_ok : constr;
+ field_simpl_eq_in_ok : constr;
+ field_cond : constr;
+ field_pre_tac : glob_tactic_expr;
+ field_post_tac : glob_tactic_expr }
+
+let field_from_carrier = ref Cmap.empty
+let field_from_relation = ref Cmap.empty
+let field_from_name = ref Spmap.empty
+
+
+let field_for_carrier r = Cmap.find r !field_from_carrier
+let field_for_relation rel = Cmap.find rel !field_from_relation
+
+let find_field_structure env sigma l =
+ check_required_library (cdir@["Field_tac"]);
+ match l with
+ | t::cl' ->
+ let ty = Retyping.get_type_of env sigma t in
+ let check c =
+ let ty' = Retyping.get_type_of env sigma c in
+ if not (Reductionops.is_conv env sigma ty ty') then
+ errorlabstrm "field"
+ (str"arguments of field_simplify do not have all the same type")
+ in
+ List.iter check cl';
+ (try field_for_carrier ty
+ with Not_found ->
+ errorlabstrm "field"
+ (str"cannot find a declared field structure over"++
+ spc()++str"\""++pr_constr ty++str"\""))
+ | [] -> assert false
+(* let (req,_,_) = dest_rel cl in
+ (try field_for_relation req
+ with Not_found ->
+ errorlabstrm "field"
+ (str"cannot find a declared field structure for equality"++
+ spc()++str"\""++pr_constr req++str"\"")) *)
+
+let _ =
+ Summary.declare_summary "tactic-new-field-table"
+ { Summary.freeze_function =
+ (fun () -> !field_from_carrier,!field_from_relation,!field_from_name);
+ Summary.unfreeze_function =
+ (fun (ct,rt,nt) ->
+ field_from_carrier := ct; field_from_relation := rt;
+ field_from_name := nt);
+ Summary.init_function =
+ (fun () ->
+ field_from_carrier := Cmap.empty; field_from_relation := Cmap.empty;
+ field_from_name := Spmap.empty) }
+
+let add_field_entry (sp,_kn) e =
+(*
+ let _ = ty e.field_ok in
+ let _ = ty e.field_simpl_eq_ok in
+ let _ = ty e.field_simpl_ok in
+ let _ = ty e.field_cond in
+*)
+ field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier;
+ field_from_relation := Cmap.add e.field_req e !field_from_relation;
+ field_from_name := Spmap.add sp e !field_from_name
+
+let subst_th (subst,th) =
+ let c' = subst_mps subst th.field_carrier in
+ let eq' = subst_mps subst th.field_req in
+ let thm1' = subst_mps subst th.field_ok in
+ let thm2' = subst_mps subst th.field_simpl_eq_ok in
+ let thm3' = subst_mps subst th.field_simpl_ok in
+ let thm4' = subst_mps subst th.field_simpl_eq_in_ok in
+ let thm5' = subst_mps subst th.field_cond in
+ let tac'= subst_tactic subst th.field_cst_tac in
+ let pow_tac' = subst_tactic subst th.field_pow_tac in
+ let pretac'= subst_tactic subst th.field_pre_tac in
+ let posttac'= subst_tactic subst th.field_post_tac in
+ if c' == th.field_carrier &&
+ eq' == th.field_req &&
+ thm1' == th.field_ok &&
+ thm2' == th.field_simpl_eq_ok &&
+ thm3' == th.field_simpl_ok &&
+ thm4' == th.field_simpl_eq_in_ok &&
+ thm5' == th.field_cond &&
+ tac' == th.field_cst_tac &&
+ pow_tac' == th.field_pow_tac &&
+ pretac' == th.field_pre_tac &&
+ posttac' == th.field_post_tac then th
+ else
+ { field_carrier = c';
+ field_req = eq';
+ field_cst_tac = tac';
+ field_pow_tac = pow_tac';
+ field_ok = thm1';
+ field_simpl_eq_ok = thm2';
+ field_simpl_ok = thm3';
+ field_simpl_eq_in_ok = thm4';
+ field_cond = thm5';
+ field_pre_tac = pretac';
+ field_post_tac = posttac' }
+
+let (ftheory_to_obj, obj_to_ftheory) =
+ let cache_th (name,th) = add_field_entry name th in
+ declare_object
+ {(default_object "tactic-new-field-theory") with
+ open_function = (fun i o -> if i=1 then cache_th o);
+ cache_function = cache_th;
+ subst_function = subst_th;
+ classify_function = (fun x -> Substitute x) }
+
+let field_equality r inv req =
+ match kind_of_term req with
+ | App (f, [| _ |]) when eq_constr f (Lazy.force coq_eq) ->
+ mkApp((Coqlib.build_coq_eq_data()).congr,[|r;r;inv|])
+ | _ ->
+ let _setoid = setoid_of_relation (Global.env ()) r req in
+ let signature = [Some (r,req)],Some(r,req) in
+ let inv_m, inv_m_lem =
+ try Rewrite.default_morphism signature inv
+ with Not_found ->
+ error "field inverse should be declared as a morphism" in
+ inv_m_lem
+
+let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv =
+ check_required_library (cdir@["Field_tac"]);
+ let env = Global.env() in
+ let sigma = Evd.empty in
+ let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) =
+ dest_field env sigma fth in
+ let (sth,ext) = build_setoid_params r add mul opp req eqth in
+ let eqth = Some(sth,ext) in
+ let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in
+ let (pow_tac, pspec) = interp_power env power in
+ let sspec = interp_sign env sign in
+ let dspec = interp_div env odiv in
+ let inv_m = field_equality r inv req in
+ let rk = reflect_coeff morphth in
+ let params =
+ exec_tactic env 9 (field_ltac"field_lemmas")
+ (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in
+ let lemma1 = constr_of params.(3) in
+ let lemma2 = constr_of params.(4) in
+ let lemma3 = constr_of params.(5) in
+ let lemma4 = constr_of params.(6) in
+ let cond_lemma =
+ match inj with
+ | Some thm -> mkApp(constr_of params.(8),[|thm|])
+ | None -> constr_of params.(7) in
+ let lemma1 = decl_constant (string_of_id name^"_field_lemma1") lemma1 in
+ let lemma2 = decl_constant (string_of_id name^"_field_lemma2") lemma2 in
+ let lemma3 = decl_constant (string_of_id name^"_field_lemma3") lemma3 in
+ let lemma4 = decl_constant (string_of_id name^"_field_lemma4") lemma4 in
+ let cond_lemma = decl_constant (string_of_id name^"_lemma5") cond_lemma in
+ let cst_tac =
+ interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in
+ let pretac =
+ match pre with
+ Some t -> Tacinterp.glob_tactic t
+ | _ -> TacId [] in
+ let posttac =
+ match post with
+ Some t -> Tacinterp.glob_tactic t
+ | _ -> TacId [] in
+ let _ =
+ Lib.add_leaf name
+ (ftheory_to_obj
+ { field_carrier = r;
+ field_req = req;
+ field_cst_tac = cst_tac;
+ field_pow_tac = pow_tac;
+ field_ok = lemma1;
+ field_simpl_eq_ok = lemma2;
+ field_simpl_ok = lemma3;
+ field_simpl_eq_in_ok = lemma4;
+ field_cond = cond_lemma;
+ field_pre_tac = pretac;
+ field_post_tac = posttac }) in ()
+
+type field_mod =
+ Ring_mod of ring_mod
+ | Inject of Topconstr.constr_expr
+
+VERNAC ARGUMENT EXTEND field_mod
+ | [ ring_mod(m) ] -> [ Ring_mod m ]
+ | [ "completeness" constr(inj) ] -> [ Inject inj ]
+END
+
+let process_field_mods l =
+ let kind = ref None in
+ let set = ref None in
+ let cst_tac = ref None in
+ let pre = ref None in
+ let post = ref None in
+ let inj = ref None in
+ let sign = ref None in
+ let power = ref None in
+ let div = ref None in
+ List.iter(function
+ Ring_mod(Ring_kind k) -> set_once "field kind" kind k
+ | Ring_mod(Const_tac t) ->
+ set_once "tactic recognizing constants" cst_tac t
+ | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t
+ | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t
+ | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic sth,ic ext)
+ | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec)
+ | Ring_mod(Sign_spec t) -> set_once "sign" sign t
+ | Ring_mod(Div_spec t) -> set_once "div" div t
+ | Inject i -> set_once "infinite property" inj (ic i)) l;
+ let k = match !kind with Some k -> k | None -> Abstract in
+ (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div)
+
+VERNAC COMMAND EXTEND AddSetoidField
+| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] ->
+ [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
+ add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
+END
+
+
+let ltac_field_structure e =
+ let req = carg e.field_req in
+ let cst_tac = Tacexp e.field_cst_tac in
+ let pow_tac = Tacexp e.field_pow_tac in
+ let field_ok = carg e.field_ok in
+ let field_simpl_ok = carg e.field_simpl_ok in
+ let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
+ let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
+ let cond_ok = carg e.field_cond in
+ let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in
+ let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
+ [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
+ field_simpl_eq_in_ok;cond_ok;pretac;posttac]
+
+let field_lookup (f:glob_tactic_expr) lH rl t gl =
+ let env = pf_env gl in
+ let sigma = project gl in
+ let rl = make_args_list rl t in
+ let e = find_field_structure env sigma rl in
+ let rl = carg (make_term_list e.field_carrier rl) in
+ let lH = carg (make_hyp_list env lH) in
+ let field = ltac_field_structure e in
+ ltac_apply f (field@[lH;rl]) 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 ]
+END
diff --git a/plugins/setoid_ring/newring_plugin.mllib b/plugins/setoid_ring/newring_plugin.mllib
new file mode 100644
index 00000000..a98392f1
--- /dev/null
+++ b/plugins/setoid_ring/newring_plugin.mllib
@@ -0,0 +1,2 @@
+Newring
+Newring_plugin_mod
diff --git a/plugins/setoid_ring/vo.itarget b/plugins/setoid_ring/vo.itarget
new file mode 100644
index 00000000..6934375b
--- /dev/null
+++ b/plugins/setoid_ring/vo.itarget
@@ -0,0 +1,15 @@
+ArithRing.vo
+BinList.vo
+Field_tac.vo
+Field_theory.vo
+Field.vo
+InitialRing.vo
+NArithRing.vo
+RealField.vo
+Ring_base.vo
+Ring_equiv.vo
+Ring_polynom.vo
+Ring_tac.vo
+Ring_theory.vo
+Ring.vo
+ZArithRing.vo
diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml
new file mode 100644
index 00000000..4b95df19
--- /dev/null
+++ b/plugins/subtac/eterm.ml
@@ -0,0 +1,233 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+(**
+ - Get types of existentials ;
+ - Flatten dependency tree (prefix order) ;
+ - Replace existentials by De Bruijn indices in term, applied to the right arguments ;
+ - Apply term prefixed by quantification on "existentials".
+*)
+
+open Term
+open Sign
+open Names
+open Evd
+open List
+open Pp
+open Util
+open Subtac_utils
+open Proof_type
+
+let trace s =
+ if !Flags.debug then (msgnl s; msgerr s)
+ else ()
+
+let succfix (depth, fixrels) =
+ (succ depth, List.map succ fixrels)
+
+type oblinfo =
+ { ev_name: int * identifier;
+ ev_hyps: named_context;
+ ev_status: obligation_definition_status;
+ ev_chop: int option;
+ ev_loc: Util.loc;
+ ev_typ: types;
+ ev_tac: tactic option;
+ ev_deps: Intset.t }
+
+(** Substitute evar references in t using De Bruijn indices,
+ where n binders were passed through. *)
+
+let subst_evar_constr evs n idf t =
+ let seen = ref Intset.empty in
+ let transparent = ref Idset.empty in
+ let evar_info id = List.assoc id evs in
+ let rec substrec (depth, fixrels) c = match kind_of_term c with
+ | Evar (k, args) ->
+ let { ev_name = (id, idstr) ;
+ ev_hyps = hyps ; ev_chop = chop } =
+ try evar_info k
+ with Not_found ->
+ anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
+ in
+ seen := Intset.add id !seen;
+ (* Evar arguments are created in inverse order,
+ and we must not apply to defined ones (i.e. LetIn's)
+ *)
+ let args =
+ let n = match chop with None -> 0 | Some c -> c in
+ let (l, r) = list_chop n (List.rev (Array.to_list args)) in
+ List.rev r
+ in
+ let args =
+ let rec aux hyps args acc =
+ match hyps, args with
+ ((_, None, _) :: tlh), (c :: tla) ->
+ aux tlh tla ((substrec (depth, fixrels) c) :: acc)
+ | ((_, Some _, _) :: tlh), (_ :: tla) ->
+ aux tlh tla acc
+ | [], [] -> acc
+ | _, _ -> acc (*failwith "subst_evars: invalid argument"*)
+ in aux hyps args []
+ in
+ if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then
+ transparent := Idset.add idstr !transparent;
+ mkApp (idf idstr, Array.of_list args)
+ | Fix _ ->
+ map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c
+ | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c
+ in
+ let t' = substrec (0, []) t in
+ t', !seen, !transparent
+
+
+(** Substitute variable references in t using De Bruijn indices,
+ where n binders were passed through. *)
+let subst_vars acc n t =
+ let var_index id = Util.list_index id acc in
+ let rec substrec depth c = match kind_of_term c with
+ | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c)
+ | _ -> map_constr_with_binders succ substrec depth c
+ in
+ substrec 0 t
+
+(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ])
+ to a product : forall H1 : t1, ..., forall Hn : tn, concl.
+ Changes evars and hypothesis references to variable references.
+*)
+let etype_of_evar evs hyps concl =
+ let rec aux acc n = function
+ (id, copt, t) :: tl ->
+ let t', s, trans = subst_evar_constr evs n mkVar t in
+ let t'' = subst_vars acc 0 t' in
+ let rest, s', trans' = aux (id :: acc) (succ n) tl in
+ let s' = Intset.union s s' in
+ let trans' = Idset.union trans trans' in
+ (match copt with
+ Some c ->
+ let c', s'', trans'' = subst_evar_constr evs n mkVar c in
+ let c' = subst_vars acc 0 c' in
+ mkNamedProd_or_LetIn (id, Some c', t'') rest,
+ Intset.union s'' s',
+ Idset.union trans'' trans'
+ | None ->
+ mkNamedProd_or_LetIn (id, None, t'') rest, s', trans')
+ | [] ->
+ let t', s, trans = subst_evar_constr evs n mkVar concl in
+ subst_vars acc 0 t', s, trans
+ in aux [] 0 (rev hyps)
+
+
+open Tacticals
+
+let trunc_named_context n ctx =
+ let len = List.length ctx in
+ list_firstn (len - n) ctx
+
+let rec chop_product n t =
+ if n = 0 then Some t
+ else
+ match kind_of_term t with
+ | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
+ | _ -> None
+
+let evar_dependencies evm ev =
+ let one_step deps =
+ Intset.fold (fun ev s ->
+ let evi = Evd.find evm ev in
+ Intset.union (Evarutil.evars_of_evar_info evi) s)
+ deps deps
+ in
+ let rec aux deps =
+ let deps' = one_step deps in
+ if Intset.equal deps deps' then deps
+ else aux deps'
+ in aux (Intset.singleton ev)
+
+let sort_dependencies evl =
+ List.stable_sort
+ (fun (id, ev, deps) (id', ev', deps') ->
+ if id = id' then 0
+ else if Intset.mem id deps' then -1
+ else if Intset.mem id' deps then 1
+ else Pervasives.compare id id')
+ evl
+
+let map_evar_body f = function
+ | Evar_empty -> Evar_empty
+ | Evar_defined c -> Evar_defined (f c)
+
+open Environ
+
+let map_evar_info f evi =
+ { evi with evar_hyps = val_of_named_context (map_named_context f (named_context_of_val evi.evar_hyps));
+ evar_concl = f evi.evar_concl;
+ evar_body = map_evar_body f evi.evar_body }
+
+let eterm_obligations env name isevars evm fs ?status t ty =
+ (* 'Serialize' the evars *)
+ let nc = Environ.named_context env in
+ let nc_len = Sign.named_context_length nc in
+ let evl = List.rev (to_list evm) in
+ let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in
+ let sevl = sort_dependencies evl in
+ let evl = List.map (fun (id, ev, _) -> id, ev) sevl in
+ let evn =
+ let i = ref (-1) in
+ List.rev_map (fun (id, ev) -> incr i;
+ (id, (!i, id_of_string
+ (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))),
+ ev)) evl
+ in
+ let evts =
+ (* Remove existential variables in types and build the corresponding products *)
+ fold_right
+ (fun (id, (n, nstr), ev) l ->
+ let hyps = Evd.evar_filtered_context ev in
+ let hyps = trunc_named_context nc_len hyps in
+ let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in
+ let evtyp, hyps, chop =
+ match chop_product fs evtyp with
+ | Some t -> t, trunc_named_context fs hyps, fs
+ | None -> evtyp, hyps, 0
+ in
+ let loc, k = evar_source id isevars in
+ let status = match k with QuestionMark o -> Some o | _ -> status in
+ let status, chop = match status with
+ | Some (Define true as stat) ->
+ if chop <> fs then Define false, None
+ else stat, Some chop
+ | Some s -> s, None
+ | None -> Define true, None
+ in
+ let tac = match ev.evar_extra with
+ | Some t ->
+ if Dyn.tag t = "tactic" then
+ Some (Tacinterp.interp
+ (Tacinterp.globTacticIn (Tacinterp.tactic_out t)))
+ else None
+ | None -> None
+ in
+ let info = { ev_name = (n, nstr);
+ ev_hyps = hyps; ev_status = status; ev_chop = chop;
+ ev_loc = loc; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac }
+ in (id, info) :: l)
+ evn []
+ in
+ let t', _, transparent = (* Substitute evar refs in the term by variables *)
+ subst_evar_constr evts 0 mkVar t
+ in
+ let ty, _, _ = subst_evar_constr evts 0 mkVar ty in
+ let evars =
+ List.map (fun (ev, info) ->
+ let { ev_name = (_, name); ev_status = status;
+ ev_loc = loc; 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, loc, 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
+ Array.of_list (List.rev evars), (evnames, evmap), t', ty
+
+let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n
diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli
new file mode 100644
index 00000000..406f9433
--- /dev/null
+++ b/plugins/subtac/eterm.mli
@@ -0,0 +1,34 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+open Environ
+open Tacmach
+open Term
+open Evd
+open Names
+open Util
+open Tacinterp
+
+val mkMetas : int -> constr list
+
+val evar_dependencies : evar_map -> int -> Intset.t
+val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list
+
+(* env, id, evars, number of function prototypes to try to clear from
+ evars contexts, object and type *)
+val eterm_obligations : env -> identifier -> evar_map -> evar_map -> int ->
+ ?status:obligation_definition_status -> constr -> types ->
+ (identifier * types * loc * obligation_definition_status * Intset.t *
+ tactic option) array
+ (* Existential key, obl. name, type as product, location of the original evar, associated tactic,
+ status and dependencies as indexes into the array *)
+ * ((existential_key * identifier) list * ((identifier -> constr) -> constr -> constr)) * constr * types
+ (* Translations from existential identifiers to obligation identifiers
+ and for terms with existentials to closed terms, given a
+ translation from obligation identifiers to constrs, new term, new type *)
diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4
new file mode 100644
index 00000000..113b1680
--- /dev/null
+++ b/plugins/subtac/g_subtac.ml4
@@ -0,0 +1,177 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4use: "pa_extend.cmo" i*)
+
+
+(*
+ Syntax for the subtac terms and types.
+ Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
+
+(* $Id$ *)
+
+
+open Flags
+open Util
+open Names
+open Nameops
+open Vernacentries
+open Reduction
+open Term
+open Libnames
+open Topconstr
+
+(* We define new entries for programs, with the use of this module
+ * Subtac. These entries are named Subtac.<foo>
+ *)
+
+module Gram = Pcoq.Gram
+module Vernac = Pcoq.Vernac_
+module Tactic = Pcoq.Tactic
+
+module SubtacGram =
+struct
+ 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_withtac : Tacexpr.raw_tactic_expr option Gram.Entry.e = gec "subtac_withtac"
+end
+
+open Rawterm
+open SubtacGram
+open Util
+open Pcoq
+open Prim
+open Constr
+let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Specif.sig"))
+
+GEXTEND Gram
+ GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_withtac;
+
+ subtac_gallina_loc:
+ [ [ g = Vernac.gallina -> loc, g
+ | g = Vernac.gallina_ext -> loc, g ] ]
+ ;
+
+ subtac_withtac:
+ [ [ "with"; t = Tactic.tactic -> Some t
+ | -> None ] ]
+ ;
+
+ Constr.binder_let:
+ [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
+ let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in
+ [LocalRawAssum ([id], default_binder_kind, typ)]
+ ] ];
+
+ Constr.binder:
+ [ [ "("; id=Prim.name; ":"; c=Constr.lconstr; "|"; p=Constr.lconstr; ")" ->
+ ([id],default_binder_kind, mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, c, p)]))
+ | "("; id=Prim.name; ":"; c=Constr.lconstr; ")" ->
+ ([id],default_binder_kind, c)
+ | "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" ->
+ (id::lid,default_binder_kind, c)
+ ] ];
+
+ END
+
+
+type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstract_argument_type
+
+let (wit_subtac_gallina_loc : Genarg.tlevel gallina_loc_argtype),
+ (globwit_subtac_gallina_loc : Genarg.glevel gallina_loc_argtype),
+ (rawwit_subtac_gallina_loc : Genarg.rlevel gallina_loc_argtype) =
+ Genarg.create_arg "subtac_gallina_loc"
+
+type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type
+
+let (wit_subtac_withtac : Genarg.tlevel withtac_argtype),
+ (globwit_subtac_withtac : Genarg.glevel withtac_argtype),
+ (rawwit_subtac_withtac : Genarg.rlevel withtac_argtype) =
+ Genarg.create_arg "subtac_withtac"
+
+VERNAC COMMAND EXTEND Subtac
+[ "Program" subtac_gallina_loc(g) ] -> [ Subtac.subtac g ]
+ END
+
+let try_catch_exn f e =
+ try f e
+ with exn -> errorlabstrm "Program" (Cerrors.explain_exn 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
+let try_solve_obligation e = try_catch_exn Subtac_obligations.try_solve_obligation e
+let try_solve_obligations e = try_catch_exn Subtac_obligations.try_solve_obligations e
+let solve_all_obligations e = try_catch_exn Subtac_obligations.solve_all_obligations e
+let admit_obligations e = try_catch_exn Subtac_obligations.admit_obligations e
+
+VERNAC COMMAND EXTEND Subtac_Obligations
+| [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) subtac_withtac(tac) ] ->
+ [ subtac_obligation (num, Some name, Some t) tac ]
+| [ "Obligation" integer(num) "of" ident(name) subtac_withtac(tac) ] ->
+ [ subtac_obligation (num, Some name, None) tac ]
+| [ "Obligation" integer(num) ":" lconstr(t) subtac_withtac(tac) ] ->
+ [ subtac_obligation (num, None, Some t) tac ]
+| [ "Obligation" integer(num) subtac_withtac(tac) ] ->
+ [ subtac_obligation (num, None, None) tac ]
+| [ "Next" "Obligation" "of" ident(name) subtac_withtac(tac) ] ->
+ [ next_obligation (Some name) tac ]
+| [ "Next" "Obligation" subtac_withtac(tac) ] -> [ next_obligation None tac ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Solve_Obligation
+| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] ->
+ [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] ->
+ [ try_solve_obligation num None (Some (Tacinterp.interp t)) ]
+ END
+
+VERNAC COMMAND EXTEND Subtac_Solve_Obligations
+| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] ->
+ [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" "using" tactic(t) ] ->
+ [ try_solve_obligations None (Some (Tacinterp.interp t)) ]
+| [ "Solve" "Obligations" ] ->
+ [ try_solve_obligations None None ]
+ END
+
+VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations
+| [ "Solve" "All" "Obligations" "using" tactic(t) ] ->
+ [ solve_all_obligations (Some (Tacinterp.interp t)) ]
+| [ "Solve" "All" "Obligations" ] ->
+ [ solve_all_obligations None ]
+ END
+
+VERNAC COMMAND EXTEND Subtac_Admit_Obligations
+| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ]
+| [ "Admit" "Obligations" ] -> [ admit_obligations None ]
+ END
+
+VERNAC COMMAND EXTEND Subtac_Set_Solver
+| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [
+ Subtac_obligations.set_default_tactic
+ (Vernacexpr.use_section_locality ())
+ (Tacinterp.glob_tactic t) ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Show_Solver
+| [ "Show" "Obligation" "Tactic" ] -> [
+ Pp.msgnl (Pptactic.pr_glob_tactic (Global.env ()) (Subtac_obligations.default_tactic_expr ())) ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Show_Obligations
+| [ "Obligations" "of" ident(name) ] -> [ Subtac_obligations.show_obligations (Some name) ]
+| [ "Obligations" ] -> [ Subtac_obligations.show_obligations None ]
+END
+
+VERNAC COMMAND EXTEND Subtac_Show_Preterm
+| [ "Preterm" "of" ident(name) ] -> [ Subtac_obligations.show_term (Some name) ]
+| [ "Preterm" ] -> [ Subtac_obligations.show_term None ]
+END
diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml
new file mode 100644
index 00000000..0eba0f63
--- /dev/null
+++ b/plugins/subtac/subtac.ml
@@ -0,0 +1,250 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Global
+open Pp
+open Util
+open Names
+open Sign
+open Evd
+open Term
+open Termops
+open Namegen
+open Reductionops
+open Environ
+open Type_errors
+open Typeops
+open Libnames
+open Classops
+open List
+open Recordops
+open Evarutil
+open Pretype_errors
+open Rawterm
+open Evarconv
+open Pattern
+open Vernacexpr
+
+open Subtac_coercion
+open Subtac_utils
+open Coqlib
+open Printer
+open Subtac_errors
+open Eterm
+
+let require_library dirpath =
+ let qualid = (dummy_loc, qualid_of_dirpath (dirpath_of_string dirpath)) in
+ Library.require_library [qualid] None
+
+open Pp
+open Ppconstr
+open Decl_kinds
+open Tacinterp
+open Tacexpr
+
+let solve_tccs_in_type env id isevars evm c typ =
+ if not (evm = Evd.empty) 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
+ | Subtac_obligations.Defined cst -> constant_value (Global.env())
+ (match cst with ConstRef kn -> kn | _ -> assert false)
+ | _ ->
+ errorlabstrm "start_proof"
+ (str "The statement obligations could not be resolved automatically, " ++ spc () ++
+ str "write a statement definition first.")
+ else
+ let _ = Typeops.infer_type env c in c
+
+
+let start_proof_com env isevars sopt kind (bl,t) hook =
+ let id = match sopt with
+ | Some (loc,id) ->
+ (* We check existence here: it's a bit late at Qed time *)
+ if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
+ user_err_loc (loc,"start_proof",pr_id id ++ str " already exists");
+ id
+ | None ->
+ next_global_ident_away (id_of_string "Unnamed_thm")
+ (Pfedit.get_all_proof_names ())
+ in
+ let evm, c, typ, imps =
+ Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr t bl) None
+ in
+ let c = solve_tccs_in_type env id isevars evm c typ in
+ Lemmas.start_proof id kind c (fun loc gr ->
+ Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true imps;
+ hook loc gr)
+
+let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
+
+let start_proof_and_print env isevars idopt k t hook =
+ start_proof_com env isevars idopt k t hook;
+ print_subgoals ()
+
+let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
+
+let assumption_message id =
+ Flags.if_verbose message ((string_of_id id) ^ " is assumed")
+
+let declare_assumptions env isevars idl is_coe k bl c nl =
+ if not (Pfedit.refining ()) then
+ let id = snd (List.hd idl) in
+ let evm, c, typ, imps =
+ Subtac_pretyping.subtac_process env isevars id [] (Topconstr.prod_constr_expr c bl) None
+ in
+ let c = solve_tccs_in_type env id isevars evm c typ in
+ List.iter (Command.declare_assumption is_coe k c imps false nl) idl
+ else
+ errorlabstrm "Command.Assumption"
+ (str "Cannot declare an assumption while in proof editing mode.")
+
+let dump_constraint ty ((loc, n), _, _) =
+ match n with
+ | Name id -> Dumpglob.dump_definition (loc, id) false ty
+ | Anonymous -> ()
+
+let dump_variable lid = ()
+
+let vernac_assumption env isevars kind l nl =
+ let global = fst kind = Global in
+ List.iter (fun (is_coe,(idl,c)) ->
+ if Dumpglob.dump () then
+ List.iter (fun lid ->
+ if global then Dumpglob.dump_definition lid (not global) "ax"
+ else dump_variable lid) idl;
+ declare_assumptions env isevars idl is_coe kind [] c nl) l
+
+let check_fresh (loc,id) =
+ if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then
+ user_err_loc (loc,"",pr_id id ++ str " already exists")
+
+let subtac (loc, command) =
+ check_required_library ["Coq";"Init";"Datatypes"];
+ check_required_library ["Coq";"Init";"Specif"];
+ let env = Global.env () in
+ let isevars = ref (create_evar_defs Evd.empty) in
+ try
+ match command with
+ | VernacDefinition (defkind, (_, id as lid), expr, hook) ->
+ check_fresh lid;
+ Dumpglob.dump_definition lid false "def";
+ (match expr with
+ | ProveBody (bl, t) ->
+ if Lib.is_modtype () then
+ errorlabstrm "Subtac_command.StartProof"
+ (str "Proof editing mode not supported in module types");
+ start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t)
+ (fun _ _ -> ())
+ | DefineBody (bl, _, c, tycon) ->
+ ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon))
+ | VernacFixpoint (l, b) ->
+ 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)
+
+ | VernacStartTheoremProof (thkind, [Some id, (bl,t,guard)], lettop, hook) ->
+ if guard <> None then
+ error "Do not support building theorems as a fixpoint.";
+ Dumpglob.dump_definition id false "prf";
+ if not(Pfedit.refining ()) then
+ if lettop then
+ errorlabstrm "Subtac_command.StartProof"
+ (str "Let declarations can only be used in proof editing mode");
+ if Lib.is_modtype () then
+ errorlabstrm "Subtac_command.StartProof"
+ (str "Proof editing mode not supported in module types");
+ check_fresh id;
+ start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook
+
+ | VernacAssumption (stre,nl,l) ->
+ vernac_assumption env isevars stre l nl
+
+ | VernacInstance (abst, glob, sup, is, props, pri) ->
+ dump_constraint "inst" is;
+ if abst then
+ error "Declare Instance not supported here.";
+ ignore(Subtac_classes.new_instance ~global:glob sup is props pri)
+
+ | VernacCoFixpoint (l, b) ->
+ if Dumpglob.dump () then
+ List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l;
+ ignore(Subtac_command.build_corecursive l b)
+
+ (*| VernacEndProof e ->
+ subtac_end_proof e*)
+
+ | _ -> user_err_loc (loc,"", str ("Invalid Program command"))
+ with
+ | Typing_error e ->
+ msg_warning (str "Type error in Program tactic:");
+ let cmds =
+ (match e with
+ | NonFunctionalApp (loc, x, mux, e) ->
+ str "non functional application of term " ++
+ e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux
+ | NonSigma (loc, t) ->
+ str "Term is not of Sigma type: " ++ t
+ | NonConvertible (loc, x, y) ->
+ str "Unconvertible terms:" ++ spc () ++
+ x ++ spc () ++ str "and" ++ spc () ++ y
+ | IllSorted (loc, t) ->
+ str "Term is ill-sorted:" ++ spc () ++ t
+ )
+ in msg_warning cmds
+
+ | Subtyping_error e ->
+ msg_warning (str "(Program tactic) Subtyping error:");
+ let cmds =
+ match e with
+ | UncoercibleInferType (loc, x, y) ->
+ str "Uncoercible terms:" ++ spc ()
+ ++ x ++ spc () ++ str "and" ++ spc () ++ y
+ | UncoercibleInferTerm (loc, x, y, tx, ty) ->
+ str "Uncoercible terms:" ++ spc ()
+ ++ tx ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ x
+ ++ str "and" ++ spc() ++ ty ++ spc () ++ str "of" ++ spc () ++ str "type" ++ spc () ++ y
+ | UncoercibleRewrite (x, y) ->
+ str "Uncoercible terms:" ++ spc ()
+ ++ x ++ spc () ++ str "and" ++ spc () ++ y
+ in msg_warning cmds
+
+ | Cases.PatternMatchingError (env, exn) as e ->
+ debug 2 (Himsg.explain_pattern_matching_error env exn);
+ raise e
+
+ | Type_errors.TypeError (env, exn) as e ->
+ debug 2 (Himsg.explain_type_error env exn);
+ raise e
+
+ | Pretype_errors.PretypeError (env, exn) as e ->
+ debug 2 (Himsg.explain_pretype_error env exn);
+ raise e
+
+ | (Stdpp.Exc_located (loc, Proof_type.LtacLocated (_,e')) |
+ Stdpp.Exc_located (loc, e') as e) ->
+ debug 2 (str "Parsing exception: ");
+ (match e' with
+ | Type_errors.TypeError (env, exn) ->
+ debug 2 (Himsg.explain_type_error env exn);
+ raise e
+
+ | Pretype_errors.PretypeError (env, exn) ->
+ debug 2 (Himsg.explain_pretype_error env exn);
+ raise e
+
+ | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e'');
+ raise e)
+
+ | e ->
+ msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e);
+ raise e
diff --git a/plugins/subtac/subtac.mli b/plugins/subtac/subtac.mli
new file mode 100644
index 00000000..b51150aa
--- /dev/null
+++ b/plugins/subtac/subtac.mli
@@ -0,0 +1,2 @@
+val require_library : string -> unit
+val subtac : Util.loc * Vernacexpr.vernac_expr -> unit
diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml
new file mode 100644
index 00000000..e8f4f05f
--- /dev/null
+++ b/plugins/subtac/subtac_cases.ml
@@ -0,0 +1,2027 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Cases
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Namegen
+open Declarations
+open Inductiveops
+open Environ
+open Sign
+open Reductionops
+open Typeops
+open Type_errors
+
+open Rawterm
+open Retyping
+open Pretype_errors
+open Evarutil
+open Evarconv
+
+open Subtac_utils
+
+(************************************************************************)
+(* Pattern-matching compilation (Cases) *)
+(************************************************************************)
+
+(************************************************************************)
+(* Configuration, errors and warnings *)
+
+open Pp
+
+let mssg_may_need_inversion () =
+ str "Found a matching with no clauses on a term unknown to have an empty inductive type"
+
+(* Utils *)
+let make_anonymous_patvars =
+ list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous))
+
+(* Environment management *)
+let push_rels vars env = List.fold_right push_rel vars env
+
+(* We have x1:t1...xn:tn,xi':ti,y1..yk |- c and re-generalize
+ over xi:ti to get x1:t1...xn:tn,xi':ti,y1..yk |- c[xi:=xi'] *)
+
+let regeneralize_rel i k j = if j = i+k then k else if j < i+k then j else j
+
+let rec regeneralize_index i k t = match kind_of_term t with
+ | Rel j when j = i+k -> mkRel (k+1)
+ | Rel j when j < i+k -> t
+ | Rel j when j > i+k -> t
+ | _ -> map_constr_with_binders succ (regeneralize_index i) k t
+
+type alias_constr =
+ | DepAlias
+ | NonDepAlias
+
+let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) =
+ { uj_val =
+ (match d with
+ | DepAlias -> mkLetIn (na,deppat,t,j.uj_val)
+ | NonDepAlias ->
+ if (not (dependent (mkRel 1) j.uj_type))
+ or (* A leaf: *) isRel deppat
+ then
+ (* The body of pat is not needed to type j - see *)
+ (* insert_aliases - and both deppat and nondeppat have the *)
+ (* same type, then one can freely substitute one by the other *)
+ subst1 nondeppat j.uj_val
+ else
+ (* The body of pat is not needed to type j but its value *)
+ (* is dependent in the type of j; our choice is to *)
+ (* enforce this dependency *)
+ mkLetIn (na,deppat,t,j.uj_val));
+ uj_type = subst1 deppat j.uj_type }
+
+(**********************************************************************)
+(* Structures used in compiling pattern-matching *)
+
+type rhs =
+ { rhs_env : env;
+ avoid_ids : identifier list;
+ it : rawconstr;
+ }
+
+type equation =
+ { patterns : cases_pattern list;
+ rhs : rhs;
+ alias_stack : name list;
+ eqn_loc : loc;
+ used : bool ref }
+
+type matrix = equation list
+
+(* 1st argument of IsInd is the original ind before extracting the summary *)
+type tomatch_type =
+ | IsInd of types * inductive_type
+ | NotInd of constr option * types
+
+type tomatch_status =
+ | Pushed of ((constr * tomatch_type) * int list)
+ | Alias of (constr * constr * alias_constr * constr)
+ | Abstract of rel_declaration
+
+type tomatch_stack = tomatch_status list
+
+(* The type [predicate_signature] types the terms to match and the rhs:
+
+ - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
+ if dep<>Anonymous, the term is dependent, let n=|names|, if
+ n<>0 then the type of the pushed term is necessarily an
+ inductive with n real arguments. Otherwise, it may be
+ non inductive, or inductive without real arguments, or inductive
+ originating from a subterm in which case real args are not dependent;
+ it accounts for n+1 binders if dep or n binders if not dep
+ - [PrProd] types abstracted term ([Abstract]); it accounts for one binder
+ - [PrCcl] types the right-hand-side
+ - Aliases [Alias] have no trace in [predicate_signature]
+*)
+
+type predicate_signature =
+ | PrLetIn of (name list * name) * predicate_signature
+ | PrProd of predicate_signature
+ | PrCcl of constr
+
+(* We keep a constr for aliases and a cases_pattern for error message *)
+
+type alias_builder =
+ | AliasLeaf
+ | AliasConstructor of constructor
+
+type pattern_history =
+ | Top
+ | MakeAlias of alias_builder * pattern_continuation
+
+and pattern_continuation =
+ | Continuation of int * cases_pattern list * pattern_history
+ | Result of cases_pattern list
+
+let start_history n = Continuation (n, [], Top)
+
+let feed_history arg = function
+ | Continuation (n, l, h) when n>=1 ->
+ Continuation (n-1, arg :: l, h)
+ | Continuation (n, _, _) ->
+ anomaly ("Bad number of expected remaining patterns: "^(string_of_int n))
+ | Result _ ->
+ anomaly "Exhausted pattern history"
+
+(* This is for non exhaustive error message *)
+
+let rec rawpattern_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
+ | Result pl -> pl
+
+and build_rawpattern args = function
+ | Top -> args
+ | MakeAlias (AliasLeaf, rh) ->
+ assert (args = []);
+ rawpattern_of_partial_history [PatVar (dummy_loc, Anonymous)] rh
+ | MakeAlias (AliasConstructor pci, rh) ->
+ rawpattern_of_partial_history
+ [PatCstr (dummy_loc, pci, args, Anonymous)] rh
+
+let complete_history = rawpattern_of_partial_history []
+
+(* This is to build glued pattern-matching history and alias bodies *)
+
+let rec simplify_history = function
+ | Continuation (0, l, Top) -> Result (List.rev l)
+ | Continuation (0, l, MakeAlias (f, rh)) ->
+ let pargs = List.rev l in
+ let pat = match f with
+ | AliasConstructor pci ->
+ PatCstr (dummy_loc,pci,pargs,Anonymous)
+ | AliasLeaf ->
+ assert (l = []);
+ PatVar (dummy_loc, Anonymous) in
+ feed_history pat rh
+ | h -> h
+
+(* Builds a continuation expecting [n] arguments and building [ci] applied
+ to this [n] arguments *)
+
+let push_history_pattern n current cont =
+ Continuation (n, [], MakeAlias (current, cont))
+
+(* A pattern-matching problem has the following form:
+
+ env, isevars |- <pred> Cases tomatch of mat end
+
+ where tomatch is some sequence of "instructions" (t1 ... tn)
+
+ and mat is some matrix
+ (p11 ... p1n -> rhs1)
+ ( ... )
+ (pm1 ... pmn -> rhsm)
+
+ Terms to match: there are 3 kinds of instructions
+
+ - "Pushed" terms to match are typed in [env]; these are usually just
+ Rel(n) except for the initial terms given by user and typed in [env]
+ - "Abstract" instructions means an abstraction has to be inserted in the
+ current branch to build (this means a pattern has been detected dependent
+ in another one and generalisation is necessary to ensure well-typing)
+ - "Alias" instructions means an alias has to be inserted (this alias
+ is usually removed at the end, except when its type is not the
+ same as the type of the matched term from which it comes -
+ typically because the inductive types are "real" parameters)
+
+ Right-hand-sides:
+
+ They consist of a raw term to type in an environment specific to the
+ clause they belong to: the names of declarations are those of the
+ variables present in the patterns. Therefore, they come with their
+ own [rhs_env] (actually it is the same as [env] except for the names
+ of variables).
+
+*)
+type pattern_matching_problem =
+ { env : env;
+ isevars : Evd.evar_map ref;
+ pred : predicate_signature option;
+ tomatch : tomatch_stack;
+ history : pattern_continuation;
+ mat : matrix;
+ caseloc : loc;
+ casestyle: case_style;
+ typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
+
+(*--------------------------------------------------------------------------*
+ * A few functions to infer the inductive type from the patterns instead of *
+ * checking that the patterns correspond to the ind. type of the *
+ * destructurated object. Allows type inference of examples like *
+ * match n with O => true | _ => false end *
+ * match x in I with C => true | _ => false end *
+ *--------------------------------------------------------------------------*)
+
+(* Computing the inductive type from the matrix of patterns *)
+
+(* We use the "in I" clause to coerce the terms to match and otherwise
+ use the constructor to know in which type is the matching problem
+
+ Note that insertion of coercions inside nested patterns is done
+ each time the matrix is expanded *)
+
+let rec find_row_ind = function
+ [] -> None
+ | PatVar _ :: l -> find_row_ind l
+ | PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
+
+let inductive_template isevars env tmloc ind =
+ let arsign = get_full_arity_sign env ind in
+ let hole_source = match tmloc with
+ | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
+ | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
+ let (_,evarl,_) =
+ List.fold_right
+ (fun (na,b,ty) (subst,evarl,n) ->
+ match b with
+ | None ->
+ let ty' = substl subst ty in
+ let e = e_new_evar isevars env ~src:(hole_source n) ty' in
+ (e::subst,e::evarl,n+1)
+ | Some b ->
+ (b::subst,evarl,n+1))
+ arsign ([],[],1) in
+ applist (mkInd ind,List.rev evarl)
+
+
+(************************************************************************)
+(* Utils *)
+
+let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars =
+ e_new_evar isevars env ~src:src (new_Type ())
+
+let evd_comb2 f isevars x y =
+ let (evd',y) = f !isevars x y in
+ isevars := evd';
+ y
+
+let context_of_arsign l =
+ let (x, _) = List.fold_right
+ (fun c (x, n) ->
+ (lift_rel_context n c @ x, List.length c + n))
+ l ([], 0)
+ in x
+
+(* We put the tycon inside the arity signature, possibly discovering dependencies. *)
+
+let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c =
+ let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in
+ let subst, len =
+ List.fold_left2 (fun (subst, len) (tm, tmtype) sign ->
+ let signlen = List.length sign in
+ match kind_of_term tm with
+ | Rel n when dependent tm c
+ && signlen = 1 (* The term to match is not of a dependent type itself *) ->
+ ((n, len) :: subst, len - signlen)
+ | Rel n when signlen > 1 (* The term is of a dependent type,
+ maybe some variable in its type appears in the tycon. *) ->
+ (match tmtype with
+ | NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
+ | IsInd (_, IndType(indf,realargs)) ->
+ let subst =
+ if dependent tm c && List.for_all isRel realargs
+ then (n, 1) :: subst else subst
+ in
+ List.fold_left
+ (fun (subst, len) arg ->
+ match kind_of_term arg with
+ | Rel n when dependent arg c ->
+ ((n, len) :: subst, pred len)
+ | _ -> (subst, pred len))
+ (subst, len) realargs)
+ | _ -> (subst, len - signlen))
+ ([], nar) tomatchs arsign
+ in
+ let rec predicate lift c =
+ match kind_of_term c with
+ | Rel n when n > lift ->
+ (try
+ (* Make the predicate dependent on the matched variable *)
+ let idx = List.assoc (n - lift) subst in
+ mkRel (idx + lift)
+ with Not_found ->
+ (* A variable that is not matched, lift over the arsign. *)
+ mkRel (n + nar))
+ | _ ->
+ map_constr_with_binders succ predicate lift c
+ in
+ try
+ (* The tycon may be ill-typed after abstraction. *)
+ let pred = predicate 0 c in
+ let env' = push_rel_context (context_of_arsign arsign) env in
+ ignore(Typing.sort_of env' evm pred); pred
+ with _ -> lift nar c
+
+module Cases_F(Coercion : Coercion.S) : S = struct
+
+let inh_coerce_to_ind isevars env ty tyi =
+ let expected_typ = inductive_template isevars env None tyi in
+ (* devrait être indifférent d'exiger leq ou pas puisque pour
+ un inductif cela doit être égal *)
+ let _ = e_cumul env isevars expected_typ ty in ()
+
+let unify_tomatch_with_patterns isevars env loc typ pats =
+ match find_row_ind pats with
+ | None -> NotInd (None,typ)
+ | Some (_,(ind,_)) ->
+ inh_coerce_to_ind isevars env typ ind;
+ try IsInd (typ,find_rectype env ( !isevars) typ)
+ with Not_found -> NotInd (None,typ)
+
+let find_tomatch_tycon isevars env loc = function
+ (* Try if some 'in I ...' is present and can be used as a constraint *)
+ | Some (_,ind,_,_) -> mk_tycon (inductive_template isevars env loc ind)
+ | None -> empty_tycon
+
+let coerce_row typing_fun isevars env pats (tomatch,(_,indopt)) =
+ let loc = Some (loc_of_rawconstr 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
+ isevars := evd;
+ let typ = nf_evar ( !isevars) j.uj_type in
+ let t =
+ try IsInd (typ,find_rectype env ( !isevars) typ)
+ with Not_found ->
+ unify_tomatch_with_patterns isevars env loc typ pats in
+ (j.uj_val,t)
+
+let coerce_to_indtype typing_fun isevars env matx tomatchl =
+ let pats = List.map (fun r -> r.patterns) matx in
+ let matx' = match matrix_transpose pats with
+ | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *)
+ | m -> m in
+ List.map2 (coerce_row typing_fun isevars env) matx' tomatchl
+
+
+
+let adjust_tomatch_to_pattern pb ((current,typ),deps) =
+ (* Ideally, we could find a common inductive type to which both the
+ term to match and the patterns coerce *)
+ (* In practice, we coerce the term to match if it is not already an
+ inductive type and it is not dependent; moreover, we use only
+ the first pattern type and forget about the others *)
+ let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
+ let typ =
+ try IsInd (typ,find_rectype pb.env ( !(pb.isevars)) typ)
+ with Not_found -> NotInd (None,typ) in
+ let tomatch = ((current,typ),deps) in
+ match typ with
+ | NotInd (None,typ) ->
+ let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
+ (match find_row_ind tm1 with
+ | None -> tomatch
+ | Some (_,(ind,_)) ->
+ let indt = inductive_template pb.isevars pb.env None ind in
+ let current =
+ if deps = [] & isEvar typ then
+ (* Don't insert coercions if dependent; only solve evars *)
+ let _ = e_cumul pb.env pb.isevars indt typ in
+ current
+ else
+ (evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env)
+ pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
+ let sigma = !(pb.isevars) in
+ let typ = IsInd (indt,find_rectype pb.env sigma indt) in
+ ((current,typ),deps))
+ | _ -> tomatch
+
+ (* extract some ind from [t], possibly coercing from constructors in [tm] *)
+let to_mutind env isevars tm c t =
+(* match c with
+ | Some body -> *) NotInd (c,t)
+(* | None -> unify_tomatch_with_patterns isevars env t tm*)
+
+let type_of_tomatch = function
+ | IsInd (t,_) -> t
+ | NotInd (_,t) -> t
+
+let mkDeclTomatch na = function
+ | IsInd (t,_) -> (na,None,t)
+ | NotInd (c,t) -> (na,c,t)
+
+let map_tomatch_type f = function
+ | IsInd (t,ind) -> IsInd (f t,map_inductive_type f ind)
+ | NotInd (c,t) -> NotInd (Option.map f c, f t)
+
+let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth)
+let lift_tomatch_type n = liftn_tomatch_type n 1
+
+(**********************************************************************)
+(* Utilities on patterns *)
+
+let current_pattern eqn =
+ match eqn.patterns with
+ | pat::_ -> pat
+ | [] -> anomaly "Empty list of patterns"
+
+let alias_of_pat = function
+ | PatVar (_,name) -> name
+ | PatCstr(_,_,_,name) -> name
+
+let remove_current_pattern eqn =
+ match eqn.patterns with
+ | pat::pats ->
+ { eqn with
+ patterns = pats;
+ alias_stack = alias_of_pat pat :: eqn.alias_stack }
+ | [] -> anomaly "Empty list of patterns"
+
+let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
+
+(**********************************************************************)
+(* Well-formedness tests *)
+(* Partial check on patterns *)
+
+exception NotAdjustable
+
+let rec adjust_local_defs loc = function
+ | (pat :: pats, (_,None,_) :: decls) ->
+ pat :: adjust_local_defs loc (pats,decls)
+ | (pats, (_,Some _,_) :: decls) ->
+ PatVar (loc, Anonymous) :: adjust_local_defs loc (pats,decls)
+ | [], [] -> []
+ | _ -> raise NotAdjustable
+
+let check_and_adjust_constructor env ind cstrs = function
+ | PatVar _ as pat -> pat
+ | PatCstr (loc,((_,i) as cstr),args,alias) as pat ->
+ (* Check it is constructor of the right type *)
+ let ind' = inductive_of_constructor cstr in
+ if Names.eq_ind ind' ind then
+ (* Check the constructor has the right number of args *)
+ let ci = cstrs.(i-1) in
+ let nb_args_constr = ci.cs_nargs in
+ if List.length args = nb_args_constr then pat
+ else
+ try
+ let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
+ in PatCstr (loc, cstr, args', alias)
+ with NotAdjustable ->
+ error_wrong_numarg_constructor_loc loc (Global.env())
+ cstr nb_args_constr
+ else
+ (* Try to insert a coercion *)
+ try
+ Coercion.inh_pattern_coerce_to loc pat ind' ind
+ with Not_found ->
+ error_bad_constructor_loc loc cstr ind
+
+let check_all_variables typ mat =
+ List.iter
+ (fun eqn -> match current_pattern eqn with
+ | PatVar (_,id) -> ()
+ | PatCstr (loc,cstr_sp,_,_) ->
+ error_bad_pattern_loc loc cstr_sp typ)
+ mat
+
+let check_unused_pattern env eqn =
+ if not !(eqn.used) then
+ raise_pattern_matching_error
+ (eqn.eqn_loc, env, UnusedClause eqn.patterns)
+
+let set_used_pattern eqn = eqn.used := true
+
+let extract_rhs pb =
+ match pb.mat with
+ | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
+ | eqn::_ ->
+ set_used_pattern eqn;
+ eqn.rhs
+
+(**********************************************************************)
+(* Functions to deal with matrix factorization *)
+
+let occur_in_rhs na rhs =
+ match na with
+ | Anonymous -> false
+ | Name id -> occur_rawconstr id rhs.it
+
+let is_dep_patt eqn = function
+ | PatVar (_,name) -> occur_in_rhs name eqn.rhs
+ | PatCstr _ -> true
+
+let dependencies_in_rhs nargs eqns =
+ if eqns = [] then list_tabulate (fun _ -> false) nargs (* Only "_" patts *)
+ else
+ let deps = List.map (fun (tms,eqn) -> List.map (is_dep_patt eqn) tms) eqns in
+ let columns = matrix_transpose deps in
+ List.map (List.exists ((=) true)) columns
+
+let dependent_decl a = function
+ | (na,None,t) -> dependent a t
+ | (na,Some c,t) -> dependent a t || dependent a c
+
+(* Computing the matrix of dependencies *)
+
+(* We are in context d1...dn |- and [find_dependencies k 1 nextlist]
+ computes for declaration [k+1] in which of declarations in
+ [nextlist] (which corresponds to d(k+2)...dn) it depends;
+ declarations are expressed by index, e.g. in dependency list
+ [n-2;1], [1] points to [dn] and [n-2] to [d3] *)
+
+let rec find_dependency_list k n = function
+ | [] -> []
+ | (used,tdeps,d)::rest ->
+ let deps = find_dependency_list k (n+1) rest in
+ if used && dependent_decl (mkRel n) d
+ then list_add_set (List.length rest + 1) (list_union deps tdeps)
+ else deps
+
+let find_dependencies is_dep_or_cstr_in_rhs d (k,nextlist) =
+ let deps = find_dependency_list k 1 nextlist in
+ if is_dep_or_cstr_in_rhs || deps <> []
+ then (k-1,(true ,deps,d)::nextlist)
+ else (k-1,(false,[] ,d)::nextlist)
+
+let find_dependencies_signature deps_in_rhs typs =
+ let k = List.length deps_in_rhs in
+ let _,l = List.fold_right2 find_dependencies deps_in_rhs typs (k,[]) in
+ List.map (fun (_,deps,_) -> deps) l
+
+(******)
+
+(* A Pushed term to match has just been substituted by some
+ constructor t = (ci x1...xn) and the terms x1 ... xn have been added to
+ match
+
+ - all terms to match and to push (dependent on t by definition)
+ must have (Rel depth) substituted by t and Rel's>depth lifted by n
+ - all pushed terms to match (non dependent on t by definition) must
+ be lifted by n
+
+ We start with depth=1
+*)
+
+let regeneralize_index_tomatch n =
+ let rec genrec depth = function
+ | [] -> []
+ | Pushed ((c,tm),l)::rest ->
+ let c = regeneralize_index n depth c in
+ let tm = map_tomatch_type (regeneralize_index n depth) tm in
+ let l = List.map (regeneralize_rel n depth) l in
+ Pushed ((c,tm),l)::(genrec depth rest)
+ | Alias (c1,c2,d,t)::rest ->
+ Alias (regeneralize_index n depth c1,c2,d,t)::(genrec depth rest)
+ | Abstract d::rest ->
+ Abstract (map_rel_declaration (regeneralize_index n depth) d)
+ ::(genrec (depth+1) rest) in
+ genrec 0
+
+let rec replace_term n c k t =
+ if t = mkRel (n+k) then lift k c
+ else map_constr_with_binders succ (replace_term n c) k t
+
+let replace_tomatch n c =
+ let rec replrec depth = function
+ | [] -> []
+ | Pushed ((b,tm),l)::rest ->
+ let b = replace_term n c depth b in
+ let tm = map_tomatch_type (replace_term n c depth) tm in
+ List.iter (fun i -> if i=n+depth then anomaly "replace_tomatch") l;
+ Pushed ((b,tm),l)::(replrec depth rest)
+ | Alias (c1,c2,d,t)::rest ->
+ Alias (replace_term n c depth c1,c2,d,t)::(replrec depth rest)
+ | Abstract d::rest ->
+ Abstract (map_rel_declaration (replace_term n c depth) d)
+ ::(replrec (depth+1) rest) in
+ replrec 0
+
+let rec liftn_tomatch_stack n depth = function
+ | [] -> []
+ | Pushed ((c,tm),l)::rest ->
+ let c = liftn n depth c in
+ let tm = liftn_tomatch_type n depth tm in
+ let l = List.map (fun i -> if i<depth then i else i+n) l in
+ Pushed ((c,tm),l)::(liftn_tomatch_stack n depth rest)
+ | Alias (c1,c2,d,t)::rest ->
+ Alias (liftn n depth c1,liftn n depth c2,d,liftn n depth t)
+ ::(liftn_tomatch_stack n depth rest)
+ | Abstract d::rest ->
+ Abstract (map_rel_declaration (liftn n depth) d)
+ ::(liftn_tomatch_stack n (depth+1) rest)
+
+
+let lift_tomatch_stack n = liftn_tomatch_stack n 1
+
+(* if [current] has type [I(p1...pn u1...um)] and we consider the case
+ of constructor [ci] of type [I(p1...pn u'1...u'm)], then the
+ default variable [name] is expected to have which type?
+ Rem: [current] is [(Rel i)] except perhaps for initial terms to match *)
+
+(************************************************************************)
+(* Some heuristics to get names for variables pushed in pb environment *)
+(* Typical requirement:
+
+ [match y with (S (S x)) => x | x => x end] should be compiled into
+ [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
+
+ and [match y with (S (S n)) => n | n => n end] into
+ [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
+
+ i.e. user names should be preserved and created names should not
+ interfere with user names *)
+
+let merge_name get_name obj = function
+ | Anonymous -> get_name obj
+ | na -> na
+
+let merge_names get_name = List.map2 (merge_name get_name)
+
+let get_names env sign eqns =
+ let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in
+ (* If any, we prefer names used in pats, from top to bottom *)
+ let names2 =
+ List.fold_right
+ (fun (pats,eqn) names -> merge_names alias_of_pat pats names)
+ eqns names1 in
+ (* Otherwise, we take names from the parameters of the constructor but
+ avoiding conflicts with user ids *)
+ let allvars =
+ List.fold_left (fun l (_,eqn) -> list_union l eqn.rhs.avoid_ids) [] eqns in
+ let names4,_ =
+ List.fold_left2
+ (fun (l,avoid) d na ->
+ let na =
+ merge_name
+ (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid))
+ d na
+ in
+ (na::l,(out_name na)::avoid))
+ ([],allvars) (List.rev sign) names2 in
+ names4
+
+(************************************************************************)
+(* Recovering names for variables pushed to the rhs' environment *)
+
+let recover_alias_names get_name = List.map2 (fun x (_,c,t) ->(get_name x,c,t))
+
+let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n | Anonymous -> Name (id_of_string "Anonymous") in
+ (n, b, t)) sign
+
+let push_rels_eqn sign eqn =
+ let sign = all_name sign in
+ {eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } }
+
+let push_rels_eqn_with_names sign eqn =
+ let pats = List.rev (list_firstn (List.length sign) eqn.patterns) in
+ let sign = recover_alias_names alias_of_pat pats sign in
+ push_rels_eqn sign eqn
+
+let build_aliases_context env sigma names allpats pats =
+ (* pats is the list of bodies to push as an alias *)
+ (* They all are defined in env and we turn them into a sign *)
+ (* cuts in sign need to be done in allpats *)
+ let rec insert env sign1 sign2 n newallpats oldallpats = function
+ | (deppat,_,_,_)::pats, Anonymous::names when not (isRel deppat) ->
+ (* Anonymous leaves must be considered named and treated in the *)
+ (* next clause because they may occur in implicit arguments *)
+ insert env sign1 sign2
+ n newallpats (List.map List.tl oldallpats) (pats,names)
+ | (deppat,nondeppat,d,t)::pats, na::names ->
+ let nondeppat = lift n nondeppat in
+ let deppat = lift n deppat in
+ let newallpats =
+ List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
+ let oldallpats = List.map List.tl oldallpats in
+ let decl = (na,Some deppat,t) in
+ let a = (deppat,nondeppat,d,t) in
+ insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1)
+ newallpats oldallpats (pats,names)
+ | [], [] -> newallpats, sign1, sign2, env
+ | _ -> anomaly "Inconsistent alias and name lists" in
+ let allpats = List.map (fun x -> [x]) allpats
+ in insert env [] [] 0 (List.map (fun _ -> []) allpats) allpats (pats, names)
+
+let insert_aliases_eqn sign eqnnames alias_rest eqn =
+ let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in
+ push_rels_eqn thissign { eqn with alias_stack = alias_rest; }
+
+
+let insert_aliases env sigma alias eqns =
+ (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *)
+ (* défaut présent mais inutile, ce qui est le cas général, l'alias *)
+ (* est introduit même s'il n'est pas utilisé dans les cas réguliers *)
+ let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in
+ let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in
+ (* names2 takes the meet of all needed aliases *)
+ let names2 =
+ List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in
+ (* Only needed aliases are kept by build_aliases_context *)
+ let eqnsnames, sign1, sign2, env =
+ build_aliases_context env sigma [names2] eqnsnames [alias] in
+ let eqns = list_map3 (insert_aliases_eqn sign1) eqnsnames alias_rests eqns in
+ sign2, env, eqns
+
+(**********************************************************************)
+(* Functions to deal with elimination predicate *)
+
+exception Occur
+let noccur_between_without_evar n m term =
+ let rec occur_rec n c = match kind_of_term c with
+ | Rel p -> if n<=p && p<n+m then raise Occur
+ | Evar (_,cl) -> ()
+ | _ -> iter_constr_with_binders succ occur_rec n c
+ in
+ try occur_rec n term; true with Occur -> false
+
+(* Inferring the predicate *)
+let prepare_unif_pb typ cs =
+ let n = List.length (assums_of_rel_context cs.cs_args) in
+
+ (* We may need to invert ci if its parameters occur in typ *)
+ let typ' =
+ if noccur_between_without_evar 1 n typ then lift (-n) typ
+ else (* TODO4-1 *)
+ error "Unable to infer return clause of this pattern-matching problem" in
+ let args = extended_rel_list (-n) cs.cs_args in
+ let ci = applist (mkConstruct cs.cs_cstr, cs.cs_params@args) in
+
+ (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = typ' *)
+ (Array.map (lift (-n)) cs.cs_concl_realargs, ci, typ')
+
+
+(* Infering the predicate *)
+(*
+The problem to solve is the following:
+
+We match Gamma |- t : I(u01..u0q) against the following constructors:
+
+ Gamma, x11...x1p1 |- C1(x11..x1p1) : I(u11..u1q)
+ ...
+ Gamma, xn1...xnpn |- Cn(xn1..xnp1) : I(un1..unq)
+
+Assume the types in the branches are the following
+
+ Gamma, x11...x1p1 |- branch1 : T1
+ ...
+ Gamma, xn1...xnpn |- branchn : Tn
+
+Assume the type of the global case expression is Gamma |- T
+
+The predicate has the form phi = [y1..yq][z:I(y1..yq)]? and must satisfy
+the following n+1 equations:
+
+ Gamma, x11...x1p1 |- (phi u11..u1q (C1 x11..x1p1)) = T1
+ ...
+ Gamma, xn1...xnpn |- (phi un1..unq (Cn xn1..xnpn)) = Tn
+ Gamma |- (phi u01..u0q t) = T
+
+Some hints:
+
+- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..."
+ should be inserted somewhere in Ti.
+
+- If T is undefined, an easy solution is to insert a "match z with (Ci
+ xi1..xipi) => ..." in front of each Ti
+
+- Otherwise, T1..Tn and T must be step by step unified, if some of them
+ diverge, then try to replace the diverging subterm by one of y1..yq or z.
+
+- The main problem is what to do when an existential variables is encountered
+
+let prepare_unif_pb typ cs =
+ let n = cs.cs_nargs in
+ let _,p = decompose_prod_n n typ in
+ let ci = build_dependent_constructor cs in
+ (* This is the problem: finding P s.t. cs_args |- (P realargs ci) = p *)
+ (n, cs.cs_concl_realargs, ci, p)
+
+let eq_operator_lift k (n,n') = function
+ | OpRel p, OpRel p' when p > k & p' > k ->
+ if p < k+n or p' < k+n' then false else p - n = p' - n'
+ | op, op' -> op = op'
+
+let rec transpose_args n =
+ if n=0 then []
+ else
+ (Array.map (fun l -> List.hd l) lv)::
+ (transpose_args (m-1) (Array.init (fun l -> List.tl l)))
+
+let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
+
+let reloc_operator (k,n) = function OpRel p when p > k ->
+let rec unify_clauses k pv =
+ let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) ( isevars)) p) pv in
+ let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
+ if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
+ then
+ let argvl = transpose_args (List.length args1) pv' in
+ let k' = shift_operator k op1 in
+ let argl = List.map (unify_clauses k') argvl in
+ gather_constr (reloc_operator (k,n1) op1) argl
+*)
+
+let abstract_conclusion typ cs =
+ let n = List.length (assums_of_rel_context cs.cs_args) in
+ let (sign,p) = decompose_prod_n n typ in
+ it_mkLambda p sign
+
+let infer_predicate loc env isevars typs cstrs indf =
+ (* Il faudra substituer les isevars a un certain moment *)
+ if Array.length cstrs = 0 then (* "TODO4-3" *)
+ error "Inference of annotation for empty inductive types not implemented"
+ else
+ (* Empiric normalization: p may depend in a irrelevant way on args of the*)
+ (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
+ let typs =
+ Array.map (local_strong whd_beta ( !isevars)) typs
+ in
+ let eqns = array_map2 prepare_unif_pb typs cstrs in
+ (* First strategy: no dependencies at all *)
+(*
+ let (mis,_) = dest_ind_family indf in
+ let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in
+*)
+ let (sign,_) = get_arity env indf in
+ let mtyp =
+ if array_exists is_Type typs then
+ (* Heuristic to avoid comparison between non-variables algebric univs*)
+ new_Type ()
+ else
+ mkExistential env ~src:(loc, Evd.CasesType) isevars
+ in
+ if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns
+ then
+ (* Non dependent case -> turn it into a (dummy) dependent one *)
+ let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
+ let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
+ (true,pred) (* true = dependent -- par défaut *)
+ else
+(*
+ let s = get_sort_of env ( isevars) typs.(0) in
+ let predpred = it_mkLambda_or_LetIn (mkSort s) sign in
+ let caseinfo = make_default_case_info mis in
+ let brs = array_map2 abstract_conclusion typs cstrs in
+ let predbody = mkCase (caseinfo, (nf_betaiota predpred), mkRel 1, brs) in
+ let pred = it_mkLambda_or_LetIn (lift (List.length sign) mtyp) sign in
+*)
+ (* "TODO4-2" *)
+ (* We skip parameters *)
+ let cis =
+ Array.map
+ (fun cs ->
+ applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args))
+ cstrs in
+ let ct = array_map2 (fun ci (_,_,t) -> (ci,t)) cis eqns in
+ raise_pattern_matching_error (loc,env, CannotInferPredicate ct)
+(*
+ (true,pred)
+*)
+
+(* Propagation of user-provided predicate through compilation steps *)
+
+let rec map_predicate f k = function
+ | PrCcl ccl -> PrCcl (f k ccl)
+ | PrProd pred ->
+ PrProd (map_predicate f (k+1) pred)
+ | PrLetIn ((names,dep as tm),pred) ->
+ let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
+ PrLetIn (tm, map_predicate f (k+k') pred)
+
+let rec noccurn_predicate k = function
+ | PrCcl ccl -> noccurn k ccl
+ | PrProd pred -> noccurn_predicate (k+1) pred
+ | PrLetIn ((names,dep),pred) ->
+ let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
+ noccurn_predicate (k+k') pred
+
+let liftn_predicate n = map_predicate (liftn n)
+
+let lift_predicate n = liftn_predicate n 1
+
+let regeneralize_index_predicate n = map_predicate (regeneralize_index n) 0
+
+let substnl_predicate sigma = map_predicate (substnl sigma)
+
+(* This is parallel bindings *)
+let subst_predicate (args,copt) pred =
+ let sigma = match copt with
+ | None -> List.rev args
+ | Some c -> c::(List.rev args) in
+ substnl_predicate sigma 0 pred
+
+let specialize_predicate_var (cur,typ) = function
+ | PrProd _ | PrCcl _ ->
+ anomaly "specialize_predicate_var: a pattern-variable must be pushed"
+ | PrLetIn (([],dep),pred) ->
+ subst_predicate ([],if dep<>Anonymous then Some cur else None) pred
+ | PrLetIn ((_,dep),pred) ->
+ (match typ with
+ | IsInd (_,IndType (_,realargs)) ->
+ subst_predicate (realargs,if dep<>Anonymous then Some cur else None) pred
+ | _ -> anomaly "specialize_predicate_var")
+
+let ungeneralize_predicate = function
+ | PrLetIn _ | PrCcl _ -> anomaly "ungeneralize_predicate: expects a product"
+ | PrProd pred -> pred
+
+(*****************************************************************************)
+(* We have pred = [X:=realargs;x:=c]P typed in Gamma1, x:I(realargs), Gamma2 *)
+(* and we want to abstract P over y:t(x) typed in the same context to get *)
+(* *)
+(* pred' = [X:=realargs;x':=c](y':t(x'))P[y:=y'] *)
+(* *)
+(* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x' *)
+(* then we have to replace x by x' in t(x) and y by y' in P *)
+(*****************************************************************************)
+let generalize_predicate ny d = function
+ | PrLetIn ((names,dep as tm),pred) ->
+ if dep=Anonymous then anomaly "Undetected dependency";
+ let p = List.length names + 1 in
+ let pred = lift_predicate 1 pred in
+ let pred = regeneralize_index_predicate (ny+p+1) pred in
+ PrLetIn (tm, PrProd pred)
+ | PrProd _ | PrCcl _ ->
+ anomaly "generalize_predicate: expects a non trivial pattern"
+
+let rec extract_predicate l = function
+ | pred, Alias (deppat,nondeppat,_,_)::tms ->
+ let tms' = match kind_of_term nondeppat with
+ | Rel i -> replace_tomatch i deppat tms
+ | _ -> (* initial terms are not dependent *) tms in
+ extract_predicate l (pred,tms')
+ | PrProd pred, Abstract d'::tms ->
+ let d' = map_rel_declaration (lift (List.length l)) d' in
+ substl l (mkProd_or_LetIn d' (extract_predicate [] (pred,tms)))
+ | PrLetIn (([],dep),pred), Pushed ((cur,_),_)::tms ->
+ extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
+ | PrLetIn ((_,dep),pred), Pushed ((cur,IsInd (_,(IndType(_,realargs)))),_)::tms ->
+ let l = List.rev realargs@l in
+ extract_predicate (if dep<>Anonymous then cur::l else l) (pred,tms)
+ | PrCcl ccl, [] ->
+ substl l ccl
+ | _ -> anomaly"extract_predicate: predicate inconsistent with terms to match"
+
+let abstract_predicate env sigma indf cur tms = function
+ | (PrProd _ | PrCcl _) -> anomaly "abstract_predicate: must be some LetIn"
+ | PrLetIn ((names,dep),pred) ->
+ let sign = make_arity_signature env true indf in
+ (* n is the number of real args + 1 *)
+ let n = List.length sign in
+ let tms = lift_tomatch_stack n tms in
+ let tms =
+ match kind_of_term cur with
+ | Rel i -> regeneralize_index_tomatch (i+n) tms
+ | _ -> (* Initial case *) tms in
+ (* Depending on whether the predicate is dependent or not, and has real
+ args or not, we lift it to make room for [sign] *)
+ (* Even if not intrinsically dep, we move the predicate into a dep one *)
+ let sign,k =
+ if names = [] & n <> 1 then
+ (* Real args were not considered *)
+ (if dep<>Anonymous then
+ ((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1)
+ else
+ (sign,n))
+ else
+ (* Real args are OK *)
+ (List.map2 (fun na (_,c,t) -> (na,c,t)) (dep::names) sign,
+ if dep<>Anonymous then 0 else 1) in
+ let pred = lift_predicate k pred in
+ let pred = extract_predicate [] (pred,tms) in
+ (true, it_mkLambda_or_LetIn_name env pred sign)
+
+let rec known_dependent = function
+ | None -> false
+ | Some (PrLetIn ((_,dep),_)) -> dep<>Anonymous
+ | Some (PrCcl _) -> false
+ | Some (PrProd _) ->
+ anomaly "known_dependent: can only be used when patterns remain"
+
+(* [expand_arg] is used by [specialize_predicate]
+ it replaces gamma, x1...xn, x1...xk |- pred
+ by gamma, x1...xn, x1...xk-1 |- [X=realargs,xk=xk]pred (if dep) or
+ by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *)
+
+let expand_arg n alreadydep (na,t) deps (k,pred) =
+ (* current can occur in pred even if the original problem is not dependent *)
+ let dep =
+ if alreadydep<>Anonymous then alreadydep
+ else if deps = [] && noccurn_predicate 1 pred then Anonymous
+ else Name (id_of_string "x") in
+ let pred = if dep<>Anonymous then pred else lift_predicate (-1) pred in
+ (* There is no dependency in realargs for subpattern *)
+ (k-1, PrLetIn (([],dep), pred))
+
+
+(*****************************************************************************)
+(* pred = [X:=realargs;x:=c]P types the following problem: *)
+(* *)
+(* Gamma |- match Pushed(c:I(realargs)) rest with...end: pred *)
+(* *)
+(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi) *)
+(* is considered. Assume each Ti is some Ii(argsi). *)
+(* We let e=Ci(x1,...,xn) and replace pred by *)
+(* *)
+(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
+(* *)
+(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
+(* *)
+(*****************************************************************************)
+let specialize_predicate tomatchs deps cs = function
+ | (PrProd _ | PrCcl _) ->
+ anomaly "specialize_predicate: a matched pattern must be pushed"
+ | PrLetIn ((names,isdep),pred) ->
+ (* Assume some gamma st: gamma, (X,x:=realargs,copt) |- pred *)
+ let nrealargs = List.length names in
+ let k = nrealargs + (if isdep<>Anonymous then 1 else 0) in
+ (* We adjust pred st: gamma, x1..xn, (X,x:=realargs,copt) |- pred' *)
+ let n = cs.cs_nargs in
+ let pred' = liftn_predicate n (k+1) pred in
+ let argsi = if nrealargs <> 0 then Array.to_list cs.cs_concl_realargs else [] in
+ let copti = if isdep<>Anonymous then Some (build_dependent_constructor cs) else None in
+ (* The substituends argsi, copti are all defined in gamma, x1...xn *)
+ (* We need _parallel_ bindings to get gamma, x1...xn |- pred'' *)
+ let pred'' = subst_predicate (argsi, copti) pred' in
+ (* We adjust pred st: gamma, x1..xn, x1..xn |- pred'' *)
+ let pred''' = liftn_predicate n (n+1) pred'' in
+ (* We finally get gamma,x1..xn |- [X1,x1:=R1,x1]..[Xn,xn:=Rn,xn]pred'''*)
+ snd (List.fold_right2 (expand_arg n isdep) tomatchs deps (n,pred'''))
+
+let find_predicate loc env isevars p typs cstrs current
+ (IndType (indf,realargs)) tms =
+ let (dep,pred) =
+ match p with
+ | Some p -> abstract_predicate env ( !isevars) indf current tms p
+ | None -> infer_predicate loc env isevars typs cstrs indf in
+ let typ = whd_beta ( !isevars) (applist (pred, realargs)) in
+ if dep then
+ (pred, whd_beta ( !isevars) (applist (typ, [current])),
+ new_Type ())
+ else
+ (pred, typ, new_Type ())
+
+(************************************************************************)
+(* Sorting equations by constructor *)
+
+type inversion_problem =
+ (* the discriminating arg in some Ind and its order in Ind *)
+ | Incompatible of int * (int * int)
+ | Constraints of (int * constr) list
+
+let solve_constraints constr_info indt =
+ (* TODO *)
+ Constraints []
+
+let rec irrefutable env = function
+ | PatVar (_,name) -> true
+ | PatCstr (_,cstr,args,_) ->
+ let ind = inductive_of_constructor cstr in
+ let (_,mip) = Inductive.lookup_mind_specif env ind in
+ let one_constr = Array.length mip.mind_user_lc = 1 in
+ one_constr & List.for_all (irrefutable env) args
+
+let first_clause_irrefutable env = function
+ | eqn::mat -> List.for_all (irrefutable env) eqn.patterns
+ | _ -> false
+
+let group_equations pb ind current cstrs mat =
+ let mat =
+ if first_clause_irrefutable pb.env mat then [List.hd mat] else mat in
+ let brs = Array.create (Array.length cstrs) [] in
+ let only_default = ref true in
+ let _ =
+ List.fold_right (* To be sure it's from bottom to top *)
+ (fun eqn () ->
+ let rest = remove_current_pattern eqn in
+ let pat = current_pattern eqn in
+ match check_and_adjust_constructor pb.env ind cstrs pat with
+ | PatVar (_,name) ->
+ (* This is a default clause that we expand *)
+ for i=1 to Array.length cstrs do
+ let n = cstrs.(i-1).cs_nargs in
+ let args = make_anonymous_patvars n in
+ brs.(i-1) <- (args, rest) :: brs.(i-1)
+ done
+ | PatCstr (loc,((_,i)),args,_) ->
+ (* This is a regular clause *)
+ only_default := false;
+ brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
+ (brs,!only_default)
+
+(************************************************************************)
+(* Here starts the pattern-matching compilation algorithm *)
+
+(* Abstracting over dependent subterms to match *)
+let rec generalize_problem pb = function
+ | [] -> pb
+ | i::l ->
+ let d = map_rel_declaration (lift i) (Environ.lookup_rel i pb.env) in
+ let pb' = generalize_problem pb l in
+ let tomatch = lift_tomatch_stack 1 pb'.tomatch in
+ let tomatch = regeneralize_index_tomatch (i+1) tomatch in
+ { pb with
+ tomatch = Abstract d :: tomatch;
+ pred = Option.map (generalize_predicate i d) pb'.pred }
+
+(* No more patterns: typing the right-hand-side of equations *)
+let build_leaf pb =
+ let rhs = extract_rhs pb in
+ let tycon = match pb.pred with
+ | None -> anomaly "Predicate not found"
+ | Some (PrCcl typ) -> mk_tycon typ
+ | Some _ -> anomaly "not all parameters of pred have been consumed" in
+ pb.typing_function tycon rhs.rhs_env rhs.it
+
+(* Building the sub-problem when all patterns are variables *)
+let shift_problem (current,t) pb =
+ {pb with
+ tomatch = Alias (current,current,NonDepAlias,type_of_tomatch t)::pb.tomatch;
+ pred = Option.map (specialize_predicate_var (current,t)) pb.pred;
+ history = push_history_pattern 0 AliasLeaf pb.history;
+ mat = List.map remove_current_pattern pb.mat }
+
+(* Building the sub-pattern-matching problem for a given branch *)
+let build_branch current deps pb eqns const_info =
+ (* We remember that we descend through a constructor *)
+ let alias_type =
+ if Array.length const_info.cs_concl_realargs = 0
+ & not (known_dependent pb.pred) & deps = []
+ then
+ NonDepAlias
+ else
+ DepAlias
+ in
+ let history =
+ push_history_pattern const_info.cs_nargs
+ (AliasConstructor const_info.cs_cstr)
+ pb.history in
+
+ (* We find matching clauses *)
+ let cs_args = (*assums_of_rel_context*) const_info.cs_args in
+ let names = get_names pb.env cs_args eqns in
+ let submat = List.map (fun (tms,eqn) -> prepend_pattern tms eqn) eqns in
+ if submat = [] then
+ raise_pattern_matching_error
+ (dummy_loc, pb.env, NonExhaustive (complete_history history));
+ let typs = List.map2 (fun (_,c,t) na -> (na,c,t)) cs_args names in
+ let _,typs',_ =
+ List.fold_right
+ (fun (na,c,t as d) (env,typs,tms) ->
+ let tm1 = List.map List.hd tms in
+ let tms = List.map List.tl tms in
+ (push_rel d env, (na,to_mutind env pb.isevars tm1 c t)::typs,tms))
+ typs (pb.env,[],List.map fst eqns) in
+
+ let dep_sign =
+ find_dependencies_signature
+ (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in
+
+ (* The dependent term to subst in the types of the remaining UnPushed
+ terms is relative to the current context enriched by topushs *)
+ let ci = build_dependent_constructor const_info in
+
+ (* We replace [(mkRel 1)] by its expansion [ci] *)
+ (* and context "Gamma = Gamma1, current, Gamma2" by "Gamma;typs;curalias" *)
+ (* This is done in two steps : first from "Gamma |- tms" *)
+ (* into "Gamma; typs; curalias |- tms" *)
+ let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in
+
+ let currents =
+ list_map2_i
+ (fun i (na,t) deps -> Pushed ((mkRel i, lift_tomatch_type i t), deps))
+ 1 typs' (List.rev dep_sign) in
+
+ let sign = List.map (fun (na,t) -> mkDeclTomatch na t) typs' in
+ let ind =
+ appvect (
+ applist (mkInd (inductive_of_constructor const_info.cs_cstr),
+ List.map (lift const_info.cs_nargs) const_info.cs_params),
+ const_info.cs_concl_realargs) in
+
+ let cur_alias = lift (List.length sign) current in
+ let currents = Alias (ci,cur_alias,alias_type,ind) :: currents in
+ let env' = push_rels sign pb.env in
+ let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in
+ sign,
+ { pb with
+ env = env';
+ tomatch = List.rev_append currents tomatch;
+ pred = pred';
+ history = history;
+ mat = List.map (push_rels_eqn_with_names sign) submat }
+
+(**********************************************************************
+ INVARIANT:
+
+ pb = { env, subst, tomatch, mat, ...}
+ tomatch = list of Pushed (c:T) or Abstract (na:T) or Alias (c:T)
+
+ "Pushed" terms and types are relative to env
+ "Abstract" types are relative to env enriched by the previous terms to match
+
+*)
+
+(**********************************************************************)
+(* Main compiling descent *)
+let rec compile pb =
+ match pb.tomatch with
+ | (Pushed cur)::rest -> match_current { pb with tomatch = rest } cur
+ | (Alias x)::rest -> compile_alias pb x rest
+ | (Abstract d)::rest -> compile_generalization pb d rest
+ | [] -> build_leaf pb
+
+and match_current pb tomatch =
+ let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in
+ match typ with
+ | NotInd (_,typ) ->
+ check_all_variables typ pb.mat;
+ compile (shift_problem ct pb)
+ | IsInd (_,(IndType(indf,realargs) as indt)) ->
+ let mind,_ = dest_ind_family indf in
+ let cstrs = get_constructors pb.env indf in
+ let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
+ if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt then
+ compile (shift_problem ct pb)
+ else
+ let _constraints = Array.map (solve_constraints indt) cstrs in
+
+ (* We generalize over terms depending on current term to match *)
+ let pb = generalize_problem pb deps in
+
+ (* We compile branches *)
+ let brs = array_map2 (compile_branch current deps pb) eqns cstrs in
+
+ (* We build the (elementary) case analysis *)
+ let brvals = Array.map (fun (v,_) -> v) brs in
+ let brtyps = Array.map (fun (_,t) -> t) brs in
+ let (pred,typ,s) =
+ find_predicate pb.caseloc pb.env pb.isevars
+ pb.pred brtyps cstrs current indt pb.tomatch in
+ let ci = make_case_info pb.env mind pb.casestyle in
+ let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in
+ let inst = List.map mkRel deps in
+ { uj_val = applist (case, inst);
+ uj_type = substl inst typ }
+
+and compile_branch current deps pb eqn cstr =
+ let sign, pb = build_branch current deps pb eqn cstr in
+ let j = compile pb in
+ (it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
+
+and compile_generalization pb d rest =
+ let pb =
+ { pb with
+ env = push_rel d pb.env;
+ tomatch = rest;
+ pred = Option.map ungeneralize_predicate pb.pred;
+ mat = List.map (push_rels_eqn [d]) pb.mat } in
+ let j = compile pb in
+ { uj_val = mkLambda_or_LetIn d j.uj_val;
+ uj_type = mkProd_or_LetIn d j.uj_type }
+
+and compile_alias pb (deppat,nondeppat,d,t) rest =
+ let history = simplify_history pb.history in
+ let sign, newenv, mat =
+ insert_aliases pb.env ( !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
+ let n = List.length sign in
+
+ (* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
+ (* Gamma1; x:current; Gamma2; typs; x':=curalias |- tomatch(x') *)
+ let tomatch = lift_tomatch_stack n rest in
+ let tomatch = match kind_of_term nondeppat with
+ | Rel i ->
+ if n = 1 then regeneralize_index_tomatch (i+n) tomatch
+ else replace_tomatch i deppat tomatch
+ | _ -> (* initial terms are not dependent *) tomatch in
+
+ let pb =
+ {pb with
+ env = newenv;
+ tomatch = tomatch;
+ pred = Option.map (lift_predicate n) pb.pred;
+ history = history;
+ mat = mat } in
+ let j = compile pb in
+ List.fold_left mkSpecialLetInJudge j sign
+
+(* pour les alias des initiaux, enrichir les env de ce qu'il faut et
+substituer après par les initiaux *)
+
+(**************************************************************************)
+(* Preparation of the pattern-matching problem *)
+
+(* builds the matrix of equations testing that each eqn has n patterns
+ * and linearizing the _ patterns.
+ * Syntactic correctness has already been done in astterm *)
+let matx_of_eqns env eqns =
+ let build_eqn (loc,ids,lpat,rhs) =
+ let rhs =
+ { rhs_env = env;
+ avoid_ids = ids@(ids_of_named_context (named_context env));
+ it = rhs;
+ } in
+ { patterns = lpat;
+ alias_stack = [];
+ eqn_loc = loc;
+ used = ref false;
+ rhs = rhs }
+ in List.map build_eqn eqns
+
+(************************************************************************)
+(* preparing the elimination predicate if any *)
+
+let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c =
+ let cook (n, l, env, signs) = function
+ | c,IsInd (_,IndType(indf,realargs)) ->
+ let indf' = lift_inductive_family n indf in
+ let sign = make_arity_signature env dep indf' in
+ let p = List.length realargs in
+ if dep then
+ (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
+ else
+ (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
+ | c,NotInd _ ->
+ (n, l, env, []::signs) in
+ let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
+ let names = List.rev (List.map (List.map pi1) signs) in
+ let allargs =
+ List.map (fun c -> lift n (nf_betadeltaiota env ( !isevars) c)) allargs in
+ let rec build_skeleton env c =
+ (* Don't put into normal form, it has effects on the synthesis of evars *)
+ (* let c = whd_betadeltaiota env ( isevars) c in *)
+ (* We turn all subterms possibly dependent into an evar with maximum ctxt*)
+ if isEvar c or List.exists (eq_constr c) allargs then
+ e_new_evar isevars env ~src:(loc, Evd.CasesType)
+ (Retyping.get_type_of env ( !isevars) c)
+ else
+ map_constr_with_full_binders push_rel build_skeleton env c
+ in
+ names, build_skeleton env (lift n c)
+
+(* Here, [pred] is assumed to be in the context built from all *)
+(* realargs and terms to match *)
+let build_initial_predicate isdep allnames pred =
+ let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
+ let rec buildrec n pred = function
+ | [] -> PrCcl pred
+ | names::lnames ->
+ let names' = if isdep then List.tl names else names in
+ let n' = n + List.length names' in
+ let pred, p, user_p =
+ if isdep then
+ if dependent (mkRel (nar-n')) pred then pred, 1, 1
+ else liftn (-1) (nar-n') pred, 0, 1
+ else pred, 0, 0 in
+ let na =
+ if p=1 then
+ let na = List.hd names in
+ if na = Anonymous then
+ (* peut arriver en raison des evars *)
+ Name (id_of_string "x") (*Hum*)
+ else na
+ else Anonymous in
+ PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
+ in buildrec 0 pred allnames
+
+let extract_arity_signature env0 tomatchl tmsign =
+ let get_one_sign n tm (na,t) =
+ match tm with
+ | NotInd (bo,typ) ->
+ (match t with
+ | None -> [na,Option.map (lift n) bo,lift n typ]
+ | Some (loc,_,_,_) ->
+ user_err_loc (loc,"",
+ str "Unexpected type annotation for a term of non inductive type"))
+ | IsInd (_,IndType(indf,realargs)) ->
+ let indf' = lift_inductive_family n indf in
+ let (ind,params) = dest_ind_family indf' in
+ let nrealargs = List.length realargs in
+ let realnal =
+ match t with
+ | Some (loc,ind',nparams,realnal) ->
+ if ind <> ind' then
+ user_err_loc (loc,"",str "Wrong inductive type");
+ if List.length params <> nparams
+ or nrealargs <> List.length realnal then
+ anomaly "Ill-formed 'in' clause in cases";
+ List.rev realnal
+ | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
+ let arsign = fst (get_arity env0 indf') in
+ (na,None,build_dependent_inductive env0 indf')
+ ::(List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign) in
+ let rec buildrec n = function
+ | [],[] -> []
+ | (_,tm)::ltm, x::tmsign ->
+ let l = get_one_sign n tm x in
+ l :: buildrec (n + List.length l) (ltm,tmsign)
+ | _ -> assert false
+ in List.rev (buildrec 0 (tomatchl,tmsign))
+
+let extract_arity_signatures env0 tomatchl tmsign =
+ let get_one_sign tm (na,t) =
+ match tm with
+ | NotInd (bo,typ) ->
+ (match t with
+ | None -> [na,bo,typ]
+ | Some (loc,_,_,_) ->
+ user_err_loc (loc,"",
+ str "Unexpected type annotation for a term of non inductive type"))
+ | IsInd (_,IndType(indf,realargs)) ->
+ let (ind,params) = dest_ind_family indf in
+ let nrealargs = List.length realargs in
+ let realnal =
+ match t with
+ | Some (loc,ind',nparams,realnal) ->
+ if ind <> ind' then
+ user_err_loc (loc,"",str "Wrong inductive type");
+ if List.length params <> nparams
+ or nrealargs <> List.length realnal then
+ anomaly "Ill-formed 'in' clause in cases";
+ List.rev realnal
+ | None -> list_tabulate (fun _ -> Anonymous) nrealargs in
+ let arsign = fst (get_arity env0 indf) in
+ (na,None,build_dependent_inductive env0 indf)
+ ::(try List.map2 (fun x (_,c,t) ->(x,c,t)) realnal arsign with _ -> assert false) in
+ let rec buildrec = function
+ | [],[] -> []
+ | (_,tm)::ltm, x::tmsign ->
+ let l = get_one_sign tm x in
+ l :: buildrec (ltm,tmsign)
+ | _ -> assert false
+ in List.rev (buildrec (tomatchl,tmsign))
+
+let inh_conv_coerce_to_tycon loc env isevars j tycon =
+ match tycon with
+ | Some p ->
+ let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in
+ isevars := evd';
+ j
+ | None -> j
+
+let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false)
+
+let string_of_name name =
+ match name with
+ | Anonymous -> "anonymous"
+ | Name n -> string_of_id n
+
+let id_of_name n = id_of_string (string_of_name n)
+
+let make_prime_id name =
+ let str = string_of_name name in
+ id_of_string str, id_of_string (str ^ "'")
+
+let prime avoid name =
+ let previd, id = make_prime_id name in
+ previd, next_ident_away id avoid
+
+let make_prime avoid prevname =
+ let previd, id = prime !avoid prevname in
+ avoid := id :: !avoid;
+ previd, id
+
+let eq_id avoid id =
+ let hid = id_of_string ("Heq_" ^ string_of_id id) in
+ let hid' = next_ident_away hid avoid in
+ hid'
+
+let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |])
+let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |])
+let mk_JMeq typ x typ' y =
+ mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |])
+let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |])
+
+let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true))
+
+let constr_of_pat env isevars arsign pat avoid =
+ let rec typ env (ty, realargs) pat avoid =
+ match pat with
+ | PatVar (l,name) ->
+ let name, avoid = match name with
+ Name n -> name, avoid
+ | Anonymous ->
+ let previd, id = prime avoid (Name (id_of_string "wildcard")) in
+ Name id, id :: avoid
+ in
+ PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, 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)
+ with Not_found -> error_case_not_inductive env
+ {uj_val = ty; uj_type = Typing.type_of env !isevars ty}
+ in
+ let ind, params = dest_ind_family indf in
+ if ind <> cind then error_bad_constructor_loc l cstr ind;
+ let cstrs = get_constructors env indf in
+ let ci = cstrs.(i-1) in
+ let nb_args_constr = ci.cs_nargs in
+ assert(nb_args_constr = List.length args);
+ let patargs, args, sign, env, n, m, 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
+ in
+ let args' = arg' :: List.map (lift n') args in
+ let env' = push_rels sign' env in
+ (pat' :: patargs, args', sign' @ sign, env', n' + n, succ m, avoid))
+ ci.cs_args (List.rev args) ([], [], [], env, 0, 0, avoid)
+ in
+ let args = List.rev args in
+ let patargs = List.rev patargs in
+ let pat' = PatCstr (l, cstr, patargs, alias) in
+ let cstr = mkConstruct ci.cs_cstr in
+ let app = applistc cstr (List.map (lift (List.length sign)) params) in
+ let app = applistc app args in
+ let apptype = Retyping.get_type_of env ( !isevars) app in
+ let IndType (indf, realargs) = find_rectype env ( !isevars) apptype in
+ match alias with
+ Anonymous ->
+ pat', sign, app, apptype, realargs, n, avoid
+ | Name id ->
+ let sign = (alias, None, lift m ty) :: sign in
+ let avoid = id :: avoid in
+ let sign, i, avoid =
+ try
+ let env = push_rels sign env in
+ isevars := the_conv_x_leq (push_rels sign env) (lift (succ m) ty) (lift 1 apptype) !isevars;
+ let eq_t = mk_eq (lift (succ m) ty)
+ (mkRel 1) (* alias *)
+ (lift 1 app) (* aliased term *)
+ in
+ let neq = eq_id avoid id in
+ (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid
+ with Reduction.NotConvertible -> sign, 1, avoid
+ in
+ (* Mark the equality as a hole *)
+ pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
+ in
+ let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in
+ pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
+
+
+(* shadows functional version *)
+let eq_id avoid id =
+ let hid = id_of_string ("Heq_" ^ string_of_id id) in
+ let hid' = next_ident_away hid !avoid in
+ avoid := hid' :: !avoid;
+ hid'
+
+let rels_of_patsign =
+ List.map (fun ((na, b, t) as x) ->
+ match b with
+ | Some t' when kind_of_term t' = Rel 0 -> (na, None, t)
+ | _ -> x)
+
+let vars_of_ctx ctx =
+ let _, y =
+ List.fold_right (fun (na, b, t) (prev, vars) ->
+ match b with
+ | Some t' when kind_of_term t' = Rel 0 ->
+ prev,
+ (RApp (dummy_loc,
+ (RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars
+ | _ ->
+ match na with
+ Anonymous -> raise (Invalid_argument "vars_of_ctx")
+ | Name n -> n, RVar (dummy_loc, n) :: vars)
+ ctx (id_of_string "vars_of_ctx_error", [])
+ in List.rev y
+
+let rec is_included x y =
+ match x, y with
+ | PatVar _, _ -> true
+ | _, PatVar _ -> true
+ | PatCstr (l, (_, i), args, alias), PatCstr (l', (_, i'), args', alias') ->
+ if i = i' then List.for_all2 is_included args args'
+ else false
+
+(* liftsign is the current pattern's complete signature length. Hence pats is already typed in its
+ full signature. However prevpatterns are in the original one signature per pattern form.
+ *)
+let build_ineqs prevpatterns pats liftsign =
+ let _tomatchs = List.length pats in
+ let diffs =
+ List.fold_left
+ (fun c eqnpats ->
+ let acc = List.fold_left2
+ (* ppat is the pattern we are discriminating against, curpat is the current one. *)
+ (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat)
+ (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) ->
+ match acc with
+ None -> None
+ | Some (sign, len, n, c) -> (* FixMe: do not work with ppat_args *)
+ if is_included curpat ppat then
+ (* Length of previous pattern's signature *)
+ let lens = List.length ppat_sign in
+ (* Accumulated length of previous pattern's signatures *)
+ let len' = lens + len in
+ let acc =
+ ((* Jump over previous prevpat signs *)
+ lift_rel_context len ppat_sign @ sign,
+ len',
+ succ n, (* nth pattern *)
+ mkApp (Lazy.force eq_ind,
+ [| lift (len' + liftsign) curpat_ty;
+ liftn (len + liftsign) (succ lens) ppat_c ;
+ lift len' curpat_c |]) ::
+ List.map (lift lens (* Jump over this prevpat signature *)) c)
+ in Some acc
+ else None)
+ (Some ([], 0, 0, [])) eqnpats pats
+ in match acc with
+ None -> c
+ | Some (sign, len, _, c') ->
+ let conj = it_mkProd_or_LetIn (mk_not (mk_conj c'))
+ (lift_rel_context liftsign sign)
+ in
+ conj :: c)
+ [] prevpatterns
+ in match diffs with [] -> None
+ | _ -> Some (mk_conj diffs)
+
+let subst_rel_context k ctx subst =
+ let (_, ctx') =
+ List.fold_right
+ (fun (n, b, t) (k, acc) ->
+ (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc))
+ ctx (k, [])
+ in ctx'
+
+let lift_rel_contextn n k sign =
+ let rec liftrec k = function
+ | (na,c,t)::sign ->
+ (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
+ | [] -> []
+ in
+ liftrec (rel_context_length sign + k) sign
+
+let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity =
+ let i = ref 0 in
+ let (x, y, z) =
+ List.fold_left
+ (fun (branches, eqns, prevpatterns) eqn ->
+ let _, newpatterns, pats =
+ List.fold_left2
+ (fun (idents, newpatterns, pats) pat arsign ->
+ let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in
+ (idents, pat' :: newpatterns, cpat :: pats))
+ ([], [], []) eqn.patterns sign
+ in
+ let newpatterns = List.rev newpatterns and opats = List.rev pats in
+ let rhs_rels, pats, signlen =
+ List.fold_left
+ (fun (renv, pats, n) (sign,c, (s, args), p) ->
+ (* Recombine signatures and terms of all of the row's patterns *)
+ let sign' = lift_rel_context n sign in
+ let len = List.length sign' in
+ (sign' @ renv,
+ (* lift to get outside of previous pattern's signatures. *)
+ (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats,
+ len + n))
+ ([], [], 0) opats in
+ let pats, _ = List.fold_left
+ (* lift to get outside of past patterns to get terms in the combined environment. *)
+ (fun (pats, n) (sign, c, (s, args), p) ->
+ let len = List.length sign in
+ ((rels_of_patsign sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n))
+ ([], 0) pats
+ in
+ let ineqs = build_ineqs prevpatterns pats signlen in
+ let rhs_rels' = rels_of_patsign rhs_rels in
+ let _signenv = push_rel_context rhs_rels' env in
+ let arity =
+ let args, nargs =
+ List.fold_right (fun (sign, c, (_, args), _) (allargs,n) ->
+ (args @ c :: allargs, List.length args + succ n))
+ pats ([], 0)
+ in
+ let args = List.rev args in
+ substl args (liftn signlen (succ nargs) arity)
+ in
+ let rhs_rels', tycon =
+ let neqs_rels, arity =
+ match ineqs with
+ | None -> [], arity
+ | Some ineqs ->
+ [Anonymous, None, ineqs], lift 1 arity
+ in
+ let eqs_rels, arity = decompose_prod_n_assum neqs arity in
+ eqs_rels @ neqs_rels @ rhs_rels', arity
+ in
+ let rhs_env = push_rels rhs_rels' env in
+ let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in
+ let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels'
+ and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in
+ let branch_name = id_of_string ("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
+ match vars_of_ctx rhs_rels with
+ [] -> bref
+ | l -> RApp (dummy_loc, bref, l)
+ in
+ let branch = match ineqs with
+ Some _ -> RApp (dummy_loc, branch, [ hole ])
+ | None -> branch
+ in
+ incr i;
+ let rhs = { eqn.rhs with it = branch } in
+ (branch_decl :: branches,
+ { eqn with patterns = newpatterns; rhs = rhs } :: eqns,
+ opats :: prevpatterns))
+ ([], [], []) eqns
+ in x, y
+
+(* Builds the predicate. If the predicate is dependent, its context is
+ * made of 1+nrealargs assumptions for each matched term in an inductive
+ * type and 1 assumption for each term not _syntactically_ in an
+ * inductive type.
+
+ * Each matched terms are independently considered dependent or not.
+
+ * A type constraint but no annotation case: it is assumed non dependent.
+ *)
+
+let lift_ctx n ctx =
+ let ctx', _ =
+ List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0)
+ in ctx'
+
+(* Turn matched terms into variables. *)
+let abstract_tomatch env tomatchs tycon =
+ let prev, ctx, names, tycon =
+ List.fold_left
+ (fun (prev, ctx, names, tycon) (c, t) ->
+ let lenctx = List.length ctx in
+ match kind_of_term c with
+ 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
+ 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,
+ name :: names, tycon)
+ ([], [], [], tycon) tomatchs
+ in List.rev prev, ctx, tycon
+
+let is_dependent_ind = function
+ IsInd (_, IndType (indf, args)) when List.length args > 0 -> true
+ | _ -> false
+
+let build_dependent_signature env evars avoid tomatchs arsign =
+ let avoid = ref avoid in
+ let arsign = List.rev arsign in
+ let allnames = List.rev (List.map (List.map pi1) arsign) in
+ let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in
+ let eqs, neqs, refls, slift, arsign' =
+ List.fold_left2
+ (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign ->
+ (* The accumulator:
+ previous eqs,
+ number of previous eqs,
+ lift to get outside eqs and in the introduced variables ('as' and 'in'),
+ new arity signatures
+ *)
+ match ty with
+ IsInd (ty, IndType (indf, args)) when List.length args > 0 ->
+ (* Build the arity signature following the names in matched terms as much as possible *)
+ let argsign = List.tl arsign in (* arguments in inverse application order *)
+ let (appn, appb, appt) as _appsign = List.hd arsign in (* The matched argument *)
+ let argsign = List.rev argsign in (* arguments in application order *)
+ let env', nargeqs, argeqs, refl_args, slift, argsign' =
+ List.fold_left2
+ (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) ->
+ let argt = Retyping.get_type_of env evars arg in
+ let eq, refl_arg =
+ if Reductionops.is_conv env evars argt t then
+ (mk_eq (lift (nargeqs + slift) argt)
+ (mkRel (nargeqs + slift))
+ (lift (nargeqs + nar) arg),
+ mk_eq_refl argt arg)
+ else
+ (mk_JMeq (lift (nargeqs + slift) t)
+ (mkRel (nargeqs + slift))
+ (lift (nargeqs + nar) argt)
+ (lift (nargeqs + nar) arg),
+ mk_JMeq_refl argt arg)
+ in
+ let previd, id =
+ let name =
+ match kind_of_term arg with
+ Rel n -> pi1 (lookup_rel n env)
+ | _ -> name
+ in
+ make_prime avoid name
+ in
+ (env, succ nargeqs,
+ (Name (eq_id avoid previd), None, eq) :: argeqs,
+ refl_arg :: refl_args,
+ pred slift,
+ (Name id, b, t) :: argsign'))
+ (env, 0, [], [], slift, []) args argsign
+ in
+ let eq = mk_JMeq
+ (lift (nargeqs + slift) appt)
+ (mkRel (nargeqs + slift))
+ (lift (nargeqs + nar) ty)
+ (lift (nargeqs + nar) tm)
+ in
+ let refl_eq = mk_JMeq_refl ty tm in
+ let previd, id = make_prime avoid appn in
+ (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs,
+ succ nargeqs,
+ refl_eq :: refl_args,
+ pred slift,
+ (((Name id, appb, appt) :: argsign') :: arsigns))
+
+ | _ ->
+ (* Non dependent inductive or not inductive, just use a regular equality *)
+ let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in
+ let previd, id = make_prime avoid name in
+ let arsign' = (Name id, b, typ) in
+ let tomatch_ty = type_of_tomatch ty in
+ let eq =
+ mk_eq (lift nar tomatch_ty)
+ (mkRel slift) (lift nar tm)
+ in
+ ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs,
+ (mk_eq_refl tomatch_ty tm) :: refl_args,
+ pred slift, (arsign' :: []) :: arsigns))
+ ([], 0, [], nar, []) tomatchs arsign
+ in
+ let arsign'' = List.rev arsign' in
+ assert(slift = 0); (* we must have folded over all elements of the arity signature *)
+ arsign'', allnames, nar, eqs, neqs, refls
+
+(**************************************************************************)
+(* Main entry of the matching compilation *)
+
+let liftn_rel_context n k sign =
+ let rec liftrec k = function
+ | (na,c,t)::sign ->
+ (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
+ | [] -> []
+ in
+ liftrec (k + rel_context_length sign) sign
+
+let nf_evars_env sigma (env : env) : env =
+ let nf t = nf_evar sigma t in
+ let env0 : env = reset_context env in
+ let f e (na, b, t) e' : env =
+ Environ.push_named (na, Option.map nf b, nf t) e'
+ in
+ let env' = Environ.fold_named_context f ~init:env0 env in
+ Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e')
+ ~init:env' env
+
+
+let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp =
+ (* We extract the signature of the arity *)
+ let arsign = extract_arity_signature env tomatchs sign in
+ let newenv = List.fold_right push_rels arsign env in
+ let allnames = List.rev (List.map (List.map pi1) arsign) in
+ match rtntyp with
+ | Some rtntyp ->
+ let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in
+ let predccl = (j_nf_evar !isevars predcclj).uj_val in
+ Some (build_initial_predicate true allnames predccl)
+ | None ->
+ match valcon_of_tycon tycon with
+ | Some ty ->
+ let pred =
+ prepare_predicate_from_arsign_tycon loc env !isevars tomatchs arsign ty
+ in Some (build_initial_predicate true allnames pred)
+ | None -> None
+
+let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) =
+
+ let typing_fun tycon env = typing_fun tycon env isevars in
+
+ (* We build the matrix of patterns and right-hand-side *)
+ let matx = matx_of_eqns env eqns in
+
+ (* We build the vector of terms to match consistently with the *)
+ (* constructors found in patterns *)
+ let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in
+ let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in
+ if predopt = None then
+ let tycon = valcon_of_tycon tycon in
+ let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in
+ let env = push_rel_context tomatchs_lets env in
+ let len = List.length eqns in
+ let sign, allnames, signlen, eqs, neqs, args =
+ (* The arity signature *)
+ let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in
+ (* Build the dependent arity signature, the equalities which makes
+ the first part of the predicate and their instantiations. *)
+ let avoid = [] in
+ build_dependent_signature env ( !isevars) avoid tomatchs arsign
+
+ in
+ let tycon, arity =
+ match tycon' with
+ | None -> let ev = mkExistential env isevars in ev, ev
+ | Some t ->
+ Option.get tycon, prepare_predicate_from_arsign_tycon loc env ( !isevars)
+ tomatchs sign t
+ in
+ let neqs, arity =
+ let ctx = context_of_arsign eqs in
+ let neqs = List.length ctx in
+ neqs, it_mkProd_or_LetIn (lift neqs arity) ctx
+ in
+ let lets, matx =
+ (* Type the rhs under the assumption of equations *)
+ constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity
+ in
+ let matx = List.rev matx in
+ let _ = assert(len = List.length lets) in
+ let env = push_rels lets env in
+ let matx = List.map (fun eqn -> { eqn with rhs = { eqn.rhs with rhs_env = env } }) matx in
+ let tomatchs = List.map (fun (x, y) -> lift len x, lift_tomatch_type len y) tomatchs in
+ let args = List.rev_map (lift len) args in
+ let pred = liftn len (succ signlen) arity in
+ let pred = build_initial_predicate true allnames pred in
+
+ (* We push the initial terms to match and push their alias to rhs' envs *)
+ (* names of aliases will be recovered from patterns (hence Anonymous here) *)
+ let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
+
+ let pb =
+ { env = env;
+ isevars = isevars;
+ pred = Some pred;
+ tomatch = initial_pushed;
+ history = start_history (List.length initial_pushed);
+ mat = matx;
+ caseloc = loc;
+ casestyle= style;
+ typing_function = typing_fun } in
+
+ let j = compile pb in
+ (* We check for unused patterns *)
+ List.iter (check_unused_pattern env) matx;
+ let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in
+ let j =
+ { uj_val = it_mkLambda_or_LetIn body tomatchs_lets;
+ uj_type = nf_evar !isevars tycon; }
+ in j
+ else
+ (* We build the elimination predicate if any and check its consistency *)
+ (* with the type of arguments to match *)
+ let tmsign = List.map snd tomatchl in
+ let pred = prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs tmsign tycon predopt in
+
+ (* We push the initial terms to match and push their alias to rhs' envs *)
+ (* names of aliases will be recovered from patterns (hence Anonymous here) *)
+ let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
+ let pb =
+ { env = env;
+ isevars = isevars;
+ pred = pred;
+ tomatch = initial_pushed;
+ history = start_history (List.length initial_pushed);
+ mat = matx;
+ caseloc = loc;
+ casestyle= style;
+ typing_function = typing_fun } in
+
+ let j = compile pb in
+ (* We check for unused patterns *)
+ List.iter (check_unused_pattern env) matx;
+ inh_conv_coerce_to_tycon loc env isevars j tycon
+
+end
+
diff --git a/plugins/subtac/subtac_cases.mli b/plugins/subtac/subtac_cases.mli
new file mode 100644
index 00000000..90989d2d
--- /dev/null
+++ b/plugins/subtac/subtac_cases.mli
@@ -0,0 +1,23 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Evd
+open Environ
+open Inductiveops
+open Rawterm
+open Evarutil
+(*i*)
+
+(*s Compilation of pattern-matching, subtac style. *)
+module Cases_F(C : Coercion.S) : Cases.S
diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml
new file mode 100644
index 00000000..59c877c8
--- /dev/null
+++ b/plugins/subtac/subtac_classes.ml
@@ -0,0 +1,182 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Pretyping
+open Evd
+open Environ
+open Term
+open Rawterm
+open Topconstr
+open Names
+open Libnames
+open Pp
+open Vernacexpr
+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 =
+ SPretyping.understand_tcc_evars evdref env kind
+ (intern_gen (kind=IsType) ~impls ( !evdref) env c)
+
+let interp_casted_constr_evars evdref env ?(impls=([],[])) c typ =
+ interp_constr_evars_gen evdref env ~impls (OfType (Some typ)) c
+
+let interp_context_evars evdref env params =
+ Constrintern.interp_context_gen
+ (fun env t -> SPretyping.understand_tcc_evars evdref env IsType t)
+ (SPretyping.understand_judgment_tcc evdref) !evdref env params
+
+let type_ctx_instance evars env ctx inst subst =
+ let rec aux (subst, instctx) l = function
+ (na, b, t) :: ctx ->
+ let t' = substl subst t in
+ let c', l =
+ match b with
+ | None -> interp_casted_constr_evars evars env (List.hd l) t', List.tl l
+ | Some b -> substl subst b, l
+ in
+ evars := resolve_typeclasses ~onlyargs:true ~fail:true env !evars;
+ let d = na, Some c', t' in
+ aux (c' :: subst, d :: instctx) l ctx
+ | [] -> subst
+ in aux (subst, []) inst (List.rev ctx)
+
+let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) pri =
+ let env = Global.env() in
+ let evars = ref Evd.empty in
+ let tclass, _ =
+ match bk with
+ | Implicit ->
+ Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *)
+ ~allow_partial:false (fun avoid (clname, (id, _, t)) ->
+ match clname with
+ | Some (cl, b) ->
+ let t =
+ if b then
+ let _k = class_info cl in
+ CHole (Util.dummy_loc, Some Evd.InternalHole)
+ else CHole (Util.dummy_loc, None)
+ in t, avoid
+ | None -> failwith ("new instance: under-applied typeclass"))
+ cl
+ | Explicit -> cl, Idset.empty
+ in
+ let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in
+ let k, cty, ctx', ctx, len, imps, subst =
+ let (env', ctx), imps = interp_context_evars evars env ctx in
+ let c', imps' = interp_type_evars_impls ~evdref:evars env' tclass in
+ let len = List.length ctx in
+ let imps = imps @ Impargs.lift_implicits len imps' in
+ let ctx', c = decompose_prod_assum c' in
+ let ctx'' = ctx' @ ctx in
+ let cl, args = Typeclasses.dest_class_app (push_rel_context ctx'' env) c in
+ let _, args =
+ List.fold_right (fun (na, b, t) (args, args') ->
+ match b with
+ | None -> (List.tl args, List.hd args :: args')
+ | Some b -> (args, substl args' b :: args'))
+ (snd cl.cl_context) (args, [])
+ in
+ cl, c', ctx', ctx, len, imps, args
+ in
+ let id =
+ match snd instid with
+ | Name id ->
+ let sp = Lib.make_path id in
+ if Nametab.exists_cci sp then
+ errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists");
+ id
+ | Anonymous ->
+ let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in
+ Namegen.next_global_ident_away i (Termops.ids_of_context env)
+ in
+ let env' = push_rel_context ctx env in
+ evars := Evarutil.nf_evar_map !evars;
+ evars := resolve_typeclasses ~onlyargs:false ~fail:true env !evars;
+ let sigma = !evars in
+ let subst = List.map (Evarutil.nf_evar sigma) subst in
+ let props =
+ match props with
+ | CRecord (loc, _, fs) ->
+ 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
+ in
+ let subst =
+ match props with
+ | Inr term ->
+ let c = interp_casted_constr_evars evars env' term cty in
+ Inr (c, subst)
+ | Inl props ->
+ let get_id =
+ function
+ | Ident id' -> id'
+ | _ -> errorlabstrm "new_instance" (Pp.str "Only local structures are handled")
+ in
+ let props, rest =
+ List.fold_left
+ (fun (props, rest) (id,b,_) ->
+ if b = None then
+ try
+ 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);
+ c :: props, rest'
+ with Not_found ->
+ (CHole (Util.dummy_loc, None) :: props), rest
+ else props, rest)
+ ([], props) k.cl_props
+ in
+ if rest <> [] then
+ unbound_method env' k.cl_impl (get_id (fst (List.hd rest)))
+ else
+ Inl (type_ctx_instance evars (push_rel_context ctx' env') k.cl_props props subst)
+ in
+ evars := Evarutil.nf_evar_map !evars;
+ let term, termtype =
+ match subst with
+ | Inl subst ->
+ let subst = List.fold_left2
+ (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst')
+ [] subst (k.cl_props @ snd k.cl_context)
+ in
+ let app, ty_constr = instance_constructor k subst in
+ let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in
+ let term = Termops.it_mkLambda_or_LetIn app (ctx' @ ctx) in
+ term, termtype
+ | Inr (def, subst) ->
+ let termtype = it_mkProd_or_LetIn cty ctx in
+ let term = Termops.it_mkLambda_or_LetIn def ctx in
+ term, termtype
+ in
+ let termtype = Evarutil.nf_evar !evars termtype in
+ let term = Evarutil.nf_evar !evars term in
+ evars := undefined_evars !evars;
+ 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
+ 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
diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli
new file mode 100644
index 00000000..ee78ff68
--- /dev/null
+++ b/plugins/subtac/subtac_classes.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(*i*)
+open Names
+open Decl_kinds
+open Term
+open Sign
+open Evd
+open Environ
+open Nametab
+open Mod_subst
+open Topconstr
+open Util
+open Typeclasses
+open Implicit_quantifiers
+open Classes
+(*i*)
+
+val type_ctx_instance : Evd.evar_map ref ->
+ Environ.env ->
+ ('a * Term.constr option * Term.constr) list ->
+ Topconstr.constr_expr list ->
+ Term.constr list ->
+ Term.constr list
+
+val new_instance :
+ ?global:bool ->
+ local_binder list ->
+ typeclass_constraint ->
+ constr_expr ->
+ ?generalize:bool ->
+ int option ->
+ identifier * Subtac_obligations.progress
diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml
new file mode 100644
index 00000000..5337baca
--- /dev/null
+++ b/plugins/subtac/subtac_coercion.ml
@@ -0,0 +1,503 @@
+(* -*- compile-command: "make -C ../.. bin/coqtop.byte" -*- *)
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+(* $Id$ *)
+
+open Util
+open Names
+open Term
+open Reductionops
+open Environ
+open Typeops
+open Pretype_errors
+open Classops
+open Recordops
+open Evarutil
+open Evarconv
+open Retyping
+open Evd
+
+open Global
+open Subtac_utils
+open Coqlib
+open Printer
+open Subtac_errors
+open Eterm
+open Pp
+
+let pair_of_array a = (a.(0), a.(1))
+let make_name s = Name (id_of_string s)
+
+let rec disc_subset x =
+ match kind_of_term x with
+ | App (c, l) ->
+ (match kind_of_term c with
+ Ind i ->
+ let len = Array.length l in
+ let sig_ = Lazy.force sig_ in
+ if len = 2 && i = Term.destInd sig_.typ
+ then
+ let (a, b) = pair_of_array l in
+ Some (a, b)
+ else None
+ | _ -> None)
+ | _ -> None
+
+and disc_exist env x =
+ match kind_of_term x with
+ | App (c, l) ->
+ (match kind_of_term c with
+ Construct c ->
+ if c = Term.destConstruct (Lazy.force sig_).intro
+ then Some (l.(0), l.(1), l.(2), l.(3))
+ else None
+ | _ -> None)
+ | _ -> None
+
+module Coercion = struct
+
+ exception NoSubtacCoercion
+
+ let disc_proj_exist env x =
+ match kind_of_term x with
+ | App (c, l) ->
+ (if Term.eq_constr c (Lazy.force sig_).proj1
+ && Array.length l = 3
+ then disc_exist env l.(2)
+ else None)
+ | _ -> None
+
+
+ let sort_rel s1 s2 =
+ match s1, s2 with
+ Prop Pos, Prop Pos -> Prop Pos
+ | Prop Pos, Prop Null -> Prop Null
+ | Prop Null, Prop Null -> Prop Null
+ | Prop Null, Prop Pos -> Prop Pos
+ | Type _, Prop Pos -> Prop Pos
+ | Type _, Prop Null -> Prop Null
+ | _, Type _ -> s2
+
+ let hnf env isevars c = whd_betadeltaiota env ( !isevars) c
+
+ let lift_args n sign =
+ let rec liftrec k = function
+ | t::sign -> liftn n k t :: (liftrec (k-1) sign)
+ | [] -> []
+ in
+ liftrec (List.length sign) sign
+
+ let rec mu env isevars t =
+ let isevars = ref isevars in
+ let rec aux v =
+ let v = hnf env isevars v in
+ match disc_subset v with
+ Some (u, p) ->
+ let f, ct = aux u in
+ (Some (fun x ->
+ app_opt f (mkApp ((Lazy.force sig_).proj1,
+ [| u; p; x |]))),
+ ct)
+ | None -> (None, v)
+ in aux t
+
+ and coerce loc env isevars (x : Term.constr) (y : Term.constr)
+ : (Term.constr -> Term.constr) option
+ =
+ let x = nf_evar ( !isevars) x and y = nf_evar ( !isevars) y in
+ let rec coerce_unify env x y =
+ let x = hnf env isevars x and y = hnf env isevars y in
+ try
+ isevars := the_conv_x_leq env x y !isevars;
+ None
+ with Reduction.NotConvertible -> coerce' env x y
+ and coerce' env x y : (Term.constr -> Term.constr) option =
+ let subco () = subset_coerce env isevars x y in
+ let dest_prod c =
+ match Reductionops.splay_prod_n env ( !isevars) 1 c with
+ | [(na,b,t)], c -> (na,t), c
+ | _ -> raise NoSubtacCoercion
+ in
+ let rec coerce_application typ typ' c c' l l' =
+ let len = Array.length l in
+ let rec aux tele typ typ' i co =
+ if i < len then
+ let hdx = l.(i) and hdy = l'.(i) in
+ try isevars := the_conv_x_leq env hdx hdy !isevars;
+ let (n, eqT), restT = dest_prod typ in
+ let (n', eqT'), restT' = dest_prod typ' in
+ aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co
+ with Reduction.NotConvertible ->
+ let (n, eqT), restT = dest_prod typ in
+ let (n', eqT'), restT' = dest_prod typ' in
+ let _ =
+ try isevars := the_conv_x_leq env eqT eqT' !isevars
+ with Reduction.NotConvertible -> raise NoSubtacCoercion
+ in
+ (* Disallow equalities on arities *)
+ if Reduction.is_arity env eqT then raise NoSubtacCoercion;
+ 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 pred = mkLambda (n, eqT, applistc (lift 1 c) args) in
+ let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in
+ let evar = make_existential loc env isevars eq in
+ let eq_app x = mkApp (Lazy.force eq_rect,
+ [| eqT; hdx; pred; x; hdy; evar|]) in
+ aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x))
+ else Some co
+ in
+ if isEvar c || isEvar c' then
+ (* Second-order unification needed. *)
+ raise NoSubtacCoercion;
+ aux [] typ typ' 0 (fun x -> x)
+ in
+ match (kind_of_term x, kind_of_term y) with
+ | Sort s, Sort s' ->
+ (match s, s' with
+ Prop x, Prop y when x = y -> None
+ | Prop _, Type _ -> None
+ | Type x, Type y when x = y -> None (* false *)
+ | _ -> subco ())
+ | Prod (name, a, b), Prod (name', a', b') ->
+ let name' = Name (Namegen.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in
+ let env' = push_rel (name', None, a') env in
+ let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
+ (* env, x : a' |- c1 : lift 1 a' > lift 1 a *)
+ let coec1 = app_opt c1 (mkRel 1) in
+ (* env, x : a' |- c1[x] : lift 1 a *)
+ let c2 = coerce_unify env' (subst1 coec1 (liftn 1 2 b)) b' in
+ (* env, x : a' |- c2 : b[c1[x]/x]] > b' *)
+ (match c1, c2 with
+ | None, None -> None
+ | _, _ ->
+ Some
+ (fun f ->
+ mkLambda (name', a',
+ app_opt c2
+ (mkApp (Term.lift 1 f, [| coec1 |])))))
+
+ | App (c, l), App (c', l') ->
+ (match kind_of_term c, kind_of_term c' with
+ Ind i, Ind i' -> (* Inductive types *)
+ let len = Array.length l in
+ let existS = Lazy.force existS in
+ let prod = Lazy.force prod in
+ (* Sigma types *)
+ if len = Array.length l' && len = 2 && i = i'
+ && (i = Term.destInd existS.typ || i = Term.destInd prod.typ)
+ then
+ if i = Term.destInd existS.typ
+ then
+ begin
+ let (a, pb), (a', pb') =
+ pair_of_array l, pair_of_array l'
+ in
+ let c1 = coerce_unify env a a' in
+ let rec remove_head a c =
+ match kind_of_term c with
+ | 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
+ isevars := evs;
+ let (n, dom, rng) = destLambda t in
+ let (domk, args) = destEvar dom in
+ isevars := define domk a !isevars;
+ t, rng
+ | _ -> raise NoSubtacCoercion
+ in
+ let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in
+ let env' = push_rel (make_name "x", None, a) env in
+ let c2 = coerce_unify env' b b' in
+ match c1, c2 with
+ None, None ->
+ None
+ | _, _ ->
+ Some
+ (fun x ->
+ let x, y =
+ app_opt c1 (mkApp (existS.proj1,
+ [| a; pb; x |])),
+ app_opt c2 (mkApp (existS.proj2,
+ [| a; pb; x |]))
+ in
+ mkApp (existS.intro, [| a'; pb'; x ; y |]))
+ end
+ else
+ begin
+ let (a, b), (a', b') =
+ pair_of_array l, pair_of_array l'
+ in
+ let c1 = coerce_unify env a a' in
+ let c2 = coerce_unify env b b' in
+ match c1, c2 with
+ None, None -> None
+ | _, _ ->
+ Some
+ (fun x ->
+ let x, y =
+ app_opt c1 (mkApp (prod.proj1,
+ [| a; b; x |])),
+ app_opt c2 (mkApp (prod.proj2,
+ [| a; b; x |]))
+ in
+ mkApp (prod.intro, [| a'; b'; x ; y |]))
+ end
+ else
+ if i = i' && len = Array.length l' then
+ let evm = !isevars in
+ (try subco ()
+ with NoSubtacCoercion ->
+ let typ = Typing.type_of env evm c in
+ let typ' = Typing.type_of env evm c' in
+ (* if not (is_arity env evm typ) then *)
+ coerce_application typ typ' c c' l l')
+ (* else subco () *)
+ else
+ subco ()
+ | x, y when x = y ->
+ if Array.length l = Array.length l' then
+ let evm = !isevars in
+ let lam_type = Typing.type_of env evm c in
+ let lam_type' = Typing.type_of env evm c' in
+(* if not (is_arity env evm lam_type) then ( *)
+ coerce_application lam_type lam_type' c c' l l'
+(* ) else subco () *)
+ else subco ()
+ | _ -> subco ())
+ | _, _ -> subco ()
+
+ and subset_coerce env isevars x y =
+ match disc_subset x with
+ Some (u, p) ->
+ let c = coerce_unify env u y in
+ let f x =
+ app_opt c (mkApp ((Lazy.force sig_).proj1,
+ [| u; p; x |]))
+ in Some f
+ | None ->
+ match disc_subset y with
+ Some (u, p) ->
+ let c = coerce_unify env x u in
+ Some
+ (fun x ->
+ let cx = app_opt c x in
+ let evar = make_existential loc env isevars (mkApp (p, [| cx |]))
+ in
+ (mkApp
+ ((Lazy.force sig_).intro,
+ [| u; p; cx; evar |])))
+ | None ->
+ raise NoSubtacCoercion
+ (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars;
+ None*)
+ in coerce_unify env x y
+
+ let coerce_itf loc env isevars v t c1 =
+ let evars = ref isevars in
+ let coercion = coerce loc env evars t c1 in
+ !evars, Option.map (app_opt coercion) v
+
+ (* Taken from pretyping/coercion.ml *)
+
+ (* Typing operations dealing with coercions *)
+
+ (* Here, funj is a coercion therefore already typed in global context *)
+ let apply_coercion_args env argl funj =
+ let rec apply_rec acc typ = function
+ | [] -> { uj_val = applist (j_val funj,argl);
+ uj_type = typ }
+ | h::restl ->
+ (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
+ match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
+ | Prod (_,c1,c2) ->
+ (* Typage garanti par l'appel à app_coercion*)
+ apply_rec (h::acc) (subst1 h c2) restl
+ | _ -> anomaly "apply_coercion_args"
+ in
+ apply_rec [] funj.uj_type argl
+
+ (* appliquer le chemin de coercions de patterns p *)
+ exception NoCoercion
+
+ 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))
+ pat p
+
+ (* raise Not_found if no coercion found *)
+ let inh_pattern_coerce_to loc pat ind1 ind2 =
+ let p = lookup_pattern_path_between (ind1,ind2) in
+ apply_pattern_coercion loc pat p
+
+ (* appliquer le chemin de coercions p à hj *)
+
+ let apply_coercion env sigma p hj typ_cl =
+ try
+ fst (List.fold_left
+ (fun (ja,typ_cl) i ->
+ let fv,isid = coercion_value i in
+ let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in
+ let jres = apply_coercion_args env argl fv in
+ (if isid then
+ { uj_val = ja.uj_val; uj_type = jres.uj_type }
+ else
+ jres),
+ jres.uj_type)
+ (hj,typ_cl) p)
+ with _ -> anomaly "apply_coercion"
+
+ let inh_app_fun env isevars j =
+ let t = whd_betadeltaiota env ( isevars) j.uj_type in
+ match kind_of_term t with
+ | Prod (_,_,_) -> (isevars,j)
+ | Evar ev when not (is_defined_evar isevars ev) ->
+ let (isevars',t) = define_evar_as_product isevars ev in
+ (isevars',{ uj_val = j.uj_val; uj_type = t })
+ | _ ->
+ (try
+ let t,p =
+ lookup_path_to_fun_from env ( isevars) j.uj_type in
+ (isevars,apply_coercion env ( isevars) p j t)
+ with Not_found ->
+ try
+ let coercef, t = mu env isevars t in
+ (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t })
+ with NoSubtacCoercion | NoCoercion ->
+ (isevars,j))
+
+ let inh_tosort_force loc env isevars j =
+ try
+ let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in
+ let j1 = apply_coercion env ( isevars) p j t in
+ (isevars,type_judgment env (j_nf_evar ( isevars) j1))
+ with Not_found ->
+ error_not_a_type_loc loc env ( isevars) j
+
+ let inh_coerce_to_sort loc env isevars j =
+ let typ = whd_betadeltaiota env ( isevars) j.uj_type in
+ match kind_of_term typ with
+ | Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
+ | Evar ev when not (is_defined_evar isevars ev) ->
+ let (isevars',s) = define_evar_as_sort isevars ev in
+ (isevars',{ utj_val = j.uj_val; utj_type = s })
+ | _ ->
+ inh_tosort_force loc env isevars j
+
+ let inh_coerce_to_base loc env isevars j =
+ let typ = whd_betadeltaiota env ( isevars) j.uj_type in
+ let ct, typ' = mu env isevars typ in
+ isevars, { uj_val = app_opt ct j.uj_val;
+ uj_type = typ' }
+
+ let inh_coerce_to_prod loc env isevars t =
+ let typ = whd_betadeltaiota env ( isevars) (snd t) in
+ let _, typ' = mu env isevars typ in
+ isevars, (fst t, typ')
+
+ let inh_coerce_to_fail env evd rigidonly v t c1 =
+ if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t)
+ then
+ raise NoCoercion
+ else
+ let v', t' =
+ try
+ let t2,t1,p = lookup_path_between env ( evd) (t,c1) in
+ match v with
+ Some v ->
+ 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
+ with Not_found -> raise NoCoercion
+ in
+ try (the_conv_x_leq env t' c1 evd, v')
+ with Reduction.NotConvertible -> raise NoCoercion
+
+
+ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 =
+ try (the_conv_x_leq env t c1 evd, v)
+ with Reduction.NotConvertible ->
+ 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)
+ with
+ | Prod (name,t1,t2), Prod (_,u1,u2) ->
+ (* Conversion did not work, we may succeed with a coercion. *)
+ (* We eta-expand (hence possibly modifying the original term!) *)
+ (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *)
+ (* has type forall (x:u1), u2 (with v' recursively obtained) *)
+ let name = match name with
+ | Anonymous -> Name (id_of_string "x")
+ | _ -> name in
+ let env1 = push_rel (name,None,u1) env in
+ let (evd', v1) =
+ inh_conv_coerce_to_fail loc env1 evd rigidonly
+ (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in
+ let v1 = Option.get v1 in
+ let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in
+ let t2 = Termops.subst_term v1 t2 in
+ let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in
+ (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2')
+ | _ -> raise NoCoercion
+
+ (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
+ let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) =
+ match n with
+ None ->
+ let (evd', val') =
+ try
+ inh_conv_coerce_to_fail loc env evd rigidonly
+ (Some (nf_evar evd cj.uj_val))
+ (nf_evar evd cj.uj_type) (nf_evar evd t)
+ with NoCoercion ->
+ let sigma = evd in
+ try
+ coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t
+ with NoSubtacCoercion ->
+ error_actual_type_loc loc env sigma cj t
+ in
+ let val' = match val' with Some v -> v | None -> assert(false) in
+ (evd',{ uj_val = val'; uj_type = t })
+ | Some (init, cur) ->
+ (evd, cj)
+
+ let inh_conv_coerce_to = inh_conv_coerce_to_gen false
+ let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true
+
+ let inh_conv_coerces_to loc env isevars t ((abs, t') as _tycon) =
+ let nabsinit, nabs =
+ match abs with
+ None -> 0, 0
+ | Some (init, cur) -> init, cur
+ in
+ try
+ let rels, rng = Reductionops.splay_prod_n env ( isevars) nabs t in
+ (* The final range free variables must have been replaced by evars, we accept only that evars
+ in rng are applied to free vars. *)
+ if noccur_with_meta 1 (succ nabs) rng then (
+ let env', t, t' =
+ let env' = push_rel_context rels env in
+ env', rng, lift nabs t'
+ in
+ try
+ fst (try inh_conv_coerce_to_fail loc env' isevars false None t t'
+ with NoCoercion ->
+ coerce_itf loc env' isevars None t t')
+ with NoSubtacCoercion ->
+ let sigma = isevars in
+ error_cannot_coerce env' sigma (t, t'))
+ else isevars
+ with _ -> isevars
+end
diff --git a/plugins/subtac/subtac_coercion.mli b/plugins/subtac/subtac_coercion.mli
new file mode 100644
index 00000000..5678c10e
--- /dev/null
+++ b/plugins/subtac/subtac_coercion.mli
@@ -0,0 +1,4 @@
+open Term
+val disc_subset : types -> (types * types) option
+
+module Coercion : Coercion.S
diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml
new file mode 100644
index 00000000..f2747225
--- /dev/null
+++ b/plugins/subtac/subtac_command.ml
@@ -0,0 +1,534 @@
+open Closure
+open RedFlags
+open Declarations
+open Entries
+open Libobject
+open Pattern
+open Matching
+open Pp
+open Rawterm
+open Sign
+open Tacred
+open Util
+open Names
+open Nameops
+open Libnames
+open Nametab
+open Pfedit
+open Proof_type
+open Refiner
+open Tacmach
+open Tactic_debug
+open Topconstr
+open Term
+open Termops
+open Tacexpr
+open Safe_typing
+open Typing
+open Hiddentac
+open Genarg
+open Decl_kinds
+open Mod_subst
+open Printer
+open Inductiveops
+open Syntax_def
+open Environ
+open Tactics
+open Tacticals
+open Tacinterp
+open Vernacexpr
+open Notation
+open Evd
+open Evarutil
+
+module SPretyping = Subtac_pretyping.Pretyping
+open Subtac_utils
+open Pretyping
+open Subtac_obligations
+
+(*********************************************************************)
+(* Functions to parse and interpret constructions *)
+
+let evar_nf isevars c =
+ Evarutil.nf_evar !isevars c
+
+let interp_gen kind isevars env
+ ?(impls=([],[])) ?(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
+ evar_nf isevars c'
+
+let interp_constr isevars env c =
+ interp_gen (OfType None) isevars env c
+
+let interp_type_evars isevars env ?(impls=([],[])) c =
+ interp_gen IsType isevars env ~impls c
+
+let interp_casted_constr isevars env ?(impls=([],[])) c typ =
+ interp_gen (OfType (Some typ)) isevars env ~impls c
+
+let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ =
+ interp_gen (OfType (Some typ)) isevars env ~impls c
+
+let interp_open_constr isevars env c =
+ msgnl (str "Pretyping " ++ my_print_constr_expr c);
+ let c = Constrintern.intern_constr ( !isevars) env c in
+ let c' = SPretyping.understand_tcc_evars isevars env (OfType None) c in
+ evar_nf isevars c'
+
+let interp_constr_judgment isevars env c =
+ let j =
+ SPretyping.understand_judgment_tcc isevars env
+ (Constrintern.intern_constr ( !isevars) env c)
+ in
+ { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type }
+
+let locate_if_isevar loc na = function
+ | RHole _ ->
+ (try match na with
+ | Name id -> Reserve.find_reserved_type id
+ | Anonymous -> raise Not_found
+ with Not_found -> RHole (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)
+
+let interp_context_evars evdref env params =
+ let bl = Constrintern.intern_context false ( !evdref) 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 = SPretyping.understand_tcc_evars evdref env IsType t' in
+ let d = (na,None,t) in
+ let impls =
+ if k = Implicit then
+ let na = match na with Name n -> Some n | Anonymous -> None in
+ (ExplByPos (n, na), (true, true, true)) :: impls
+ else impls
+ in
+ (push_rel d env, d::params, succ n, impls)
+ | Some b ->
+ let c = SPretyping.understand_judgment_tcc evdref env b in
+ let d = (na, Some c.uj_val, c.uj_type) in
+ (push_rel d env,d::params, succ n, impls))
+ (env,[],1,[]) (List.rev bl)
+ in (env, par), impls
+
+(* try to find non recursive definitions *)
+
+let list_chop_hd i l = match list_chop i l with
+ | (l1,x::l2) -> (l1,x,l2)
+ | (x :: [], l2) -> ([], x, [])
+ | _ -> assert(false)
+
+let collect_non_rec env =
+ let rec searchrec lnonrec lnamerec ldefrec larrec nrec =
+ try
+ let i =
+ list_try_find_i
+ (fun i f ->
+ if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec
+ then i else failwith "try_find_i")
+ 0 lnamerec
+ in
+ let (lf1,f,lf2) = list_chop_hd i lnamerec in
+ let (ldef1,def,ldef2) = list_chop_hd i ldefrec in
+ let (lar1,ar,lar2) = list_chop_hd i larrec in
+ let newlnv =
+ try
+ match list_chop i nrec with
+ | (lnv1,_::lnv2) -> (lnv1@lnv2)
+ | _ -> [] (* nrec=[] for cofixpoints *)
+ with Failure "list_chop" -> []
+ in
+ searchrec ((f,def,ar)::lnonrec)
+ (lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv
+ with Failure "try_find_i" ->
+ (List.rev lnonrec,
+ (Array.of_list lnamerec, Array.of_list ldefrec,
+ Array.of_list larrec, Array.of_list nrec))
+ in
+ searchrec []
+
+let list_of_local_binders l =
+ let rec aux acc = function
+ Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl
+ | Topconstr.LocalRawAssum (nl, k, c) :: tl ->
+ aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl
+ | [] -> List.rev acc
+ in aux [] l
+
+let lift_binders k n l =
+ let rec aux n = function
+ | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl
+ | [] -> []
+ in aux n l
+
+let rec gen_rels = function
+ 0 -> []
+ | n -> mkRel n :: gen_rels (pred n)
+
+let split_args n rel = match list_chop ((List.length rel) - n) rel with
+ (l1, x :: l2) -> l1, x, l2
+ | _ -> assert(false)
+
+open Coqlib
+
+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_pp_info = { ind_nargs = 0; style = LetStyle }
+ }
+
+let telescope = function
+ | [] -> assert false
+ | [(n, None, t)] -> t, [n, Some (mkRel 1), t], mkRel 1
+ | (n, None, t) :: tl ->
+ let ty, tys, (k, constr) =
+ List.fold_left
+ (fun (ty, tys, (k, constr)) (n, b, t) ->
+ let pred = mkLambda (n, t, ty) in
+ let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in
+ let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in
+ (sigty, pred :: tys, (succ k, intro)))
+ (t, [], (2, mkRel 1)) tl
+ in
+ let (last, subst) = List.fold_right2
+ (fun pred (n, b, t) (prev, subst) ->
+ let proj1 = applistc (Lazy.force sigT).proj1 [t; pred; prev] in
+ let proj2 = applistc (Lazy.force sigT).proj2 [t; pred; prev] in
+ (lift 1 proj2, (n, Some proj1, t) :: subst))
+ (List.rev tys) tl (mkRel 1, [])
+ in ty, ((n, Some last, t) :: subst), constr
+
+ | _ -> raise (Invalid_argument "telescope")
+
+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 =
+ Coqlib.check_required_library ["Coq";"Program";"Wf"];
+ let sigma = Evd.empty in
+ let isevars = ref (Evd.create_evar_defs sigma) in
+ let env = Global.env() in
+ let _pr c = my_print_constr env c in
+ let _prr = Printer.pr_rel_context env in
+ let _prn = Printer.pr_named_context env in
+ let _pr_rel env = Printer.pr_rel_context env in
+ let (env', binders_rel), impls = interp_context_evars isevars env bl in
+ let len = List.length binders_rel in
+ let top_env = push_rel_context binders_rel env in
+ let top_arity = interp_type_evars isevars top_env arityc in
+ let full_arity = it_mkProd_or_LetIn top_arity binders_rel in
+ let argtyp, letbinders, make = telescope binders_rel in
+ let argname = id_of_string "recarg" in
+ let arg = (Name argname, None, argtyp) in
+ let binders = letbinders @ [arg] in
+ let binders_env = push_rel_context binders_rel env in
+ let rel = interp_constr isevars env r in
+ let relty = type_of env !isevars rel in
+ let relargty =
+ let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in
+ match ctx, kind_of_term ar with
+ | [(_, None, t); (_, None, u)], Sort (Prop Null)
+ when Reductionops.is_conv env !isevars t u -> t
+ | _, _ ->
+ user_err_loc (constr_loc r,
+ "Subtac_command.build_wellfounded",
+ my_print_constr env rel ++ str " is not an homogeneous binary relation.")
+ in
+ let measure = interp_casted_constr isevars binders_env measure relargty in
+ let wf_rel, wf_rel_fun, measure_fn =
+ let measure_body, measure =
+ it_mkLambda_or_LetIn measure letbinders,
+ it_mkLambda_or_LetIn measure binders
+ in
+ let comb = constr_of_global (Lazy.force measure_on_R_ref) in
+ let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in
+ let wf_rel_fun x y =
+ mkApp (rel, [| subst1 x measure_body;
+ subst1 y measure_body |])
+ in wf_rel, wf_rel_fun, measure
+ in
+ let wf_proof = mkApp (Lazy.force well_founded, [| argtyp ; wf_rel |]) in
+ let argid' = id_of_string (string_of_id argname ^ "'") in
+ let wfarg len = (Name argid', None,
+ mkSubset (Name argid') argtyp
+ (wf_rel_fun (mkRel 1) (mkRel (len + 1))))
+ in
+ let intern_bl = wfarg 1 :: [arg] in
+ let _intern_env = push_rel_context intern_bl env in
+ let proj = (Lazy.force sig_).Coqlib.proj1 in
+ let wfargpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel 3)) in
+ let projection = (* in wfarg :: arg :: before *)
+ mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |])
+ in
+ let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in
+ let intern_arity = substl [projection] top_arity_let in
+ (* substitute the projection of wfarg for something,
+ now intern_arity is in wfarg :: arg *)
+ let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
+ let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in
+ let curry_fun =
+ let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in
+ let arg = mkApp ((Lazy.force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in
+ let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in
+ let rcurry = mkApp (rel, [| measure; lift len measure |]) in
+ let lam = (Name (id_of_string "recproof"), None, rcurry) in
+ let body = it_mkLambda_or_LetIn app (lam :: binders_rel) in
+ let ty = it_mkProd_or_LetIn (lift 1 top_arity) (lam :: binders_rel) in
+ (Name recname, Some body, ty)
+ in
+ let fun_bl = intern_fun_binder :: [arg] in
+ let lift_lets = Termops.lift_rel_context 1 letbinders in
+ let intern_body =
+ let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in
+ let (r, l, impls, scopes) =
+ 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
+ let newimpls = Constrintern.set_internalization_env_params newimpls [] 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
+ let def =
+ mkApp (constr_of_global (Lazy.force fix_sub_ref),
+ [| argtyp ; wf_rel ;
+ make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ;
+ prop ; intern_body_lam |])
+ in
+ let _ = isevars := Evarutil.nf_evar_map !isevars in
+ let binders_rel = nf_evar_context !isevars binders_rel in
+ let binders = nf_evar_context !isevars binders in
+ let top_arity = Evarutil.nf_evar !isevars top_arity in
+ let hook, recname, typ =
+ if List.length binders_rel > 1 then
+ let name = add_suffix recname "_func" in
+ let hook l gr =
+ 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_type = Some ty;
+ const_entry_opaque = false;
+ const_entry_boxed = false}
+ in
+ let c = Declare.declare_constant recname (DefinitionEntry ce, IsDefinition Definition) in
+ let gr = ConstRef c in
+ if Impargs.is_implicit_args () || impls <> [] then
+ Impargs.declare_manual_implicits false gr impls
+ in
+ let typ = it_mkProd_or_LetIn top_arity binders in
+ hook, name, typ
+ else
+ let typ = it_mkProd_or_LetIn top_arity binders_rel in
+ let hook l gr =
+ if Impargs.is_implicit_args () || impls <> [] then
+ Impargs.declare_manual_implicits false gr impls
+ in hook, recname, typ
+ in
+ let fullcoqc = Evarutil.nf_evar !isevars def in
+ let fullctyp = Evarutil.nf_evar !isevars typ in
+ let evm = evars_of_term !isevars Evd.empty fullctyp in
+ let evm = evars_of_term !isevars evm fullcoqc in
+ let evm = non_instanciated_map env isevars evm in
+ let evars, _, evars_def, evars_typ =
+ Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp
+ in
+ Subtac_obligations.add_definition recname ~term:evars_def evars_typ evars ~hook
+
+let interp_fix_context evdref env fix =
+ interp_context_evars evdref env fix.Command.fix_binders
+
+let interp_fix_ccl evdref (env,_) fix =
+ interp_type_evars evdref env fix.Command.fix_type
+
+let interp_fix_body evdref env_rec impls (_,ctx) fix ccl =
+ let env = push_rel_context ctx env_rec in
+ let body = Option.map (fun c -> interp_casted_constr_evars evdref env ~impls c ccl) fix.Command.fix_body in
+ Option.map (fun c -> it_mkLambda_or_LetIn c ctx) body
+
+let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx
+
+let prepare_recursive_declaration fixnames fixtypes fixdefs =
+ let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in
+ let names = List.map (fun id -> Name id) fixnames in
+ (Array.of_list names, Array.of_list fixtypes, Array.of_list defs)
+
+let rel_index n ctx =
+ list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx))
+
+let rec unfold f b =
+ match f b with
+ | Some (x, b') -> x :: unfold f b'
+ | None -> []
+
+let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype =
+ match n with
+ | Some (loc, n) -> [rel_index n fixctx]
+ | None ->
+ (* If recursive argument was not given by user, we try all args.
+ An earlier approach was to look only for inductive arguments,
+ but doing it properly involves delta-reduction, and it finally
+ doesn't seem to worth the effort (except for huge mutual
+ fixpoints ?) *)
+ let len = List.length fixctx in
+ unfold (function x when x = len -> None
+ | n -> Some (n, succ n)) 0
+
+let push_named_context = List.fold_right push_named
+
+let check_evars env initial_sigma evd c =
+ let sigma = evd in
+ let c = nf_evar sigma c in
+ let rec proc_rec c =
+ match kind_of_term c with
+ | Evar (evk,args) ->
+ assert (Evd.mem sigma evk);
+ if not (Evd.mem initial_sigma evk) then
+ let (loc,k) = evar_source evk evd in
+ (match k with
+ | QuestionMark _
+ | ImplicitArg (_, _, false) -> ()
+ | _ ->
+ let evi = nf_evar_info sigma (Evd.find sigma evk) in
+ Pretype_errors.error_unsolvable_implicit loc env sigma evi k None)
+ | _ -> iter_constr proc_rec c
+ in proc_rec c
+
+let out_def = function
+ | Some def -> def
+ | None -> error "Program Fixpoint needs defined bodies."
+
+let interp_recursive fixkind l boxed =
+ let env = Global.env() in
+ let fixl, ntnl = List.split l in
+ let kind = fixkind <> IsCoFixpoint in
+ let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in
+
+ (* Interp arities allowing for unresolved types *)
+ let evdref = ref Evd.empty in
+ let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in
+ let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in
+ let fixtypes = List.map2 build_fix_type fixctxs fixccls in
+ let rec_sign =
+ List.fold_left2 (fun env' id t ->
+ let sort = Retyping.get_type_of env !evdref t in
+ let fixprot =
+ try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|])
+ with e -> t
+ in
+ (id,None,fixprot) :: env')
+ [] fixnames fixtypes
+ in
+ let env_rec = push_named_context rec_sign env in
+
+ (* Get interpretation metadatas *)
+ let impls = Constrintern.compute_full_internalization_env env
+ Constrintern.Recursive [] fixnames fixtypes fiximps
+ in
+ let notations = List.flatten ntnl in
+
+ (* Interp bodies with rollback because temp use of notations/implicit *)
+ let fixdefs =
+ States.with_state_protection (fun () ->
+ List.iter (Metasyntax.set_notation_for_interpretation impls) notations;
+ list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
+ () in
+
+ let fixdefs = List.map out_def fixdefs in
+
+ (* Instantiate evars and check all are resolved *)
+ let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in
+ let evd = Typeclasses.resolve_typeclasses
+ ~onlyargs:true ~split:true ~fail:false env_rec evd
+ in
+ let evd = Evarutil.nf_evar_map evd in
+ let fixdefs = List.map (nf_evar evd) fixdefs in
+ let fixtypes = List.map (nf_evar evd) fixtypes in
+ let rec_sign = nf_named_context_evar evd rec_sign in
+
+ let recdefs = List.length rec_sign in
+ List.iter (check_evars env_rec Evd.empty evd) fixdefs;
+ List.iter (check_evars env Evd.empty evd) fixtypes;
+ Command.check_mutuality env kind (List.combine fixnames fixdefs);
+
+ (* Russell-specific code *)
+
+ (* Get the interesting evars, those that were not instanciated *)
+ let isevars = Evd.undefined_evars evd in
+ let evm = isevars in
+ (* Solve remaining evars *)
+ let rec collect_evars id def typ imps =
+ (* Generalize by the recursive prototypes *)
+ let def =
+ Termops.it_mkNamedLambda_or_LetIn def rec_sign
+ and typ =
+ Termops.it_mkNamedProd_or_LetIn typ rec_sign
+ in
+ let evm' = Subtac_utils.evars_of_term evm Evd.empty def in
+ let evm' = Subtac_utils.evars_of_term evm evm' typ in
+ let evars, _, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in
+ (id, def, typ, imps, evars)
+ in
+ let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in
+ (match fixkind with
+ | IsFixpoint wfl ->
+ let possible_indexes =
+ list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in
+ let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames),
+ Array.of_list fixtypes,
+ Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs)
+ in
+ let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
+ list_iter_i (fun i _ -> Inductive.check_fix env ((indexes,i),fixdecls)) l
+ | IsCoFixpoint -> ());
+ Subtac_obligations.add_mutual_definitions defs notations fixkind
+
+let out_n = function
+ Some n -> n
+ | None -> raise Not_found
+
+let build_recursive l b =
+ let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in
+ match g, l with
+ [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
+ ignore(build_wellfounded (id, n, bl, typ, out_def def) r
+ (match n with Some n -> mkIdentC (snd n) | None ->
+ errorlabstrm "Subtac_command.build_recursive"
+ (str "Recursive argument required for well-founded fixpoints"))
+ ntn false)
+
+ | [(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)
+
+ | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g ->
+ let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) ->
+ ({Command.fix_name = id; Command.fix_binders = bl;
+ Command.fix_body = def; Command.fix_type = typ},ntn)) l
+ in interp_recursive (IsFixpoint g) fixl b
+ | _, _ ->
+ errorlabstrm "Subtac_command.build_recursive"
+ (str "Well-founded fixpoints not allowed in mutually recursive blocks")
+
+let build_corecursive l b =
+ let fixl = List.map (fun (((_,id),bl,typ,def),ntn) ->
+ ({Command.fix_name = id; Command.fix_binders = bl;
+ Command.fix_body = def; Command.fix_type = typ},ntn))
+ l in
+ interp_recursive IsCoFixpoint fixl b
diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli
new file mode 100644
index 00000000..304aa139
--- /dev/null
+++ b/plugins/subtac/subtac_command.mli
@@ -0,0 +1,60 @@
+open Pretyping
+open Evd
+open Environ
+open Term
+open Topconstr
+open Names
+open Libnames
+open Pp
+open Vernacexpr
+open Constrintern
+
+val interp_gen :
+ typing_constraint ->
+ evar_map ref ->
+ env ->
+ ?impls:full_internalization_env ->
+ ?allow_patvar:bool ->
+ ?ltacvars:ltac_sign ->
+ constr_expr -> constr
+val interp_constr :
+ evar_map ref ->
+ env -> constr_expr -> constr
+val interp_type_evars :
+ evar_map ref ->
+ env ->
+ ?impls:full_internalization_env ->
+ constr_expr -> constr
+val interp_casted_constr_evars :
+ evar_map ref ->
+ env ->
+ ?impls:full_internalization_env ->
+ constr_expr -> types -> constr
+val interp_open_constr :
+ evar_map ref -> env -> constr_expr -> constr
+val interp_constr_judgment :
+ evar_map ref ->
+ env ->
+ constr_expr -> unsafe_judgment
+val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
+
+val interp_binder : Evd.evar_map ref ->
+ Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr
+
+
+val telescope :
+ (Names.name * 'a option * Term.types) list ->
+ Term.types * (Names.name * Term.types option * Term.types) list *
+ Term.constr
+
+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
+
+val build_recursive :
+ (fixpoint_expr * decl_notation list) list -> bool -> unit
+
+val build_corecursive :
+ (cofixpoint_expr * decl_notation list) list -> bool -> unit
diff --git a/plugins/subtac/subtac_errors.ml b/plugins/subtac/subtac_errors.ml
new file mode 100644
index 00000000..067da150
--- /dev/null
+++ b/plugins/subtac/subtac_errors.ml
@@ -0,0 +1,24 @@
+open Util
+open Pp
+open Printer
+
+type term_pp = Pp.std_ppcmds
+
+type subtyping_error =
+ | UncoercibleInferType of loc * term_pp * term_pp
+ | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp
+ | UncoercibleRewrite of term_pp * term_pp
+
+type typing_error =
+ | NonFunctionalApp of loc * term_pp * term_pp * term_pp
+ | NonConvertible of loc * term_pp * term_pp
+ | NonSigma of loc * term_pp
+ | IllSorted of loc * term_pp
+
+exception Subtyping_error of subtyping_error
+exception Typing_error of typing_error
+
+exception Debug_msg of string
+
+let typing_error e = raise (Typing_error e)
+let subtyping_error e = raise (Subtyping_error e)
diff --git a/plugins/subtac/subtac_errors.mli b/plugins/subtac/subtac_errors.mli
new file mode 100644
index 00000000..8d75b9c0
--- /dev/null
+++ b/plugins/subtac/subtac_errors.mli
@@ -0,0 +1,15 @@
+type term_pp = Pp.std_ppcmds
+type subtyping_error =
+ UncoercibleInferType of Util.loc * term_pp * term_pp
+ | UncoercibleInferTerm of Util.loc * term_pp * term_pp * term_pp * term_pp
+ | UncoercibleRewrite of term_pp * term_pp
+type typing_error =
+ NonFunctionalApp of Util.loc * term_pp * term_pp * term_pp
+ | NonConvertible of Util.loc * term_pp * term_pp
+ | NonSigma of Util.loc * term_pp
+ | IllSorted of Util.loc * term_pp
+exception Subtyping_error of subtyping_error
+exception Typing_error of typing_error
+exception Debug_msg of string
+val typing_error : typing_error -> 'a
+val subtyping_error : subtyping_error -> 'a
diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml
new file mode 100644
index 00000000..2836bc73
--- /dev/null
+++ b/plugins/subtac/subtac_obligations.ml
@@ -0,0 +1,652 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+open Printf
+open Pp
+open Subtac_utils
+open Command
+open Environ
+
+open Term
+open Names
+open Libnames
+open Summary
+open Libobject
+open Entries
+open Decl_kinds
+open Util
+open Evd
+open Declare
+open Proof_type
+
+let ppwarn cmd = Pp.warn (str"Program:" ++ cmd)
+let pperror cmd = Util.errorlabstrm "Program" cmd
+let error s = pperror (str s)
+
+let reduce =
+ Reductionops.clos_norm_flags Closure.betaiotazeta (Global.env ()) Evd.empty
+
+exception NoObligations of identifier option
+
+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 * loc * obligation_definition_status * Intset.t
+ * tactic option) array
+
+type obligation =
+ { obl_name : identifier;
+ obl_type : types;
+ obl_location : loc;
+ obl_body : constr option;
+ obl_status : obligation_definition_status;
+ obl_deps : Intset.t;
+ obl_tac : tactic option;
+ }
+
+type obligations = (obligation array * int)
+
+type fixpoint_kind =
+ | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
+ | IsCoFixpoint
+
+type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
+
+type program_info = {
+ prg_name: identifier;
+ prg_body: constr;
+ prg_type: constr;
+ prg_obligations: obligations;
+ prg_deps : identifier list;
+ prg_fixkind : fixpoint_kind option ;
+ prg_implicits : (Topconstr.explicitation * (bool * bool * bool)) list;
+ prg_notations : notations ;
+ prg_kind : definition_kind;
+ prg_hook : Tacexpr.declaration_hook;
+}
+
+let assumption_message id =
+ Flags.if_verbose message ((string_of_id id) ^ " is assumed")
+
+let default_tactic : Proof_type.tactic ref = ref Refiner.tclIDTAC
+let default_tactic_expr : Tacexpr.glob_tactic_expr ref = ref (Tacexpr.TacId [])
+
+let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t
+
+(* true = All transparent, false = Opaque if possible *)
+let proofs_transparency = ref true
+
+let set_proofs_transparency = (:=) proofs_transparency
+let get_proofs_transparency () = !proofs_transparency
+
+open Goptions
+
+let _ =
+ declare_bool_option
+ { optsync = true;
+ optname = "transparency of Program obligations";
+ optkey = ["Transparent";"Obligations"];
+ optread = get_proofs_transparency;
+ optwrite = set_proofs_transparency; }
+
+let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type
+
+let get_obligation_body expand obl =
+ let c = Option.get obl.obl_body in
+ if expand && obl.obl_status = Expand then
+ match kind_of_term c with
+ | Const c -> constant_value (Global.env ()) c
+ | _ -> c
+ else c
+
+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_deps_obl obls obl =
+ let t' = subst_deps true obls obl.obl_deps obl.obl_type in
+ { obl with obl_type = t' }
+
+module ProgMap = Map.Make(struct type t = identifier let compare = compare end)
+
+let map_replace k v m = ProgMap.add k v (ProgMap.remove k m)
+
+let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m []
+
+let map_cardinal m =
+ let i = ref 0 in
+ ProgMap.iter (fun _ _ -> incr i) m;
+ !i
+
+exception Found of program_info
+
+let map_first m =
+ try
+ ProgMap.iter (fun _ v -> raise (Found v)) m;
+ assert(false)
+ with Found x -> x
+
+let from_prg : program_info ProgMap.t ref = ref ProgMap.empty
+
+let freeze () = !from_prg, !default_tactic_expr
+let unfreeze (v, t) = from_prg := v; set_default_tactic t
+let init () =
+ from_prg := ProgMap.empty; set_default_tactic (Tacexpr.TacId [])
+
+(** Beware: if this code is dynamically loaded via dynlink after the start
+ of Coq, then this [init] function will not be run by [Lib.init ()].
+ Luckily, here we can launch [init] at load-time. *)
+
+let _ = init ()
+
+let _ =
+ Summary.declare_summary "program-tcc-table"
+ { Summary.freeze_function = freeze;
+ Summary.unfreeze_function = unfreeze;
+ Summary.init_function = init }
+
+let progmap_union = ProgMap.fold ProgMap.add
+
+let cache (_, (local, tac)) =
+ set_default_tactic tac
+
+let load (_, (local, tac)) =
+ if not local then set_default_tactic tac
+
+let subst (s, (local, tac)) =
+ (local, Tacinterp.subst_tactic s tac)
+
+let (input,output) =
+ declare_object
+ { (default_object "Program state") with
+ cache_function = cache;
+ load_function = (fun _ -> load);
+ open_function = (fun _ -> load);
+ classify_function = (fun (local, tac) ->
+ 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));
+ if local then Dispose else Substitute (local, tac));
+ subst_function = subst}
+
+let update_state local =
+ Lib.add_anonymous_leaf (input (local, !default_tactic_expr))
+
+let set_default_tactic local t =
+ set_default_tactic t; update_state local
+
+open Evd
+
+let progmap_remove prg =
+ from_prg := ProgMap.remove prg.prg_name !from_prg
+
+let rec intset_to = function
+ -1 -> Intset.empty
+ | n -> Intset.add n (intset_to (pred n))
+
+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)
+
+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 ce =
+ { const_entry_body = body;
+ const_entry_type = Some typ;
+ const_entry_opaque = false;
+ const_entry_boxed = boxed}
+ in
+ (Command.get_declare_definition_hook ()) ce;
+ match local with
+ | Local when Lib.sections_are_opened () ->
+ let c =
+ SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in
+ let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in
+ print_message (Subtac_utils.definition_message prg.prg_name);
+ if Pfedit.refining () then
+ Flags.if_verbose msg_warning
+ (str"Local definition " ++ Nameops.pr_id prg.prg_name ++
+ str" is not visible from current goals");
+ progmap_remove prg;
+ VarRef prg.prg_name
+ | (Global|Local) ->
+ let c =
+ Declare.declare_constant
+ prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind))
+ in
+ let gr = ConstRef c in
+ if Impargs.is_implicit_args () || prg.prg_implicits <> [] then
+ Impargs.declare_manual_implicits false gr prg.prg_implicits;
+ print_message (Subtac_utils.definition_message prg.prg_name);
+ progmap_remove prg;
+ prg.prg_hook local gr;
+ gr
+
+open Pp
+open Ppconstr
+
+let rec lam_index n t acc =
+ match kind_of_term t with
+ | Lambda (na, _, b) ->
+ if na = Name n then acc
+ else lam_index n b (succ acc)
+ | _ -> raise Not_found
+
+let compute_possible_guardness_evidences (n,_) fixbody fixtype =
+ match n with
+ | Some (loc, n) -> [lam_index n fixbody 0]
+ | None ->
+ (* If recursive argument was not given by user, we try all args.
+ An earlier approach was to look only for inductive arguments,
+ but doing it properly involves delta-reduction, and it finally
+ doesn't seem to worth the effort (except for huge mutual
+ fixpoints ?) *)
+ let m = Term.nb_prod fixtype in
+ let ctx = fst (decompose_prod_n_assum m fixtype) in
+ list_map_i (fun i _ -> i) 0 ctx
+
+let declare_mutual_definition l =
+ let len = List.length l in
+ let first = List.hd l in
+ let fixdefs, fixtypes, fiximps =
+ list_split3
+ (List.map (fun x ->
+ let subs, typ = (subst_body true x) in
+ let term = snd (Reductionops.splay_lam_n (Global.env ()) Evd.empty len subs) in
+ let typ = snd (Reductionops.splay_prod_n (Global.env ()) Evd.empty len typ) in
+ reduce term, reduce typ, x.prg_implicits) l)
+ in
+(* let fixdefs = List.map reduce_fix fixdefs in *)
+ 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 fixnames = first.prg_deps in
+ let kind = if fixkind <> IsCoFixpoint then Fixpoint else CoFixpoint in
+ let indexes, fixdecls =
+ match fixkind with
+ | IsFixpoint wfl ->
+ let possible_indexes =
+ list_map3 compute_possible_guardness_evidences wfl fixdefs fixtypes in
+ let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in
+ Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l
+ | IsCoFixpoint ->
+ 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
+ (* Declare notations *)
+ List.iter Metasyntax.add_notation_interpretation first.prg_notations;
+ Declare.recursive_message (fixkind<>IsCoFixpoint) indexes fixnames;
+ let gr = List.hd kns in
+ let kn = match gr with ConstRef kn -> kn | _ -> assert false in
+ first.prg_hook local gr;
+ List.iter progmap_remove l; kn
+
+let declare_obligation prg obl body =
+ let body = reduce body in
+ let ty = reduce obl.obl_type in
+ match obl.obl_status with
+ | Expand -> { obl with obl_body = Some body }
+ | Define opaque ->
+ let opaque = if get_proofs_transparency () then false else opaque in
+ let ce =
+ { const_entry_body = body;
+ const_entry_type = Some ty;
+ const_entry_opaque = opaque;
+ const_entry_boxed = false}
+ in
+ let constant = Declare.declare_constant obl.obl_name
+ (DefinitionEntry ce,IsProof Property)
+ in
+ if not opaque then
+ Auto.add_hints false [string_of_id prg.prg_name]
+ (Auto.HintsUnfoldEntry [EvalConstRef constant]);
+ print_message (Subtac_utils.definition_message obl.obl_name);
+ { obl with obl_body = Some (mkConst constant) }
+
+let red = Reductionops.nf_betaiota Evd.empty
+
+let init_prog_info n b t deps fixkind notations obls impls kind hook =
+ let obls', b =
+ match b with
+ | None ->
+ assert(obls = [||]);
+ let n = Nameops.add_suffix n "_obligation" in
+ [| { obl_name = n; obl_body = None;
+ obl_location = dummy_loc; 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_location = l; obl_type = red t; obl_status = o;
+ obl_deps = d; obl_tac = tac })
+ obls, b
+ in
+ { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls');
+ prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ;
+ prg_implicits = impls; prg_kind = kind; prg_hook = hook; }
+
+let get_prog name =
+ let prg_infos = !from_prg in
+ match name with
+ Some n ->
+ (try ProgMap.find n prg_infos
+ with Not_found -> raise (NoObligations (Some n)))
+ | None ->
+ (let n = map_cardinal prg_infos in
+ match n with
+ 0 -> raise (NoObligations None)
+ | 1 -> map_first prg_infos
+ | _ -> error "More than one program with unsolved obligations")
+
+let get_prog_err n =
+ try get_prog n with NoObligations id -> pperror (explain_no_obligations id)
+
+let obligations_solved prg = (snd prg.prg_obligations) = 0
+
+let all_programs () =
+ ProgMap.fold (fun k p l -> p :: l) !from_prg []
+
+type progress =
+ | Remain of int
+ | Dependent
+ | Defined of global_reference
+
+let obligations_message rem =
+ if rem > 0 then
+ if rem = 1 then
+ Flags.if_verbose msgnl (int rem ++ str " obligation remaining")
+ else
+ Flags.if_verbose msgnl (int rem ++ str " obligations remaining")
+ else
+ Flags.if_verbose msgnl (str "No more obligations remaining")
+
+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;
+ obligations_message rem;
+ if rem > 0 then Remain rem
+ else (
+ match prg'.prg_deps with
+ | [] ->
+ let kn = declare_definition prg' in
+ progmap_remove prg';
+ Defined kn
+ | l ->
+ let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in
+ if List.for_all (fun x -> obligations_solved x) progs then
+ let kn = declare_mutual_definition progs in
+ Defined (ConstRef kn)
+ else Dependent)
+
+let is_defined obls x = obls.(x).obl_body <> None
+
+let deps_remaining obls deps =
+ Intset.fold
+ (fun x acc ->
+ if is_defined obls x then acc
+ else x :: acc)
+ deps []
+
+let has_dependencies obls n =
+ let res = ref false in
+ Array.iteri
+ (fun i obl ->
+ if i <> n && Intset.mem n obl.obl_deps then
+ res := true)
+ obls;
+ !res
+
+let kind_of_opacity o =
+ match o with
+ | Define false | Expand -> Subtac_utils.goal_kind
+ | _ -> Subtac_utils.goal_proof_kind
+
+let not_transp_msg =
+ str "Obligation should be transparent but was declared opaque." ++ spc () ++
+ str"Use 'Defined' instead."
+
+let warn_not_transp () = ppwarn not_transp_msg
+let error_not_transp () = pperror not_transp_msg
+
+let rec solve_obligation prg num tac =
+ let user_num = succ num in
+ let obls, rem = prg.prg_obligations in
+ let obl = obls.(num) in
+ if obl.obl_body <> None then
+ pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.")
+ else
+ match deps_remaining obls obl.obl_deps with
+ | [] ->
+ let obl = subst_deps_obl obls obl in
+ Lemmas.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type
+ (fun strength gr ->
+ let cst = match gr with ConstRef cst -> cst | _ -> assert false in
+ let obl =
+ let transparent = evaluable_constant cst (Global.env ()) in
+ let body =
+ match obl.obl_status with
+ | Expand ->
+ if not transparent then error_not_transp ()
+ else constant_value (Global.env ()) cst
+ | Define opaque ->
+ if not opaque && not transparent then error_not_transp ()
+ else Libnames.constr_of_global gr
+ in
+ if transparent then
+ Auto.add_hints true [string_of_id prg.prg_name]
+ (Auto.HintsUnfoldEntry [EvalConstRef cst]);
+ { obl with obl_body = Some body }
+ in
+ 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)
+ in
+ match res with
+ | Remain n when n > 0 ->
+ if has_dependencies obls num then
+ ignore(auto_solve_obligations (Some prg.prg_name) None)
+ | _ -> ());
+ trace (str "Started obligation " ++ int user_num ++ str " proof: " ++
+ Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
+ Pfedit.by !default_tactic;
+ Option.iter (fun tac -> Pfedit.set_end_tac (Tacinterp.interp tac)) tac;
+ Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
+ | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) "
+ ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l))
+
+and subtac_obligation (user_num, name, typ) tac =
+ let num = pred user_num in
+ let prg = get_prog_err name in
+ let obls, rem = prg.prg_obligations in
+ if num < Array.length obls then
+ let obl = obls.(num) in
+ match obl.obl_body with
+ None -> solve_obligation prg num tac
+ | Some r -> error "Obligation already solved"
+ else error (sprintf "Unknown obligation number %i" (succ num))
+
+
+and solve_obligation_by_tac prg obls i tac =
+ let obl = obls.(i) in
+ match obl.obl_body with
+ | Some _ -> false
+ | None ->
+ try
+ if deps_remaining obls obl.obl_deps = [] then
+ let obl = subst_deps_obl obls obl in
+ let tac =
+ match tac with
+ | Some t -> t
+ | None ->
+ match obl.obl_tac with
+ | Some t -> t
+ | None -> !default_tactic
+ in
+ let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
+ obls.(i) <- declare_obligation prg obl t;
+ true
+ else false
+ with
+ | Stdpp.Exc_located(_, Proof_type.LtacLocated (_, Refiner.FailError (_, s)))
+ | Stdpp.Exc_located(_, Refiner.FailError (_, s))
+ | Refiner.FailError (_, s) ->
+ user_err_loc (obl.obl_location, "solve_obligation", Lazy.force s)
+ | e -> false
+
+and solve_prg_obligations prg tac =
+ let obls, rem = prg.prg_obligations in
+ let rem = ref rem in
+ let obls' = Array.copy obls in
+ let _ =
+ Array.iteri (fun i x ->
+ if solve_obligation_by_tac prg obls' i tac then
+ decr rem)
+ obls'
+ in
+ update_obls prg obls' !rem
+
+and solve_obligations n tac =
+ let prg = get_prog_err n in
+ solve_prg_obligations prg tac
+
+and solve_all_obligations tac =
+ ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg
+
+and try_solve_obligation n prg tac =
+ let prg = get_prog prg in
+ let obls, rem = prg.prg_obligations in
+ let obls' = Array.copy obls in
+ if solve_obligation_by_tac prg obls' n tac then
+ ignore(update_obls prg obls' (pred rem));
+
+and try_solve_obligations n tac =
+ try ignore (solve_obligations n tac) with NoObligations _ -> ()
+
+and auto_solve_obligations n tac : progress =
+ Flags.if_verbose msgnl (str "Solving obligations automatically...");
+ try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent
+
+open Pp
+let show_obligations_of_prg ?(msg=true) prg =
+ let n = prg.prg_name in
+ let obls, rem = prg.prg_obligations in
+ let showed = ref 5 in
+ if msg then msgnl (int rem ++ str " obligation(s) remaining: ");
+ Array.iteri (fun i x ->
+ match x.obl_body with
+ | None ->
+ if !showed > 0 then (
+ decr showed;
+ msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++
+ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++
+ hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ())))
+ | Some _ -> ())
+ obls
+
+let show_obligations ?(msg=true) n =
+ let progs = match n with
+ | None -> all_programs ()
+ | Some n ->
+ try [ProgMap.find n !from_prg]
+ with Not_found -> raise (NoObligations (Some n))
+ in List.iter (show_obligations_of_prg ~msg) progs
+
+let show_term n =
+ let prg = get_prog_err n in
+ let n = prg.prg_name in
+ msgnl (str (string_of_id n) ++ spc () ++ str":" ++ spc () ++
+ 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 ?(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 hook in
+ let obls,_ = prg.prg_obligations in
+ if Array.length obls = 0 then (
+ Flags.if_verbose ppnl (str ".");
+ let cst = declare_definition prg in
+ Defined cst)
+ 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;
+ 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) ?(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 hook in
+ ProgMap.add n prg acc)
+ !from_prg l
+ in
+ from_prg := upd;
+ let _defined =
+ List.fold_left (fun finished x ->
+ if finished then finished
+ else
+ let res = auto_solve_obligations (Some x) tactic in
+ match res with
+ | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true
+ | _ -> false)
+ false deps
+ in ()
+
+let admit_obligations n =
+ let prg = get_prog_err n in
+ let obls, rem = prg.prg_obligations in
+ Array.iteri
+ (fun i x ->
+ match x.obl_body with
+ | None ->
+ let x = subst_deps_obl obls x in
+ let kn = Declare.declare_constant x.obl_name (ParameterEntry (x.obl_type,false),
+ IsAssumption Conjectural)
+ in
+ assumption_message x.obl_name;
+ obls.(i) <- { x with obl_body = Some (mkConst kn) }
+ | Some _ -> ())
+ obls;
+ ignore(update_obls prg obls 0)
+
+exception Found of int
+
+let array_find f arr =
+ try Array.iteri (fun i x -> if f x then raise (Found i)) arr;
+ raise Not_found
+ with Found i -> i
+
+let next_obligation n tac =
+ let prg = get_prog_err n in
+ let obls, rem = prg.prg_obligations in
+ let i =
+ try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls
+ with Not_found -> anomaly "Could not find a solvable obligation."
+ in solve_obligation prg i tac
+
+let default_tactic () = !default_tactic
+let default_tactic_expr () = !default_tactic_expr
diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli
new file mode 100644
index 00000000..1608c134
--- /dev/null
+++ b/plugins/subtac/subtac_obligations.mli
@@ -0,0 +1,69 @@
+open Names
+open Util
+open Libnames
+open Evd
+open Proof_type
+
+type obligation_info =
+ (identifier * Term.types * loc *
+ obligation_definition_status * Intset.t * tactic option) array
+ (* ident, type, location, (opaque or transparent, expand or define),
+ dependencies, tactic to solve it *)
+
+type progress = (* Resolution status of a program *)
+ | Remain of int (* n obligations remaining *)
+ | Dependent (* Dependent on other definitions *)
+ | Defined of global_reference (* Defined as id *)
+
+val set_default_tactic : bool -> Tacexpr.glob_tactic_expr -> unit
+val default_tactic : unit -> Proof_type.tactic
+val default_tactic_expr : unit -> Tacexpr.glob_tactic_expr
+
+val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *)
+val get_proofs_transparency : unit -> bool
+
+val add_definition : Names.identifier -> ?term:Term.constr -> Term.types ->
+ ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list ->
+ ?kind:Decl_kinds.definition_kind ->
+ ?tactic:Proof_type.tactic ->
+ ?hook:(Tacexpr.declaration_hook) -> obligation_info -> progress
+
+type notations = (Vernacexpr.lstring * Topconstr.constr_expr * Topconstr.scope_name option) list
+
+type fixpoint_kind =
+ | IsFixpoint of (identifier located option * Topconstr.recursion_order_expr) list
+ | IsCoFixpoint
+
+val add_mutual_definitions :
+ (Names.identifier * Term.constr * Term.types *
+ (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list ->
+ ?tactic:Proof_type.tactic ->
+ ?kind:Decl_kinds.definition_kind ->
+ ?hook:Tacexpr.declaration_hook ->
+ notations ->
+ fixpoint_kind -> unit
+
+val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option ->
+ Tacexpr.raw_tactic_expr option -> unit
+
+val next_obligation : Names.identifier option -> Tacexpr.raw_tactic_expr option -> unit
+
+val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress
+(* Number of remaining obligations to be solved for this program *)
+
+val solve_all_obligations : Proof_type.tactic option -> unit
+
+val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit
+
+val try_solve_obligations : Names.identifier option -> Proof_type.tactic option -> unit
+
+val show_obligations : ?msg:bool -> Names.identifier option -> unit
+
+val show_term : Names.identifier option -> unit
+
+val admit_obligations : Names.identifier option -> unit
+
+exception NoObligations of Names.identifier option
+
+val explain_no_obligations : Names.identifier option -> Pp.std_ppcmds
+
diff --git a/plugins/subtac/subtac_plugin.mllib b/plugins/subtac/subtac_plugin.mllib
new file mode 100644
index 00000000..a4b9d67e
--- /dev/null
+++ b/plugins/subtac/subtac_plugin.mllib
@@ -0,0 +1,13 @@
+Subtac_utils
+Eterm
+Subtac_errors
+Subtac_coercion
+Subtac_obligations
+Subtac_cases
+Subtac_pretyping_F
+Subtac_pretyping
+Subtac_command
+Subtac_classes
+Subtac
+G_subtac
+Subtac_plugin_mod
diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml
new file mode 100644
index 00000000..f1541f25
--- /dev/null
+++ b/plugins/subtac/subtac_pretyping.ml
@@ -0,0 +1,137 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Global
+open Pp
+open Util
+open Names
+open Sign
+open Evd
+open Term
+open Termops
+open Reductionops
+open Environ
+open Type_errors
+open Typeops
+open Libnames
+open Classops
+open List
+open Recordops
+open Evarutil
+open Pretype_errors
+open Rawterm
+open Evarconv
+open Pattern
+
+open Subtac_coercion
+open Subtac_utils
+open Coqlib
+open Printer
+open Subtac_errors
+open Eterm
+
+module Pretyping = Subtac_pretyping_F.SubtacPretyping_F(Subtac_coercion.Coercion)
+
+open Pretyping
+
+let _ = Pretyping.allow_anonymous_refs := true
+
+type recursion_info = {
+ arg_name: name;
+ arg_type: types; (* A *)
+ args_after : rel_context;
+ wf_relation: constr; (* R : A -> A -> Prop *)
+ wf_proof: constr; (* : well_founded R *)
+ f_type: types; (* f: A -> Set *)
+ f_fulltype: types; (* Type with argument and wf proof product first *)
+}
+
+let my_print_rec_info env t =
+ str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++
+ str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++
+ str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++
+ 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) ++ *)
+(* str " and tycon "++ my_print_tycon env tycon ++ *)
+(* str " in environment: " ++ my_print_env env); *)
+
+let merge_evms x y =
+ Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y
+
+let interp env isevars c tycon =
+ let j = pretype tycon env isevars ([],[]) c in
+ let _ = isevars := Evarutil.nf_evar_map !isevars in
+ let evd,_ = consider_remaining_unif_problems env !isevars in
+(* let unevd = undefined_evars evd in *)
+ let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:true ~fail:true env evd in
+ let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:false env unevd' in
+ let evm = unevd' in
+ isevars := unevd';
+ nf_evar evm j.uj_val, nf_evar evm j.uj_type
+
+let find_with_index x l =
+ let rec aux i = function
+ (y, _, _) as t :: tl -> if x = y then i, t else aux (succ i) tl
+ | [] -> raise Not_found
+ in aux 0 l
+
+open Vernacexpr
+
+let coqintern_constr evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_constr ( evd) env
+let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constrintern.intern_type ( evd) env
+
+let env_with_binders env isevars l =
+ let rec aux ((env, rels) as acc) = function
+ Topconstr.LocalRawDef ((loc, name), def) :: tl ->
+ let rawdef = coqintern_constr !isevars env def in
+ let coqdef, deftyp = interp env isevars rawdef empty_tycon in
+ let reldecl = (name, Some coqdef, deftyp) in
+ aux (push_rel reldecl env, reldecl :: rels) tl
+ | Topconstr.LocalRawAssum (bl, k, typ) :: tl ->
+ let rawtyp = coqintern_type !isevars env typ in
+ let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in
+ let acc =
+ List.fold_left (fun (env, rels) (loc, name) ->
+ let reldecl = (name, None, coqtyp) in
+ (push_rel reldecl env,
+ reldecl :: rels))
+ (env, rels) bl
+ in aux acc tl
+ | [] -> acc
+ in aux (env, []) l
+
+let subtac_process env isevars id bl c tycon =
+ let c = Topconstr.abstract_constr_expr c bl in
+ let tycon =
+ match tycon with
+ None -> empty_tycon
+ | Some t ->
+ let t = Topconstr.prod_constr_expr t bl in
+ let t = coqintern_type !isevars env t in
+ let coqt, ttyp = interp env isevars t empty_tycon in
+ mk_tycon coqt
+ in
+ let c = coqintern_constr !isevars env c in
+ let imps = Implicit_quantifiers.implicits_of_rawterm c in
+ let coqc, ctyp = interp env isevars c tycon in
+ let evm = non_instanciated_map env isevars ( !isevars) in
+ let ty = nf_evar !isevars (match tycon with Some (None, c) -> c | _ -> ctyp) in
+ evm, coqc, ty, imps
+
+open Subtac_obligations
+
+let subtac_proof kind hook env isevars id bl c tycon =
+ let evm, coqc, coqt, imps = subtac_process env isevars id bl c tycon in
+ let evm' = Subtac_utils.evars_of_term evm Evd.empty coqc in
+ let evm' = Subtac_utils.evars_of_term evm evm' coqt in
+ let evars, _, def, ty = Eterm.eterm_obligations env id !isevars evm' 0 coqc coqt in
+ add_definition id ~term:def ty ~implicits:imps ~kind ~hook evars
diff --git a/plugins/subtac/subtac_pretyping.mli b/plugins/subtac/subtac_pretyping.mli
new file mode 100644
index 00000000..055c6df2
--- /dev/null
+++ b/plugins/subtac/subtac_pretyping.mli
@@ -0,0 +1,23 @@
+open Term
+open Environ
+open Names
+open Sign
+open Evd
+open Global
+open Topconstr
+open Implicit_quantifiers
+open Impargs
+
+module Pretyping : Pretyping.S
+
+val interp :
+ Environ.env ->
+ Evd.evar_map ref ->
+ Rawterm.rawconstr ->
+ Evarutil.type_constraint -> Term.constr * Term.constr
+
+val subtac_process : env -> evar_map ref -> identifier -> local_binder list ->
+ constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list
+
+val subtac_proof : Decl_kinds.definition_kind -> Tacexpr.declaration_hook -> env -> evar_map ref -> identifier -> local_binder list ->
+ constr_expr -> constr_expr option -> Subtac_obligations.progress
diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml
new file mode 100644
index 00000000..e574ef3b
--- /dev/null
+++ b/plugins/subtac/subtac_pretyping_F.ml
@@ -0,0 +1,645 @@
+(* -*- compile-command: "make -C ../.. plugins/subtac/subtac_plugin.cma" -*- *)
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Pp
+open Util
+open Names
+open Sign
+open Evd
+open Term
+open Termops
+open Reductionops
+open Environ
+open Type_errors
+open Typeops
+open Libnames
+open Nameops
+open Classops
+open List
+open Recordops
+open Evarutil
+open Pretype_errors
+open Rawterm
+open Evarconv
+open Pattern
+open Pretyping
+
+(************************************************************************)
+(* This concerns Cases *)
+open Declarations
+open Inductive
+open Inductiveops
+
+module SubtacPretyping_F (Coercion : Coercion.S) = struct
+
+ module Cases = Subtac_cases.Cases_F(Coercion)
+
+ (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+ let allow_anonymous_refs = ref true
+
+ let evd_comb0 f evdref =
+ let (evd',x) = f !evdref in
+ evdref := evd';
+ x
+
+ let evd_comb1 f evdref x =
+ let (evd',y) = f !evdref x in
+ evdref := evd';
+ y
+
+ let evd_comb2 f evdref x y =
+ let (evd',z) = f !evdref x y in
+ evdref := evd';
+ z
+
+ let evd_comb3 f evdref x y z =
+ let (evd',t) = f !evdref x y z in
+ evdref := evd';
+ t
+
+ let mt_evd = Evd.empty
+
+ (* Utilisé pour inférer le prédicat des Cases *)
+ (* Semble exagérement fort *)
+ (* Faudra préférer une unification entre les types de toutes les clauses *)
+ (* et autoriser des ? à rester dans le résultat de l'unification *)
+
+ let evar_type_fixpoint loc env evdref lna lar vdefj =
+ let lt = Array.length vdefj in
+ if Array.length lar = lt then
+ 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)
+ i lna vdefj lar
+ done
+
+ let check_branches_message loc env evdref 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)
+ done
+
+ (* coerce to tycon if any *)
+ let inh_conv_coerce_to_tycon loc env evdref j = function
+ | None -> j_nf_evar !evdref j
+ | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) evdref j t
+
+ let push_rels vars env = List.fold_right push_rel vars env
+
+ (*
+ 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)
+ *)
+
+ let strip_meta id = (* For Grammar v7 compatibility *)
+ let s = string_of_id id in
+ if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
+ else id
+
+ let invert_ltac_bound_name env id0 id =
+ try mkRel (pi1 (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 ++
+ str " which is not bound in current context")
+
+ 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
+ { uj_val = mkRel n; uj_type = lift n typ }
+ with Not_found ->
+ try
+ let (ids,c) = List.assoc id lvar in
+ let subst = List.map (invert_ltac_bound_name env id) ids in
+ let c = substl subst c in
+ { uj_val = c; uj_type = Retyping.get_type_of env sigma c }
+ with Not_found ->
+ try
+ let (_,_,typ) = lookup_named id env in
+ { uj_val = mkVar id; uj_type = typ }
+ with Not_found ->
+ try (* To build a nicer ltac error message *)
+ match List.assoc id unbndltacvars with
+ | None -> user_err_loc (loc,"",
+ str "variable " ++ pr_id id ++ str " should be bound to a term")
+ | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
+ with Not_found ->
+ error_var_not_found_loc loc id
+
+ (* make a dependent predicate from an undependent one *)
+
+ let make_dep_of_undep env (IndType (indf,realargs)) pj =
+ let n = List.length realargs in
+ let rec decomp n p =
+ if n=0 then p else
+ match kind_of_term p with
+ | Lambda (_,_,c) -> decomp (n-1) c
+ | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1]))
+ in
+ let sign,s = decompose_prod_n n pj.uj_type in
+ let ind = build_dependent_inductive env indf in
+ 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}
+
+ (*************************************************************************)
+ (* Main pretyping function *)
+
+ let pretype_ref evdref env ref =
+ 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 ()
+
+ (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *)
+ (* 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 ++ *)
+(* str " with tycon " ++ Evarutil.pr_tycon env tycon) *)
+(* with _ -> () *)
+(* in *)
+ match c with
+ | RRef (loc,ref) ->
+ inh_conv_coerce_to_tycon loc env evdref
+ (pretype_ref evdref env ref)
+ tycon
+
+ | RVar (loc, id) ->
+ inh_conv_coerce_to_tycon loc env evdref
+ (pretype_id loc env !evdref lvar id)
+ tycon
+
+ | REvar (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 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
+ inh_conv_coerce_to_tycon loc env evdref j tycon
+
+ | RPatVar (loc,(someta,n)) ->
+ anomaly "Found a pattern variable in a rawterm to type"
+
+ | RHole (loc,k) ->
+ let ty =
+ match tycon with
+ | Some (None, ty) -> ty
+ | None | Some _ ->
+ e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in
+ { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty }
+
+ | RRec (loc,fixkind,names,bl,lar,vdef) ->
+ let rec type_bl env ctxt = function
+ [] -> ctxt
+ | (na,k,None,ty)::bl ->
+ let ty' = pretype_type empty_valcon env evdref lvar ty in
+ let dcl = (na,None,ty'.utj_val) in
+ type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
+ | (na,k,Some bd,ty)::bl ->
+ let ty' = pretype_type empty_valcon env evdref lvar ty in
+ let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in
+ let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
+ type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
+ let ctxtv = Array.map (type_bl env empty_rel_context) bl in
+ let larj =
+ array_map2
+ (fun e ar ->
+ pretype_type empty_valcon (push_rel_context e env) evdref lvar ar)
+ ctxtv lar in
+ let lara = Array.map (fun a -> a.utj_val) larj in
+ let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
+ let nbfix = Array.length lar in
+ let names = Array.map (fun id -> Name id) names in
+ (* Note: bodies are not used by push_rec_types, so [||] is safe *)
+ let newenv =
+ let marked_ftys =
+ Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in
+ mkApp (Lazy.force Subtac_utils.fix_proto, [| sort; ty |]))
+ ftys
+ in
+ push_rec_types (names,marked_ftys,[||]) env
+ in
+ let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in
+ let vdefj =
+ array_map2_i
+ (fun i ctxt def ->
+ let fty =
+ let ty = ftys.(i) in
+ if i = fixi then (
+ Option.iter (fun tycon ->
+ evdref := Coercion.inh_conv_coerces_to loc env !evdref ftys.(i) tycon)
+ tycon;
+ nf_evar !evdref ty)
+ else ty
+ in
+ (* we lift nbfix times the type in tycon, because of
+ * the nbfix variables pushed to newenv *)
+ let (ctxt,ty) =
+ decompose_prod_n_assum (rel_context_length ctxt)
+ (lift nbfix fty) in
+ let nenv = push_rel_context ctxt newenv in
+ let j = pretype (mk_tycon ty) nenv evdref lvar def in
+ { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
+ 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 fixj = match fixkind with
+ | RFix (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,
+ but doing it properly involves delta-reduction, and it finally
+ doesn't seem worth the effort (except for huge mutual
+ fixpoints ?) *)
+ let possible_indexes = Array.to_list (Array.mapi
+ (fun i (n,_) -> match n with
+ | Some n -> [n]
+ | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
+ vn)
+ in
+ 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 ->
+ let cofix = (i,(names,ftys,fdefs)) in
+ (try check_cofix env cofix with e -> Stdpp.raise_with_loc 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
+
+ | RApp (loc,f,args) ->
+ let length = List.length args in
+ let ftycon =
+ let ty =
+ if length > 0 then
+ match tycon with
+ | None -> None
+ | Some (None, ty) -> mk_abstr_tycon length ty
+ | Some (Some (init, cur), ty) ->
+ Some (Some (length + init, length + cur), ty)
+ else tycon
+ in
+ match ty with
+ | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty
+ | _ -> None
+ in
+ let fj = pretype ftycon env evdref lvar f in
+ let floc = loc_of_rawconstr f in
+ let rec apply_rec env n resj tycon = function
+ | [] -> resj
+ | c::rest ->
+ let argloc = loc_of_rawconstr c in
+ let resj = evd_comb1 (Coercion.inh_app_fun env) evdref resj in
+ let resty = whd_betadeltaiota env ( !evdref) resj.uj_type in
+ match kind_of_term resty with
+ | Prod (na,c1,c2) ->
+ Option.iter (fun ty -> evdref :=
+ Coercion.inh_conv_coerces_to loc env !evdref resty ty) tycon;
+ let evd, (_, _, tycon) = split_tycon loc env !evdref tycon in
+ evdref := evd;
+ let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in
+ let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
+ let typ' = nf_evar !evdref typ in
+ apply_rec env (n+1)
+ { uj_val = nf_evar !evdref value;
+ uj_type = nf_evar !evdref typ' }
+ (Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest
+
+ | _ ->
+ let hj = pretype empty_tycon env evdref lvar c in
+ error_cant_apply_not_functional_loc
+ (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 =
+ match kind_of_term resj.uj_val with
+ | App (f,args) when isInd f or isConst f ->
+ let sigma = !evdref in
+ let c = mkApp (f,Array.map (whd_evar sigma) args) in
+ let t = Retyping.get_type_of env sigma c in
+ make_judge c t
+ | _ -> resj in
+ inh_conv_coerce_to_tycon loc env evdref resj tycon
+
+ | RLambda(loc,name,k,c1,c2) ->
+ let tycon' = evd_comb1
+ (fun evd tycon ->
+ match tycon with
+ | None -> evd, tycon
+ | Some ty ->
+ let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in
+ evd, Some ty')
+ evdref tycon
+ in
+ let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in
+ let dom_valcon = valcon_of_tycon dom in
+ let j = pretype_type dom_valcon env evdref lvar c1 in
+ let var = (name,None,j.utj_val) in
+ let j' = pretype rng (push_rel var env) evdref lvar c2 in
+ 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) ->
+ 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 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
+ inh_conv_coerce_to_tycon loc env evdref resj tycon
+
+ | RLetIn(loc,name,c1,c2) ->
+ let j = pretype empty_tycon env evdref lvar c1 in
+ let t = 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) ->
+ let cj = pretype empty_tycon env evdref lvar c in
+ let (IndType (indf,realargs)) =
+ 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 cstrs = get_constructors env indf in
+ if Array.length cstrs <> 1 then
+ user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
+ let cs = cstrs.(0) in
+ if List.length nal <> cs.cs_nargs then
+ user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
+ let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
+ (List.rev nal) cs.cs_args in
+ let env_f = push_rels fsign env in
+ (* Make dependencies from arity signature impossible *)
+ let arsgn =
+ let arsgn,_ = get_arity env indf in
+ if not !allow_anonymous_refs then
+ List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+ else arsgn
+ in
+ let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+ let nar = List.length arsgn in
+ (match po with
+ | 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 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 fj = pretype (mk_tycon fty) env_f evdref lvar d in
+ let f = it_mkLambda_or_LetIn fj.uj_val fsign in
+ let v =
+ let mis,_ = dest_ind_family indf in
+ let ci = make_case_info env mis LetStyle in
+ mkCase (ci, p, cj.uj_val,[|f|]) in
+ { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
+
+ | None ->
+ 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 =
+ if noccur_between 1 cs.cs_nargs ccl then
+ lift (- cs.cs_nargs) ccl
+ else
+ 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 =
+ let mis,_ = dest_ind_family indf in
+ let ci = make_case_info env mis LetStyle in
+ mkCase (ci, p, cj.uj_val,[|f|] )
+ in
+ { uj_val = v; uj_type = ccl })
+
+ | RIf (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
+ with Not_found ->
+ let cloc = loc_of_rawconstr 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,"",
+ str "If is only for inductive types with two constructors.");
+
+ let arsgn =
+ let arsgn,_ = get_arity env indf in
+ if not !allow_anonymous_refs then
+ (* Make dependencies from arity signature impossible *)
+ List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+ else arsgn
+ in
+ let nar = List.length arsgn in
+ let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+ let pred,p = match po with
+ | 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 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;
+ uj_type = typ} tycon
+ in
+ jtyp.uj_val, jtyp.uj_type
+ | None ->
+ let p = match tycon with
+ | Some (None, ty) -> ty
+ | None | Some _ ->
+ e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ())
+ in
+ it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
+ let pred = nf_evar ( !evdref) pred in
+ let p = nf_evar ( !evdref) p in
+ (* msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
+ let f cs b =
+ let n = rel_context_length cs.cs_args in
+ let pi = lift n pred in (* liftn n 2 pred ? *)
+ let pi = beta_applist (pi, [build_dependent_constructor cs]) in
+ let csgn =
+ if not !allow_anonymous_refs then
+ List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
+ else
+ List.map
+ (fun (n, b, t) ->
+ match n with
+ Name _ -> (n, b, t)
+ | Anonymous -> (Name (id_of_string "H"), b, t))
+ cs.cs_args
+ in
+ let env_c = push_rels csgn env in
+(* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
+ let bj = pretype (mk_tycon pi) env_c evdref lvar b in
+ it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
+ let b1 = f cstrs.(0) b1 in
+ let b2 = f cstrs.(1) b2 in
+ let v =
+ let mis,_ = dest_ind_family indf in
+ let ci = make_case_info env mis IfStyle in
+ mkCase (ci, pred, cj.uj_val, [|b1;b2|])
+ in
+ { uj_val = v; uj_type = p }
+
+ | RCases (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) ->
+ let cj =
+ match k with
+ CastCoerce ->
+ let cj = pretype empty_tycon env evdref lvar c in
+ evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj
+ | CastConv (k,t) ->
+ let tj = pretype_type empty_valcon env evdref lvar t in
+ let cj = pretype (mk_tycon tj.utj_val) env evdref lvar c in
+ (* User Casts are for helping pretyping, experimentally not to be kept*)
+ (* ... except for Correctness *)
+ let v = mkCast (cj.uj_val, k, tj.utj_val) in
+ { uj_val = v; uj_type = tj.utj_val }
+ in
+ inh_conv_coerce_to_tycon loc env evdref cj tycon
+
+ | RDynamic (loc,d) ->
+ if (Dyn.tag d) = "constr" then
+ let c = constr_out d in
+ let j = (Retyping.get_judgment_of env ( !evdref) c) in
+ j
+ (*inh_conv_coerce_to_tycon loc env evdref j tycon*)
+ else
+ user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic."))
+
+ (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *)
+ and pretype_type valcon env evdref lvar = function
+ | RHole loc ->
+ (match valcon with
+ | Some v ->
+ let s =
+ let sigma = !evdref in
+ let t = Retyping.get_type_of env sigma v in
+ match kind_of_term (whd_betadeltaiota env sigma t) with
+ | Sort s -> s
+ | Evar ev when is_Type (existential_type sigma ev) ->
+ evd_comb1 (define_evar_as_sort) evdref ev
+ | _ -> anomaly "Found a type constraint which is not a type"
+ in
+ { utj_val = v;
+ utj_type = s }
+ | None ->
+ let s = 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 tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in
+ match valcon with
+ | None -> tj
+ | Some v ->
+ 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
+
+ let pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c =
+ let c' = match kind with
+ | OfType exptyp ->
+ 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 := fst (consider_remaining_unif_problems env !evdref);
+ if resolve_classes then
+ evdref :=
+ Typeclasses.resolve_typeclasses ~onlyargs:false
+ ~split:true ~fail:fail_evar 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
+ retourne aussi le nouveau sigma...
+ *)
+
+ let understand_judgment sigma env c =
+ let evdref = ref (create_evar_defs sigma) in
+ let j = pretype empty_tycon env evdref ([],[]) c in
+ let evd,_ = consider_remaining_unif_problems env !evdref in
+ let j = j_nf_evar evd j in
+ check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
+ j
+
+ let understand_judgment_tcc evdref env c =
+ let j = pretype empty_tycon env evdref ([],[]) c in
+ j_nf_evar !evdref j
+
+ (* Raw calls to the unsafe inference machine: boolean says if we must
+ fail on unresolved evars; the unsafe_judgment list allows us to
+ extend env with some bindings *)
+
+ let ise_pretype_gen expand_evar fail_evar resolve_classes sigma env lvar kind c =
+ let evdref = ref (Evd.create_evar_defs sigma) in
+ let c = pretype_gen expand_evar fail_evar resolve_classes evdref env lvar kind c in
+ !evdref, c
+
+ (** Entry points of the high-level type synthesis algorithm *)
+
+ let understand_gen kind sigma env c =
+ snd (ise_pretype_gen true true true sigma env ([],[]) kind c)
+
+ let understand sigma env ?expected_type:exptyp c =
+ snd (ise_pretype_gen true true true sigma env ([],[]) (OfType exptyp) c)
+
+ let understand_type sigma env c =
+ snd (ise_pretype_gen true false true sigma env ([],[]) IsType c)
+
+ let understand_ltac expand_evar sigma env lvar kind c =
+ ise_pretype_gen expand_evar false true sigma env lvar kind c
+
+ let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
+ ise_pretype_gen true false resolve_classes sigma env ([],[]) (OfType exptyp) c
+
+ let understand_tcc_evars ?(fail_evar=false) ?(resolve_classes=true) evdref env kind c =
+ pretype_gen true fail_evar resolve_classes evdref env ([],[]) kind c
+end
+
+module Default : S = SubtacPretyping_F(Coercion.Default)
diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml
new file mode 100644
index 00000000..06a80f68
--- /dev/null
+++ b/plugins/subtac/subtac_utils.ml
@@ -0,0 +1,484 @@
+open Evd
+open Libnames
+open Coqlib
+open Term
+open Names
+open Util
+
+let ($) f x = f x
+
+(****************************************************************************)
+(* Library linking *)
+
+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 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
+
+let fixsub = lazy (init_constant fixsub_module "Fix_sub")
+let ex_pi1 = lazy (init_constant utils_module "ex_pi1")
+let ex_pi2 = lazy (init_constant utils_module "ex_pi2")
+
+let make_ref l s = lazy (init_reference l s)
+let well_founded_ref = make_ref ["Init";"Wf"] "Well_founded"
+let acc_ref = make_ref ["Init";"Wf"] "Acc"
+let acc_inv_ref = make_ref ["Init";"Wf"] "Acc_inv"
+let fix_sub_ref = make_ref fixsub_module "Fix_sub"
+let measure_on_R_ref = make_ref fixsub_module "MR"
+let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub"
+let refl_ref = make_ref ["Init";"Logic"] "refl_equal"
+
+let make_ref s = Qualid (dummy_loc, qualid_of_string s)
+let lt_ref = make_ref "Init.Peano.lt"
+let sig_ref = make_ref "Init.Specif.sig"
+let proj1_sig_ref = make_ref "Init.Specif.proj1_sig"
+let proj2_sig_ref = make_ref "Init.Specif.proj2_sig"
+
+let build_sig () =
+ { proj1 = init_constant ["Init"; "Specif"] "proj1_sig";
+ proj2 = init_constant ["Init"; "Specif"] "proj2_sig";
+ elim = init_constant ["Init"; "Specif"] "sig_rec";
+ intro = init_constant ["Init"; "Specif"] "exist";
+ typ = init_constant ["Init"; "Specif"] "sig" }
+
+let sig_ = lazy (build_sig ())
+
+let fix_proto = lazy (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 eq_ind = lazy (init_constant ["Init"; "Logic"] "eq")
+let eq_rec = lazy (init_constant ["Init"; "Logic"] "eq_rec")
+let eq_rect = lazy (init_constant ["Init"; "Logic"] "eq_rect")
+let eq_refl = lazy (init_constant ["Init"; "Logic"] "refl_equal")
+let eq_ind_ref = lazy (init_reference ["Init"; "Logic"] "eq")
+let refl_equal_ref = lazy (init_reference ["Init"; "Logic"] "refl_equal")
+
+let not_ref = lazy (init_constant ["Init"; "Logic"] "not")
+
+let and_typ = lazy (Coqlib.build_coq_and ())
+
+let eqdep_ind = lazy (init_constant [ "Logic";"Eqdep"] "eq_dep")
+let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec")
+let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep")
+let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro")
+
+let jmeq_ind =
+ lazy (check_required_library ["Coq";"Logic";"JMeq"];
+ init_constant ["Logic";"JMeq"] "JMeq")
+let jmeq_rec =
+ lazy (check_required_library ["Coq";"Logic";"JMeq"];
+ init_constant ["Logic";"JMeq"] "JMeq_rec")
+let jmeq_refl =
+ lazy (check_required_library ["Coq";"Logic";"JMeq"];
+ init_constant ["Logic";"JMeq"] "JMeq_refl")
+
+let ex_ind = lazy (init_constant ["Init"; "Logic"] "ex")
+let ex_intro = lazy (init_reference ["Init"; "Logic"] "ex_intro")
+
+let proj1 = lazy (init_constant ["Init"; "Logic"] "proj1")
+let proj2 = lazy (init_constant ["Init"; "Logic"] "proj2")
+
+let boolind = lazy (init_constant ["Init"; "Datatypes"] "bool")
+let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool")
+let natind = lazy (init_constant ["Init"; "Datatypes"] "nat")
+let intind = lazy (init_constant ["ZArith"; "binint"] "Z")
+let existSind = lazy (init_constant ["Init"; "Specif"] "sigS")
+
+let existS = lazy (build_sigma_type ())
+
+let prod = lazy (build_prod ())
+
+
+(* orders *)
+let well_founded = lazy (init_constant ["Init"; "Wf"] "well_founded")
+let fix = lazy (init_constant ["Init"; "Wf"] "Fix")
+let acc = lazy (init_constant ["Init"; "Wf"] "Acc")
+let acc_inv = lazy (init_constant ["Init"; "Wf"] "Acc_inv")
+
+let extconstr = Constrextern.extern_constr true (Global.env ())
+let extsort s = Constrextern.extern_constr true (Global.env ()) (mkSort s)
+
+open Pp
+
+let my_print_constr = Termops.print_constr_env
+let my_print_constr_expr = Ppconstr.pr_constr_expr
+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_tycon_type = Evarutil.pr_tycon_type
+
+let debug_level = 2
+
+let debug_on = true
+
+let debug n s =
+ if debug_on then
+ if !Flags.debug && n >= debug_level then
+ msgnl s
+ else ()
+ else ()
+
+let debug_msg n s =
+ if debug_on then
+ if !Flags.debug && n >= debug_level then s
+ else mt ()
+ else mt ()
+
+let trace s =
+ if debug_on then
+ if !Flags.debug && debug_level > 0 then msgnl s
+ else ()
+ else ()
+
+let rec pp_list f = function
+ [] -> mt()
+ | x :: y -> f x ++ spc () ++ pp_list f y
+
+let wf_relations = Hashtbl.create 10
+
+let std_relations () =
+ let add k v = Hashtbl.add wf_relations k v in
+ add (init_constant ["Init"; "Peano"] "lt")
+ (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf"))
+
+let std_relations = Lazy.lazy_from_fun std_relations
+
+type binders = Topconstr.local_binder list
+
+let app_opt c e =
+ match c with
+ Some constr -> constr e
+ | None -> e
+
+let print_args env args =
+ Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "")
+
+let make_existential loc ?(opaque = Define true) env isevars c =
+ let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in
+ let (key, args) = destEvar evar in
+ (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++
+ print_args env args ++ str " for type: "++
+ my_print_constr env c) with _ -> ());
+ evar
+
+let make_existential_expr loc env c =
+ let key = Evarutil.new_untyped_evar () in
+ let evar = Topconstr.CEvar (loc, key, None) in
+ debug 2 (str "Constructed evar " ++ int key);
+ evar
+
+let string_of_hole_kind = function
+ | ImplicitArg _ -> "ImplicitArg"
+ | BinderType _ -> "BinderType"
+ | QuestionMark _ -> "QuestionMark"
+ | CasesType -> "CasesType"
+ | InternalHole -> "InternalHole"
+ | TomatchTypeParameter _ -> "TomatchTypeParameter"
+ | GoalEvar -> "GoalEvar"
+ | ImpossibleCase -> "ImpossibleCase"
+ | MatchingVar _ -> "MatchingVar"
+
+let evars_of_term evc init c =
+ let rec evrec acc c =
+ match kind_of_term c with
+ | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n)
+ | Evar (n, _) -> assert(false)
+ | _ -> fold_constr evrec acc c
+ in
+ evrec init c
+
+let non_instanciated_map env evd evm =
+ List.fold_left
+ (fun evm (key, evi) ->
+ let (loc,k) = evar_source key !evd in
+ debug 2 (str "evar " ++ int key ++ str " has kind " ++
+ str (string_of_hole_kind k));
+ match k with
+ | QuestionMark _ -> Evd.add evm key evi
+ | ImplicitArg (_,_,false) -> Evd.add evm key evi
+ | _ ->
+ debug 2 (str " and is an implicit");
+ Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None)
+ Evd.empty (Evarutil.non_instantiated evm)
+
+let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition
+let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition
+
+let global_proof_kind = Decl_kinds.IsProof Decl_kinds.Lemma
+let goal_proof_kind = Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma
+
+let global_fix_kind = Decl_kinds.IsDefinition Decl_kinds.Fixpoint
+let goal_fix_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Fixpoint
+
+open Tactics
+open Tacticals
+
+let id x = x
+let filter_map f l =
+ let rec aux acc = function
+ hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl
+ | None -> aux acc tl)
+ | [] -> List.rev acc
+ in aux [] l
+
+let build_dependent_sum l =
+ let rec aux names conttac conttype = function
+ (n, t) :: ((_ :: _) as tl) ->
+ let hyptype = substl names t in
+ trace (spc () ++ str ("treating evar " ^ string_of_id n));
+ (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype)
+ with _ -> ());
+ let tac = assert_tac (Name n) hyptype in
+ let conttac =
+ (fun cont ->
+ conttac
+ (tclTHENS tac
+ ([intros;
+ (tclTHENSEQ
+ [constructor_tac false (Some 1) 1
+ (Rawterm.ImplicitBindings [mkVar n]);
+ cont]);
+ ])))
+ in
+ let conttype =
+ (fun typ ->
+ let tex = mkLambda (Name n, t, typ) in
+ conttype
+ (mkApp (Lazy.force ex_ind, [| t; tex |])))
+ in
+ aux (mkVar n :: names) conttac conttype tl
+ | (n, t) :: [] ->
+ (conttac intros, conttype t)
+ | [] -> raise (Invalid_argument "build_dependent_sum")
+ in aux [] id id (List.rev l)
+
+open Proof_type
+open Tacexpr
+
+let mkProj1 a b c =
+ mkApp (Lazy.force proj1, [| a; b; c |])
+
+let mkProj2 a b c =
+ mkApp (Lazy.force proj2, [| a; b; c |])
+
+let mk_ex_pi1 a b c =
+ mkApp (Lazy.force ex_pi1, [| a; b; c |])
+
+let mk_ex_pi2 a b c =
+ mkApp (Lazy.force ex_pi2, [| a; b; c |])
+
+let mkSubset name typ prop =
+ mkApp ((Lazy.force sig_).typ,
+ [| typ; mkLambda (name, typ, prop) |])
+
+let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |])
+let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |])
+let mk_JMeq typ x typ' y = mkApp (Lazy.force jmeq_ind, [| typ; x ; typ'; y |])
+let mk_JMeq_refl typ x = mkApp (Lazy.force jmeq_refl, [| typ; x |])
+
+let unsafe_fold_right f = function
+ hd :: tl -> List.fold_right f tl hd
+ | [] -> raise (Invalid_argument "unsafe_fold_right")
+
+let mk_conj l =
+ let conj_typ = Lazy.force and_typ in
+ unsafe_fold_right
+ (fun c conj ->
+ mkApp (conj_typ, [| c ; conj |]))
+ l
+
+let mk_not c =
+ let notc = Lazy.force not_ref in
+ mkApp (notc, [| c |])
+
+let and_tac l hook =
+ let andc = Coqlib.build_coq_and () in
+ let rec aux ((accid, goal, tac, extract) as acc) = function
+ | [] -> (* Singleton *) acc
+
+ | (id, x, elgoal, eltac) :: tl ->
+ let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in
+ let proj = fun c -> mkProj2 goal elgoal c in
+ let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in
+ aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac',
+ (id, x, elgoal, proj) :: extract) tl
+
+ in
+ let and_proof_id, and_goal, and_tac, and_extract =
+ match l with
+ | [] -> raise (Invalid_argument "and_tac: empty list of goals")
+ | (hdid, x, hdg, hdt) :: tl ->
+ aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl
+ in
+ let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in
+ Lemmas.start_proof and_proofid goal_kind and_goal
+ (hook (fun c -> List.map (fun (id, x, t, f) -> (id, x, t, f c)) and_extract));
+ trace (str "Started and proof");
+ Pfedit.by and_tac;
+ trace (str "Applied and tac")
+
+
+let destruct_ex ext ex =
+ let rec aux c acc =
+ match kind_of_term c with
+ App (f, args) ->
+ (match kind_of_term f with
+ Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 ->
+ let (dom, rng) =
+ try (args.(0), args.(1))
+ with _ -> assert(false)
+ in
+ let pi1 = (mk_ex_pi1 dom rng acc) in
+ let rng_body =
+ match kind_of_term rng with
+ Lambda (_, _, t) -> subst1 pi1 t
+ | t -> rng
+ in
+ pi1 :: aux rng_body (mk_ex_pi2 dom rng acc)
+ | _ -> [acc])
+ | _ -> [acc]
+ in aux ex ext
+
+open Rawterm
+
+let id_of_name = function
+ Name n -> n
+ | Anonymous -> raise (Invalid_argument "id_of_name")
+
+let definition_message id =
+ Nameops.pr_id id ++ str " is defined"
+
+let recursive_message v =
+ match Array.length v with
+ | 0 -> error "no recursive definition"
+ | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined")
+ | _ -> hov 0 (prvect_with_sep pr_comma (Printer.pr_constant (Global.env ())) v ++
+ spc () ++ str "are recursively defined")
+
+let print_message m =
+ Flags.if_verbose ppnl m
+
+(* Solve an obligation using tactics, return the corresponding proof term *)
+let solve_by_tac evi t =
+ let id = id_of_string "H" in
+ try
+ Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl
+ (fun _ _ -> ());
+ Pfedit.by (tclCOMPLETE t);
+ let _,(const,_,_,_) = Pfedit.cook_proof ignore in
+ Pfedit.delete_current_proof ();
+ Inductiveops.control_only_guard (Global.env ())
+ const.Entries.const_entry_body;
+ const.Entries.const_entry_body
+ with e ->
+ Pfedit.delete_current_proof();
+ raise e
+
+(* let apply_tac t goal = t goal *)
+
+(* let solve_by_tac evi t = *)
+(* let ev = 1 in *)
+(* let evm = Evd.add Evd.empty ev evi in *)
+(* let goal = {it = evi; sigma = evm } in *)
+(* let (res, valid) = apply_tac t goal in *)
+(* if res.it = [] then *)
+(* let prooftree = valid [] in *)
+(* let proofterm, obls = Refiner.extract_open_proof res.sigma prooftree in *)
+(* if obls = [] then proofterm *)
+(* else raise Exit *)
+(* else raise Exit *)
+
+let rec string_of_list sep f = function
+ [] -> ""
+ | x :: [] -> f x
+ | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl
+
+let string_of_intset d =
+ string_of_list "," string_of_int (Intset.elements d)
+
+(**********************************************************)
+(* Pretty-printing *)
+open Printer
+open Ppconstr
+open Nameops
+open Termops
+open Evd
+
+let pr_meta_map evd =
+ let ml = meta_list evd in
+ let pr_name = function
+ Name id -> str"[" ++ pr_id id ++ str"]"
+ | _ -> mt() in
+ let pr_meta_binding = function
+ | (mv,Cltyp (na,b)) ->
+ hov 0
+ (pr_meta mv ++ pr_name na ++ str " : " ++
+ print_constr b.rebus ++ fnl ())
+ | (mv,Clval(na,b,_)) ->
+ hov 0
+ (pr_meta mv ++ pr_name na ++ str " := " ++
+ print_constr (fst b).rebus ++ fnl ())
+ in
+ prlist pr_meta_binding ml
+
+let pr_idl idl = prlist_with_sep pr_spc pr_id idl
+
+let pr_evar_info evi =
+ let phyps =
+ (*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 pb =
+ match evi.evar_body with
+ | Evar_empty -> mt ()
+ | Evar_defined c -> spc() ++ str"=> " ++ print_constr c
+ in
+ hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]")
+
+let pr_evar_map sigma =
+ h 0
+ (prlist_with_sep pr_fnl
+ (fun (ev,evi) ->
+ h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
+ (to_list sigma))
+
+let pr_constraints pbs =
+ h 0
+ (prlist_with_sep pr_fnl (fun (pbty,t1,t2) ->
+ print_constr t1 ++ spc() ++
+ str (match pbty with
+ | Reduction.CONV -> "=="
+ | Reduction.CUMUL -> "<=") ++
+ spc() ++ print_constr t2) pbs)
+
+let pr_evar_map evd =
+ let pp_evm =
+ let evars = evd in
+ if evars = empty then mt() else
+ str"EVARS:"++brk(0,1)++pr_evar_map evars++fnl() in
+ let pp_met =
+ if meta_list evd = [] then mt() else
+ str"METAS:"++brk(0,1)++pr_meta_map evd in
+ v 0 (pp_evm ++ pp_met)
+
+let contrib_tactics_path =
+ make_dirpath (List.map id_of_string ["Tactics";contrib_name;"Coq"])
+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))
diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli
new file mode 100644
index 00000000..d0ad334d
--- /dev/null
+++ b/plugins/subtac/subtac_utils.mli
@@ -0,0 +1,136 @@
+open Term
+open Libnames
+open Coqlib
+open Environ
+open Pp
+open Evd
+open Decl_kinds
+open Topconstr
+open Rawterm
+open Util
+open Evarutil
+open Names
+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
+val init_reference : string list -> string -> global_reference
+val fixsub : constr lazy_t
+val well_founded_ref : global_reference lazy_t
+val acc_ref : global_reference lazy_t
+val acc_inv_ref : global_reference lazy_t
+val fix_sub_ref : global_reference lazy_t
+val measure_on_R_ref : global_reference lazy_t
+val fix_measure_sub_ref : global_reference lazy_t
+val refl_ref : global_reference lazy_t
+val lt_ref : reference
+val sig_ref : reference
+val proj1_sig_ref : reference
+val proj2_sig_ref : reference
+val build_sig : unit -> coq_sigma_data
+val sig_ : coq_sigma_data lazy_t
+
+val fix_proto : constr lazy_t
+val fix_proto_ref : unit -> constant
+
+val eq_ind : constr lazy_t
+val eq_rec : constr lazy_t
+val eq_rect : constr lazy_t
+val eq_refl : constr lazy_t
+
+val not_ref : constr lazy_t
+val and_typ : constr lazy_t
+
+val eqdep_ind : constr lazy_t
+val eqdep_rec : constr lazy_t
+
+val jmeq_ind : constr lazy_t
+val jmeq_rec : constr lazy_t
+val jmeq_refl : constr lazy_t
+
+val boolind : constr lazy_t
+val sumboolind : constr lazy_t
+val natind : constr lazy_t
+val intind : constr lazy_t
+val existSind : constr lazy_t
+val existS : coq_sigma_data lazy_t
+val prod : coq_sigma_data lazy_t
+
+val well_founded : constr lazy_t
+val fix : constr lazy_t
+val acc : constr lazy_t
+val acc_inv : constr lazy_t
+val extconstr : constr -> constr_expr
+val extsort : sorts -> constr_expr
+
+val my_print_constr : env -> constr -> std_ppcmds
+val my_print_constr_expr : constr_expr -> std_ppcmds
+val my_print_evardefs : evar_map -> std_ppcmds
+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_tycon_type : env -> type_constraint_type -> std_ppcmds
+
+
+val debug : int -> std_ppcmds -> unit
+val debug_msg : int -> std_ppcmds -> std_ppcmds
+val trace : std_ppcmds -> unit
+val wf_relations : (constr, constr lazy_t) Hashtbl.t
+
+type binders = local_binder list
+val app_opt : ('a -> 'a) option -> 'a -> 'a
+val print_args : env -> constr array -> std_ppcmds
+val make_existential : loc -> ?opaque:obligation_definition_status ->
+ env -> evar_map ref -> types -> constr
+val make_existential_expr : loc -> 'a -> 'b -> constr_expr
+val string_of_hole_kind : hole_kind -> string
+val evars_of_term : evar_map -> evar_map -> constr -> evar_map
+val non_instanciated_map : env -> evar_map ref -> evar_map -> evar_map
+val global_kind : logical_kind
+val goal_kind : locality * goal_object_kind
+val global_proof_kind : logical_kind
+val goal_proof_kind : locality * goal_object_kind
+val global_fix_kind : logical_kind
+val goal_fix_kind : locality * goal_object_kind
+
+val mkSubset : name -> constr -> constr -> constr
+val mkProj1 : constr -> constr -> constr -> constr
+val mkProj1 : constr -> constr -> constr -> constr
+val mk_ex_pi1 : constr -> constr -> constr -> constr
+val mk_ex_pi1 : constr -> constr -> constr -> constr
+val mk_eq : types -> constr -> constr -> types
+val mk_eq_refl : types -> constr -> constr
+val mk_JMeq : types -> constr-> types -> constr -> types
+val mk_JMeq_refl : types -> constr -> constr
+val mk_conj : types list -> types
+val mk_not : types -> types
+
+val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types
+val and_tac : (identifier * 'a * constr * Proof_type.tactic) list ->
+ ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit
+
+val destruct_ex : constr -> constr -> constr list
+
+val id_of_name : name -> identifier
+
+val definition_message : identifier -> std_ppcmds
+val recursive_message : constant array -> std_ppcmds
+
+val print_message : std_ppcmds -> unit
+
+val solve_by_tac : evar_info -> Tacmach.tactic -> constr
+
+val string_of_list : string -> ('a -> string) -> 'a list -> string
+val string_of_intset : Intset.t -> string
+
+val pr_evar_map : evar_map -> Pp.std_ppcmds
+
+val tactics_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr
+
+val pp_list : ('a -> Pp.std_ppcmds) -> 'a list -> Pp.std_ppcmds
diff --git a/plugins/subtac/test/ListDep.v b/plugins/subtac/test/ListDep.v
new file mode 100644
index 00000000..e3dbd127
--- /dev/null
+++ b/plugins/subtac/test/ListDep.v
@@ -0,0 +1,49 @@
+(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
+Require Import List.
+Require Import Coq.Program.Program.
+
+Set Implicit Arguments.
+
+Definition sub_list (A : Set) (l' l : list A) := (forall v, In v l' -> In v l) /\ length l' <= length l.
+
+Lemma sub_list_tl : forall A : Set, forall x (l l' : list A), sub_list (x :: l) l' -> sub_list l l'.
+Proof.
+ intros.
+ inversion H.
+ split.
+ intros.
+ apply H0.
+ auto with datatypes.
+ auto with arith.
+Qed.
+
+Section Map_DependentRecursor.
+ Variable U V : Set.
+ Variable l : list U.
+ Variable f : { x : U | In x l } -> V.
+
+ Obligations Tactic := unfold sub_list in * ;
+ program_simpl ; intuition.
+
+ Program Fixpoint map_rec ( l' : list U | sub_list l' l )
+ { measure length l' } : { r : list V | length r = length l' } :=
+ match l' with
+ | nil => nil
+ | cons x tl => let tl' := map_rec tl in
+ f x :: tl'
+ end.
+
+ Next Obligation.
+ destruct_call map_rec.
+ simpl in *.
+ subst l'.
+ simpl ; auto with arith.
+ Qed.
+
+ Program Definition map : list V := map_rec l.
+
+End Map_DependentRecursor.
+
+Extraction map.
+Extraction map_rec.
+
diff --git a/plugins/subtac/test/ListsTest.v b/plugins/subtac/test/ListsTest.v
new file mode 100644
index 00000000..2cea0841
--- /dev/null
+++ b/plugins/subtac/test/ListsTest.v
@@ -0,0 +1,99 @@
+(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
+Require Import Coq.Program.Program.
+Require Import List.
+
+Set Implicit Arguments.
+
+Section Accessors.
+ Variable A : Set.
+
+ Program Definition myhd : forall (l : list A | length l <> 0), A :=
+ fun l =>
+ match l with
+ | nil => !
+ | hd :: tl => hd
+ end.
+
+ Program Definition mytail (l : list A | length l <> 0) : list A :=
+ match l with
+ | nil => !
+ | hd :: tl => tl
+ end.
+End Accessors.
+
+Program Definition test_hd : nat := myhd (cons 1 nil).
+
+(*Eval compute in test_hd*)
+(*Program Definition test_tail : list A := mytail nil.*)
+
+Section app.
+ Variable A : Set.
+
+ Program Fixpoint app (l : list A) (l' : list A) { struct l } :
+ { r : list A | length r = length l + length l' } :=
+ match l with
+ | nil => l'
+ | hd :: tl => hd :: (tl ++ l')
+ end
+ where "x ++ y" := (app x y).
+
+ Next Obligation.
+ intros.
+ destruct_call app ; program_simpl.
+ Defined.
+
+ Program Lemma app_id_l : forall l : list A, l = nil ++ l.
+ Proof.
+ simpl ; auto.
+ Qed.
+
+ Program Lemma app_id_r : forall l : list A, l = l ++ nil.
+ Proof.
+ induction l ; simpl in * ; auto.
+ rewrite <- IHl ; auto.
+ Qed.
+
+End app.
+
+Extraction app.
+
+Section Nth.
+
+ Variable A : Set.
+
+ Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A :=
+ match n, l with
+ | 0, hd :: _ => hd
+ | S n', _ :: tl => nth tl n'
+ | _, nil => !
+ end.
+
+ Next Obligation.
+ Proof.
+ simpl in *. auto with arith.
+ Defined.
+
+ Next Obligation.
+ Proof.
+ inversion H.
+ Qed.
+
+ Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A :=
+ match l, n with
+ | hd :: _, 0 => hd
+ | _ :: tl, S n' => nth' tl n'
+ | nil, _ => !
+ end.
+ Next Obligation.
+ Proof.
+ simpl in *. auto with arith.
+ Defined.
+
+ Next Obligation.
+ Proof.
+ intros.
+ inversion H.
+ Defined.
+
+End Nth.
+
diff --git a/plugins/subtac/test/Mutind.v b/plugins/subtac/test/Mutind.v
new file mode 100644
index 00000000..01e2d75f
--- /dev/null
+++ b/plugins/subtac/test/Mutind.v
@@ -0,0 +1,20 @@
+Require Import List.
+
+Program Fixpoint f a : { x : nat | x > 0 } :=
+ match a with
+ | 0 => 1
+ | S a' => g a a'
+ end
+with g a b : { x : nat | x > 0 } :=
+ match b with
+ | 0 => 1
+ | S b' => f b'
+ end.
+
+Check f.
+Check g.
+
+
+
+
+
diff --git a/plugins/subtac/test/Test1.v b/plugins/subtac/test/Test1.v
new file mode 100644
index 00000000..7e0755d5
--- /dev/null
+++ b/plugins/subtac/test/Test1.v
@@ -0,0 +1,16 @@
+Program Definition test (a b : nat) : { x : nat | x = a + b } :=
+ ((a + b) : { x : nat | x = a + b }).
+Proof.
+intros.
+reflexivity.
+Qed.
+
+Print test.
+
+Require Import List.
+
+Program hd_opt (l : list nat) : { x : nat | x <> 0 } :=
+ match l with
+ nil => 1
+ | a :: l => a
+ end.
diff --git a/plugins/subtac/test/euclid.v b/plugins/subtac/test/euclid.v
new file mode 100644
index 00000000..97c3d941
--- /dev/null
+++ b/plugins/subtac/test/euclid.v
@@ -0,0 +1,24 @@
+Require Import Coq.Program.Program.
+Require Import Coq.Arith.Compare_dec.
+Notation "( x & y )" := (existS _ x y) : core_scope.
+
+Require Import Omega.
+
+Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a} :
+ { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
+ if le_lt_dec b a then let (q', r) := euclid (a - b) b in
+ (S q' & r)
+ else (O & a).
+
+Next Obligation.
+ assert(b * S q' = b * q' + b) by auto with arith ; omega.
+Defined.
+
+Program Definition test_euclid : (prod nat nat) := let (q, r) := euclid 4 2 in (q, q).
+
+Eval lazy beta zeta delta iota in test_euclid.
+
+Program Definition testsig (a : nat) : { x : nat & { y : nat | x < y } } :=
+ (a & S a).
+
+Check testsig.
diff --git a/plugins/subtac/test/id.v b/plugins/subtac/test/id.v
new file mode 100644
index 00000000..9ae11088
--- /dev/null
+++ b/plugins/subtac/test/id.v
@@ -0,0 +1,46 @@
+Require Coq.Arith.Arith.
+
+Require Import Coq.subtac.Utils.
+Program Fixpoint id (n : nat) : { x : nat | x = n } :=
+ match n with
+ | O => O
+ | S p => S (id p)
+ end.
+intros ; auto.
+
+pose (subset_simpl (id p)).
+simpl in e.
+unfold p0.
+rewrite e.
+auto.
+Defined.
+
+Check id.
+Print id.
+Extraction id.
+
+Axiom le_gt_dec : forall n m, { n <= m } + { n > m }.
+Require Import Omega.
+
+Program Fixpoint id_if (n : nat) { wf n lt }: { x : nat | x = n } :=
+ if le_gt_dec n 0 then 0
+ else S (id_if (pred n)).
+intros.
+auto with arith.
+intros.
+pose (subset_simpl (id_if (pred n))).
+simpl in e.
+rewrite e.
+induction n ; auto with arith.
+Defined.
+
+Print id_if_instance.
+Extraction id_if_instance.
+
+Notation "( x & y )" := (@existS _ _ x y) : core_scope.
+
+Program Definition testsig ( a : nat ) : { x : nat & { y : nat | x = y }} :=
+ (a & a).
+intros.
+auto.
+Qed.
diff --git a/plugins/subtac/test/measure.v b/plugins/subtac/test/measure.v
new file mode 100644
index 00000000..4f938f4f
--- /dev/null
+++ b/plugins/subtac/test/measure.v
@@ -0,0 +1,20 @@
+Notation "( x & y )" := (@existS _ _ x y) : core_scope.
+Unset Printing All.
+Require Import Coq.Arith.Compare_dec.
+
+Require Import Coq.Program.Program.
+
+Fixpoint size (a : nat) : nat :=
+ match a with
+ 0 => 1
+ | S n => S (size n)
+ end.
+
+Program Fixpoint test_measure (a : nat) {measure size a} : nat :=
+ match a with
+ | S (S n) => S (test_measure n)
+ | 0 | S 0 => a
+ end.
+
+Check test_measure.
+Print test_measure. \ No newline at end of file
diff --git a/plugins/subtac/test/rec.v b/plugins/subtac/test/rec.v
new file mode 100644
index 00000000..aaefd8cc
--- /dev/null
+++ b/plugins/subtac/test/rec.v
@@ -0,0 +1,65 @@
+Require Import Coq.Arith.Arith.
+Require Import Lt.
+Require Import Omega.
+
+Axiom lt_ge_dec : forall x y : nat, { x < y } + { x >= y }.
+(*Proof.
+ intros.
+ elim (le_lt_dec y x) ; intros ; auto with arith.
+Defined.
+*)
+Require Import Coq.subtac.FixSub.
+Require Import Wf_nat.
+
+Lemma preda_lt_a : forall a, 0 < a -> pred a < a.
+auto with arith.
+Qed.
+
+Program Fixpoint id_struct (a : nat) : nat :=
+ match a with
+ 0 => 0
+ | S n => S (id_struct n)
+ end.
+
+Check struct_rec.
+
+ if (lt_ge_dec O a)
+ then S (wfrec (pred a))
+ else O.
+
+Program Fixpoint wfrec (a : nat) { wf a lt } : nat :=
+ if (lt_ge_dec O a)
+ then S (wfrec (pred a))
+ else O.
+intros.
+apply preda_lt_a ; auto.
+
+Defined.
+
+Extraction wfrec.
+Extraction Inline proj1_sig.
+Extract Inductive bool => "bool" [ "true" "false" ].
+Extract Inductive sumbool => "bool" [ "true" "false" ].
+Extract Inlined Constant lt_ge_dec => "<".
+
+Extraction wfrec.
+Extraction Inline lt_ge_dec le_lt_dec.
+Extraction wfrec.
+
+
+Program Fixpoint structrec (a : nat) { wf a lt } : nat :=
+ match a with
+ S n => S (structrec n)
+ | 0 => 0
+ end.
+intros.
+unfold n0.
+omega.
+Defined.
+
+Print structrec.
+Extraction structrec.
+Extraction structrec.
+
+Definition structrec_fun (a : nat) : nat := structrec a (lt_wf a).
+Print structrec_fun.
diff --git a/plugins/subtac/test/take.v b/plugins/subtac/test/take.v
new file mode 100644
index 00000000..90ae8bae
--- /dev/null
+++ b/plugins/subtac/test/take.v
@@ -0,0 +1,34 @@
+(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
+Require Import JMeq.
+Require Import List.
+Require Import Program.
+
+Set Implicit Arguments.
+Obligations Tactic := idtac.
+
+Print cons.
+
+Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } :=
+ match n with
+ | 0 => nil
+ | S p =>
+ match l with
+ | cons hd tl => let rest := take tl p in cons hd rest
+ | nil => !
+ end
+ end.
+
+Require Import Omega.
+Solve All Obligations.
+Next Obligation.
+ destruct_call take ; program_simpl.
+Defined.
+
+Next Obligation.
+ intros.
+ inversion H.
+Defined.
+
+
+
+
diff --git a/plugins/subtac/test/wf.v b/plugins/subtac/test/wf.v
new file mode 100644
index 00000000..5ccc154a
--- /dev/null
+++ b/plugins/subtac/test/wf.v
@@ -0,0 +1,48 @@
+Notation "( x & y )" := (@existS _ _ x y) : core_scope.
+Unset Printing All.
+Require Import Coq.Arith.Compare_dec.
+
+Require Import Coq.subtac.Utils.
+
+Ltac one_simpl_hyp :=
+ match goal with
+ | [H : (`exist _ _ _) = _ |- _] => simpl in H
+ | [H : _ = (`exist _ _ _) |- _] => simpl in H
+ | [H : (`exist _ _ _) < _ |- _] => simpl in H
+ | [H : _ < (`exist _ _ _) |- _] => simpl in H
+ | [H : (`exist _ _ _) <= _ |- _] => simpl in H
+ | [H : _ <= (`exist _ _ _) |- _] => simpl in H
+ | [H : (`exist _ _ _) > _ |- _] => simpl in H
+ | [H : _ > (`exist _ _ _) |- _] => simpl in H
+ | [H : (`exist _ _ _) >= _ |- _] => simpl in H
+ | [H : _ >= (`exist _ _ _) |- _] => simpl in H
+ end.
+
+Ltac one_simpl_subtac :=
+ destruct_exists ;
+ repeat one_simpl_hyp ; simpl.
+
+Ltac simpl_subtac := do 3 one_simpl_subtac ; simpl.
+
+Require Import Omega.
+Require Import Wf_nat.
+
+Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} :
+ { q : nat & { r : nat | a = b * q + r /\ r < b } } :=
+ if le_lt_dec b a then let (q', r) := euclid (a - b) b in
+ (S q' & r)
+ else (O & a).
+destruct b ; simpl_subtac.
+omega.
+simpl_subtac.
+assert(x0 * S q' = x0 + x0 * q').
+rewrite <- mult_n_Sm.
+omega.
+rewrite H2 ; omega.
+simpl_subtac.
+split ; auto with arith.
+omega.
+apply lt_wf.
+Defined.
+
+Check euclid_evars_proof. \ No newline at end of file
diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
new file mode 100644
index 00000000..19473dfa
--- /dev/null
+++ b/plugins/syntax/ascii_syntax.ml
@@ -0,0 +1,83 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(*i $Id$ i*)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Rawterm
+open Topconstr
+open Libnames
+open Coqlib
+open Bigint
+
+exception Non_closed_ascii
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let make_kn dir id = Libnames.encode_mind (make_dir dir) (id_of_string id)
+let make_path dir id = Libnames.make_path (make_dir dir) (id_of_string id)
+
+let ascii_module = ["Coq";"Strings";"Ascii"]
+
+let ascii_path = make_path ascii_module "ascii"
+
+let ascii_kn = make_kn ascii_module "ascii"
+let path_of_Ascii = ((ascii_kn,0),1)
+let static_glob_Ascii = ConstructRef path_of_Ascii
+
+let make_reference id = find_reference "Ascii interpretation" ascii_module id
+let glob_Ascii = lazy (make_reference "Ascii")
+
+open Lazy
+
+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)
+ :: (aux (n-1) (p/2)) in
+ RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p)
+
+let interp_ascii_string dloc s =
+ let p =
+ if String.length s = 1 then int_of_char s.[0]
+ else
+ if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2]
+ then int_of_string s
+ else
+ user_err_loc (dloc,"interp_ascii_string",
+ str "Expects a single character or a three-digits ascii code.") in
+ interp_ascii dloc p
+
+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)
+ | _ -> raise Non_closed_ascii in
+ try
+ let rec aux = function
+ | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l
+ | _ -> raise Non_closed_ascii in
+ Some (aux r)
+ with
+ Non_closed_ascii -> None
+
+let make_ascii_string n =
+ if n>=32 && n<=126 then String.make 1 (char_of_int n)
+ else Printf.sprintf "%03d" n
+
+let uninterp_ascii_string r = Option.map make_ascii_string (uninterp_ascii r)
+
+let _ =
+ Notation.declare_string_interpreter "char_scope"
+ (ascii_path,ascii_module)
+ interp_ascii_string
+ ([RRef (dummy_loc,static_glob_Ascii)], uninterp_ascii_string, true)
diff --git a/plugins/syntax/ascii_syntax_plugin.mllib b/plugins/syntax/ascii_syntax_plugin.mllib
new file mode 100644
index 00000000..b00f9250
--- /dev/null
+++ b/plugins/syntax/ascii_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Ascii_syntax
+Ascii_syntax_plugin_mod
diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml
new file mode 100644
index 00000000..5d20c2a3
--- /dev/null
+++ b/plugins/syntax/nat_syntax.ml
@@ -0,0 +1,78 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+(* This file defines the printer for natural numbers in [nat] *)
+
+(*i*)
+open Pcoq
+open Pp
+open Util
+open Names
+open Coqlib
+open Rawterm
+open Libnames
+open Bigint
+open Coqlib
+open Notation
+open Pp
+open Util
+open Names
+(*i*)
+
+(**********************************************************************)
+(* Parsing via scopes *)
+(* For example, (nat_of_string "3") is <<(S (S (S O)))>> *)
+
+let nat_of_int dloc n =
+ if is_pos_or_zero n then begin
+ if less_than (of_string "5000") n then
+ Flags.if_warn msg_warning
+ (strbrk "Stack overflow or segmentation fault happens when " ++
+ strbrk "working with large numbers in nat (observed threshold " ++
+ strbrk "may vary from 5000 to 70000 depending on your system " ++
+ strbrk "limits and on the command executed).");
+ let ref_O = RRef (dloc, glob_O) in
+ let ref_S = RRef (dloc, glob_S) in
+ let rec mk_nat acc n =
+ if n <> zero then
+ mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n)
+ else
+ acc
+ in
+ mk_nat ref_O n
+ end
+ else
+ user_err_loc (dloc, "nat_of_int",
+ str "Cannot interpret a negative number as a number of type nat")
+
+(************************************************************************)
+(* Printing via scopes *)
+
+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
+ | _ -> raise Non_closed_number
+
+let uninterp_nat p =
+ try
+ Some (int_of_nat p)
+ with
+ Non_closed_number -> None
+
+(************************************************************************)
+(* Declare the primitive parsers and printers *)
+
+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)
diff --git a/plugins/syntax/nat_syntax_plugin.mllib b/plugins/syntax/nat_syntax_plugin.mllib
new file mode 100644
index 00000000..69b0cb20
--- /dev/null
+++ b/plugins/syntax/nat_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Nat_syntax
+Nat_syntax_plugin_mod
diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml
new file mode 100644
index 00000000..4375d5e0
--- /dev/null
+++ b/plugins/syntax/numbers_syntax.ml
@@ -0,0 +1,330 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(* digit-based syntax for int31, bigN bigZ and bigQ *)
+
+open Bigint
+open Libnames
+open Rawterm
+
+(*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***)
+
+let make_dir l = Names.make_dirpath (List.map Names.id_of_string (List.rev l))
+let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id)
+
+let make_mind mp id = Names.make_mind mp Names.empty_dirpath (Names.mk_label id)
+let make_mind_mpfile dir id = make_mind (Names.MPfile (make_dir dir)) id
+let make_mind_mpdot dir modname id =
+ let mp = Names.MPdot (Names.MPfile (make_dir dir), Names.mk_label modname)
+ in make_mind mp id
+
+
+(* int31 stuff *)
+let int31_module = ["Coq"; "Numbers"; "Cyclic"; "Int31"; "Int31"]
+let int31_path = make_path int31_module "int31"
+let int31_id = make_mind_mpfile int31_module
+let int31_scope = "int31_scope"
+
+let int31_construct = ConstructRef ((int31_id "int31",0),1)
+
+let int31_0 = ConstructRef ((int31_id "digits",0),1)
+let int31_1 = ConstructRef ((int31_id "digits",0),2)
+
+
+(* bigN stuff*)
+let zn2z_module = ["Coq"; "Numbers"; "Cyclic"; "DoubleCyclic"; "DoubleType"]
+let zn2z_path = make_path zn2z_module "zn2z"
+let zn2z_id = make_mind_mpfile zn2z_module
+
+let zn2z_W0 = ConstructRef ((zn2z_id "zn2z",0),1)
+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_scope = "bigN_scope"
+
+(* number of inlined level of bigN (actually the level 0 to n_inlined-1 are inlined) *)
+let n_inlined = of_string "7"
+let bigN_constructor =
+ (* converts a bigint into an int the ugly way *)
+ let rec to_int i =
+ if equal i zero then
+ 0
+ else
+ let (quo,rem) = div2_with_rest i in
+ if rem then
+ 2*(to_int quo)+1
+ else
+ 2*(to_int quo)
+ in
+ fun i ->
+ ConstructRef ((bigN_t,0),
+ if less_than i n_inlined then
+ (to_int i)+1
+ else
+ (to_int n_inlined)+1
+ )
+
+(*bigZ stuff*)
+let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ]
+let bigZ_path = make_path (bigZ_module@["BigZ"]) "t"
+let bigZ_t = make_mind_mpdot bigZ_module "BigZ" "t_"
+let bigZ_scope = "bigZ_scope"
+
+let bigZ_pos = ConstructRef ((bigZ_t,0),1)
+let bigZ_neg = ConstructRef ((bigZ_t,0),2)
+
+
+(*bigQ stuff*)
+let bigQ_module = ["Coq"; "Numbers"; "Rational"; "BigQ"; "BigQ"]
+let bigQ_path = make_path (bigQ_module@["BigQ"]) "t"
+let bigQ_t = make_mind_mpdot bigQ_module "BigQ" "t_"
+let bigQ_scope = "bigQ_scope"
+
+let bigQ_z = ConstructRef ((bigQ_t,0),1)
+
+
+(*** Definition of the Non_closed exception, used in the pretty printing ***)
+exception Non_closed
+
+(*** Parsing for int31 in digital notation ***)
+
+(* 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 rec args counter n =
+ if counter <= 0 then
+ []
+ else
+ 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))
+
+let error_negative dloc =
+ Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
+
+let interp_int31 dloc n =
+ if is_pos_or_zero n then
+ int31_of_pos_bigint dloc n
+ else
+ error_negative dloc
+
+(* Pretty prints an int31 *)
+
+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))
+ | _ -> raise Non_closed
+ in
+ function
+ | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero
+ | _ -> raise Non_closed
+
+let uninterp_int31 i =
+ try
+ Some (bigint_of_int31 i)
+ with Non_closed ->
+ None
+
+(* Actually declares the interpreter for int31 *)
+let _ = Notation.declare_numeral_interpreter int31_scope
+ (int31_path, int31_module)
+ interp_int31
+ ([RRef (Util.dummy_loc, int31_construct)],
+ uninterp_int31,
+ true)
+
+
+(*** Parsing for bigN in digital notation ***)
+(* the base for bigN (in Coq) that is 2^31 in our case *)
+let base = pow two (of_string "31")
+
+(* base of the bigN of height N : *)
+let rank n = pow base (pow two n)
+
+(* splits a number bi at height n, that is the rest needs 2^n int31 to be stored
+ it is expected to be used only when the quotient would also need 2^n int31 to be
+ stored *)
+let split_at n bi =
+ euclid bi (rank (sub_1 n))
+
+(* search the height of the Coq bigint needed to represent the integer bi *)
+let height bi =
+ let rec height_aux n =
+ if less_than bi (rank n) then
+ n
+ else
+ height_aux (add_1 n)
+ in
+ height_aux zero
+
+
+(* 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 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)])
+ else
+ let (h,l) = split_at hgt n in
+ RApp (dloc, ref_WW, [RHole (dloc, Evd.InternalHole);
+ decomp (sub_1 hgt) h;
+ decomp (sub_1 hgt) l])
+ in
+ decomp hght n
+
+let bigN_of_pos_bigint dloc n =
+ let ref_constructor i = RRef (dloc, bigN_constructor i) in
+ let result h word = RApp (dloc, ref_constructor h, if less_than h n_inlined then
+ [word]
+ else
+ [Nat_syntax.nat_of_int dloc (sub h n_inlined);
+ word])
+ in
+ let hght = height n in
+ result hght (word_of_pos_bigint dloc hght n)
+
+let bigN_error_negative dloc =
+ Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
+
+let interp_bigN dloc n =
+ if is_pos_or_zero n then
+ bigN_of_pos_bigint dloc n
+ else
+ bigN_error_negative dloc
+
+
+(* Pretty prints a bigN *)
+
+let bigint_of_word =
+ let rec get_height rc =
+ match rc with
+ | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW ->
+ let hleft = get_height lft in
+ let hright = get_height rght in
+ add_1
+ (if less_than hleft hright then
+ hright
+ else
+ hleft)
+ | _ -> zero
+ in
+ let rec transform hght rc =
+ match rc with
+ | RApp (_,RRef(_,c),_) when c = zn2z_W0-> zero
+ | RApp (_,RRef(_,c), [_;lft;rght]) when c=zn2z_WW-> let new_hght = sub_1 hght in
+ add (mult (rank new_hght)
+ (transform (new_hght) lft))
+ (transform (new_hght) rght)
+ | _ -> bigint_of_int31 rc
+ in
+ fun rc ->
+ let hght = get_height rc in
+ transform hght rc
+
+let bigint_of_bigN rc =
+ match rc with
+ | RApp (_,_,[one_arg]) -> bigint_of_word one_arg
+ | RApp (_,_,[_;second_arg]) -> bigint_of_word second_arg
+ | _ -> raise Non_closed
+
+let uninterp_bigN rc =
+ try
+ Some (bigint_of_bigN rc)
+ with Non_closed ->
+ None
+
+
+(* declare the list of constructors of bigN used in the declaration of the
+ numeral interpreter *)
+
+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))
+ else
+ []
+ in
+ build zero
+
+(* Actually declares the interpreter for bigN *)
+let _ = Notation.declare_numeral_interpreter bigN_scope
+ (bigN_path, bigN_module)
+ interp_bigN
+ (bigN_list_of_constructors,
+ uninterp_bigN,
+ true)
+
+
+(*** 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
+ if is_pos_or_zero n then
+ RApp (dloc, ref_pos, [bigN_of_pos_bigint dloc n])
+ else
+ RApp (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 ->
+ let opp_val = bigint_of_bigN one_arg in
+ if equal opp_val zero then
+ raise Non_closed
+ else
+ neg opp_val
+ | _ -> raise Non_closed
+
+
+let uninterp_bigZ rc =
+ try
+ Some (bigint_of_bigZ rc)
+ with Non_closed ->
+ None
+
+(* Actually declares the interpreter for bigZ *)
+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)],
+ 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 uninterp_bigQ rc =
+ try match rc with
+ | RApp (_, RRef(_,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
+
+(* Actually declares the interpreter for bigQ *)
+let _ = Notation.declare_numeral_interpreter bigQ_scope
+ (bigQ_path, bigQ_module)
+ interp_bigQ
+ ([RRef (Util.dummy_loc, bigQ_z)], uninterp_bigQ,
+ true)
diff --git a/plugins/syntax/numbers_syntax_plugin.mllib b/plugins/syntax/numbers_syntax_plugin.mllib
new file mode 100644
index 00000000..ebc0bb20
--- /dev/null
+++ b/plugins/syntax/numbers_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Numbers_syntax
+Numbers_syntax_plugin_mod
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
new file mode 100644
index 00000000..f85309e6
--- /dev/null
+++ b/plugins/syntax/r_syntax.ml
@@ -0,0 +1,125 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Topconstr
+open Libnames
+
+exception Non_closed_number
+
+(**********************************************************************)
+(* Parsing R via scopes *)
+(**********************************************************************)
+
+open Libnames
+open Rawterm
+open Bigint
+
+let make_dir l = make_dirpath (List.map id_of_string (List.rev l))
+let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"]
+let make_path dir id = Libnames.make_path dir (id_of_string id)
+
+let r_path = make_path rdefinitions "R"
+
+(* TODO: temporary hack *)
+let make_path dir id = Libnames.encode_con dir (id_of_string id)
+
+let r_kn = make_path rdefinitions "R"
+let glob_R = ConstRef r_kn
+let glob_R1 = ConstRef (make_path rdefinitions "R1")
+let glob_R0 = ConstRef (make_path rdefinitions "R0")
+let glob_Ropp = ConstRef (make_path rdefinitions "Ropp")
+let glob_Rplus = ConstRef (make_path rdefinitions "Rplus")
+let glob_Rmult = ConstRef (make_path rdefinitions "Rmult")
+
+let two = mult_2 one
+let three = add_1 two
+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)])
+
+let r_of_posint dloc n =
+ let r1 = RRef (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 r_of_int dloc z =
+ if is_strictly_neg z then
+ RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)])
+ else
+ r_of_posint dloc z
+
+(**********************************************************************)
+(* Printing R via scopes *)
+(**********************************************************************)
+
+let bignat_of_r =
+(* for numbers > 1 *)
+let rec bignat_of_pos = function
+ (* 1+1 *)
+ | RApp (_,RRef (_,p), [RRef (_,o1); RRef (_,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)])])
+ 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 ->
+ 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])])
+ 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
+ | r -> bignat_of_pos r
+in
+bignat_of_r
+
+let bigint_of_r = function
+ | RApp (_,RRef (_,o), [a]) when o = glob_Ropp ->
+ let n = bignat_of_r a in
+ if n = zero then raise Non_closed_number;
+ neg n
+ | a -> bignat_of_r a
+
+let uninterp_r p =
+ try
+ Some (bigint_of_r p)
+ with Non_closed_number ->
+ None
+
+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)],
+ uninterp_r,
+ false)
diff --git a/plugins/syntax/r_syntax_plugin.mllib b/plugins/syntax/r_syntax_plugin.mllib
new file mode 100644
index 00000000..5c173a14
--- /dev/null
+++ b/plugins/syntax/r_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+R_syntax
+R_syntax_plugin_mod
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
new file mode 100644
index 00000000..bc02357a
--- /dev/null
+++ b/plugins/syntax/string_syntax.ml
@@ -0,0 +1,69 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(*i $Id$ i*)
+
+open Pp
+open Util
+open Names
+open Pcoq
+open Libnames
+open Topconstr
+open Ascii_syntax
+open Rawterm
+open Coqlib
+
+exception Non_closed_string
+
+(* make a string term from the string s *)
+
+let string_module = ["Coq";"Strings";"String"]
+
+let string_path = make_path string_module "string"
+
+let string_kn = make_kn string_module "string"
+let static_glob_EmptyString = ConstructRef ((string_kn,0),1)
+let static_glob_String = ConstructRef ((string_kn,0),2)
+
+let make_reference id = find_reference "String interpretation" string_module id
+let glob_String = lazy (make_reference "String")
+let glob_EmptyString = lazy (make_reference "EmptyString")
+
+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),
+ [interp_ascii dloc (int_of_char s.[n]); aux (n+1)])
+ in aux 0
+
+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 ->
+ (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 ->
+ Some (Buffer.contents b)
+ | _ ->
+ raise Non_closed_string
+ in aux r
+ with
+ Non_closed_string -> None
+
+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)],
+ uninterp_string, true)
diff --git a/plugins/syntax/string_syntax_plugin.mllib b/plugins/syntax/string_syntax_plugin.mllib
new file mode 100644
index 00000000..b108c9e0
--- /dev/null
+++ b/plugins/syntax/string_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+String_syntax
+String_syntax_plugin_mod
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
new file mode 100644
index 00000000..f6afd080
--- /dev/null
+++ b/plugins/syntax/z_syntax.ml
@@ -0,0 +1,194 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id$ *)
+
+open Pcoq
+open Pp
+open Util
+open Names
+open Topconstr
+open Libnames
+open Bigint
+
+exception Non_closed_number
+
+(**********************************************************************)
+(* Parsing positive via scopes *)
+(**********************************************************************)
+
+open Libnames
+open Rawterm
+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"
+
+(* 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 glob_positive = IndRef (positive_kn,0)
+let path_of_xI = ((positive_kn,0),1)
+let path_of_xO = ((positive_kn,0),2)
+let path_of_xH = ((positive_kn,0),3)
+let glob_xI = ConstructRef path_of_xI
+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 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,true) -> ref_xH
+ in
+ pos_of x
+
+let error_non_positive dloc =
+ user_err_loc (dloc, "interp_positive",
+ str "Only strictly positive numbers in type \"positive\".")
+
+let interp_positive dloc n =
+ if is_strictly_pos n then pos_of_bignat dloc n
+ else error_non_positive dloc
+
+(**********************************************************************)
+(* Printing positive via scopes *)
+(**********************************************************************)
+
+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
+ | _ -> raise Non_closed_number
+
+let uninterp_positive p =
+ try
+ Some (bignat_of_pos p)
+ with Non_closed_number ->
+ None
+
+(************************************************************************)
+(* Declaring interpreters and uninterpreters for positive *)
+(************************************************************************)
+
+let _ = Notation.declare_numeral_interpreter "positive_scope"
+ (positive_path,positive_module)
+ interp_positive
+ ([RRef (dummy_loc, glob_xI);
+ RRef (dummy_loc, glob_xO);
+ RRef (dummy_loc, glob_xH)],
+ uninterp_positive,
+ true)
+
+(**********************************************************************)
+(* Parsing N via scopes *)
+(**********************************************************************)
+
+let binnat_module = ["Coq";"NArith";"BinNat"]
+let n_kn = make_kn (make_dir binnat_module) (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_of_binnat dloc pos_or_neg n =
+ if n <> zero then
+ RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n])
+ else
+ RRef (dloc, glob_N0)
+
+let error_negative dloc =
+ user_err_loc (dloc, "interp_N", str "No negative numbers in type \"N\".")
+
+let n_of_int dloc n =
+ if is_pos_or_zero n then n_of_binnat dloc true n
+ else error_negative dloc
+
+(**********************************************************************)
+(* Printing N via scopes *)
+(**********************************************************************)
+
+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
+ | _ -> raise Non_closed_number
+
+let uninterp_n p =
+ try Some (bignat_of_n p)
+ with Non_closed_number -> None
+
+(************************************************************************)
+(* Declaring interpreters and uninterpreters for N *)
+
+let _ = Notation.declare_numeral_interpreter "N_scope"
+ (n_path,binnat_module)
+ n_of_int
+ ([RRef (dummy_loc, glob_N0);
+ RRef (dummy_loc, glob_Npos)],
+ uninterp_n,
+ true)
+
+(**********************************************************************)
+(* 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 glob_z = IndRef (z_kn,0)
+let path_of_ZERO = ((z_kn,0),1)
+let path_of_POS = ((z_kn,0),2)
+let path_of_NEG = ((z_kn,0),3)
+let glob_ZERO = ConstructRef path_of_ZERO
+let glob_POS = ConstructRef path_of_POS
+let glob_NEG = ConstructRef path_of_NEG
+
+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])
+ else
+ RRef (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
+ | _ -> raise Non_closed_number
+
+let uninterp_z p =
+ try
+ Some (bigint_of_z p)
+ with Non_closed_number -> None
+
+(************************************************************************)
+(* Declaring interpreters and uninterpreters for Z *)
+
+let _ = Notation.declare_numeral_interpreter "Z_scope"
+ (z_path,binint_module)
+ z_of_int
+ ([RRef (dummy_loc, glob_ZERO);
+ RRef (dummy_loc, glob_POS);
+ RRef (dummy_loc, glob_NEG)],
+ uninterp_z,
+ true)
diff --git a/plugins/syntax/z_syntax_plugin.mllib b/plugins/syntax/z_syntax_plugin.mllib
new file mode 100644
index 00000000..36d41acc
--- /dev/null
+++ b/plugins/syntax/z_syntax_plugin.mllib
@@ -0,0 +1,2 @@
+Z_syntax
+Z_syntax_plugin_mod
diff --git a/plugins/xml/COPYRIGHT b/plugins/xml/COPYRIGHT
new file mode 100644
index 00000000..c8d231fd
--- /dev/null
+++ b/plugins/xml/COPYRIGHT
@@ -0,0 +1,25 @@
+(******************************************************************************)
+(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* Project Helm (http://helm.cs.unibo.it) *)
+(* Project MoWGLI (http://mowgli.cs.unibo.it) *)
+(* *)
+(* Coq Exportation to XML *)
+(* *)
+(******************************************************************************)
+
+This Coq module has been developed by Claudio Sacerdoti Coen
+<sacerdot@cs.unibo.it> as a developer of projects HELM and MoWGLI.
+
+Project HELM (for Hypertextual Electronic Library of Mathematics) is a
+project developed at the Department of Computer Science, University of Bologna;
+http://helm.cs.unibo.it
+
+Project MoWGLI (Mathematics on the Web: Get It by Logics and Interfaces)
+is a UE IST project that generalizes and extends the HELM project;
+http://mowgli.cs.unibo.it
+
+The author is interested in any possible usage of the module.
+So, if you plan to use the module, please send him an e-mail.
+
+The licensing policy applied to the module is the same as for the whole Coq
+distribution.
diff --git a/plugins/xml/README b/plugins/xml/README
new file mode 100644
index 00000000..a45dd31a
--- /dev/null
+++ b/plugins/xml/README
@@ -0,0 +1,254 @@
+(******************************************************************************)
+(* Copyright (C) 2000-2004, Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* Project Helm (http://helm.cs.unibo.it) *)
+(* Project MoWGLI (http://mowgli.cs.unibo.it) *)
+(* *)
+(* Coq Exportation to XML *)
+(* *)
+(******************************************************************************)
+
+This module provides commands to export a piece of Coq library in XML format.
+Only the information relevant to proof-checking and proof-rendering is exported,
+i.e. only the CIC proof objects (lambda-terms).
+
+This document is tructured in the following way:
+ 1. User documentation
+ 1.1. New vernacular commands available
+ 1.2. New coqc/coqtop flags and suggested usage
+ 1.3. How to exploit the XML files
+ 2. Technical informations
+ 2.1. Inner-types
+ 2.2. CIC with Explicit Named Substitutions
+ 2.3. The CIC with Explicit Named Substitutions XML DTD
+
+================================================================================
+ USER DOCUMENTATION
+================================================================================
+
+=======================================
+1.1. New vernacular commands available:
+=======================================
+
+The new commands are:
+
+ Print XML qualid. It prints in XML (to standard output) the
+ object whose qualified name is qualid and
+ its inner-types (see Sect. 2.1).
+ The inner-types are always printed
+ in their own XML file. If the object is a
+ constant, its type and body are also printed
+ as two distinct XML files.
+ The object printed is always the most
+ discharged form of the object (see
+ the Section command of the Coq manual).
+
+ Print XML File "filename" qualid. Similar to "Print XML qualid". The generated
+ files are stored on the hard-disk using the
+ base file name "filename".
+
+ Show XML Proof. It prints in XML the current proof in
+ progress. Its inner-types are also printed.
+
+ Show XML File "filename" Proof. Similar to "Show XML Proof". The generated
+ files are stored on the hard-disk using
+ the base file name "filename".
+
+ The verbosity of the previous commands is raised if the configuration
+ parameter verbose of xmlcommand.ml is set to true at compile time.
+
+==============================================
+1.2. New coqc/coqtop flags and suggested usage
+==============================================
+
+ The following flag has been added to coqc and coqtop:
+
+ -xml export XML files either to the hierarchy rooted in
+ the directory $COQ_XML_LIBRARY_ROOT (if the environment
+ variable is set) or to stdout (if unset)
+
+ If the flag is set, every definition or declaration is immediately
+ exported to XML. The XML files describe the user-provided non-discharged
+ form of the definition or declaration.
+
+
+ The coq_makefile utility has also been modified to easily allow XML
+ exportation:
+
+ make COQ_XML=-xml (or, equivalently, setting the environment
+ variable COQ_XML)
+
+
+ The suggested usage of the module is the following:
+
+ 1. add to your own contribution a valid Make file and use coq_makefile
+ to generate the Makefile from the Make file.
+ *WARNING:* Since logical names are used to structure the XML hierarchy,
+ always add to the Make file at least one "-R" option to map physical
+ file names to logical module paths. See the Coq manual for further
+ informations on the -R flag.
+ 2. set $COQ_XML_LIBRARY_ROOT to the directory where the XML file hierarchy
+ must be physically rooted.
+ 3. compile your contribution with "make COQ_XML=-xml"
+
+
+=================================
+1.3. How to exploit the XML files
+=================================
+
+ Once the information is exported to XML, it becomes possible to implement
+ services that are completely Coq-independent. Projects HELM and MoWGLI
+ already provide rendering, searching and data mining functionalities.
+
+ In particular, the standard library and contributions of Coq can be
+ browsed and searched on the HELM web site:
+
+ http://helm.cs.unibo.it/library.html
+
+
+ If you want to publish your own contribution so that it is included in the
+ HELM library, use the MoWGLI prototype upload form:
+
+ http://mowgli.cs.unibo.it
+
+
+================================================================================
+ TECHNICAL INFORMATIONS
+================================================================================
+
+==========================
+2.1. Inner-types
+==========================
+
+In order to do proof-rendering (for example in natural language),
+some redundant typing information is required, i.e. the type of
+at least some of the subterms of the bodies and types. So, each
+new command described in section 1.1 print not only
+the object, but also another XML file in which you can find
+the type of all the subterms of the terms of the printed object
+which respect the following conditions:
+
+ 1. It's sort is Prop or CProp (the "sort"-like definition used in
+ CoRN to type computationally relevant predicative propositions).
+ 2. It is not a cast or an atomic term, i.e. it's root is not a CAST, REL,
+ VAR, MUTCONSTR or CONST.
+ 3. If it's root is a LAMBDA, then the root's parent node is not a LAMBDA,
+ i.e. only the type of the outer LAMBDA of a block of nested LAMBDAs is
+ printed.
+
+The rationale for the 3rd condition is that the type of the inner LAMBDAs
+could be easily computed starting from the type of the outer LAMBDA; moreover,
+the types of the inner LAMBDAs requires a lot of disk/memory space: removing
+the 3rd condition leads to XML file that are two times as big as the ones
+exported appling the 3rd condition.
+
+==========================================
+2.2. CIC with Explicit Named Substitutions
+==========================================
+
+The exported files are and XML encoding of the lambda-terms used by the
+Coq system. The implementative details of the Coq system are hidden as much
+as possible, so that the XML DTD is a straightforward encoding of the
+Calculus of (Co)Inductive Constructions.
+
+Nevertheless, there is a feature of the Coq system that can not be
+hidden in a completely satisfactory way: discharging. In Coq it is possible
+to open a section, declare variables and use them in the rest of the section
+as if they were axiom declarations. Once the section is closed, every definition
+and theorem in the section is discharged by abstracting it over the section
+variables. Variable declarations as well as section declarations are entirely
+dropped. Since we are interested in an XML encoding of definitions and
+theorems as close as possible to those directly provided the user, we
+do not want to export discharged forms. Exporting non-discharged theorem
+and definitions together with theorems that rely on the discharged forms
+obliges the tools that work on the XML encoding to implement discharging to
+achieve logical consistency. Moreover, the rendering of the files can be
+misleading, since hyperlinks can be shown between occurrences of the discharge
+form of a definition and the non-discharged definition, that are different
+objects.
+
+To overcome the previous limitations, Claudio Sacerdoti Coen developed in his
+PhD. thesis an extension of CIC, called Calculus of (Co)Inductive Constructions
+with Explicit Named Substitutions, that is a slight extension of CIC where
+discharging is not necessary. The DTD of the exported XML files describes
+constants, inductive types and variables of the Calculus of (Co)Inductive
+Constructions with Explicit Named Substitions. The conversion to the new
+calculus is performed during the exportation phase.
+
+The following example shows a very small Coq development together with its
+version in CIC with Explicit Named Substitutions.
+
+# CIC version: #
+Section S.
+ Variable A : Prop.
+
+ Definition impl := A -> A.
+
+ Theorem t : impl. (* uses the undischarged form of impl *)
+ Proof.
+ exact (fun (a:A) => a).
+ Qed.
+
+End S.
+
+Theorem t' : (impl False). (* uses the discharged form of impl *)
+ Proof.
+ exact (t False). (* uses the discharged form of t *)
+ Qed.
+
+# Corresponding CIC with Explicit Named Substitutions version: #
+Section S.
+ Variable A : Prop.
+
+ Definition impl(A) := A -> A. (* theorems and definitions are
+ explicitly abstracted over the
+ variables. The name is sufficient
+ to completely describe the abstraction *)
+
+ Theorem t(A) : impl. (* impl where A is not instantiated *)
+ Proof.
+ exact (fun (a:A) => a).
+ Qed.
+
+End S.
+
+Theorem t'() : impl{False/A}. (* impl where A is instantiated with False
+ Notice that t' does not depend on A *)
+ Proof.
+ exact t{False/A}. (* t where A is instantiated with False *)
+ Qed.
+
+Further details on the typing and reduction rules of the calculus can be
+found in Claudio Sacerdoti Coen PhD. dissertation, where the consistency
+of the calculus is also proved.
+
+======================================================
+2.3. The CIC with Explicit Named Substitutions XML DTD
+======================================================
+
+A copy of the DTD can be found in the file "cic.dtd".
+
+<ConstantType> is the root element of the files that correspond to
+ constant types.
+<ConstantBody> is the root element of the files that correspond to
+ constant bodies. It is used only for closed definitions and
+ theorems (i.e. when no metavariable occurs in the body
+ or type of the constant)
+<CurrentProof> is the root element of the file that correspond to
+ the body of a constant that depends on metavariables
+ (e.g. unfinished proofs)
+<Variable> is the root element of the files that correspond to variables
+<InductiveTypes> is the root element of the files that correspond to blocks
+ of mutually defined inductive definitions
+
+The elements
+ <LAMBDA>,<CAST>,<PROD>,<REL>,<SORT>,<APPLY>,<VAR>,<META>, <IMPLICIT>,<CONST>,
+ <LETIN>,<MUTIND>,<MUTCONSTRUCT>,<MUTCASE>,<FIX> and <COFIX>
+are used to encode the constructors of CIC. The sort or type attribute of the
+element, if present, is respectively the sort or the type of the term, that
+is a sort because of the typing rules of CIC.
+
+The element <instantiate> correspond to the application of an explicit named
+substitution to its first argument, that is a reference to a definition
+or declaration in the environment.
+
+All the other elements are just syntactic sugar.
diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml
new file mode 100644
index 00000000..40bc61bb
--- /dev/null
+++ b/plugins/xml/acic.ml
@@ -0,0 +1,108 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+open Names
+open Term
+
+(* Maps fron \em{unshared} [constr] to ['a]. *)
+module CicHash =
+ Hashtbl.Make
+ (struct
+ type t = Term.constr
+ let equal = (==)
+ let hash = Hashtbl.hash
+ end)
+;;
+
+type id = string (* the type of the (annotated) node identifiers *)
+type uri = string
+
+type 'constr context_entry =
+ Decl of 'constr (* Declaration *)
+ | Def of 'constr * 'constr (* Definition; the second argument (the type) *)
+ (* is not present in the DTD, but is needed *)
+ (* to use Coq functions during exportation. *)
+
+type 'constr hypothesis = identifier * 'constr context_entry
+type context = constr hypothesis list
+
+type conjecture = existential_key * context * constr
+type metasenv = conjecture list
+
+(* list of couples section path -- variables defined in that section *)
+type params = (string * uri list) list
+
+type obj =
+ Constant of string * (* id, *)
+ constr option * constr * (* value, type, *)
+ params (* parameters *)
+ | Variable of
+ string * constr option * constr * (* name, body, type *)
+ params (* parameters *)
+ | CurrentProof of
+ string * metasenv * (* name, conjectures, *)
+ constr * constr (* value, type *)
+ | InductiveDefinition of
+ inductiveType list * (* inductive types , *)
+ params * int (* parameters,n ind. pars*)
+and inductiveType =
+ identifier * bool * constr * (* typename, inductive, arity *)
+ constructor list (* constructors *)
+and constructor =
+ identifier * constr (* id, type *)
+
+type aconstr =
+ | ARel of id * int * id * identifier
+ | AVar of id * uri
+ | AEvar of id * existential_key * aconstr list
+ | ASort of id * sorts
+ | ACast of id * aconstr * aconstr
+ | AProds of (id * name * aconstr) list * aconstr
+ | ALambdas of (id * name * aconstr) list * aconstr
+ | ALetIns of (id * name * aconstr) list * aconstr
+ | AApp of id * aconstr list
+ | AConst of id * explicit_named_substitution * uri
+ | AInd of id * explicit_named_substitution * uri * int
+ | AConstruct of id * explicit_named_substitution * uri * int * int
+ | ACase of id * uri * int * aconstr * aconstr * aconstr list
+ | AFix of id * int * ainductivefun list
+ | ACoFix of id * int * acoinductivefun list
+and ainductivefun =
+ id * identifier * int * aconstr * aconstr
+and acoinductivefun =
+ id * identifier * aconstr * aconstr
+and explicit_named_substitution = id option * (uri * aconstr) list
+
+type acontext = (id * aconstr hypothesis) list
+type aconjecture = id * existential_key * acontext * aconstr
+type ametasenv = aconjecture list
+
+type aobj =
+ AConstant of id * string * (* id, *)
+ aconstr option * aconstr * (* value, type, *)
+ params (* parameters *)
+ | AVariable of id *
+ string * aconstr option * aconstr * (* name, body, type *)
+ params (* parameters *)
+ | ACurrentProof of id *
+ string * ametasenv * (* name, conjectures, *)
+ aconstr * aconstr (* value, type *)
+ | AInductiveDefinition of id *
+ anninductiveType list * (* inductive types , *)
+ params * int (* parameters,n ind. pars*)
+and anninductiveType =
+ id * identifier * bool * aconstr * (* typename, inductive, arity *)
+ annconstructor list (* constructors *)
+and annconstructor =
+ identifier * aconstr (* id, type *)
diff --git a/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4
new file mode 100644
index 00000000..fb40ed86
--- /dev/null
+++ b/plugins/xml/acic2Xml.ml4
@@ -0,0 +1,363 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+(*CSC codice cut & paste da cicPp e xmlcommand *)
+
+exception ImpossiblePossible;;
+exception NotImplemented;;
+let dtdname = "http://mowgli.cs.unibo.it/dtd/cic.dtd";;
+let typesdtdname = "http://mowgli.cs.unibo.it/dtd/cictypes.dtd";;
+
+let rec find_last_id =
+ function
+ [] -> Util.anomaly "find_last_id: empty list"
+ | [id,_,_] -> id
+ | _::tl -> find_last_id tl
+;;
+
+let export_existential = string_of_int
+
+let print_term ids_to_inner_sorts =
+ let rec aux =
+ let module A = Acic in
+ let module N = Names in
+ let module X = Xml in
+ function
+ A.ARel (id,n,idref,b) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ X.xml_empty "REL"
+ ["value",(string_of_int n) ; "binder",(N.string_of_id b) ;
+ "id",id ; "idref",idref; "sort",sort]
+ | A.AVar (id,uri) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort]
+ | A.AEvar (id,n,l) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ X.xml_nempty "META"
+ ["no",(export_existential n) ; "id",id ; "sort",sort]
+ (List.fold_left
+ (fun i t ->
+ [< i ; X.xml_nempty "substitution" [] (aux t) >]
+ ) [< >] (List.rev l))
+ | A.ASort (id,s) ->
+ let string_of_sort =
+ match Term.family_of_sort s with
+ Term.InProp -> "Prop"
+ | Term.InSet -> "Set"
+ | Term.InType -> "Type"
+ in
+ X.xml_empty "SORT" ["value",string_of_sort ; "id",id]
+ | A.AProds (prods,t) ->
+ let last_id = find_last_id prods in
+ let sort = Hashtbl.find ids_to_inner_sorts last_id in
+ X.xml_nempty "PROD" ["type",sort]
+ [< List.fold_left
+ (fun i (id,binder,s) ->
+ let sort =
+ Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
+ in
+ let attrs =
+ ("id",id)::("type",sort)::
+ match binder with
+ Names.Anonymous -> []
+ | Names.Name b -> ["binder",Names.string_of_id b]
+ in
+ [< X.xml_nempty "decl" attrs (aux s) ; i >]
+ ) [< >] prods ;
+ X.xml_nempty "target" [] (aux t)
+ >]
+ | A.ACast (id,v,t) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ X.xml_nempty "CAST" ["id",id ; "sort",sort]
+ [< X.xml_nempty "term" [] (aux v) ;
+ X.xml_nempty "type" [] (aux t)
+ >]
+ | A.ALambdas (lambdas,t) ->
+ let last_id = find_last_id lambdas in
+ let sort = Hashtbl.find ids_to_inner_sorts last_id in
+ X.xml_nempty "LAMBDA" ["sort",sort]
+ [< List.fold_left
+ (fun i (id,binder,s) ->
+ let sort =
+ Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
+ in
+ let attrs =
+ ("id",id)::("type",sort)::
+ match binder with
+ Names.Anonymous -> []
+ | Names.Name b -> ["binder",Names.string_of_id b]
+ in
+ [< X.xml_nempty "decl" attrs (aux s) ; i >]
+ ) [< >] lambdas ;
+ X.xml_nempty "target" [] (aux t)
+ >]
+ | A.ALetIns (letins,t) ->
+ let last_id = find_last_id letins in
+ let sort = Hashtbl.find ids_to_inner_sorts last_id in
+ X.xml_nempty "LETIN" ["sort",sort]
+ [< List.fold_left
+ (fun i (id,binder,s) ->
+ let sort =
+ Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
+ in
+ let attrs =
+ ("id",id)::("sort",sort)::
+ match binder with
+ Names.Anonymous -> assert false
+ | Names.Name b -> ["binder",Names.string_of_id b]
+ in
+ [< X.xml_nempty "def" attrs (aux s) ; i >]
+ ) [< >] letins ;
+ X.xml_nempty "target" [] (aux t)
+ >]
+ | A.AApp (id,li) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ X.xml_nempty "APPLY" ["id",id ; "sort",sort]
+ [< (List.fold_left (fun i x -> [< i ; (aux x) >]) [<>] li)
+ >]
+ | A.AConst (id,subst,uri) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ let attrs = ["uri", uri ; "id",id ; "sort",sort] in
+ aux_subst (X.xml_empty "CONST" attrs) subst
+ | A.AInd (id,subst,uri,i) ->
+ let attrs = ["uri", uri ; "noType",(string_of_int i) ; "id",id] in
+ aux_subst (X.xml_empty "MUTIND" attrs) subst
+ | A.AConstruct (id,subst,uri,i,j) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ let attrs =
+ ["uri", uri ;
+ "noType",(string_of_int i) ; "noConstr",(string_of_int j) ;
+ "id",id ; "sort",sort]
+ in
+ aux_subst (X.xml_empty "MUTCONSTRUCT" attrs) subst
+ | A.ACase (id,uri,typeno,ty,te,patterns) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ X.xml_nempty "MUTCASE"
+ ["uriType", uri ;
+ "noType", (string_of_int typeno) ;
+ "id", id ; "sort",sort]
+ [< X.xml_nempty "patternsType" [] [< (aux ty) >] ;
+ X.xml_nempty "inductiveTerm" [] [< (aux te) >] ;
+ List.fold_left
+ (fun i x -> [< i ; X.xml_nempty "pattern" [] [< aux x >] >])
+ [<>] patterns
+ >]
+ | A.AFix (id, no, funs) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ X.xml_nempty "FIX"
+ ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
+ [< List.fold_left
+ (fun i (id,fi,ai,ti,bi) ->
+ [< i ;
+ X.xml_nempty "FixFunction"
+ ["id",id ; "name", (Names.string_of_id fi) ;
+ "recIndex", (string_of_int ai)]
+ [< X.xml_nempty "type" [] [< aux ti >] ;
+ X.xml_nempty "body" [] [< aux bi >]
+ >]
+ >]
+ ) [<>] funs
+ >]
+ | A.ACoFix (id,no,funs) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ X.xml_nempty "COFIX"
+ ["noFun", (string_of_int no) ; "id",id ; "sort",sort]
+ [< List.fold_left
+ (fun i (id,fi,ti,bi) ->
+ [< i ;
+ X.xml_nempty "CofixFunction"
+ ["id",id ; "name", Names.string_of_id fi]
+ [< X.xml_nempty "type" [] [< aux ti >] ;
+ X.xml_nempty "body" [] [< aux bi >]
+ >]
+ >]
+ ) [<>] funs
+ >]
+ and aux_subst target (id,subst) =
+ if subst = [] then
+ target
+ else
+ Xml.xml_nempty "instantiate"
+ (match id with None -> [] | Some id -> ["id",id])
+ [< target ;
+ List.fold_left
+ (fun i (uri,arg) ->
+ [< i ; Xml.xml_nempty "arg" ["relUri", uri] (aux arg) >]
+ ) [<>] subst
+ >]
+ in
+ aux
+;;
+
+let param_attribute_of_params params =
+ List.fold_right
+ (fun (path,l) i ->
+ List.fold_right
+ (fun x i ->path ^ "/" ^ x ^ ".var" ^ match i with "" -> "" | i' -> " " ^ i'
+ ) l "" ^ match i with "" -> "" | i' -> " " ^ i'
+ ) params ""
+;;
+
+let print_object uri ids_to_inner_sorts =
+ let rec aux =
+ let module A = Acic in
+ let module X = Xml in
+ function
+ A.ACurrentProof (id,n,conjectures,bo,ty) ->
+ let xml_for_current_proof_body =
+(*CSC: Should the CurrentProof also have the list of variables it depends on? *)
+(*CSC: I think so. Not implemented yet. *)
+ X.xml_nempty "CurrentProof" ["of",uri ; "id", id]
+ [< List.fold_left
+ (fun i (cid,n,canonical_context,t) ->
+ [< i ;
+ X.xml_nempty "Conjecture"
+ ["id", cid ; "no",export_existential n]
+ [< List.fold_left
+ (fun i (hid,t) ->
+ [< (match t with
+ n,A.Decl t ->
+ X.xml_nempty "Decl"
+ ["id",hid;"name",Names.string_of_id n]
+ (print_term ids_to_inner_sorts t)
+ | n,A.Def (t,_) ->
+ X.xml_nempty "Def"
+ ["id",hid;"name",Names.string_of_id n]
+ (print_term ids_to_inner_sorts t)
+ ) ;
+ i
+ >]
+ ) [< >] canonical_context ;
+ X.xml_nempty "Goal" []
+ (print_term ids_to_inner_sorts t)
+ >]
+ >])
+ [<>] (List.rev conjectures) ;
+ X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >]
+ in
+ let xml_for_current_proof_type =
+ X.xml_nempty "ConstantType" ["name",n ; "id", id]
+ (print_term ids_to_inner_sorts ty)
+ in
+ let xmlbo =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^dtdname ^"\">\n");
+ xml_for_current_proof_body
+ >] in
+ let xmlty =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata
+ ("<!DOCTYPE ConstantType SYSTEM \"" ^ dtdname ^ "\">\n");
+ xml_for_current_proof_type
+ >]
+ in
+ xmlty, Some xmlbo
+ | A.AConstant (id,n,bo,ty,params) ->
+ let params' = param_attribute_of_params params in
+ let xmlbo =
+ match bo with
+ None -> None
+ | Some bo ->
+ Some
+ [< X.xml_cdata
+ "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata
+ ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ;
+ X.xml_nempty "ConstantBody"
+ ["for",uri ; "params",params' ; "id", id]
+ [< print_term ids_to_inner_sorts bo >]
+ >]
+ in
+ let xmlty =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^dtdname ^"\">\n");
+ X.xml_nempty "ConstantType"
+ ["name",n ; "params",params' ; "id", id]
+ [< print_term ids_to_inner_sorts ty >]
+ >]
+ in
+ xmlty, xmlbo
+ | A.AVariable (id,n,bo,ty,params) ->
+ let params' = param_attribute_of_params params in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n") ;
+ X.xml_nempty "Variable" ["name",n ; "params",params' ; "id", id]
+ [< (match bo with
+ None -> [<>]
+ | Some bo ->
+ X.xml_nempty "body" []
+ (print_term ids_to_inner_sorts bo)
+ ) ;
+ X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty)
+ >]
+ >], None
+ | A.AInductiveDefinition (id,tys,params,nparams) ->
+ let params' = param_attribute_of_params params in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^
+ dtdname ^ "\">\n") ;
+ X.xml_nempty "InductiveDefinition"
+ ["noParams",string_of_int nparams ;
+ "id",id ;
+ "params",params']
+ [< (List.fold_left
+ (fun i (id,typename,finite,arity,cons) ->
+ [< i ;
+ X.xml_nempty "InductiveType"
+ ["id",id ; "name",Names.string_of_id typename ;
+ "inductive",(string_of_bool finite)
+ ]
+ [< X.xml_nempty "arity" []
+ (print_term ids_to_inner_sorts arity) ;
+ (List.fold_left
+ (fun i (name,lc) ->
+ [< i ;
+ X.xml_nempty "Constructor"
+ ["name",Names.string_of_id name]
+ (print_term ids_to_inner_sorts lc)
+ >]) [<>] cons
+ )
+ >]
+ >]
+ ) [< >] tys
+ )
+ >]
+ >], None
+ in
+ aux
+;;
+
+let print_inner_types curi ids_to_inner_sorts ids_to_inner_types =
+ let module C2A = Cic2acic in
+ let module X = Xml in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE InnerTypes SYSTEM \"" ^ typesdtdname ^"\">\n");
+ X.xml_nempty "InnerTypes" ["of",curi]
+ (Hashtbl.fold
+ (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x ->
+ [< x ;
+ X.xml_nempty "TYPE" ["of",id]
+ [< X.xml_nempty "synthesized" []
+ (print_term ids_to_inner_sorts synty) ;
+ match expty with
+ None -> [<>]
+ | Some expty' ->
+ X.xml_nempty "expected" []
+ (print_term ids_to_inner_sorts expty')
+ >]
+ >]
+ ) ids_to_inner_types [<>]
+ )
+ >]
+;;
diff --git a/plugins/xml/cic.dtd b/plugins/xml/cic.dtd
new file mode 100644
index 00000000..c8035cab
--- /dev/null
+++ b/plugins/xml/cic.dtd
@@ -0,0 +1,259 @@
+<?xml encoding="ISO-8859-1"?>
+
+<!-- Copyright (C) 2000-2004, HELM Team -->
+<!-- -->
+<!-- This file is part of HELM, an Hypertextual, Electronic -->
+<!-- Library of Mathematics, developed at the Computer Science -->
+<!-- Department, University of Bologna, Italy. -->
+<!-- -->
+<!-- HELM is free software; you can redistribute it and/or -->
+<!-- modify it under the terms of the GNU General Public License -->
+<!-- as published by the Free Software Foundation; either version 2 -->
+<!-- of the License, or (at your option) any later version. -->
+<!-- -->
+<!-- HELM is distributed in the hope that it will be useful, -->
+<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of -->
+<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -->
+<!-- GNU General Public License for more details. -->
+<!-- -->
+<!-- You should have received a copy of the GNU General Public License -->
+<!-- along with HELM; if not, write to the Free Software -->
+<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, -->
+<!-- MA 02111-1307, USA. -->
+<!-- -->
+<!-- For details, see the HELM World-Wide-Web page, -->
+<!-- http://cs.unibo.it/helm/. -->
+
+<!-- DTD FOR CIC OBJECTS: -->
+
+<!-- CIC term declaration -->
+
+<!ENTITY % term '(LAMBDA|CAST|PROD|REL|SORT|APPLY|VAR|META|IMPLICIT|CONST|
+ LETIN|MUTIND|MUTCONSTRUCT|MUTCASE|FIX|COFIX|instantiate)'>
+
+<!-- CIC sorts -->
+
+<!ENTITY % sort '(Prop|Set|Type|CProp)'>
+
+<!-- CIC sequents -->
+
+<!ENTITY % sequent '((Decl|Def|Hidden)*,Goal)'>
+
+<!-- CIC objects: -->
+
+<!ELEMENT ConstantType %term;>
+<!ATTLIST ConstantType
+ name CDATA #REQUIRED
+ params CDATA #REQUIRED
+ id ID #REQUIRED>
+
+<!ELEMENT ConstantBody %term;>
+<!ATTLIST ConstantBody
+ for CDATA #REQUIRED
+ params CDATA #REQUIRED
+ id ID #REQUIRED>
+
+<!ELEMENT CurrentProof (Conjecture*,body)>
+<!ATTLIST CurrentProof
+ of CDATA #REQUIRED
+ id ID #REQUIRED>
+
+<!ELEMENT InductiveDefinition (InductiveType+)>
+<!ATTLIST InductiveDefinition
+ noParams NMTOKEN #REQUIRED
+ params CDATA #REQUIRED
+ id ID #REQUIRED>
+
+<!ELEMENT Variable (body?,type)>
+<!ATTLIST Variable
+ name CDATA #REQUIRED
+ params CDATA #REQUIRED
+ id ID #REQUIRED>
+
+<!ELEMENT Sequent %sequent;>
+<!ATTLIST Sequent
+ no NMTOKEN #REQUIRED
+ id ID #REQUIRED>
+
+<!-- Elements used in CIC objects, which are not terms: -->
+
+<!ELEMENT InductiveType (arity,Constructor*)>
+<!ATTLIST InductiveType
+ name CDATA #REQUIRED
+ inductive (true|false) #REQUIRED
+ id ID #REQUIRED>
+
+<!ELEMENT Conjecture %sequent;>
+<!ATTLIST Conjecture
+ no NMTOKEN #REQUIRED
+ id ID #REQUIRED>
+
+<!ELEMENT Constructor %term;>
+<!ATTLIST Constructor
+ name CDATA #REQUIRED>
+
+<!ELEMENT Decl %term;>
+<!ATTLIST Decl
+ name CDATA #IMPLIED
+ id ID #REQUIRED>
+
+<!ELEMENT Def %term;>
+<!ATTLIST Def
+ name CDATA #IMPLIED
+ id ID #REQUIRED>
+
+<!ELEMENT Hidden EMPTY>
+<!ATTLIST Hidden
+ id ID #REQUIRED>
+
+<!ELEMENT Goal %term;>
+
+<!-- CIC terms: -->
+
+<!ELEMENT LAMBDA (decl*,target)>
+<!ATTLIST LAMBDA
+ sort %sort; #REQUIRED>
+
+<!ELEMENT LETIN (def*,target)>
+<!ATTLIST LETIN
+ sort %sort; #REQUIRED>
+
+<!ELEMENT PROD (decl*,target)>
+<!ATTLIST PROD
+ type %sort; #REQUIRED>
+
+<!ELEMENT CAST (term,type)>
+<!ATTLIST CAST
+ id ID #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!ELEMENT REL EMPTY>
+<!ATTLIST REL
+ value NMTOKEN #REQUIRED
+ binder CDATA #REQUIRED
+ id ID #REQUIRED
+ idref IDREF #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!ELEMENT SORT EMPTY>
+<!ATTLIST SORT
+ value CDATA #REQUIRED
+ id ID #REQUIRED>
+
+<!ELEMENT APPLY (%term;)+>
+<!ATTLIST APPLY
+ id ID #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!ELEMENT VAR EMPTY>
+<!ATTLIST VAR
+ uri CDATA #REQUIRED
+ id ID #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!-- The substitutions are ordered by increasing DeBrujin -->
+<!-- index. An empty substitution means that that index is -->
+<!-- not accessible. -->
+<!ELEMENT META (substitution*)>
+<!ATTLIST META
+ no NMTOKEN #REQUIRED
+ id ID #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!ELEMENT IMPLICIT EMPTY>
+<!ATTLIST IMPLICIT
+ id ID #REQUIRED>
+
+<!ELEMENT CONST EMPTY>
+<!ATTLIST CONST
+ uri CDATA #REQUIRED
+ id ID #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!ELEMENT MUTIND EMPTY>
+<!ATTLIST MUTIND
+ uri CDATA #REQUIRED
+ noType NMTOKEN #REQUIRED
+ id ID #REQUIRED>
+
+<!ELEMENT MUTCONSTRUCT EMPTY>
+<!ATTLIST MUTCONSTRUCT
+ uri CDATA #REQUIRED
+ noType NMTOKEN #REQUIRED
+ noConstr NMTOKEN #REQUIRED
+ id ID #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!ELEMENT MUTCASE (patternsType,inductiveTerm,pattern*)>
+<!ATTLIST MUTCASE
+ uriType CDATA #REQUIRED
+ noType NMTOKEN #REQUIRED
+ id ID #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!ELEMENT FIX (FixFunction+)>
+<!ATTLIST FIX
+ noFun NMTOKEN #REQUIRED
+ id ID #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!ELEMENT COFIX (CofixFunction+)>
+<!ATTLIST COFIX
+ noFun NMTOKEN #REQUIRED
+ id ID #REQUIRED
+ sort %sort; #REQUIRED>
+
+<!-- Elements used in CIC terms: -->
+
+<!ELEMENT FixFunction (type,body)>
+<!ATTLIST FixFunction
+ name CDATA #REQUIRED
+ id ID #REQUIRED
+ recIndex NMTOKEN #REQUIRED>
+
+<!ELEMENT CofixFunction (type,body)>
+<!ATTLIST CofixFunction
+ id ID #REQUIRED
+ name CDATA #REQUIRED>
+
+<!ELEMENT substitution ((%term;)?)>
+
+<!-- Explicit named substitutions: -->
+
+<!ELEMENT instantiate ((CONST|MUTIND|MUTCONSTRUCT|VAR),arg+)>
+<!ATTLIST instantiate
+ id ID #IMPLIED>
+
+<!-- Sintactic sugar for CIC terms and for CIC objects: -->
+
+<!ELEMENT arg %term;>
+<!ATTLIST arg
+ relUri CDATA #REQUIRED>
+
+<!ELEMENT decl %term;>
+<!ATTLIST decl
+ id ID #REQUIRED
+ type %sort; #REQUIRED
+ binder CDATA #IMPLIED>
+
+<!ELEMENT def %term;>
+<!ATTLIST def
+ id ID #REQUIRED
+ sort %sort; #REQUIRED
+ binder CDATA #IMPLIED>
+
+<!ELEMENT target %term;>
+
+<!ELEMENT term %term;>
+
+<!ELEMENT type %term;>
+
+<!ELEMENT arity %term;>
+
+<!ELEMENT patternsType %term;>
+
+<!ELEMENT inductiveTerm %term;>
+
+<!ELEMENT pattern %term;>
+
+<!ELEMENT body %term;>
diff --git a/plugins/xml/cic2Xml.ml b/plugins/xml/cic2Xml.ml
new file mode 100644
index 00000000..981503a6
--- /dev/null
+++ b/plugins/xml/cic2Xml.ml
@@ -0,0 +1,17 @@
+let print_xml_term ch env sigma cic =
+ let ids_to_terms = Hashtbl.create 503 in
+ let constr_to_ids = Acic.CicHash.create 503 in
+ let ids_to_father_ids = Hashtbl.create 503 in
+ let ids_to_inner_sorts = Hashtbl.create 503 in
+ let ids_to_inner_types = Hashtbl.create 503 in
+ let seed = ref 0 in
+ let acic =
+ Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids
+ ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
+ env [] sigma (Unshare.unshare cic) None in
+ let xml = Acic2Xml.print_term ids_to_inner_sorts acic in
+ Xml.pp_ch xml ch
+;;
+
+Tacinterp.declare_xml_printer print_xml_term
+;;
diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml
new file mode 100644
index 00000000..a80ceb0f
--- /dev/null
+++ b/plugins/xml/cic2acic.ml
@@ -0,0 +1,942 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+(* Utility Functions *)
+
+exception TwoModulesWhoseDirPathIsOneAPrefixOfTheOther;;
+let get_module_path_of_full_path path =
+ let dirpath = fst (Libnames.repr_path path) in
+ let modules = Lib.library_dp () :: (Library.loaded_libraries ()) in
+ match
+ List.filter
+ (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules
+ with
+ [] ->
+ Pp.warning ("Modules not supported: reference to "^
+ Libnames.string_of_path path^" will be wrong");
+ dirpath
+ | [modul] -> modul
+ | _ ->
+ raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther
+;;
+
+(*CSC: Problem: here we are using the wrong (???) hypothesis that there do *)
+(*CSC: not exist two modules whose dir_paths are one a prefix of the other *)
+let remove_module_dirpath_from_dirpath ~basedir dir =
+ let module Ln = Libnames in
+ if Ln.is_dirpath_prefix_of basedir dir then
+ let ids = Names.repr_dirpath dir in
+ let rec remove_firsts n l =
+ match n,l with
+ (0,l) -> l
+ | (n,he::tl) -> remove_firsts (n-1) tl
+ | _ -> assert false
+ in
+ let ids' =
+ List.rev
+ (remove_firsts
+ (List.length (Names.repr_dirpath basedir))
+ (List.rev ids))
+ in
+ ids'
+ else Names.repr_dirpath dir
+;;
+
+
+let get_uri_of_var v pvars =
+ let module D = Decls in
+ let module N = Names in
+ let rec search_in_open_sections =
+ function
+ [] -> Util.error ("Variable "^v^" not found")
+ | he::tl as modules ->
+ let dirpath = N.make_dirpath modules in
+ if List.mem (N.id_of_string v) (D.last_section_hyps dirpath) then
+ modules
+ else
+ search_in_open_sections tl
+ in
+ let path =
+ if List.mem v pvars then
+ []
+ else
+ search_in_open_sections (N.repr_dirpath (Lib.cwd ()))
+ in
+ "cic:" ^
+ List.fold_left
+ (fun i x -> "/" ^ N.string_of_id x ^ i) "" path
+;;
+
+type tag =
+ Constant of Names.constant
+ | Inductive of Names.mutual_inductive
+ | Variable of Names.kernel_name
+;;
+
+type etag =
+ TConstant
+ | TInductive
+ | TVariable
+;;
+
+let etag_of_tag =
+ function
+ Constant _ -> TConstant
+ | Inductive _ -> TInductive
+ | Variable _ -> TVariable
+
+let ext_of_tag =
+ function
+ TConstant -> "con"
+ | TInductive -> "ind"
+ | TVariable -> "var"
+;;
+
+exception FunctorsXMLExportationNotImplementedYet;;
+
+let subtract l1 l2 =
+ let l1' = List.rev (Names.repr_dirpath l1) in
+ let l2' = List.rev (Names.repr_dirpath l2) in
+ let rec aux =
+ function
+ he::tl when tl = l2' -> [he]
+ | he::tl -> he::(aux tl)
+ | [] -> assert (l2' = []) ; []
+ in
+ Names.make_dirpath (List.rev (aux l1'))
+;;
+
+let token_list_of_path dir id tag =
+ let module N = Names in
+ let token_list_of_dirpath dirpath =
+ List.rev_map N.string_of_id (N.repr_dirpath dirpath) in
+ token_list_of_dirpath dir @ [N.string_of_id id ^ "." ^ (ext_of_tag tag)]
+
+let token_list_of_kernel_name tag =
+ let module N = Names in
+ let module LN = Libnames in
+ let id,dir = match tag with
+ | Variable kn ->
+ N.id_of_label (N.label kn), Lib.cwd ()
+ | Constant con ->
+ N.id_of_label (N.con_label con),
+ Lib.remove_section_part (LN.ConstRef con)
+ | Inductive kn ->
+ N.id_of_label (N.mind_label kn),
+ Lib.remove_section_part (LN.IndRef (kn,0))
+ in
+ token_list_of_path dir id (etag_of_tag tag)
+;;
+
+let uri_of_kernel_name tag =
+ let tokens = token_list_of_kernel_name tag in
+ "cic:/" ^ String.concat "/" tokens
+
+let uri_of_declaration id tag =
+ let module LN = Libnames in
+ let dir = LN.pop_dirpath_n (Lib.sections_depth ()) (Lib.cwd ()) in
+ let tokens = token_list_of_path dir id tag in
+ "cic:/" ^ String.concat "/" tokens
+
+(* Special functions for handling of CCorn's CProp "sort" *)
+
+type sort =
+ Coq_sort of Term.sorts_family
+ | CProp
+;;
+
+let prerr_endline _ = ();;
+
+let family_of_term ty =
+ match Term.kind_of_term ty with
+ Term.Sort s -> Coq_sort (Term.family_of_sort s)
+ | Term.Const _ -> CProp (* I could check that the constant is CProp *)
+ | _ -> Util.anomaly "family_of_term"
+;;
+
+module CPropRetyping =
+ struct
+ module T = Term
+
+ let outsort env sigma t =
+ family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma t)
+
+ let rec subst_type env sigma typ = function
+ | [] -> typ
+ | h::rest ->
+ match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma typ) with
+ | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest
+ | _ -> Util.anomaly "Non-functional construction"
+
+
+ let sort_of_atomic_type env sigma ft args =
+ let rec concl_of_arity env ar =
+ match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with
+ | T.Prod (na, t, b) -> concl_of_arity (Environ.push_rel (na,None,t) env) b
+ | T.Sort s -> Coq_sort (T.family_of_sort s)
+ | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args))
+ in concl_of_arity env ft
+
+let typeur sigma metamap =
+ let rec type_of env cstr=
+ match Term.kind_of_term cstr with
+ | T.Meta n ->
+ (try T.strip_outer_cast (List.assoc n metamap)
+ with Not_found -> Util.anomaly "type_of: this is not a well-typed term")
+ | T.Rel n ->
+ let (_,_,ty) = Environ.lookup_rel n env in
+ T.lift n ty
+ | T.Var id ->
+ (try
+ let (_,_,ty) = Environ.lookup_named id env in
+ ty
+ with Not_found ->
+ Util.anomaly ("type_of: variable "^(Names.string_of_id id)^" unbound"))
+ | T.Const c ->
+ let cb = Environ.lookup_constant c env in
+ Typeops.type_of_constant_type env (cb.Declarations.const_type)
+ | T.Evar ev -> Evd.existential_type sigma ev
+ | T.Ind ind -> Inductiveops.type_of_inductive env ind
+ | T.Construct cstr -> Inductiveops.type_of_constructor env cstr
+ | T.Case (_,p,c,lf) ->
+ let Inductiveops.IndType(_,realargs) =
+ try Inductiveops.find_rectype env sigma (type_of env c)
+ with Not_found -> Util.anomaly "type_of: Bad recursive type" in
+ let t = Reductionops.whd_beta sigma (T.applist (p, realargs)) in
+ (match Term.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma (type_of env t)) with
+ | T.Prod _ -> Reductionops.whd_beta sigma (T.applist (t, [c]))
+ | _ -> t)
+ | T.Lambda (name,c1,c2) ->
+ T.mkProd (name, c1, type_of (Environ.push_rel (name,None,c1) env) c2)
+ | T.LetIn (name,b,c1,c2) ->
+ T.subst1 b (type_of (Environ.push_rel (name,Some b,c1) env) c2)
+ | T.Fix ((_,i),(_,tys,_)) -> tys.(i)
+ | T.CoFix (i,(_,tys,_)) -> tys.(i)
+ | T.App(f,args)->
+ T.strip_outer_cast
+ (subst_type env sigma (type_of env f) (Array.to_list args))
+ | T.Cast (c,_, t) -> t
+ | T.Sort _ | T.Prod _ ->
+ match sort_of env cstr with
+ Coq_sort T.InProp -> T.mkProp
+ | Coq_sort T.InSet -> T.mkSet
+ | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *)
+ | CProp -> T.mkConst DoubleTypeInference.cprop
+
+ and sort_of env t =
+ match Term.kind_of_term t with
+ | T.Cast (c,_, s) when T.isSort s -> family_of_term s
+ | T.Sort (T.Prop c) -> Coq_sort T.InType
+ | T.Sort (T.Type u) -> Coq_sort T.InType
+ | T.Prod (name,t,c2) ->
+ (match sort_of env t,sort_of (Environ.push_rel (name,None,t) env) c2 with
+ | _, (Coq_sort T.InProp as s) -> s
+ | Coq_sort T.InProp, (Coq_sort T.InSet as s)
+ | Coq_sort T.InSet, (Coq_sort T.InSet as s) -> s
+ | Coq_sort T.InType, (Coq_sort T.InSet as s)
+ | CProp, (Coq_sort T.InSet as s) when
+ Environ.engagement env = Some Declarations.ImpredicativeSet -> s
+ | Coq_sort T.InType, Coq_sort T.InSet
+ | CProp, Coq_sort T.InSet -> Coq_sort T.InType
+ | _, (Coq_sort T.InType as s) -> s (*Type Univ.dummy_univ*)
+ | _, (CProp as s) -> s)
+ | T.App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args
+ | T.Lambda _ | T.Fix _ | T.Construct _ ->
+ Util.anomaly "sort_of: Not a type (1)"
+ | _ -> outsort env sigma (type_of env t)
+
+ and sort_family_of env t =
+ match T.kind_of_term t with
+ | T.Cast (c,_, s) when T.isSort s -> family_of_term s
+ | T.Sort (T.Prop c) -> Coq_sort T.InType
+ | T.Sort (T.Type u) -> Coq_sort T.InType
+ | T.Prod (name,t,c2) -> sort_family_of (Environ.push_rel (name,None,t) env) c2
+ | T.App(f,args) ->
+ sort_of_atomic_type env sigma (type_of env f) args
+ | T.Lambda _ | T.Fix _ | T.Construct _ ->
+ Util.anomaly "sort_of: Not a type (1)"
+ | _ -> outsort env sigma (type_of env t)
+
+ in type_of, sort_of, sort_family_of
+
+ let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c
+ let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c
+
+ end
+;;
+
+let get_sort_family_of env evar_map ty =
+ CPropRetyping.get_sort_family_of env evar_map ty
+;;
+
+let type_as_sort env evar_map ty =
+(* CCorn code *)
+ family_of_term (DoubleTypeInference.whd_betadeltaiotacprop env evar_map ty)
+;;
+
+let is_a_Prop =
+ function
+ "Prop"
+ | "CProp" -> true
+ | _ -> false
+;;
+
+(* Main Functions *)
+
+type anntypes =
+ {annsynthesized : Acic.aconstr ; annexpected : Acic.aconstr option}
+;;
+
+let gen_id seed =
+ let res = "i" ^ string_of_int !seed in
+ incr seed ;
+ res
+;;
+
+let fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids =
+ fun father t ->
+ let res = gen_id seed in
+ Hashtbl.add ids_to_father_ids res father ;
+ Hashtbl.add ids_to_terms res t ;
+ Acic.CicHash.add constr_to_ids t res ;
+ res
+;;
+
+let source_id_of_id id = "#source#" ^ id;;
+
+let acic_of_cic_context' computeinnertypes seed ids_to_terms constr_to_ids
+ ids_to_father_ids ids_to_inner_sorts ids_to_inner_types
+ ?(fake_dependent_products=false) env idrefs evar_map t expectedty
+=
+ let module D = DoubleTypeInference in
+ let module E = Environ in
+ let module N = Names in
+ let module A = Acic in
+ let module T = Term in
+ let fresh_id' = fresh_id seed ids_to_terms constr_to_ids ids_to_father_ids in
+ (* CSC: do you have any reasonable substitute for 503? *)
+ let terms_to_types = Acic.CicHash.create 503 in
+ D.double_type_of env evar_map t expectedty terms_to_types ;
+ let rec aux computeinnertypes father passed_lambdas_or_prods_or_letins env
+ idrefs ?(subst=None,[]) tt
+ =
+ let fresh_id'' = fresh_id' father tt in
+ let aux' = aux computeinnertypes (Some fresh_id'') [] in
+ let string_of_sort_family =
+ function
+ Coq_sort T.InProp -> "Prop"
+ | Coq_sort T.InSet -> "Set"
+ | Coq_sort T.InType -> "Type"
+ | CProp -> "CProp"
+ in
+ let string_of_sort t =
+ string_of_sort_family
+ (type_as_sort env evar_map t)
+ in
+ let ainnertypes,innertype,innersort,expected_available =
+ let {D.synthesized = synthesized; D.expected = expected} =
+ if computeinnertypes then
+try
+ Acic.CicHash.find terms_to_types tt
+with _ ->
+(*CSC: Warning: it really happens, for example in Ring_theory!!! *)
+Pp.ppnl (Pp.(++) (Pp.str "BUG: this subterm was not visited during the double-type-inference: ") (Printer.pr_lconstr tt)) ; assert false
+ else
+ (* We are already in an inner-type and Coscoy's double *)
+ (* type inference algorithm has not been applied. *)
+ (* We need to refresh the universes because we are doing *)
+ (* type inference on an already inferred type. *)
+ {D.synthesized =
+ Reductionops.nf_beta evar_map
+ (CPropRetyping.get_type_of env evar_map
+ (Termops.refresh_universes tt)) ;
+ D.expected = None}
+ in
+(* Debugging only:
+print_endline "TERMINE:" ; flush stdout ;
+Pp.ppnl (Printer.pr_lconstr tt) ; flush stdout ;
+print_endline "TIPO:" ; flush stdout ;
+Pp.ppnl (Printer.pr_lconstr synthesized) ; flush stdout ;
+print_endline "ENVIRONMENT:" ; flush stdout ;
+Pp.ppnl (Printer.pr_context_of env) ; flush stdout ;
+print_endline "FINE_ENVIRONMENT" ; flush stdout ;
+*)
+ let innersort =
+ let synthesized_innersort =
+ get_sort_family_of env evar_map synthesized
+ in
+ match expected with
+ None -> synthesized_innersort
+ | Some ty ->
+ let expected_innersort =
+ get_sort_family_of env evar_map ty
+ in
+ match expected_innersort, synthesized_innersort with
+ CProp, _
+ | _, CProp -> CProp
+ | _, _ -> expected_innersort
+ in
+(* Debugging only:
+print_endline "PASSATO" ; flush stdout ;
+*)
+ let ainnertypes,expected_available =
+ if computeinnertypes then
+ let annexpected,expected_available =
+ match expected with
+ None -> None,false
+ | Some expectedty' ->
+ Some (aux false (Some fresh_id'') [] env idrefs expectedty'),
+ true
+ in
+ Some
+ {annsynthesized =
+ aux false (Some fresh_id'') [] env idrefs synthesized ;
+ annexpected = annexpected
+ }, expected_available
+ else
+ None,false
+ in
+ ainnertypes,synthesized, string_of_sort_family innersort,
+ expected_available
+ in
+ let add_inner_type id =
+ match ainnertypes with
+ None -> ()
+ | Some ainnertypes -> Hashtbl.add ids_to_inner_types id ainnertypes
+ in
+
+ (* explicit_substitute_and_eta_expand_if_required h t t' *)
+ (* where [t] = [] and [tt] = [h]{[t']} ("{.}" denotes explicit *)
+ (* named substitution) or [tt] = (App [h]::[t]) (and [t'] = []) *)
+ (* check if [h] is a term that requires an explicit named *)
+ (* substitution and, in that case, uses the first arguments of *)
+ (* [t] as the actual arguments of the substitution. If there *)
+ (* are not enough parameters in the list [t], then eta-expansion *)
+ (* is performed. *)
+ let
+ explicit_substitute_and_eta_expand_if_required h t t'
+ compute_result_if_eta_expansion_not_required
+ =
+ let subst,residual_args,uninst_vars =
+ let variables,basedir =
+ try
+ let g = Libnames.global_of_constr h in
+ let sp =
+ match g with
+ Libnames.ConstructRef ((induri,_),_)
+ | Libnames.IndRef (induri,_) ->
+ Nametab.path_of_global (Libnames.IndRef (induri,0))
+ | Libnames.VarRef id ->
+ (* Invariant: variables are never cooked in Coq *)
+ raise Not_found
+ | _ -> Nametab.path_of_global g
+ in
+ Dischargedhypsmap.get_discharged_hyps sp,
+ get_module_path_of_full_path sp
+ with Not_found ->
+ (* no explicit substitution *)
+ [], Libnames.dirpath_of_string "dummy"
+ in
+ (* returns a triple whose first element is *)
+ (* an explicit named substitution of "type" *)
+ (* (variable * argument) list, whose *)
+ (* second element is the list of residual *)
+ (* arguments and whose third argument is *)
+ (* the list of uninstantiated variables *)
+ let rec get_explicit_subst variables arguments =
+ match variables,arguments with
+ [],_ -> [],arguments,[]
+ | _,[] -> [],[],variables
+ | he1::tl1,he2::tl2 ->
+ let subst,extra_args,uninst = get_explicit_subst tl1 tl2 in
+ let (he1_sp, he1_id) = Libnames.repr_path he1 in
+ let he1' = remove_module_dirpath_from_dirpath ~basedir he1_sp in
+ let he1'' =
+ String.concat "/"
+ (List.map Names.string_of_id (List.rev he1')) ^ "/"
+ ^ (Names.string_of_id he1_id) ^ ".var"
+ in
+ (he1'',he2)::subst, extra_args, uninst
+ in
+ get_explicit_subst variables t'
+ in
+ let uninst_vars_length = List.length uninst_vars in
+ if uninst_vars_length > 0 then
+ (* Not enough arguments provided. We must eta-expand! *)
+ let un_args,_ =
+ T.decompose_prod_n uninst_vars_length
+ (CPropRetyping.get_type_of env evar_map tt)
+ in
+ let eta_expanded =
+ let arguments =
+ List.map (T.lift uninst_vars_length) t @
+ Termops.rel_list 0 uninst_vars_length
+ in
+ Unshare.unshare
+ (T.lamn uninst_vars_length un_args
+ (T.applistc h arguments))
+ in
+ D.double_type_of env evar_map eta_expanded
+ None terms_to_types ;
+ Hashtbl.remove ids_to_inner_types fresh_id'' ;
+ aux' env idrefs eta_expanded
+ else
+ compute_result_if_eta_expansion_not_required subst residual_args
+ in
+
+ (* Now that we have all the auxiliary functions we *)
+ (* can finally proceed with the main case analysis. *)
+ match T.kind_of_term tt with
+ T.Rel n ->
+ let id =
+ match List.nth (E.rel_context env) (n - 1) with
+ (N.Name id,_,_) -> id
+ | (N.Anonymous,_,_) -> Nameops.make_ident "_" None
+ in
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort && expected_available then
+ add_inner_type fresh_id'' ;
+ A.ARel (fresh_id'', n, List.nth idrefs (n-1), id)
+ | T.Var id ->
+ let pvars = Termops.ids_of_named_context (E.named_context env) in
+ let pvars = List.map N.string_of_id pvars in
+ let path = get_uri_of_var (N.string_of_id id) pvars in
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort && expected_available then
+ add_inner_type fresh_id'' ;
+ A.AVar
+ (fresh_id'', path ^ "/" ^ (N.string_of_id id) ^ ".var")
+ | T.Evar (n,l) ->
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort && expected_available then
+ add_inner_type fresh_id'' ;
+ A.AEvar
+ (fresh_id'', n, Array.to_list (Array.map (aux' env idrefs) l))
+ | T.Meta _ -> Util.anomaly "Meta met during exporting to XML"
+ | T.Sort s -> A.ASort (fresh_id'', s)
+ | T.Cast (v,_, t) ->
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort then
+ add_inner_type fresh_id'' ;
+ A.ACast (fresh_id'', aux' env idrefs v, aux' env idrefs t)
+ | T.Prod (n,s,t) ->
+ let n' =
+ match n with
+ N.Anonymous -> N.Anonymous
+ | _ ->
+ if not fake_dependent_products && T.noccurn 1 t then
+ N.Anonymous
+ else
+ N.Name
+ (Namegen.next_name_away n (Termops.ids_of_context env))
+ in
+ Hashtbl.add ids_to_inner_sorts fresh_id''
+ (string_of_sort innertype) ;
+ let sourcetype = CPropRetyping.get_type_of env evar_map s in
+ Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
+ (string_of_sort sourcetype) ;
+ let new_passed_prods =
+ let father_is_prod =
+ match father with
+ None -> false
+ | Some father' ->
+ match
+ Term.kind_of_term (Hashtbl.find ids_to_terms father')
+ with
+ T.Prod _ -> true
+ | _ -> false
+ in
+ (fresh_id'', n', aux' env idrefs s)::
+ (if father_is_prod then
+ passed_lambdas_or_prods_or_letins
+ else [])
+ in
+ let new_env = E.push_rel (n', None, s) env in
+ let new_idrefs = fresh_id''::idrefs in
+ (match Term.kind_of_term t with
+ T.Prod _ ->
+ aux computeinnertypes (Some fresh_id'') new_passed_prods
+ new_env new_idrefs t
+ | _ ->
+ A.AProds (new_passed_prods, aux' new_env new_idrefs t))
+ | T.Lambda (n,s,t) ->
+ let n' =
+ match n with
+ N.Anonymous -> N.Anonymous
+ | _ ->
+ N.Name (Namegen.next_name_away n (Termops.ids_of_context env))
+ in
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ let sourcetype = CPropRetyping.get_type_of env evar_map s in
+ Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
+ (string_of_sort sourcetype) ;
+ let father_is_lambda =
+ match father with
+ None -> false
+ | Some father' ->
+ match
+ Term.kind_of_term (Hashtbl.find ids_to_terms father')
+ with
+ T.Lambda _ -> true
+ | _ -> false
+ in
+ if is_a_Prop innersort &&
+ ((not father_is_lambda) || expected_available)
+ then add_inner_type fresh_id'' ;
+ let new_passed_lambdas =
+ (fresh_id'',n', aux' env idrefs s)::
+ (if father_is_lambda then
+ passed_lambdas_or_prods_or_letins
+ else []) in
+ let new_env = E.push_rel (n', None, s) env in
+ let new_idrefs = fresh_id''::idrefs in
+ (match Term.kind_of_term t with
+ T.Lambda _ ->
+ aux computeinnertypes (Some fresh_id'') new_passed_lambdas
+ new_env new_idrefs t
+ | _ ->
+ let t' = aux' new_env new_idrefs t in
+ (* eta-expansion for explicit named substitutions *)
+ (* can create nested Lambdas. Here we perform the *)
+ (* flattening. *)
+ match t' with
+ A.ALambdas (lambdas, t'') ->
+ A.ALambdas (lambdas@new_passed_lambdas, t'')
+ | _ ->
+ A.ALambdas (new_passed_lambdas, t')
+ )
+ | T.LetIn (n,s,t,d) ->
+ let id =
+ match n with
+ N.Anonymous -> N.id_of_string "_X"
+ | N.Name id -> id
+ in
+ let n' =
+ N.Name (Namegen.next_ident_away id (Termops.ids_of_context env))
+ in
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ let sourcesort =
+ get_sort_family_of env evar_map
+ (CPropRetyping.get_type_of env evar_map s)
+ in
+ Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
+ (string_of_sort_family sourcesort) ;
+ let father_is_letin =
+ match father with
+ None -> false
+ | Some father' ->
+ match
+ Term.kind_of_term (Hashtbl.find ids_to_terms father')
+ with
+ T.LetIn _ -> true
+ | _ -> false
+ in
+ if is_a_Prop innersort then
+ add_inner_type fresh_id'' ;
+ let new_passed_letins =
+ (fresh_id'',n', aux' env idrefs s)::
+ (if father_is_letin then
+ passed_lambdas_or_prods_or_letins
+ else []) in
+ let new_env = E.push_rel (n', Some s, t) env in
+ let new_idrefs = fresh_id''::idrefs in
+ (match Term.kind_of_term d with
+ T.LetIn _ ->
+ aux computeinnertypes (Some fresh_id'') new_passed_letins
+ new_env new_idrefs d
+ | _ -> A.ALetIns
+ (new_passed_letins, aux' new_env new_idrefs d))
+ | T.App (h,t) ->
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort then
+ add_inner_type fresh_id'' ;
+ let
+ compute_result_if_eta_expansion_not_required subst residual_args
+ =
+ let residual_args_not_empty = residual_args <> [] in
+ let h' =
+ if residual_args_not_empty then
+ aux' env idrefs ~subst:(None,subst) h
+ else
+ aux' env idrefs ~subst:(Some fresh_id'',subst) h
+ in
+ (* maybe all the arguments were used for the explicit *)
+ (* named substitution *)
+ if residual_args_not_empty then
+ A.AApp (fresh_id'', h'::residual_args)
+ else
+ h'
+ in
+ let t' =
+ Array.fold_right (fun x i -> (aux' env idrefs x)::i) t []
+ in
+ explicit_substitute_and_eta_expand_if_required h
+ (Array.to_list t) t'
+ compute_result_if_eta_expansion_not_required
+ | T.Const kn ->
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort && expected_available then
+ add_inner_type fresh_id'' ;
+ let compute_result_if_eta_expansion_not_required _ _ =
+ A.AConst (fresh_id'', subst, (uri_of_kernel_name (Constant kn)))
+ in
+ let (_,subst') = subst in
+ explicit_substitute_and_eta_expand_if_required tt []
+ (List.map snd subst')
+ compute_result_if_eta_expansion_not_required
+ | T.Ind (kn,i) ->
+ let compute_result_if_eta_expansion_not_required _ _ =
+ A.AInd (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i)
+ in
+ let (_,subst') = subst in
+ explicit_substitute_and_eta_expand_if_required tt []
+ (List.map snd subst')
+ compute_result_if_eta_expansion_not_required
+ | T.Construct ((kn,i),j) ->
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort && expected_available then
+ add_inner_type fresh_id'' ;
+ let compute_result_if_eta_expansion_not_required _ _ =
+ A.AConstruct
+ (fresh_id'', subst, (uri_of_kernel_name (Inductive kn)), i, j)
+ in
+ let (_,subst') = subst in
+ explicit_substitute_and_eta_expand_if_required tt []
+ (List.map snd subst')
+ compute_result_if_eta_expansion_not_required
+ | T.Case ({T.ci_ind=(kn,i)},ty,term,a) ->
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort then
+ add_inner_type fresh_id'' ;
+ let a' =
+ Array.fold_right (fun x i -> (aux' env idrefs x)::i) a []
+ in
+ A.ACase
+ (fresh_id'', (uri_of_kernel_name (Inductive kn)), i,
+ aux' env idrefs ty, aux' env idrefs term, a')
+ | T.Fix ((ai,i),(f,t,b)) ->
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort then add_inner_type fresh_id'' ;
+ let fresh_idrefs =
+ Array.init (Array.length t) (function _ -> gen_id seed) in
+ let new_idrefs =
+ (List.rev (Array.to_list fresh_idrefs)) @ idrefs
+ in
+ let f' =
+ let ids = ref (Termops.ids_of_context env) in
+ Array.map
+ (function
+ N.Anonymous -> Util.error "Anonymous fix function met"
+ | N.Name id as n ->
+ let res = N.Name (Namegen.next_name_away n !ids) in
+ ids := id::!ids ;
+ res
+ ) f
+ in
+ A.AFix (fresh_id'', i,
+ Array.fold_right
+ (fun (id,fi,ti,bi,ai) i ->
+ let fi' =
+ match fi with
+ N.Name fi -> fi
+ | N.Anonymous -> Util.error "Anonymous fix function met"
+ in
+ (id, fi', ai,
+ aux' env idrefs ti,
+ aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
+ (Array.mapi
+ (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j),ai.(j))) f'
+ ) []
+ )
+ | T.CoFix (i,(f,t,b)) ->
+ Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
+ if is_a_Prop innersort then add_inner_type fresh_id'' ;
+ let fresh_idrefs =
+ Array.init (Array.length t) (function _ -> gen_id seed) in
+ let new_idrefs =
+ (List.rev (Array.to_list fresh_idrefs)) @ idrefs
+ in
+ let f' =
+ let ids = ref (Termops.ids_of_context env) in
+ Array.map
+ (function
+ N.Anonymous -> Util.error "Anonymous fix function met"
+ | N.Name id as n ->
+ let res = N.Name (Namegen.next_name_away n !ids) in
+ ids := id::!ids ;
+ res
+ ) f
+ in
+ A.ACoFix (fresh_id'', i,
+ Array.fold_right
+ (fun (id,fi,ti,bi) i ->
+ let fi' =
+ match fi with
+ N.Name fi -> fi
+ | N.Anonymous -> Util.error "Anonymous fix function met"
+ in
+ (id, fi',
+ aux' env idrefs ti,
+ aux' (E.push_rec_types (f',t,b) env) new_idrefs bi)::i)
+ (Array.mapi
+ (fun j x -> (fresh_idrefs.(j),x,t.(j),b.(j)) ) f'
+ ) []
+ )
+ in
+ aux computeinnertypes None [] env idrefs t
+;;
+
+(* Obsolete [HH 1/2009]
+let acic_of_cic_context metasenv context t =
+ let ids_to_terms = Hashtbl.create 503 in
+ let constr_to_ids = Acic.CicHash.create 503 in
+ let ids_to_father_ids = Hashtbl.create 503 in
+ let ids_to_inner_sorts = Hashtbl.create 503 in
+ let ids_to_inner_types = Hashtbl.create 503 in
+ let seed = ref 0 in
+ acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
+ ids_to_inner_sorts ids_to_inner_types metasenv context t,
+ ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types
+;;
+*)
+
+let acic_object_of_cic_object sigma obj =
+ let module A = Acic in
+ let ids_to_terms = Hashtbl.create 503 in
+ let constr_to_ids = Acic.CicHash.create 503 in
+ let ids_to_father_ids = Hashtbl.create 503 in
+ let ids_to_inner_sorts = Hashtbl.create 503 in
+ let ids_to_inner_types = Hashtbl.create 503 in
+ let ids_to_conjectures = Hashtbl.create 11 in
+ let ids_to_hypotheses = Hashtbl.create 127 in
+ let hypotheses_seed = ref 0 in
+ let conjectures_seed = ref 0 in
+ let seed = ref 0 in
+ let acic_term_of_cic_term_context' =
+ acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids
+ ids_to_inner_sorts ids_to_inner_types in
+(*CSC: is this the right env to use? Hhmmm. There is a problem: in *)
+(*CSC: Global.env () the object we are exporting is already defined, *)
+(*CSC: either in the environment or in the named context (in the case *)
+(*CSC: of variables. Is this a problem? *)
+ let env = Global.env () in
+ let acic_term_of_cic_term' ?fake_dependent_products =
+ acic_term_of_cic_term_context' ?fake_dependent_products env [] sigma in
+(*CSC: the fresh_id is not stored anywhere. This _MUST_ be fixed using *)
+(*CSC: a modified version of the already existent fresh_id function *)
+ let fresh_id () =
+ let res = "i" ^ string_of_int !seed in
+ incr seed ;
+ res
+ in
+ let aobj =
+ match obj with
+ A.Constant (id,bo,ty,params) ->
+ let abo =
+ match bo with
+ None -> None
+ | Some bo' -> Some (acic_term_of_cic_term' bo' (Some ty))
+ in
+ let aty = acic_term_of_cic_term' ty None in
+ A.AConstant (fresh_id (),id,abo,aty,params)
+ | A.Variable (id,bo,ty,params) ->
+ let abo =
+ match bo with
+ Some bo -> Some (acic_term_of_cic_term' bo (Some ty))
+ | None -> None
+ in
+ let aty = acic_term_of_cic_term' ty None in
+ A.AVariable (fresh_id (),id,abo,aty,params)
+ | A.CurrentProof (id,conjectures,bo,ty) ->
+ let aconjectures =
+ List.map
+ (function (i,canonical_context,term) as conjecture ->
+ let cid = "c" ^ string_of_int !conjectures_seed in
+ Hashtbl.add ids_to_conjectures cid conjecture ;
+ incr conjectures_seed ;
+ let canonical_env,idrefs',acanonical_context =
+ let rec aux env idrefs =
+ function
+ [] -> env,idrefs,[]
+ | ((n,decl_or_def) as hyp)::tl ->
+ let hid = "h" ^ string_of_int !hypotheses_seed in
+ let new_idrefs = hid::idrefs in
+ Hashtbl.add ids_to_hypotheses hid hyp ;
+ incr hypotheses_seed ;
+ match decl_or_def with
+ A.Decl t ->
+ let final_env,final_idrefs,atl =
+ aux (Environ.push_rel (Names.Name n,None,t) env)
+ new_idrefs tl
+ in
+ let at =
+ acic_term_of_cic_term_context' env idrefs sigma t None
+ in
+ final_env,final_idrefs,(hid,(n,A.Decl at))::atl
+ | A.Def (t,ty) ->
+ let final_env,final_idrefs,atl =
+ aux
+ (Environ.push_rel (Names.Name n,Some t,ty) env)
+ new_idrefs tl
+ in
+ let at =
+ acic_term_of_cic_term_context' env idrefs sigma t None
+ in
+ let dummy_never_used =
+ let s = "dummy_never_used" in
+ A.ARel (s,99,s,Names.id_of_string s)
+ in
+ final_env,final_idrefs,
+ (hid,(n,A.Def (at,dummy_never_used)))::atl
+ in
+ aux env [] canonical_context
+ in
+ let aterm =
+ acic_term_of_cic_term_context' canonical_env idrefs' sigma term
+ None
+ in
+ (cid,i,List.rev acanonical_context,aterm)
+ ) conjectures in
+ let abo = acic_term_of_cic_term_context' env [] sigma bo (Some ty) in
+ let aty = acic_term_of_cic_term_context' env [] sigma ty None in
+ A.ACurrentProof (fresh_id (),id,aconjectures,abo,aty)
+ | A.InductiveDefinition (tys,params,paramsno) ->
+ let env' =
+ List.fold_right
+ (fun (name,_,arity,_) env ->
+ Environ.push_rel (Names.Name name, None, arity) env
+ ) (List.rev tys) env in
+ let idrefs = List.map (function _ -> gen_id seed) tys in
+ let atys =
+ List.map2
+ (fun id (name,inductive,ty,cons) ->
+ let acons =
+ List.map
+ (function (name,ty) ->
+ (name,
+ acic_term_of_cic_term_context' ~fake_dependent_products:true
+ env' idrefs Evd.empty ty None)
+ ) cons
+ in
+ let aty =
+ acic_term_of_cic_term' ~fake_dependent_products:true ty None
+ in
+ (id,name,inductive,aty,acons)
+ ) (List.rev idrefs) tys
+ in
+ A.AInductiveDefinition (fresh_id (),atys,params,paramsno)
+ in
+ aobj,ids_to_terms,constr_to_ids,ids_to_father_ids,ids_to_inner_sorts,
+ ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses
+;;
diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml
new file mode 100644
index 00000000..f8921aec
--- /dev/null
+++ b/plugins/xml/doubleTypeInference.ml
@@ -0,0 +1,272 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+(*CSC: tutto da rifare!!! Basarsi su Retyping che e' meno costoso! *)
+type types = {synthesized : Term.types ; expected : Term.types option};;
+
+let prerr_endline _ = ();;
+
+let cprop =
+ let module N = Names in
+ N.make_con
+ (N.MPfile
+ (Libnames.dirpath_of_string "CoRN.algebra.CLogic"))
+ (N.make_dirpath [])
+ (N.mk_label "CProp")
+;;
+
+let whd_betadeltaiotacprop env _evar_map ty =
+ let module R = Rawterm in
+ let module C = Closure in
+ let module CR = C.RedFlags in
+ (*** CProp is made Opaque ***)
+ let flags = CR.red_sub C.betadeltaiota (CR.fCONST cprop) in
+ C.whd_val (C.create_clos_infos flags env) (C.inject ty)
+;;
+
+
+(* Code similar to the code in the Typing module, but: *)
+(* - the term is already assumed to be well typed *)
+(* - some checks have been removed *)
+(* - both the synthesized and expected types of every *)
+(* node are computed (Coscoy's double type inference) *)
+
+let assumption_of_judgment env sigma j =
+ Typeops.assumption_of_judgment env (Evarutil.j_nf_evar sigma j)
+;;
+
+let type_judgment env sigma j =
+ Typeops.type_judgment env (Evarutil.j_nf_evar sigma j)
+;;
+
+let type_judgment_cprop env sigma j =
+ match Term.kind_of_term(whd_betadeltaiotacprop env sigma j.Environ.uj_type) with
+ | Term.Sort s -> Some {Environ.utj_val = j.Environ.uj_val; Environ.utj_type = s }
+ | _ -> None (* None means the CProp constant *)
+;;
+
+let double_type_of env sigma cstr expectedty subterms_to_types =
+ (*CSC: the code is inefficient because judgments are created just to be *)
+ (*CSC: destroyed using Environ.j_type. Moreover I am pretty sure that the *)
+ (*CSC: functions used do checks that we do not need *)
+ let rec execute env sigma cstr expectedty =
+ let module T = Term in
+ let module E = Environ in
+ (* the type part is the synthesized type *)
+ let judgement =
+ match T.kind_of_term cstr with
+ T.Meta n ->
+ Util.error
+ "DoubleTypeInference.double_type_of: found a non-instanciated goal"
+
+ | T.Evar ((n,l) as ev) ->
+ let ty = Unshare.unshare (Evd.existential_type sigma ev) in
+ let jty = execute env sigma ty None in
+ let jty = assumption_of_judgment env sigma jty in
+ let evar_context =
+ E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in
+ let rec iter actual_args evar_context =
+ match actual_args,evar_context with
+ [],[] -> ()
+ | he1::tl1,(n,_,ty)::tl2 ->
+ (* for side-effects *)
+ let _ = execute env sigma he1 (Some ty) in
+ let tl2' =
+ List.map
+ (function (m,bo,ty) ->
+ (* Warning: the substitution should be performed also on bo *)
+ (* This is not done since bo is not used later yet *)
+ (m,bo,Unshare.unshare (T.replace_vars [n,he1] ty))
+ ) tl2
+ in
+ iter tl1 tl2'
+ | _,_ -> assert false
+ in
+ (* for side effects only *)
+ iter (List.rev (Array.to_list l)) (List.rev evar_context) ;
+ E.make_judge cstr jty
+
+ | T.Rel n ->
+ Typeops.judge_of_relative env n
+
+ | T.Var id ->
+ Typeops.judge_of_variable env id
+
+ | T.Const c ->
+ E.make_judge cstr (Typeops.type_of_constant env c)
+
+ | T.Ind ind ->
+ E.make_judge cstr (Inductiveops.type_of_inductive env ind)
+
+ | T.Construct cstruct ->
+ E.make_judge cstr (Inductiveops.type_of_constructor env cstruct)
+
+ | T.Case (ci,p,c,lf) ->
+ let expectedtype =
+ Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in
+ let cj = execute env sigma c (Some expectedtype) in
+ let pj = execute env sigma p None in
+ let (expectedtypes,_,_) =
+ let indspec = Inductive.find_rectype env cj.Environ.uj_type in
+ Inductive.type_case_branches env indspec pj cj.Environ.uj_val
+ in
+ let lfj =
+ execute_array env sigma lf
+ (Array.map (function x -> Some x) expectedtypes) in
+ let (j,_) = Typeops.judge_of_case env ci pj cj lfj in
+ j
+
+ | T.Fix ((vn,i as vni),recdef) ->
+ let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
+ let fix = (vni,recdef') in
+ E.make_judge (T.mkFix fix) tys.(i)
+
+ | T.CoFix (i,recdef) ->
+ let (_,tys,_ as recdef') = execute_recdef env sigma recdef in
+ let cofix = (i,recdef') in
+ E.make_judge (T.mkCoFix cofix) tys.(i)
+
+ | T.Sort (T.Prop c) ->
+ Typeops.judge_of_prop_contents c
+
+ | T.Sort (T.Type u) ->
+(*CSC: In case of need, I refresh the universe. But exportation of the *)
+(*CSC: right universe level information is destroyed. It must be changed *)
+(*CSC: again once Judicael will introduce his non-bugged algebraic *)
+(*CSC: universes. *)
+(try
+ Typeops.judge_of_type u
+ with _ -> (* Successor of a non universe-variable universe anomaly *)
+ (Pp.ppnl (Pp.str "Warning: universe refresh performed!!!") ; flush stdout ) ;
+ Typeops.judge_of_type (Termops.new_univ ())
+)
+
+ | T.App (f,args) ->
+ let expected_head =
+ Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in
+ let j = execute env sigma f (Some expected_head) in
+ let expected_args =
+ let rec aux typ =
+ function
+ [] -> []
+ | hj::restjl ->
+ match T.kind_of_term (Reduction.whd_betadeltaiota env typ) with
+ T.Prod (_,c1,c2) ->
+ (Some (Reductionops.nf_beta sigma c1)) ::
+ (aux (T.subst1 hj c2) restjl)
+ | _ -> assert false
+ in
+ Array.of_list (aux j.Environ.uj_type (Array.to_list args))
+ in
+ let jl = execute_array env sigma args expected_args in
+ let (j,_) = Typeops.judge_of_apply env j jl in
+ j
+
+ | T.Lambda (name,c1,c2) ->
+ let j = execute env sigma c1 None in
+ let var = type_judgment env sigma j in
+ let env1 = E.push_rel (name,None,var.E.utj_val) env in
+ let expectedc2type =
+ match expectedty with
+ None -> None
+ | Some ety ->
+ match T.kind_of_term (Reduction.whd_betadeltaiota env ety) with
+ T.Prod (_,_,expected_target_type) ->
+ Some (Reductionops.nf_beta sigma expected_target_type)
+ | _ -> assert false
+ in
+ let j' = execute env1 sigma c2 expectedc2type in
+ Typeops.judge_of_abstraction env1 name var j'
+
+ | T.Prod (name,c1,c2) ->
+ let j = execute env sigma c1 None in
+ let varj = type_judgment env sigma j in
+ let env1 = E.push_rel (name,None,varj.E.utj_val) env in
+ let j' = execute env1 sigma c2 None in
+ (match type_judgment_cprop env1 sigma j' with
+ Some varj' -> Typeops.judge_of_product env name varj varj'
+ | None ->
+ (* CProp found *)
+ { Environ.uj_val = T.mkProd (name, j.Environ.uj_val, j'.Environ.uj_val);
+ Environ.uj_type = T.mkConst cprop })
+
+ | T.LetIn (name,c1,c2,c3) ->
+(*CSC: What are the right expected types for the source and *)
+(*CSC: target of a LetIn? None used. *)
+ let j1 = execute env sigma c1 None in
+ let j2 = execute env sigma c2 None in
+ let j2 = type_judgment env sigma j2 in
+ let env1 =
+ E.push_rel (name,Some j1.E.uj_val,j2.E.utj_val) env
+ in
+ let j3 = execute env1 sigma c3 None in
+ Typeops.judge_of_letin env name j1 j2 j3
+
+ | T.Cast (c,k,t) ->
+ let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in
+ let tj = execute env sigma t None in
+ let tj = type_judgment env sigma tj in
+ let j, _ = Typeops.judge_of_cast env cj k tj in
+ j
+ in
+ let synthesized = E.j_type judgement in
+ let synthesized' = Reductionops.nf_beta sigma synthesized in
+ let types,res =
+ match expectedty with
+ None ->
+ (* No expected type *)
+ {synthesized = synthesized' ; expected = None}, synthesized
+ | Some ty when Term.eq_constr synthesized' ty ->
+ (* The expected type is synthactically equal to the *)
+ (* synthesized type. Let's forget it. *)
+ (* Note: since eq_constr is up to casts, it is better *)
+ (* to keep the expected type, since it can bears casts *)
+ (* that change the innersort to CProp *)
+ {synthesized = ty ; expected = None}, ty
+ | Some expectedty' ->
+ {synthesized = synthesized' ; expected = Some expectedty'},
+ expectedty'
+ in
+(*CSC: debugging stuff to be removed *)
+if Acic.CicHash.mem subterms_to_types cstr then
+ (Pp.ppnl (Pp.(++) (Pp.str "DUPLICATE INSERTION: ") (Printer.pr_lconstr cstr)) ; flush stdout ) ;
+ Acic.CicHash.add subterms_to_types cstr types ;
+ E.make_judge cstr res
+
+
+ and execute_recdef env sigma (names,lar,vdef) =
+ let length = Array.length lar in
+ let larj =
+ execute_array env sigma lar (Array.make length None) in
+ let lara = Array.map (assumption_of_judgment env sigma) larj in
+ let env1 = Environ.push_rec_types (names,lara,vdef) env in
+ let expectedtypes =
+ Array.map (function i -> Some (Term.lift length i)) lar
+ in
+ let vdefj = execute_array env1 sigma vdef expectedtypes in
+ let vdefv = Array.map Environ.j_val vdefj in
+ (names,lara,vdefv)
+
+ and execute_array env sigma v expectedtypes =
+ let jl =
+ execute_list env sigma (Array.to_list v) (Array.to_list expectedtypes)
+ in
+ Array.of_list jl
+
+ and execute_list env sigma =
+ List.map2 (execute env sigma)
+
+in
+ ignore (execute env sigma cstr expectedty)
+;;
diff --git a/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli
new file mode 100644
index 00000000..b604ec4c
--- /dev/null
+++ b/plugins/xml/doubleTypeInference.mli
@@ -0,0 +1,24 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+type types = { synthesized : Term.types; expected : Term.types option; }
+
+val cprop : Names.constant
+
+val whd_betadeltaiotacprop :
+ Environ.env -> Evd.evar_map -> Term.constr -> Term.constr
+
+val double_type_of :
+ Environ.env -> Evd.evar_map -> Term.constr -> Term.constr option ->
+ types Acic.CicHash.t -> unit
diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4
new file mode 100644
index 00000000..9419ba59
--- /dev/null
+++ b/plugins/xml/dumptree.ml4
@@ -0,0 +1,152 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(** This module provides the "Dump Tree" command that allows dumping the
+ current state of the proof stree in XML format *)
+
+(** Contributed by Cezary Kaliszyk, Radboud University Nijmegen *)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+open Tacexpr;;
+open Decl_mode;;
+open Printer;;
+open Pp;;
+open Environ;;
+open Format;;
+open Proof_type;;
+open Evd;;
+open Termops;;
+open Ppconstr;;
+open Names;;
+
+exception Different
+
+let xmlstream s =
+ (* In XML we want to print the whole stream so we can force the evaluation *)
+ Stream.of_list (List.map xmlescape (Stream.npeek max_int s))
+;;
+
+let thin_sign osign sign =
+ Sign.fold_named_context
+ (fun (id,c,ty as d) sign ->
+ try
+ if Sign.lookup_named id osign = (id,c,ty) then sign
+ else raise Different
+ with Not_found | Different -> Environ.push_named_context_val d sign)
+ sign ~init:Environ.empty_named_context_val
+;;
+
+let pr_tactic_xml = function
+ | 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 "\"/>"
+;;
+
+let pr_proof_instr_xml instr =
+ Ppdecl_proof.pr_proof_instr (Global.env()) instr
+;;
+
+let pr_rule_xml pr = function
+ | Prim r -> str "<rule text=\"" ++ xmlstream (pr_prim_rule r) ++ str "\"/>"
+ | Nested(cmpd, subtree) ->
+ 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) =
+ let ptyp = print_constr_env env typ in
+ match c with
+ | None ->
+ (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>")
+ | Some c ->
+ (* Force evaluation *)
+ let pb = print_constr_env env c in
+ (str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\" body=\"" ++
+ xmlstream pb ++ str "\"/>")
+;;
+
+let pr_rel_decl_xml env (na,c,typ) =
+ let pbody = match c with
+ | None -> mt ()
+ | Some c ->
+ (* Force evaluation *)
+ let pb = print_constr_env env c in
+ (str" body=\"" ++ xmlstream pb ++ str "\"") in
+ let ptyp = print_constr_env env typ in
+ let pid =
+ match na with
+ | Anonymous -> mt ()
+ | Name id -> str " id=\"" ++ pr_id id ++ str "\""
+ in
+ (str "<hyp" ++ pid ++ str " type=\"" ++ xmlstream ptyp ++ str "\"" ++ pbody ++ str "/>")
+;;
+
+let pr_context_xml env =
+ let sign_env =
+ fold_named_context
+ (fun env d pp -> pp ++ pr_var_decl_xml env d)
+ env ~init:(mt ())
+ in
+ let db_env =
+ fold_rel_context
+ (fun env d pp -> pp ++ pr_rel_decl_xml env d)
+ env ~init:(mt ())
+ in
+ (sign_env ++ db_env)
+;;
+
+let pr_subgoal_metas_xml metas env=
+ let pr_one (meta, typ) =
+ fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++
+ str "\"/>"
+ in
+ List.fold_left (++) (mt ()) (List.map pr_one metas)
+;;
+
+let pr_goal_xml g =
+ let env = try evar_unfiltered_env g with _ -> empty_env in
+ if g.evar_extra = None then
+ (hov 2 (str "<goal>" ++ fnl () ++ str "<concl type=\"" ++
+ xmlstream (pr_ltype_env_at_top env g.evar_concl) ++
+ str "\"/>" ++
+ (pr_context_xml env)) ++
+ fnl () ++ str "</goal>")
+ else
+ (hov 2 (str "<goal type=\"declarative\">" ++
+ (pr_context_xml env)) ++
+ 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
+;;
+
+VERNAC COMMAND EXTEND DumpTree
+ [ "Dump" "Tree" ] -> [ print_proof_xml () ]
+END
diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml
new file mode 100644
index 00000000..1beabf26
--- /dev/null
+++ b/plugins/xml/proof2aproof.ml
@@ -0,0 +1,176 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+(* Note: we can not use the Set module here because we _need_ physical *)
+(* equality and there exists no comparison function compatible with *)
+(* physical equality. *)
+
+module S =
+ struct
+ let empty = []
+ let mem = List.memq
+ let add x l = x::l
+ end
+;;
+
+(* evar reduction that preserves some terms *)
+let nf_evar sigma ~preserve =
+ let module T = Term in
+ let rec aux t =
+ if preserve t then t else
+ match T.kind_of_term t with
+ | T.Rel _ | T.Meta _ | T.Var _ | T.Sort _ | T.Const _ | T.Ind _
+ | T.Construct _ -> t
+ | T.Cast (c1,k,c2) -> T.mkCast (aux c1, k, aux c2)
+ | T.Prod (na,c1,c2) -> T.mkProd (na, aux c1, aux c2)
+ | T.Lambda (na,t,c) -> T.mkLambda (na, aux t, aux c)
+ | T.LetIn (na,b,t,c) -> T.mkLetIn (na, aux b, aux t, aux c)
+ | T.App (c,l) ->
+ let c' = aux c in
+ let l' = Array.map aux l in
+ (match T.kind_of_term c' with
+ T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
+ | T.Cast (he,_,_) ->
+ (match T.kind_of_term he with
+ T.App (c'',l'') -> T.mkApp (c'', Array.append l'' l')
+ | _ -> T.mkApp (c', l')
+ )
+ | _ -> T.mkApp (c', l'))
+ | T.Evar (e,l) when Evd.mem sigma e & Evd.is_defined sigma e ->
+ aux (Evd.existential_value sigma (e,l))
+ | T.Evar (e,l) -> T.mkEvar (e, Array.map aux l)
+ | T.Case (ci,p,c,bl) -> T.mkCase (ci, aux p, aux c, Array.map aux bl)
+ | T.Fix (ln,(lna,tl,bl)) ->
+ T.mkFix (ln,(lna,Array.map aux tl,Array.map aux bl))
+ | T.CoFix(ln,(lna,tl,bl)) ->
+ T.mkCoFix (ln,(lna,Array.map aux tl,Array.map aux bl))
+ in
+ aux
+;;
+
+(* Unshares a proof-tree. *)
+(* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *)
+let rec unshare_proof_tree =
+ let module PT = Proof_type in
+ function {PT.open_subgoals = status ;
+ PT.goal = goal ;
+ PT.ref = ref} ->
+ let unshared_ref =
+ match ref with
+ None -> None
+ | Some (rule,pfs) ->
+ let unshared_rule =
+ match rule with
+ PT.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
+ type t = Proof_type.proof_tree
+ let equal = (==)
+ let hash = Hashtbl.hash
+ end)
+;;
+
+
+let extract_open_proof sigma pf =
+ let module PT = Proof_type in
+ let module L = Logic in
+ let 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)
+;;
+
+let extract_open_pftreestate pts =
+ extract_open_proof (Refiner.evc_of_pftreestate pts)
+ (Tacmach.proof_of_pftreestate pts)
+;;
diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4
new file mode 100644
index 00000000..3f1e0a63
--- /dev/null
+++ b/plugins/xml/proofTree2Xml.ml4
@@ -0,0 +1,210 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+let prooftreedtdname = "http://mowgli.cs.unibo.it/dtd/prooftree.dtd";;
+
+let std_ppcmds_to_string s =
+ Pp.msg_with Format.str_formatter s;
+ Format.flush_str_formatter ()
+;;
+
+let idref_of_id id = "v" ^ id;;
+
+(* Transform a constr to an Xml.token Stream.t *)
+(* env is a named context *)
+(*CSC: in verita' dovrei "separare" le variabili vere e lasciarle come Var! *)
+let constr_to_xml obj sigma env =
+ let ids_to_terms = Hashtbl.create 503 in
+ let constr_to_ids = Acic.CicHash.create 503 in
+ let ids_to_father_ids = Hashtbl.create 503 in
+ let ids_to_inner_sorts = Hashtbl.create 503 in
+ let ids_to_inner_types = Hashtbl.create 503 in
+
+ (* named_context holds section variables and local variables *)
+ let named_context = Environ.named_context env in
+ (* real_named_context holds only the section variables *)
+ let real_named_context = Environ.named_context (Global.env ()) in
+ (* named_context' holds only the local variables *)
+ let named_context' =
+ List.filter (function n -> not (List.mem n real_named_context)) named_context
+ in
+ let idrefs =
+ List.map
+ (function x,_,_ -> idref_of_id (Names.string_of_id x)) named_context' in
+ let rel_context = Sign.push_named_to_rel_context named_context' [] in
+ let rel_env =
+ Environ.push_rel_context rel_context
+ (Environ.reset_with_named_context
+ (Environ.val_of_named_context real_named_context) env) in
+ let obj' =
+ Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in
+ let seed = ref 0 in
+ try
+ let annobj =
+ Cic2acic.acic_of_cic_context' false seed ids_to_terms constr_to_ids
+ ids_to_father_ids ids_to_inner_sorts ids_to_inner_types rel_env
+ idrefs sigma (Unshare.unshare obj') None
+ in
+ Acic2Xml.print_term ids_to_inner_sorts annobj
+ with e ->
+ Util.anomaly
+ ("Problem during the conversion of constr into XML: " ^
+ Printexc.to_string e)
+(* CSC: debugging stuff
+Pp.ppnl (Pp.str "Problem during the conversion of constr into XML") ;
+Pp.ppnl (Pp.str "ENVIRONMENT:") ;
+Pp.ppnl (Printer.pr_context_of rel_env) ;
+Pp.ppnl (Pp.str "TERM:") ;
+Pp.ppnl (Printer.pr_lconstr_env rel_env obj') ;
+Pp.ppnl (Pp.str "RAW-TERM:") ;
+Pp.ppnl (Printer.pr_lconstr obj') ;
+Xml.xml_empty "MISSING TERM" [] (*; raise e*)
+*)
+;;
+
+let first_word s =
+ try let i = String.index s ' ' in
+ String.sub s 0 i
+ with _ -> s
+;;
+
+let string_of_prim_rule x = match x with
+ | Proof_type.Intro _-> "Intro"
+ | Proof_type.Cut _ -> "Cut"
+ | Proof_type.FixRule _ -> "FixRule"
+ | Proof_type.Cofix _ -> "Cofix"
+ | Proof_type.Refine _ -> "Refine"
+ | Proof_type.Convert_concl _ -> "Convert_concl"
+ | Proof_type.Convert_hyp _->"Convert_hyp"
+ | Proof_type.Thin _ -> "Thin"
+ | Proof_type.ThinBody _-> "ThinBody"
+ | Proof_type.Move (_,_,_) -> "Move"
+ | Proof_type.Order _ -> "Order"
+ | Proof_type.Rename (_,_) -> "Rename"
+ | Proof_type.Change_evars -> "Change_evars"
+
+let
+ print_proof_tree curi sigma pf proof_tree_to_constr
+ proof_tree_to_flattened_proof_tree constr_to_ids
+=
+ let module PT = Proof_type in
+ let module L = Logic in
+ let module X = Xml in
+ let module T = Tacexpr in
+ let ids_of_node node =
+ let constr = Proof2aproof.ProofTreeHash.find proof_tree_to_constr node in
+(*
+let constr =
+ try
+ Proof2aproof.ProofTreeHash.find proof_tree_to_constr node
+ with _ -> Pp.ppnl (Pp.(++) (Pp.str "Node of the proof-tree that generated
+no lambda-term: ") (Refiner.print_script true (Evd.empty)
+(Global.named_context ()) node)) ; assert false (* Closed bug, should not
+happen any more *)
+in
+*)
+ try
+ Some (Acic.CicHash.find constr_to_ids constr)
+ with _ ->
+Pp.ppnl (Pp.(++) (Pp.str
+"The_generated_term_is_not_a_subterm_of_the_final_lambda_term")
+(Printer.pr_lconstr constr)) ;
+ None
+ in
+ let rec aux node old_hyps =
+ let of_attribute =
+ match ids_of_node node with
+ None -> []
+ | Some id -> ["of",id]
+ in
+ match node with
+ {PT.ref=Some(PT.Prim tactic_expr,nodes)} ->
+ let tac = string_of_prim_rule tactic_expr in
+ let of_attribute = ("name",tac)::of_attribute in
+ if nodes = [] then
+ X.xml_empty "Prim" of_attribute
+ else
+ X.xml_nempty "Prim" of_attribute
+ (List.fold_left
+ (fun i n -> [< i ; (aux n old_hyps) >]) [<>] nodes)
+
+ | {PT.goal=goal;
+ PT.ref=Some(PT.Nested (PT.Tactic(tactic_expr,_),hidden_proof),nodes)} ->
+ (* [hidden_proof] is the proof of the tactic; *)
+ (* [nodes] are the proof of the subgoals generated by the tactic; *)
+ (* [flat_proof] if the proof-tree obtained substituting [nodes] *)
+ (* for the holes in [hidden_proof] *)
+ let flat_proof =
+ Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node
+ in begin
+ match tactic_expr with
+ | T.TacArg (T.Tacexp _) ->
+ (* We don't need to keep the level of abstraction introduced at *)
+ (* user-level invocation of tactic... (see Tacinterp.hide_interp)*)
+ aux flat_proof old_hyps
+ | _ ->
+ (****** la tactique employee *)
+ let prtac = Pptactic.pr_tactic (Global.env()) in
+ let tac = std_ppcmds_to_string (prtac tactic_expr) in
+ let tacname= first_word tac in
+ let of_attribute = ("name",tacname)::("script",tac)::of_attribute in
+
+ (****** le but *)
+ let {Evd.evar_concl=concl;
+ Evd.evar_hyps=hyps}=goal in
+
+ let env = Global.env_of_context hyps in
+
+ let xgoal =
+ X.xml_nempty "Goal" [] (constr_to_xml concl sigma env) in
+
+ let rec build_hyps =
+ function
+ | [] -> xgoal
+ | (id,c,tid)::hyps1 ->
+ let id' = Names.string_of_id id in
+ [< build_hyps hyps1;
+ (X.xml_nempty "Hypothesis"
+ ["id",idref_of_id id' ; "name",id']
+ (constr_to_xml tid sigma env))
+ >] in
+ let old_names = List.map (fun (id,c,tid)->id) old_hyps in
+ let nhyps = Environ.named_context_of_val hyps in
+ let new_hyps =
+ List.filter (fun (id,c,tid)-> not (List.mem id old_names)) nhyps in
+
+ X.xml_nempty "Tactic" of_attribute
+ [<(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
+ in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE ProofTree SYSTEM \""^prooftreedtdname ^"\">\n\n");
+ X.xml_nempty "ProofTree" ["of",curi] (aux pf [])
+ >]
+;;
+
+
+(* Hook registration *)
+(* CSC: debranched since it is bugged
+Xmlcommand.set_print_proof_tree print_proof_tree;;
+*)
diff --git a/plugins/xml/theoryobject.dtd b/plugins/xml/theoryobject.dtd
new file mode 100644
index 00000000..953fe009
--- /dev/null
+++ b/plugins/xml/theoryobject.dtd
@@ -0,0 +1,62 @@
+<?xml encoding="ISO-8859-1"?>
+
+<!-- Copyright (C) 2000-2004, HELM Team -->
+<!-- -->
+<!-- This file is part of HELM, an Hypertextual, Electronic -->
+<!-- Library of Mathematics, developed at the Computer Science -->
+<!-- Department, University of Bologna, Italy. -->
+<!-- -->
+<!-- HELM is free software; you can redistribute it and/or -->
+<!-- modify it under the terms of the GNU General Public License -->
+<!-- as published by the Free Software Foundation; either version 2 -->
+<!-- of the License, or (at your option) any later version. -->
+<!-- -->
+<!-- HELM is distributed in the hope that it will be useful, -->
+<!-- but WITHOUT ANY WARRANTY; without even the implied warranty of -->
+<!-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -->
+<!-- GNU General Public License for more details. -->
+<!-- -->
+<!-- You should have received a copy of the GNU General Public License -->
+<!-- along with HELM; if not, write to the Free Software -->
+<!-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, -->
+<!-- MA 02111-1307, USA. -->
+<!-- -->
+<!-- For details, see the HELM World-Wide-Web page, -->
+<!-- http://cs.unibo.it/helm/. -->
+
+
+
+<!-- Notice: the markup described in this DTD is meant to be embedded -->
+<!-- in foreign markup (e.g. XHTML) -->
+
+<!ENTITY % theorystructure
+ '(ht:AXIOM|ht:DEFINITION|ht:THEOREM|ht:VARIABLE|ht:SECTION|ht:MUTUAL)*'>
+
+<!ELEMENT ht:SECTION (%theorystructure;)>
+<!ATTLIST ht:SECTION
+ uri CDATA #REQUIRED>
+
+<!ELEMENT ht:MUTUAL (ht:DEFINITION,ht:DEFINITION+)>
+
+<!-- Theory Items -->
+
+<!ELEMENT ht:AXIOM (Axiom)>
+<!ATTLIST ht:AXIOM
+ uri CDATA #REQUIRED
+ as (Axiom|Declaration) #REQUIRED>
+
+<!ELEMENT ht:DEFINITION (Definition|InductiveDefinition)>
+<!ATTLIST ht:DEFINITION
+ uri CDATA #REQUIRED
+ as (Definition|InteractiveDefinition|Inductive|CoInductive
+ |Record) #REQUIRED>
+
+<!ELEMENT ht:THEOREM (type)>
+<!ATTLIST ht:THEOREM
+ uri CDATA #REQUIRED
+ as (Theorem|Lemma|Corollary|Fact|Remark) #REQUIRED>
+
+<!ELEMENT ht:VARIABLE (Variable)>
+<!ATTLIST ht:VARIABLE
+ uri CDATA #REQUIRED
+ as (Assumption|Hypothesis|LocalDefinition|LocalFact) #REQUIRED>
diff --git a/plugins/xml/unshare.ml b/plugins/xml/unshare.ml
new file mode 100644
index 00000000..f30f8230
--- /dev/null
+++ b/plugins/xml/unshare.ml
@@ -0,0 +1,52 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+exception CanNotUnshare;;
+
+(* [unshare t] gives back a copy of t where all sharing has been removed *)
+(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
+(* use physical equality can now be used to associate information to evey *)
+(* node of the term. *)
+let unshare ?(already_unshared = function _ -> false) t =
+ let obj = Obj.repr t in
+ let rec aux obj =
+ if already_unshared (Obj.obj obj) then
+ obj
+ else
+ (if Obj.is_int obj then
+ obj
+ else if Obj.is_block obj then
+ begin
+ let tag = Obj.tag obj in
+ if tag < Obj.no_scan_tag then
+ begin
+ let size = Obj.size obj in
+ let new_obj = Obj.new_block 0 size in
+ Obj.set_tag new_obj tag ;
+ for i = 0 to size - 1 do
+ Obj.set_field new_obj i (aux (Obj.field obj i))
+ done ;
+ new_obj
+ end
+ else if tag = Obj.string_tag then
+ obj
+ else
+ raise CanNotUnshare
+ end
+ else
+ raise CanNotUnshare
+ )
+ in
+ Obj.obj (aux obj)
+;;
diff --git a/plugins/xml/unshare.mli b/plugins/xml/unshare.mli
new file mode 100644
index 00000000..31ba9037
--- /dev/null
+++ b/plugins/xml/unshare.mli
@@ -0,0 +1,21 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+exception CanNotUnshare;;
+
+(* [unshare t] gives back a copy of t where all sharing has been removed *)
+(* Physical equality becomes meaningful on unshared terms. Hashtables that *)
+(* use physical equality can now be used to associate information to evey *)
+(* node of the term. *)
+val unshare: ?already_unshared:('a -> bool) -> 'a -> 'a
diff --git a/plugins/xml/xml.ml4 b/plugins/xml/xml.ml4
new file mode 100644
index 00000000..5b217119
--- /dev/null
+++ b/plugins/xml/xml.ml4
@@ -0,0 +1,78 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+(* the type token for XML cdata, empty elements and not-empty elements *)
+(* Usage: *)
+(* Str cdata *)
+(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *)
+(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
+(* content *)
+type token = Str of string
+ | Empty of string * (string * string) list
+ | NEmpty of string * (string * string) list * token Stream.t
+;;
+
+(* currified versions of the constructors make the code more readable *)
+let xml_empty name attrs = [< 'Empty(name,attrs) >]
+let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >]
+let xml_cdata str = [< 'Str str >]
+
+(* Usage: *)
+(* pp tokens None pretty prints the output on stdout *)
+(* pp tokens (Some filename) pretty prints the output on the file filename *)
+let pp_ch strm channel =
+ let rec pp_r m =
+ parser
+ [< 'Str a ; s >] ->
+ print_spaces m ;
+ fprint_string (a ^ "\n") ;
+ pp_r m s
+ | [< 'Empty(n,l) ; s >] ->
+ print_spaces m ;
+ fprint_string ("<" ^ n) ;
+ List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
+ fprint_string "/>\n" ;
+ pp_r m s
+ | [< 'NEmpty(n,l,c) ; s >] ->
+ print_spaces m ;
+ fprint_string ("<" ^ n) ;
+ List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
+ fprint_string ">\n" ;
+ pp_r (m+1) c ;
+ print_spaces m ;
+ fprint_string ("</" ^ n ^ ">\n") ;
+ pp_r m s
+ | [< >] -> ()
+ and print_spaces m =
+ for i = 1 to m do fprint_string " " done
+ and fprint_string str =
+ output_string channel str
+ in
+ pp_r 0 strm
+;;
+
+
+let pp strm fn =
+ match fn with
+ Some filename ->
+ let filename = filename ^ ".xml" in
+ let ch = open_out filename in
+ pp_ch strm ch;
+ close_out ch ;
+ print_string ("\nWriting on file \"" ^ filename ^ "\" was successful\n");
+ flush stdout
+ | None ->
+ pp_ch strm stdout
+;;
+
diff --git a/plugins/xml/xml.mli b/plugins/xml/xml.mli
new file mode 100644
index 00000000..3775287a
--- /dev/null
+++ b/plugins/xml/xml.mli
@@ -0,0 +1,40 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(* Tokens for XML cdata, empty elements and not-empty elements *)
+(* Usage: *)
+(* Str cdata *)
+(* Empty (element_name, [attrname1, value1 ; ... ; attrnamen, valuen] *)
+(* NEmpty (element_name, [attrname1, value2 ; ... ; attrnamen, valuen], *)
+(* content *)
+type token =
+ | Str of string
+ | Empty of string * (string * string) list
+ | NEmpty of string * (string * string) list * token Stream.t
+
+(* currified versions of the token constructors make the code more readable *)
+val xml_empty : string -> (string * string) list -> token Stream.t
+val xml_nempty :
+ string -> (string * string) list -> token Stream.t -> token Stream.t
+val xml_cdata : string -> token Stream.t
+
+val pp_ch : token Stream.t -> out_channel -> unit
+
+(* The pretty printer for streams of token *)
+(* Usage: *)
+(* pp tokens None pretty prints the output on stdout *)
+(* pp tokens (Some filename) pretty prints the output on the file filename *)
+val pp : token Stream.t -> string option -> unit
diff --git a/plugins/xml/xml_plugin.mllib b/plugins/xml/xml_plugin.mllib
new file mode 100644
index 00000000..90797e8d
--- /dev/null
+++ b/plugins/xml/xml_plugin.mllib
@@ -0,0 +1,13 @@
+Unshare
+Xml
+Acic
+DoubleTypeInference
+Cic2acic
+Acic2Xml
+Proof2aproof
+Xmlcommand
+ProofTree2Xml
+Xmlentries
+Cic2Xml
+Dumptree
+Xml_plugin_mod
diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml
new file mode 100644
index 00000000..2299e6c8
--- /dev/null
+++ b/plugins/xml/xmlcommand.ml
@@ -0,0 +1,719 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+(* CONFIGURATION PARAMETERS *)
+
+let verbose = ref false;;
+
+(* HOOKS *)
+let print_proof_tree, set_print_proof_tree =
+ let print_proof_tree = ref (fun _ _ _ _ _ _ -> None) in
+ (fun () -> !print_proof_tree),
+ (fun f ->
+ print_proof_tree :=
+ fun
+ curi sigma0 pf proof_tree_to_constr proof_tree_to_flattened_proof_tree
+ constr_to_ids
+ ->
+ Some
+ (f curi sigma0 pf proof_tree_to_constr
+ proof_tree_to_flattened_proof_tree constr_to_ids))
+;;
+
+(* UTILITY FUNCTIONS *)
+
+let print_if_verbose s = if !verbose then print_string s;;
+
+(* Next exception is used only inside print_coq_object and tag_of_string_tag *)
+exception Uninteresting;;
+
+(* NOT USED anymore, we back to the V6 point of view with global parameters
+
+(* Internally, for Coq V7, params of inductive types are associated *)
+(* not to the whole block of mutual inductive (as it was in V6) but to *)
+(* each member of the block; but externally, all params are required *)
+(* to be the same; the following function checks that the parameters *)
+(* of each inductive of a same block are all the same, then returns *)
+(* this number; it fails otherwise *)
+let extract_nparams pack =
+ let module D = Declarations in
+ let module U = Util in
+ let module S = Sign in
+
+ let {D.mind_nparams=nparams0} = pack.(0) in
+ let arity0 = pack.(0).D.mind_user_arity in
+ let params0, _ = S.decompose_prod_n_assum nparams0 arity0 in
+ for i = 1 to Array.length pack - 1 do
+ let {D.mind_nparams=nparamsi} = pack.(i) in
+ let arityi = pack.(i).D.mind_user_arity in
+ let paramsi, _ = S.decompose_prod_n_assum nparamsi arityi in
+ if params0 <> paramsi then U.error "Cannot convert a block of inductive definitions with parameters specific to each inductive to a block of mutual inductive definitions with parameters global to the whole block"
+ done;
+ nparams0
+
+*)
+
+(* could_have_namesakes sp = true iff o is an object that could be cooked and *)
+(* than that could exists in cooked form with the same name in a super *)
+(* section of the actual section *)
+let could_have_namesakes o sp = (* namesake = omonimo in italian *)
+ let module DK = Decl_kinds in
+ let module D = Declare in
+ let tag = Libobject.object_tag o in
+ print_if_verbose ("Object tag: " ^ tag ^ "\n") ;
+ match tag with
+ "CONSTANT" -> true (* constants/parameters are non global *)
+ | "INDUCTIVE" -> true (* mutual inductive types are never local *)
+ | "VARIABLE" -> false (* variables are local, so no namesakes *)
+ | _ -> false (* uninteresting thing that won't be printed*)
+;;
+
+(* filter_params pvars hyps *)
+(* filters out from pvars (which is a list of lists) all the variables *)
+(* that does not belong to hyps (which is a simple list) *)
+(* It returns a list of couples relative section path -- list of *)
+(* variable names. *)
+let filter_params pvars hyps =
+ let rec aux ids =
+ function
+ [] -> []
+ | (id,he)::tl ->
+ let ids' = id::ids in
+ let ids'' =
+ "cic:/" ^
+ String.concat "/" (List.rev (List.map Names.string_of_id ids')) in
+ let he' =
+ ids'', List.rev (List.filter (function x -> List.mem x hyps) he) in
+ let tl' = aux ids' tl in
+ match he' with
+ _,[] -> tl'
+ | _,_ -> he'::tl'
+ in
+ let cwd = Lib.cwd () in
+ let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
+ let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in
+ aux (Names.repr_dirpath modulepath) (List.rev pvars)
+;;
+
+type variables_type =
+ Definition of string * Term.constr * Term.types
+ | Assumption of string * Term.constr
+;;
+
+(* The computation is very inefficient, but we can't do anything *)
+(* better unless this function is reimplemented in the Declare *)
+(* module. *)
+let search_variables () =
+ let module N = Names in
+ let cwd = Lib.cwd () in
+ let cwdsp = Libnames.make_path cwd (Names.id_of_string "dummy") in
+ let modulepath = Cic2acic.get_module_path_of_full_path cwdsp in
+ let rec aux =
+ function
+ [] -> []
+ | he::tl as modules ->
+ let one_section_variables =
+ let dirpath = N.make_dirpath (modules @ N.repr_dirpath modulepath) in
+ let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in
+ [he,t]
+ in
+ one_section_variables @ aux tl
+ in
+ aux
+ (Cic2acic.remove_module_dirpath_from_dirpath
+ ~basedir:modulepath cwd)
+;;
+
+(* FUNCTIONS TO PRINT A SINGLE OBJECT OF COQ *)
+
+let rec join_dirs cwd =
+ function
+ [] -> cwd
+ | he::tail ->
+ (try
+ Unix.mkdir cwd 0o775
+ with _ -> () (* Let's ignore the errors on mkdir *)
+ ) ;
+ let newcwd = cwd ^ "/" ^ he in
+ join_dirs newcwd tail
+;;
+
+let filename_of_path xml_library_root tag =
+ let module N = Names in
+ match xml_library_root with
+ None -> None (* stdout *)
+ | Some xml_library_root' ->
+ let tokens = Cic2acic.token_list_of_kernel_name tag in
+ Some (join_dirs xml_library_root' tokens)
+;;
+
+let body_filename_of_filename =
+ function
+ Some f -> Some (f ^ ".body")
+ | None -> None
+;;
+
+let types_filename_of_filename =
+ function
+ Some f -> Some (f ^ ".types")
+ | None -> None
+;;
+
+let prooftree_filename_of_filename =
+ function
+ Some f -> Some (f ^ ".proof_tree")
+ | None -> None
+;;
+
+let theory_filename xml_library_root =
+ let module N = Names in
+ match xml_library_root with
+ None -> None (* stdout *)
+ | Some xml_library_root' ->
+ let toks = List.map N.string_of_id (N.repr_dirpath (Lib.library_dp ())) in
+ (* theory from A/B/C/F.v goes into A/B/C/F.theory *)
+ let alltoks = List.rev toks in
+ Some (join_dirs xml_library_root' alltoks ^ ".theory")
+
+let print_object uri obj sigma proof_tree_infos filename =
+ (* function to pretty print and compress an XML file *)
+(*CSC: Unix.system "gzip ..." is an horrible non-portable solution. *)
+ let pp xml filename =
+ Xml.pp xml filename ;
+ match filename with
+ None -> ()
+ | Some fn ->
+ let fn' =
+ let rec escape s n =
+ try
+ let p = String.index_from s n '\'' in
+ String.sub s n (p - n) ^ "\\'" ^ escape s (p+1)
+ with Not_found -> String.sub s n (String.length s - n)
+ in
+ escape fn 0
+ in
+ ignore (Unix.system ("gzip " ^ fn' ^ ".xml"))
+ in
+ let (annobj,_,constr_to_ids,_,ids_to_inner_sorts,ids_to_inner_types,_,_) =
+ Cic2acic.acic_object_of_cic_object sigma obj in
+ let (xml, xml') = Acic2Xml.print_object uri ids_to_inner_sorts annobj in
+ let xmltypes =
+ Acic2Xml.print_inner_types uri ids_to_inner_sorts ids_to_inner_types in
+ pp xml filename ;
+ begin
+ match xml' with
+ None -> ()
+ | Some xml' -> pp xml' (body_filename_of_filename filename)
+ end ;
+ pp xmltypes (types_filename_of_filename filename) ;
+ match proof_tree_infos with
+ None -> ()
+ | Some (sigma0,proof_tree,proof_tree_to_constr,
+ proof_tree_to_flattened_proof_tree) ->
+ let xmlprooftree =
+ print_proof_tree ()
+ uri sigma0 proof_tree proof_tree_to_constr
+ proof_tree_to_flattened_proof_tree constr_to_ids
+ in
+ match xmlprooftree with
+ None -> ()
+ | Some xmlprooftree ->
+ pp xmlprooftree (prooftree_filename_of_filename filename)
+;;
+
+let string_list_of_named_context_list =
+ List.map
+ (function (n,_,_) -> Names.string_of_id n)
+;;
+
+(* Function to collect the variables that occur in a term. *)
+(* Used only for variables (since for constants and mutual *)
+(* inductive types this information is already available. *)
+let find_hyps t =
+ let module T = Term in
+ let rec aux l t =
+ match T.kind_of_term t with
+ T.Var id when not (List.mem id l) ->
+ let (_,bo,ty) = Global.lookup_named id in
+ let boids =
+ match bo with
+ Some bo' -> aux l bo'
+ | None -> l
+ in
+ id::(aux boids ty)
+ | T.Var _
+ | T.Rel _
+ | T.Meta _
+ | T.Evar _
+ | T.Sort _ -> l
+ | T.Cast (te,_, ty) -> aux (aux l te) ty
+ | T.Prod (_,s,t) -> aux (aux l s) t
+ | T.Lambda (_,s,t) -> aux (aux l s) t
+ | T.LetIn (_,s,_,t) -> aux (aux l s) t
+ | T.App (he,tl) -> Array.fold_left (fun i x -> aux i x) (aux l he) tl
+ | T.Const con ->
+ let hyps = (Global.lookup_constant con).Declarations.const_hyps in
+ map_and_filter l hyps @ l
+ | T.Ind ind
+ | T.Construct (ind,_) ->
+ let hyps = (fst (Global.lookup_inductive ind)).Declarations.mind_hyps in
+ map_and_filter l hyps @ l
+ | T.Case (_,t1,t2,b) ->
+ Array.fold_left (fun i x -> aux i x) (aux (aux l t1) t2) b
+ | T.Fix (_,(_,tys,bodies))
+ | T.CoFix (_,(_,tys,bodies)) ->
+ let r = Array.fold_left (fun i x -> aux i x) l tys in
+ Array.fold_left (fun i x -> aux i x) r bodies
+ and map_and_filter l =
+ function
+ [] -> []
+ | (n,_,_)::tl when not (List.mem n l) -> n::(map_and_filter l tl)
+ | _::tl -> map_and_filter l tl
+ in
+ aux [] t
+;;
+
+(* Functions to construct an object *)
+
+let mk_variable_obj id body typ =
+ let hyps,unsharedbody =
+ match body with
+ None -> [],None
+ | Some bo -> find_hyps bo, Some (Unshare.unshare bo)
+ in
+ let hyps' = find_hyps typ @ hyps in
+ let hyps'' = List.map Names.string_of_id hyps' in
+ let variables = search_variables () in
+ let params = filter_params variables hyps'' in
+ Acic.Variable
+ (Names.string_of_id id, unsharedbody, Unshare.unshare typ, params)
+;;
+
+(* Unsharing is not performed on the body, that must be already unshared. *)
+(* The evar map and the type, instead, are unshared by this function. *)
+let mk_current_proof_obj is_a_variable id bo ty evar_map env =
+ let unshared_ty = Unshare.unshare ty in
+ let metasenv =
+ List.map
+ (function
+ (n, {Evd.evar_concl = evar_concl ;
+ Evd.evar_hyps = evar_hyps}
+ ) ->
+ (* We map the named context to a rel context and every Var to a Rel *)
+ let final_var_ids,context =
+ let rec aux var_ids =
+ function
+ [] -> var_ids,[]
+ | (n,None,t)::tl ->
+ let final_var_ids,tl' = aux (n::var_ids) tl in
+ let t' = Term.subst_vars var_ids t in
+ final_var_ids,(n, Acic.Decl (Unshare.unshare t'))::tl'
+ | (n,Some b,t)::tl ->
+ let final_var_ids,tl' = aux (n::var_ids) tl in
+ let b' = Term.subst_vars var_ids b in
+ (* t will not be exported to XML. Thus no unsharing performed *)
+ final_var_ids,(n, Acic.Def (Unshare.unshare b',t))::tl'
+ in
+ aux [] (List.rev (Environ.named_context_of_val evar_hyps))
+ in
+ (* We map the named context to a rel context and every Var to a Rel *)
+ (n,context,Unshare.unshare (Term.subst_vars final_var_ids evar_concl))
+ ) (Evarutil.non_instantiated evar_map)
+ in
+ let id' = Names.string_of_id id in
+ if metasenv = [] then
+ let ids =
+ Names.Idset.union
+ (Environ.global_vars_set env bo) (Environ.global_vars_set env ty) in
+ let hyps0 = Environ.keep_hyps env ids in
+ let hyps = string_list_of_named_context_list hyps0 in
+ (* Variables are the identifiers of the variables in scope *)
+ let variables = search_variables () in
+ let params = filter_params variables hyps in
+ if is_a_variable then
+ Acic.Variable (id',Some bo,unshared_ty,params)
+ else
+ Acic.Constant (id',Some bo,unshared_ty,params)
+ else
+ Acic.CurrentProof (id',metasenv,bo,unshared_ty)
+;;
+
+let mk_constant_obj id bo ty variables hyps =
+ let hyps = string_list_of_named_context_list hyps in
+ let ty = Unshare.unshare ty in
+ let params = filter_params variables hyps in
+ match bo with
+ None ->
+ Acic.Constant (Names.string_of_id id,None,ty,params)
+ | Some c ->
+ Acic.Constant
+ (Names.string_of_id id, Some (Unshare.unshare (Declarations.force c)),
+ ty,params)
+;;
+
+let mk_inductive_obj sp mib packs variables nparams hyps finite =
+ let module D = Declarations in
+ let hyps = string_list_of_named_context_list hyps in
+ let params = filter_params variables hyps in
+(* let nparams = extract_nparams packs in *)
+ let tys =
+ let tyno = ref (Array.length packs) in
+ Array.fold_right
+ (fun p i ->
+ decr tyno ;
+ let {D.mind_consnames=consnames ;
+ D.mind_typename=typename } = p
+ in
+ let arity = Inductive.type_of_inductive (Global.env()) (mib,p) in
+ let lc = Inductiveops.arities_of_constructors (Global.env ()) (sp,!tyno) in
+ let cons =
+ (Array.fold_right (fun (name,lc) i -> (name,lc)::i)
+ (Array.mapi
+ (fun j x ->(x,Unshare.unshare lc.(j))) consnames)
+ []
+ )
+ in
+ (typename,finite,Unshare.unshare arity,cons)::i
+ ) packs []
+ in
+ Acic.InductiveDefinition (tys,params,nparams)
+;;
+
+(* The current channel for .theory files *)
+let theory_buffer = Buffer.create 4000;;
+
+let theory_output_string ?(do_not_quote = false) s =
+ (* prepare for coqdoc post-processing *)
+ let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in
+ print_if_verbose s;
+ Buffer.add_string theory_buffer s
+;;
+
+let kind_of_global_goal = function
+ | Decl_kinds.Global, Decl_kinds.DefinitionBody _ -> "DEFINITION","InteractiveDefinition"
+ | Decl_kinds.Global, (Decl_kinds.Proof k) -> "THEOREM",Decl_kinds.string_of_theorem_kind k
+ | Decl_kinds.Local, _ -> assert false
+
+let kind_of_inductive isrecord kn =
+ "DEFINITION",
+ if (fst (Global.lookup_inductive (kn,0))).Declarations.mind_finite
+ then begin
+ match isrecord with
+ | Declare.KernelSilent -> "Record"
+ | _ -> "Inductive"
+ end
+ else "CoInductive"
+;;
+
+let kind_of_variable id =
+ let module DK = Decl_kinds in
+ match Decls.variable_kind id with
+ | DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption"
+ | DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis"
+ | DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture"
+ | DK.IsDefinition DK.Definition -> "VARIABLE","LocalDefinition"
+ | DK.IsProof _ -> "VARIABLE","LocalFact"
+ | _ -> Util.anomaly "Unsupported variable kind"
+;;
+
+let kind_of_constant kn =
+ let module DK = Decl_kinds in
+ match Decls.constant_kind kn with
+ | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration"
+ | DK.IsAssumption DK.Logical -> "AXIOM","Axiom"
+ | DK.IsAssumption DK.Conjectural ->
+ Pp.warning "Conjecture not supported in dtd (used Declaration instead)";
+ "AXIOM","Declaration"
+ | DK.IsDefinition DK.Definition -> "DEFINITION","Definition"
+ | DK.IsDefinition DK.Example ->
+ Pp.warning "Example not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.Coercion ->
+ Pp.warning "Coercion not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.SubClass ->
+ Pp.warning "SubClass not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.CanonicalStructure ->
+ Pp.warning "CanonicalStructure not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.Fixpoint ->
+ Pp.warning "Fixpoint not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.CoFixpoint ->
+ Pp.warning "CoFixpoint not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.Scheme ->
+ Pp.warning "Scheme not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.StructureComponent ->
+ Pp.warning "StructureComponent not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.IdentityCoercion ->
+ Pp.warning "IdentityCoercion not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.Instance ->
+ Pp.warning "Instance not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsDefinition DK.Method ->
+ Pp.warning "Method not supported in dtd (used Definition instead)";
+ "DEFINITION","Definition"
+ | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) ->
+ "THEOREM",DK.string_of_theorem_kind thm
+ | DK.IsProof _ ->
+ Pp.warning "Unsupported theorem kind (used Theorem instead)";
+ "THEOREM",DK.string_of_theorem_kind DK.Theorem
+;;
+
+let kind_of_global r =
+ let module Ln = Libnames in
+ let module DK = Decl_kinds in
+ match r with
+ | Ln.IndRef kn | Ln.ConstructRef (kn,_) ->
+ let isrecord =
+ try let _ = Recordops.lookup_projections kn in Declare.KernelSilent
+ with Not_found -> Declare.KernelVerbose in
+ kind_of_inductive isrecord (fst kn)
+ | Ln.VarRef id -> kind_of_variable id
+ | Ln.ConstRef kn -> kind_of_constant kn
+;;
+
+let print_object_kind uri (xmltag,variation) =
+ let s =
+ Printf.sprintf "<ht:%s uri=\"%s\" as=\"%s\"/>\n" xmltag uri variation
+ in
+ theory_output_string s
+;;
+
+(* print id dest *)
+(* where sp is the qualified identifier (section path) of a *)
+(* definition/theorem, variable or inductive definition *)
+(* and dest is either None (for stdout) or (Some filename) *)
+(* pretty prints via Xml.pp the object whose identifier is id on dest *)
+(* Note: it is printed only (and directly) the most cooked available *)
+(* form of the definition (all the parameters are *)
+(* lambda-abstracted, but the object can still refer to variables) *)
+let print internal glob_ref kind xml_library_root =
+ let module D = Declarations in
+ let module De = Declare in
+ let module G = Global in
+ let module N = Names in
+ let module Nt = Nametab in
+ let module T = Term in
+ let module X = Xml in
+ let module Ln = Libnames in
+ (* Variables are the identifiers of the variables in scope *)
+ let variables = search_variables () in
+ let tag,obj =
+ match glob_ref with
+ Ln.VarRef id ->
+ (* this kn is fake since it is not provided by Coq *)
+ let kn =
+ let (mod_path,dir_path) = Lib.current_prefix () in
+ N.make_kn mod_path dir_path (N.label_of_id id)
+ in
+ let (_,body,typ) = G.lookup_named id in
+ 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 typ = Typeops.type_of_constant_type (Global.env()) typ in
+ Cic2acic.Constant kn,mk_constant_obj id val0 typ variables hyps
+ | Ln.IndRef (kn,_) ->
+ let mib = G.lookup_mind kn in
+ let {D.mind_nparams=nparams;
+ D.mind_packets=packs ;
+ D.mind_hyps=hyps;
+ D.mind_finite=finite} = mib in
+ Cic2acic.Inductive kn,mk_inductive_obj kn mib packs variables nparams hyps finite
+ | Ln.ConstructRef _ ->
+ Util.error ("a single constructor cannot be printed in XML")
+ in
+ let fn = filename_of_path xml_library_root tag in
+ let uri = Cic2acic.uri_of_kernel_name tag in
+ (match internal with
+ | Declare.KernelSilent -> ()
+ | _ -> print_object_kind uri kind);
+ print_object uri obj Evd.empty None fn
+;;
+
+let print_ref qid fn =
+ let ref = Nametab.global qid in
+ print Declare.UserVerbose ref (kind_of_global ref) fn
+
+(* show dest *)
+(* where dest is either None (for stdout) or (Some filename) *)
+(* pretty prints via Xml.pp the proof in progress on dest *)
+let show_pftreestate internal fn (kind,pftst) id =
+ let 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
+;;
+
+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
+;;
+
+
+(* Let's register the callbacks *)
+let xml_library_root =
+ try
+ Some (Sys.getenv "COQ_XML_LIBRARY_ROOT")
+ with Not_found -> None
+;;
+
+let proof_to_export = ref None (* holds the proof-tree to export *)
+;;
+
+let _ =
+ Pfedit.set_xml_cook_proof
+ (function pftreestate -> proof_to_export := Some pftreestate)
+;;
+
+let _ =
+ Declare.set_xml_declare_variable
+ (function (sp,kn) ->
+ let id = Libnames.basename sp in
+ print Declare.UserVerbose (Libnames.VarRef id) (kind_of_variable id) xml_library_root ;
+ proof_to_export := None)
+;;
+
+let _ =
+ Declare.set_xml_declare_constant
+ (function (internal,kn) ->
+ match !proof_to_export with
+ None ->
+ print internal (Libnames.ConstRef kn) (kind_of_constant kn)
+ xml_library_root
+ | Some pftreestate ->
+ (* It is a proof. Let's export it starting from the proof-tree *)
+ (* I saved in the Pfedit.set_xml_cook_proof callback. *)
+ let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in
+ show_pftreestate internal fn pftreestate
+ (Names.id_of_label (Names.con_label kn)) ;
+ proof_to_export := None)
+;;
+
+let _ =
+ Declare.set_xml_declare_inductive
+ (function (isrecord,(sp,kn)) ->
+ print Declare.UserVerbose (Libnames.IndRef (Names.mind_of_kn kn,0))
+ (kind_of_inductive isrecord (Names.mind_of_kn kn))
+ xml_library_root)
+;;
+
+let _ =
+ Vernac.set_xml_start_library
+ (function () ->
+ Buffer.reset theory_buffer;
+ theory_output_string "<?xml version=\"1.0\" encoding=\"latin1\"?>\n";
+ theory_output_string ("<!DOCTYPE html [\n" ^
+ "<!ENTITY % xhtml-lat1.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-lat1.ent\">\n" ^
+ "<!ENTITY % xhtml-special.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-special.ent\">\n" ^
+ "<!ENTITY % xhtml-symbol.ent SYSTEM \"http://helm.cs.unibo.it/dtd/xhtml-symbol.ent\">\n\n" ^
+ "%xhtml-lat1.ent;\n" ^
+ "%xhtml-special.ent;\n" ^
+ "%xhtml-symbol.ent;\n" ^
+ "]>\n\n");
+ theory_output_string "<html xmlns=\"http://www.w3.org/1999/xhtml\" xmlns:ht=\"http://www.cs.unibo.it/helm/namespaces/helm-theory\" xmlns:helm=\"http://www.cs.unibo.it/helm\">\n";
+ theory_output_string "<head></head>\n<body>\n")
+;;
+
+let _ =
+ Vernac.set_xml_end_library
+ (function () ->
+ theory_output_string "</body>\n</html>\n";
+ let ofn = theory_filename xml_library_root in
+ begin
+ match ofn with
+ None ->
+ Buffer.output_buffer stdout theory_buffer ;
+ | Some fn ->
+ let ch = open_out (fn ^ ".v") in
+ Buffer.output_buffer ch theory_buffer ;
+ close_out ch;
+ (* dummy glob file *)
+ let ch = open_out (fn ^ ".glob") in
+ close_out ch
+ end ;
+ Option.iter
+ (fun fn ->
+ 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
+ Util.anomaly ("Error executing \"" ^ cmd ^ "\"")
+ in
+ command (coqdoc^options^" -o "^fn^".xml "^fn^".v");
+ command ("rm "^fn^".v "^fn^".glob");
+ print_string("\nWriting on file \"" ^ fn ^ ".xml\" was successful\n"))
+ ofn)
+;;
+
+let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;;
+
+let uri_of_dirpath dir =
+ "/" ^ String.concat "/"
+ (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir)))
+;;
+
+let _ =
+ Lib.set_xml_open_section
+ (fun _ ->
+ let s = "cic:" ^ uri_of_dirpath (Lib.cwd ()) in
+ theory_output_string ("<ht:SECTION uri=\""^s^"\">"))
+;;
+
+let _ =
+ Lib.set_xml_close_section
+ (fun _ -> theory_output_string "</ht:SECTION>")
+;;
+
+let _ =
+ Library.set_xml_require
+ (fun d -> theory_output_string
+ (Printf.sprintf "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>"
+ (uri_of_dirpath d) (Names.string_of_dirpath d)))
+;;
diff --git a/plugins/xml/xmlcommand.mli b/plugins/xml/xmlcommand.mli
new file mode 100644
index 00000000..66ff9f0b
--- /dev/null
+++ b/plugins/xml/xmlcommand.mli
@@ -0,0 +1,41 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+(*i $Id$ i*)
+
+(* print_global qid fn *)
+(* where qid is a long name denoting a definition/theorem or *)
+(* an inductive definition *)
+(* and dest is either None (for stdout) or (Some filename) *)
+(* pretty prints via Xml.pp the object whose name is ref on dest *)
+(* Note: it is printed only (and directly) the most discharged available *)
+(* form of the definition (all the parameters are *)
+(* lambda-abstracted, but the object can still refer to variables) *)
+val print_ref : Libnames.reference -> string option -> unit
+
+(* show dest *)
+(* where dest is either None (for stdout) or (Some filename) *)
+(* pretty prints via Xml.pp the proof in progress on dest *)
+val show : string option -> unit
+
+(* set_print_proof_tree f *)
+(* sets a callback function f to export the proof_tree to XML *)
+val set_print_proof_tree :
+ (string ->
+ Evd.evar_map ->
+ Proof_type.proof_tree ->
+ Term.constr Proof2aproof.ProofTreeHash.t ->
+ Proof_type.proof_tree Proof2aproof.ProofTreeHash.t ->
+ string Acic.CicHash.t -> Xml.token Stream.t) ->
+ unit
diff --git a/plugins/xml/xmlentries.ml4 b/plugins/xml/xmlentries.ml4
new file mode 100644
index 00000000..41c107ad
--- /dev/null
+++ b/plugins/xml/xmlentries.ml4
@@ -0,0 +1,40 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * The HELM Project / The EU MoWGLI Project *)
+(* * University of Bologna *)
+(************************************************************************)
+(* This file is distributed under the terms of the *)
+(* GNU Lesser General Public License Version 2.1 *)
+(* *)
+(* Copyright (C) 2000-2004, HELM Team. *)
+(* http://helm.cs.unibo.it *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id$ *)
+
+open Util;;
+open Vernacinterp;;
+
+open Extend;;
+open Genarg;;
+open Pp;;
+open Pcoq;;
+
+(* File name *)
+
+VERNAC ARGUMENT EXTEND filename
+| [ "File" string(fn) ] -> [ Some fn ]
+| [ ] -> [ None ]
+END
+
+(* Print XML and Show XML *)
+
+VERNAC COMMAND EXTEND Xml
+| [ "Print" "XML" filename(fn) global(qid) ] -> [ Xmlcommand.print_ref qid fn ]
+
+| [ "Show" "XML" filename(fn) "Proof" ] -> [ Xmlcommand.show fn ]
+END