summaryrefslogtreecommitdiff
path: root/contrib
diff options
context:
space:
mode:
authorGravatar Samuel Mimram <smimram@debian.org>2008-07-25 15:12:53 +0200
committerGravatar Samuel Mimram <smimram@debian.org>2008-07-25 15:12:53 +0200
commita0cfa4f118023d35b767a999d5a2ac4b082857b4 (patch)
treedabcac548e299fee1da464c93b3dba98484f45b1 /contrib
parent2281410e38ef99d025ea77194585a9bc019fdaa9 (diff)
Imported Upstream version 8.2~beta3+dfsgupstream/8.2.beta3+dfsg
Diffstat (limited to 'contrib')
-rw-r--r--contrib/cc/ccalgo.ml307
-rw-r--r--contrib/cc/ccalgo.mli19
-rw-r--r--contrib/cc/ccproof.ml2
-rw-r--r--contrib/cc/ccproof.mli2
-rw-r--r--contrib/cc/cctac.ml145
-rw-r--r--contrib/cc/cctac.mli4
-rw-r--r--contrib/cc/g_congruence.ml410
-rw-r--r--contrib/correctness/ProgramsExtraction.v4
-rw-r--r--contrib/correctness/past.mli97
-rw-r--r--contrib/correctness/pcic.ml231
-rw-r--r--contrib/correctness/pcic.mli24
-rw-r--r--contrib/correctness/pcicenv.ml118
-rw-r--r--contrib/correctness/pcicenv.mli38
-rw-r--r--contrib/correctness/pdb.ml165
-rw-r--r--contrib/correctness/pdb.mli25
-rw-r--r--contrib/correctness/peffect.ml159
-rw-r--r--contrib/correctness/peffect.mli42
-rw-r--r--contrib/correctness/penv.ml240
-rw-r--r--contrib/correctness/penv.mli87
-rw-r--r--contrib/correctness/perror.ml172
-rw-r--r--contrib/correctness/perror.mli47
-rw-r--r--contrib/correctness/pextract.ml473
-rw-r--r--contrib/correctness/pextract.mli17
-rw-r--r--contrib/correctness/pmisc.ml222
-rw-r--r--contrib/correctness/pmisc.mli81
-rw-r--r--contrib/correctness/pmlize.ml320
-rw-r--r--contrib/correctness/pmlize.mli20
-rw-r--r--contrib/correctness/pmonad.ml665
-rw-r--r--contrib/correctness/pmonad.mli106
-rw-r--r--contrib/correctness/pred.ml115
-rw-r--r--contrib/correctness/pred.mli26
-rw-r--r--contrib/correctness/prename.ml139
-rw-r--r--contrib/correctness/prename.mli57
-rw-r--r--contrib/correctness/psyntax.ml41058
-rw-r--r--contrib/correctness/psyntax.mli25
-rw-r--r--contrib/correctness/ptactic.ml258
-rw-r--r--contrib/correctness/ptactic.mli22
-rw-r--r--contrib/correctness/ptype.mli73
-rw-r--r--contrib/correctness/ptyping.ml600
-rw-r--r--contrib/correctness/ptyping.mli36
-rw-r--r--contrib/correctness/putil.ml303
-rw-r--r--contrib/correctness/putil.mli72
-rw-r--r--contrib/correctness/pwp.ml347
-rw-r--r--contrib/correctness/pwp.mli18
-rw-r--r--contrib/dp/Dp.v120
-rw-r--r--contrib/dp/TODO4
-rw-r--r--contrib/dp/dp.ml316
-rw-r--r--contrib/dp/dp.mli8
-rw-r--r--contrib/dp/dp_cvcl.ml112
-rw-r--r--contrib/dp/dp_cvcl.mli4
-rw-r--r--contrib/dp/dp_gappa.ml445
-rw-r--r--contrib/dp/dp_simplify.ml117
-rw-r--r--contrib/dp/dp_simplify.mli4
-rw-r--r--contrib/dp/dp_sorts.ml51
-rw-r--r--contrib/dp/dp_sorts.mli4
-rw-r--r--contrib/dp/dp_why.ml12
-rw-r--r--contrib/dp/dp_why.mli17
-rw-r--r--contrib/dp/dp_zenon.ml103
-rw-r--r--contrib/dp/dp_zenon.mli5
-rw-r--r--contrib/dp/dp_zenon.mll181
-rw-r--r--contrib/dp/fol.mli9
-rw-r--r--contrib/dp/g_dp.ml443
-rw-r--r--contrib/dp/test2.v8
-rw-r--r--contrib/dp/test_gappa.v91
-rw-r--r--contrib/dp/tests.v116
-rw-r--r--contrib/dp/zenon.v94
-rw-r--r--contrib/extraction/CHANGES4
-rw-r--r--contrib/extraction/common.ml759
-rw-r--r--contrib/extraction/common.mli50
-rw-r--r--contrib/extraction/extract_env.ml453
-rw-r--r--contrib/extraction/extract_env.mli13
-rw-r--r--contrib/extraction/extraction.ml63
-rw-r--r--contrib/extraction/extraction.mli14
-rw-r--r--contrib/extraction/g_extraction.ml47
-rw-r--r--contrib/extraction/haskell.ml134
-rw-r--r--contrib/extraction/haskell.mli12
-rw-r--r--contrib/extraction/miniml.mli66
-rw-r--r--contrib/extraction/mlutil.ml79
-rw-r--r--contrib/extraction/modutil.ml209
-rw-r--r--contrib/extraction/modutil.mli36
-rw-r--r--contrib/extraction/ocaml.ml704
-rw-r--r--contrib/extraction/ocaml.mli46
-rw-r--r--contrib/extraction/scheme.ml75
-rw-r--r--contrib/extraction/scheme.mli20
-rw-r--r--contrib/extraction/table.ml173
-rw-r--r--contrib/extraction/table.mli36
-rw-r--r--contrib/extraction/test/.depend1136
-rw-r--r--contrib/extraction/test/Makefile109
-rw-r--r--contrib/extraction/test/Makefile.haskell416
-rw-r--r--contrib/extraction/test/addReals21
-rw-r--r--contrib/extraction/test/custom/Adalloc2
-rw-r--r--contrib/extraction/test/custom/Euclid1
-rw-r--r--contrib/extraction/test/custom/List1
-rw-r--r--contrib/extraction/test/custom/ListSet1
-rw-r--r--contrib/extraction/test/custom/Lsort2
-rw-r--r--contrib/extraction/test/custom/Map3
-rw-r--r--contrib/extraction/test/custom/Mapcard4
-rw-r--r--contrib/extraction/test/custom/Mapiter2
-rw-r--r--contrib/extraction/test/custom/R_Ifp2
-rw-r--r--contrib/extraction/test/custom/R_sqr2
-rw-r--r--contrib/extraction/test/custom/Ranalysis2
-rw-r--r--contrib/extraction/test/custom/Raxioms2
-rw-r--r--contrib/extraction/test/custom/Rbase2
-rw-r--r--contrib/extraction/test/custom/Rbasic_fun2
-rw-r--r--contrib/extraction/test/custom/Rdefinitions2
-rw-r--r--contrib/extraction/test/custom/Reals.v17
-rw-r--r--contrib/extraction/test/custom/Rfunctions2
-rw-r--r--contrib/extraction/test/custom/Rgeom2
-rw-r--r--contrib/extraction/test/custom/Rlimit2
-rw-r--r--contrib/extraction/test/custom/Rseries2
-rw-r--r--contrib/extraction/test/custom/Rsigma2
-rw-r--r--contrib/extraction/test/custom/Rtrigo2
-rw-r--r--contrib/extraction/test/custom/ZArith_dec1
-rw-r--r--contrib/extraction/test/custom/fast_integer1
-rw-r--r--contrib/extraction/test/e17
-rwxr-xr-xcontrib/extraction/test/extract12
-rwxr-xr-xcontrib/extraction/test/extract.haskell12
-rw-r--r--contrib/extraction/test/hs2v.ml14
-rwxr-xr-xcontrib/extraction/test/make_mli17
-rw-r--r--contrib/extraction/test/ml2v.ml14
-rw-r--r--contrib/extraction/test/v2hs.ml9
-rw-r--r--contrib/extraction/test/v2ml.ml9
-rw-r--r--contrib/field/field.ml44
-rw-r--r--contrib/firstorder/formula.ml (renamed from contrib/first-order/formula.ml)4
-rw-r--r--contrib/firstorder/formula.mli (renamed from contrib/first-order/formula.mli)0
-rw-r--r--contrib/firstorder/g_ground.ml4 (renamed from contrib/first-order/g_ground.ml4)19
-rw-r--r--contrib/firstorder/ground.ml (renamed from contrib/first-order/ground.ml)2
-rw-r--r--contrib/firstorder/ground.mli (renamed from contrib/first-order/ground.mli)0
-rw-r--r--contrib/firstorder/instances.ml (renamed from contrib/first-order/instances.ml)6
-rw-r--r--contrib/firstorder/instances.mli (renamed from contrib/first-order/instances.mli)0
-rw-r--r--contrib/firstorder/rules.ml (renamed from contrib/first-order/rules.ml)10
-rw-r--r--contrib/firstorder/rules.mli (renamed from contrib/first-order/rules.mli)0
-rw-r--r--contrib/firstorder/sequent.ml (renamed from contrib/first-order/sequent.ml)4
-rw-r--r--contrib/firstorder/sequent.mli (renamed from contrib/first-order/sequent.mli)0
-rw-r--r--contrib/firstorder/unify.ml (renamed from contrib/first-order/unify.ml)0
-rw-r--r--contrib/firstorder/unify.mli (renamed from contrib/first-order/unify.mli)0
-rw-r--r--contrib/fourier/Fourier_util.v4
-rw-r--r--contrib/fourier/fourierR.ml21
-rw-r--r--contrib/funind/Recdef.v (renamed from contrib/recdef/Recdef.v)0
-rw-r--r--contrib/funind/functional_principles_proofs.ml88
-rw-r--r--contrib/funind/functional_principles_types.ml25
-rw-r--r--contrib/funind/g_indfun.ml4 (renamed from contrib/funind/indfun_main.ml4)67
-rw-r--r--contrib/funind/indfun.ml114
-rw-r--r--contrib/funind/indfun_common.ml57
-rw-r--r--contrib/funind/invfun.ml76
-rw-r--r--contrib/funind/merge.ml514
-rw-r--r--contrib/funind/rawterm_to_relation.ml41
-rw-r--r--contrib/funind/rawtermops.ml142
-rw-r--r--contrib/funind/rawtermops.mli8
-rw-r--r--contrib/funind/recdef.ml (renamed from contrib/recdef/recdef.ml4)678
-rw-r--r--contrib/funind/tacinv.ml4872
-rw-r--r--contrib/funind/tacinvutils.ml284
-rw-r--r--contrib/funind/tacinvutils.mli80
-rw-r--r--contrib/interface/COPYRIGHT6
-rw-r--r--contrib/interface/ascent.mli9
-rw-r--r--contrib/interface/blast.ml59
-rw-r--r--contrib/interface/centaur.ml4408
-rw-r--r--contrib/interface/debug_tac.ml410
-rw-r--r--contrib/interface/depends.ml454
-rw-r--r--contrib/interface/name_to_ast.ml12
-rw-r--r--contrib/interface/name_to_ast.mli4
-rw-r--r--contrib/interface/parse.ml27
-rw-r--r--contrib/interface/pbp.ml16
-rw-r--r--contrib/interface/showproof.ml23
-rw-r--r--contrib/interface/translate.ml3
-rw-r--r--contrib/interface/translate.mli1
-rw-r--r--contrib/interface/vtp.ml1575
-rw-r--r--contrib/interface/vtp.mli27
-rw-r--r--contrib/interface/xlate.ml337
-rw-r--r--contrib/interface/xlate.mli1
-rw-r--r--contrib/jprover/jall.ml103
-rw-r--r--contrib/jprover/jprover.ml42
-rw-r--r--contrib/micromega/CheckerMaker.v129
-rw-r--r--contrib/micromega/Env.v182
-rw-r--r--contrib/micromega/EnvRing.v1403
-rw-r--r--contrib/micromega/LICENSE.sos29
-rw-r--r--contrib/micromega/MExtraction.v23
-rw-r--r--contrib/micromega/Micromegatac.v79
-rw-r--r--contrib/micromega/OrderedRing.v458
-rw-r--r--contrib/micromega/QMicromega.v259
-rw-r--r--contrib/micromega/RMicromega.v148
-rw-r--r--contrib/micromega/Refl.v129
-rw-r--r--contrib/micromega/RingMicromega.v779
-rw-r--r--contrib/micromega/Tauto.v324
-rw-r--r--contrib/micromega/VarMap.v258
-rw-r--r--contrib/micromega/ZCoeff.v173
-rw-r--r--contrib/micromega/ZMicromega.v714
-rw-r--r--contrib/micromega/certificate.ml618
-rw-r--r--contrib/micromega/coq_micromega.ml1290
-rw-r--r--contrib/micromega/csdpcert.ml333
-rw-r--r--contrib/micromega/g_micromega.ml459
-rw-r--r--contrib/micromega/mfourier.ml667
-rw-r--r--contrib/micromega/micromega.ml1512
-rw-r--r--contrib/micromega/micromega.mli398
-rw-r--r--contrib/micromega/mutils.ml305
-rw-r--r--contrib/micromega/sos.ml1919
-rw-r--r--contrib/micromega/sos.mli66
-rw-r--r--contrib/micromega/vector.ml674
-rw-r--r--contrib/omega/Omega.v5
-rw-r--r--contrib/omega/PreOmega.v445
-rw-r--r--contrib/omega/coq_omega.ml10
-rw-r--r--contrib/omega/g_omega.ml427
-rw-r--r--contrib/ring/LegacyRing.v2
-rw-r--r--contrib/ring/LegacyRing_theory.v6
-rw-r--r--contrib/ring/Ring_abstract.v4
-rw-r--r--contrib/ring/Ring_normalize.v6
-rw-r--r--contrib/ring/Setoid_ring_normalize.v4
-rw-r--r--contrib/ring/Setoid_ring_theory.v8
-rw-r--r--contrib/ring/quote.ml9
-rw-r--r--contrib/ring/ring.ml20
-rw-r--r--contrib/romega/ROmega.v5
-rw-r--r--contrib/romega/ReflOmegaCore.v2353
-rw-r--r--contrib/romega/const_omega.ml260
-rw-r--r--contrib/romega/const_omega.mli176
-rw-r--r--contrib/romega/g_romega.ml431
-rw-r--r--contrib/romega/refl_omega.ml285
-rw-r--r--contrib/rtauto/Bintree.v15
-rw-r--r--contrib/rtauto/refl_tauto.ml4
-rw-r--r--contrib/setoid_ring/ArithRing.v2
-rw-r--r--contrib/setoid_ring/Field_tac.v185
-rw-r--r--contrib/setoid_ring/Field_theory.v176
-rw-r--r--contrib/setoid_ring/InitialRing.v224
-rw-r--r--contrib/setoid_ring/NArithRing.v2
-rw-r--r--contrib/setoid_ring/RealField.v1
-rw-r--r--contrib/setoid_ring/Ring.v2
-rw-r--r--contrib/setoid_ring/Ring_polynom.v257
-rw-r--r--contrib/setoid_ring/Ring_tac.v152
-rw-r--r--contrib/setoid_ring/Ring_theory.v21
-rw-r--r--contrib/setoid_ring/ZArithRing.v16
-rw-r--r--contrib/setoid_ring/newring.ml4251
-rw-r--r--contrib/subtac/FixSub.v147
-rw-r--r--contrib/subtac/FunctionalExtensionality.v47
-rw-r--r--contrib/subtac/Heq.v34
-rw-r--r--contrib/subtac/Subtac.v2
-rw-r--r--contrib/subtac/SubtacTactics.v158
-rw-r--r--contrib/subtac/Utils.v65
-rw-r--r--contrib/subtac/eterm.ml65
-rw-r--r--contrib/subtac/eterm.mli15
-rw-r--r--contrib/subtac/g_subtac.ml450
-rw-r--r--contrib/subtac/subtac.ml266
-rw-r--r--contrib/subtac/subtac_cases.ml370
-rw-r--r--contrib/subtac/subtac_cases.mli2
-rw-r--r--contrib/subtac/subtac_classes.ml210
-rw-r--r--contrib/subtac/subtac_classes.mli42
-rw-r--r--contrib/subtac/subtac_coercion.ml234
-rw-r--r--contrib/subtac/subtac_command.ml389
-rw-r--r--contrib/subtac/subtac_command.mli13
-rw-r--r--contrib/subtac/subtac_obligations.ml349
-rw-r--r--contrib/subtac/subtac_obligations.mli34
-rw-r--r--contrib/subtac/subtac_pretyping.ml51
-rw-r--r--contrib/subtac/subtac_pretyping.mli14
-rw-r--r--contrib/subtac/subtac_pretyping_F.ml132
-rw-r--r--contrib/subtac/subtac_utils.ml85
-rw-r--r--contrib/subtac/subtac_utils.mli14
-rw-r--r--contrib/subtac/test/ListDep.v8
-rw-r--r--contrib/subtac/test/Mutind.v17
-rw-r--r--contrib/subtac/test/euclid.v11
-rw-r--r--contrib/subtac/test/measure.v10
-rw-r--r--contrib/subtac/test/take.v38
-rw-r--r--contrib/xml/cic2acic.ml28
-rw-r--r--contrib/xml/doubleTypeInference.ml2
-rw-r--r--contrib/xml/dumptree.ml4152
-rw-r--r--contrib/xml/xmlcommand.ml41
263 files changed, 24083 insertions, 16756 deletions
diff --git a/contrib/cc/ccalgo.ml b/contrib/cc/ccalgo.ml
index 8bdae54b..e67797e4 100644
--- a/contrib/cc/ccalgo.ml
+++ b/contrib/cc/ccalgo.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ccalgo.ml 9151 2006-09-19 13:32:22Z corbinea $ *)
+(* $Id: ccalgo.ml 10579 2008-02-21 13:54:00Z corbinea $ *)
(* This file implements the basic congruence-closure algorithm by *)
(* Downey,Sethi and Tarjan. *)
@@ -16,13 +16,16 @@ 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 msg (stdpp:std_ppcmds) =
- if !cc_verbose then msg stdpp
+let debug f x =
+ if !cc_verbose then f x
let _=
let gdopt=
@@ -97,7 +100,8 @@ type cinfo=
type term=
Symb of constr
- | Eps
+ | Product of sorts_family * sorts_family
+ | Eps of identifier
| Appli of term*term
| Constructor of cinfo (* constructor arity + nhyps *)
@@ -122,14 +126,19 @@ 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:bool;
+ qe_lhs_valid:patt_kind;
qe_rhs: ccpattern;
- qe_rhs_valid:bool}
+ qe_rhs_valid:patt_kind}
let swap eq : equality =
let swap_rule=match eq.rule with
@@ -145,10 +154,11 @@ type inductive_status =
| Total of (int * pa_constructor)
type representative=
- {mutable nfathers:int;
+ {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) *)
@@ -179,9 +189,11 @@ type state =
mutable diseq: disequality list;
mutable quant: quant_eq list;
mutable pa_classes: Intset.t;
- q_history: (constr,unit) Hashtbl.t;
+ q_history: (identifier,int array) Hashtbl.t;
mutable rew_depth:int;
- mutable changed:bool}
+ 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});
@@ -189,7 +201,7 @@ let dummy_node =
vertex=Leaf;
term=Symb (mkRel min_int)}
-let empty depth:state =
+let empty depth gls:state =
{uf=
{max_size=init_size;
size=0;
@@ -206,7 +218,9 @@ let empty depth:state =
pa_classes=Intset.empty;
q_history=Hashtbl.create init_size;
rew_depth=depth;
- changed=false}
+ by_type=Hashtbl.create init_size;
+ changed=false;
+ gls=gls}
let forest state = state.uf
@@ -233,7 +247,7 @@ let get_constructor_info uf i=
| _ -> anomaly "get_constructor: not a constructor"
let size uf i=
- (get_representative uf i).nfathers
+ (get_representative uf i).weight
let axioms uf = uf.axioms
@@ -241,13 +255,13 @@ let epsilons uf = uf.epsilons
let add_lfather uf i t=
let r=get_representative uf i in
- r.nfathers<-r.nfathers+1;
+ 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.nfathers<-r.nfathers+1;
+ r.weight<-r.weight+1;
r.fathers <-Intset.add t r.fathers
exception Discriminable of int * pa_constructor * int * pa_constructor
@@ -295,19 +309,29 @@ let next uf=
uf.size<-nsize;
size
-let new_representative ()=
- {nfathers=0;
+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
- | Eps -> anomaly "epsilon constant has no value"
+ | 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
@@ -330,24 +354,31 @@ let rec inst_pattern subst = function
(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 _ ->
+ Symb _ | Product (_,_) ->
let paf =
{fsym=b;
fnargs=0} in
Queue.add (b,Fmark paf) state.marks;
- {clas= Rep (new_representative ());
+ {clas= Rep (new_representative typ);
cpath= -1;
vertex= Leaf;
term= t}
- | Eps ->
- {clas= Rep (new_representative ());
+ | Eps id ->
+ {clas= Rep (new_representative typ);
cpath= -1;
vertex= Leaf;
term= t}
@@ -356,7 +387,7 @@ let rec add_term state t=
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 ());
+ {clas= Rep (new_representative typ);
cpath= -1;
vertex= Node(i1,i2);
term= t}
@@ -370,13 +401,17 @@ let rec add_term state t=
arity= cinfo.ci_arity;
args=[]} in
Queue.add (b,Cmark pac) state.marks;
- {clas=Rep (new_representative ());
+ {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=
@@ -400,32 +435,53 @@ let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) =
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) =
- if state.rew_depth > 0 then
- let subst = build_subst (forest state) int_subst in
- let prfhead= mkVar inst.qe_hyp_id in
- let args = Array.map constr_of_term subst in
- let _ = array_rev args in (* highest deBruijn index first *)
- let prf= mkApp(prfhead,args) in
- try Hashtbl.find state.q_history prf
- with Not_found ->
- (* this instance is new, we can go on *)
- let s = inst_pattern subst inst.qe_lhs
- and t = inst_pattern subst inst.qe_rhs in
- state.changed<-true;
- state.rew_depth<-pred state.rew_depth;
- if inst.qe_pol then
- begin
- debug msgnl
- (str "adding new equality, depth="++ int state.rew_depth);
- add_equality state prf s t
- end
- else
- begin
- debug msgnl (str "adding new disequality, depth="++
- int state.rew_depth);
- add_disequality state (Hyp prf) s t
- end
+ 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
@@ -448,12 +504,17 @@ let join_path uf i j=
min_path (down_path uf i [],down_path uf j [])
let union state i1 i2 eq=
- debug msgnl (str "Linking " ++ int i1 ++ str " and " ++ int i2 ++ str ".");
+ 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.nfathers<-Intset.cardinal f;
+ r2.weight<-Intset.cardinal f;
r2.fathers<-f;
r2.lfathers<-Intset.union r1.lfathers r2.lfathers;
ST.delete_set state.sigtable r1.fathers;
@@ -483,8 +544,9 @@ let union state i1 i2 eq=
| _,_ -> ()
let merge eq state = (* merge and no-merge *)
- debug msgnl
- (str "Merging " ++ int eq.lhs ++ str " and " ++ int eq.rhs ++ str ".");
+ 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
@@ -495,8 +557,8 @@ let merge eq state = (* merge and no-merge *)
union state j i (swap eq)
let update t state = (* update 1 and 2 *)
- debug msgnl
- (str "Updating term " ++ int t ++ str ".");
+ 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
@@ -556,8 +618,8 @@ let process_constructor_mark t i rep pac state =
end
let process_mark t m state =
- debug msgnl
- (str "Processing mark for term " ++ int t ++ str ".");
+ 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
@@ -573,9 +635,9 @@ let check_disequalities state =
let uf=state.uf in
let rec check_aux = function
dis::q ->
- debug msg
- (str "Checking if " ++ int dis.lhs ++ str " = " ++
- int dis.rhs ++ str " ... ");
+ 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
@@ -601,16 +663,35 @@ let one_step state =
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 n =
+ let rec app t typ n =
if n<=0 then t else
- app (Appli(t,Eps)) (n-1) in
+ 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 (app (term state.uf i) pac.arity))
+ ignore (add_term state ct)
| _ -> anomaly "wrong incomplete class"
let complete state =
@@ -624,18 +705,18 @@ type matching_problem =
let make_fun_table state =
let uf= state.uf in
let funtab=ref PafMap.empty in
- for cl=0 to pred uf.size do
- match uf.map.(cl).clas with
- Rep rep ->
- PafMap.iter
- (fun paf _ ->
- let elem =
- try PafMap.find paf !funtab
- with Not_found -> Intset.empty in
- funtab:= PafMap.add paf (Intset.add cl elem) !funtab)
- rep.functions
- | _ -> ()
- done;
+ 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
@@ -656,6 +737,7 @@ let rec do_match state res pb_stack =
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
@@ -665,19 +747,19 @@ let rec do_match state res pb_stack =
end
| PApp(f, ((last_arg::rem_args) as args)) ->
try
- let j=Hashtbl.find uf.syms f in
+ let j=Hashtbl.find uf.syms f in
let paf={fsym=j;fnargs=List.length args} in
let rep=get_representative uf cl in
let good_terms = PafMap.find paf rep.functions in
let aux i =
- let (s,t) = ST.rev_query i state.sigtable in
+ 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
+ Intset.iter aux good_terms
with Not_found -> ()
let paf_of_patt syms = function
@@ -692,28 +774,50 @@ let init_pb_stack state =
let funtab = make_fun_table state in
let aux inst =
begin
- if inst.qe_lhs_valid then
- try
- let paf= paf_of_patt syms inst.qe_lhs in
- let good_classes = PafMap.find paf funtab in
- Intset.iter (fun i ->
- Stack.push
- {mp_subst = Array.make inst.qe_nvars (-1);
- mp_inst=inst;
- mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes
- with Not_found -> ()
+ 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
- if inst.qe_rhs_valid then
- try
- let paf= paf_of_patt syms inst.qe_rhs in
- let good_classes = PafMap.find paf funtab in
- Intset.iter (fun i ->
- Stack.push
- {mp_subst = Array.make inst.qe_nvars (-1);
- mp_inst=inst;
- mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes
- with Not_found -> ()
+ 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
@@ -724,7 +828,8 @@ let find_instances state =
let _ =
debug msgnl (str "Running E-matching algorithm ... ");
try
- while true do
+ while true do
+ check_for_interrupt ();
do_match state res pb_stack
done;
anomaly "get out of here !"
@@ -734,7 +839,9 @@ let find_instances state =
let rec execute first_run state =
debug msgnl (str "Executing ... ");
try
- while one_step state do ()
+ while
+ check_for_interrupt ();
+ one_step state do ()
done;
match check_disequalities state with
None ->
diff --git a/contrib/cc/ccalgo.mli b/contrib/cc/ccalgo.mli
index 05a5c4d1..cdc0065e 100644
--- a/contrib/cc/ccalgo.mli
+++ b/contrib/cc/ccalgo.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ccalgo.mli 9151 2006-09-19 13:32:22Z corbinea $ *)
+(* $Id: ccalgo.mli 10579 2008-02-21 13:54:00Z corbinea $ *)
open Util
open Term
@@ -19,10 +19,16 @@ type cinfo =
type term =
Symb of constr
- | Eps
+ | 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
@@ -70,7 +76,7 @@ val axioms : forest -> (constr, term * term) Hashtbl.t
val epsilons : forest -> pa_constructor list
-val empty : int -> state
+val empty : int -> Proof_type.goal Tacmach.sigma -> state
val add_term : state -> term -> int
@@ -79,8 +85,7 @@ val add_equality : state -> constr -> term -> term -> unit
val add_disequality : state -> from -> term -> term -> unit
val add_quant : state -> identifier -> bool ->
- int * bool * ccpattern * bool * ccpattern -> unit
-
+ int * patt_kind * ccpattern * patt_kind * ccpattern -> unit
val tail_pac : pa_constructor -> pa_constructor
@@ -102,9 +107,9 @@ type quant_eq=
qe_pol: bool;
qe_nvars:int;
qe_lhs: ccpattern;
- qe_lhs_valid:bool;
+ qe_lhs_valid:patt_kind;
qe_rhs: ccpattern;
- qe_rhs_valid:bool}
+ qe_rhs_valid:patt_kind}
type pa_fun=
diff --git a/contrib/cc/ccproof.ml b/contrib/cc/ccproof.ml
index d336f599..a459b18f 100644
--- a/contrib/cc/ccproof.ml
+++ b/contrib/cc/ccproof.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ccproof.ml 9856 2007-05-24 14:05:40Z corbinea $ *)
+(* $Id: ccproof.ml 9857 2007-05-24 14:21:08Z corbinea $ *)
(* This file uses the (non-compressed) union-find structure to generate *)
(* proof-trees that will be transformed into proof-terms in cctac.ml4 *)
diff --git a/contrib/cc/ccproof.mli b/contrib/cc/ccproof.mli
index 572b2c53..0eb97efe 100644
--- a/contrib/cc/ccproof.mli
+++ b/contrib/cc/ccproof.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ccproof.mli 9856 2007-05-24 14:05:40Z corbinea $ *)
+(* $Id: ccproof.mli 9857 2007-05-24 14:21:08Z corbinea $ *)
open Ccalgo
open Names
diff --git a/contrib/cc/cctac.ml b/contrib/cc/cctac.ml
index dc0dec0e..871d7521 100644
--- a/contrib/cc/cctac.ml
+++ b/contrib/cc/cctac.ml
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: cctac.ml 10121 2007-09-14 09:45:40Z corbinea $ *)
+(* $Id: cctac.ml 10670 2008-03-14 19:30:48Z letouzey $ *)
(* This file is the interface between the c-c algorithm and Coq *)
@@ -24,6 +24,7 @@ open Termops
open Tacmach
open Tactics
open Tacticals
+open Typing
open Ccalgo
open Tacinterp
open Ccproof
@@ -49,6 +50,8 @@ let _False = constant ["Init";"Logic"] "False"
(* decompose member of equality in an applicative format *)
+let sf_of env sigma c = family_of_sort (destSort (type_of env sigma c))
+
let whd env=
let infos=Closure.create_clos_infos Closure.betaiotazeta env in
(fun t -> Closure.whd_val infos (Closure.inject t))
@@ -57,12 +60,19 @@ let whd_delta env=
let infos=Closure.create_clos_infos Closure.betadeltaiota env in
(fun t -> Closure.whd_val infos (Closure.inject t))
-let rec decompose_term env t=
+let rec decompose_term env sigma t=
match kind_of_term (whd env t) with
App (f,args)->
- let tf=decompose_term env f in
- let targs=Array.map (decompose_term env) args in
+ 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
@@ -73,95 +83,111 @@ let rec decompose_term env t=
(* decompose equality in members and type *)
-let atom_of_constr env term =
+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 args.(1),
- decompose_term env args.(2))
- else `Other (decompose_term env term)
- | _ -> `Other (decompose_term env term)
+ 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 c =
+let rec pattern_of_constr env sigma c =
match kind_of_term (whd env c) with
App (f,args)->
- let pf = decompose_term env f in
+ let pf = decompose_term env sigma f in
let pargs,lrels = List.split
- (array_map_to_list (pattern_of_constr env) args) in
+ (array_map_to_list (pattern_of_constr env sigma) args) in
PApp (pf,List.rev pargs),
- List.fold_left Intset.union Intset.empty lrels
+ 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 c in
+ let pf = decompose_term env sigma c in
PApp (pf,[]),Intset.empty
let non_trivial = function
PVar _ -> false
| _ -> true
-let patterns_of_constr env nrels term=
+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 args.(1)
- and patt2,rels2 = pattern_of_constr env args.(2) in
- let valid1 = (Intset.cardinal rels1 = nrels && non_trivial patt1)
- and valid2 = (Intset.cardinal rels2 = nrels && non_trivial patt2) in
- if valid1 || valid2 then
+ 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 nrels term =
+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 nrels atom in
+ let patts=patterns_of_constr env sigma nrels atom in
`Nrule patts
else
- quantified_atom_of_constr env (succ nrels) ff
+ quantified_atom_of_constr env sigma (succ nrels) ff
| _ ->
- let patts=patterns_of_constr env nrels term in
+ let patts=patterns_of_constr env sigma nrels term in
`Rule patts
-let litteral_of_constr env term=
+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 atom) with
+ 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 1 ff
+ quantified_atom_of_constr env sigma 1 ff
with Not_found ->
- `Other (decompose_term env term)
+ `Other (decompose_term env sigma term)
end
| _ ->
- atom_of_constr env term
+ 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 state = empty depth 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 c in
+ 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 e with
+ 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 ->
@@ -180,7 +206,7 @@ let rec make_prb gls depth additionnal_terms =
| `Nrule patts -> add_quant state id false patts
end) (Environ.named_context_of_val gls.it.evar_hyps);
begin
- match atom_of_constr env gls.it.evar_concl with
+ 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
@@ -209,7 +235,7 @@ let build_projection intype outtype (cstr:constructor) special default gls=
let branches=Array.init lp branch in
let casee=mkRel 1 in
let pred=mkLambda(Anonymous,intype,outtype) in
- let case_info=make_default_case_info (pf_env gls) RegularStyle ind 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)
@@ -224,19 +250,19 @@ let rec proof_tac p gls =
| SymAx c ->
let l=constr_of_term p.p_lhs and
r=constr_of_term p.p_rhs in
- let typ = pf_type_of gls l 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 = pf_type_of gls lr 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 = pf_type_of gls t2 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
@@ -245,16 +271,17 @@ let rec proof_tac p gls =
and tx1=constr_of_term p2.p_lhs
and tf2=constr_of_term p1.p_rhs
and tx2=constr_of_term p2.p_rhs in
- let typf = pf_type_of gls tf1 in
- let typx = pf_type_of gls tx1 in
- let typfx = pf_type_of gls (mkApp (tf1,[|tx1|])) 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
+ mkApp(Lazy.force _f_equal,
+ [|typx;typfx;tf2;tx1;tx2;_M 1|]) in
let prf =
mkApp(Lazy.force _trans_eq,
[|typfx;
@@ -274,8 +301,8 @@ let rec proof_tac p gls =
let ti=constr_of_term prf.p_lhs in
let tj=constr_of_term prf.p_rhs in
let default=constr_of_term p.p_lhs in
- let intype=pf_type_of gls ti in
- let outtype=pf_type_of gls default 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=
@@ -284,7 +311,7 @@ let rec proof_tac p gls =
let refute_tac c t1 t2 p gls =
let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
- let intype=pf_type_of gls tt1 in
+ let intype=refresh_universes (pf_type_of gls tt1) in
let neweq=
mkApp(Lazy.force _eq,
[|intype;tt1;tt2|]) in
@@ -295,7 +322,7 @@ let refute_tac c t1 t2 p gls =
let convert_to_goal_tac c t1 t2 p gls =
let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
- let sort=pf_type_of gls tt2 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
@@ -315,7 +342,7 @@ let convert_to_hyp_tac c1 t1 c2 t2 p gls =
let discriminate_tac cstr p gls =
let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in
- let intype=pf_type_of gls t1 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
@@ -403,3 +430,29 @@ let congruence_tac depth l =
tclORELSE
(tclTHEN (tclREPEAT introf) (cc_tactic depth l))
cc_fail
+
+(* 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|]))) 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/contrib/cc/cctac.mli b/contrib/cc/cctac.mli
index ffc4b9c4..57ad0558 100644
--- a/contrib/cc/cctac.mli
+++ b/contrib/cc/cctac.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: cctac.mli 10121 2007-09-14 09:45:40Z corbinea $ *)
+(* $Id: cctac.mli 10637 2008-03-07 23:52:56Z letouzey $ *)
open Term
open Proof_type
@@ -18,3 +18,5 @@ 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/contrib/cc/g_congruence.ml4 b/contrib/cc/g_congruence.ml4
index 693aebb4..9877e6fc 100644
--- a/contrib/cc/g_congruence.ml4
+++ b/contrib/cc/g_congruence.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_congruence.ml4 9151 2006-09-19 13:32:22Z corbinea $ *)
+(* $Id: g_congruence.ml4 10637 2008-03-07 23:52:56Z letouzey $ *)
open Cctac
open Tactics
@@ -17,9 +17,13 @@ open Tacticals
(* Tactic registration *)
TACTIC EXTEND cc
- [ "congruence" ] -> [ congruence_tac 0 [] ]
+ [ "congruence" ] -> [ congruence_tac 1000 [] ]
|[ "congruence" integer(n) ] -> [ congruence_tac n [] ]
- |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 0 l ]
+ |[ "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/contrib/correctness/ProgramsExtraction.v b/contrib/correctness/ProgramsExtraction.v
index 5f7dfdbf..70f4b730 100644
--- a/contrib/correctness/ProgramsExtraction.v
+++ b/contrib/correctness/ProgramsExtraction.v
@@ -8,9 +8,7 @@
(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-(* $Id: ProgramsExtraction.v 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-Require Export Extraction.
+(* $Id: ProgramsExtraction.v 10290 2007-11-06 01:27:17Z letouzey $ *)
Extract Inductive unit => unit [ "()" ].
Extract Inductive bool => bool [ true false ].
diff --git a/contrib/correctness/past.mli b/contrib/correctness/past.mli
deleted file mode 100644
index 70328704..00000000
--- a/contrib/correctness/past.mli
+++ /dev/null
@@ -1,97 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: past.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(*s Abstract syntax of imperative programs. *)
-
-open Names
-open Ptype
-open Topconstr
-
-type termination =
- | RecArg of int
- | Wf of constr_expr * constr_expr
-
-type variable = identifier
-
-type pattern =
- | PatVar of identifier
- | PatConstruct of identifier * ((kernel_name * int) * int)
- | PatAlias of pattern * identifier
- | PatPair of pattern * pattern
- | PatApp of pattern list
-
-type epattern =
- | ExnConstant of identifier
- | ExnBind of identifier * identifier
-
-type ('a, 'b) block_st =
- | Label of string
- | Assert of 'b Ptype.assertion
- | Statement of 'a
-
-type ('a, 'b) block = ('a, 'b) block_st list
-
-type ('a, 'b) t = {
- desc : ('a, 'b) t_desc;
- pre : 'b Ptype.precondition list;
- post : 'b Ptype.postcondition option;
- loc : Util.loc;
- info : 'a
-}
-
-and ('a, 'b) t_desc =
- | Variable of variable
- | Acc of variable
- | Aff of variable * ('a, 'b) t
- | TabAcc of bool * variable * ('a, 'b) t
- | TabAff of bool * variable * ('a, 'b) t * ('a, 'b) t
- | Seq of (('a, 'b) t, 'b) block
- | While of ('a, 'b) t * 'b Ptype.assertion option * ('b * 'b) *
- (('a, 'b) t, 'b) block
- | If of ('a, 'b) t * ('a, 'b) t * ('a, 'b) t
- | Lam of 'b Ptype.ml_type_v Ptype.binder list * ('a, 'b) t
- | Apply of ('a, 'b) t * ('a, 'b) arg list
- | SApp of ('a, 'b) t_desc list * ('a, 'b) t list
- | LetRef of variable * ('a, 'b) t * ('a, 'b) t
- | Let of variable * ('a, 'b) t * ('a, 'b) t
- | LetRec of variable * 'b Ptype.ml_type_v Ptype.binder list *
- 'b Ptype.ml_type_v * ('b * 'b) * ('a, 'b) t
- | PPoint of string * ('a, 'b) t_desc
- | Expression of Term.constr
- | Debug of string * ('a, 'b) t
-
-and ('a, 'b) arg =
- | Term of ('a, 'b) t
- | Refarg of variable
- | Type of 'b Ptype.ml_type_v
-
-type program = (unit, Topconstr.constr_expr) t
-
-(*s Intermediate type for CC terms. *)
-
-type cc_type = Term.constr
-
-type cc_bind_type =
- | CC_typed_binder of cc_type
- | CC_untyped_binder
-
-type cc_binder = variable * cc_bind_type
-
-type cc_term =
- | CC_var of variable
- | CC_letin of bool * cc_type * cc_binder list * cc_term * cc_term
- | CC_lam of cc_binder list * cc_term
- | CC_app of cc_term * cc_term list
- | CC_tuple of bool * cc_type list * cc_term list
- | CC_case of cc_type * cc_term * cc_term list
- | CC_expr of Term.constr
- | CC_hole of cc_type
diff --git a/contrib/correctness/pcic.ml b/contrib/correctness/pcic.ml
deleted file mode 100644
index 041cd81f..00000000
--- a/contrib/correctness/pcic.ml
+++ /dev/null
@@ -1,231 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pcic.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Util
-open Names
-open Nameops
-open Libnames
-open Term
-open Termops
-open Nametab
-open Declarations
-open Indtypes
-open Sign
-open Rawterm
-open Typeops
-open Entries
-open Topconstr
-
-open Pmisc
-open Past
-
-
-(* Here we translate intermediates terms (cc_term) into CCI terms (constr) *)
-
-let make_hole c = mkCast (isevar, c)
-
-(* Tuples are defined in file Tuples.v
- * and their constructors are called Build_tuple_n or exists_n,
- * wether they are dependant (last element only) or not.
- * If necessary, tuples are generated ``on the fly''. *)
-
-let tuple_exists id =
- try let _ = Nametab.locate (make_short_qualid id) in true
- with Not_found -> false
-
-let ast_set = CSort (dummy_loc,RProp Pos)
-
-let tuple_n n =
- let id = make_ident "tuple_" (Some n) in
- let l1n = Util.interval 1 n in
- let params =
- List.map (fun i ->
- (LocalRawAssum ([dummy_loc,Name (make_ident "T" (Some i))], ast_set)))
- l1n in
- let fields =
- List.map
- (fun i ->
- let id = make_ident ("proj_" ^ string_of_int n ^ "_") (Some i) in
- let id' = make_ident "T" (Some i) in
- (false, Vernacexpr.AssumExpr ((dummy_loc,Name id), mkIdentC id')))
- l1n
- in
- let cons = make_ident "Build_tuple_" (Some n) in
- Record.definition_structure
- ((false, (dummy_loc,id)), params, fields, cons, mk_Set)
-
-(*s [(sig_n n)] generates the inductive
- \begin{verbatim}
- Inductive sig_n [T1,...,Tn:Set; P:T1->...->Tn->Prop] : Set :=
- exist_n : (x1:T1)...(xn:Tn)(P x1 ... xn) -> (sig_n T1 ... Tn P).
- \end{verbatim} *)
-
-let sig_n n =
- let id = make_ident "sig_" (Some n) in
- let l1n = Util.interval 1 n in
- let lT = List.map (fun i -> make_ident "T" (Some i)) l1n in
- let lx = List.map (fun i -> make_ident "x" (Some i)) l1n in
- let idp = make_ident "P" None in
- let params =
- let typ = List.fold_right (fun _ c -> mkArrow (mkRel n) c) lT mkProp in
- (idp, LocalAssum typ) ::
- (List.rev_map (fun id -> (id, LocalAssum mkSet)) lT)
- in
- let lc =
- let app_sig = mkApp(mkRel (2*n+3),
- Array.init (n+1) (fun i -> mkRel (2*n+2-i))) in
- let app_p = mkApp(mkRel (n+1),
- Array.init n (fun i -> mkRel (n-i))) in
- let c = mkArrow app_p app_sig in
- List.fold_right (fun id c -> mkProd (Name id, mkRel (n+1), c)) lx c
- in
- let cname = make_ident "exist_" (Some n) in
- Declare.declare_mind
- { mind_entry_finite = true;
- mind_entry_inds =
- [ { mind_entry_params = params;
- mind_entry_typename = id;
- mind_entry_arity = mkSet;
- mind_entry_consnames = [ cname ];
- mind_entry_lc = [ lc ] } ] }
-
-(*s On the fly generation of needed (possibly dependent) tuples. *)
-
-let check_product_n n =
- if n > 2 then
- let s = Printf.sprintf "tuple_%d" n in
- if not (tuple_exists (id_of_string s)) then tuple_n n
-
-let check_dep_product_n n =
- if n > 1 then
- let s = Printf.sprintf "sig_%d" n in
- if not (tuple_exists (id_of_string s)) then ignore (sig_n n)
-
-(*s Constructors for the tuples. *)
-
-let pair = ConstructRef ((coq_constant ["Init"; "Datatypes"] "prod",0),1)
-let exist = ConstructRef ((coq_constant ["Init"; "Specif"] "sig",0),1)
-
-let tuple_ref dep n =
- if n = 2 & not dep then
- pair
- else
- let n = n - (if dep then 1 else 0) in
- if dep then
- if n = 1 then
- exist
- else begin
- let id = make_ident "exist_" (Some n) in
- if not (tuple_exists id) then ignore (sig_n n);
- Nametab.locate (make_short_qualid id)
- end
- else begin
- let id = make_ident "Build_tuple_" (Some n) in
- if not (tuple_exists id) then tuple_n n;
- Nametab.locate (make_short_qualid id)
- end
-
-(* Binders. *)
-
-let trad_binder avoid nenv id = function
- | CC_untyped_binder -> RHole (dummy_loc,BinderType (Name id))
- | CC_typed_binder ty -> Detyping.detype (false,Global.env()) avoid nenv ty
-
-let rec push_vars avoid nenv = function
- | [] -> ([],avoid,nenv)
- | (id,b) :: bl ->
- let b' = trad_binder avoid nenv id b in
- let bl',avoid',nenv' =
- push_vars (id :: avoid) (add_name (Name id) nenv) bl
- in
- ((id,b') :: bl', avoid', nenv')
-
-let rec raw_lambda bl v = match bl with
- | [] ->
- v
- | (id,ty) :: bl' ->
- RLambda (dummy_loc, Name id, ty, raw_lambda bl' v)
-
-(* The translation itself is quite easy.
- letin are translated into Cases constructions *)
-
-let rawconstr_of_prog p =
- let rec trad avoid nenv = function
- | CC_var id ->
- RVar (dummy_loc, id)
-
- (*i optimisation : let x = <constr> in e2 => e2[x<-constr]
- | CC_letin (_,_,[id,_],CC_expr c,e2) ->
- real_subst_in_constr [id,c] (trad e2)
- | CC_letin (_,_,([_] as b),CC_expr e1,e2) ->
- let (b',avoid',nenv') = push_vars avoid nenv b in
- let c1 = Detyping.detype avoid nenv e1
- and c2 = trad avoid' nenv' e2 in
- let id = Name (fst (List.hd b')) in
- RLetIn (dummy_loc, id, c1, c2)
- i*)
-
- | CC_letin (_,_,([_] as b),e1,e2) ->
- let (b',avoid',nenv') = push_vars avoid nenv b in
- let c1 = trad avoid nenv e1
- and c2 = trad avoid' nenv' e2 in
- RApp (dummy_loc, raw_lambda b' c2, [c1])
-
- | CC_letin (dep,ty,bl,e1,e2) ->
- let (bl',avoid',nenv') = push_vars avoid nenv bl in
- let c1 = trad avoid nenv e1
- and c2 = trad avoid' nenv' e2 in
- ROrderedCase (dummy_loc, LetStyle, None, c1, [| raw_lambda bl' c2 |], ref None)
-
- | CC_lam (bl,e) ->
- let bl',avoid',nenv' = push_vars avoid nenv bl in
- let c = trad avoid' nenv' e in
- raw_lambda bl' c
-
- | CC_app (f,args) ->
- let c = trad avoid nenv f
- and cargs = List.map (trad avoid nenv) args in
- RApp (dummy_loc, c, cargs)
-
- | CC_tuple (_,_,[e]) ->
- trad avoid nenv e
-
- | CC_tuple (false,_,[e1;e2]) ->
- let c1 = trad avoid nenv e1
- and c2 = trad avoid nenv e2 in
- RApp (dummy_loc, RRef (dummy_loc,pair),
- [RHole (dummy_loc,ImplicitArg (pair,1));
- RHole (dummy_loc,ImplicitArg (pair,2));c1;c2])
-
- | CC_tuple (dep,tyl,l) ->
- let n = List.length l in
- let cl = List.map (trad avoid nenv) l in
- let tuple = tuple_ref dep n in
- let tyl = List.map (Detyping.detype (false,Global.env()) avoid nenv) tyl in
- let args = tyl @ cl in
- RApp (dummy_loc, RRef (dummy_loc, tuple), args)
-
- | CC_case (ty,b,el) ->
- let c = trad avoid nenv b in
- let cl = List.map (trad avoid nenv) el in
- let ty = Detyping.detype (false,Global.env()) avoid nenv ty in
- ROrderedCase (dummy_loc, RegularStyle, Some ty, c, Array.of_list cl, ref None)
-
- | CC_expr c ->
- Detyping.detype (false,Global.env()) avoid nenv c
-
- | CC_hole c ->
- RCast (dummy_loc, RHole (dummy_loc, QuestionMark),
- Detyping.detype (false,Global.env()) avoid nenv c)
-
- in
- trad [] empty_names_context p
diff --git a/contrib/correctness/pcic.mli b/contrib/correctness/pcic.mli
deleted file mode 100644
index 67b152f3..00000000
--- a/contrib/correctness/pcic.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(*i $Id: pcic.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
-
-open Past
-open Rawterm
-
-(* On-the-fly generation of needed (possibly dependent) tuples. *)
-
-val check_product_n : int -> unit
-val check_dep_product_n : int -> unit
-
-(* transforms intermediate functional programs into (raw) CIC terms *)
-
-val rawconstr_of_prog : cc_term -> rawconstr
-
diff --git a/contrib/correctness/pcicenv.ml b/contrib/correctness/pcicenv.ml
deleted file mode 100644
index 368d0281..00000000
--- a/contrib/correctness/pcicenv.ml
+++ /dev/null
@@ -1,118 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pcicenv.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Sign
-
-open Pmisc
-open Putil
-open Ptype
-open Past
-
-(* on redéfinit add_sign pour éviter de construire des environnements
- * avec des doublons (qui font planter la résolution des implicites !) *)
-
-(* VERY UGLY!! find some work around *)
-let modify_sign id t s =
- fold_named_context
- (fun ((x,b,ty) as d) sign ->
- if x=id then add_named_decl (x,b,t) sign else add_named_decl d sign)
- s ~init:empty_named_context
-
-let add_sign (id,t) s =
- try
- let _ = lookup_named id s in
- modify_sign id t s
- with Not_found ->
- add_named_decl (id,None,t) s
-
-let cast_set c = mkCast (c, mkSet)
-
-let set = mkCast (mkSet, mkType Univ.prop_univ)
-
-(* [cci_sign_of env] construit un environnement pour CIC ne comprenant que
- * les objets fonctionnels de l'environnement de programes [env]
- *)
-
-let cci_sign_of ren env =
- Penv.fold_all
- (fun (id,v) sign ->
- match v with
- | Penv.TypeV (Ref _ | Array _) -> sign
- | Penv.TypeV v ->
- let ty = Pmonad.trad_ml_type_v ren env v in
- add_sign (id,cast_set ty) sign
- | Penv.Set -> add_sign (id,set) sign)
- env (Global.named_context ())
-
-(* [sign_meta ren env fadd ini]
- * construit un environnement pour CIC qui prend en compte les variables
- * de programme.
- * pour cela, cette fonction parcours tout l'envrionnement (global puis
- * local [env]) et pour chaque déclaration, ajoute ce qu'il faut avec la
- * fonction [fadd] s'il s'agit d'un mutable et directement sinon,
- * en partant de [ini].
- *)
-
-let sign_meta ren env fast ini =
- Penv.fold_all
- (fun (id,v) sign ->
- match v with
- | Penv.TypeV (Ref _ | Array _ as v) ->
- let ty = Pmonad.trad_imp_type ren env v in
- fast sign id ty
- | Penv.TypeV v ->
- let ty = Pmonad.trad_ml_type_v ren env v in
- add_sign (id,cast_set ty) sign
- | Penv.Set -> add_sign (id,set) sign)
- env ini
-
-let add_sign_d dates (id,c) sign =
- let sign =
- List.fold_left (fun sign d -> add_sign (at_id id d,c) sign) sign dates
- in
- add_sign (id,c) sign
-
-let sign_of add ren env =
- sign_meta ren env
- (fun sign id c -> let c = cast_set c in add (id,c) sign)
- (Global.named_context ())
-
-let result_of sign = function
- None -> sign
- | Some (id,c) -> add_sign (id, cast_set c) sign
-
-let before_after_result_sign_of res ren env =
- let dates = "" :: Prename.all_dates ren in
- result_of (sign_of (add_sign_d dates) ren env) res
-
-let before_after_sign_of ren =
- let dates = "" :: Prename.all_dates ren in
- sign_of (add_sign_d dates) ren
-
-let before_sign_of ren =
- let dates = Prename.all_dates ren in
- sign_of (add_sign_d dates) ren
-
-let now_sign_of =
- sign_of (add_sign_d [])
-
-
-(* environnement après traduction *)
-
-let trad_sign_of ren =
- sign_of
- (fun (id,c) sign -> add_sign (Prename.current_var ren id,c) sign)
- ren
-
-
diff --git a/contrib/correctness/pcicenv.mli b/contrib/correctness/pcicenv.mli
deleted file mode 100644
index 365fa960..00000000
--- a/contrib/correctness/pcicenv.mli
+++ /dev/null
@@ -1,38 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pcicenv.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Penv
-open Names
-open Term
-open Sign
-
-(* Translation of local programs environments into Coq signatures.
- * It is mainly used to type the pre/post conditions in the good
- * environment *)
-
-(* cci_sign_of: uniquement les objets purement fonctionnels de l'env. *)
-val cci_sign_of : Prename.t -> local_env -> named_context
-
-(* env. Coq avec seulement les variables X de l'env. *)
-val now_sign_of : Prename.t -> local_env -> named_context
-
-(* + les variables X@d pour toutes les dates de l'env. *)
-val before_sign_of : Prename.t -> local_env -> named_context
-
-(* + les variables `avant' X@ *)
-val before_after_sign_of : Prename.t -> local_env -> named_context
-val before_after_result_sign_of : ((identifier * constr) option)
- -> Prename.t -> local_env -> named_context
-
-(* env. des programmes traduits, avec les variables rennomées *)
-val trad_sign_of : Prename.t -> local_env -> named_context
-
diff --git a/contrib/correctness/pdb.ml b/contrib/correctness/pdb.ml
deleted file mode 100644
index 759e9133..00000000
--- a/contrib/correctness/pdb.ml
+++ /dev/null
@@ -1,165 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pdb.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Termops
-open Nametab
-open Constrintern
-
-open Ptype
-open Past
-open Penv
-
-let cci_global id =
- try
- global_reference id
- with
- _ -> raise Not_found
-
-let lookup_var ids locop id =
- if List.mem id ids then
- None
- else begin
- try Some (cci_global id)
- with Not_found -> Perror.unbound_variable id locop
- end
-
-let check_ref idl loc id =
- if (not (List.mem id idl)) & (not (Penv.is_global id)) then
- Perror.unbound_reference id loc
-
-(* db types : only check the references for the moment *)
-
-let rec check_type_v refs = function
- | Ref v ->
- check_type_v refs v
- | Array (c,v) ->
- check_type_v refs v
- | Arrow (bl,c) ->
- check_binder refs c bl
- | TypePure _ ->
- ()
-
-and check_type_c refs ((_,v),e,_,_) =
- check_type_v refs v;
- List.iter (check_ref refs None) (Peffect.get_reads e);
- List.iter (check_ref refs None) (Peffect.get_writes e)
- (* TODO: check_condition on p and q *)
-
-and check_binder refs c = function
- | [] ->
- check_type_c refs c
- | (id, BindType (Ref _ | Array _ as v)) :: bl ->
- check_type_v refs v;
- check_binder (id :: refs) c bl
- | (_, BindType v) :: bl ->
- check_type_v refs v;
- check_binder refs c bl
- | _ :: bl ->
- check_binder refs c bl
-
-(* db binders *)
-
-let rec db_binders ((tids,pids,refs) as idl) = function
- | [] ->
- idl, []
- | (id, BindType (Ref _ | Array _ as v)) as b :: rem ->
- check_type_v refs v;
- let idl',rem' = db_binders (tids,pids,id::refs) rem in
- idl', b :: rem'
- | (id, BindType v) as b :: rem ->
- check_type_v refs v;
- let idl',rem' = db_binders (tids,id::pids,refs) rem in
- idl', b :: rem'
- | ((id, BindSet) as t) :: rem ->
- let idl',rem' = db_binders (id::tids,pids,refs) rem in
- idl', t :: rem'
- | a :: rem ->
- let idl',rem' = db_binders idl rem in idl', a :: rem'
-
-
-(* db programs *)
-
-let db_prog e =
- (* tids = type identifiers, ids = variables, refs = references and arrays *)
- let rec db_desc ((tids,ids,refs) as idl) = function
- | (Variable x) as t ->
- (match lookup_var ids (Some e.loc) x with
- None -> t
- | Some c -> Expression c)
- | (Acc x) as t ->
- check_ref refs (Some e.loc) x;
- t
- | Aff (x,e1) ->
- check_ref refs (Some e.loc) x;
- Aff (x, db idl e1)
- | TabAcc (b,x,e1) ->
- check_ref refs (Some e.loc) x;
- TabAcc(b,x,db idl e1)
- | TabAff (b,x,e1,e2) ->
- check_ref refs (Some e.loc) x;
- TabAff (b,x, db idl e1, db idl e2)
- | Seq bl ->
- Seq (List.map (function
- Statement p -> Statement (db idl p)
- | x -> x) bl)
- | If (e1,e2,e3) ->
- If (db idl e1, db idl e2, db idl e3)
- | While (b,inv,var,bl) ->
- let bl' = List.map (function
- Statement p -> Statement (db idl p)
- | x -> x) bl in
- While (db idl b, inv, var, bl')
-
- | Lam (bl,e) ->
- let idl',bl' = db_binders idl bl in Lam(bl', db idl' e)
- | Apply (e1,l) ->
- Apply (db idl e1, List.map (db_arg idl) l)
- | SApp (dl,l) ->
- SApp (dl, List.map (db idl) l)
- | LetRef (x,e1,e2) ->
- LetRef (x, db idl e1, db (tids,ids,x::refs) e2)
- | Let (x,e1,e2) ->
- Let (x, db idl e1, db (tids,x::ids,refs) e2)
-
- | LetRec (f,bl,v,var,e) ->
- let (tids',ids',refs'),bl' = db_binders idl bl in
- check_type_v refs' v;
- LetRec (f, bl, v, var, db (tids',f::ids',refs') e)
-
- | Debug (s,e1) ->
- Debug (s, db idl e1)
-
- | Expression _ as x -> x
- | PPoint (s,d) -> PPoint (s, db_desc idl d)
-
- and db_arg ((tids,_,refs) as idl) = function
- | Term ({ desc = Variable id } as t) ->
- if List.mem id refs then Refarg id else Term (db idl t)
- | Term t -> Term (db idl t)
- | Type v as ty -> check_type_v refs v; ty
- | Refarg _ -> assert false
-
- and db idl e =
- { desc = db_desc idl e.desc ;
- pre = e.pre; post = e.post;
- loc = e.loc; info = e.info }
-
- in
- let ids = Termops.ids_of_named_context (Global.named_context ()) in
- (* TODO: separer X:Set et x:V:Set
- virer le reste (axiomes, etc.) *)
- let vars,refs = all_vars (), all_refs () in
- db ([],vars@ids,refs) e
-;;
-
diff --git a/contrib/correctness/pdb.mli b/contrib/correctness/pdb.mli
deleted file mode 100644
index d6e647b7..00000000
--- a/contrib/correctness/pdb.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pdb.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Ptype
-open Past
-
-
-(* Here we separate local and global variables, we check the use of
- * references and arrays w.r.t the local and global environments, etc.
- * These functions directly raise UserError exceptions on bad programs.
- *)
-
-val check_type_v : Names.identifier list -> 'a ml_type_v -> unit
-
-val db_prog : program -> program
-
diff --git a/contrib/correctness/peffect.ml b/contrib/correctness/peffect.ml
deleted file mode 100644
index faf5f3d3..00000000
--- a/contrib/correctness/peffect.ml
+++ /dev/null
@@ -1,159 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: peffect.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Nameops
-open Pmisc
-
-(* The type of effects.
- *
- * An effect is composed of two lists (r,w) of variables.
- * The first one is the list of read-only variables
- * and the second one is the list of read-write variables.
- *
- * INVARIANT: 1. each list is sorted in decreasing order for Pervasives.compare
- * 2. there are no duplicate elements in each list
- * 3. the two lists are disjoint
- *)
-
-type t = identifier list * identifier list
-
-
-(* the empty effect *)
-
-let bottom = ([], [])
-
-(* basic operations *)
-
-let push x l =
- let rec push_rec = function
- [] -> [x]
- | (y::rem) as l ->
- if x = y then l else if x > y then x::l else y :: push_rec rem
- in
- push_rec l
-
-let basic_remove x l =
- let rec rem_rec = function
- [] -> []
- | y::l -> if x = y then l else y :: rem_rec l
- in
- rem_rec l
-
-let mem x (r,w) = (List.mem x r) or (List.mem x w)
-
-let rec basic_union = function
- [], s2 -> s2
- | s1, [] -> s1
- | ((v1::l1) as s1), ((v2::l2) as s2) ->
- if v1 > v2 then
- v1 :: basic_union (l1,s2)
- else if v1 < v2 then
- v2 :: basic_union (s1,l2)
- else
- v1 :: basic_union (l1,l2)
-
-(* adds reads and writes variables *)
-
-let add_read id ((r,w) as e) =
- (* if the variable is already a RW it is ok, otherwise adds it as a RO. *)
- if List.mem id w then
- e
- else
- push id r, w
-
-let add_write id (r,w) =
- (* if the variable is a RO then removes it from RO. Adds it to RW. *)
- if List.mem id r then
- basic_remove id r, push id w
- else
- r, push id w
-
-(* access *)
-
-let get_reads = basic_union
-let get_writes = snd
-let get_repr e = (get_reads e, get_writes e)
-
-(* tests *)
-
-let is_read (r,_) id = List.mem id r
-let is_write (_,w) id = List.mem id w
-
-(* union and disjunction *)
-
-let union (r1,w1) (r2,w2) = basic_union (r1,r2), basic_union (w1,w2)
-
-let rec diff = function
- [], s2 -> []
- | s1, [] -> s1
- | ((v1::l1) as s1), ((v2::l2) as s2) ->
- if v1 > v2 then
- v1 :: diff (l1,s2)
- else if v1 < v2 then
- diff (s1,l2)
- else
- diff (l1,l2)
-
-let disj (r1,w1) (r2,w2) =
- let w1_w2 = diff (w1,w2) and w2_w1 = diff (w2,w1) in
- let r = basic_union (basic_union (r1,r2), basic_union (w1_w2,w2_w1))
- and w = basic_union (w1,w2) in
- r,w
-
-(* comparison relation *)
-
-let le e1 e2 = failwith "effects: le: not yet implemented"
-
-let inf e1 e2 = failwith "effects: inf: not yet implemented"
-
-(* composition *)
-
-let compose (r1,w1) (r2,w2) =
- let r = basic_union (r1, diff (r2,w1)) in
- let w = basic_union (w1,w2) in
- r,w
-
-(* remove *)
-
-let remove (r,w) name = basic_remove name r, basic_remove name w
-
-(* substitution *)
-
-let subst_list (x,x') l =
- if List.mem x l then push x' (basic_remove x l) else l
-
-let subst_one (r,w) s = subst_list s r, subst_list s w
-
-let subst s e = List.fold_left subst_one e s
-
-(* pretty-print *)
-
-open Pp
-open Util
-open Himsg
-
-let pp (r,w) =
- hov 0 (if r<>[] then
- (str"reads " ++
- prlist_with_sep (fun () -> (str"," ++ spc ())) pr_id r)
- else (mt ()) ++
- spc () ++
- if w<>[] then
- (str"writes " ++
- prlist_with_sep (fun ()-> (str"," ++ spc ())) pr_id w)
- else (mt ())
-)
-
-let ppr e =
- Pp.pp (pp e)
-
diff --git a/contrib/correctness/peffect.mli b/contrib/correctness/peffect.mli
deleted file mode 100644
index 9a10dea4..00000000
--- a/contrib/correctness/peffect.mli
+++ /dev/null
@@ -1,42 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: peffect.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-
-(* The abstract type of effects *)
-
-type t
-
-val bottom : t
-val add_read : identifier -> t -> t
-val add_write : identifier -> t -> t
-
-val get_reads : t -> identifier list
-val get_writes : t -> identifier list
-val get_repr : t -> (identifier list) * (identifier list)
-
-val is_read : t -> identifier -> bool (* read-only *)
-val is_write : t -> identifier -> bool (* read-write *)
-
-val compose : t -> t -> t
-
-val union : t -> t -> t
-val disj : t -> t -> t
-
-val remove : t -> identifier -> t
-
-val subst : (identifier * identifier) list -> t -> t
-
-
-val pp : t -> Pp.std_ppcmds
-val ppr : t -> unit
-
diff --git a/contrib/correctness/penv.ml b/contrib/correctness/penv.ml
deleted file mode 100644
index 7f89b1e1..00000000
--- a/contrib/correctness/penv.ml
+++ /dev/null
@@ -1,240 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: penv.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pmisc
-open Past
-open Ptype
-open Names
-open Nameops
-open Libobject
-open Library
-open Term
-
-(* Environments for imperative programs.
- *
- * An environment of programs is an association tables
- * from identifiers (Names.identifier) to types of values with effects
- * (ProgAst.ml_type_v), together with a list of these associations, since
- * the order is relevant (we have dependent types e.g. [x:nat; t:(array x T)])
- *)
-
-module Env = struct
- type 'a t = ('a Idmap.t)
- * ((identifier * 'a) list)
- * ((identifier * (identifier * variant)) list)
- let empty = Idmap.empty, [], []
- let add id v (m,l,r) = (Idmap.add id v m, (id,v)::l, r)
- let find id (m,_,_) = Idmap.find id m
- let fold f (_,l,_) x0 = List.fold_right f l x0
- let add_rec (id,var) (m,l,r) = (m,l,(id,var)::r)
- let find_rec id (_,_,r) = List.assoc id r
-end
-
-(* Local environments *)
-
-type type_info = Set | TypeV of type_v
-
-type local_env = type_info Env.t
-
-let empty = (Env.empty : local_env)
-
-let add (id,v) = Env.add id (TypeV v)
-
-let add_set id = Env.add id Set
-
-let find id env =
- match Env.find id env with TypeV v -> v | Set -> raise Not_found
-
-let is_local env id =
- try
- match Env.find id env with TypeV _ -> true | Set -> false
- with
- Not_found -> false
-
-let is_local_set env id =
- try
- match Env.find id env with TypeV _ -> false | Set -> true
- with
- Not_found -> false
-
-
-(* typed programs *)
-
-type typing_info = {
- env : local_env;
- kappa : constr ml_type_c
-}
-
-type typed_program = (typing_info, constr) t
-
-
-(* The global environment.
- *
- * We have a global typing environment env
- * We also keep a table of programs for extraction purposes
- * and a table of initializations (still for extraction)
- *)
-
-let (env : type_info Env.t ref) = ref Env.empty
-
-let (pgm_table : (typed_program option) Idmap.t ref) = ref Idmap.empty
-
-let (init_table : constr Idmap.t ref) = ref Idmap.empty
-
-let freeze () = (!env, !pgm_table, !init_table)
-let unfreeze (e,p,i) = env := e; pgm_table := p; init_table := i
-let init () =
- env := Env.empty; pgm_table := Idmap.empty; init_table := Idmap.empty
-;;
-
-Summary.declare_summary "programs-environment"
- { Summary.freeze_function = freeze;
- Summary.unfreeze_function = unfreeze;
- Summary.init_function = init;
- Summary.survive_module = false;
- Summary.survive_section = false }
-;;
-
-(* Operations on the global environment. *)
-
-let add_pgm id p = pgm_table := Idmap.add id p !pgm_table
-
-let cache_global (_,(id,v,p)) =
- env := Env.add id v !env; add_pgm id p
-
-let type_info_app f = function Set -> Set | TypeV v -> TypeV (f v)
-
-let subst_global (_,s,(id,v,p)) = (id, type_info_app (type_v_knsubst s) v, p)
-
-let (inProg,outProg) =
- declare_object { object_name = "programs-objects";
- cache_function = cache_global;
- load_function = (fun _ -> cache_global);
- open_function = (fun _ _ -> ());
- classify_function = (fun (_,x) -> Substitute x);
- subst_function = subst_global;
- export_function = (fun x -> Some x) }
-
-let is_mutable = function Ref _ | Array _ -> true | _ -> false
-
-let add_global id v p =
- try
- let _ = Env.find id !env in
- Perror.clash id None
- with
- Not_found -> begin
- let id' =
- if is_mutable v then id
- else id_of_string ("prog_" ^ (string_of_id id))
- in
- Lib.add_leaf id' (inProg (id,TypeV v,p))
- end
-
-let add_global_set id =
- try
- let _ = Env.find id !env in
- Perror.clash id None
- with
- Not_found -> Lib.add_leaf id (inProg (id,Set,None))
-
-let is_global id =
- try
- match Env.find id !env with TypeV _ -> true | Set -> false
- with
- Not_found -> false
-
-let is_global_set id =
- try
- match Env.find id !env with TypeV _ -> false | Set -> true
- with
- Not_found -> false
-
-
-let lookup_global id =
- match Env.find id !env with TypeV v -> v | Set -> raise Not_found
-
-let find_pgm id = Idmap.find id !pgm_table
-
-let all_vars () =
- Env.fold
- (fun (id,v) l -> match v with TypeV (Arrow _|TypePure _) -> id::l | _ -> l)
- !env []
-
-let all_refs () =
- Env.fold
- (fun (id,v) l -> match v with TypeV (Ref _ | Array _) -> id::l | _ -> l)
- !env []
-
-(* initializations *)
-
-let cache_init (_,(id,c)) =
- init_table := Idmap.add id c !init_table
-
-let subst_init (_,s,(id,c)) = (id, subst_mps s c)
-
-let (inInit,outInit) =
- declare_object { object_name = "programs-objects-init";
- cache_function = cache_init;
- load_function = (fun _ -> cache_init);
- open_function = (fun _ _-> ());
- classify_function = (fun (_,x) -> Substitute x);
- subst_function = subst_init;
- export_function = (fun x -> Some x) }
-
-let initialize id c = Lib.add_anonymous_leaf (inInit (id,c))
-
-let find_init id = Idmap.find id !init_table
-
-
-(* access in env, local then global *)
-
-let type_in_env env id =
- try find id env with Not_found -> lookup_global id
-
-let is_in_env env id =
- (is_global id) or (is_local env id)
-
-let fold_all f lenv x0 =
- let x1 = Env.fold f !env x0 in
- Env.fold f lenv x1
-
-
-(* recursions *)
-
-let add_recursion = Env.add_rec
-
-let find_recursion = Env.find_rec
-
-
-(* We also maintain a table of the currently edited proofs of programs
- * in order to add them in the environnement when the user does Save *)
-
-open Pp
-open Himsg
-
-let (edited : (type_v * typed_program) Idmap.t ref) = ref Idmap.empty
-
-let new_edited id v =
- edited := Idmap.add id v !edited
-
-let is_edited id =
- try let _ = Idmap.find id !edited in true with Not_found -> false
-
-let register id id' =
- try
- let (v,p) = Idmap.find id !edited in
- let _ = add_global id' v (Some p) in
- Options.if_verbose
- msgnl (hov 0 (str"Program " ++ pr_id id' ++ spc () ++ str"is defined"));
- edited := Idmap.remove id !edited
- with Not_found -> ()
-
diff --git a/contrib/correctness/penv.mli b/contrib/correctness/penv.mli
deleted file mode 100644
index 6743b465..00000000
--- a/contrib/correctness/penv.mli
+++ /dev/null
@@ -1,87 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: penv.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Ptype
-open Past
-open Names
-open Libnames
-open Term
-
-(* Environment for imperative programs.
- *
- * Here we manage the global environment, which is imperative,
- * and we provide a functional local environment.
- *
- * The most important functions, is_in_env, type_in_env and fold_all
- * first look in the local environment then in the global one.
- *)
-
-(* local environments *)
-
-type local_env
-
-val empty : local_env
-val add : (identifier * type_v) -> local_env -> local_env
-val add_set : identifier -> local_env -> local_env
-val is_local : local_env -> identifier -> bool
-val is_local_set : local_env -> identifier -> bool
-
-(* typed programs *)
-
-type typing_info = {
- env : local_env;
- kappa : constr ml_type_c
-}
-
-type typed_program = (typing_info, constr) t
-
-(* global environment *)
-
-val add_global : identifier -> type_v -> typed_program option -> object_name
-val add_global_set : identifier -> object_name
-val is_global : identifier -> bool
-val is_global_set : identifier -> bool
-val lookup_global : identifier -> type_v
-
-val all_vars : unit -> identifier list
-val all_refs : unit -> identifier list
-
-(* a table keeps the program (for extraction) *)
-
-val find_pgm : identifier -> typed_program option
-
-(* a table keeps the initializations of mutable objects *)
-
-val initialize : identifier -> constr -> unit
-val find_init : identifier -> constr
-
-(* access in env (local then global) *)
-
-val type_in_env : local_env -> identifier -> type_v
-val is_in_env : local_env -> identifier -> bool
-
-type type_info = Set | TypeV of type_v
-val fold_all : (identifier * type_info -> 'a -> 'a) -> local_env -> 'a -> 'a
-
-(* local environnements also contains a list of recursive functions
- * with the associated variant *)
-
-val add_recursion : identifier * (identifier*variant) -> local_env -> local_env
-val find_recursion : identifier -> local_env -> identifier * variant
-
-(* We also maintain a table of the currently edited proofs of programs
- * in order to add them in the environnement when the user does Save *)
-
-val new_edited : identifier -> type_v * typed_program -> unit
-val is_edited : identifier -> bool
-val register : identifier -> identifier -> unit
-
diff --git a/contrib/correctness/perror.ml b/contrib/correctness/perror.ml
deleted file mode 100644
index 8415e96d..00000000
--- a/contrib/correctness/perror.ml
+++ /dev/null
@@ -1,172 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: perror.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Term
-open Himsg
-
-open Ptype
-open Past
-
-let is_mutable = function Ref _ | Array _ -> true | _ -> false
-let is_pure = function TypePure _ -> true | _ -> false
-
-let raise_with_loc = function
- | None -> raise
- | Some loc -> Stdpp.raise_with_loc loc
-
-let unbound_variable id loc =
- raise_with_loc loc
- (UserError ("Perror.unbound_variable",
- (hov 0 (str"Unbound variable" ++ spc () ++ pr_id id ++ fnl ()))))
-
-let unbound_reference id loc =
- raise_with_loc loc
- (UserError ("Perror.unbound_reference",
- (hov 0 (str"Unbound reference" ++ spc () ++ pr_id id ++ fnl ()))))
-
-let clash id loc =
- raise_with_loc loc
- (UserError ("Perror.clash",
- (hov 0 (str"Clash with previous constant" ++ spc () ++
- str(string_of_id id) ++ fnl ()))))
-
-let not_defined id =
- raise
- (UserError ("Perror.not_defined",
- (hov 0 (str"The object" ++ spc () ++ pr_id id ++ spc () ++
- str"is not defined" ++ fnl ()))))
-
-let check_for_reference loc id = function
- Ref _ -> ()
- | _ -> Stdpp.raise_with_loc loc
- (UserError ("Perror.check_for_reference",
- hov 0 (pr_id id ++ spc () ++
- str"is not a reference")))
-
-let check_for_array loc id = function
- Array _ -> ()
- | _ -> Stdpp.raise_with_loc loc
- (UserError ("Perror.check_for_array",
- hov 0 (pr_id id ++ spc () ++
- str"is not an array")))
-
-let is_constant_type s = function
- TypePure c ->
- let id = id_of_string s in
- let c' = Constrintern.global_reference id in
- Reductionops.is_conv (Global.env()) Evd.empty c c'
- | _ -> false
-
-let check_for_index_type loc v =
- let is_index = is_constant_type "Z" v in
- if not is_index then
- Stdpp.raise_with_loc loc
- (UserError ("Perror.check_for_index",
- hov 0 (str"This expression is an index" ++ spc () ++
- str"and should have type int (Z)")))
-
-let check_no_effect loc ef =
- if not (Peffect.get_writes ef = []) then
- Stdpp.raise_with_loc loc
- (UserError ("Perror.check_no_effect",
- hov 0 (str"A boolean should not have side effects"
-)))
-
-let should_be_boolean loc =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.should_be_boolean",
- hov 0 (str"This expression is a test:" ++ spc () ++
- str"it should have type bool")))
-
-let test_should_be_annotated loc =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.test_should_be_annotated",
- hov 0 (str"This test should be annotated")))
-
-let if_branches loc =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.if_branches",
- hov 0 (str"The two branches of an `if' expression" ++ spc () ++
- str"should have the same type")))
-
-let check_for_not_mutable loc v =
- if is_mutable v then
- Stdpp.raise_with_loc loc
- (UserError ("Perror.check_for_not_mutable",
- hov 0 (str"This expression cannot be a mutable")))
-
-let check_for_pure_type loc v =
- if not (is_pure v) then
- Stdpp.raise_with_loc loc
- (UserError ("Perror.check_for_pure_type",
- hov 0 (str"This expression must be pure" ++ spc () ++
- str"(neither a mutable nor a function)")))
-
-let check_for_let_ref loc v =
- if not (is_pure v) then
- Stdpp.raise_with_loc loc
- (UserError ("Perror.check_for_let_ref",
- hov 0 (str"References can only be bound in pure terms")))
-
-let informative loc s =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.variant_informative",
- hov 0 (str s ++ spc () ++ str"must be informative")))
-
-let variant_informative loc = informative loc "Variant"
-let should_be_informative loc = informative loc "This term"
-
-let app_of_non_function loc =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.app_of_non_function",
- hov 0 (str"This term cannot be applied" ++ spc () ++
- str"(either it is not a function" ++ spc () ++
- str"or it is applied to non pure arguments)")))
-
-let partial_app loc =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.partial_app",
- hov 0 (str"This function does not have" ++
- spc () ++ str"the right number of arguments")))
-
-let expected_type loc s =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.expected_type",
- hov 0 (str"Argument is expected to have type" ++ spc () ++ s)))
-
-let expects_a_type id loc =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.expects_a_type",
- hov 0 (str"The argument " ++ pr_id id ++ spc () ++
- str"in this application is supposed to be a type")))
-
-let expects_a_term id =
- raise
- (UserError ("Perror.expects_a_type",
- hov 0 (str"The argument " ++ pr_id id ++ spc () ++
- str"in this application is supposed to be a term")))
-
-let should_be_a_variable loc =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.should_be_a_variable",
- hov 0 (str"Argument should be a variable")))
-
-let should_be_a_reference loc =
- Stdpp.raise_with_loc loc
- (UserError ("Perror.should_be_a_reference",
- hov 0 (str"Argument of function should be a reference")))
-
-
diff --git a/contrib/correctness/perror.mli b/contrib/correctness/perror.mli
deleted file mode 100644
index 45b2acdc..00000000
--- a/contrib/correctness/perror.mli
+++ /dev/null
@@ -1,47 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: perror.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Util
-open Names
-open Ptype
-open Past
-
-val unbound_variable : identifier -> loc option -> 'a
-val unbound_reference : identifier -> loc option -> 'a
-
-val clash : identifier -> loc option -> 'a
-val not_defined : identifier -> 'a
-
-val check_for_reference : loc -> identifier -> type_v -> unit
-val check_for_array : loc -> identifier -> type_v -> unit
-
-val check_for_index_type : loc -> type_v -> unit
-val check_no_effect : loc -> Peffect.t -> unit
-val should_be_boolean : loc -> 'a
-val test_should_be_annotated : loc -> 'a
-val if_branches : loc -> 'a
-
-val check_for_not_mutable : loc -> type_v -> unit
-val check_for_pure_type : loc -> type_v -> unit
-val check_for_let_ref : loc -> type_v -> unit
-
-val variant_informative : loc -> 'a
-val should_be_informative : loc -> 'a
-
-val app_of_non_function : loc -> 'a
-val partial_app : loc -> 'a
-val expected_type : loc -> std_ppcmds -> 'a
-val expects_a_type : identifier -> loc -> 'a
-val expects_a_term : identifier -> 'a
-val should_be_a_variable : loc -> 'a
-val should_be_a_reference : loc -> 'a
diff --git a/contrib/correctness/pextract.ml b/contrib/correctness/pextract.ml
deleted file mode 100644
index 407567ad..00000000
--- a/contrib/correctness/pextract.ml
+++ /dev/null
@@ -1,473 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pextract.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp_control
-open Pp
-open Util
-open System
-open Names
-open Term
-open Himsg
-open Reduction
-
-open Putil
-open Ptype
-open Past
-open Penv
-open Putil
-
-let extraction env c =
- let ren = initial_renaming env in
- let sign = Pcicenv.now_sign_of ren env in
- let fsign = Mach.fsign_of_sign (Evd.mt_evd()) sign in
- match Mach.infexecute (Evd.mt_evd()) (sign,fsign) c with
- | (_,Inf j) -> j._VAL
- | (_,Logic) -> failwith "Prog_extract.pp: should be informative"
-
-(* les tableaux jouent un role particulier, puisqu'ils seront extraits
- * vers des tableaux ML *)
-
-let sp_access = coq_constant ["correctness"; "Arrays"] "access"
-let access = ConstRef sp_access
-
-let has_array = ref false
-
-let pp_conversions () =
- (str"\
-let rec int_of_pos = function
- XH -> 1
- | XI p -> 2 * (int_of_pos p) + 1
- | XO p -> 2 * (int_of_pos p)
- ++ ++
-
-let int_of_z = function
- ZERO -> 0
- | POS p -> int_of_pos p
- | NEG p -> -(int_of_pos p)
- ++ ++
-") (* '"' *)
-
-(* collect all section-path in a CIC constant *)
-
-let spset_of_cci env c =
- let spl = Fw_env.collect (extraction env c) in
- let sps = List.fold_left (fun e x -> SpSet.add x e) SpSet.empty spl in
- has_array := !has_array or (SpSet.mem sp_access sps) ++
- SpSet.remove sp_access sps
-
-
-(* collect all Coq constants and all pgms appearing in a given program *)
-
-let add_id env ((sp,ids) as s) id =
- if is_local env id then
- s
- else if is_global id then
- (sp,IdSet.add id ids)
- else
- try (SpSet.add (Nametab.sp_of_id FW id) sp,ids) with Not_found -> s
-
-let collect env =
- let rec collect_desc env s = function
- | Var x -> add_id env s x
- | Acc x -> add_id env s x
- | Aff (x,e1) -> add_id env (collect_rec env s e1) x
- | TabAcc (_,x,e1) ->
- has_array := true ++
- add_id env (collect_rec env s e1) x
- | TabAff (_,x,e1,e2) ->
- has_array := true ++
- add_id env (collect_rec env (collect_rec env s e1) e2) x
- | Seq bl ->
- List.fold_left (fun s st -> match st with
- Statement p -> collect_rec env s p
- | _ -> s) s bl
- | If (e1,e2,e3) ->
- collect_rec env (collect_rec env (collect_rec env s e1) e2) e3
- | While (b,_,_,bl) ->
- let s = List.fold_left (fun s st -> match st with
- Statement p -> collect_rec env s p
- | _ -> s) s bl in
- collect_rec env s b
- | Lam (bl,e) ->
- collect_rec (traverse_binders env bl) s e
- | App (e1,l) ->
- let s = List.fold_left (fun s a -> match a with
- Term t -> collect_rec env s t
- | Type _ | Refarg _ -> s) s l in
- collect_rec env s e1
- | SApp (_,l) ->
- List.fold_left (fun s a -> collect_rec env s a) s l
- | LetRef (x,e1,e2) ->
- let (_,v),_,_,_ = e1.info.kappa in
- collect_rec (add (x,Ref v) env) (collect_rec env s e1) e2
- | LetIn (x,e1,e2) ->
- let (_,v),_,_,_ = e1.info.kappa in
- collect_rec (add (x,v) env) (collect_rec env s e1) e2
- | LetRec (f,bl,_,_,e) ->
- let env' = traverse_binders env bl in
- let env'' = add (f,make_arrow bl e.info.kappa) env' in
- collect_rec env'' s e
- | Debug (_,e1) -> collect_rec env s e1
- | PPoint (_,d) -> collect_desc env s d
- | Expression c ->
- let (sp,ids) = s in
- let sp' = spset_of_cci env c in
- SpSet.fold
- (fun s (es,ei) ->
- let id = basename s in
- if is_global id then (*SpSet.add s*)es,IdSet.add id ei
- else SpSet.add s es,ei)
- sp' (sp,ids)
-
- and collect_rec env s p = collect_desc env s p.desc
-
- in
- collect_rec env (SpSet.empty,IdSet.empty)
-
-
-(* On a besoin de faire du renommage, tout comme pour l'extraction des
- * termes Coq. En ce qui concerne les globaux, on utilise la table de
- * Fwtoml. Pour les objects locaux, on introduit la structure de
- * renommage rename_struct
- *)
-
-module Ocaml_ren = Ocaml.OCaml_renaming
-
-let rename_global id =
- let id' = Ocaml_ren.rename_global_term !Fwtoml.globals (Name id) in
- Fwtoml.add_global_renaming (id,id') ++
- id'
-
-type rename_struct = { rn_map : identifier IdMap.t;
- rn_avoid : identifier list }
-
-let rn_empty = { rn_map = IdMap.empty; rn_avoid = [] }
-
-let rename_local rn id =
- let id' = Ocaml_ren.rename_term (!Fwtoml.globals@rn.rn_avoid) (Name id) in
- { rn_map = IdMap.add id id' rn.rn_map; rn_avoid = id' :: rn.rn_avoid },
- id'
-
-let get_local_name rn id = IdMap.find id rn.rn_map
-
-let get_name env rn id =
- if is_local env id then
- get_local_name rn id
- else
- Fwtoml.get_global_name id
-
-let rec rename_binders rn = function
- | [] -> rn
- | (id,_) :: bl -> let rn',_ = rename_local rn id in rename_binders rn' bl
-
-(* on a bespoin d'un pretty-printer de constr particulier, qui reconnaisse
- * les acces a des references et dans des tableaux, et qui de plus n'imprime
- * pas de GENTERM lorsque des identificateurs ne sont pas visibles.
- * Il est simplifie dans la mesure ou l'on a ici que des constantes et
- * des applications.
- *)
-
-let putpar par s =
- if par then (str"(" ++ s ++ str")") else s
-
-let is_ref env id =
- try
- (match type_in_env env id with Ref _ -> true | _ -> false)
- with
- Not_found -> false
-
-let rec pp_constr env rn = function
- | VAR id ->
- if is_ref env id then
- (str"!" ++ pID (get_name env rn id))
- else
- pID (get_name env rn id)
- | DOPN((Const _|MutInd _|MutConstruct _) as oper, _) ->
- pID (Fwtoml.name_of_oper oper)
- | DOPN(AppL,v) ->
- if Array.length v = 0 then
- (mt ())
- else begin
- match v.(0) with
- DOPN(Const sp,_) when sp = sp_access ->
- (pp_constr env rn v.(3) ++
- str".(int_of_z " ++ pp_constr env rn v.(4) ++ str")")
- | _ ->
- hov 2 (putpar true (prvect_with_sep (fun () -> (spc ()))
- (pp_constr env rn) v))
- end
- | DOP2(Cast,c,_) -> pp_constr env rn c
- | _ -> failwith "Prog_extract.pp_constr: unexpected constr"
-
-
-(* pretty-print of imperative programs *)
-
-let collect_lambda =
- let rec collect acc p = match p.desc with
- | Lam(bl,t) -> collect (bl@acc) t
- | x -> acc,p
- in
- collect []
-
-let pr_binding rn =
- prlist_with_sep (fun () -> (mt ()))
- (function
- | (id,(Untyped | BindType _)) ->
- (str" " ++ pID (get_local_name rn id))
- | (id,BindSet) -> (mt ()))
-
-let pp_prog id =
- let rec pp_d env rn par = function
- | Var x -> pID (get_name env rn x)
- | Acc x -> (str"!" ++ pID (get_name env rn x))
- | Aff (x,e1) -> (pID (get_name env rn x) ++
- str" := " ++ hov 0 (pp env rn false e1))
- | TabAcc (_,x,e1) ->
- (pID (get_name env rn x) ++
- str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")")
- | TabAff (_,x,e1,e2) ->
- (pID (get_name env rn x) ++
- str".(int_of_z " ++ hov 0 (pp env rn true e1) ++ str")" ++
- str" <-" ++ spc () ++ hov 2 (pp env rn false e2))
- | Seq bl ->
- (str"begin" ++ fnl () ++
- str" " ++ hov 0 (pp_block env rn bl) ++ fnl () ++
- str"end")
- | If (e1,e2,e3) ->
- putpar par (str"if " ++ (pp env rn false e1) ++
- str" then" ++ fnl () ++
- str" " ++ hov 0 (pp env rn false e2) ++ fnl () ++
- str"else" ++ fnl () ++
- str" " ++ hov 0 (pp env rn false e3))
- (* optimisations : then begin .... end else begin ... end *)
- | While (b,inv,_,bl) ->
- (str"while " ++ (pp env rn false b) ++ str" do" ++ fnl () ++
- str" " ++
- hov 0 ((match inv with
- None -> (mt ())
- | Some c -> (str"(* invariant: " ++ pTERM c.a_value ++
- str" *)" ++ fnl ())) ++
- pp_block env rn bl) ++ fnl () ++
- str"done")
- | Lam (bl,e) ->
- let env' = traverse_binders env bl in
- let rn' = rename_binders rn bl in
- putpar par
- (hov 2 (str"fun" ++ pr_binding rn' bl ++ str" ->" ++
- spc () ++ pp env' rn' false e))
- | SApp ((Var id)::_, [e1; e2])
- when id = connective_and or id = connective_or ->
- let conn = if id = connective_and then "&" else "or" in
- putpar par
- (hov 0 (pp env rn true e1 ++ spc () ++ str conn ++ spc () ++
- pp env rn true e2))
- | SApp ((Var id)::_, [e]) when id = connective_not ->
- putpar par
- (hov 0 (str"not" ++ spc () ++ pp env rn true e))
- | SApp _ ->
- invalid_arg "Prog_extract.pp_prog (SApp)"
- | App(e1,[]) ->
- hov 0 (pp env rn false e1)
- | App (e1,l) ->
- putpar true
- (hov 2 (pp env rn true e1 ++
- prlist (function
- Term p -> (spc () ++ pp env rn true p)
- | Refarg x -> (spc () ++ pID (get_name env rn x))
- | Type _ -> (mt ()))
- l))
- | LetRef (x,e1,e2) ->
- let (_,v),_,_,_ = e1.info.kappa in
- let env' = add (x,Ref v) env in
- let rn',x' = rename_local rn x in
- putpar par
- (hov 0 (str"let " ++ pID x' ++ str" = ref " ++ pp env rn false e1 ++
- str" in" ++ fnl () ++ pp env' rn' false e2))
- | LetIn (x,e1,e2) ->
- let (_,v),_,_,_ = e1.info.kappa in
- let env' = add (x,v) env in
- let rn',x' = rename_local rn x in
- putpar par
- (hov 0 (str"let " ++ pID x' ++ str" = " ++ pp env rn false e1 ++
- str" in" ++ fnl () ++ pp env' rn' false e2))
- | LetRec (f,bl,_,_,e) ->
- let env' = traverse_binders env bl in
- let rn' = rename_binders rn bl in
- let env'' = add (f,make_arrow bl e.info.kappa) env' in
- let rn'',f' = rename_local rn' f in
- putpar par
- (hov 0 (str"let rec " ++ pID f' ++ pr_binding rn' bl ++ str" =" ++ fnl () ++
- str" " ++ hov 0 (pp env'' rn'' false e) ++ fnl () ++
- str"in " ++ pID f'))
- | Debug (_,e1) -> pp env rn par e1
- | PPoint (_,d) -> pp_d env rn par d
- | Expression c ->
- pp_constr env rn (extraction env c)
-
- and pp_block env rn bl =
- let bl =
- map_succeed (function Statement p -> p | _ -> failwith "caught") bl
- in
- prlist_with_sep (fun () -> (str";" ++ fnl ()))
- (fun p -> hov 0 (pp env rn false p)) bl
-
- and pp env rn par p =
- (pp_d env rn par p.desc)
-
- and pp_mut v c = match v with
- | Ref _ ->
- (str"ref " ++ pp_constr empty rn_empty (extraction empty c))
- | Array (n,_) ->
- (str"Array.create " ++ cut () ++
- putpar true
- (str"int_of_z " ++
- pp_constr empty rn_empty (extraction empty n)) ++
- str" " ++ pp_constr empty rn_empty (extraction empty c))
- | _ -> invalid_arg "pp_mut"
- in
- let v = lookup_global id in
- let id' = rename_global id in
- if is_mutable v then
- try
- let c = find_init id in
- hov 0 (str"let " ++ pID id' ++ str" = " ++ pp_mut v c)
- with Not_found ->
- errorlabstrm "Prog_extract.pp_prog"
- (str"The variable " ++ pID id ++
- str" must be initialized first !")
- else
- match find_pgm id with
- | None ->
- errorlabstrm "Prog_extract.pp_prog"
- (str"The program " ++ pID id ++
- str" must be realized first !")
- | Some p ->
- let bl,p = collect_lambda p in
- let rn = rename_binders rn_empty bl in
- let env = traverse_binders empty bl in
- hov 0 (str"let " ++ pID id' ++ pr_binding rn bl ++ str" =" ++ fnl () ++
- str" " ++ hov 2 (pp env rn false p))
-
-(* extraction des programmes impératifs/fonctionnels vers ocaml *)
-
-(* Il faut parfois importer des modules non ouverts, sinon
- * Ocaml.OCaml_pp_file.pp echoue en disant "machin is not a defined
- * informative object". Cela dit, ce n'est pas tres satisfaisant, vu que
- * la constante existe quand meme: il vaudrait mieux contourner l'echec
- * de ml_import.fwsp_of_id
- *)
-
-let import sp = match repr_path sp with
- | [m],_,_ ->
- begin
- try Library.import_export_module m true
- with _ -> ()
- end
- | _ -> ()
-
-let pp_ocaml file prm =
- has_array := false ++
- (* on separe objects Coq et programmes *)
- let cic,pgms =
- List.fold_left
- (fun (sp,ids) id ->
- if is_global id then (sp,IdSet.add id ids) else (IdSet.add id sp,ids))
- (IdSet.empty,IdSet.empty) prm.needed
- in
- (* on met les programmes dans l'ordre et pour chacun on recherche les
- * objects Coq necessaires, que l'on rajoute a l'ensemble cic *)
- let cic,_,pgms =
- let o_pgms = fold_all (fun (id,_) l -> id::l) empty [] in
- List.fold_left
- (fun (cic,pgms,pl) id ->
- if IdSet.mem id pgms then
- let spl,pgms' =
- try
- (match find_pgm id with
- | Some p -> collect empty p
- | None ->
- (try
- let c = find_init id in
- spset_of_cci empty c,IdSet.empty
- with Not_found ->
- SpSet.empty,IdSet.empty))
- with Not_found -> SpSet.empty,IdSet.empty
- in
- let cic' =
- SpSet.fold
- (fun sp cic -> import sp ++ IdSet.add (basename sp) cic)
- spl cic
- in
- (cic',IdSet.union pgms pgms',id::pl)
- else
- (cic,pgms,pl))
- (cic,pgms,[]) o_pgms
- in
- let cic = IdSet.elements cic in
- (* on pretty-print *)
- let prm' = { needed = cic ++ expand = prm.expand ++
- expansion = prm.expansion ++ exact = prm.exact }
- in
- let strm = (Ocaml.OCaml_pp_file.pp_recursive prm' ++
- fnl () ++ fnl () ++
- if !has_array then pp_conversions() else (mt ()) ++
- prlist (fun p -> (pp_prog p ++ fnl () ++ str";;" ++ fnl () ++ fnl ()))
- pgms
-)
- in
- (* puis on ecrit dans le fichier *)
- let chan = open_trapping_failure open_out file ".ml" in
- let ft = with_output_to chan in
- begin
- try pP_with ft strm ++ pp_flush_with ft ()
- with e -> pp_flush_with ft () ++ close_out chan ++ raise e
- end ++
- close_out chan
-
-
-(* Initializations of mutable objects *)
-
-let initialize id com =
- let loc = Ast.loc com in
- let c = constr_of_com (Evd.mt_evd()) (initial_sign()) com in
- let ty =
- Reductionops.nf_betaiota (type_of (Evd.mt_evd()) (initial_sign()) c) in
- try
- let v = lookup_global id in
- let ety = match v with
- | Ref (TypePure c) -> c | Array (_,TypePure c) -> c
- | _ -> raise Not_found
- in
- if conv (Evd.mt_evd()) ty ety then
- initialize id c
- else
- errorlabstrm "Prog_extract.initialize"
- (str"Not the expected type for the mutable " ++ pID id)
- with Not_found ->
- errorlabstrm "Prog_extract.initialize"
- (pr_id id ++ str" is not a mutable")
-
-(* grammaire *)
-
-open Vernacinterp
-
-let _ = vinterp_add "IMPERATIVEEXTRACTION"
- (function
- | VARG_STRING file :: rem ->
- let prm = parse_param rem in (fun () -> pp_ocaml file prm)
- | _ -> assert false)
-
-let _ = vinterp_add "INITIALIZE"
- (function
- | [VARG_IDENTIFIER id; VARG_COMMAND com] ->
- (fun () -> initialize id com)
- | _ -> assert false)
diff --git a/contrib/correctness/pextract.mli b/contrib/correctness/pextract.mli
deleted file mode 100644
index 3492729c..00000000
--- a/contrib/correctness/pextract.mli
+++ /dev/null
@@ -1,17 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pextract.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-
-val pp_ocaml : string -> unit
-
-
diff --git a/contrib/correctness/pmisc.ml b/contrib/correctness/pmisc.ml
deleted file mode 100644
index 076b11cd..00000000
--- a/contrib/correctness/pmisc.ml
+++ /dev/null
@@ -1,222 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmisc.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-open Pp
-open Util
-open Names
-open Nameops
-open Term
-open Libnames
-open Topconstr
-
-(* debug *)
-
-let deb_mess s =
- if !Options.debug then begin
- msgnl s; pp_flush()
- end
-
-let deb_print f x =
- if !Options.debug then begin
- msgnl (f x); pp_flush()
- end
-
-let list_of_some = function
- None -> []
- | Some x -> [x]
-
-let difference l1 l2 =
- let rec diff = function
- [] -> []
- | a::rem -> if List.mem a l2 then diff rem else a::(diff rem)
- in
- diff l1
-
-(* TODO: these functions should be moved in the code of Coq *)
-
-let reraise_with_loc loc f x =
- try f x with Util.UserError (_,_) as e -> Stdpp.raise_with_loc loc e
-
-
-(* functions on names *)
-
-let at = if !Options.v7 then "@" else "'at'"
-
-let at_id id d = id_of_string ((string_of_id id) ^ at ^ d)
-
-let is_at id =
- try
- let _ = string_index_from (string_of_id id) 0 at in true
- with Not_found ->
- false
-
-let un_at id =
- let s = string_of_id id in
- try
- let n = string_index_from s 0 at in
- id_of_string (String.sub s 0 n),
- String.sub s (n + String.length at)
- (String.length s - n - String.length at)
- with Not_found ->
- invalid_arg "un_at"
-
-let renaming_of_ids avoid ids =
- let rec rename avoid = function
- [] -> [], avoid
- | x::rem ->
- let al,avoid = rename avoid rem in
- let x' = next_ident_away x avoid in
- (x,x')::al, x'::avoid
- in
- rename avoid ids
-
-let result_id = id_of_string "result"
-
-let adr_id id = id_of_string ("adr_" ^ (string_of_id id))
-
-(* hypotheses names *)
-
-let next s r = function
- Anonymous -> incr r; id_of_string (s ^ string_of_int !r)
- | Name id -> id
-
-let reset_names,pre_name,post_name,inv_name,
- test_name,bool_name,var_name,phi_name,for_name,label_name =
- let pre = ref 0 in
- let post = ref 0 in
- let inv = ref 0 in
- let test = ref 0 in
- let bool = ref 0 in
- let var = ref 0 in
- let phi = ref 0 in
- let forr = ref 0 in
- let label = ref 0 in
- (fun () ->
- pre := 0; post := 0; inv := 0; test := 0;
- bool := 0; var := 0; phi := 0; label := 0),
- (next "Pre" pre),
- (next "Post" post),
- (next "Inv" inv),
- (next "Test" test),
- (fun () -> next "Bool" bool Anonymous),
- (next "Variant" var),
- (fun () -> next "rphi" phi Anonymous),
- (fun () -> next "for" forr Anonymous),
- (fun () -> string_of_id (next "Label" label Anonymous))
-
-let default = id_of_string "x_"
-let id_of_name = function Name id -> id | Anonymous -> default
-
-
-(* functions on CIC terms *)
-
-let isevar = Evarutil.new_evar_in_sign (Global.env ())
-
-(* Substitutions of variables by others. *)
-let subst_in_constr alist =
- let alist' = List.map (fun (id,id') -> (id, mkVar id')) alist in
- replace_vars alist'
-
-(*
-let subst_in_ast alist ast =
- let rec subst = function
- Nvar(l,s) -> Nvar(l,try List.assoc s alist with Not_found -> s)
- | Node(l,s,args) -> Node(l,s,List.map subst args)
- | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *)
- | x -> x
- in
- subst ast
-*)
-(*
-let subst_ast_in_ast alist ast =
- let rec subst = function
- Nvar(l,s) as x -> (try List.assoc s alist with Not_found -> x)
- | Node(l,s,args) -> Node(l,s,List.map subst args)
- | Slam(l,so,a) -> Slam(l,so,subst a) (* TODO:enlever so de alist ? *)
- | x -> x
- in
- subst ast
-*)
-
-let rec subst_in_ast alist = function
- | CRef (Ident (loc,id)) ->
- CRef (Ident (loc,(try List.assoc id alist with Not_found -> id)))
- | x -> map_constr_expr_with_binders subst_in_ast List.remove_assoc alist x
-
-let rec subst_ast_in_ast alist = function
- | CRef (Ident (_,id)) as x -> (try List.assoc id alist with Not_found -> x)
- | x ->
- map_constr_expr_with_binders subst_ast_in_ast List.remove_assoc alist x
-
-(* subst. of variables by constr *)
-let real_subst_in_constr = replace_vars
-
-(* Coq constants *)
-
-let coq_constant d s =
- Libnames.encode_kn
- (make_dirpath (List.rev (List.map id_of_string ("Coq"::d))))
- (id_of_string s)
-
-let bool_sp = coq_constant ["Init"; "Datatypes"] "bool"
-let coq_true = mkConstruct ((bool_sp,0),1)
-let coq_false = mkConstruct ((bool_sp,0),2)
-
-let constant s =
- let id = Constrextern.id_of_v7_string s in
- Constrintern.global_reference id
-
-let connective_and = id_of_string "prog_bool_and"
-let connective_or = id_of_string "prog_bool_or"
-let connective_not = id_of_string "prog_bool_not"
-
-let is_connective id =
- id = connective_and or id = connective_or or id = connective_not
-
-(* [conj i s] constructs the conjunction of two constr *)
-
-let conj i s = Term.applist (constant "and", [i; s])
-
-(* [n_mkNamedProd v [xn,tn;...;x1,t1]] constructs the type
- [(x1:t1)...(xn:tn)v] *)
-
-let rec n_mkNamedProd v = function
- | [] -> v
- | (id,ty) :: rem -> n_mkNamedProd (Term.mkNamedProd id ty v) rem
-
-(* [n_lambda v [xn,tn;...;x1,t1]] constructs the type [x1:t1]...[xn:tn]v *)
-
-let rec n_lambda v = function
- | [] -> v
- | (id,ty) :: rem -> n_lambda (Term.mkNamedLambda id ty v) rem
-
-(* [abstract env idl c] constructs [x1]...[xn]c where idl = [x1;...;xn] *)
-
-let abstract ids c = n_lambda c (List.rev ids)
-
-(* substitutivity (of kernel names, for modules management) *)
-
-open Ptype
-
-let rec type_v_knsubst s = function
- | Ref v -> Ref (type_v_knsubst s v)
- | Array (c, v) -> Array (subst_mps s c, type_v_knsubst s v)
- | Arrow (bl, c) -> Arrow (List.map (binder_knsubst s) bl, type_c_knsubst s c)
- | TypePure c -> TypePure (subst_mps s c)
-
-and type_c_knsubst s ((id,v),e,pl,q) =
- ((id, type_v_knsubst s v), e,
- List.map (fun p -> { p with p_value = subst_mps s p.p_value }) pl,
- option_map (fun q -> { q with a_value = subst_mps s q.a_value }) q)
-
-and binder_knsubst s (id,b) =
- (id, match b with BindType v -> BindType (type_v_knsubst s v) | _ -> b)
diff --git a/contrib/correctness/pmisc.mli b/contrib/correctness/pmisc.mli
deleted file mode 100644
index 9d96467f..00000000
--- a/contrib/correctness/pmisc.mli
+++ /dev/null
@@ -1,81 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmisc.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Ptype
-open Topconstr
-
-(* Some misc. functions *)
-
-val reraise_with_loc : Util.loc -> ('a -> 'b) -> 'a -> 'b
-
-val list_of_some : 'a option -> 'a list
-val difference : 'a list -> 'a list -> 'a list
-
-val at_id : identifier -> string -> identifier
-val un_at : identifier -> identifier * string
-val is_at : identifier -> bool
-
-val result_id : identifier
-val adr_id : identifier -> identifier
-
-val renaming_of_ids : identifier list -> identifier list
- -> (identifier * identifier) list * identifier list
-
-val reset_names : unit -> unit
-val pre_name : name -> identifier
-val post_name : name -> identifier
-val inv_name : name -> identifier
-val test_name : name -> identifier
-val bool_name : unit -> identifier
-val var_name : name -> identifier
-val phi_name : unit -> identifier
-val for_name : unit -> identifier
-val label_name : unit -> string
-
-val id_of_name : name -> identifier
-
-(* CIC terms *)
-
-val isevar : constr
-
-val subst_in_constr : (identifier * identifier) list -> constr -> constr
-val subst_in_ast : (identifier * identifier) list -> constr_expr -> constr_expr
-val subst_ast_in_ast :
- (identifier * constr_expr) list -> constr_expr -> constr_expr
-val real_subst_in_constr : (identifier * constr) list -> constr -> constr
-
-val constant : string -> constr
-val coq_constant : string list -> string -> kernel_name
-val conj : constr -> constr -> constr
-
-val coq_true : constr
-val coq_false : constr
-
-val connective_and : identifier
-val connective_or : identifier
-val connective_not : identifier
-val is_connective : identifier -> bool
-
-val n_mkNamedProd : constr -> (identifier * constr) list -> constr
-val n_lambda : constr -> (identifier * constr) list -> constr
-val abstract : (identifier * constr) list -> constr -> constr
-
-val type_v_knsubst : substitution -> type_v -> type_v
-val type_c_knsubst : substitution -> type_c -> type_c
-
-(* for debugging purposes *)
-
-val deb_mess : Pp.std_ppcmds -> unit
-val deb_print : ('a -> Pp.std_ppcmds) -> 'a -> unit
-
diff --git a/contrib/correctness/pmlize.ml b/contrib/correctness/pmlize.ml
deleted file mode 100644
index e812fa57..00000000
--- a/contrib/correctness/pmlize.ml
+++ /dev/null
@@ -1,320 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmlize.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Termast
-open Pattern
-open Matching
-
-open Pmisc
-open Ptype
-open Past
-open Putil
-open Prename
-open Penv
-open Peffect
-open Ptyping
-open Pmonad
-
-
-let has_proof_part ren env c =
- let sign = Pcicenv.trad_sign_of ren env in
- let ty = Typing.type_of (Global.env_of_context sign) Evd.empty c in
- Hipattern.is_matching_sigma (Reductionops.nf_betaiota ty)
-
-(* main part: translation of imperative programs into functional ones.
- *
- * [env] is the environment
- * [ren] is the current renamings of variables
- * [t] is the imperative program to translate, annotated with type+effects
- *
- * we return the translated program in type cc_term
- *)
-
-let rec trad ren t =
- let env = t.info.env in
- trad_desc ren env t.info.kappa t.desc
-
-and trad_desc ren env ct d =
- let (_,tt),eft,pt,qt = ct in
- match d with
-
- | Expression c ->
- let ids = get_reads eft in
- let al = current_vars ren ids in
- let c' = subst_in_constr al c in
- if has_proof_part ren env c' then
- CC_expr c'
- else
- let ty = trad_ml_type_v ren env tt in
- make_tuple [ CC_expr c',ty ] qt ren env (current_date ren)
-
- | Variable id ->
- if is_mutable_in_env env id then
- invalid_arg "Mlise.trad_desc"
- else if is_local env id then
- CC_var id
- else
- CC_expr (constant (string_of_id id))
-
- | Acc _ ->
- failwith "Mlise.trad: pure terms are supposed to be expressions"
-
- | TabAcc (check, x, e1) ->
- let _,ty_elem,_ = array_info ren env x in
- let te1 = trad ren e1 in
- let (_,ef1,p1,q1) = e1.info.kappa in
- let w = get_writes ef1 in
- let ren' = next ren w in
- let id = id_of_string "index" in
- let access =
- make_raw_access ren' env (x,current_var ren' x) (mkVar id)
- in
- let t,ty = result_tuple ren' (current_date ren) env
- (CC_expr access, ty_elem) (eft,qt) in
- let t =
- if check then
- let h = make_pre_access ren env x (mkVar id) in
- let_in_pre ty (anonymous_pre true h) t
- else
- t
- in
- make_let_in ren env te1 p1
- (current_vars ren' w,q1) (id,constant "Z") (t,ty)
-
- | Aff (x, e1) ->
- let tx = trad_type_in_env ren env x in
- let te1 = trad ren e1 in
- let (_,ef1,p1,q1) = e1.info.kappa in
- let w1 = get_writes ef1 in
- let ren' = next ren (x::w1) in
- let t_ty = result_tuple ren' (current_date ren) env
- (CC_expr (constant "tt"), constant "unit") (eft,qt)
- in
- make_let_in ren env te1 p1
- (current_vars ren' w1,q1) (current_var ren' x,tx) t_ty
-
- | TabAff (check, x, e1, e2) ->
- let _,ty_elem,ty_array = array_info ren env x in
- let te1 = trad ren e1 in
- let (_,ef1,p1,q1) = e1.info.kappa in
- let w1 = get_writes ef1 in
- let ren' = next ren w1 in
- let te2 = trad ren' e2 in
- let (_,ef2,p2,q2) = e2.info.kappa in
- let w2 = get_writes ef2 in
- let ren'' = next ren' w2 in
- let id1 = id_of_string "index" in
- let id2 = id_of_string "v" in
- let ren''' = next ren'' [x] in
- let t,ty = result_tuple ren''' (current_date ren) env
- (CC_expr (constant "tt"), constant "unit") (eft,qt) in
- let store = make_raw_store ren'' env (x,current_var ren'' x) (mkVar id1)
- (mkVar id2) in
- let t = make_let_in ren'' env (CC_expr store) [] ([],None)
- (current_var ren''' x,ty_array) (t,ty) in
- let t = make_let_in ren' env te2 p2
- (current_vars ren'' w2,q2) (id2,ty_elem) (t,ty) in
- let t =
- if check then
- let h = make_pre_access ren' env x (mkVar id1) in
- let_in_pre ty (anonymous_pre true h) t
- else
- t
- in
- make_let_in ren env te1 p1
- (current_vars ren' w1,q1) (id1,constant "Z") (t,ty)
-
- | Seq bl ->
- let before = current_date ren in
- let finish ren = function
- Some (id,ty) ->
- result_tuple ren before env (CC_var id, ty) (eft,qt)
- | None ->
- failwith "a block should contain at least one statement"
- in
- let bl = trad_block ren env bl in
- make_block ren env finish bl
-
- | If (b, e1, e2) ->
- let tb = trad ren b in
- let _,efb,_,_ = b.info.kappa in
- let ren' = next ren (get_writes efb) in
- let te1 = trad ren' e1 in
- let te2 = trad ren' e2 in
- make_if ren env (tb,b.info.kappa) ren' (te1,e1.info.kappa)
- (te2,e2.info.kappa) ct
-
- (* Translation of the while. *)
-
- | While (b, inv, var, bl) ->
- let ren' = next ren (get_writes eft) in
- let tb = trad ren' b in
- let tbl = trad_block ren' env bl in
- let var' = typed_var ren env var in
- make_while ren env var' (tb,b.info.kappa) tbl (inv,ct)
-
- | Lam (bl, e) ->
- let bl' = trad_binders ren env bl in
- let env' = traverse_binders env bl in
- let ren' = initial_renaming env' in
- let te = trans ren' e in
- CC_lam (bl', te)
-
- | SApp ([Variable id; Expression q1; Expression q2], [e1; e2])
- when id = connective_and or id = connective_or ->
- let c = constant (string_of_id id) in
- let te1 = trad ren e1
- and te2 = trad ren e2 in
- let q1' = apply_post ren env (current_date ren) (anonymous q1)
- and q2' = apply_post ren env (current_date ren) (anonymous q2) in
- CC_app (CC_expr c, [CC_expr q1'.a_value; CC_expr q2'.a_value; te1; te2])
-
- | SApp ([Variable id; Expression q], [e]) when id = connective_not ->
- let c = constant (string_of_id id) in
- let te = trad ren e in
- let q' = apply_post ren env (current_date ren) (anonymous q) in
- CC_app (CC_expr c, [CC_expr q'.a_value; te])
-
- | SApp _ ->
- invalid_arg "mlise.trad (SApp)"
-
- | Apply (f, args) ->
- let trad_arg (ren,args) = function
- | Term a ->
- let ((_,tya),efa,_,_) as ca = a.info.kappa in
- let ta = trad ren a in
- let w = get_writes efa in
- let ren' = next ren w in
- ren', ta::args
- | Refarg _ ->
- ren, args
- | Type v ->
- let c = trad_ml_type_v ren env v in
- ren, (CC_expr c)::args
- in
- let ren',targs = List.fold_left trad_arg (ren,[]) args in
- let tf = trad ren' f in
- let cf = f.info.kappa in
- let c,(s,_,_),capp = effect_app ren env f args in
- let tc_args =
- List.combine
- (List.rev targs)
- (Util.map_succeed
- (function
- | Term x -> x.info.kappa
- | Refarg _ -> failwith "caught"
- | Type _ ->
- (result_id,TypePure mkSet),Peffect.bottom,[],None)
- args)
- in
- make_app env ren tc_args ren' (tf,cf) (c,s,capp) ct
-
- | LetRef (x, e1, e2) ->
- let (_,v1),ef1,p1,q1 = e1.info.kappa in
- let te1 = trad ren e1 in
- let tv1 = trad_ml_type_v ren env v1 in
- let env' = add (x,Ref v1) env in
- let ren' = next ren [x] in
- let (_,v2),ef2,p2,q2 = e2.info.kappa in
- let tv2 = trad_ml_type_v ren' env' v2 in
- let te2 = trad ren' e2 in
- let ren'' = next ren' (get_writes ef2) in
- let t,ty = result_tuple ren'' (current_date ren) env
- (CC_var result_id, tv2) (eft,qt) in
- let t = make_let_in ren' env' te2 p2
- (current_vars ren'' (get_writes ef2),q2)
- (result_id,tv2) (t,ty) in
- let t = make_let_in ren env te1 p1
- (current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty)
- in
- t
-
- | Let (x, e1, e2) ->
- let (_,v1),ef1,p1,q1 = e1.info.kappa in
- let te1 = trad ren e1 in
- let tv1 = trad_ml_type_v ren env v1 in
- let env' = add (x,v1) env in
- let ren' = next ren (get_writes ef1) in
- let (_,v2),ef2,p2,q2 = e2.info.kappa in
- let tv2 = trad_ml_type_v ren' env' v2 in
- let te2 = trad ren' e2 in
- let ren'' = next ren' (get_writes ef2) in
- let t,ty = result_tuple ren'' (current_date ren) env
- (CC_var result_id, tv2) (eft,qt) in
- let t = make_let_in ren' env' te2 p2
- (current_vars ren'' (get_writes ef2),q2)
- (result_id,tv2) (t,ty) in
- let t = make_let_in ren env te1 p1
- (current_vars ren' (get_writes ef1),q1) (x,tv1) (t,ty)
- in
- t
-
- | LetRec (f,bl,v,var,e) ->
- let (_,ef,_,_) as c =
- match tt with Arrow(_,c) -> c | _ -> assert false in
- let bl' = trad_binders ren env bl in
- let env' = traverse_binders env bl in
- let ren' = initial_renaming env' in
- let (phi0,var') = find_recursion f e.info.env in
- let te = trad ren' e in
- let t = make_letrec ren' env' (phi0,var') f bl' (te,e.info.kappa) c in
- CC_lam (bl', t)
-
- | PPoint (s,d) ->
- let ren' = push_date ren s in
- trad_desc ren' env ct d
-
- | Debug _ -> failwith "Mlise.trad: Debug: not implemented"
-
-
-and trad_binders ren env = function
- | [] ->
- []
- | (_,BindType (Ref _ | Array _))::bl ->
- trad_binders ren env bl
- | (id,BindType v)::bl ->
- let tt = trad_ml_type_v ren env v in
- (id, CC_typed_binder tt) :: (trad_binders ren env bl)
- | (id,BindSet)::bl ->
- (id, CC_typed_binder mkSet) :: (trad_binders ren env bl)
- | (_,Untyped)::_ -> invalid_arg "trad_binders"
-
-
-and trad_block ren env = function
- | [] ->
- []
- | (Assert c)::block ->
- (Assert c)::(trad_block ren env block)
- | (Label s)::block ->
- let ren' = push_date ren s in
- (Label s)::(trad_block ren' env block)
- | (Statement e)::block ->
- let te = trad ren e in
- let _,efe,_,_ = e.info.kappa in
- let w = get_writes efe in
- let ren' = next ren w in
- (Statement (te,e.info.kappa))::(trad_block ren' env block)
-
-
-and trans ren e =
- let env = e.info.env in
- let _,ef,p,_ = e.info.kappa in
- let ty = trad_ml_type_c ren env e.info.kappa in
- let ids = get_reads ef in
- let al = current_vars ren ids in
- let c = trad ren e in
- let c = abs_pre ren env (c,ty) p in
- let bl = binding_of_alist ren env al in
- make_abs (List.rev bl) c
-
diff --git a/contrib/correctness/pmlize.mli b/contrib/correctness/pmlize.mli
deleted file mode 100644
index 1f8936f0..00000000
--- a/contrib/correctness/pmlize.mli
+++ /dev/null
@@ -1,20 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmlize.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Past
-open Penv
-open Names
-
-(* translation of imperative programs into intermediate functional programs *)
-
-val trans : Prename.t -> typed_program -> cc_term
-
diff --git a/contrib/correctness/pmonad.ml b/contrib/correctness/pmonad.ml
deleted file mode 100644
index 8f1b5946..00000000
--- a/contrib/correctness/pmonad.ml
+++ /dev/null
@@ -1,665 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmonad.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-open Util
-open Names
-open Term
-open Termast
-
-open Pmisc
-open Putil
-open Ptype
-open Past
-open Prename
-open Penv
-open Pcic
-open Peffect
-
-
-(* [product ren [y1,z1;...;yk,zk] q] constructs
- * the (possibly dependent) tuple type
- *
- * z1 x ... x zk if no post-condition
- * or \exists. y1:z1. ... yk:zk. (Q x1 ... xn) otherwise
- *
- * where the xi are given by the renaming [ren].
- *)
-
-let product_name = function
- | 2 -> "prod"
- | n -> check_product_n n; Printf.sprintf "tuple_%d" n
-
-let dep_product_name = function
- | 1 -> "sig"
- | n -> check_dep_product_n n; Printf.sprintf "sig_%d" n
-
-let product ren env before lo = function
- | None -> (* non dependent case *)
- begin match lo with
- | [_,v] -> v
- | _ ->
- let s = product_name (List.length lo) in
- Term.applist (constant s, List.map snd lo)
- end
- | Some q -> (* dependent case *)
- let s = dep_product_name (List.length lo) in
- let a' = apply_post ren env before q in
- Term.applist (constant s, (List.map snd lo) @ [a'.a_value])
-
-(* [arrow ren v pl] abstracts the term v over the pre-condition if any
- * i.e. computes
- *
- * (P1 x1 ... xn) -> ... -> (Pk x1 ... xn) -> v
- *
- * where the xi are given by the renaming [ren].
- *)
-
-let arrow ren env v pl =
- List.fold_left
- (fun t p ->
- if p.p_assert then t else Term.mkArrow (apply_pre ren env p).p_value t)
- v pl
-
-(* [abstract_post ren env (e,q) (res,v)] abstract a post-condition q
- * over the write-variables of e *)
-
-let rec abstract_post ren env (e,q) =
- let after_id id = id_of_string ((string_of_id id) ^ "'") in
- let (_,go) = Peffect.get_repr e in
- let al = List.map (fun id -> (id,after_id id)) go in
- let q = option_map (named_app (subst_in_constr al)) q in
- let tgo = List.map (fun (id,aid) -> (aid, trad_type_in_env ren env id)) al in
- option_map (named_app (abstract tgo)) q
-
-(* Translation of effects types in cic types.
- *
- * [trad_ml_type_v] and [trad_ml_type_c] translate types with effects
- * into cic types.
- *)
-
-and prod ren env g =
- List.map
- (fun id -> (current_var ren id, trad_type_in_env ren env id))
- g
-
-and input ren env e =
- let i,_ = Peffect.get_repr e in
- prod ren env i
-
-and output ren env ((id,v),e) =
- let tv = trad_ml_type_v ren env v in
- let _,o = Peffect.get_repr e in
- (prod ren env o) @ [id,tv]
-
-and input_output ren env c =
- let ((res,v),e,_,_) = c in
- input ren env e, output ren env ((res,v),e)
-
-(* The function t -> \barre{t} on V and C. *)
-
-and trad_ml_type_c ren env c =
- let ((res,v),e,p,q) = c in
- let q = abstract_post ren env (e,q) in
- let lo = output ren env ((res,v),e) in
- let ty = product ren env (current_date ren) lo q in
- let ty = arrow ren env ty p in
- let li = input ren env e in
- n_mkNamedProd ty li
-
-and trad_ml_type_v ren env = function
-
- | Ref _ | Array _ -> invalid_arg "Monad.trad_ml_type_v"
-
- | Arrow (bl, c) ->
- let bl',ren',env' =
- List.fold_left
- (fun (bl,ren,env) b -> match b with
- | (id,BindType ((Ref _ | Array _) as v)) ->
- let env' = add (id,v) env in
- let ren' = initial_renaming env' in
- (bl,ren',env')
- | (id,BindType v) ->
- let tt = trad_ml_type_v ren env v in
- let env' = add (id,v) env in
- let ren' = initial_renaming env' in
- (id,tt)::bl,ren',env'
- | (id, BindSet) ->
- (id,mkSet) :: bl,ren,env
- | _ -> failwith "Monad: trad_ml_type_v: not yet implemented"
- )
- ([],ren,env) bl
- in
- n_mkNamedProd (trad_ml_type_c ren' env' c) bl'
-
- | TypePure c ->
- (apply_pre ren env (anonymous_pre false c)).p_value
-
-and trad_imp_type ren env = function
- | Ref v -> trad_ml_type_v ren env v
- | Array (c,v) -> Term.applist (constant "array",
- [c; trad_ml_type_v ren env v])
- | _ -> invalid_arg "Monad.trad_imp_type"
-
-and trad_type_in_env ren env id =
- let v = type_in_env env id in trad_imp_type ren env v
-
-
-
-(* bindings *)
-
-let binding_of_alist ren env al =
- List.map
- (fun (id,id') -> (id', CC_typed_binder (trad_type_in_env ren env id)))
- al
-
-
-(* [make_abs bl t p] abstracts t w.r.t binding list bl., that is
- * [x1:t1]...[xn:tn]t. Returns t if the binding is empty. *)
-
-let make_abs bl t = match bl with
- | [] -> t
- | _ -> CC_lam (bl, t)
-
-
-(* [result_tuple ren before env (res,v) (ef,q)] constructs the tuple
- *
- * (y1,...,yn,res,?::(q/ren y1 ... yn res))
- *
- * where the yi are the values of the output of ef.
- * if there is no yi and no post-condition, it is simplified in res itself.
- *)
-
-let simple_constr_of_prog = function
- | CC_expr c -> c
- | CC_var id -> mkVar id
- | _ -> assert false
-
-let make_tuple l q ren env before = match l with
- | [e,_] when q = None ->
- e
- | _ ->
- let tl = List.map snd l in
- let dep,h,th = match q with
- | None -> false,[],[]
- | Some c ->
- let args = List.map (fun (e,_) -> simple_constr_of_prog e) l in
- let c = apply_post ren env before c in
- true,
- [ CC_hole (Term.applist (c.a_value, args)) ], (* hole *)
- [ c.a_value ] (* type of the hole *)
- in
- CC_tuple (dep, tl @ th, (List.map fst l) @ h)
-
-let result_tuple ren before env (res,v) (ef,q) =
- let ids = get_writes ef in
- let lo =
- (List.map (fun id ->
- let id' = current_var ren id in
- CC_var id', trad_type_in_env ren env id) ids)
- @ [res,v]
- in
- let q = abstract_post ren env (ef,q) in
- make_tuple lo q ren env before,
- product ren env before lo q
-
-
-(* [make_let_in ren env fe p (vo,q) (res,v) t] constructs the term
-
- [ let h1 = ?:P1 in ... let hn = ?:Pm in ]
- let y1,y2,...,yn, res [,q] = fe in
- t
-
- vo=[_,y1;...;_,ym] are list of renamings.
- v is the type of res
- *)
-
-let let_in_pre ty p t =
- let h = p.p_value in
- CC_letin (false, ty, [pre_name p.p_name,CC_typed_binder h], CC_hole h, t)
-
-let multiple_let_in_pre ty hl t =
- List.fold_left (fun t h -> let_in_pre ty h t) t hl
-
-let make_let_in ren env fe p (vo,q) (res,tyres) (t,ty) =
- let b = [res, CC_typed_binder tyres] in
- let b',dep = match q with
- | None -> [],false
- | Some q -> [post_name q.a_name, CC_untyped_binder],true
- in
- let bl = (binding_of_alist ren env vo) @ b @ b' in
- let tyapp =
- let n = succ (List.length vo) in
- let name = match q with None -> product_name n | _ -> dep_product_name n in
- constant name
- in
- let t = CC_letin (dep, ty, bl, fe, t) in
- multiple_let_in_pre ty (List.map (apply_pre ren env) p) t
-
-
-(* [abs_pre ren env (t,ty) pl] abstracts a term t with respect to the
- * list of pre-conditions [pl]. Some of them are real pre-conditions
- * and others are assertions, according to the boolean field p_assert,
- * so we construct the term
- * [h1:P1]...[hn:Pn]let h'1 = ?:P'1 in ... let H'm = ?:P'm in t
- *)
-
-let abs_pre ren env (t,ty) pl =
- List.fold_left
- (fun t p ->
- if p.p_assert then
- let_in_pre ty (apply_pre ren env p) t
- else
- let h = pre_name p.p_name in
- CC_lam ([h,CC_typed_binder (apply_pre ren env p).p_value],t))
- t pl
-
-
-(* [make_block ren env finish bl] builds the translation of a block
- * finish is the function that is applied to the result at the end of the
- * block. *)
-
-let make_block ren env finish bl =
- let rec rec_block ren result = function
- | [] ->
- finish ren result
- | (Assert c) :: block ->
- let t,ty = rec_block ren result block in
- let c = apply_assert ren env c in
- let p = { p_assert = true; p_name = c.a_name; p_value = c.a_value } in
- let_in_pre ty p t, ty
- | (Label s) :: block ->
- let ren' = push_date ren s in
- rec_block ren' result block
- | (Statement (te,info)) :: block ->
- let (_,tye),efe,pe,qe = info in
- let w = get_writes efe in
- let ren' = next ren w in
- let id = result_id in
- let tye = trad_ml_type_v ren env tye in
- let t = rec_block ren' (Some (id,tye)) block in
- make_let_in ren env te pe (current_vars ren' w,qe) (id,tye) t,
- snd t
- in
- let t,_ = rec_block ren None bl in
- t
-
-
-(* [make_app env ren args ren' (tf,cf) (cb,s,capp) c]
- * constructs the application of [tf] to [args].
- * capp is the effect of application, after substitution (s) and cb before
- *)
-
-let eq ty e1 e2 =
- Term.applist (constant "eq", [ty; e1; e2])
-
-let lt r e1 e2 =
- Term.applist (r, [e1; e2])
-
-let is_recursive env = function
- | CC_var x ->
- (try let _ = find_recursion x env in true with Not_found -> false)
- | _ -> false
-
-let if_recursion env f = function
- | CC_var x ->
- (try let v = find_recursion x env in (f v x) with Not_found -> [])
- | _ -> []
-
-let dec_phi ren env s svi =
- if_recursion env
- (fun (phi0,(cphi,r,_)) f ->
- let phi = subst_in_constr svi (subst_in_constr s cphi) in
- let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in
- [CC_expr phi; CC_hole (lt r phi (mkVar phi0))])
-
-let eq_phi ren env s svi =
- if_recursion env
- (fun (phi0,(cphi,_,a)) f ->
- let phi = subst_in_constr svi (subst_in_constr s cphi) in
- let phi = (apply_pre ren env (anonymous_pre true phi)).p_value in
- [CC_hole (eq a phi phi)])
-
-let is_ref_binder = function
- | (_,BindType (Ref _ | Array _)) -> true
- | _ -> false
-
-let make_app env ren args ren' (tf,cf) ((bl,cb),s,capp) c =
- let ((_,tvf),ef,pf,qf) = cf in
- let (_,eapp,papp,qapp) = capp in
- let ((_,v),e,p,q) = c in
- let bl = List.filter (fun b -> not (is_ref_binder b)) bl in
- let recur = is_recursive env tf in
- let before = current_date ren in
- let ren'' = next ren' (get_writes ef) in
- let ren''' = next ren'' (get_writes eapp) in
- let res = result_id in
- let vi,svi =
- let ids = List.map fst bl in
- let s = fresh (avoid ren ids) ids in
- List.map snd s, s
- in
- let tyres = subst_in_constr svi (trad_ml_type_v ren env v) in
- let t,ty = result_tuple ren''' before env (CC_var res, tyres) (e,q) in
- let res_f = id_of_string "vf" in
- let inf,outf =
- let i,o = let _,e,_,_ = cb in get_reads e, get_writes e in
- let apply_s = List.map (fun id -> try List.assoc id s with _ -> id) in
- apply_s i, apply_s o
- in
- let fe =
- let xi = List.rev (List.map snd (current_vars ren'' inf)) in
- let holes = List.map (fun x -> (apply_pre ren'' env x).p_value)
- (List.map (pre_app (subst_in_constr svi)) papp) in
- CC_app ((if recur then tf else CC_var res_f),
- (dec_phi ren'' env s svi tf)
- @(List.map (fun id -> CC_var id) (vi @ xi))
- @(eq_phi ren'' env s svi tf)
- @(List.map (fun c -> CC_hole c) holes))
- in
- let qapp' = option_map (named_app (subst_in_constr svi)) qapp in
- let t =
- make_let_in ren'' env fe [] (current_vars ren''' outf,qapp')
- (res,tyres) (t,ty)
- in
- let t =
- if recur then
- t
- else
- make_let_in ren' env tf pf
- (current_vars ren'' (get_writes ef),qf)
- (res_f,trad_ml_type_v ren env tvf) (t,ty)
- in
- let rec eval_args ren = function
- | [] -> t
- | (vx,(ta,((_,tva),ea,pa,qa)))::args ->
- let w = get_writes ea in
- let ren' = next ren w in
- let t' = eval_args ren' args in
- make_let_in ren env ta pa (current_vars ren' (get_writes ea),qa)
- (vx,trad_ml_type_v ren env tva) (t',ty)
- in
- eval_args ren (List.combine vi args)
-
-
-(* [make_if ren env (tb,cb) ren' (t1,c1) (t2,c2)]
- * constructs the term corresponding to a if expression, i.e
- *
- * [p] let o1, b [,q1] = m1 [?::p1] in
- * Cases b of
- * R => let o2, v2 [,q2] = t1 [?::p2] in
- * (proj (o1,o2)), v2 [,?::q]
- * | S => let o2, v2 [,q2] = t2 [?::p2] in
- * (proj (o1,o2)), v2 [,?::q]
- *)
-
-let make_if_case ren env ty (b,qb) (br1,br2) =
- let id_b,ty',ty1,ty2 = match qb with
- | Some q ->
- let q = apply_post ren env (current_date ren) q in
- let (name,t1,t2) = Term.destLambda q.a_value in
- q.a_name,
- Term.mkLambda (name, t1, mkArrow t2 ty),
- Term.mkApp (q.a_value, [| coq_true |]),
- Term.mkApp (q.a_value, [| coq_false |])
- | None -> assert false
- in
- let n = test_name Anonymous in
- CC_app (CC_case (ty', b, [CC_lam ([n,CC_typed_binder ty1], br1);
- CC_lam ([n,CC_typed_binder ty2], br2)]),
- [CC_var (post_name id_b)])
-
-let make_if ren env (tb,cb) ren' (t1,c1) (t2,c2) c =
- let ((_,tvb),eb,pb,qb) = cb in
- let ((_,tv1),e1,p1,q1) = c1 in
- let ((_,tv2),e2,p2,q2) = c2 in
- let ((_,t),e,p,q) = c in
-
- let wb = get_writes eb in
- let resb = id_of_string "resultb" in
- let res = result_id in
- let tyb = trad_ml_type_v ren' env tvb in
- let tt = trad_ml_type_v ren env t in
-
- (* une branche de if *)
- let branch (tv_br,e_br,p_br,q_br) f_br =
- let w_br = get_writes e_br in
- let ren'' = next ren' w_br in
- let t,ty = result_tuple ren'' (current_date ren') env
- (CC_var res,tt) (e,q) in
- make_let_in ren' env f_br p_br (current_vars ren'' w_br,q_br)
- (res,tt) (t,ty),
- ty
- in
- let t1,ty1 = branch c1 t1 in
- let t2,ty2 = branch c2 t2 in
- let ty = ty1 in
- let qb = force_bool_name qb in
- let t = make_if_case ren env ty (CC_var resb,qb) (t1,t2) in
- make_let_in ren env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty)
-
-
-(* [make_while ren env (cphi,r,a) (tb,cb) (te,ce) c]
- * constructs the term corresponding to the while, i.e.
- *
- * [h:(I x)](well_founded_induction
- * A R ?::(well_founded A R)
- * [Phi:A] (x) Phi=phi(x)->(I x)-> \exists x'.res.(I x')/\(S x')
- * [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...]
- * [x][eq:Phi_0=phi(x)][h:(I x)]
- * Cases (b x) of
- * (left HH) => (x,?::(IS x))
- * | (right HH) => let x1,_,_ = (e x ?) in
- * (w phi(x1) ? x1 ? ?)
- * phi(x) x ? ?)
- *)
-
-let id_phi = id_of_string "phi"
-let id_phi0 = id_of_string "phi0"
-
-let make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c) =
- let ((_,tvb),eb,pb,qb) = cb in
- let (_,ef,_,is) = c in
-
- let ren' = next ren (get_writes ef) in
- let before = current_date ren in
-
- let ty =
- let is = abstract_post ren' env (ef,is) in
- let _,lo = input_output ren env c in
- product ren env before lo is
- in
- let resb = id_of_string "resultb" in
- let tyb = trad_ml_type_v ren' env tvb in
- let wb = get_writes eb in
-
- (* première branche: le test est vrai => e;w *)
- let t1 =
- make_block ren' env
- (fun ren'' result -> match result with
- | Some (id,_) ->
- let v = List.rev (current_vars ren'' (get_writes ef)) in
- CC_app (CC_var id_w,
- [CC_expr (phi_of ren'');
- CC_hole (lt r (phi_of ren'') (mkVar id_phi0))]
- @(List.map (fun (_,id) -> CC_var id) v)
- @(CC_hole (eq a (phi_of ren'') (phi_of ren'')))
- ::(match i with
- | None -> []
- | Some c ->
- [CC_hole (apply_assert ren'' env c).a_value])),
- ty
- | None -> failwith "a block should contain at least one statement")
- tbl
- in
-
- (* deuxième branche: le test est faux => on sort de la boucle *)
- let t2,_ =
- result_tuple ren' before env
- (CC_expr (constant "tt"),constant "unit") (ef,is)
- in
-
- let b_al = current_vars ren' (get_reads eb) in
- let qb = force_bool_name qb in
- let t = make_if_case ren' env ty (CC_var resb,qb) (t1,t2) in
- let t =
- make_let_in ren' env tb pb (current_vars ren' wb,qb) (resb,tyb) (t,ty)
- in
- let t =
- let pl = List.map (pre_of_assert false) (list_of_some i) in
- abs_pre ren' env (t,ty) pl
- in
- let t =
- CC_lam ([var_name Anonymous,
- CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren'))],t)
- in
- let bl = binding_of_alist ren env (current_vars ren' (get_writes ef)) in
- make_abs (List.rev bl) t
-
-
-let make_while ren env (cphi,r,a) (tb,cb) tbl (i,c) =
- let (_,ef,_,is) = c in
- let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in
- let wf_a_r = Term.applist (constant "well_founded", [a; r]) in
-
- let before = current_date ren in
- let ren' = next ren (get_writes ef) in
- let al = current_vars ren' (get_writes ef) in
- let v =
- let _,lo = input_output ren env c in
- let is = abstract_post ren' env (ef,is) in
- match i with
- | None -> product ren' env before lo is
- | Some ci ->
- Term.mkArrow (apply_assert ren' env ci).a_value
- (product ren' env before lo is)
- in
- let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren')) v in
- let v =
- n_mkNamedProd v
- (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al)
- in
- let tw =
- Term.mkNamedProd id_phi a
- (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v)
- in
- let id_w = id_of_string "loop" in
- let vars = List.rev (current_vars ren (get_writes ef)) in
- let body =
- make_body_while ren env phi_of a r id_phi0 id_w (tb,cb) tbl (i,c)
- in
- CC_app (CC_expr (constant "well_founded_induction"),
- [CC_expr a; CC_expr r;
- CC_hole wf_a_r;
- CC_expr (Term.mkNamedLambda id_phi a v);
- CC_lam ([id_phi0, CC_typed_binder a;
- id_w, CC_typed_binder tw],
- body);
- CC_expr (phi_of ren)]
- @(List.map (fun (_,id) -> CC_var id) vars)
- @(CC_hole (eq a (phi_of ren) (phi_of ren)))
- ::(match i with
- | None -> []
- | Some c -> [CC_hole (apply_assert ren env c).a_value]))
-
-
-(* [make_letrec ren env (phi0,(cphi,r,a)) bl (te,ce) c]
- * constructs the term corresponding to the let rec i.e.
- *
- * [x][h:P(x)](well_founded_induction
- * A R ?::(well_founded A R)
- * [Phi:A] (bl) (x) Phi=phi(x)->(P x)-> \exists x'.res.(Q x x')
- * [Phi_0:A][w:(Phi:A)(Phi<Phi_0)-> ...]
- * [bl][x][eq:Phi_0=phi(x)][h:(P x)]te
- * phi(x) bl x ? ?)
- *)
-
-let make_letrec ren env (id_phi0,(cphi,r,a)) idf bl (te,ce) c =
- let (_,ef,p,q) = c in
- let phi_of ren = (apply_pre ren env (anonymous_pre true cphi)).p_value in
- let wf_a_r = Term.applist (constant "well_founded", [a; r]) in
-
- let before = current_date ren in
- let al = current_vars ren (get_reads ef) in
- let v =
- let _,lo = input_output ren env c in
- let q = abstract_post ren env (ef,q) in
- arrow ren env (product ren env (current_date ren) lo q) p
- in
- let v = Term.mkArrow (eq a (mkVar id_phi) (phi_of ren)) v in
- let v =
- n_mkNamedProd v
- (List.map (fun (id,id') -> (id',trad_type_in_env ren env id)) al)
- in
- let v =
- n_mkNamedProd v
- (List.map (function (id,CC_typed_binder c) -> (id,c)
- | _ -> assert false) (List.rev bl))
- in
- let tw =
- Term.mkNamedProd id_phi a
- (Term.mkArrow (lt r (mkVar id_phi) (mkVar id_phi0)) v)
- in
- let vars = List.rev (current_vars ren (get_reads ef)) in
- let body =
- let al = current_vars ren (get_reads ef) in
- let bod = abs_pre ren env (te,v) p in
- let bod = CC_lam ([var_name Anonymous,
- CC_typed_binder (eq a (mkVar id_phi0) (phi_of ren))],
- bod)
- in
- let bl' = binding_of_alist ren env al in
- make_abs (bl@(List.rev bl')) bod
- in
- let t =
- CC_app (CC_expr (constant "well_founded_induction"),
- [CC_expr a; CC_expr r;
- CC_hole wf_a_r;
- CC_expr (Term.mkNamedLambda id_phi a v);
- CC_lam ([id_phi0, CC_typed_binder a;
- idf, CC_typed_binder tw],
- body);
- CC_expr (phi_of ren)]
- @(List.map (fun (id,_) -> CC_var id) bl)
- @(List.map (fun (_,id) -> CC_var id) vars)
- @[CC_hole (eq a (phi_of ren) (phi_of ren))]
- )
- in
- (* on abstrait juste par rapport aux variables de ef *)
- let al = current_vars ren (get_reads ef) in
- let bl = binding_of_alist ren env al in
- make_abs (List.rev bl) t
-
-
-(* [make_access env id c] Access in array id.
- *
- * Constructs [t:(array s T)](access_g s T t c ?::(lt c s)).
- *)
-
-let array_info ren env id =
- let ty = type_in_env env id in
- let size,v = dearray_type ty in
- let ty_elem = trad_ml_type_v ren env v in
- let ty_array = trad_imp_type ren env ty in
- size,ty_elem,ty_array
-
-let make_raw_access ren env (id,id') c =
- let size,ty_elem,_ = array_info ren env id in
- Term.applist (constant "access", [size; ty_elem; mkVar id'; c])
-
-let make_pre_access ren env id c =
- let size,_,_ = array_info ren env id in
- conj (lt (constant "Zle") (constant "ZERO") c)
- (lt (constant "Zlt") c size)
-
-let make_raw_store ren env (id,id') c1 c2 =
- let size,ty_elem,_ = array_info ren env id in
- Term.applist (constant "store", [size; ty_elem; mkVar id'; c1; c2])
diff --git a/contrib/correctness/pmonad.mli b/contrib/correctness/pmonad.mli
deleted file mode 100644
index a46a040e..00000000
--- a/contrib/correctness/pmonad.mli
+++ /dev/null
@@ -1,106 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pmonad.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-
-open Ptype
-open Past
-open Penv
-
-(* Main part of the translation of imperative programs into functional ones
- * (with mlise.ml) *)
-
-(* Here we translate the specification into a CIC specification *)
-
-val trad_ml_type_v : Prename.t -> local_env -> type_v -> constr
-val trad_ml_type_c : Prename.t -> local_env -> type_c -> constr
-val trad_imp_type : Prename.t -> local_env -> type_v -> constr
-val trad_type_in_env : Prename.t -> local_env -> identifier -> constr
-
-val binding_of_alist : Prename.t -> local_env
- -> (identifier * identifier) list
- -> cc_binder list
-val make_abs : cc_binder list -> cc_term -> cc_term
-val abs_pre : Prename.t -> local_env -> cc_term * constr ->
- constr precondition list -> cc_term
-
-(* The following functions translate the main constructions *)
-
-val make_tuple : (cc_term * cc_type) list -> predicate option
- -> Prename.t -> local_env -> string
- -> cc_term
-
-val result_tuple : Prename.t -> string -> local_env
- -> (cc_term * constr) -> (Peffect.t * predicate option)
- -> cc_term * constr
-
-val let_in_pre : constr -> constr precondition -> cc_term -> cc_term
-
-val make_let_in : Prename.t -> local_env -> cc_term
- -> constr precondition list
- -> ((identifier * identifier) list * predicate option)
- -> identifier * constr
- -> cc_term * constr -> cc_term
-
-val make_block : Prename.t -> local_env
- -> (Prename.t -> (identifier * constr) option -> cc_term * constr)
- -> (cc_term * type_c, constr) block
- -> cc_term
-
-val make_app : local_env
- -> Prename.t -> (cc_term * type_c) list
- -> Prename.t -> cc_term * type_c
- -> ((type_v binder list) * type_c)
- * ((identifier*identifier) list)
- * type_c
- -> type_c
- -> cc_term
-
-val make_if : Prename.t -> local_env
- -> cc_term * type_c
- -> Prename.t
- -> cc_term * type_c
- -> cc_term * type_c
- -> type_c
- -> cc_term
-
-val make_while : Prename.t -> local_env
- -> (constr * constr * constr) (* typed variant *)
- -> cc_term * type_c
- -> (cc_term * type_c, constr) block
- -> constr assertion option * type_c
- -> cc_term
-
-val make_letrec : Prename.t -> local_env
- -> (identifier * (constr * constr * constr)) (* typed variant *)
- -> identifier (* the name of the function *)
- -> (cc_binder list)
- -> (cc_term * type_c)
- -> type_c
- -> cc_term
-
-(* Functions to translate array operations *)
-
-val array_info :
- Prename.t -> local_env -> identifier -> constr * constr * constr
-
-val make_raw_access :
- Prename.t -> local_env -> identifier * identifier -> constr -> constr
-
-val make_raw_store :
- Prename.t -> local_env -> identifier * identifier
- -> constr -> constr -> constr
-
-val make_pre_access :
- Prename.t -> local_env -> identifier -> constr -> constr
-
diff --git a/contrib/correctness/pred.ml b/contrib/correctness/pred.ml
deleted file mode 100644
index 669727fc..00000000
--- a/contrib/correctness/pred.ml
+++ /dev/null
@@ -1,115 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pred.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Past
-open Pmisc
-
-let rec cc_subst subst = function
- | CC_var id as c ->
- (try CC_expr (List.assoc id subst) with Not_found -> c)
- | CC_letin (b,ty,bl,c1,c2) ->
- CC_letin (b, real_subst_in_constr subst ty, cc_subst_binders subst bl,
- cc_subst subst c1, cc_subst (cc_cross_binders subst bl) c2)
- | CC_lam (bl, c) ->
- CC_lam (cc_subst_binders subst bl,
- cc_subst (cc_cross_binders subst bl) c)
- | CC_app (c, cl) ->
- CC_app (cc_subst subst c, List.map (cc_subst subst) cl)
- | CC_tuple (b, tl, cl) ->
- CC_tuple (b, List.map (real_subst_in_constr subst) tl,
- List.map (cc_subst subst) cl)
- | CC_case (ty, c, cl) ->
- CC_case (real_subst_in_constr subst ty, cc_subst subst c,
- List.map (cc_subst subst) cl)
- | CC_expr c ->
- CC_expr (real_subst_in_constr subst c)
- | CC_hole ty ->
- CC_hole (real_subst_in_constr subst ty)
-
-and cc_subst_binders subst = List.map (cc_subst_binder subst)
-
-and cc_subst_binder subst = function
- | id,CC_typed_binder c -> id,CC_typed_binder (real_subst_in_constr subst c)
- | b -> b
-
-and cc_cross_binders subst = function
- | [] -> subst
- | (id,_) :: bl -> cc_cross_binders (List.remove_assoc id subst) bl
-
-(* here we only perform eta-reductions on programs to eliminate
- * redexes of the kind
- *
- * let (x1,...,xn) = e in (x1,...,xn) --> e
- *
- *)
-
-let is_eta_redex bl al =
- try
- List.for_all2
- (fun (id,_) t -> match t with CC_var id' -> id=id' | _ -> false)
- bl al
- with
- Invalid_argument("List.for_all2") -> false
-
-let rec red = function
- | CC_letin (_, _, [id,_], CC_expr c1, e2) ->
- red (cc_subst [id,c1] e2)
- | CC_letin (dep, ty, bl, e1, e2) ->
- begin match red e2 with
- | CC_tuple (false,tl,al) ->
- if is_eta_redex bl al then
- red e1
- else
- CC_letin (dep, ty, bl, red e1,
- CC_tuple (false,tl,List.map red al))
- | e -> CC_letin (dep, ty, bl, red e1, e)
- end
- | CC_lam (bl, e) ->
- CC_lam (bl, red e)
- | CC_app (e, al) ->
- CC_app (red e, List.map red al)
- | CC_case (ty, e1, el) ->
- CC_case (ty, red e1, List.map red el)
- | CC_tuple (dep, tl, al) ->
- CC_tuple (dep, tl, List.map red al)
- | e -> e
-
-
-(* How to reduce uncomplete proof terms when they have become constr *)
-
-open Term
-open Reductionops
-
-(* Il ne faut pas reduire de redexe (beta/iota) qui impliquerait
- * la substitution d'une métavariable.
- *
- * On commence par rendre toutes les applications binaire (strong bin_app)
- * puis on applique la reduction spéciale programmes définie dans
- * typing/reduction *)
-
-(*i
-let bin_app = function
- | DOPN(AppL,v) as c ->
- (match Array.length v with
- | 1 -> v.(0)
- | 2 -> c
- | n ->
- let f = DOPN(AppL,Array.sub v 0 (pred n)) in
- DOPN(AppL,[|f;v.(pred n)|]))
- | c -> c
-i*)
-
-let red_cci c =
- (*i let c = strong bin_app c in i*)
- strong whd_programs (Global.env ()) Evd.empty c
-
diff --git a/contrib/correctness/pred.mli b/contrib/correctness/pred.mli
deleted file mode 100644
index a5a9549b..00000000
--- a/contrib/correctness/pred.mli
+++ /dev/null
@@ -1,26 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pred.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Term
-open Past
-
-(* reduction on intermediate programs
- * get rid of redexes of the kind let (x1,...,xn) = e in (x1,...,xn) *)
-
-val red : cc_term -> cc_term
-
-
-(* Ad-hoc reduction on partial proof terms *)
-
-val red_cci : constr -> constr
-
-
diff --git a/contrib/correctness/prename.ml b/contrib/correctness/prename.ml
deleted file mode 100644
index 4ef1982d..00000000
--- a/contrib/correctness/prename.ml
+++ /dev/null
@@ -1,139 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: prename.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Nameops
-open Util
-open Pp
-open Himsg
-open Pmisc
-
-(* Variables names management *)
-
-type date = string
-
-(* The following data structure keeps the successive names of the variables
- * as we traverse the program. A each step a ``date'' and a
- * collection of new names is (possibly) given, and updates the
- * previous renaming.
- *
- * Then, we can ask for the name of a variable, at current date or
- * at a given date.
- *
- * It is easily represented by a list of date x assoc list, most recent coming
- * first i.e. as follows:
- *
- * [ date (= current), [ (x,xi); ... ];
- * date , [ (z,zk); ... ];
- * ...
- * date (= initial), [ (x,xj); (y,yi); ... ]
- *
- * We also keep a list of all names already introduced, in order to
- * quickly get fresh names.
- *)
-
-type t =
- { levels : (date * (identifier * identifier) list) list;
- avoid : identifier list;
- cpt : int }
-
-
-let empty_ren = { levels = []; avoid = []; cpt = 0 }
-
-let update r d ids =
- let al,av = renaming_of_ids r.avoid ids in
- { levels = (d,al) :: r.levels; avoid = av; cpt = r.cpt }
-
-let push_date r d = update r d []
-
-let next r ids =
- let al,av = renaming_of_ids r.avoid ids in
- let n = succ r.cpt in
- let d = string_of_int n in
- { levels = (d,al) :: r.levels; avoid = av; cpt = n }
-
-
-let find r x =
- let rec find_in_one = function
- [] -> raise Not_found
- | (y,v)::rem -> if y = x then v else find_in_one rem
- in
- let rec find_in_all = function
- [] -> raise Not_found
- | (_,l)::rem -> try find_in_one l with Not_found -> find_in_all rem
- in
- find_in_all r.levels
-
-
-let current_var = find
-
-let current_vars r ids = List.map (fun id -> id,current_var r id) ids
-
-
-let avoid r ids = { levels = r.levels; avoid = r.avoid @ ids; cpt = r.cpt }
-
-let fresh r ids = fst (renaming_of_ids r.avoid ids)
-
-
-let current_date r =
- match r.levels with
- [] -> invalid_arg "Renamings.current_date"
- | (d,_)::_ -> d
-
-let all_dates r = List.map fst r.levels
-
-let rec valid_date da r =
- let rec valid = function
- [] -> false
- | (d,_)::rem -> (d=da) or (valid rem)
- in
- valid r.levels
-
-(* [until d r] selects the part of the renaming [r] starting from date [d] *)
-let rec until da r =
- let rec cut = function
- [] -> invalid_arg "Renamings.until"
- | (d,_)::rem as r -> if d=da then r else cut rem
- in
- { avoid = r.avoid; levels = cut r.levels; cpt = r.cpt }
-
-let var_at_date r d id =
- try
- find (until d r) id
- with Not_found ->
- raise (UserError ("Renamings.var_at_date",
- hov 0 (str"Variable " ++ pr_id id ++ str" is unknown" ++ spc () ++
- str"at date " ++ str d)))
-
-let vars_at_date r d ids =
- let r' = until d r in List.map (fun id -> id,find r' id) ids
-
-
-(* pretty-printers *)
-
-open Pp
-open Util
-open Himsg
-
-let pp r =
- hov 2 (prlist_with_sep (fun () -> (fnl ()))
- (fun (d,l) ->
- (str d ++ str": " ++
- prlist_with_sep (fun () -> (spc ()))
- (fun (id,id') ->
- (str"(" ++ pr_id id ++ str"," ++ pr_id id' ++ str")"))
- l))
- r.levels)
-
-let ppr e =
- Pp.pp (pp e)
-
diff --git a/contrib/correctness/prename.mli b/contrib/correctness/prename.mli
deleted file mode 100644
index 1d3ab669..00000000
--- a/contrib/correctness/prename.mli
+++ /dev/null
@@ -1,57 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: prename.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-
-(* Abstract type for renamings
- *
- * Records the names of the mutables objets (ref, arrays) at the different
- * moments of the evaluation, called dates
- *)
-
-type t
-
-type date = string
-
-
-val empty_ren : t
-val update : t -> date -> identifier list -> t
- (* assign new names for the given variables, associated to a new date *)
-val next : t -> identifier list -> t
- (* assign new names for the given variables, associated to a new
- * date which is generated from an internal counter *)
-val push_date : t -> date -> t
- (* put a new date on top of the stack *)
-
-val valid_date : date -> t -> bool
-val current_date : t -> date
-val all_dates : t -> date list
-
-val current_var : t -> identifier -> identifier
-val current_vars : t -> identifier list -> (identifier * identifier) list
- (* gives the current names of some variables *)
-
-val avoid : t -> identifier list -> t
-val fresh : t -> identifier list -> (identifier * identifier) list
- (* introduces new names to avoid and renames some given variables *)
-
-val var_at_date : t -> date -> identifier -> identifier
- (* gives the name of a variable at a given date *)
-val vars_at_date : t -> date -> identifier list
- -> (identifier * identifier) list
- (* idem for a list of variables *)
-
-(* pretty-printers *)
-
-val pp : t -> Pp.std_ppcmds
-val ppr : t -> unit
-
diff --git a/contrib/correctness/psyntax.ml4 b/contrib/correctness/psyntax.ml4
deleted file mode 100644
index 98d43112..00000000
--- a/contrib/correctness/psyntax.ml4
+++ /dev/null
@@ -1,1058 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: psyntax.ml4 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-open Options
-open Util
-open Names
-open Nameops
-open Vernacentries
-open Reduction
-open Term
-open Libnames
-open Topconstr
-
-open Prename
-open Pmisc
-open Putil
-open Ptype
-open Past
-open Penv
-open Pmonad
-open Vernacexpr
-
-
-(* We define new entries for programs, with the use of this module
- * Programs. These entries are named Programs.<foo>
- *)
-
-module Gram = Pcoq.Gram
-module Constr = Pcoq.Constr
-module Tactic = Pcoq.Tactic
-
-module Programs =
- struct
- let gec s = Gram.Entry.create ("Programs."^s)
- (* types *)
- let type_v = gec "type_v"
- let type_v0 = gec "type_v0"
- let type_v1 = gec "type_v1"
- let type_v2 = gec "type_v2"
- let type_v3 = gec "type_v3"
- let type_v_app = gec "type_v_app"
- let type_c = gec "type_c"
- let effects = gec "effects"
- let reads = gec "reads"
- let writes = gec "writes"
- let pre_condition = gec "pre_condition"
- let post_condition = gec "post_condition"
- (* binders *)
- let binder = gec "binder"
- let binder_type = gec "binder_type"
- let binders = gec "binders"
- (* programs *)
- let program = gec "program"
- let prog1 = gec "prog1"
- let prog2 = gec "prog2"
- let prog3 = gec "prog3"
- let prog4 = gec "prog4"
- let prog5 = gec "prog5"
- let prog6 = gec "prog6"
- let prog7 = gec "prog7"
- let ast1 = gec "ast1"
- let ast2 = gec "ast2"
- let ast3 = gec "ast3"
- let ast4 = gec "ast4"
- let ast5 = gec "ast5"
- let ast6 = gec "ast6"
- let ast7 = gec "ast7"
- let arg = gec "arg"
- let block = gec "block"
- let block_statement = gec "block_statement"
- let relation = gec "relation"
- let variable = gec "variable"
- let invariant = gec "invariant"
- let variant = gec "variant"
- let assertion = gec "assertion"
- let precondition = gec "precondition"
- let postcondition = gec "postcondition"
- let predicate = gec "predicate"
- let name = gec "name"
- end
-
-open Programs
-
-let ast_of_int n =
- CDelimiters
- (dummy_loc, "Z", CNumeral (dummy_loc, Bignat.POS (Bignat.of_string n)))
-
-let constr_of_int n =
- Constrintern.interp_constr Evd.empty (Global.env ()) (ast_of_int n)
-
-open Util
-open Coqast
-
-let mk_id loc id = mkRefC (Ident (loc, id))
-let mk_ref loc s = mk_id loc (Constrextern.id_of_v7_string s)
-let mk_appl loc1 loc2 f args =
- CApp (join_loc loc1 loc2, (None,mk_ref loc1 f), List.map (fun a -> a,None) args)
-
-let conj_assert {a_name=n;a_value=a} {a_value=b} =
- let loc1 = constr_loc a in
- let loc2 = constr_loc a in
- { a_value = mk_appl loc1 loc2 "and" [a;b]; a_name = n }
-
-let conj = function
- None,None -> None
- | None,b -> b
- | a,None -> a
- | Some a,Some b -> Some (conj_assert a b)
-
-let without_effect loc d =
- { desc = d; pre = []; post = None; loc = loc; info = () }
-
-let isevar = Expression isevar
-
-let bin_op op loc e1 e2 =
- without_effect loc
- (Apply (without_effect loc (Expression (constant op)),
- [ Term e1; Term e2 ]))
-
-let un_op op loc e =
- without_effect loc
- (Apply (without_effect loc (Expression (constant op)), [Term e]))
-
-let bool_bin op loc a1 a2 =
- let w = without_effect loc in
- let d = SApp ( [Variable op], [a1; a2]) in
- w d
-
-let bool_or loc = bool_bin connective_or loc
-let bool_and loc = bool_bin connective_and loc
-
-let bool_not loc a =
- let w = without_effect loc in
- let d = SApp ( [Variable connective_not ], [a]) in
- w d
-
-let ast_zwf_zero loc = mk_appl loc loc "Zwf" [mk_ref loc "Z0"]
-
-(* program -> Coq AST *)
-
-let bdize c =
- let env =
- Global.env_of_context (Pcicenv.cci_sign_of Prename.empty_ren Penv.empty)
- in
- Constrextern.extern_constr true env c
-
-let rec coqast_of_program loc = function
- | Variable id -> mk_id loc id
- | Acc id -> mk_id loc id
- | Apply (f,l) ->
- let f = coqast_of_program f.loc f.desc in
- let args = List.map
- (function Term t -> (coqast_of_program t.loc t.desc,None)
- | _ -> invalid_arg "coqast_of_program") l
- in
- CApp (dummy_loc, (None,f), args)
- | Expression c -> bdize c
- | _ -> invalid_arg "coqast_of_program"
-
-(* The construction `for' is syntactic sugar.
- *
- * for i = v1 to v2 do { invariant Inv } block done
- *
- * ==> (let rec f i { variant v2+1-i } =
- * { i <= v2+1 /\ Inv(i) }
- * (if i > v2 then tt else begin block; (f (i+1)) end)
- * { Inv(v2+1) }
- * in (f v1)) { Inv(v2+1) }
- *)
-
-let ast_plus_un loc ast =
- let un = ast_of_int "1" in
- mk_appl loc loc "Zplus" [ast;un]
-
-let make_ast_for loc i v1 v2 inv block =
- let f = for_name() in
- let id_i = id_of_string i in
- let var_i = without_effect loc (Variable id_i) in
- let var_f = without_effect loc (Variable f) in
- let succ_v2 =
- let a_v2 = coqast_of_program v2.loc v2.desc in
- ast_plus_un loc a_v2 in
- let post = named_app (subst_ast_in_ast [ id_i, succ_v2 ]) inv in
- let e1 =
- let test = bin_op "Z_gt_le_bool" loc var_i v2 in
- let br_t = without_effect loc (Expression (constant "tt")) in
- let br_f =
- let un = without_effect loc (Expression (constr_of_int "1")) in
- let succ_i = bin_op "Zplus" loc var_i un in
- let f_succ_i = without_effect loc (Apply (var_f, [Term succ_i])) in
- without_effect loc (Seq (block @ [Statement f_succ_i]))
- in
- let inv' =
- let i_le_sv2 = mk_appl loc loc "Zle" [mk_ref loc i; succ_v2] in
- conj_assert {a_value=i_le_sv2;a_name=inv.a_name} inv
- in
- { desc = If(test,br_t,br_f); loc = loc;
- pre = [pre_of_assert false inv']; post = Some post; info = () }
- in
- let bl =
- let typez = mk_ref loc "Z" in
- [(id_of_string i, BindType (TypePure typez))]
- in
- let fv1 = without_effect loc (Apply (var_f, [Term v1])) in
- let v = TypePure (mk_ref loc "unit") in
- let var =
- let a = mk_appl loc loc "Zminus" [succ_v2;mk_ref loc i] in
- (a, ast_zwf_zero loc)
- in
- Let (f, without_effect loc (LetRec (f,bl,v,var,e1)), fv1)
-
-let mk_prog loc p pre post =
- { desc = p.desc;
- pre = p.pre @ pre;
- post = conj (p.post,post);
- loc = loc;
- info = () }
-
-if !Options.v7 then
-GEXTEND Gram
-
- (* Types ******************************************************************)
- type_v:
- [ [ t = type_v0 -> t ] ]
- ;
- type_v0:
- [ [ t = type_v1 -> t ] ]
- ;
- type_v1:
- [ [ t = type_v2 -> t ] ]
- ;
- type_v2:
- [ LEFTA
- [ v = type_v2; IDENT "ref" -> Ref v
- | t = type_v3 -> t ] ]
- ;
- type_v3:
- [ [ IDENT "array"; size = Constr.constr; "of"; v = type_v0 ->
- Array (size,v)
- | IDENT "fun"; bl = binders; c = type_c -> make_arrow bl c
- | c = Constr.constr -> TypePure c
- ] ]
- ;
- type_c:
- [ [ IDENT "returns"; id = IDENT; ":"; v = type_v;
- e = effects; p = OPT pre_condition; q = OPT post_condition; "end" ->
- ((id_of_string id, v), e, list_of_some p, q)
- ] ]
- ;
- effects:
- [ [ r = OPT reads; w = OPT writes ->
- let r' = match r with Some l -> l | _ -> [] in
- let w' = match w with Some l -> l | _ -> [] in
- List.fold_left (fun e x -> Peffect.add_write x e)
- (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r')
- w'
- ] ]
- ;
- reads:
- [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
- ;
- writes:
- [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
- ;
- pre_condition:
- [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ]
- ;
- post_condition:
- [ [ IDENT "post"; c = predicate -> c ] ]
- ;
-
- (* Binders (for both types and programs) **********************************)
- binder:
- [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" ->
- List.map (fun s -> (id_of_string s, t)) sl
- ] ]
- ;
- binder_type:
- [ [ "Set" -> BindSet
- | v = type_v -> BindType v
- ] ]
- ;
- binders:
- [ [ bl = LIST0 binder -> List.flatten bl ] ]
- ;
-
- (* annotations *)
- predicate:
- [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ]
- ;
- name:
- [ [ "as"; s = IDENT -> Name (id_of_string s)
- | -> Anonymous
- ] ]
- ;
-
- (* Programs ***************************************************************)
- variable:
- [ [ s = IDENT -> id_of_string s ] ]
- ;
- assertion:
- [ [ "{"; c = predicate; "}" -> c ] ]
- ;
- precondition:
- [ [ "{"; c = predicate; "}" -> pre_of_assert false c ] ]
- ;
- postcondition:
- [ [ "{"; c = predicate; "}" -> c ] ]
- ;
- program:
- [ [ p = prog1 -> p ] ]
- ;
- prog1:
- [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog2:
- [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog3:
- [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog4:
- [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog5:
- [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog6:
- [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
-
- ast1:
- [ [ x = prog2; IDENT "or"; y = prog1 -> bool_or loc x y
- | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y
- | x = prog2 -> x
- ] ]
- ;
- ast2:
- [ [ IDENT "not"; x = prog3 -> bool_not loc x
- | x = prog3 -> x
- ] ]
- ;
- ast3:
- [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y
- | x = prog4 -> x
- ] ]
- ;
- ast4:
- [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y
- | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y
- | x = prog5 -> x
- ] ]
- ;
- ast5:
- [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y
- | x = prog6 -> x
- ] ]
- ;
- ast6:
- [ [ "-"; x = prog6 -> un_op "Zopp" loc x
- | x = ast7 -> without_effect loc x
- ] ]
- ;
- ast7:
- [ [ v = variable ->
- Variable v
- | n = INT ->
- Expression (constr_of_int n)
- | "!"; v = variable ->
- Acc v
- | "?" ->
- isevar
- | v = variable; ":="; p = program ->
- Aff (v,p)
- | v = variable; "["; e = program; "]" -> TabAcc (true,v,e)
- | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e)
- | v = variable; "["; e = program; "]"; ":="; p = program ->
- TabAff (true,v,e,p)
- | v = variable; "#"; "["; e = program; "]"; ":="; p = program ->
- TabAff (true,v,e,p)
- | IDENT "if"; e1 = program; IDENT "then"; e2 = program;
- IDENT "else"; e3 = program ->
- If (e1,e2,e3)
- | IDENT "if"; e1 = program; IDENT "then"; e2 = program ->
- If (e1,e2,without_effect loc (Expression (constant "tt")))
- | IDENT "while"; b = program; IDENT "do";
- "{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}";
- bl = block; IDENT "done" ->
- While (b, inv, wf, bl)
- | IDENT "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program;
- IDENT "do"; "{"; inv = invariant; "}";
- bl = block; IDENT "done" ->
- make_ast_for loc i v1 v2 inv bl
- | IDENT "let"; v = variable; "="; IDENT "ref"; p1 = program;
- "in"; p2 = program ->
- LetRef (v, p1, p2)
- | IDENT "let"; v = variable; "="; p1 = program; "in"; p2 = program ->
- Let (v, p1, p2)
- | IDENT "begin"; b = block; "end" ->
- Seq b
- | IDENT "fun"; bl = binders; "->"; p = program ->
- Lam (bl,p)
- | IDENT "let"; IDENT "rec"; f = variable;
- bl = binders; ":"; v = type_v;
- "{"; IDENT "variant"; var = variant; "}"; "="; p = program ->
- LetRec (f,bl,v,var,p)
- | IDENT "let"; IDENT "rec"; f = variable;
- bl = binders; ":"; v = type_v;
- "{"; IDENT "variant"; var = variant; "}"; "="; p = program;
- "in"; p2 = program ->
- Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2)
-
- | "@"; s = STRING; p = program ->
- Debug (s,p)
-
- | "("; p = program; args = LIST0 arg; ")" ->
- match args with
- [] ->
- if p.pre<>[] or p.post<>None then
- Pp.warning "Some annotations are lost";
- p.desc
- | _ ->
- Apply(p,args)
- ] ]
- ;
- arg:
- [ [ "'"; t = type_v -> Type t
- | p = program -> Term p
- ] ]
- ;
- block:
- [ [ s = block_statement; ";"; b = block -> s::b
- | s = block_statement -> [s] ] ]
- ;
- block_statement:
- [ [ IDENT "label"; s = IDENT -> Label s
- | IDENT "assert"; c = assertion -> Assert c
- | p = program -> Statement p ] ]
- ;
- relation:
- [ [ "<" -> "Z_lt_ge_bool"
- | "<=" -> "Z_le_gt_bool"
- | ">" -> "Z_gt_le_bool"
- | ">=" -> "Z_ge_lt_bool"
- | "=" -> "Z_eq_bool"
- | "<>" -> "Z_noteq_bool" ] ]
- ;
-
- (* Other entries (invariants, etc.) ***************************************)
- invariant:
- [ [ IDENT "invariant"; c = predicate -> c ] ]
- ;
- variant:
- [ [ c = Constr.constr; IDENT "for"; r = Constr.constr -> (c, r)
- | c = Constr.constr -> (c, ast_zwf_zero loc) ] ]
- ;
- END
-else
-GEXTEND Gram
- GLOBAL: type_v program;
-
- (* Types ******************************************************************)
- type_v:
- [ [ t = type_v0 -> t ] ]
- ;
- type_v0:
- [ [ t = type_v1 -> t ] ]
- ;
- type_v1:
- [ [ t = type_v2 -> t ] ]
- ;
- type_v2:
- [ LEFTA
- [ v = type_v2; IDENT "ref" -> Ref v
- | t = type_v3 -> t ] ]
- ;
- type_v3:
- [ [ IDENT "array"; size = Constr.constr; IDENT "of"; v = type_v0 ->
- Array (size,v)
- | "fun"; bl = binders; c = type_c -> make_arrow bl c
- | c = Constr.constr -> TypePure c
- ] ]
- ;
- type_c:
- [ [ IDENT "returns"; id = IDENT; ":"; v = type_v;
- e = effects; p = OPT pre_condition; q = OPT post_condition; "end" ->
- ((id_of_string id, v), e, list_of_some p, q)
- ] ]
- ;
- effects:
- [ [ r = OPT reads; w = OPT writes ->
- let r' = match r with Some l -> l | _ -> [] in
- let w' = match w with Some l -> l | _ -> [] in
- List.fold_left (fun e x -> Peffect.add_write x e)
- (List.fold_left (fun e x -> Peffect.add_read x e) Peffect.bottom r')
- w'
- ] ]
- ;
- reads:
- [ [ IDENT "reads"; l = LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
- ;
- writes:
- [ [ IDENT "writes"; l=LIST0 IDENT SEP "," -> List.map id_of_string l ] ]
- ;
- pre_condition:
- [ [ IDENT "pre"; c = predicate -> pre_of_assert false c ] ]
- ;
- post_condition:
- [ [ IDENT "post"; c = predicate -> c ] ]
- ;
-
- (* Binders (for both types and programs) **********************************)
- binder:
- [ [ "("; sl = LIST1 IDENT SEP ","; ":"; t = binder_type ; ")" ->
- List.map (fun s -> (id_of_string s, t)) sl
- ] ]
- ;
- binder_type:
- [ [ "Set" -> BindSet
- | v = type_v -> BindType v
- ] ]
- ;
- binders:
- [ [ bl = LIST0 binder -> List.flatten bl ] ]
- ;
-
- (* annotations *)
- predicate:
- [ [ c = Constr.constr; n = name -> { a_name = n; a_value = c } ] ]
- ;
- dpredicate:
- [ [ c = Constr.lconstr; n = name -> { a_name = n; a_value = c } ] ]
- ;
- name:
- [ [ "as"; s = IDENT -> Name (id_of_string s)
- | -> Anonymous
- ] ]
- ;
-
- (* Programs ***************************************************************)
- variable:
- [ [ s = IDENT -> id_of_string s ] ]
- ;
- assertion:
- [ [ "{"; c = dpredicate; "}" -> c ] ]
- ;
- precondition:
- [ [ "{"; c = dpredicate; "}" -> pre_of_assert false c ] ]
- ;
- postcondition:
- [ [ "{"; c = dpredicate; "}" -> c ] ]
- ;
- program:
- [ [ p = prog1 -> p ] ]
- ;
- prog1:
- [ [ pre = LIST0 precondition; ast = ast1; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog2:
- [ [ pre = LIST0 precondition; ast = ast2; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog3:
- [ [ pre = LIST0 precondition; ast = ast3; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog4:
- [ [ pre = LIST0 precondition; ast = ast4; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog5:
- [ [ pre = LIST0 precondition; ast = ast5; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
- prog6:
- [ [ pre = LIST0 precondition; ast = ast6; post = OPT postcondition ->
- mk_prog loc ast pre post ] ]
- ;
-
- ast1:
- [ [ x = prog2; IDENT "or"; y = prog1 -> bool_or loc x y
- | x = prog2; IDENT "and"; y = prog1 -> bool_and loc x y
- | x = prog2 -> x
- ] ]
- ;
- ast2:
- [ [ IDENT "not"; x = prog3 -> bool_not loc x
- | x = prog3 -> x
- ] ]
- ;
- ast3:
- [ [ x = prog4; rel = relation; y = prog4 -> bin_op rel loc x y
- | x = prog4 -> x
- ] ]
- ;
- ast4:
- [ [ x = prog5; "+"; y = prog4 -> bin_op "Zplus" loc x y
- | x = prog5; "-"; y = prog4 -> bin_op "Zminus" loc x y
- | x = prog5 -> x
- ] ]
- ;
- ast5:
- [ [ x = prog6; "*"; y = prog5 -> bin_op "Zmult" loc x y
- | x = prog6 -> x
- ] ]
- ;
- ast6:
- [ [ "-"; x = prog6 -> un_op "Zopp" loc x
- | x = ast7 -> without_effect loc x
- ] ]
- ;
- ast7:
- [ [ v = variable ->
- Variable v
- | n = INT ->
- Expression (constr_of_int n)
- | "!"; v = variable ->
- Acc v
- | "?" ->
- isevar
- | v = variable; ":="; p = program ->
- Aff (v,p)
- | v = variable; "["; e = program; "]" -> TabAcc (true,v,e)
- | v = variable; "#"; "["; e = program; "]" -> TabAcc (true,v,e)
- | v = variable; "["; e = program; "]"; ":="; p = program ->
- TabAff (true,v,e,p)
- | v = variable; "#"; "["; e = program; "]"; ":="; p = program ->
- TabAff (true,v,e,p)
- | "if"; e1 = program; "then"; e2 = program; "else"; e3 = program ->
- If (e1,e2,e3)
- | "if"; e1 = program; "then"; e2 = program ->
- If (e1,e2,without_effect loc (Expression (constant "tt")))
- | IDENT "while"; b = program; IDENT "do";
- "{"; inv = OPT invariant; IDENT "variant"; wf = variant; "}";
- bl = block; IDENT "done" ->
- While (b, inv, wf, bl)
- | "for"; i = IDENT; "="; v1 = program; IDENT "to"; v2 = program;
- IDENT "do"; "{"; inv = invariant; "}";
- bl = block; IDENT "done" ->
- make_ast_for loc i v1 v2 inv bl
- | "let"; v = variable; "="; IDENT "ref"; p1 = program;
- "in"; p2 = program ->
- LetRef (v, p1, p2)
- | "let"; v = variable; "="; p1 = program; "in"; p2 = program ->
- Let (v, p1, p2)
- | IDENT "begin"; b = block; "end" ->
- Seq b
- | "fun"; bl = binders; "=>"; p = program ->
- Lam (bl,p)
- | "let"; IDENT "rec"; f = variable;
- bl = binders; ":"; v = type_v;
- "{"; IDENT "variant"; var = variant; "}"; "="; p = program ->
- LetRec (f,bl,v,var,p)
- | "let"; IDENT "rec"; f = variable;
- bl = binders; ":"; v = type_v;
- "{"; IDENT "variant"; var = variant; "}"; "="; p = program;
- "in"; p2 = program ->
- Let (f, without_effect loc (LetRec (f,bl,v,var,p)), p2)
-
- | "@"; s = STRING; p = program ->
- Debug (s,p)
-
- | "("; p = program; args = LIST0 arg; ")" ->
- match args with
- [] ->
- if p.pre<>[] or p.post<>None then
- Pp.warning "Some annotations are lost";
- p.desc
- | _ ->
- Apply(p,args)
- ] ]
- ;
- arg:
- [ [ "'"; t = type_v -> Type t
- | p = program -> Term p
- ] ]
- ;
- block:
- [ [ s = block_statement; ";"; b = block -> s::b
- | s = block_statement -> [s] ] ]
- ;
- block_statement:
- [ [ IDENT "label"; s = IDENT -> Label s
- | IDENT "assert"; c = assertion -> Assert c
- | p = program -> Statement p ] ]
- ;
- relation:
- [ [ "<" -> "Z_lt_ge_bool"
- | "<=" -> "Z_le_gt_bool"
- | ">" -> "Z_gt_le_bool"
- | ">=" -> "Z_ge_lt_bool"
- | "=" -> "Z_eq_bool"
- | "<>" -> "Z_noteq_bool" ] ]
- ;
-
- (* Other entries (invariants, etc.) ***************************************)
- invariant:
- [ [ IDENT "invariant"; c = predicate -> c ] ]
- ;
- variant:
- [ [ c = Constr.constr; "for"; r = Constr.constr -> (c, r)
- | c = Constr.constr -> (c, ast_zwf_zero loc) ] ]
- ;
- END
-;;
-
-let wit_program, globwit_program, rawwit_program =
- Genarg.create_arg "program"
-let wit_type_v, globwit_type_v, rawwit_type_v =
- Genarg.create_arg "type_v"
-
-open Pp
-open Util
-open Himsg
-open Vernacinterp
-open Vernacexpr
-open Declare
-
-let is_assumed global ids =
- if List.length ids = 1 then
- msgnl (str (if global then "A global variable " else "") ++
- pr_id (List.hd ids) ++ str " is assumed")
- else
- msgnl (str (if global then "Some global variables " else "") ++
- prlist_with_sep (fun () -> (str ", ")) pr_id ids ++
- str " are assumed")
-
-open Pcoq
-
-(* Variables *)
-
-let wit_variables, globwit_variables, rawwit_variables =
- Genarg.create_arg "variables"
-
-let variables = Gram.Entry.create "Variables"
-
-GEXTEND Gram
- variables: [ [ l = LIST1 Prim.ident SEP "," -> l ] ];
-END
-
-let pr_variables _prc _prtac l = spc() ++ prlist_with_sep pr_coma pr_id l
-
-let _ =
- Pptactic.declare_extra_genarg_pprule true
- (rawwit_variables, pr_variables)
- (globwit_variables, pr_variables)
- (wit_variables, pr_variables)
-
-(* then_tac *)
-
-open Genarg
-open Tacinterp
-
-let pr_then_tac _ prt = function
- | None -> mt ()
- | Some t -> pr_semicolon () ++ prt t
-
-ARGUMENT EXTEND then_tac
- TYPED AS tactic_opt
- PRINTED BY pr_then_tac
- INTERPRETED BY interp_genarg
- GLOBALIZED BY intern_genarg
-| [ ";" tactic(t) ] -> [ Some t ]
-| [ ] -> [ None ]
-END
-
-(* Correctness *)
-
-VERNAC COMMAND EXTEND Correctness
- [ "Correctness" preident(str) program(pgm) then_tac(tac) ]
- -> [ Ptactic.correctness str pgm (option_map Tacinterp.interp tac) ]
-END
-
-(* Show Programs *)
-
-let show_programs () =
- fold_all
- (fun (id,v) _ ->
- msgnl (pr_id id ++ str " : " ++
- hov 2 (match v with TypeV v -> pp_type_v v
- | Set -> (str "Set")) ++
- fnl ()))
- Penv.empty ()
-
-VERNAC COMMAND EXTEND ShowPrograms
- [ "Show" "Programs" ] -> [ show_programs () ]
-END
-
-(* Global Variable *)
-
-let global_variable ids v =
- List.iter
- (fun id -> if Penv.is_global id then
- Util.errorlabstrm "PROGVARIABLE"
- (str"Clash with previous constant " ++ pr_id id))
- ids;
- Pdb.check_type_v (all_refs ()) v;
- let env = empty in
- let ren = update empty_ren "" [] in
- let v = Ptyping.cic_type_v env ren v in
- if not (is_mutable v) then begin
- let c =
- Entries.ParameterEntry (trad_ml_type_v ren env v),
- Decl_kinds.IsAssumption Decl_kinds.Definitional in
- List.iter
- (fun id -> ignore (Declare.declare_constant id c)) ids;
- if_verbose (is_assumed false) ids
- end;
- if not (is_pure v) then begin
- List.iter (fun id -> ignore (Penv.add_global id v None)) ids;
- if_verbose (is_assumed true) ids
- end
-
-VERNAC COMMAND EXTEND ProgVariable
- [ "Global" "Variable" variables(ids) ":" type_v(t) ]
- -> [ global_variable ids t]
-END
-
-let pr_id id = pr_id (Constrextern.v7_to_v8_id id)
-
-(* Type printer *)
-
-let pr_reads = function
- | [] -> mt ()
- | l -> spc () ++
- hov 0 (str "reads" ++ spc () ++ prlist_with_sep pr_coma pr_id l)
-
-let pr_writes = function
- | [] -> mt ()
- | l -> spc () ++
- hov 0 (str "writes" ++ spc () ++ prlist_with_sep pr_coma pr_id l)
-
-let pr_effects x =
- let (ro,rw) = Peffect.get_repr x in pr_reads ro ++ pr_writes rw
-
-let pr_predicate delimited { a_name = n; a_value = c } =
- (if delimited then Ppconstr.pr_lconstr else Ppconstr.pr_constr) c ++
- (match n with Name id -> spc () ++ str "as " ++ pr_id id | Anonymous -> mt())
-
-let pr_assert b { p_name = x; p_value = v } =
- pr_predicate b { a_name = x; a_value = v }
-
-let pr_pre_condition_list = function
- | [] -> mt ()
- | [pre] -> spc() ++ hov 0 (str "pre" ++ spc () ++ pr_assert false pre)
- | _ -> assert false
-
-let pr_post_condition_opt = function
- | None -> mt ()
- | Some post ->
- spc() ++ hov 0 (str "post" ++ spc () ++ pr_predicate false post)
-
-let rec pr_type_v_v8 = function
- | Array (a,v) ->
- str "array" ++ spc() ++ Ppconstr.pr_constr a ++ spc() ++ str "of " ++
- pr_type_v_v8 v
- | v -> pr_type_v3 v
-
-and pr_type_v3 = function
- | Ref v -> pr_type_v3 v ++ spc () ++ str "ref"
- | Arrow (bl,((id,v),e,prel,postl)) ->
- str "fun" ++ spc() ++ hov 0 (prlist_with_sep cut pr_binder bl) ++
- spc () ++ str "returns" ++ spc () ++ pr_id id ++ str ":" ++
- pr_type_v_v8 v ++ pr_effects e ++
- pr_pre_condition_list prel ++ pr_post_condition_opt postl ++
- spc () ++ str "end"
- | TypePure a -> Ppconstr.pr_constr a
- | v -> str "(" ++ pr_type_v_v8 v ++ str ")"
-
-and pr_binder = function
- | (id,BindType c) ->
- str "(" ++ pr_id id ++ str ":" ++ pr_type_v_v8 c ++ str ")"
- | (id,BindSet) ->
- str "(" ++ pr_id id ++ str ":" ++ str "Set" ++ str ")"
- | (id,Untyped) ->
- str "<<<<< TODO: Untyped binder >>>>"
-
-let _ =
- Pptactic.declare_extra_genarg_pprule true
- (rawwit_type_v, fun _ _ -> pr_type_v_v8)
- (globwit_type_v, fun _ -> raise Not_found)
- (wit_type_v, fun _ -> raise Not_found)
-
-(* Program printer *)
-
-let pr_precondition pred = str "{" ++ pr_assert true pred ++ str "}" ++ spc ()
-
-let pr_postcondition pred = str "{" ++ pr_predicate true pred ++ str "}"
-
-let pr_invariant = function
- | None -> mt ()
- | Some c -> hov 2 (str "invariant" ++ spc () ++ pr_predicate false c)
-
-let pr_variant (c1,c2) =
- Ppconstr.pr_constr c1 ++
- (try Constrextern.check_same_type c2 (ast_zwf_zero dummy_loc); mt ()
- with _ -> spc() ++ hov 0 (str "for" ++ spc () ++ Ppconstr.pr_constr c2))
-
-let rec pr_desc = function
- | Variable id ->
- (* Unsafe: should distinguish global names and bound vars *)
- let vars = (* TODO *) Idset.empty in
- let id = try
- snd (repr_qualid
- (snd (qualid_of_reference
- (Constrextern.extern_reference
- dummy_loc vars (Nametab.locate (make_short_qualid id))))))
- with _ -> id in
- pr_id id
- | Acc id -> str "!" ++ pr_id id
- | Aff (id,p) -> pr_id id ++ spc() ++ str ":=" ++ spc() ++ pr_prog p
- | TabAcc (b,id,p) -> pr_id id ++ str "[" ++ pr_prog p ++ str "]"
- | TabAff (b,id,p1,p2) ->
- pr_id id ++ str "[" ++ pr_prog p1 ++ str "]" ++
- str ":=" ++ pr_prog p2
- | Seq bll ->
- hv 0 (str "begin" ++ spc () ++ pr_block bll ++ spc () ++ str "end")
- | While (p1,inv,var,bll) ->
- hv 0 (
- hov 0 (str "while" ++ spc () ++ pr_prog p1 ++ spc () ++ str "do") ++
- brk (1,2) ++
- hv 2 (
- str "{ " ++
- pr_invariant inv ++ spc() ++
- hov 0 (str "variant" ++ spc () ++ pr_variant var)
- ++ str " }") ++ cut () ++
- hov 0 (pr_block bll) ++ cut () ++
- str "done")
- | If (p1,p2,p3) ->
- hov 1 (str "if " ++ pr_prog p1) ++ spc () ++
- hov 0 (str "then" ++ spc () ++ pr_prog p2) ++ spc () ++
- hov 0 (str "else" ++ spc () ++ pr_prog p3)
- | Lam (bl,p) ->
- hov 0
- (str "fun" ++ spc () ++ hov 0 (prlist_with_sep cut pr_binder bl) ++
- spc () ++ str "=>") ++
- pr_prog p
- | Apply ({desc=Expression e; pre=[]; post=None} as p,args) when isConst e ->
- begin match
- string_of_id (snd (repr_path (Nametab.sp_of_global (ConstRef (destConst e))))),
- args
- with
- | "Zmult", [a1;a2] ->
- str "(" ++ pr_arg a1 ++ str"*" ++ pr_arg a2 ++ str ")"
- | "Zplus", [a1;a2] ->
- str "(" ++ pr_arg a1 ++ str"+" ++ pr_arg a2 ++ str ")"
- | "Zminus", [a1;a2] ->
- str "(" ++ pr_arg a1 ++ str"-" ++ pr_arg a2 ++ str ")"
- | "Zopp", [a] ->
- str "( -" ++ pr_arg a ++ str ")"
- | "Z_lt_ge_bool", [a1;a2] ->
- str "(" ++ pr_arg a1 ++ str"<" ++ pr_arg a2 ++ str ")"
- | "Z_le_gt_bool", [a1;a2] ->
- str "(" ++ pr_arg a1 ++ str"<=" ++ pr_arg a2 ++ str ")"
- | "Z_gt_le_bool", [a1;a2] ->
- str "(" ++ pr_arg a1 ++ str">" ++ pr_arg a2 ++ str ")"
- | "Z_ge_lt_bool", [a1;a2] ->
- str "(" ++ pr_arg a1 ++ str">=" ++ pr_arg a2 ++ str ")"
- | "Z_eq_bool", [a1;a2] ->
- str "(" ++ pr_arg a1 ++ str"=" ++ pr_arg a2 ++ str ")"
- | "Z_noteq_bool", [a1;a2] ->
- str "(" ++ pr_arg a1 ++ str"<> " ++ pr_arg a2 ++ str ")"
- | _ ->
- str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++
- str ")"
- end
- | Apply (p,args) ->
- str "(" ++ pr_prog p ++ spc () ++ prlist_with_sep spc pr_arg args ++
- str ")"
- | SApp ([Variable v], args) ->
- begin match string_of_id v, args with
- | "prog_bool_and", [a1;a2] ->
- str"(" ++ pr_prog a1 ++ spc() ++ str"and " ++ pr_prog a2 ++str")"
- | "prog_bool_or", [a1;a2] ->
- str"(" ++ pr_prog a1 ++ spc() ++ str"or " ++ pr_prog a2 ++ str")"
- | "prog_bool_not", [a] ->
- str "(not " ++ pr_prog a ++ str ")"
- | _ -> failwith "Correctness printer: TODO"
- end
- | SApp _ -> failwith "Correctness printer: TODO"
- | LetRef (v,p1,p2) ->
- hov 2 (
- str "let " ++ pr_id v ++ str " =" ++ spc () ++ str "ref" ++ spc () ++
- pr_prog p1 ++ str " in") ++
- spc () ++ pr_prog p2
- | Let (id, {desc=LetRec (f,bl,v,var,p); pre=[]; post=None },p2) when f=id ->
- hov 2 (
- str "let rec " ++ pr_id f ++ spc () ++
- hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++
- str ":" ++ pr_type_v_v8 v ++ spc () ++
- hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++
- spc() ++ str "=" ++ spc () ++ pr_prog p ++
- str " in") ++
- spc () ++ pr_prog p2
- | Let (v,p1,p2) ->
- hov 2 (
- str "let " ++ pr_id v ++ str " =" ++ spc () ++ pr_prog p1 ++ str" in")
- ++ spc () ++ pr_prog p2
- | LetRec (f,bl,v,var,p) ->
- str "let rec " ++ pr_id f ++ spc () ++
- hov 0 (prlist_with_sep cut pr_binder bl) ++ spc () ++
- str ":" ++ pr_type_v_v8 v ++ spc () ++
- hov 2 (str "{ variant" ++ spc () ++ pr_variant var ++ str " }") ++
- spc () ++ str "=" ++ spc () ++ pr_prog p
- | PPoint _ -> str "TODO: Ppoint" (* Internal use only *)
- | Expression c ->
- (* Numeral or "tt": use a printer which doesn't globalize *)
- Ppconstr.pr_constr
- (Constrextern.extern_constr_in_scope false "Z_scope" (Global.env()) c)
- | Debug (s,p) -> str "@" ++ Pptactic.qsnew s ++ pr_prog p
-
-and pr_block_st = function
- | Label s -> hov 0 (str "label" ++ spc() ++ str s)
- | Assert pred ->
- hov 0 (str "assert" ++ spc() ++ hov 0 (pr_postcondition pred))
- | Statement p -> pr_prog p
-
-and pr_block bl = prlist_with_sep pr_semicolon pr_block_st bl
-
-and pr_arg = function
- | Past.Term p -> pr_prog p
- | Past.Type t -> str "'" ++ pr_type_v_v8 t
- | Refarg _ -> str "TODO: Refarg" (* Internal use only *)
-
-and pr_prog0 b { desc = desc; pre = pre; post = post } =
- hv 0 (
- prlist pr_precondition pre ++
- hov 0
- (if b & post<>None then str"(" ++ pr_desc desc ++ str")"
- else pr_desc desc)
- ++ Ppconstr.pr_opt pr_postcondition post)
-
-and pr_prog x = pr_prog0 true x
-
-let _ =
- Pptactic.declare_extra_genarg_pprule true
- (rawwit_program, fun _ _ a -> spc () ++ pr_prog0 false a)
- (globwit_program, fun _ -> raise Not_found)
- (wit_program, fun _ -> raise Not_found)
-
diff --git a/contrib/correctness/psyntax.mli b/contrib/correctness/psyntax.mli
deleted file mode 100644
index c0f0990b..00000000
--- a/contrib/correctness/psyntax.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: psyntax.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pcoq
-open Ptype
-open Past
-open Topconstr
-
-(* Grammar for the programs and the tactic Correctness *)
-
-module Programs :
- sig
- val program : program Gram.Entry.e
- val type_v : constr_expr ml_type_v Gram.Entry.e
- val type_c : constr_expr ml_type_c Gram.Entry.e
- end
diff --git a/contrib/correctness/ptactic.ml b/contrib/correctness/ptactic.ml
deleted file mode 100644
index babc607d..00000000
--- a/contrib/correctness/ptactic.ml
+++ /dev/null
@@ -1,258 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptactic.ml 8759 2006-04-28 12:24:14Z herbelin $ *)
-
-open Pp
-open Options
-open Names
-open Libnames
-open Term
-open Pretyping
-open Pfedit
-open Decl_kinds
-open Vernacentries
-
-open Pmisc
-open Putil
-open Past
-open Penv
-open Prename
-open Peffect
-open Pmonad
-
-(* [coqast_of_prog: program -> constr * constr]
- * Traduction d'un programme impératif en un but (second constr)
- * et un terme de preuve partiel pour ce but (premier constr)
- *)
-
-let coqast_of_prog p =
- (* 1. db : séparation dB/var/const *)
- let p = Pdb.db_prog p in
-
- (* 2. typage avec effets *)
- deb_mess (str"Ptyping.states: Typing with effects..." ++ fnl ());
- let env = Penv.empty in
- let ren = initial_renaming env in
- let p = Ptyping.states ren env p in
- let ((_,v),_,_,_) as c = p.info.kappa in
- Perror.check_for_not_mutable p.loc v;
- deb_print pp_type_c c;
-
- (* 3. propagation annotations *)
- let p = Pwp.propagate ren p in
-
- (* 4a. traduction type *)
- let ty = Pmonad.trad_ml_type_c ren env c in
- deb_print (Printer.pr_lconstr_env (Global.env())) ty;
-
- (* 4b. traduction terme (terme intermédiaire de type cc_term) *)
- deb_mess
- (fnl () ++ str"Mlize.trad: Translation program -> cc_term..." ++ fnl ());
- let cc = Pmlize.trans ren p in
- let cc = Pred.red cc in
- deb_print Putil.pp_cc_term cc;
-
- (* 5. traduction en constr *)
- deb_mess
- (fnl () ++ str"Pcic.constr_of_prog: Translation cc_term -> rawconstr..." ++
- fnl ());
- let r = Pcic.rawconstr_of_prog cc in
- deb_print Printer.pr_lrawconstr r;
-
- (* 6. résolution implicites *)
- deb_mess (fnl () ++ str"Resolution implicits (? => Meta(n))..." ++ fnl ());
- let oc = understand_gen_tcc Evd.empty (Global.env()) [] None r in
- deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc);
-
- p,oc,ty,v
-
-(* [automatic : tactic]
- *
- * Certains buts engendrés par "correctness" (ci-dessous)
- * sont réellement triviaux. On peut les résoudre aisément, sans pour autant
- * tomber dans la solution trop lourde qui consiste à faire "; Auto."
- *
- * Cette tactique fait les choses suivantes :
- * o elle élimine les hypothèses de nom loop<i>
- * o sur G |- (well_founded nat lt) ==> Exact lt_wf.
- * o sur G |- (well_founded Z (Zwf c)) ==> Exact (Zwf_well_founded c)
- * o sur G |- e = e' ==> Reflexivity. (arg. de decr. des boucles)
- * sinon Try Assumption.
- * o sur G |- P /\ Q ==> Try (Split; Assumption). (sortie de boucle)
- * o sinon, Try AssumptionBis (= Assumption + décomposition /\ dans hyp.)
- * (pour entrée dans corps de boucle par ex.)
- *)
-
-open Pattern
-open Tacmach
-open Tactics
-open Tacticals
-open Equality
-open Nametab
-
-let nat = IndRef (coq_constant ["Init";"Datatypes"] "nat", 0)
-let lt = ConstRef (coq_constant ["Init";"Peano"] "lt")
-let well_founded = ConstRef (coq_constant ["Init";"Wf"] "well_founded")
-let z = IndRef (coq_constant ["ZArith";"BinInt"] "Z", 0)
-let and_ = IndRef (coq_constant ["Init";"Logic"] "and", 0)
-let eq = IndRef (coq_constant ["Init";"Logic"] "eq", 0)
-
-let mkmeta n = Nameops.make_ident "X" (Some n)
-let mkPMeta n = PMeta (Some (mkmeta n))
-
-(* ["(well_founded nat lt)"] *)
-let wf_nat_pattern =
- PApp (PRef well_founded, [| PRef nat; PRef lt |])
-(* ["((well_founded Z (Zwf ?1))"] *)
-let wf_z_pattern =
- let zwf = ConstRef (coq_constant ["ZArith";"Zwf"] "Zwf") in
- PApp (PRef well_founded, [| PRef z; PApp (PRef zwf, [| mkPMeta 1 |]) |])
-(* ["(and ?1 ?2)"] *)
-let and_pattern =
- PApp (PRef and_, [| mkPMeta 1; mkPMeta 2 |])
-(* ["(eq ?1 ?2 ?3)"] *)
-let eq_pattern =
- PApp (PRef eq, [| mkPMeta 1; mkPMeta 2; mkPMeta 3 |])
-
-(* loop_ids: remove loop<i> hypotheses from the context, and rewrite
- * using Variant<i> hypotheses when needed. *)
-
-let (loop_ids : tactic) = fun gl ->
- let rec arec hyps gl =
- let env = pf_env gl in
- let concl = pf_concl gl in
- match hyps with
- | [] -> tclIDTAC gl
- | (id,a) :: al ->
- let s = string_of_id id in
- let n = String.length s in
- if n >= 4 & (let su = String.sub s 0 4 in su="loop" or su="Bool")
- then
- tclTHEN (clear [id]) (arec al) gl
- else if n >= 7 & String.sub s 0 7 = "Variant" then begin
- match pf_matches gl eq_pattern (body_of_type a) with
- | [_; _,varphi; _] when isVar varphi ->
- let phi = destVar varphi in
- if Termops.occur_var env phi concl then
- tclTHEN (rewriteLR (mkVar id)) (arec al) gl
- else
- arec al gl
- | _ -> assert false end
- else
- arec al gl
- in
- arec (pf_hyps_types gl) gl
-
-(* assumption_bis: like assumption, but also solves ... h:A/\B ... |- A
- * (resp. B) *)
-
-let (assumption_bis : tactic) = fun gl ->
- let concl = pf_concl gl in
- let rec arec = function
- | [] -> Util.error "No such assumption"
- | (s,a) :: al ->
- let a = body_of_type a in
- if pf_conv_x_leq gl a concl then
- refine (mkVar s) gl
- else if pf_is_matching gl and_pattern a then
- match pf_matches gl and_pattern a with
- | [_,c1; _,c2] ->
- if pf_conv_x_leq gl c1 concl then
- exact_check (applistc (constant "proj1") [c1;c2;mkVar s]) gl
- else if pf_conv_x_leq gl c2 concl then
- exact_check (applistc (constant "proj2") [c1;c2;mkVar s]) gl
- else
- arec al
- | _ -> assert false
- else
- arec al
- in
- arec (pf_hyps_types gl)
-
-(* automatic: see above *)
-
-let (automatic : tactic) =
- tclTHEN
- loop_ids
- (fun gl ->
- let c = pf_concl gl in
- if pf_is_matching gl wf_nat_pattern c then
- exact_check (constant "lt_wf") gl
- else if pf_is_matching gl wf_z_pattern c then
- let (_,z) = List.hd (pf_matches gl wf_z_pattern c) in
- exact_check (Term.applist (constant "Zwf_well_founded",[z])) gl
- else if pf_is_matching gl and_pattern c then
- (tclORELSE assumption_bis
- (tclTRY (tclTHEN simplest_split assumption))) gl
- else if pf_is_matching gl eq_pattern c then
- (tclORELSE reflexivity (tclTRY assumption_bis)) gl
- else
- tclTRY assumption_bis gl)
-
-(* [correctness s p] : string -> program -> tactic option -> unit
- *
- * Vernac: Correctness <string> <program> [; <tactic>].
- *)
-
-let reduce_open_constr (em0,c) =
- let existential_map_of_constr =
- let rec collect em c = match kind_of_term c with
- | Cast (c',t) ->
- (match kind_of_term c' with
- | Evar (ev,_) ->
- if not (Evd.mem em ev) then
- Evd.add em ev (Evd.find em0 ev)
- else
- em
- | _ -> fold_constr collect em c)
- | Evar _ ->
- assert false (* all existentials should be casted *)
- | _ ->
- fold_constr collect em c
- in
- collect Evd.empty
- in
- let c = Pred.red_cci c in
- let em = existential_map_of_constr c in
- (em,c)
-
-let register id n =
- let id' = match n with None -> id | Some id' -> id' in
- Penv.register id id'
-
- (* On dit à la commande "Save" d'enregistrer les nouveaux programmes *)
-let correctness_hook _ ref =
- let pf_id = Nametab.id_of_global ref in
- register pf_id None
-
-let correctness s p opttac =
- Coqlib.check_required_library ["Coq";"correctness";"Correctness"];
- Pmisc.reset_names();
- let p,oc,cty,v = coqast_of_prog p in
- let env = Global.env () in
- let sign = Global.named_context () in
- let sigma = Evd.empty in
- let cty = Reduction.nf_betaiota cty in
- let id = id_of_string s in
- start_proof id (IsGlobal (Proof Lemma)) sign cty correctness_hook;
- Penv.new_edited id (v,p);
- if !debug then msg (Pfedit.pr_open_subgoals());
- deb_mess (str"Pred.red_cci: Reduction..." ++ fnl ());
- let oc = reduce_open_constr oc in
- deb_mess (str"AFTER REDUCTION:" ++ fnl ());
- deb_print (Printer.pr_lconstr_env (Global.env())) (snd oc);
- let tac = (tclTHEN (Extratactics.refine_tac oc) automatic) in
- let tac = match opttac with
- | None -> tac
- | Some t -> tclTHEN tac t
- in
- solve_nth 1 tac;
- if_verbose msg (pr_open_subgoals ())
diff --git a/contrib/correctness/ptactic.mli b/contrib/correctness/ptactic.mli
deleted file mode 100644
index 87378cff..00000000
--- a/contrib/correctness/ptactic.mli
+++ /dev/null
@@ -1,22 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptactic.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-(* The main tactic: takes a name N, a program P, creates a goal
- * of name N with the functional specification of P, then apply the Refine
- * tactic with the partial proof term obtained by the translation of
- * P into a functional program.
- *
- * Then an ad-hoc automatic tactic is applied on each subgoal to solve the
- * trivial proof obligations *)
-
-val correctness : string -> Past.program -> Tacmach.tactic option -> unit
-
diff --git a/contrib/correctness/ptype.mli b/contrib/correctness/ptype.mli
deleted file mode 100644
index be181bcc..00000000
--- a/contrib/correctness/ptype.mli
+++ /dev/null
@@ -1,73 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptype.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Term
-
-(* Types des valeurs (V) et des calculs (C).
- *
- * On a C = r:V,E,P,Q
- *
- * et V = (x1:V1)...(xn:Vn)C | V ref | V array | <type pur>
- *
- * INVARIANT: l'effet E contient toutes les variables apparaissant dans
- * le programme ET les annotations P et Q
- * Si E = { x1,...,xn | y1,...,ym }, les variables x sont les
- * variables en lecture seule et y1 les variables modifiées
- * les xi sont libres dans P et Q, et les yi,result liées dans Q
- * i.e. P = p(x)
- * et Q = [y1]...[yn][res]q(x,y,res)
- *)
-
-(* pre and post conditions *)
-
-type 'a precondition = { p_assert : bool; p_name : Names.name; p_value : 'a }
-
-type 'a assertion = { a_name : Names.name; a_value : 'a }
-
-type 'a postcondition = 'a assertion
-
-type predicate = constr assertion
-
-(* binders *)
-
-type 'a binder_type =
- BindType of 'a
- | BindSet
- | Untyped
-
-type 'a binder = Names.identifier * 'a binder_type
-
-(* variant *)
-
-type variant = constr * constr * constr (* phi, R, A *)
-
-(* types des valeurs *)
-
-type 'a ml_type_v =
- Ref of 'a ml_type_v
- | Array of 'a * 'a ml_type_v (* size x type *)
- | Arrow of 'a ml_type_v binder list * 'a ml_type_c
-
- | TypePure of 'a
-
-(* et type des calculs *)
-
-and 'a ml_type_c =
- (Names.identifier * 'a ml_type_v)
- * Peffect.t
- * ('a precondition list) * ('a postcondition option)
-
-(* at beginning they contain Coq AST but they become constr after typing *)
-type type_v = constr ml_type_v
-type type_c = constr ml_type_c
-
-
diff --git a/contrib/correctness/ptyping.ml b/contrib/correctness/ptyping.ml
deleted file mode 100644
index 91c1f293..00000000
--- a/contrib/correctness/ptyping.ml
+++ /dev/null
@@ -1,600 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptyping.ml 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Util
-open Names
-open Term
-open Termops
-open Environ
-open Constrintern
-open Himsg
-open Proof_trees
-open Topconstr
-
-open Pmisc
-open Putil
-open Prename
-open Ptype
-open Past
-open Penv
-open Peffect
-open Pcicenv
-
-(* Ce module implante le jugement Gamma |-a e : kappa de la thèse.
- * Les annotations passent du type CoqAst.t au type Term.constr ici.
- * Les post-conditions sont abstraites par rapport au résultat. *)
-
-let simplify_type_of env sigma t =
- Reductionops.nf_betaiota (Typing.type_of env sigma t)
-
-let just_reads e =
- difference (get_reads e) (get_writes e)
-
-let type_v_sup loc t1 t2 =
- if t1 = t2 then
- t1
- else
- Perror.if_branches loc
-
-let typed_var ren env (phi,r) =
- let sign = Pcicenv.before_after_sign_of ren env in
- let a = simplify_type_of (Global.env_of_context sign) Evd.empty phi in
- (phi,r,a)
-
-(* Application de fonction *)
-
-let rec convert = function
- | (TypePure c1, TypePure c2) ->
- Reductionops.is_conv (Global.env ()) Evd.empty c1 c2
- | (Ref v1, Ref v2) ->
- convert (v1,v2)
- | (Array (s1,v1), Array (s2,v2)) ->
- (Reductionops.is_conv (Global.env ()) Evd.empty s1 s2) && (convert (v1,v2))
- | (v1,v2) -> v1 = v2
-
-let effect_app ren env f args =
- let n = List.length args in
- let tf =
- let ((_,v),_,_,_) = f.info.kappa in
- match v with TypePure c -> v_of_constr c | _ -> v
- in
- let bl,c =
- match tf with
- Arrow (bl, c) ->
- if List.length bl <> n then Perror.partial_app f.loc;
- bl,c
- | _ -> Perror.app_of_non_function f.loc
- in
- let check_type loc v t so =
- let v' = type_v_rsubst so v in
- if not (convert (v',t)) then Perror.expected_type loc (pp_type_v v')
- in
- let s,so,ok =
- (* s est la substitution des références, so celle des autres arg.
- * ok nous dit si les arguments sont sans effet i.e. des expressions *)
- List.fold_left
- (fun (s,so,ok) (b,a) ->
- match b,a with
- (id,BindType (Ref _ | Array _ as v)), Refarg id' ->
- let ta = type_in_env env id' in
- check_type f.loc v ta so;
- (id,id')::s, so, ok
- | _, Refarg _ -> Perror.should_be_a_variable f.loc
- | (id,BindType v), Term t ->
- let ((_,ta),_,_,_) = t.info.kappa in
- check_type t.loc v ta so;
- (match t.desc with
- Expression c -> s, (id,c)::so, ok
- | _ -> s,so,false)
- | (id,BindSet), Type v ->
- let c = Pmonad.trad_ml_type_v ren env v in
- s, (id,c)::so, ok
- | (id,BindSet), Term t -> Perror.expects_a_type id t.loc
- | (id,BindType _), Type _ -> Perror.expects_a_term id
- | (_,Untyped), _ -> invalid_arg "effects_app")
- ([],[],true)
- (List.combine bl args)
- in
- let (id,v),ef,pre,post = type_c_subst s c in
- (bl,c), (s,so,ok), ((id,type_v_rsubst so v),ef,pre,post)
-
-(* Execution of a Coq AST. Returns value and type.
- * Also returns its variables *)
-
-let state_coq_ast sign a =
- let env = Global.env_of_context sign in
- let j =
- reraise_with_loc (constr_loc a) (judgment_of_rawconstr Evd.empty env) a in
- let ids = global_vars env j.uj_val in
- j.uj_val, j.uj_type, ids
-
-(* [is_pure p] tests wether the program p is an expression or not. *)
-
-let type_of_expression ren env c =
- let sign = now_sign_of ren env in
- simplify_type_of (Global.env_of_context sign) Evd.empty c
-
-let rec is_pure_type_v = function
- TypePure _ -> true
- | Arrow (bl,c) -> List.for_all is_pure_arg bl & is_pure_type_c c
- | Ref _ | Array _ -> false
-and is_pure_arg = function
- (_,BindType v) -> is_pure_type_v v
- | (_,BindSet) -> true
- | (_,Untyped) -> false
-and is_pure_type_c = function
- (_,v),_,[],None -> is_pure_type_v v
- | _ -> false
-
-let rec is_pure_desc ren env = function
- Variable id ->
- not (is_in_env env id) or (is_pure_type_v (type_in_env env id))
- | Expression c ->
- (c = isevar) or (is_pure_cci (type_of_expression ren env c))
- | Acc _ -> true
- | TabAcc (_,_,p) -> is_pure ren env p
- | Apply (p,args) ->
- is_pure ren env p & List.for_all (is_pure_arg ren env) args
- | SApp _ | Aff _ | TabAff _ | Seq _ | While _ | If _
- | Lam _ | LetRef _ | Let _ | LetRec _ -> false
- | Debug (_,p) -> is_pure ren env p
- | PPoint (_,d) -> is_pure_desc ren env d
-and is_pure ren env p =
- p.pre = [] & p.post = None & is_pure_desc ren env p.desc
-and is_pure_arg ren env = function
- Term p -> is_pure ren env p
- | Type _ -> true
- | Refarg _ -> false
-
-(* [state_var ren env (phi,r)] returns a tuple (e,(phi',r'))
- * where e is the effect of the variant phi and phi',r' the corresponding
- * constr of phi and r.
- *)
-
-let state_var ren env (phi,r) =
- let sign = Pcicenv.before_after_sign_of ren env in
- let phi',_,ids = state_coq_ast sign phi in
- let ef = List.fold_left
- (fun e id ->
- if is_mutable_in_env env id then Peffect.add_read id e else e)
- Peffect.bottom ids in
- let r',_,_ = state_coq_ast (Global.named_context ()) r in
- ef,(phi',r')
-
-(* [state_pre ren env pl] returns a pair (e,c) where e is the effect of the
- * pre-conditions list pl and cl the corresponding constrs not yet abstracted
- * over the variables xi (i.e. c NOT [x1]...[xn]c !)
- *)
-
-let state_pre ren env pl =
- let state e p =
- let sign = Pcicenv.before_sign_of ren env in
- let cc,_,ids = state_coq_ast sign p.p_value in
- let ef = List.fold_left
- (fun e id ->
- if is_mutable_in_env env id then
- Peffect.add_read id e
- else if is_at id then
- let uid,_ = un_at id in
- if is_mutable_in_env env uid then
- Peffect.add_read uid e
- else
- e
- else
- e)
- e ids
- in
- ef,{ p_assert = p.p_assert; p_name = p.p_name; p_value = cc }
- in
- List.fold_left
- (fun (e,cl) p -> let ef,c = state e p in (ef,c::cl))
- (Peffect.bottom,[]) pl
-
-let state_assert ren env a =
- let p = pre_of_assert true a in
- let e,l = state_pre ren env [p] in
- e,assert_of_pre (List.hd l)
-
-let state_inv ren env = function
- None -> Peffect.bottom, None
- | Some i -> let e,p = state_assert ren env i in e,Some p
-
-(* [state_post ren env (id,v,ef) q] returns a pair (e,c)
- * where e is the effect of the
- * post-condition q and c the corresponding constr not yet abstracted
- * over the variables xi, yi and result.
- * Moreover the RW variables not appearing in ef have been replaced by
- * RO variables, and (id,v) is the result
- *)
-
-let state_post ren env (id,v,ef) = function
- None -> Peffect.bottom, None
- | Some q ->
- let v' = Pmonad.trad_ml_type_v ren env v in
- let sign = Pcicenv.before_after_result_sign_of (Some (id,v')) ren env in
- let cc,_,ids = state_coq_ast sign q.a_value in
- let ef,c =
- List.fold_left
- (fun (e,c) id ->
- if is_mutable_in_env env id then
- if is_write ef id then
- Peffect.add_write id e, c
- else
- Peffect.add_read id e,
- subst_in_constr [id,at_id id ""] c
- else if is_at id then
- let uid,_ = un_at id in
- if is_mutable_in_env env uid then
- Peffect.add_read uid e, c
- else
- e,c
- else
- e,c)
- (Peffect.bottom,cc) ids
- in
- let c = abstract [id,v'] c in
- ef, Some { a_name = q.a_name; a_value = c }
-
-(* transformation of AST into constr in types V and C *)
-
-let rec cic_type_v env ren = function
- | Ref v -> Ref (cic_type_v env ren v)
- | Array (com,v) ->
- let sign = Pcicenv.now_sign_of ren env in
- let c = interp_constr Evd.empty (Global.env_of_context sign) com in
- Array (c, cic_type_v env ren v)
- | Arrow (bl,c) ->
- let bl',ren',env' =
- List.fold_left
- (fun (bl,ren,env) b ->
- let b' = cic_binder env ren b in
- let env' = traverse_binders env [b'] in
- let ren' = initial_renaming env' in
- b'::bl,ren',env')
- ([],ren,env) bl
- in
- let c' = cic_type_c env' ren' c in
- Arrow (List.rev bl',c')
- | TypePure com ->
- let sign = Pcicenv.cci_sign_of ren env in
- let c = interp_constr Evd.empty (Global.env_of_context sign) com in
- TypePure c
-
-and cic_type_c env ren ((id,v),e,p,q) =
- let v' = cic_type_v env ren v in
- let cv = Pmonad.trad_ml_type_v ren env v' in
- let efp,p' = state_pre ren env p in
- let efq,q' = state_post ren env (id,v',e) q in
- let ef = Peffect.union e (Peffect.union efp efq) in
- ((id,v'),ef,p',q')
-
-and cic_binder env ren = function
- | (id,BindType v) ->
- let v' = cic_type_v env ren v in
- let env' = add (id,v') env in
- let ren' = initial_renaming env' in
- (id, BindType v')
- | (id,BindSet) -> (id,BindSet)
- | (id,Untyped) -> (id,Untyped)
-
-and cic_binders env ren = function
- [] -> []
- | b::bl ->
- let b' = cic_binder env ren b in
- let env' = traverse_binders env [b'] in
- let ren' = initial_renaming env' in
- b' :: (cic_binders env' ren' bl)
-
-
-(* The case of expressions.
- *
- * Expressions are programs without neither effects nor pre/post conditions.
- * But access to variables are allowed.
- *
- * Here we transform an expression into the corresponding constr,
- * the variables still appearing as VAR (they will be abstracted in
- * Mlise.trad)
- * We collect the pre-conditions (e<N for t[e]) as we traverse the term.
- * We also return the effect, which does contain only *read* variables.
- *)
-
-let states_expression ren env expr =
- let rec effect pl = function
- | Variable id ->
- (if is_global id then constant (string_of_id id) else mkVar id),
- pl, Peffect.bottom
- | Expression c -> c, pl, Peffect.bottom
- | Acc id -> mkVar id, pl, Peffect.add_read id Peffect.bottom
- | TabAcc (_,id,p) ->
- let c,pl,ef = effect pl p.desc in
- let pre = Pmonad.make_pre_access ren env id c in
- Pmonad.make_raw_access ren env (id,id) c,
- (anonymous_pre true pre)::pl, Peffect.add_read id ef
- | Apply (p,args) ->
- let a,pl,e = effect pl p.desc in
- let args,pl,e =
- List.fold_right
- (fun arg (l,pl,e) ->
- match arg with
- Term p ->
- let carg,pl,earg = effect pl p.desc in
- carg::l,pl,Peffect.union e earg
- | Type v ->
- let v' = cic_type_v env ren v in
- (Pmonad.trad_ml_type_v ren env v')::l,pl,e
- | Refarg _ -> assert false)
- args ([],pl,e)
- in
- Term.applist (a,args),pl,e
- | _ -> invalid_arg "Ptyping.states_expression"
- in
- let e0,pl0 = state_pre ren env expr.pre in
- let c,pl,e = effect [] expr.desc in
- let sign = Pcicenv.before_sign_of ren env in
- (*i WAS
- let c = (Trad.ise_resolve true empty_evd [] (gLOB sign) c)._VAL in
- i*)
- let ty = simplify_type_of (Global.env_of_context sign) Evd.empty c in
- let v = TypePure ty in
- let ef = Peffect.union e0 e in
- Expression c, (v,ef), pl0@pl
-
-
-(* We infer here the type with effects.
- * The type of types with effects (ml_type_c) is defined in the module ProgAst.
- *
- * A program of the shape {P} e {Q} has a type
- *
- * V, E, {None|Some P}, {None|Some Q}
- *
- * where - V is the type of e
- * - E = (I,O) is the effect; the input I contains
- * all the input variables appearing in P,e and Q;
- * the output O contains variables possibly modified in e
- * - P is NOT abstracted
- * - Q = [y'1]...[y'k][result]Q where O = {y'j}
- * i.e. Q is only abstracted over the output and the result
- * the other variables now refer to value BEFORE
- *)
-
-let verbose_fix = ref false
-
-let rec states_desc ren env loc = function
-
- Expression c ->
- let ty = type_of_expression ren env c in
- let v = v_of_constr ty in
- Expression c, (v,Peffect.bottom)
-
- | Acc _ ->
- failwith "Ptyping.states: term is supposed not to be pure"
-
- | Variable id ->
- let v = type_in_env env id in
- let ef = Peffect.bottom in
- Variable id, (v,ef)
-
- | Aff (x, e1) ->
- Perror.check_for_reference loc x (type_in_env env x);
- let s_e1 = states ren env e1 in
- let _,e,_,_ = s_e1.info.kappa in
- let ef = add_write x e in
- let v = constant_unit () in
- Aff (x, s_e1), (v, ef)
-
- | TabAcc (check, x, e) ->
- let s_e = states ren env e in
- let _,efe,_,_ = s_e.info.kappa in
- let ef = Peffect.add_read x efe in
- let _,ty = dearray_type (type_in_env env x) in
- TabAcc (check, x, s_e), (ty, ef)
-
- | TabAff (check, x, e1, e2) ->
- let s_e1 = states ren env e1 in
- let s_e2 = states ren env e2 in
- let _,ef1,_,_ = s_e1.info.kappa in
- let _,ef2,_,_ = s_e2.info.kappa in
- let ef = Peffect.add_write x (Peffect.union ef1 ef2) in
- let v = constant_unit () in
- TabAff (check, x, s_e1, s_e2), (v,ef)
-
- | Seq bl ->
- let bl,v,ef,_ = states_block ren env bl in
- Seq bl, (v,ef)
-
- | While(b, invopt, var, bl) ->
- let efphi,(cvar,r') = state_var ren env var in
- let ren' = next ren [] in
- let s_b = states ren' env b in
- let s_bl,_,ef_bl,_ = states_block ren' env bl in
- let cb = s_b.info.kappa in
- let efinv,inv = state_inv ren env invopt in
- let _,efb,_,_ = s_b.info.kappa in
- let ef =
- Peffect.union (Peffect.union ef_bl efb) (Peffect.union efinv efphi)
- in
- let v = constant_unit () in
- let cvar =
- let al = List.map (fun id -> (id,at_id id "")) (just_reads ef) in
- subst_in_constr al cvar
- in
- While (s_b,inv,(cvar,r'),s_bl), (v,ef)
-
- | Lam ([],_) ->
- failwith "Ptyping.states: abs. should have almost one binder"
-
- | Lam (bl, e) ->
- let bl' = cic_binders env ren bl in
- let env' = traverse_binders env bl' in
- let ren' = initial_renaming env' in
- let s_e = states ren' env' e in
- let v = make_arrow bl' s_e.info.kappa in
- let ef = Peffect.bottom in
- Lam(bl',s_e), (v,ef)
-
- (* Connectives AND and OR *)
- | SApp ([Variable id], [e1;e2]) ->
- let s_e1 = states ren env e1
- and s_e2 = states ren env e2 in
- let (_,ef1,_,_) = s_e1.info.kappa
- and (_,ef2,_,_) = s_e2.info.kappa in
- let ef = Peffect.union ef1 ef2 in
- SApp ([Variable id], [s_e1; s_e2]),
- (TypePure (constant "bool"), ef)
-
- (* Connective NOT *)
- | SApp ([Variable id], [e]) ->
- let s_e = states ren env e in
- let (_,ef,_,_) = s_e.info.kappa in
- SApp ([Variable id], [s_e]),
- (TypePure (constant "bool"), ef)
-
- | SApp _ -> invalid_arg "Ptyping.states (SApp)"
-
- (* ATTENTION:
- Si un argument réel de type ref. correspond à une ref. globale
- modifiée par la fonction alors la traduction ne sera pas correcte.
- Exemple:
- f=[x:ref Int]( r := !r+1 ; x := !x+1) modifie r et son argument x
- donc si on l'applique à r justement, elle ne modifiera que r
- mais le séquencement ne sera pas correct. *)
-
- | Apply (f, args) ->
- let s_f = states ren env f in
- let _,eff,_,_ = s_f.info.kappa in
- let s_args = List.map (states_arg ren env) args in
- let ef_args =
- List.map
- (function Term t -> let (_,e,_,_) = t.info.kappa in e
- | _ -> Peffect.bottom)
- s_args
- in
- let _,_,((_,tapp),efapp,_,_) = effect_app ren env s_f s_args in
- let ef =
- Peffect.compose (List.fold_left Peffect.compose eff ef_args) efapp
- in
- Apply (s_f, s_args), (tapp, ef)
-
- | LetRef (x, e1, e2) ->
- let s_e1 = states ren env e1 in
- let (_,v1),ef1,_,_ = s_e1.info.kappa in
- let env' = add (x,Ref v1) env in
- let ren' = next ren [x] in
- let s_e2 = states ren' env' e2 in
- let (_,v2),ef2,_,_ = s_e2.info.kappa in
- Perror.check_for_let_ref loc v2;
- let ef = Peffect.compose ef1 (Peffect.remove ef2 x) in
- LetRef (x, s_e1, s_e2), (v2,ef)
-
- | Let (x, e1, e2) ->
- let s_e1 = states ren env e1 in
- let (_,v1),ef1,_,_ = s_e1.info.kappa in
- Perror.check_for_not_mutable e1.loc v1;
- let env' = add (x,v1) env in
- let s_e2 = states ren env' e2 in
- let (_,v2),ef2,_,_ = s_e2.info.kappa in
- let ef = Peffect.compose ef1 ef2 in
- Let (x, s_e1, s_e2), (v2,ef)
-
- | If (b, e1, e2) ->
- let s_b = states ren env b in
- let s_e1 = states ren env e1
- and s_e2 = states ren env e2 in
- let (_,tb),efb,_,_ = s_b.info.kappa in
- let (_,t1),ef1,_,_ = s_e1.info.kappa in
- let (_,t2),ef2,_,_ = s_e2.info.kappa in
- let ef = Peffect.compose efb (disj ef1 ef2) in
- let v = type_v_sup loc t1 t2 in
- If (s_b, s_e1, s_e2), (v,ef)
-
- | LetRec (f,bl,v,var,e) ->
- let bl' = cic_binders env ren bl in
- let env' = traverse_binders env bl' in
- let ren' = initial_renaming env' in
- let v' = cic_type_v env' ren' v in
- let efvar,var' = state_var ren' env' var in
- let phi0 = phi_name () in
- let tvar = typed_var ren env' var' in
- (* effect for a let/rec construct is computed as a fixpoint *)
- let rec state_rec c =
- let tf = make_arrow bl' c in
- let env'' = add_recursion (f,(phi0,tvar)) (add (f,tf) env') in
- let s_e = states ren' env'' e in
- if s_e.info.kappa = c then
- s_e
- else begin
- if !verbose_fix then begin msgnl (pp_type_c s_e.info.kappa) end ;
- state_rec s_e.info.kappa
- end
- in
- let s_e = state_rec ((result_id,v'),efvar,[],None) in
- let tf = make_arrow bl' s_e.info.kappa in
- LetRec (f,bl',v',var',s_e), (tf,Peffect.bottom)
-
- | PPoint (s,d) ->
- let ren' = push_date ren s in
- states_desc ren' env loc d
-
- | Debug _ -> failwith "Ptyping.states: Debug: TODO"
-
-
-and states_arg ren env = function
- Term a -> let s_a = states ren env a in Term s_a
- | Refarg id -> Refarg id
- | Type v -> let v' = cic_type_v env ren v in Type v'
-
-
-and states ren env expr =
- (* Here we deal with the pre- and post- conditions:
- * we add their effects to the effects of the program *)
- let (d,(v,e),p1) =
- if is_pure_desc ren env expr.desc then
- states_expression ren env expr
- else
- let (d,ve) = states_desc ren env expr.loc expr.desc in (d,ve,[])
- in
- let (ep,p) = state_pre ren env expr.pre in
- let (eq,q) = state_post ren env (result_id,v,e) expr.post in
- let e' = Peffect.union e (Peffect.union ep eq) in
- let p' = p1 @ p in
- let tinfo = { env = env; kappa = ((result_id,v),e',p',q) } in
- { desc = d;
- loc = expr.loc;
- pre = p'; post = q; (* on les conserve aussi ici pour prog_wp *)
- info = tinfo }
-
-
-and states_block ren env bl =
- let rec ef_block ren tyres = function
- [] ->
- begin match tyres with
- Some ty -> [],ty,Peffect.bottom,ren
- | None -> failwith "a block should contain at least one statement"
- end
- | (Assert p)::block ->
- let ep,c = state_assert ren env p in
- let bl,t,ef,ren' = ef_block ren tyres block in
- (Assert c)::bl,t,Peffect.union ep ef,ren'
- | (Label s)::block ->
- let ren' = push_date ren s in
- let bl,t,ef,ren'' = ef_block ren' tyres block in
- (Label s)::bl,t,ef,ren''
- | (Statement e)::block ->
- let s_e = states ren env e in
- let (_,t),efe,_,_ = s_e.info.kappa in
- let ren' = next ren (get_writes efe) in
- let bl,t,ef,ren'' = ef_block ren' (Some t) block in
- (Statement s_e)::bl,t,Peffect.compose efe ef,ren''
- in
- ef_block ren None bl
-
diff --git a/contrib/correctness/ptyping.mli b/contrib/correctness/ptyping.mli
deleted file mode 100644
index eaf548b1..00000000
--- a/contrib/correctness/ptyping.mli
+++ /dev/null
@@ -1,36 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: ptyping.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Names
-open Term
-open Topconstr
-
-open Ptype
-open Past
-open Penv
-
-(* This module realizes type and effect inference *)
-
-val cic_type_v : local_env -> Prename.t -> constr_expr ml_type_v -> type_v
-
-val effect_app : Prename.t -> local_env
- -> (typing_info,'b) Past.t
- -> (typing_info,constr) arg list
- -> (type_v binder list * type_c)
- * ((identifier*identifier) list * (identifier*constr) list * bool)
- * type_c
-
-val typed_var : Prename.t -> local_env -> constr * constr -> variant
-
-val type_of_expression : Prename.t -> local_env -> constr -> constr
-
-val states : Prename.t -> local_env -> program -> typed_program
diff --git a/contrib/correctness/putil.ml b/contrib/correctness/putil.ml
deleted file mode 100644
index 18c3ba35..00000000
--- a/contrib/correctness/putil.ml
+++ /dev/null
@@ -1,303 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: putil.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-open Util
-open Names
-open Nameops
-open Term
-open Termops
-open Pattern
-open Matching
-open Hipattern
-open Environ
-
-open Pmisc
-open Ptype
-open Past
-open Penv
-open Prename
-
-let is_mutable = function Ref _ | Array _ -> true | _ -> false
-let is_pure = function TypePure _ -> true | _ -> false
-
-let named_app f x = { a_name = x.a_name; a_value = (f x.a_value) }
-
-let pre_app f x =
- { p_assert = x.p_assert; p_name = x.p_name; p_value = f x.p_value }
-
-let post_app = named_app
-
-let anonymous x = { a_name = Anonymous; a_value = x }
-
-let anonymous_pre b x = { p_assert = b; p_name = Anonymous; p_value = x }
-
-let force_name f x =
- option_map (fun q -> { a_name = Name (f q.a_name); a_value = q.a_value }) x
-
-let force_post_name x = force_name post_name x
-
-let force_bool_name x =
- force_name (function Name id -> id | Anonymous -> bool_name()) x
-
-let out_post = function
- Some { a_value = x } -> x
- | None -> invalid_arg "out_post"
-
-let pre_of_assert b x =
- { p_assert = b; p_name = x.a_name; p_value = x.a_value }
-
-let assert_of_pre x =
- { a_name = x.p_name; a_value = x.p_value }
-
-(* Some generic functions on programs *)
-
-let is_mutable_in_env env id =
- (is_in_env env id) & (is_mutable (type_in_env env id))
-
-let now_vars env c =
- Util.map_succeed
- (function id -> if is_mutable_in_env env id then id else failwith "caught")
- (global_vars (Global.env()) c)
-
-let make_before_after c =
- let ids = global_vars (Global.env()) c in
- let al =
- Util.map_succeed
- (function id ->
- if is_at id then
- match un_at id with (uid,"") -> (id,uid) | _ -> failwith "caught"
- else failwith "caught")
- ids
- in
- subst_in_constr al c
-
-(* [apply_pre] and [apply_post] instantiate pre- and post- conditions
- * according to a given renaming of variables (and a date that means
- * `before' in the case of the post-condition).
- *)
-
-let make_assoc_list ren env on_prime ids =
- List.fold_left
- (fun al id ->
- if is_mutable_in_env env id then
- (id,current_var ren id)::al
- else if is_at id then
- let uid,d = un_at id in
- if is_mutable_in_env env uid then
- (match d with
- "" -> (id,on_prime ren uid)
- | _ -> (id,var_at_date ren d uid))::al
- else
- al
- else
- al)
- [] ids
-
-let apply_pre ren env c =
- let ids = global_vars (Global.env()) c.p_value in
- let al = make_assoc_list ren env current_var ids in
- { p_assert = c.p_assert; p_name = c.p_name;
- p_value = subst_in_constr al c.p_value }
-
-let apply_assert ren env c =
- let ids = global_vars (Global.env()) c.a_value in
- let al = make_assoc_list ren env current_var ids in
- { a_name = c.a_name; a_value = subst_in_constr al c.a_value }
-
-let apply_post ren env before c =
- let ids = global_vars (Global.env()) c.a_value in
- let al =
- make_assoc_list ren env (fun r uid -> var_at_date r before uid) ids in
- { a_name = c.a_name; a_value = subst_in_constr al c.a_value }
-
-(* [traverse_binder ren env bl] updates renaming [ren] and environment [env]
- * as we cross the binders [bl]
- *)
-
-let rec traverse_binders env = function
- [] -> env
- | (id,BindType v)::rem ->
- traverse_binders (add (id,v) env) rem
- | (id,BindSet)::rem ->
- traverse_binders (add_set id env) rem
- | (_,Untyped)::_ ->
- invalid_arg "traverse_binders"
-
-let initial_renaming env =
- let ids = Penv.fold_all (fun (id,_) l -> id::l) env [] in
- update empty_ren "0" ids
-
-
-(* Substitutions *)
-
-let rec type_c_subst s ((id,t),e,p,q) =
- let s' = s @ List.map (fun (x,x') -> (at_id x "", at_id x' "")) s in
- (id, type_v_subst s t), Peffect.subst s e,
- List.map (pre_app (subst_in_constr s)) p,
- option_map (post_app (subst_in_constr s')) q
-
-and type_v_subst s = function
- Ref v -> Ref (type_v_subst s v)
- | Array (n,v) -> Array (n,type_v_subst s v)
- | Arrow (bl,c) -> Arrow(List.map (binder_subst s) bl, type_c_subst s c)
- | (TypePure _) as v -> v
-
-and binder_subst s = function
- (n, BindType v) -> (n, BindType (type_v_subst s v))
- | b -> b
-
-(* substitution of constr by others *)
-
-let rec type_c_rsubst s ((id,t),e,p,q) =
- (id, type_v_rsubst s t), e,
- List.map (pre_app (real_subst_in_constr s)) p,
- option_map (post_app (real_subst_in_constr s)) q
-
-and type_v_rsubst s = function
- Ref v -> Ref (type_v_rsubst s v)
- | Array (n,v) -> Array (real_subst_in_constr s n,type_v_rsubst s v)
- | Arrow (bl,c) -> Arrow(List.map (binder_rsubst s) bl, type_c_rsubst s c)
- | TypePure c -> TypePure (real_subst_in_constr s c)
-
-and binder_rsubst s = function
- | (n, BindType v) -> (n, BindType (type_v_rsubst s v))
- | b -> b
-
-(* make_arrow bl c = (x1:V1)...(xn:Vn)c *)
-
-let make_arrow bl c = match bl with
- | [] -> invalid_arg "make_arrow: no binder"
- | _ -> Arrow (bl,c)
-
-(* misc. functions *)
-
-let deref_type = function
- | Ref v -> v
- | _ -> invalid_arg "deref_type"
-
-let dearray_type = function
- | Array (size,v) -> size,v
- | _ -> invalid_arg "dearray_type"
-
-let constant_unit () = TypePure (constant "unit")
-
-let id_from_name = function Name id -> id | Anonymous -> (id_of_string "X")
-
-(* v_of_constr : traduit un type CCI en un type ML *)
-
-(* TODO: faire un test plus serieux sur le type des objets Coq *)
-let rec is_pure_cci c = match kind_of_term c with
- | Cast (c,_) -> is_pure_cci c
- | Prod(_,_,c') -> is_pure_cci c'
- | Rel _ | Ind _ | Const _ -> true (* heu... *)
- | App _ -> not (is_matching_sigma c)
- | _ -> Util.error "CCI term not acceptable in programs"
-
-let rec v_of_constr c = match kind_of_term c with
- | Cast (c,_) -> v_of_constr c
- | Prod _ ->
- let revbl,t2 = Term.decompose_prod c in
- let bl =
- List.map
- (fun (name,t1) -> (id_from_name name, BindType (v_of_constr t1)))
- (List.rev revbl)
- in
- let vars = List.rev (List.map (fun (id,_) -> mkVar id) bl) in
- Arrow (bl, c_of_constr (substl vars t2))
- | Ind _ | Const _ | App _ ->
- TypePure c
- | _ ->
- failwith "v_of_constr: TODO"
-
-and c_of_constr c =
- if is_matching_sigma c then
- let (a,q) = match_sigma c in
- (result_id, v_of_constr a), Peffect.bottom, [], Some (anonymous q)
- else
- (result_id, v_of_constr c), Peffect.bottom, [], None
-
-
-(* pretty printers (for debugging purposes) *)
-
-open Pp
-open Util
-
-let pr_lconstr x = Printer.pr_lconstr_env (Global.env()) x
-
-let pp_pre = function
- [] -> (mt ())
- | l ->
- hov 0 (str"pre " ++
- prlist_with_sep (fun () -> (spc ()))
- (fun x -> pr_lconstr x.p_value) l)
-
-let pp_post = function
- None -> (mt ())
- | Some c -> hov 0 (str"post " ++ pr_lconstr c.a_value)
-
-let rec pp_type_v = function
- Ref v -> hov 0 (pp_type_v v ++ spc () ++ str"ref")
- | Array (cc,v) -> hov 0 (str"array " ++ pr_lconstr cc ++ str" of " ++ pp_type_v v)
- | Arrow (b,c) ->
- hov 0 (prlist_with_sep (fun () -> (mt ())) pp_binder b ++
- pp_type_c c)
- | TypePure c -> pr_lconstr c
-
-and pp_type_c ((id,v),e,p,q) =
- hov 0 (str"returns " ++ pr_id id ++ str":" ++ pp_type_v v ++ spc () ++
- Peffect.pp e ++ spc () ++ pp_pre p ++ spc () ++ pp_post q ++
- spc () ++ str"end")
-
-and pp_binder = function
- id,BindType v -> (str"(" ++ pr_id id ++ str":" ++ pp_type_v v ++ str")")
- | id,BindSet -> (str"(" ++ pr_id id ++ str":Set)")
- | id,Untyped -> (str"(" ++ pr_id id ++ str")")
-
-(* pretty-print of cc-terms (intermediate terms) *)
-
-let rec pp_cc_term = function
- CC_var id -> pr_id id
- | CC_letin (_,_,bl,c,c1) ->
- hov 0 (hov 2 (str"let " ++
- prlist_with_sep (fun () -> (str","))
- (fun (id,_) -> pr_id id) bl ++
- str" =" ++ spc () ++
- pp_cc_term c ++
- str " in") ++
- fnl () ++
- pp_cc_term c1)
- | CC_lam (bl,c) ->
- hov 2 (prlist (fun (id,_) -> (str"[" ++ pr_id id ++ str"]")) bl ++
- cut () ++
- pp_cc_term c)
- | CC_app (f,args) ->
- hov 2 (str"(" ++
- pp_cc_term f ++ spc () ++
- prlist_with_sep (fun () -> (spc ())) pp_cc_term args ++
- str")")
- | CC_tuple (_,_,cl) ->
- hov 2 (str"(" ++
- prlist_with_sep (fun () -> (str"," ++ cut ()))
- pp_cc_term cl ++
- str")")
- | CC_case (_,b,[e1;e2]) ->
- hov 0 (str"if " ++ pp_cc_term b ++ str" then" ++ fnl () ++
- str" " ++ hov 0 (pp_cc_term e1) ++ fnl () ++
- str"else" ++ fnl () ++
- str" " ++ hov 0 (pp_cc_term e2))
- | CC_case _ ->
- hov 0 (str"<Case: not yet implemented>")
- | CC_expr c ->
- hov 0 (pr_lconstr c)
- | CC_hole c ->
- (str"(?::" ++ pr_lconstr c ++ str")")
-
diff --git a/contrib/correctness/putil.mli b/contrib/correctness/putil.mli
deleted file mode 100644
index 6c487f3f..00000000
--- a/contrib/correctness/putil.mli
+++ /dev/null
@@ -1,72 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: putil.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Pp
-open Names
-open Term
-open Pmisc
-open Ptype
-open Past
-open Penv
-
-val is_mutable : 'a ml_type_v -> bool
-val is_pure : 'a ml_type_v -> bool
-
-val named_app : ('a -> 'b) -> 'a assertion -> 'b assertion
-val pre_app : ('a -> 'b) -> 'a precondition -> 'b precondition
-val post_app : ('a -> 'b) -> 'a postcondition -> 'b postcondition
-
-val anonymous : 'a -> 'a assertion
-val anonymous_pre : bool -> 'a -> 'a precondition
-val out_post : 'a postcondition option -> 'a
-val pre_of_assert : bool -> 'a assertion -> 'a precondition
-val assert_of_pre : 'a precondition -> 'a assertion
-
-val force_post_name : 'a postcondition option -> 'a postcondition option
-val force_bool_name : 'a postcondition option -> 'a postcondition option
-
-val make_before_after : constr -> constr
-
-val traverse_binders : local_env -> (type_v binder) list -> local_env
-val initial_renaming : local_env -> Prename.t
-
-val apply_pre : Prename.t -> local_env -> constr precondition ->
- constr precondition
-val apply_post : Prename.t -> local_env -> string -> constr postcondition ->
- constr postcondition
-val apply_assert : Prename.t -> local_env -> constr assertion ->
- constr assertion
-
-val type_v_subst : (identifier * identifier) list -> type_v -> type_v
-val type_c_subst : (identifier * identifier) list -> type_c -> type_c
-
-val type_v_rsubst : (identifier * constr) list -> type_v -> type_v
-val type_c_rsubst : (identifier * constr) list -> type_c -> type_c
-
-val make_arrow : ('a ml_type_v binder) list -> 'a ml_type_c -> 'a ml_type_v
-
-val is_mutable_in_env : local_env -> identifier -> bool
-val now_vars : local_env -> constr -> identifier list
-
-val deref_type : 'a ml_type_v -> 'a ml_type_v
-val dearray_type : 'a ml_type_v -> 'a * 'a ml_type_v
-val constant_unit : unit -> constr ml_type_v
-val v_of_constr : constr -> constr ml_type_v
-val c_of_constr : constr -> constr ml_type_c
-val is_pure_cci : constr -> bool
-
-(* pretty printers *)
-
-val pp_type_v : type_v -> std_ppcmds
-val pp_type_c : type_c -> std_ppcmds
-val pp_cc_term : cc_term -> std_ppcmds
-
diff --git a/contrib/correctness/pwp.ml b/contrib/correctness/pwp.ml
deleted file mode 100644
index f422c5cd..00000000
--- a/contrib/correctness/pwp.ml
+++ /dev/null
@@ -1,347 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pwp.ml 8752 2006-04-27 19:37:33Z herbelin $ *)
-
-open Util
-open Names
-open Libnames
-open Term
-open Termops
-open Environ
-open Nametab
-
-open Pmisc
-open Ptype
-open Past
-open Putil
-open Penv
-open Peffect
-open Ptyping
-open Prename
-
-(* In this module:
- * - we try to insert more annotations to achieve a greater completeness;
- * - we recursively propagate annotations inside programs;
- * - we normalize boolean expressions.
- *
- * The propagation schemas are the following:
- *
- * 1. (f a1 ... an) -> (f a1 ... an) {Qf} if the ai are functional
- *
- * 2. (if e1 then e2 else e3) {Q} -> (if e1 then e2 {Q} else e3 {Q}) {Q}
- *
- * 3. (let x = e1 in e2) {Q} -> (let x = e1 in e2 {Q}) {Q}
- *)
-
-(* force a post-condition *)
-let update_post env top ef c =
- let i,o = Peffect.get_repr ef in
- let al =
- List.fold_left
- (fun l id ->
- if is_mutable_in_env env id then
- if is_write ef id then l else (id,at_id id "")::l
- else if is_at id then
- let (uid,d) = un_at id in
- if is_mutable_in_env env uid & d="" then
- (id,at_id uid top)::l
- else
- l
- else
- l)
- [] (global_vars (Global.env()) c)
- in
- subst_in_constr al c
-
-let force_post up env top q e =
- let (res,ef,p,_) = e.info.kappa in
- let q' =
- if up then option_map (named_app (update_post env top ef)) q else q
- in
- let i = { env = e.info.env; kappa = (res,ef,p,q') } in
- { desc = e.desc; pre = e.pre; post = q'; loc = e.loc; info = i }
-
-(* put a post-condition if none is present *)
-let post_if_none_up env top q = function
- | { post = None } as p -> force_post true env top q p
- | p -> p
-
-let post_if_none env q = function
- | { post = None } as p -> force_post false env "" q p
- | p -> p
-
-(* [annotation_candidate p] determines if p is a candidate for a
- * post-condition *)
-
-let annotation_candidate = function
- | { desc = If _ | Let _ | LetRef _ ; post = None } -> true
- | _ -> false
-
-(* [extract_pre p] erase the pre-condition of p and returns it *)
-let extract_pre pr =
- let (v,e,p,q) = pr.info.kappa in
- { desc = pr.desc; pre = []; post = pr.post; loc = pr.loc;
- info = { env = pr.info.env; kappa = (v,e,[],q) } },
- p
-
-(* adds some pre-conditions *)
-let add_pre p1 pr =
- let (v,e,p,q) = pr.info.kappa in
- let p' = p1 @ p in
- { desc = pr.desc; pre = p'; post = pr.post; loc = pr.loc;
- info = { env = pr.info.env; kappa = (v,e,p',q) } }
-
-(* change the statement *)
-let change_desc p d =
- { desc = d; pre = p.pre; post = p.post; loc = p.loc; info = p.info }
-
-let create_bool_post c =
- Some { a_value = c; a_name = Name (bool_name()) }
-
-(* [normalize_boolean b] checks if the boolean expression b (of type bool) is
- * annotated, and if it is not the case tries to add the annotation
- * (if result then c=true else c=false) if b is an expression c.
- *)
-
-let is_bool = function
- | TypePure c ->
- (match kind_of_term (strip_outer_cast c) with
- | Ind op ->
- string_of_id (id_of_global (IndRef op)) = "bool"
- | _ -> false)
- | _ -> false
-
-let normalize_boolean ren env b =
- let ((res,v),ef,p,q) = b.info.kappa in
- Perror.check_no_effect b.loc ef;
- if is_bool v then
- match q with
- | Some _ ->
- (* il y a une annotation : on se contente de lui forcer un nom *)
- let q = force_bool_name q in
- { desc = b.desc; pre = b.pre; post = q; loc = b.loc;
- info = { env = b.info.env; kappa = ((res,v),ef,p,q) } }
- | None -> begin
- (* il n'y a pas d'annotation : on cherche à en mettre une *)
- match b.desc with
- Expression c ->
- let c' = Term.applist (constant "annot_bool",[c]) in
- let ty = type_of_expression ren env c' in
- let (_,q') = Hipattern.match_sigma ty in
- let q' = Some { a_value = q'; a_name = Name (bool_name()) } in
- { desc = Expression c';
- pre = b.pre; post = q'; loc = b.loc;
- info = { env = b.info.env; kappa = ((res, v),ef,p,q') } }
- | _ -> b
- end
- else
- Perror.should_be_boolean b.loc
-
-(* [decomp_boolean c] returns the specs R and S of a boolean expression *)
-
-let decomp_boolean = function
- | Some { a_value = q } ->
- Reductionops.whd_betaiota (Term.applist (q, [constant "true"])),
- Reductionops.whd_betaiota (Term.applist (q, [constant "false"]))
- | _ -> invalid_arg "Ptyping.decomp_boolean"
-
-(* top point of a program *)
-
-let top_point = function
- | PPoint (s,_) as p -> s,p
- | p -> let s = label_name() in s,PPoint(s,p)
-
-let top_point_block = function
- | (Label s :: _) as b -> s,b
- | b -> let s = label_name() in s,(Label s)::b
-
-let abstract_unit q = abstract [result_id,constant "unit"] q
-
-(* [add_decreasing env ren ren' phi r bl] adds the decreasing condition
- * phi(ren') r phi(ren)
- * to the last assertion of the block [bl], which is created if needed
- *)
-
-let add_decreasing env inv (var,r) lab bl =
- let ids = now_vars env var in
- let al = List.map (fun id -> (id,at_id id lab)) ids in
- let var_lab = subst_in_constr al var in
- let dec = Term.applist (r, [var;var_lab]) in
- let post = match inv with
- None -> anonymous dec
- | Some i -> { a_value = conj dec i.a_value; a_name = i.a_name }
- in
- bl @ [ Assert post ]
-
-(* [post_last_statement env top q bl] annotates the last statement of the
- * sequence bl with q if necessary *)
-
-let post_last_statement env top q bl =
- match List.rev bl with
- | Statement e :: rem when annotation_candidate e ->
- List.rev ((Statement (post_if_none_up env top q e)) :: rem)
- | _ -> bl
-
-(* [propagate_desc] moves the annotations inside the program
- * info is the typing information coming from the outside annotations *)
-let rec propagate_desc ren info d =
- let env = info.env in
- let (_,_,p,q) = info.kappa in
- match d with
- | If (e1,e2,e3) ->
- (* propagation number 2 *)
- let e1' = normalize_boolean ren env (propagate ren e1) in
- if e2.post = None or e3.post = None then
- let top = label_name() in
- let ren' = push_date ren top in
- PPoint (top, If (e1',
- propagate ren' (post_if_none_up env top q e2),
- propagate ren' (post_if_none_up env top q e3)))
- else
- If (e1', propagate ren e2, propagate ren e3)
- | Aff (x,e) ->
- Aff (x, propagate ren e)
- | TabAcc (ch,x,e) ->
- TabAcc (ch, x, propagate ren e)
- | TabAff (ch,x,({desc=Expression c} as e1),e2) ->
- let p = Pmonad.make_pre_access ren env x c in
- let e1' = add_pre [(anonymous_pre true p)] e1 in
- TabAff (false, x, propagate ren e1', propagate ren e2)
- | TabAff (ch,x,e1,e2) ->
- TabAff (ch, x, propagate ren e1, propagate ren e2)
- | Apply (f,l) ->
- Apply (propagate ren f, List.map (propagate_arg ren) l)
- | SApp (f,l) ->
- let l =
- List.map (fun e -> normalize_boolean ren env (propagate ren e)) l
- in
- SApp (f, l)
- | Lam (bl,e) ->
- Lam (bl, propagate ren e)
- | Seq bl ->
- let top,bl = top_point_block bl in
- let bl = post_last_statement env top q bl in
- Seq (propagate_block ren env bl)
- | While (b,inv,var,bl) ->
- let b = normalize_boolean ren env (propagate ren b) in
- let lab,bl = top_point_block bl in
- let bl = add_decreasing env inv var lab bl in
- While (b,inv,var,propagate_block ren env bl)
- | LetRef (x,e1,e2) ->
- let top = label_name() in
- let ren' = push_date ren top in
- PPoint (top, LetRef (x, propagate ren' e1,
- propagate ren' (post_if_none_up env top q e2)))
- | Let (x,e1,e2) ->
- let top = label_name() in
- let ren' = push_date ren top in
- PPoint (top, Let (x, propagate ren' e1,
- propagate ren' (post_if_none_up env top q e2)))
- | LetRec (f,bl,v,var,e) ->
- LetRec (f, bl, v, var, propagate ren e)
- | PPoint (s,d) ->
- PPoint (s, propagate_desc ren info d)
- | Debug _ | Variable _
- | Acc _ | Expression _ as d -> d
-
-
-(* [propagate] adds new annotations if possible *)
-and propagate ren p =
- let env = p.info.env in
- let p = match p.desc with
- | Apply (f,l) ->
- let _,(_,so,ok),(_,_,_,qapp) = effect_app ren env f l in
- if ok then
- let q = option_map (named_app (real_subst_in_constr so)) qapp in
- post_if_none env q p
- else
- p
- | _ -> p
- in
- let d = propagate_desc ren p.info p.desc in
- let p = change_desc p d in
- match d with
- | Aff (x,e) ->
- let e1,p1 = extract_pre e in
- change_desc (add_pre p1 p) (Aff (x,e1))
-
- | TabAff (check, x, ({ desc = Expression _ } as e1), e2) ->
- let e1',p1 = extract_pre e1 in
- let e2',p2 = extract_pre e2 in
- change_desc (add_pre (p1@p2) p) (TabAff (check,x,e1',e2'))
-
- | While (b,inv,_,_) ->
- let _,s = decomp_boolean b.post in
- let s = make_before_after s in
- let q = match inv with
- None -> Some (anonymous s)
- | Some i -> Some { a_value = conj i.a_value s; a_name = i.a_name }
- in
- let q = option_map (named_app abstract_unit) q in
- post_if_none env q p
-
- | SApp ([Variable id], [e1;e2])
- when id = connective_and or id = connective_or ->
- let (_,_,_,q1) = e1.info.kappa
- and (_,_,_,q2) = e2.info.kappa in
- let (r1,s1) = decomp_boolean q1
- and (r2,s2) = decomp_boolean q2 in
- let q =
- let conn = if id = connective_and then "spec_and" else "spec_or" in
- let c = Term.applist (constant conn, [r1; s1; r2; s2]) in
- let c = Reduction.whd_betadeltaiota (Global.env()) c in
- create_bool_post c
- in
- let d =
- SApp ([Variable id;
- Expression (out_post q1);
- Expression (out_post q2)],
- [e1; e2] )
- in
- post_if_none env q (change_desc p d)
-
- | SApp ([Variable id], [e1]) when id = connective_not ->
- let (_,_,_,q1) = e1.info.kappa in
- let (r1,s1) = decomp_boolean q1 in
- let q =
- let c = Term.applist (constant "spec_not", [r1; s1]) in
- let c = Reduction.whd_betadeltaiota (Global.env ()) c in
- create_bool_post c
- in
- let d = SApp ([Variable id; Expression (out_post q1)], [ e1 ]) in
- post_if_none env q (change_desc p d)
-
- | _ -> p
-
-and propagate_arg ren = function
- | Type _ | Refarg _ as a -> a
- | Term e -> Term (propagate ren e)
-
-
-and propagate_block ren env = function
- | [] ->
- []
- | (Statement p) :: (Assert q) :: rem when annotation_candidate p ->
- (* TODO: plutot p.post = None ? *)
- let q' =
- let ((id,v),_,_,_) = p.info.kappa in
- let tv = Pmonad.trad_ml_type_v ren env v in
- named_app (abstract [id,tv]) q
- in
- let p' = post_if_none env (Some q') p in
- (Statement (propagate ren p')) :: (Assert q)
- :: (propagate_block ren env rem)
- | (Statement p) :: rem ->
- (Statement (propagate ren p)) :: (propagate_block ren env rem)
- | (Label s as x) :: rem ->
- x :: propagate_block (push_date ren s) env rem
- | x :: rem ->
- x :: propagate_block ren env rem
diff --git a/contrib/correctness/pwp.mli b/contrib/correctness/pwp.mli
deleted file mode 100644
index 4027a623..00000000
--- a/contrib/correctness/pwp.mli
+++ /dev/null
@@ -1,18 +0,0 @@
-(************************************************************************)
-(* 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 *)
-(************************************************************************)
-
-(* Certification of Imperative Programs / Jean-Christophe Filliâtre *)
-
-(* $Id: pwp.mli 5920 2004-07-16 20:01:26Z herbelin $ *)
-
-open Term
-open Penv
-
-val update_post : local_env -> string -> Peffect.t -> constr -> constr
-
-val propagate : Prename.t -> typed_program -> typed_program
diff --git a/contrib/dp/Dp.v b/contrib/dp/Dp.v
new file mode 100644
index 00000000..857c182c
--- /dev/null
+++ b/contrib/dp/Dp.v
@@ -0,0 +1,120 @@
+(* Calls to external decision procedures *)
+
+Require Export ZArith.
+Require Export Classical.
+
+(* Zenon *)
+
+(* Copyright 2004 INRIA *)
+(* $Id: Dp.v 10739 2008-04-01 14:45:20Z herbelin $ *)
+
+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/contrib/dp/TODO b/contrib/dp/TODO
index 387cacdf..44349e21 100644
--- a/contrib/dp/TODO
+++ b/contrib/dp/TODO
@@ -21,8 +21,4 @@ TODO
BUGS
----
-- value = Some : forall A:Set, A -> option A
-
- -> eta_expanse échoue sur assert false (ligne 147)
-
diff --git a/contrib/dp/dp.ml b/contrib/dp/dp.ml
index 131dd029..79ffaf3f 100644
--- a/contrib/dp/dp.ml
+++ b/contrib/dp/dp.ml
@@ -13,6 +13,8 @@
open Util
open Pp
+open Libobject
+open Summary
open Term
open Tacmach
open Tactics
@@ -25,12 +27,46 @@ 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);
+ export_function = (fun x -> Some 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);
+ export_function = (fun x -> Some 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);
+ export_function = (fun x -> Some 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"; "omega"; "OmegaLemmas"]]
let constant = gen_constant_in_modules "dp" coq_modules
@@ -52,6 +88,7 @@ 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")
(* not Prop typed expressions *)
exception NotProp
@@ -104,7 +141,7 @@ let coq_rename_vars env vars =
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 ->
+ | 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
@@ -116,7 +153,7 @@ let decomp_type_quantifiers env 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 ->
+ | 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
@@ -314,7 +351,7 @@ and make_term_abstraction tv env c =
*)
and tr_decl env id ty =
let tv, env, t = decomp_type_quantifiers env ty in
- if is_Set t then
+ if is_Set t || is_Type t then
DeclType (id, List.length tv)
else if is_Prop t then
DeclPred (id, List.length tv, [])
@@ -329,8 +366,8 @@ and tr_decl env id ty =
DeclPred(id, List.length tv, l)
else
let s = Typing.type_of env Evd.empty t in
- if is_Set s then
- DeclFun(id, List.length tv, l, tr_type tv env t)
+ if is_Set s || is_Type s then
+ DeclFun (id, List.length tv, l, tr_type tv env t)
else
raise NotFO
@@ -364,17 +401,18 @@ and axiomatize_body env r id d = match r with
begin match (Global.lookup_constant c).const_body with
| Some b ->
let b = force b in
- let tv, env, b = decomp_type_lambdas env 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;
+ (*Format.eprintf "axiomatize_body %S@." id;*)
let b = match kind_of_term b with
(* a single recursive function *)
| Fix (_, (_,_,[|b|])) ->
@@ -391,6 +429,7 @@ and axiomatize_body env r id d = match r with
| _ ->
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
@@ -401,21 +440,21 @@ and axiomatize_body env r id d = match r with
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_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 _ ->
+ | 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 p =
- Fatom (Eq (App (id, fol_vars),
- tr_term tv bv env t))
+ let t = tr_term tv bv env t in
+ let ax =
+ add_proof (Fun_def (id, vars, ty, t))
in
- [id, foralls vars p]
+ 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
@@ -436,7 +475,7 @@ and axiomatize_body env r id d = match r with
| IndRef i ->
iter_all_constructors i
(fun _ c ->
- let rc = reference_of_constr c in
+ let rc = global_of_constr c in
try
begin match tr_global env rc with
| DeclFun (_, _, [], _) -> ()
@@ -453,18 +492,20 @@ and equations_for_case env id vars tv bv ci e br = match kind_of_term e with
iter_all_constructors ci.ci_ind
(fun j cj ->
try
- let cjr = reference_of_constr cj in
+ 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 b = substl (List.map mkVar rec_vars) b 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_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
@@ -558,7 +599,7 @@ and tr_formula tv bv env f =
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 then
+ 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
@@ -581,6 +622,8 @@ and tr_formula tv bv env f =
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)
@@ -632,55 +675,164 @@ let tr_goal gl =
hyps, c
-type prover = Simplify | CVCLite | Harvey | Zenon
+type prover = Simplify | Ergo | Yices | CVCLite | Harvey | Zenon | Gwhy
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 "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 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);
+ export_function = (fun x -> Some 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" fwhy in
- if Sys.command cmd <> 0 then error ("Call to " ^ cmd ^ " failed");
+ let cmd =
+ sprintf "why --no-arrays --simplify --encoding sstrat %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 "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" fsx
+ sprintf "timeout %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 else if out = 1 then Invalid else Timeout 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; fsx];
r
+let call_ergo fwhy =
+ let cmd = sprintf "why --no-arrays --why %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
+ let cmd =
+ if !trace then
+ sprintf "ergo -cctrace %s %s" ftrace fwhy
+ else
+ sprintf "ergo %s" fwhy
+ in
+ let ret,out = timeout_sys_command cmd in
+ let r =
+ if ret <> 0 then
+ timeout_or_failure ret cmd out
+ else if Sys.command (sprintf "grep -q -w Valid %s" out) = 0 then
+ Valid (if !trace then Some ftrace else None)
+ else if Sys.command (sprintf "grep -q -w \"I don't know\" %s" out) = 0 then
+ DontKnow
+ else if Sys.command (sprintf "grep -q -w \"Invalid\" %s" out) = 0 then
+ Invalid
+ else
+ Failure ("command failed: " ^ cmd)
+ in
+ if not !debug then remove_files [fwhy; out];
+ r
+
let call_zenon fwhy =
- let cmd = sprintf "why --no-prelude --no-zenon-prelude --zenon %s" fwhy in
+ let cmd =
+ sprintf "why --no-prelude --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
+ let out = Filename.temp_file "dp_out" "" in
let cmd =
- sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" fznn
+ 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 call_yices fwhy =
+ let cmd =
+ sprintf "why --no-arrays -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 "timeout %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
- else if out = 1 then Invalid
- else if out = 137 then Timeout
- else anomaly ("malformed Zenon input file " ^ fznn)
+ if out = 0 then Valid None else if out = 1 then Invalid else Timeout
in
- if not !debug then remove_files [fwhy; fznn];
+ if not !debug then remove_files [fwhy; fsmt];
r
let call_cvcl fwhy =
- let cmd = sprintf "why --cvcl %s" fwhy in
+ let cmd =
+ sprintf "why --no-arrays --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 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" fcvc
+ 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 else if out = 1 then Invalid else Timeout 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; fcvc];
r
let call_harvey fwhy =
- let cmd = sprintf "why --harvey %s" fwhy in
+ let cmd =
+ sprintf "why --no-arrays --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
@@ -688,7 +840,8 @@ let call_harvey fwhy =
let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in
let outf = Filename.temp_file "rv" ".out" in
let out =
- Sys.command (sprintf "timeout 10 rv -e\"-T 2000\" %s > %s 2>&1" f outf)
+ Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1"
+ !timeout f outf)
in
let r =
if out <> 0 then
@@ -697,40 +850,69 @@ let call_harvey fwhy =
let cmd =
sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf
in
- if Sys.command cmd = 0 then Valid else Invalid
+ if Sys.command cmd = 0 then Valid None else Invalid
in
if not !debug then remove_files [fwhy; frv; outf];
r
+let call_gwhy fwhy =
+ let cmd = sprintf "gwhy --no-arrays %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;
- if !debug then ignore (Sys.command (sprintf "cat %s" fwhy));
match prover with
| Simplify -> call_simplify fwhy
+ | Ergo -> call_ergo fwhy
+ | Yices -> call_yices 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 -> Tactics.admit_as_an_axiom gl
+ | 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 yices = tclTHEN intros (dp Yices)
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
@@ -741,7 +923,8 @@ let dp_hint l =
if is_Prop s then
try
let id = rename_global r in
- let d = Axiom (id, tr_formula [] [] env ty) 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 ->
@@ -757,3 +940,52 @@ let dp_hint l =
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);
+ export_function = (fun x -> Some x)}
+
+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);
+ export_function = (fun x -> Some x)}
+
+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 := []);
+ survive_module = true;
+ survive_section = true }
diff --git a/contrib/dp/dp.mli b/contrib/dp/dp.mli
index 3dad469c..6dbc05e1 100644
--- a/contrib/dp/dp.mli
+++ b/contrib/dp/dp.mli
@@ -3,10 +3,18 @@ open Libnames
open Proof_type
val simplify : tactic
+val ergo : tactic
+val yices : tactic
val cvc_lite : tactic
val harvey : tactic
val zenon : tactic
+val gwhy : 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/contrib/dp/dp_cvcl.ml b/contrib/dp/dp_cvcl.ml
deleted file mode 100644
index 05d43081..00000000
--- a/contrib/dp/dp_cvcl.ml
+++ /dev/null
@@ -1,112 +0,0 @@
-
-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_term fmt = function
- | Cst n ->
- fprintf fmt "%d" 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
- | App (id, []) ->
- fprintf fmt "@[%s@]" id
- | App (id, tl) ->
- fprintf fmt "@[%s(%a)@]" 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 "@[%s@]" id
- | Fatom (Pred (id, tl)) ->
- fprintf fmt "@[%s(%a)@]" id print_terms tl
- | Imp (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 (%s:%s): %a)@]" id t pp p
- | Exists (id, t, p) ->
- fprintf fmt "@[(EXISTS (%s:%s): %a)@]" id t pp p
-
-let rec string_of_type_list = function
- | [] -> assert false
- | [e] -> e
- | e :: l' -> e ^ ", " ^ (string_of_type_list l')
-
-let print_query fmt (decls,concl) =
- let print_decl = function
- | DeclVar (id, [], t) ->
- fprintf fmt "@[%s: %s;@]@\n" id t
- | DeclVar (id, [e], t) ->
- fprintf fmt "@[%s: [%s -> %s];@]@\n"
- id e t
- | DeclVar (id, l, t) ->
- fprintf fmt "@[%s: [[%s] -> %s];@]@\n"
- id (string_of_type_list l) t
- | DeclPred (id, []) ->
- fprintf fmt "@[%s: BOOLEAN;@]@\n" id
- | DeclPred (id, [e]) ->
- fprintf fmt "@[%s: [%s -> BOOLEAN];@]@\n"
- id e
- | DeclPred (id, l) ->
- fprintf fmt "@[%s: [[%s] -> BOOLEAN];@]@\n"
- id (string_of_type_list l)
- | DeclType id ->
- fprintf fmt "@[%s: TYPE;@]@\n" id
- | Assert (id, f) ->
- fprintf fmt "@[ASSERT %% %s@\n %a;@]@\n" id print_predicate f
- in
- List.iter print_decl decls;
- fprintf fmt "QUERY %a;" print_predicate concl
-
-let call q =
- let f = Filename.temp_file "coq_dp" ".cvc" in
- let c = open_out f in
- let fmt = formatter_of_out_channel c in
- fprintf fmt "@[%a@]@." print_query q;
- close_out c;
- ignore (Sys.command (sprintf "cat %s" f));
- let cmd =
- sprintf "timeout 10 cvcl < %s > out 2>&1 && grep -q -w Valid out" f
- in
- prerr_endline cmd; flush stderr;
- let out = Sys.command cmd in
- if out = 0 then Valid else if out = 1 then Invalid else Timeout
- (* TODO: effacer le fichier f et le fichier out *)
-
-
diff --git a/contrib/dp/dp_cvcl.mli b/contrib/dp/dp_cvcl.mli
deleted file mode 100644
index 03b6d347..00000000
--- a/contrib/dp/dp_cvcl.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-
-open Fol
-
-val call : query -> prover_answer
diff --git a/contrib/dp/dp_gappa.ml b/contrib/dp/dp_gappa.ml
new file mode 100644
index 00000000..70439a97
--- /dev/null
+++ b/contrib/dp/dp_gappa.ml
@@ -0,0 +1,445 @@
+
+open Format
+open Util
+open Pp
+open Term
+open Tacmach
+open Tactics
+open Tacticals
+open Names
+open Nameops
+open Termops
+open Coqlib
+open Hipattern
+open Libnames
+open Declarations
+open Evarutil
+
+let debug = ref false
+
+(* 1. gappa syntax trees and output *)
+
+module Constant = struct
+
+ open Bigint
+
+ type t = { mantissa : bigint; base : int; exp : bigint }
+
+ let create (b, m, e) =
+ { mantissa = m; base = b; exp = e }
+
+ let of_int x =
+ { mantissa = x; base = 1; exp = zero }
+
+ let print fmt x = match x.base with
+ | 1 -> fprintf fmt "%s" (to_string x.mantissa)
+ | 2 -> fprintf fmt "%sb%s" (to_string x.mantissa) (to_string x.exp)
+ | 10 -> fprintf fmt "%se%s" (to_string x.mantissa) (to_string x.exp)
+ | _ -> assert false
+
+end
+
+type binop = Bminus | Bplus | Bmult | Bdiv
+
+type unop = Usqrt | Uabs | Uopp
+
+type rounding_mode = string
+
+type term =
+ | Tconst of Constant.t
+ | Tvar of string
+ | Tbinop of binop * term * term
+ | Tunop of unop * term
+ | Tround of rounding_mode * term
+
+type pred =
+ | Pin of term * Constant.t * Constant.t
+
+let rec print_term fmt = function
+ | Tconst c -> Constant.print fmt c
+ | Tvar s -> pp_print_string fmt s
+ | Tbinop (op, t1, t2) ->
+ let op = match op with
+ | Bplus -> "+" | Bminus -> "-" | Bmult -> "*" | Bdiv -> "/"
+ in
+ fprintf fmt "(%a %s %a)" print_term t1 op print_term t2
+ | Tunop (Uabs, t) ->
+ fprintf fmt "|%a|" print_term t
+ | Tunop (Uopp | Usqrt as op, t) ->
+ let s = match op with
+ | Uopp -> "-" | Usqrt -> "sqrt" | _ -> assert false
+ in
+ fprintf fmt "(%s(%a))" s print_term t
+ | Tround (m, t) ->
+ fprintf fmt "(%s(%a))" m print_term t
+
+let print_pred fmt = function
+ | Pin (t, c1, c2) ->
+ fprintf fmt "%a in [%a, %a]"
+ print_term t Constant.print c1 Constant.print c2
+
+let temp_file f = if !debug then f else Filename.temp_file f ".v"
+let remove_file f = if not !debug then try Sys.remove f with _ -> ()
+
+let read_gappa_proof f =
+ let buf = Buffer.create 1024 in
+ Buffer.add_char buf '(';
+ let cin = open_in f in
+ let rec skip_space () =
+ let c = input_char cin in if c = ' ' then skip_space () else c
+ in
+ while input_char cin <> '=' do () done;
+ try
+ while true do
+ let c = skip_space () in
+ if c = ':' then raise Exit;
+ Buffer.add_char buf c;
+ let s = input_line cin in
+ Buffer.add_string buf s;
+ Buffer.add_char buf '\n';
+ done;
+ assert false
+ with Exit ->
+ close_in cin;
+ remove_file f;
+ Buffer.add_char buf ')';
+ Buffer.contents buf
+
+exception GappaFailed
+exception GappaProofFailed
+
+let patch_gappa_proof fin fout =
+ let cin = open_in fin in
+ let cout = open_out fout in
+ let fmt = formatter_of_out_channel cout in
+ let last = ref "" in
+ let defs = ref "" in
+ try
+ while true do
+ let s = input_line cin in
+ if s = "Qed." then
+ fprintf fmt "Defined.@\n"
+ else begin
+ begin
+ try Scanf.sscanf s "Lemma %s "
+ (fun n -> defs := n ^ " " ^ !defs; last := n)
+ with Scanf.Scan_failure _ ->
+ try Scanf.sscanf s "Definition %s "
+ (fun n -> defs := n ^ " " ^ !defs)
+ with Scanf.Scan_failure _ ->
+ ()
+ end;
+ fprintf fmt "%s@\n" s
+ end
+ done
+ with End_of_file ->
+ close_in cin;
+ fprintf fmt "Definition proof := Eval cbv delta [%s] in %s.@." !defs !last;
+ close_out cout
+
+let call_gappa hl p =
+ let gappa_in = temp_file "gappa_input" in
+ let c = open_out gappa_in in
+ let fmt = formatter_of_out_channel c in
+ fprintf fmt "@[{ ";
+ List.iter (fun h -> fprintf fmt "%a ->@ " print_pred h) hl;
+ fprintf fmt "%a }@]@." print_pred p;
+ close_out c;
+ let gappa_out = temp_file "gappa_output" in
+ let cmd = sprintf "gappa -Bcoq < %s > %s 2> /dev/null" gappa_in gappa_out in
+ let out = Sys.command cmd in
+ if out <> 0 then raise GappaFailed;
+ remove_file gappa_in;
+ let gappa_out2 = temp_file "gappa2" in
+ patch_gappa_proof gappa_out gappa_out2;
+ remove_file gappa_out;
+ let cmd = sprintf "%s/coqc %s" Coq_config.bindir gappa_out2 in
+ let out = Sys.command cmd in
+ if out <> 0 then raise GappaProofFailed;
+ let gappa_out3 = temp_file "gappa3" in
+ let c = open_out gappa_out3 in
+ let gappa2 = Filename.chop_suffix (Filename.basename gappa_out2) ".v" in
+ Printf.fprintf c
+ "Require \"%s\". Set Printing Depth 9999999. Print %s.proof."
+ (Filename.chop_suffix gappa_out2 ".v") gappa2;
+ close_out c;
+ let lambda = temp_file "gappa_lambda" in
+ let cmd = sprintf "%s/coqc %s > %s" Coq_config.bindir gappa_out3 lambda in
+ let out = Sys.command cmd in
+ if out <> 0 then raise GappaProofFailed;
+ remove_file gappa_out2; remove_file gappa_out3;
+ remove_file (gappa_out2 ^ "o"); remove_file (gappa_out3 ^ "o");
+ read_gappa_proof lambda
+
+(* 2. coq -> gappa translation *)
+
+exception NotGappa
+
+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";];
+ ["Gappa"; "Gappa_tactic";];
+ ["Gappa"; "Gappa_fixed";];
+ ["Gappa"; "Gappa_float";];
+ ["Gappa"; "Gappa_round_def";];
+ ["Gappa"; "Gappa_pred_bnd";];
+ ["Gappa"; "Gappa_definitions";];
+ ]
+
+let constant = gen_constant_in_modules "gappa" coq_modules
+
+let coq_refl_equal = lazy (constant "refl_equal")
+let coq_Rle = lazy (constant "Rle")
+let coq_R = lazy (constant "R")
+(*
+let coq_Rplus = lazy (constant "Rplus")
+let coq_Rminus = lazy (constant "Rminus")
+let coq_Rmult = lazy (constant "Rmult")
+let coq_Rdiv = lazy (constant "Rdiv")
+let coq_powerRZ = lazy (constant "powerRZ")
+let coq_R1 = lazy (constant "R1")
+let coq_Ropp = lazy (constant "Ropp")
+let coq_Rabs = lazy (constant "Rabs")
+let coq_sqrt = lazy (constant "sqrt")
+*)
+
+let coq_convert = lazy (constant "convert")
+let coq_reUnknown = lazy (constant "reUnknown")
+let coq_reFloat2 = lazy (constant "reFloat2")
+let coq_reFloat10 = lazy (constant "reFloat10")
+let coq_reInteger = lazy (constant "reInteger")
+let coq_reBinary = lazy (constant "reBinary")
+let coq_reUnary = lazy (constant "reUnary")
+let coq_reRound = lazy (constant "reRound")
+let coq_roundDN = lazy (constant "roundDN")
+let coq_roundUP = lazy (constant "roundUP")
+let coq_roundNE = lazy (constant "roundNE")
+let coq_roundZR = lazy (constant "roundZR")
+let coq_rounding_fixed = lazy (constant "rounding_fixed")
+let coq_rounding_float = lazy (constant "rounding_float")
+let coq_boAdd = lazy (constant "boAdd")
+let coq_boSub = lazy (constant "boSub")
+let coq_boMul = lazy (constant "boMul")
+let coq_boDiv = lazy (constant "boDiv")
+let coq_uoAbs = lazy (constant "uoAbs")
+let coq_uoNeg = lazy (constant "uoNeg")
+let coq_uoSqrt = lazy (constant "uoSqrt")
+let coq_subset = lazy (constant "subset")
+let coq_makepairF = lazy (constant "makepairF")
+
+let coq_true = lazy (constant "true")
+let coq_false = lazy (constant "false")
+
+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_IZR = lazy (constant "IZR")
+
+(* translates a closed Coq term p:positive into a FOL term of type int *)
+let rec tr_positive p = match kind_of_term p with
+ | Term.Construct _ when p = Lazy.force coq_xH ->
+ 1
+ | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
+ 2 * (tr_positive a) + 1
+ | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
+ 2 * (tr_positive a)
+ | Term.Cast (p, _, _) ->
+ tr_positive p
+ | _ ->
+ raise NotGappa
+
+(* translates a closed Coq term t:Z into a term of type int *)
+let rec tr_arith_constant t = match kind_of_term t with
+ | Term.Construct _ when t = Lazy.force coq_Z0 -> 0
+ | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_positive a
+ | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg -> - (tr_positive a)
+ | Term.Cast (t, _, _) -> tr_arith_constant t
+ | _ -> raise NotGappa
+
+(* translates a closed Coq term p:positive into a FOL term of type bigint *)
+let rec tr_bigpositive p = match kind_of_term p with
+ | Term.Construct _ when p = Lazy.force coq_xH ->
+ Bigint.one
+ | Term.App (f, [|a|]) when f = Lazy.force coq_xI ->
+ Bigint.add_1 (Bigint.mult_2 (tr_bigpositive a))
+ | Term.App (f, [|a|]) when f = Lazy.force coq_xO ->
+ (Bigint.mult_2 (tr_bigpositive a))
+ | Term.Cast (p, _, _) ->
+ tr_bigpositive p
+ | _ ->
+ raise NotGappa
+
+(* translates a closed Coq term t:Z into a term of type bigint *)
+let rec tr_arith_bigconstant t = match kind_of_term t with
+ | Term.Construct _ when t = Lazy.force coq_Z0 -> Bigint.zero
+ | Term.App (f, [|a|]) when f = Lazy.force coq_Zpos -> tr_bigpositive a
+ | Term.App (f, [|a|]) when f = Lazy.force coq_Zneg ->
+ Bigint.neg (tr_bigpositive a)
+ | Term.Cast (t, _, _) -> tr_arith_bigconstant t
+ | _ -> raise NotGappa
+
+let decomp c =
+ let c, args = decompose_app c in
+ kind_of_term c, args
+
+let tr_bool c = match decompose_app c with
+ | c, [] when c = Lazy.force coq_true -> true
+ | c, [] when c = Lazy.force coq_false -> false
+ | _ -> raise NotGappa
+
+let tr_float b m e =
+ (b, tr_arith_bigconstant m, tr_arith_bigconstant e)
+
+let tr_binop c = match decompose_app c with
+ | c, [] when c = Lazy.force coq_boAdd -> Bplus
+ | c, [] when c = Lazy.force coq_boSub -> Bminus
+ | c, [] when c = Lazy.force coq_boMul -> Bmult
+ | c, [] when c = Lazy.force coq_boDiv -> Bdiv
+ | _ -> assert false
+
+let tr_unop c = match decompose_app c with
+ | c, [] when c = Lazy.force coq_uoNeg -> Uopp
+ | c, [] when c = Lazy.force coq_uoSqrt -> Usqrt
+ | c, [] when c = Lazy.force coq_uoAbs -> Uabs
+ | _ -> raise NotGappa
+
+let tr_var c = match decomp c with
+ | Var x, [] -> string_of_id x
+ | _ -> assert false
+
+let tr_mode c = match decompose_app c with
+ | c, [] when c = Lazy.force coq_roundDN -> "dn"
+ | c, [] when c = Lazy.force coq_roundNE -> "ne"
+ | c, [] when c = Lazy.force coq_roundUP -> "up"
+ | c, [] when c = Lazy.force coq_roundZR -> "zr"
+ | _ -> raise NotGappa
+
+let tr_rounding_mode c = match decompose_app c with
+ | c, [a;b] when c = Lazy.force coq_rounding_fixed ->
+ let a = tr_mode a in
+ let b = tr_arith_constant b in
+ sprintf "fixed<%d,%s>" b a
+ | c, [a;p;e] when c = Lazy.force coq_rounding_float ->
+ let a = tr_mode a in
+ let p = tr_positive p in
+ let e = tr_arith_constant e in
+ sprintf "float<%d,%d,%s>" p (-e) a
+ | _ ->
+ raise NotGappa
+
+(* REexpr -> term *)
+let rec tr_term c0 =
+ let c, args = decompose_app c0 in
+ match kind_of_term c, args with
+ | _, [a] when c = Lazy.force coq_reUnknown ->
+ Tvar (tr_var a)
+ | _, [a; b] when c = Lazy.force coq_reFloat2 ->
+ Tconst (Constant.create (tr_float 2 a b))
+ | _, [a; b] when c = Lazy.force coq_reFloat10 ->
+ Tconst (Constant.create (tr_float 10 a b))
+ | _, [a] when c = Lazy.force coq_reInteger ->
+ Tconst (Constant.create (1, tr_arith_bigconstant a, Bigint.zero))
+ | _, [op;a;b] when c = Lazy.force coq_reBinary ->
+ Tbinop (tr_binop op, tr_term a, tr_term b)
+ | _, [op;a] when c = Lazy.force coq_reUnary ->
+ Tunop (tr_unop op, tr_term a)
+ | _, [op;a] when c = Lazy.force coq_reRound ->
+ Tround (tr_rounding_mode op, tr_term a)
+ | _ ->
+ msgnl (str "tr_term: " ++ Printer.pr_constr c0);
+ assert false
+
+let tr_rle c =
+ let c, args = decompose_app c in
+ match kind_of_term c, args with
+ | _, [a;b] when c = Lazy.force coq_Rle ->
+ begin match decompose_app a, decompose_app b with
+ | (ac, [at]), (bc, [bt])
+ when ac = Lazy.force coq_convert && bc = Lazy.force coq_convert ->
+ at, bt
+ | _ ->
+ raise NotGappa
+ end
+ | _ ->
+ raise NotGappa
+
+let tr_pred c =
+ let c, args = decompose_app c in
+ match kind_of_term c, args with
+ | _, [a;b] when c = build_coq_and () ->
+ begin match tr_rle a, tr_rle b with
+ | (c1, t1), (t2, c2) when t1 = t2 ->
+ begin match tr_term c1, tr_term c2 with
+ | Tconst c1, Tconst c2 ->
+ Pin (tr_term t1, c1, c2)
+ | _ ->
+ raise NotGappa
+ end
+ | _ ->
+ raise NotGappa
+ end
+ | _ ->
+ raise NotGappa
+
+let is_R c = match decompose_app c with
+ | c, [] when c = Lazy.force coq_R -> true
+ | _ -> false
+
+let tr_hyps =
+ List.fold_left
+ (fun acc (_,h) -> try tr_pred h :: acc with NotGappa -> acc) []
+
+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)
+
+let var_name = function
+ | Name id ->
+ let s = string_of_id id in
+ let s = String.sub s 1 (String.length s - 1) in
+ mkVar (id_of_string s)
+ | Anonymous ->
+ assert false
+
+let build_proof_term c0 =
+ let bl,c = decompose_lam c0 in
+ List.fold_right
+ (fun (x,t) pf ->
+ mkApp (pf, [| if is_R t then var_name x else mk_new_meta () |]))
+ bl c0
+
+let gappa_internal gl =
+ try
+ let c = tr_pred (pf_concl gl) in
+ let s = call_gappa (tr_hyps (pf_hyps_types gl)) c in
+ let pf = constr_of_string gl s in
+ let pf = build_proof_term pf in
+ Tacticals.tclTHEN (Tacmach.refine_no_check pf) Tactics.assumption gl
+ with
+ | NotGappa -> error "not a gappa goal"
+ | GappaFailed -> error "gappa failed"
+ | GappaProofFailed -> error "incorrect gappa proof term"
+
+let gappa_prepare =
+ let id = Ident (dummy_loc, id_of_string "gappa_prepare") in
+ lazy (Tacinterp.interp (Tacexpr.TacArg (Tacexpr.Reference id)))
+
+let gappa gl =
+ Coqlib.check_required_library ["Gappa"; "Gappa_tactic"];
+ Tacticals.tclTHEN (Lazy.force gappa_prepare) gappa_internal gl
+
+(*
+Local Variables:
+compile-command: "make -C ../.. bin/coqc.opt bin/coqide.opt"
+End:
+*)
+
diff --git a/contrib/dp/dp_simplify.ml b/contrib/dp/dp_simplify.ml
deleted file mode 100644
index d5376b8d..00000000
--- a/contrib/dp/dp_simplify.ml
+++ /dev/null
@@ -1,117 +0,0 @@
-
-open Format
-open Fol
-
-let is_simplify_ident s =
- let is_simplify_char = function
- | 'a'..'z' | 'A'..'Z' | '0'..'9' -> true
- | _ -> false
- in
- try
- String.iter (fun c -> if not (is_simplify_char c) then raise Exit) s; true
- with Exit ->
- false
-
-let ident fmt s =
- if is_simplify_ident s then fprintf fmt "%s" s else fprintf fmt "|%s|" s
-
-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_term fmt = function
- | Cst n ->
- fprintf fmt "%d" 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
- | 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 space 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 "@[(EQ %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, tl)) ->
- fprintf fmt "@[(EQ (%a@ %a) |@@true|)@]" ident id print_terms tl
- | Imp (a, b) ->
- fprintf fmt "@[(IMPLIES@ %a@ %a)@]" pp a pp b
- | And (a, b) ->
- fprintf fmt "@[(AND@ %a@ %a)@]" pp a pp b
- | Or (a, b) ->
- fprintf fmt "@[(OR@ %a@ %a)@]" pp a pp b
- | Not a ->
- fprintf fmt "@[(NOT@ %a)@]" pp a
- | Forall (id, _, p) ->
- fprintf fmt "@[(FORALL (%a)@ %a)@]" ident id pp p
- | Exists (id, _, p) ->
- fprintf fmt "@[(EXISTS (%a)@ %a)@]" ident id pp p
-
-(**
-let rec string_list l = match l with
- [] -> ""
- | [e] -> e
- | e::l' -> e ^ " " ^ (string_list l')
-**)
-
-let print_query fmt (decls,concl) =
- let print_decl = function
- | DeclVar (id, [], t) ->
- fprintf fmt "@[;; %s : %s@]@\n" id t
- | DeclVar (id, l, t) ->
- fprintf fmt "@[;; %s : %a -> %s@]@\n"
- id (print_list comma pp_print_string) l t
- | DeclPred (id, []) ->
- fprintf fmt "@[;; %s : BOOLEAN @]@\n" id
- | DeclPred (id, l) ->
- fprintf fmt "@[;; %s : %a -> BOOLEAN@]@\n"
- id (print_list comma pp_print_string) l
- | DeclType id ->
- fprintf fmt "@[;; %s : TYPE@]@\n" id
- | Assert (id, f) ->
- fprintf fmt "@[(BG_PUSH ;; %s@\n %a)@]@\n" id print_predicate f
- in
- List.iter print_decl decls;
- fprintf fmt "%a@." print_predicate concl
-
-let call q =
- let f = Filename.temp_file "coq_dp" ".sx" in
- let c = open_out f in
- let fmt = formatter_of_out_channel c in
- fprintf fmt "@[%a@]@." print_query q;
- close_out c;
- ignore (Sys.command (sprintf "cat %s" f));
- let cmd =
- sprintf "timeout 10 Simplify %s > out 2>&1 && grep -q -w Valid out" f
- in
- prerr_endline cmd; flush stderr;
- let out = Sys.command cmd in
- if out = 0 then Valid else if out = 1 then Invalid else Timeout
- (* TODO: effacer le fichier f et le fichier out *)
diff --git a/contrib/dp/dp_simplify.mli b/contrib/dp/dp_simplify.mli
deleted file mode 100644
index 03b6d347..00000000
--- a/contrib/dp/dp_simplify.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-
-open Fol
-
-val call : query -> prover_answer
diff --git a/contrib/dp/dp_sorts.ml b/contrib/dp/dp_sorts.ml
deleted file mode 100644
index 7dbdfa56..00000000
--- a/contrib/dp/dp_sorts.ml
+++ /dev/null
@@ -1,51 +0,0 @@
-
-open Fol
-
-let term_has_sort x s = Fatom (Pred ("%sort_" ^ s, [x]))
-
-let has_sort x s = term_has_sort (App (x, [])) s
-
-let rec form = function
- | True | False | Fatom _ as f -> f
- | Imp (f1, f2) -> Imp (form f1, form f2)
- | And (f1, f2) -> And (form f1, form f2)
- | Or (f1, f2) -> Or (form f1, form f2)
- | Not f -> Not (form f)
- | Forall (x, ("INT" as t), f) -> Forall (x, t, form f)
- | Forall (x, t, f) -> Forall (x, t, Imp (has_sort x t, form f))
- | Exists (x, ("INT" as t), f) -> Exists (x, t, form f)
- | Exists (x, t, f) -> Exists (x, t, Imp (has_sort x t, form f))
-
-let sort_ax = let r = ref 0 in fun () -> incr r; "sort_ax_" ^ string_of_int !r
-
-let hyp acc = function
- | Assert (id, f) ->
- (Assert (id, form f)) :: acc
- | DeclVar (id, _, "INT") as d ->
- d :: acc
- | DeclVar (id, [], t) as d ->
- (Assert (sort_ax (), has_sort id t)) :: d :: acc
- | DeclVar (id, l, t) as d ->
- let n = ref 0 in
- let xi =
- List.fold_left
- (fun l t -> incr n; ("x" ^ string_of_int !n, t) :: l) [] l
- in
- let f =
- List.fold_left
- (fun f (x,t) -> if t = "INT" then f else Imp (has_sort x t, f))
- (term_has_sort
- (App (id, List.rev_map (fun (x,_) -> App (x,[])) xi)) t)
- xi
- in
- let f = List.fold_left (fun f (x,t) -> Forall (x, t, f)) f xi in
- (Assert (sort_ax (), f)) :: d :: acc
- | DeclPred _ as d ->
- d :: acc
- | DeclType t as d ->
- (DeclPred ("%sort_" ^ t, [t])) :: d :: acc
-
-let query (hyps, f) =
- let hyps' = List.fold_left hyp [] hyps in
- List.rev hyps', form f
-
diff --git a/contrib/dp/dp_sorts.mli b/contrib/dp/dp_sorts.mli
deleted file mode 100644
index 9e74f997..00000000
--- a/contrib/dp/dp_sorts.mli
+++ /dev/null
@@ -1,4 +0,0 @@
-
-open Fol
-
-val query : query -> query
diff --git a/contrib/dp/dp_why.ml b/contrib/dp/dp_why.ml
index e1ddb039..e24049ad 100644
--- a/contrib/dp/dp_why.ml
+++ b/contrib/dp/dp_why.ml
@@ -4,6 +4,18 @@
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
diff --git a/contrib/dp/dp_why.mli b/contrib/dp/dp_why.mli
new file mode 100644
index 00000000..b38a3d37
--- /dev/null
+++ b/contrib/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/contrib/dp/dp_zenon.ml b/contrib/dp/dp_zenon.ml
deleted file mode 100644
index 57b0a44f..00000000
--- a/contrib/dp/dp_zenon.ml
+++ /dev/null
@@ -1,103 +0,0 @@
-
-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 rec print_term fmt = function
- | Cst n ->
- fprintf fmt "%d" 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
- | 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
-
-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, tl)) ->
- fprintf fmt "@[(%s@ %a)@]" id print_terms tl
- | Imp (a, b) ->
- fprintf fmt "@[(=>@ %a@ %a)@]" pp a pp b
- | And (a, b) ->
- fprintf fmt "@[(/\\@ %a@ %a)@]" pp a pp b
- | Or (a, b) ->
- fprintf fmt "@[(\\/@ %a@ %a)@]" pp a pp b
- | Not a ->
- fprintf fmt "@[(-.@ %a)@]" pp a
- | Forall (id, t, p) ->
- fprintf fmt "@[(A. ((%s \"%s\")@ %a))@]" id t pp p
- | Exists (id, t, p) ->
- fprintf fmt "@[(E. ((%s \"%s\")@ %a))@]" id t pp p
-
-let rec string_of_type_list = function
- | [] -> ""
- | e :: l' -> e ^ " -> " ^ (string_of_type_list l')
-
-let print_query fmt (decls,concl) =
- let print_decl = function
- | DeclVar (id, [], t) ->
- fprintf fmt "@[;; %s: %s@]@\n" id t
- | DeclVar (id, l, t) ->
- fprintf fmt "@[;; %s: %s%s@]@\n"
- id (string_of_type_list l) t
- | DeclPred (id, l) ->
- fprintf fmt "@[;; %s: %sBOOLEAN@]@\n"
- id (string_of_type_list l)
- | DeclType id ->
- fprintf fmt "@[;; %s: TYPE@]@\n" id
- | Assert (id, f) ->
- fprintf fmt "@[\"%s\" %a@]@\n" id print_predicate f
- in
- List.iter print_decl decls;
- fprintf fmt "$goal %a@." print_predicate concl
-
-let call q =
- let f = Filename.temp_file "coq_dp" ".znn" in
- let c = open_out f in
- let fmt = formatter_of_out_channel c in
- fprintf fmt "@[%a@]@." print_query q;
- close_out c;
- ignore (Sys.command (sprintf "cat %s" f));
- let cmd =
- sprintf "timeout 10 zenon %s > out 2>&1 && grep -q PROOF-FOUND out" f
- in
- prerr_endline cmd; flush stderr;
- let out = Sys.command cmd in
- if out = 0 then Valid
- else if out = 1 then Invalid
- else if out = 137 then Timeout
- else Util.anomaly "malformed Zenon input file"
- (* TODO: effacer le fichier f et le fichier out *)
-
-
diff --git a/contrib/dp/dp_zenon.mli b/contrib/dp/dp_zenon.mli
index 03b6d347..0a727d1f 100644
--- a/contrib/dp/dp_zenon.mli
+++ b/contrib/dp/dp_zenon.mli
@@ -1,4 +1,7 @@
open Fol
-val call : query -> prover_answer
+val set_debug : bool -> unit
+
+val proof_from_file : string -> Proof_type.tactic
+
diff --git a/contrib/dp/dp_zenon.mll b/contrib/dp/dp_zenon.mll
new file mode 100644
index 00000000..2fc2a5f4
--- /dev/null
+++ b/contrib/dp/dp_zenon.mll
@@ -0,0 +1,181 @@
+
+{
+
+ 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 "%d" n
+ | 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
+ | 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 true (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 true (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/contrib/dp/fol.mli b/contrib/dp/fol.mli
index a85469cc..b94bd3e3 100644
--- a/contrib/dp/fol.mli
+++ b/contrib/dp/fol.mli
@@ -45,4 +45,11 @@ type query = decl list * form
(* prover result *)
-type prover_answer = Valid | Invalid | DontKnow | Timeout
+type prover_answer =
+ | Valid of string option
+ | Invalid
+ | DontKnow
+ | Timeout
+ | NoAnswer
+ | Failure of string
+
diff --git a/contrib/dp/g_dp.ml4 b/contrib/dp/g_dp.ml4
index eb7fb73b..99bcf477 100644
--- a/contrib/dp/g_dp.ml4
+++ b/contrib/dp/g_dp.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_dp.ml4 7165 2005-06-24 12:56:46Z coq $ *)
+(* $Id: g_dp.ml4 10924 2008-05-13 14:01:11Z filliatr $ *)
open Dp
@@ -16,6 +16,14 @@ TACTIC EXTEND Simplify
[ "simplify" ] -> [ simplify ]
END
+TACTIC EXTEND Ergo
+ [ "ergo" ] -> [ ergo ]
+END
+
+TACTIC EXTEND Yices
+ [ "yices" ] -> [ yices ]
+END
+
TACTIC EXTEND CVCLite
[ "cvcl" ] -> [ cvc_lite ]
END
@@ -28,6 +36,18 @@ TACTIC EXTEND Zenon
[ "zenon" ] -> [ zenon ]
END
+TACTIC EXTEND Gwhy
+ [ "gwhy" ] -> [ gwhy ]
+END
+
+TACTIC EXTEND Gappa_internal
+ [ "gappa_internal" ] -> [ Dp_gappa.gappa_internal ]
+END
+
+TACTIC EXTEND Gappa
+ [ "gappa" ] -> [ Dp_gappa.gappa ]
+END
+
(* should be part of basic tactics syntax *)
TACTIC EXTEND admit
[ "admit" ] -> [ Tactics.admit_as_an_axiom ]
@@ -36,3 +56,24 @@ 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/contrib/dp/test2.v b/contrib/dp/test2.v
index 4e933a3c..3e4c0f6d 100644
--- a/contrib/dp/test2.v
+++ b/contrib/dp/test2.v
@@ -5,6 +5,10 @@ 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
@@ -18,9 +22,7 @@ Open Scope nat_scope.
Print plus.
Goal forall x, x+0=x.
- induction x.
- zenon.
- zenon.
+ induction x; ergo.
(* simplify resoud le premier, pas le second *)
Admitted.
diff --git a/contrib/dp/test_gappa.v b/contrib/dp/test_gappa.v
new file mode 100644
index 00000000..eb65a59d
--- /dev/null
+++ b/contrib/dp/test_gappa.v
@@ -0,0 +1,91 @@
+Require Export Gappa_tactic.
+Require Export Reals.
+
+Open Scope Z_scope.
+Open Scope R_scope.
+
+Lemma test_base10 :
+ forall x y:R,
+ 0 <= x <= 4 ->
+ 0 <= x * (24 * powerRZ 10 (-1)) <= 10.
+Proof.
+ gappa.
+Qed.
+
+(*
+@rnd = float< ieee_32, zr >;
+a = rnd(a_); b = rnd(b_);
+{ a in [3.2,3.3] /\ b in [1.4,1.9] ->
+ rnd(a - b) - (a - b) in [0,0] }
+*)
+
+Definition rnd := gappa_rounding (rounding_float roundZR 43 (120)).
+
+Lemma test_float3 :
+ forall a_ b_ a b : R,
+ a = rnd a_ ->
+ b = rnd b_ ->
+ 52 / 16 <= a <= 53 / 16 ->
+ 22 / 16 <= b <= 30 / 16 ->
+ 0 <= rnd (a - b) - (a - b) <= 0.
+Proof.
+ unfold rnd.
+ gappa.
+Qed.
+
+Lemma test_float2 :
+ forall x y:R,
+ 0 <= x <= 1 ->
+ 0 <= y <= 1 ->
+ 0 <= gappa_rounding (rounding_float roundNE 53 (1074)) (x+y) <= 2.
+Proof.
+ gappa.
+Qed.
+
+Lemma test_float1 :
+ forall x y:R,
+ 0 <= gappa_rounding (rounding_fixed roundDN (0)) x -
+ gappa_rounding (rounding_fixed roundDN (0)) y <= 0 ->
+ Rabs (x - y) <= 1.
+Proof.
+ gappa.
+Qed.
+
+Lemma test1 :
+ forall x y:R,
+ 0 <= x <= 1 ->
+ 0 <= -y <= 1 ->
+ 0 <= x * (-y) <= 1.
+Proof.
+ gappa.
+Qed.
+
+Lemma test2 :
+ forall x y:R,
+ 3/4 <= x <= 3 ->
+ 0 <= sqrt x <= 1775 * (powerRZ 2 (-10)).
+Proof.
+ gappa.
+Qed.
+
+Lemma test3 :
+ forall x y z:R,
+ 0 <= x - y <= 3 ->
+ -2 <= y - z <= 4 ->
+ -2 <= x - z <= 7.
+Proof.
+ gappa.
+Qed.
+
+Lemma test4 :
+ forall x1 x2 y1 y2 : R,
+ 1 <= Rabs y1 <= 1000 ->
+ 1 <= Rabs y2 <= 1000 ->
+ - powerRZ 2 (-53) <= (x1 - y1) / y1 <= powerRZ 2 (-53) ->
+ - powerRZ 2 (-53) <= (x2 - y2) / y2 <= powerRZ 2 (-53) ->
+ - powerRZ 2 (-51) <= (x1 * x2 - y1 * y2) / (y1 * y2) <= powerRZ 2 (-51).
+Proof.
+ gappa.
+Qed.
+
+
diff --git a/contrib/dp/tests.v b/contrib/dp/tests.v
index 52a57a0c..a6d4f2e1 100644
--- a/contrib/dp/tests.v
+++ b/contrib/dp/tests.v
@@ -2,48 +2,115 @@
Require Import ZArith.
Require Import Classical.
+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.
-zenon.
+simplify.
Qed.
-
(* Examples in the Propositional Calculus
and theory of equality *)
Parameter A C : Prop.
Goal A -> A.
-zenon.
+simplify.
Qed.
Goal A -> (A \/ C).
-zenon.
+simplify.
Qed.
Parameter x y z : Z.
Goal x = y -> y = z -> x = z.
-
-zenon.
+ergo.
Qed.
Goal ((((A -> C) -> A) -> A) -> C) -> C.
-zenon.
+ergo.
Qed.
-
(* Arithmetic *)
Open Scope Z_scope.
Goal 1 + 1 = 2.
-simplify.
+yices.
Qed.
@@ -57,14 +124,12 @@ Qed.
Goal (forall (x y : Z), x = y) -> 0=1.
try zenon.
-simplify.
+ergo.
Qed.
Goal forall (x: nat), (x + 0 = x)%nat.
-induction x0.
-zenon.
-zenon.
+induction x0; ergo.
Qed.
@@ -106,7 +171,7 @@ Inductive even : Z -> Prop :=
unlike CVC Lite *)
Goal even 4.
-cvcl.
+ergo.
Qed.
@@ -115,8 +180,7 @@ 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.
-
-zenon.
+yices.
Qed.
@@ -133,8 +197,7 @@ Dp_hint add_S.
unlike zenon *)
Goal forall n : nat, add n 0 = n.
-
-induction n ; zenon.
+induction n ; yices.
Qed.
@@ -144,8 +207,8 @@ Definition pred (n : nat) : nat := match n with
end.
Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat.
-
-zenon.
+yices.
+(*zenon.*)
Qed.
@@ -157,7 +220,7 @@ end.
Goal forall n : nat, plus n 0%nat = n.
-induction n; zenon.
+induction n; ergo.
Qed.
@@ -173,8 +236,11 @@ with odd_b (n : nat) : bool := match n with
end.
Goal even_b (S (S O)) = true.
-
+ergo.
+(*
+simplify.
zenon.
+*)
Qed.
@@ -184,7 +250,8 @@ 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.
-zenon.
+yices.
+(*zenon.*)
Qed.
@@ -194,7 +261,8 @@ Qed.
Parameter poly_f : forall A:Set, A->A.
Goal forall x:nat, poly_f nat x = poly_f nat x.
-zenon.
+ergo.
+(*zenon.*)
Qed.
diff --git a/contrib/dp/zenon.v b/contrib/dp/zenon.v
new file mode 100644
index 00000000..4ad00a11
--- /dev/null
+++ b/contrib/dp/zenon.v
@@ -0,0 +1,94 @@
+(* Copyright 2004 INRIA *)
+(* $Id: zenon.v 10739 2008-04-01 14:45:20Z herbelin $ *)
+
+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/contrib/extraction/CHANGES b/contrib/extraction/CHANGES
index 83ea4910..acd1dbda 100644
--- a/contrib/extraction/CHANGES
+++ b/contrib/extraction/CHANGES
@@ -346,8 +346,8 @@ 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-orderde deux termes.
-Rocq/ARITH/Chinese computation of the chinese remaindering.
+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.
diff --git a/contrib/extraction/common.ml b/contrib/extraction/common.ml
index 346201ec..5ad4a288 100644
--- a/contrib/extraction/common.ml
+++ b/contrib/extraction/common.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: common.ml 8930 2006-06-09 02:14:34Z letouzey $ i*)
+(*i $Id: common.ml 10596 2008-02-27 15:30:11Z letouzey $ i*)
open Pp
open Util
@@ -17,42 +17,218 @@ open Nameops
open Libnames
open Table
open Miniml
+open Mlutil
open Modutil
-open Ocaml
+open Mod_subst
-(*S Renamings. *)
+(*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 dottify = function
+ | [] -> assert false
+ | [s] -> unquote s
+ | s::[""] -> unquote s
+ | s::l -> (dottify l)^"."^(unquote s)
+
+(*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 = id_of_string (String.capitalize (string_of_id id))
+
+(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *)
+let pr_upper_id id = str (String.capitalize (string_of_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_ident 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 keywords = ref Idset.empty
+let set_keywords kws = keywords := kws
+
let global_ids = ref Idset.empty
-let modular = ref false
+let add_global_ids s = global_ids := Idset.add s !global_ids
+let global_ids_list () = Idset.elements !global_ids
+
+let empty_env () = [], !global_ids
+
+let mktable () =
+ let h = Hashtbl.create 97 in
+ (Hashtbl.add h, Hashtbl.find h, fun () -> Hashtbl.clear h)
+
+let mkset () =
+ let h = Hashtbl.create 97 in
+ (fun x -> Hashtbl.add h x ()), (Hashtbl.mem h), (fun () -> Hashtbl.clear h)
+
+let mktriset () =
+ let h = Hashtbl.create 97 in
+ (fun x y z -> Hashtbl.add h (x,y,z) ()),
+ (fun x y z -> Hashtbl.mem h (x,y,z)),
+ (fun () -> Hashtbl.clear h)
(* For each [global_reference], this table will contain the different parts
- of its renamings, in [string list] form. *)
-let renamings = Hashtbl.create 97
-let rename r l = Hashtbl.add renamings r l
-let get_renamings r = Hashtbl.find renamings r
+ of its renaming, in [string list] form. *)
+let add_renaming, get_renaming, clear_renaming = mktable ()
(* Idem for [module_path]. *)
-let mp_renamings = Hashtbl.create 97
-let mp_rename mp l = Hashtbl.add mp_renamings mp l
-let mp_get_renamings mp = Hashtbl.find mp_renamings mp
+let add_mp_renaming, get_mp_renaming, clear_mp_renaming = mktable ()
-let modvisited = ref MPset.empty
-let modcontents = ref Gset.empty
-let add_module_contents mp s = modcontents := Gset.add (mp,s) !modcontents
-let module_contents mp s = Gset.mem (mp,s) !modcontents
+(* A table for function modfstlev_rename *)
+let add_modfstlev, get_modfstlev, clear_modfstlev = mktable ()
-let to_qualify = ref Refset.empty
+(* A set of all external objects that will have to be fully qualified *)
+let add_static_clash, static_clash, clear_static_clash = mkset ()
-let mod_1st_level = ref Idmap.empty
+(* Two tables of triplets [kind * module_path * string]. The first one
+ will record the first level of all MPfile, not only the current one.
+ The second table will contains local renamings. *)
-(*s Uppercase/lowercase renamings. *)
+type kind = Term | Type | Cons | Mod
-let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false
+let add_ext_mpmem, ext_mpmem, clear_ext_mpmem = mktriset ()
+let add_loc_mpmem, loc_mpmem, clear_loc_mpmem = mktriset ()
+
+(* The list of external modules that will be opened initially *)
+let add_mpfiles, mem_mpfiles, list_mpfiles, clear_mpfiles =
+ let m = ref MPset.empty in
+ (fun mp -> m:= MPset.add mp !m),
+ (fun mp -> MPset.mem mp !m),
+ (fun () -> MPset.elements !m),
+ (fun () -> m:= MPset.empty)
+
+(*s table containing the visible horizon at a precise moment *)
+
+let visible = ref ([] : module_path list)
+let pop_visible () = visible := List.tl !visible
+let push_visible mp = visible := mp :: !visible
+let top_visible_mp () = List.hd !visible
+
+(*s substitutions for printing signatures *)
+
+let substs = ref empty_subst
+let add_subst msid mp = substs := add_msid msid mp !substs
+let subst_mp mp = subst_mp !substs mp
+let subst_kn kn = subst_kn !substs kn
+let subst_con c = fst (subst_con !substs c)
+let subst_ref = function
+ | ConstRef con -> ConstRef (subst_con con)
+ | IndRef (kn,i) -> IndRef (subst_kn kn,i)
+ | ConstructRef ((kn,i),j) -> ConstructRef ((subst_kn kn,i),j)
+ | _ -> assert false
-let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false
+
+let duplicate_index = ref 0
+let to_duplicate = ref Gmap.empty
+let add_duplicate mp l =
+ incr duplicate_index;
+ let ren = "Coq__" ^ string_of_int (!duplicate_index) in
+ to_duplicate := Gmap.add (mp,l) ren !to_duplicate
+let check_duplicate mp l =
+ let mp' = subst_mp mp in
+ Gmap.find (mp',l) !to_duplicate
+
+type reset_kind = OnlyLocal | AllButExternal | Everything
+
+let reset_allbutext () =
+ clear_loc_mpmem ();
+ global_ids := !keywords;
+ clear_renaming ();
+ clear_mp_renaming ();
+ clear_modfstlev ();
+ clear_static_clash ();
+ clear_mpfiles ();
+ duplicate_index := 0;
+ to_duplicate := Gmap.empty;
+ visible := [];
+ substs := empty_subst
+
+let reset_everything () = reset_allbutext (); clear_ext_mpmem ()
+
+let reset_renaming_tables = function
+ | OnlyLocal -> clear_loc_mpmem ()
+ | AllButExternal -> reset_allbutext ()
+ | Everything -> reset_everything ()
+
+(*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
@@ -69,389 +245,238 @@ let modular_rename up id =
then prefix ^ s
else s
-let rename_module = modular_rename true
-
-(* [clash mp0 l s mpl] checks if [mp0-l-s] can be printed as [l-s] when
- [mpl] is the context of visible modules. More precisely, we check if
- there exists a mp1, module (sub-)path of an element of [mpl], such as
- module [mp1-l] contains [s].
- The verification stops if we encounter [mp1=mp0]. *)
-
-exception Stop
-
-let clash mp0 l s mpl =
- let rec clash_one mp = match mp with
- | _ when mp = mp0 -> raise Stop
- | MPdot (mp',_) ->
- (module_contents (add_labels_mp mp l) s) || (clash_one mp')
- | mp when is_toplevel mp -> false
- | _ -> module_contents (add_labels_mp mp l) s
+(*s [record_contents_fstlev] finds the names of the first-level objects
+ exported by the ground-level modules in [struc]. *)
+
+let rec record_contents_fstlev struc =
+ let upper_type = (lang () = Haskell) in
+ let addtyp mp id = add_ext_mpmem Type mp (modular_rename upper_type id) in
+ let addcons mp id = add_ext_mpmem Cons mp (modular_rename true id) in
+ let addterm mp id = add_ext_mpmem Term mp (modular_rename false id) in
+ let addmod mp id = add_ext_mpmem Mod mp (modular_rename true id) in
+ let addfix mp r =
+ add_ext_mpmem Term mp (modular_rename false (id_of_global r))
+ in
+ let f mp = function
+ | (l,SEdecl (Dind (_,ind))) ->
+ Array.iter
+ (fun ip ->
+ addtyp mp ip.ip_typename; Array.iter (addcons mp) ip.ip_consnames)
+ ind.ind_packets
+ | (l,SEdecl (Dtype _)) -> addtyp mp (id_of_label l)
+ | (l,SEdecl (Dterm _)) -> addterm mp (id_of_label l)
+ | (l,SEdecl (Dfix (rv,_,_))) -> Array.iter (addfix mp) rv
+ | (l,SEmodule _) -> addmod mp (id_of_label l)
+ | (l,SEmodtype _) -> addmod mp (id_of_label l)
in
- let rec clash_list = function
- | [] -> false
- | mp :: mpl -> (clash_one mp) || (clash_list mpl)
- in try clash_list mpl with Stop -> false
-
-(*s [contents_first_level mp] finds the names of the first-level objects
- exported by module [mp]. Nota: it might fail if [mp] isn't a directly
- visible module. Ex: [MPself] under functor, [MPbound], etc ... *)
-
-let contents_first_level mp =
- if not (MPset.mem mp !modvisited) then begin
- modvisited := MPset.add mp !modvisited;
- match (Global.lookup_module mp).mod_type with
- | MTBsig (msid,msb) ->
- let add b id = add_module_contents mp (modular_rename b id) in
- let upper_type = (lang () = Haskell) in
- List.iter
- (function
- | (l, SPBconst cb) ->
- (match Extraction.constant_kind (Global.env ()) cb with
- | Extraction.Logical -> ()
- | Extraction.Type -> add upper_type (id_of_label l)
- | Extraction.Term -> add false (id_of_label l))
- | (_, SPBmind mib) ->
- Array.iter
- (fun mip -> if snd (Inductive.mind_arity mip) <> InProp
- then begin
- add upper_type mip.mind_typename;
- Array.iter (add true) mip.mind_consnames
- end)
- mib.mind_packets
- | _ -> ())
- (Modops.subst_signature_msid msid mp msb)
- | _ -> ()
- end
+ List.iter (fun (mp,sel) -> List.iter (f mp) sel) struc
-(*s Initial renamings creation, for modular extraction. *)
+(*s For monolithic extraction, first-level modules might have to be renamed
+ with unique numbers *)
-let rec mp_create_modular_renamings mp =
- try mp_get_renamings mp
+let modfstlev_rename l =
+ let coqid = id_of_string "Coq" in
+ let id = id_of_label l in
+ try
+ let coqset = get_modfstlev id in
+ let nextcoq = next_ident_away coqid coqset in
+ add_modfstlev 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_modfstlev id [coqid]; "Coq_"^s)
+ else
+ (add_modfstlev id []; s)
+
+
+(*s Creating renaming for a [module_path] *)
+
+let rec mp_create_renaming mp =
+ try get_mp_renaming mp
with Not_found ->
let ren = match mp with
+ | _ when not (modular ()) && at_toplevel mp -> [""]
| MPdot (mp,l) ->
- (rename_module (id_of_label l)) :: (mp_create_modular_renamings mp)
- | MPself msid -> [rename_module (id_of_msid msid)]
- | MPbound mbid -> [rename_module (id_of_mbid mbid)]
- | MPfile f -> [String.capitalize (string_of_id (List.hd (repr_dirpath f)))]
- in mp_rename mp ren; ren
+ let lmp = mp_create_renaming mp in
+ if lmp = [""] then (modfstlev_rename l)::lmp
+ else (modular_rename true (id_of_label l))::lmp
+ | MPself msid -> [modular_rename true (id_of_msid msid)]
+ | MPbound mbid -> [modular_rename true (id_of_mbid mbid)]
+ | MPfile _ when not (modular ()) -> assert false
+ | MPfile _ -> [string_of_modfile mp]
+ in add_mp_renaming mp ren; ren
+
+(* [clash mp0 s mpl] checks if [mp0-s] can be printed as [s] when
+ [mpl] is the context of visible modules. More precisely, we check if
+ there exists a [mp] in [mpl] that contains [s].
+ The verification stops if we encounter [mp=mp0]. *)
+let rec clash mem mp0 s = function
+ | [] -> false
+ | mp :: _ when mp = mp0 -> false
+ | mp :: mpl -> mem mp s || clash mem mp0 s mpl
+
+(*s Initial renamings creation, for modular extraction. *)
let create_modular_renamings struc =
let current_module = fst (List.hd struc) in
- let modfiles = ref MPset.empty in
- let { up = u ; down = d } = struct_get_references_set struc
+ let { typ = ty ; trm = tr ; cons = co } = struct_get_references_set struc
in
(* 1) creates renamings of objects *)
let add upper r =
let mp = modpath_of_r r in
- let l = mp_create_modular_renamings mp in
+ let l = mp_create_renaming mp in
let s = modular_rename upper (id_of_global r) in
- global_ids := Idset.add (id_of_string s) !global_ids;
- rename r (s::l);
+ add_global_ids (id_of_string s);
+ add_renaming r (s::l);
begin try
- let mp = modfile_of_mp mp in
- if mp <> current_module then modfiles := MPset.add mp !modfiles
+ let mp = modfile_of_mp mp in if mp <> current_module then add_mpfiles mp
with Not_found -> ()
end;
in
- Refset.iter (add true) u;
- Refset.iter (add false) d;
+ Refset.iter (add (lang () = Haskell)) ty;
+ Refset.iter (add true) co;
+ Refset.iter (add false) tr;
(* 2) determines the opened libraries. *)
- let used_modules = MPset.elements !modfiles in
-
- (* [s] will contain all first-level sub-modules of [cur_mp] *)
- let s = ref Stringset.empty in
- begin
- let add l = s := Stringset.add (rename_module (id_of_label l)) !s in
- match (Global.lookup_module current_module).mod_type with
- | MTBsig (_,msb) ->
- List.iter (function (l,SPBmodule _) -> add l | _ -> ()) msb
- | _ -> ()
- end;
- (* We now compare [s] with the modules coming from [used_modules]. *)
- List.iter
- (function
- | MPfile d ->
- let s_mp =
- String.capitalize (string_of_id (List.hd (repr_dirpath d))) in
- if Stringset.mem s_mp !s then error_module_clash s_mp
- else s:= Stringset.add s_mp !s
- | _ -> assert false)
- used_modules;
+ let used_modules = list_mpfiles () in
+ let used_modules' = List.rev used_modules in
+ let str_list = List.map string_of_modfile used_modules'
+ in
+ let rec check_elsewhere mpl sl = match mpl, sl with
+ | [], [] -> []
+ | mp::mpl, _::sl ->
+ if List.exists (ext_mpmem Mod mp) sl then
+ check_elsewhere mpl sl
+ else mp :: (check_elsewhere mpl sl)
+ | _ -> assert false
+ in
+ let opened_modules = check_elsewhere used_modules' str_list in
+ clear_mpfiles ();
+ List.iter add_mpfiles opened_modules;
(* 3) determines the potential clashes *)
- List.iter contents_first_level used_modules;
- let used_modules' = List.rev used_modules in
- let needs_qualify r =
+ let needs_qualify k r =
let mp = modpath_of_r r in
- if (is_modfile mp) && mp <> current_module &&
- (clash mp [] (List.hd (get_renamings r)) used_modules')
- then to_qualify := Refset.add r !to_qualify
+ if (is_modfile mp) && mp <> current_module &&
+ (clash (ext_mpmem k) mp (List.hd (get_renaming r)) opened_modules)
+ then add_static_clash r
in
- Refset.iter needs_qualify u;
- Refset.iter needs_qualify d;
- used_modules
+ Refset.iter (needs_qualify Type) ty;
+ Refset.iter (needs_qualify Term) tr;
+ Refset.iter (needs_qualify Cons) co;
+ List.rev opened_modules
(*s Initial renamings creation, for monolithic extraction. *)
-let begins_with_CoqXX s =
- (String.length s >= 4) &&
- (String.sub s 0 3 = "Coq") &&
- (try
- for i = 4 to (String.index s '_')-1 do
- match s.[i] with
- | '0'..'9' -> ()
- | _ -> raise Not_found
- done;
- true
- with Not_found -> false)
-
-let mod_1st_level_rename l =
- let coqid = id_of_string "Coq" in
- let id = id_of_label l in
- try
- let coqset = Idmap.find id !mod_1st_level in
- let nextcoq = next_ident_away coqid coqset in
- mod_1st_level := Idmap.add id (nextcoq::coqset) !mod_1st_level;
- (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
- (mod_1st_level := Idmap.add id [coqid] !mod_1st_level; "Coq_"^s)
- else
- (mod_1st_level := Idmap.add id [] !mod_1st_level; s)
-
-let rec mp_create_mono_renamings mp =
- try mp_get_renamings mp
- with Not_found ->
- let ren = match mp with
- | _ when (at_toplevel mp) -> [""]
- | MPdot (mp,l) ->
- let lmp = mp_create_mono_renamings mp in
- if lmp = [""] then (mod_1st_level_rename l)::lmp
- else (rename_module (id_of_label l))::lmp
- | MPself msid -> [rename_module (id_of_msid msid)]
- | MPbound mbid -> [rename_module (id_of_mbid mbid)]
- | _ -> assert false
- in mp_rename mp ren; ren
-
let create_mono_renamings struc =
- let { up = u ; down = d } = struct_get_references_list struc in
+ let { typ = ty ; trm = tr ; cons = co } = struct_get_references_list struc in
let add upper r =
let mp = modpath_of_r r in
- let l = mp_create_mono_renamings mp in
+ let l = mp_create_renaming mp in
let mycase = if upper then uppercase_id else lowercase_id in
let id =
if l = [""] then
- next_ident_away (mycase (id_of_global r)) (Idset.elements !global_ids)
+ next_ident_away (mycase (id_of_global r)) (global_ids_list ())
else id_of_string (modular_rename upper (id_of_global r))
in
- global_ids := Idset.add id !global_ids;
- rename r ((string_of_id id)::l)
+ add_global_ids id;
+ add_renaming r ((string_of_id id)::l)
in
- List.iter (add true) (List.rev u);
- List.iter (add false) (List.rev d)
-
-(*s Renaming issues at toplevel *)
-
-module TopParams = struct
- let globals () = Idset.empty
- let pp_global _ r = pr_id (id_of_global r)
- let pp_module _ mp = str (string_of_mp mp)
-end
-
-(*s Renaming issues for a monolithic or modular extraction. *)
-
-module StdParams = struct
-
- let globals () = !global_ids
-
- 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 dottify = function
- | [] -> assert false
- | [s] -> unquote s
- | s::[""] -> unquote s
- | s::l -> (dottify l)^"."^(unquote s)
-
- let pp_global mpl r =
- let ls = get_renamings r in
- let s = List.hd ls in
- let mp = modpath_of_r r in
- let ls =
- if mp = List.hd mpl then [s] (* simpliest situation *)
- else match lang () with
- | Scheme -> [s] (* no modular Scheme extraction... *)
- | Toplevel -> [s] (* idem *)
- | Haskell ->
- if !modular then
- ls (* for the moment we always qualify in modular Haskell *)
- else [s]
- | Ocaml ->
- try (* has [mp] something in common with one of those in [mpl] ? *)
- let pref = common_prefix_from_list mp mpl in
- (*i TODO: possibilité de clash i*)
- list_firstn ((mp_length mp)-(mp_length pref)+1) ls
- with Not_found -> (* [mp] is othogonal with every element of [mp]. *)
- let base = base_mp mp in
- if !modular &&
- (at_toplevel mp) &&
- not (Refset.mem r !to_qualify) &&
- not (clash base [] s mpl)
- then snd (list_sep_last ls)
- else ls
- in
- add_module_contents mp s; (* update the visible environment *)
- str (dottify ls)
-
- (* The next function is used only in Ocaml extraction...*)
- let pp_module mpl mp =
- let ls =
- if !modular
- then mp_create_modular_renamings mp
- else mp_create_mono_renamings mp
- in
- let ls =
- try (* has [mp] something in common with one of those in [mpl] ? *)
- let pref = common_prefix_from_list mp mpl in
- (*i TODO: clash possible i*)
- list_firstn ((mp_length mp)-(mp_length pref)) ls
- with Not_found -> (* [mp] is othogonal with every element of [mp]. *)
- if !modular && (at_toplevel mp)
- then snd (list_sep_last ls)
- else ls
- in str (dottify ls)
-
-end
-
-module ToplevelPp = Ocaml.Make(TopParams)
-module OcamlPp = Ocaml.Make(StdParams)
-module HaskellPp = Haskell.Make(StdParams)
-module SchemePp = Scheme.Make(StdParams)
-
-let pp_decl mp d = match lang () with
- | Ocaml -> OcamlPp.pp_decl mp d
- | Haskell -> HaskellPp.pp_decl mp d
- | Scheme -> SchemePp.pp_decl mp d
- | Toplevel -> ToplevelPp.pp_decl mp d
-
-let pp_struct s = match lang () with
- | Ocaml -> OcamlPp.pp_struct s
- | Haskell -> HaskellPp.pp_struct s
- | Scheme -> SchemePp.pp_struct s
- | Toplevel -> ToplevelPp.pp_struct s
-
-let pp_signature s = match lang () with
- | Ocaml -> OcamlPp.pp_signature s
- | Haskell -> HaskellPp.pp_signature s
- | _ -> assert false
-
-let set_keywords () =
- (match lang () with
- | Ocaml -> keywords := Ocaml.keywords
- | Haskell -> keywords := Haskell.keywords
- | Scheme -> keywords := Scheme.keywords
- | Toplevel -> keywords := Idset.empty);
- global_ids := !keywords;
- to_qualify := Refset.empty
+ List.iter (add (lang () = Haskell)) (List.rev ty);
+ List.iter (add false) (List.rev tr);
+ List.iter (add true) (List.rev co);
+ []
+
+let create_renamings struc =
+ if modular () then create_modular_renamings struc
+ else create_mono_renamings struc
-let preamble prm = match lang () with
- | Ocaml -> Ocaml.preamble prm
- | Haskell -> Haskell.preamble prm
- | Scheme -> Scheme.preamble prm
- | Toplevel -> (fun _ _ _ -> mt ())
-
-let preamble_sig prm = match lang () with
- | Ocaml -> Ocaml.preamble_sig prm
- | _ -> assert false
-
-(*S Extraction of one decl to stdout. *)
-
-let print_one_decl struc mp decl =
- set_keywords ();
- modular := false;
- create_mono_renamings struc;
- msgnl (pp_decl [mp] decl)
-
-(*S Extraction to a file. *)
-
-let info f =
- Options.if_verbose msgnl
- (str ("The file "^f^" has been created by extraction."))
-
-let print_structure_to_file f prm struc =
- Hashtbl.clear renamings;
- mod_1st_level := Idmap.empty;
- modcontents := Gset.empty;
- modvisited := MPset.empty;
- set_keywords ();
- modular := prm.modular;
- let used_modules =
- if lang () = Toplevel then []
- else if prm.modular then create_modular_renamings struc
- else (create_mono_renamings struc; [])
- in
- let print_dummys =
- (struct_ast_search ((=) MLdummy) struc,
- struct_type_search Mlutil.isDummy struc,
- struct_type_search ((=) Tunknown) struc)
- in
- let print_magic =
- if lang () <> Haskell then false
- else struct_ast_search (function MLmagic _ -> true | _ -> false) struc
- in
- (* print the implementation *)
- let cout = option_map (fun (f,_) -> open_out f) f in
- let ft = match cout with
- | None -> !Pp_control.std_ft
- | Some cout -> Pp_control.with_output_to cout in
- begin try
- msg_with ft (preamble prm used_modules print_dummys print_magic);
- msg_with ft (pp_struct struc);
- option_iter close_out cout;
- with e ->
- option_iter close_out cout; raise e
- end;
- option_iter (fun (f,_) -> info f) f;
- (* print the signature *)
- match f with
- | Some (_,f) when lang () = Ocaml ->
- let cout = open_out f in
- let ft = Pp_control.with_output_to cout in
- begin try
- msg_with ft (preamble_sig prm used_modules print_dummys);
- msg_with ft (pp_signature (signature_of_structure struc));
- close_out cout;
- with e ->
- close_out cout; raise e
- end;
- info f
- | _ -> ()
-
-
-(*i
- (* DO NOT REMOVE: used when making names resolution *)
- let cout = open_out (f^".ren") in
- let ft = Pp_control.with_output_to cout in
- Hashtbl.iter
- (fun r id ->
- if short_module r = !current_module then
- msgnl_with ft (pr_id id ++ str " " ++ pr_sp (sp_of_r r)))
- renamings;
- pp_flush_with ft ();
- close_out cout;
-i*)
-
-
-
-
-
-
+
+(*s On-the-fly qualification issues for both monolithic or modular extraction. *)
+
+let pp_global k r =
+ let ls = get_renaming r in
+ assert (List.length ls > 1);
+ let s = List.hd ls in
+ let mp = modpath_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_loc_mpmem k mp s; unquote s)
+ else match lang () with
+ | Scheme -> unquote s (* no modular Scheme extraction... *)
+ | Haskell ->
+ (* for the moment we always qualify in modular Haskell *)
+ if modular () then dottify ls else s
+ | Ocaml ->
+ try (* has [mp] something in common with one of [!visible] ? *)
+ let prefix = common_prefix_from_list mp !visible in
+ let delta = mp_length mp - mp_length prefix in
+ let ls = list_firstn (delta+1) ls in
+ (* Difficulty: in ocaml we cannot qualify more than [ls],
+ but this (not-so-long) name can in fact be hidden. Solution:
+ duplication of the _definition_ of r in a Coq__XXX module *)
+ let s,ls' = list_sep_last ls in
+ let k' = if ls' = [] then k else Mod in
+ if clash (loc_mpmem k') prefix s !visible then
+ let front = if ls' = [] then [s] else ls' in
+ let l = get_nth_label delta r in
+ try dottify (front @ [check_duplicate prefix l])
+ with Not_found -> add_duplicate prefix l; dottify ls
+ else dottify ls
+ with Not_found ->
+ (* [mp] belongs to a closed module, not one of [!visible]. *)
+ let base = base_mp mp in
+ let base_s,ls1 = list_sep_last ls in
+ let s,ls2 = list_sep_last ls1 in
+ let k' = if ls2 = [] then k else Mod in
+ if modular () && (mem_mpfiles base) &&
+ not (static_clash r) &&
+ (* k' = Mod can't clash in an opened module, see earlier check *)
+ not (clash (loc_mpmem k') base s !visible)
+ then (* Standard situation of an object in another file: *)
+ (* Thanks to the "open" of this file we remove its name *)
+ dottify ls1
+ else if clash (loc_mpmem Mod) base base_s !visible then
+ error_module_clash base_s
+ else dottify ls
+
+(* The next function is used only in Ocaml extraction...*)
+let pp_module mp =
+ let ls = mp_create_renaming mp in
+ if List.length ls = 1 then dottify ls
+ else match mp with
+ | MPdot (mp0,_) 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_loc_mpmem Mod mp0 s; s
+ | _ ->
+ try (* has [mp] something in common with one of those in [!visible] ? *)
+ let prefix = common_prefix_from_list mp !visible in
+ assert (mp <> prefix); (* no use of mp as whole module from itself *)
+ let delta = mp_length mp - mp_length prefix in
+ let ls = list_firstn delta ls in
+ (* Difficulty: in ocaml we cannot qualify more than [ls],
+ but this (not-so-long) name can in fact be hidden. Solution:
+ duplication of the _definition_ of mp via a Coq__XXX module *)
+ let s,ls' = list_sep_last ls in
+ if clash (loc_mpmem Mod) prefix s !visible then
+ let l = get_nth_label_mp delta mp in
+ try dottify (ls' @ [check_duplicate prefix l])
+ with Not_found -> add_duplicate prefix l; dottify ls
+ else dottify ls
+ with Not_found ->
+ (* [mp] belongs to a closed module, not one of [!visible]. *)
+ let base = base_mp mp in
+ let base_s,ls' = list_sep_last ls in
+ let s = fst (list_sep_last ls) in
+ if modular () && (mem_mpfiles base) &&
+ not (clash (loc_mpmem Mod) base s !visible)
+ then dottify ls'
+ else if clash (loc_mpmem Mod) base base_s !visible then
+ error_module_clash base_s
+ else dottify ls
diff --git a/contrib/extraction/common.mli b/contrib/extraction/common.mli
index 2ba51e1c..5cd26584 100644
--- a/contrib/extraction/common.mli
+++ b/contrib/extraction/common.mli
@@ -6,16 +6,56 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: common.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: common.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
open Names
+open Libnames
open Miniml
open Mlutil
+open Pp
-val print_one_decl :
- ml_structure -> module_path -> ml_decl -> unit
+val fnl2 : unit -> std_ppcmds
+val space_if : bool -> std_ppcmds
+val sec_space_if : bool -> std_ppcmds
-val print_structure_to_file :
- (string * string) option -> extraction_params -> ml_structure -> unit
+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
+val lowercase_id : identifier -> identifier
+val uppercase_id : identifier -> identifier
+
+val pr_upper_id : identifier -> std_ppcmds
+
+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
+
+val record_contents_fstlev : ml_structure -> unit
+
+val create_renamings : ml_structure -> 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
+val push_visible : module_path -> unit
+val pop_visible : unit -> unit
+
+val add_subst : mod_self_id -> module_path -> unit
+
+val check_duplicate : module_path -> label -> string
+
+type reset_kind = OnlyLocal | AllButExternal | Everything
+
+val reset_renaming_tables : reset_kind -> unit
+
+val set_keywords : Idset.t -> unit
diff --git a/contrib/extraction/extract_env.ml b/contrib/extraction/extract_env.ml
index 825b3554..311b42c0 100644
--- a/contrib/extraction/extract_env.ml
+++ b/contrib/extraction/extract_env.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: extract_env.ml 10209 2007-10-09 21:49:37Z letouzey $ i*)
+(*i $Id: extract_env.ml 10794 2008-04-15 00:12:06Z letouzey $ i*)
open Term
open Declarations
@@ -21,7 +21,9 @@ open Modutil
open Common
open Mod_subst
-(*s Obtaining Coq environment. *)
+(***************************************)
+(*S Part I: computing Coq environment. *)
+(***************************************)
let toplevel_env () =
let seg = Lib.contents_after None in
@@ -29,16 +31,17 @@ let toplevel_env () =
| (_,kn), Lib.Leaf o ->
let mp,_,l = repr_kn kn in
let seb = match Libobject.object_tag o with
- | "CONSTANT" -> SEBconst (Global.lookup_constant (constant_of_kn kn))
- | "INDUCTIVE" -> SEBmind (Global.lookup_mind kn)
- | "MODULE" -> SEBmodule (Global.lookup_module (MPdot (mp,l)))
- | "MODULE TYPE" -> SEBmodtype (Global.lookup_modtype kn)
+ | "CONSTANT" -> SFBconst (Global.lookup_constant (constant_of_kn kn))
+ | "INDUCTIVE" -> SFBmind (Global.lookup_mind 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
- | MPself msid -> MEBstruct (msid, List.rev (map_succeed get_reference seg))
+ | MPself msid -> SEBstruct (msid, List.rev (map_succeed get_reference seg))
| _ -> assert false
let environment_until dir_opt =
@@ -130,58 +133,87 @@ let factor_fix env l cb msb =
list_iter_i
(fun j ->
function
- | (l,SEBconst cb') ->
+ | (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
-let rec extract_msig env mp = function
+(* From a [structure_body] (i.e. a list of [structure_field_body])
+ to specifications. *)
+
+let rec extract_sfb_spec env mp = function
| [] -> []
- | (l,SPBconst cb) :: msig ->
+ | (l,SFBconst cb) :: msig ->
let kn = make_con mp empty_dirpath l in
let s = extract_constant_spec env kn cb in
- if logical_spec s then extract_msig env mp msig
- else begin
- Visit.add_spec_deps s;
- (l,Spec s) :: (extract_msig env mp msig)
- end
- | (l,SPBmind cb) :: msig ->
+ 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 cb) :: msig ->
let kn = make_kn mp empty_dirpath l in
let s = Sind (kn, extract_inductive env kn) in
- if logical_spec s then extract_msig env mp msig
- else begin
- Visit.add_spec_deps s;
- (l,Spec s) :: (extract_msig env mp msig)
- end
- | (l,SPBmodule {msb_modtype=mtb}) :: msig ->
- (l,Smodule (extract_mtb env None mtb)) :: (extract_msig env mp msig)
- | (l,SPBmodtype mtb) :: msig ->
- (l,Smodtype (extract_mtb env None mtb)) :: (extract_msig env mp msig)
-
-and extract_mtb env mpo = function
- | MTBident kn -> Visit.add_kn kn; MTident kn
- | MTBfunsig (mbid, mtb, mtb') ->
+ 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 mtb = Modops.type_of_mb env mb in
+ let spec = extract_seb_spec env (mb.mod_type<>None) mtb in
+ (l,Smodule spec) :: specs
+ | (l,SFBmodtype mtb) :: msig ->
+ let specs = extract_sfb_spec env mp msig in
+ (l,Smodtype (extract_seb_spec env true(*?*) mtb.typ_expr)) :: specs
+ | (l,SFBalias(mp1,_))::msig ->
+ extract_sfb_spec env mp
+ ((l,SFBmodule {mod_expr = Some (SEBident mp1);
+ mod_type = None;
+ mod_constraints = Univ.Constraint.empty;
+ mod_alias = Mod_subst.empty_subst;
+ mod_retroknowledge = []})::msig)
+
+(* From [struct_expr_body] to specifications *)
+
+
+and extract_seb_spec env truetype = function
+ | SEBident kn when truetype -> Visit.add_mp kn; MTident kn
+ | SEBwith(mtb',With_definition_body(idl,cb))->
+ let mtb''= extract_seb_spec env truetype mtb' in
+ (match extract_with_type env cb with (* cb peut contenir des kn *)
+ | None -> mtb''
+ | Some (vl,typ) -> MTwith(mtb'',ML_With_type(idl,vl,typ)))
+ | SEBwith(mtb',With_module_body(idl,mp,_))->
+ Visit.add_mp mp;
+ MTwith(extract_seb_spec env truetype mtb',
+ ML_With_module(idl,mp))
+ | SEBfunctor (mbid, mtb, mtb') ->
let mp = MPbound mbid in
- let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in
- MTfunsig (mbid, extract_mtb env None mtb,
- extract_mtb env' None mtb')
- | MTBsig (msid, msig) ->
- let mp, msig = match mpo with
- | None -> MPself msid, msig
- | Some mp -> mp, Modops.subst_signature_msid msid mp msig
- in
+ let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in
+ MTfunsig (mbid, extract_seb_spec env true mtb.typ_expr,
+ extract_seb_spec env' truetype mtb')
+ | SEBstruct (msid, msig) ->
+ let mp = MPself msid in
let env' = Modops.add_signature mp msig env in
- MTsig (msid, extract_msig env' mp msig)
+ MTsig (msid, extract_sfb_spec env' mp msig)
+ | (SEBapply _|SEBident _ (*when not truetype*)) as mtb ->
+ extract_seb_spec env truetype (Modops.eval_struct env mtb)
+
+
+(* From a [structure_body] (i.e. a list of [structure_field_body])
+ to implementations.
-let rec extract_msb env mp all = function
+ 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,SEBconst cb) :: msb ->
+ | (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_msb env mp all msb 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
@@ -189,7 +221,7 @@ let rec extract_msb env mp all = function
else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
else ms
with Impossible ->
- let ms = extract_msb env mp all msb in
+ 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
@@ -197,8 +229,8 @@ let rec extract_msb env mp all = function
if (not b) && (logical_decl d) then ms
else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
else ms)
- | (l,SEBmind mib) :: msb ->
- let ms = extract_msb env mp all msb in
+ | (l,SFBmind mib) :: msb ->
+ let ms = extract_sfb env mp all msb in
let kn = make_kn mp empty_dirpath l in
let b = Visit.needed_kn kn in
if all || b then
@@ -206,48 +238,68 @@ let rec extract_msb env mp all = function
if (not b) && (logical_decl d) then ms
else begin Visit.add_decl_deps d; (l,SEdecl d) :: ms end
else ms
- | (l,SEBmodule mb) :: msb ->
- let ms = extract_msb env mp all msb in
+ | (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,SEBmodtype mtb) :: msb ->
- let ms = extract_msb env mp all msb in
- let kn = make_kn mp empty_dirpath l in
- if all || Visit.needed_kn kn then
- (l,SEmodtype (extract_mtb env None mtb)) :: 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 true(*?*) mtb.typ_expr)) :: ms
+ else ms
+ | (l,SFBalias (mp1,cst)) :: 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
+ {mod_expr = Some (SEBident mp1);
+ mod_type = None;
+ mod_constraints= Univ.Constraint.empty;
+ mod_alias = empty_subst;
+ mod_retroknowledge = []})) :: ms
else ms
-and extract_meb env mpo all = function
- | MEBident (MPfile d) -> error_MPfile_as_mod d (* temporary (I hope) *)
- | MEBident mp -> Visit.add_mp mp; MEident mp
- | MEBapply (meb, meb',_) ->
- MEapply (extract_meb env None true meb,
- extract_meb env None true meb')
- | MEBfunctor (mbid, mtb, meb) ->
+(* From [struct_expr_body] to implementations *)
+
+and extract_seb env mpo all = function
+ | 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 None true meb,
+ extract_seb env None true meb')
+ | SEBfunctor (mbid, mtb, meb) ->
let mp = MPbound mbid in
let env' = Modops.add_module mp (Modops.module_body_of_type mtb) env in
- MEfunctor (mbid, extract_mtb env None mtb,
- extract_meb env' None true meb)
- | MEBstruct (msid, msb) ->
+ MEfunctor (mbid, extract_seb_spec env true mtb.typ_expr,
+ extract_seb env' None true meb)
+ | SEBstruct (msid, msb) ->
let mp,msb = match mpo with
| None -> MPself msid, msb
- | Some mp -> mp, subst_msb (map_msid msid mp) msb
+ | Some mp -> mp, Modops.subst_structure (map_msid msid mp) msb
in
- let env' = add_structure mp msb env in
- MEstruct (msid, extract_msb env' mp all msb)
+ let env' = Modops.add_signature mp msb env in
+ MEstruct (msid, 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]. *)
- let meb = out_some mb.mod_expr in
- let mtb = match mb.mod_user_type with None -> mb.mod_type | Some mt -> mt in
+ let meb = Option.get mb.mod_expr in
+ let mtb = match mb.mod_type with
+ | None -> Modops.eval_struct env meb
+ | Some mt -> mt
+ in
(* Because of the "with" construct, the module type can be [MTBsig] with *)
(* a msid different from the one of the module. Here is the patch. *)
- let mtb = replicate_msid meb mtb in
- { ml_mod_expr = extract_meb env (Some mp) all meb;
- ml_mod_type = extract_mtb env None mtb }
+ (* PL 26/02/2008: is this still relevant ?
+ let mtb = replicate_msid meb mtb in *)
+ { ml_mod_expr = extract_seb env (Some mp) all meb;
+ ml_mod_type = extract_seb_spec env (mb.mod_type<>None) mtb }
+
let unpack = function MEstruct (_,sel) -> sel | _ -> assert false
@@ -258,161 +310,198 @@ let mono_environment refs mpl =
let env = Global.env () in
let l = List.rev (environment_until None) in
List.rev_map
- (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) false m)) l
+ (fun (mp,m) -> mp, unpack (extract_seb env (Some 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 m =
+ let d = descr () in
+ let f = if d.capital_file then String.capitalize else String.uncapitalize in
+ let fn = f (string_of_id m) in
+ Some (fn^d.file_suffix), Option.map ((^) fn) d.sig_suffix, m
+
+(*s Extraction of one decl to stdout. *)
+
+let print_one_decl struc mp decl =
+ let d = descr () in
+ reset_renaming_tables AllButExternal;
+ ignore (create_renamings struc);
+ push_visible mp;
+ msgnl (d.pp_decl decl);
+ pop_visible ()
+
+(*s Extraction of a ml struct to a file. *)
+
+let print_structure_to_file (fn,si,mo) struc =
+ let d = descr () in
+ reset_renaming_tables AllButExternal;
+ let used_modules = create_renamings struc in
+ 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
+ (* print the implementation *)
+ let cout = Option.map open_out fn in
+ let ft = match cout with
+ | None -> !Pp_control.std_ft
+ | Some cout -> Pp_control.with_output_to cout in
+ begin try
+ msg_with ft (d.preamble mo used_modules unsafe_needs);
+ if lang () = Ocaml then begin
+ (* for computing objects to duplicate *)
+ let devnull = Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) in
+ msg_with devnull (d.pp_struct struc);
+ reset_renaming_tables OnlyLocal;
+ end;
+ msg_with ft (d.pp_struct struc);
+ Option.iter close_out cout;
+ with e ->
+ Option.iter close_out cout; raise e
+ end;
+ Option.iter info_file fn;
+ (* print the signature *)
+ Option.iter
+ (fun si ->
+ let cout = open_out si in
+ let ft = Pp_control.with_output_to cout in
+ begin try
+ msg_with ft (d.sig_preamble mo used_modules unsafe_needs);
+ reset_renaming_tables OnlyLocal;
+ msg_with ft (d.pp_sig (signature_of_structure struc));
+ close_out cout;
+ with e ->
+ close_out cout; raise e
+ end;
+ info_file si)
+ 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 ()
+
-
(*s Recursive extraction in the Coq toplevel. The vernacular command is
- \verb!Recursive Extraction! [qualid1] ... [qualidn]. We use [extract_env]
- to get the saturated environment to extract. *)
+ \verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when
+ extracting to a file with the command:
+ \verb!Extraction "file"! [qualid1] ... [qualidn]. *)
-let mono_extraction (f,m) qualids =
- check_inside_section ();
- check_inside_module ();
+let full_extraction f qualids =
+ init false;
let rec find = function
| [] -> [],[]
| q::l ->
let refs,mps = find l in
try
- let mp = Nametab.locate_module (snd (qualid_of_reference q))
- in refs,(mp::mps)
+ let mp = Nametab.locate_module (snd (qualid_of_reference q)) in
+ if is_modfile mp then error_MPfile_as_mod mp true;
+ refs,(mp::mps)
with Not_found -> (Nametab.global q)::refs, mps
- in
+ in
let refs,mps = find qualids in
- let prm = {modular=false; mod_name = m; to_appear= refs} in
- let struc = optimize_struct prm None (mono_environment refs mps) in
- print_structure_to_file f prm struc;
- Visit.reset ();
- reset_tables ()
+ let struc = optimize_struct refs (mono_environment refs mps) in
+ warning_axioms ();
+ print_structure_to_file (mono_filename f) struc;
+ reset ()
-let extraction_rec = mono_extraction (None,id_of_string "Main")
-(*s Extraction in the Coq toplevel. We display the extracted term in
- Ocaml syntax and we use the Coq printers for globals. The
- vernacular command is \verb!Extraction! [qualid]. *)
+(*s Simple extraction in the Coq toplevel. The vernacular command
+ is \verb!Extraction! [qualid]. *)
-let extraction qid =
- check_inside_section ();
- check_inside_module ();
+let simple_extraction qid =
+ init false;
try
- let _ = Nametab.locate_module (snd (qualid_of_reference qid)) in
- extraction_rec [qid]
+ let mp = Nametab.locate_module (snd (qualid_of_reference qid)) in
+ if is_modfile mp then error_MPfile_as_mod mp true;
+ full_extraction None [qid]
with Not_found ->
let r = Nametab.global qid in
if is_custom r then
msgnl (str "User defined extraction:" ++ spc () ++
str (find_custom r) ++ fnl ())
else
- let prm =
- { modular = false; mod_name = id_of_string "Main"; to_appear = [r]} in
- let struc = optimize_struct prm None (mono_environment [r] []) in
+ let struc = optimize_struct [r] (mono_environment [r] []) in
let d = get_decl_in_structure r struc in
+ warning_axioms ();
print_one_decl struc (modpath_of_r r) d;
- Visit.reset ();
- reset_tables ()
-
-(*s Extraction to a file (necessarily recursive).
- The vernacular command is
- \verb!Extraction "file"! [qualid1] ... [qualidn].*)
-
-let lang_suffix () = match lang () with
- | Ocaml -> ".ml",".mli"
- | Haskell -> ".hs",".hi"
- | Scheme -> ".scm",".scm"
- | Toplevel -> assert false
-
-let filename f =
- let s,s' = lang_suffix () in
- if Filename.check_suffix f s then
- let f' = Filename.chop_suffix f s in
- Some (f,f'^s'),id_of_string f'
- else Some (f^s,f^s'),id_of_string f
-
-let extraction_file f vl =
- if lang () = Toplevel then error_toplevel ()
- else mono_extraction (filename f) vl
-
-(*s Extraction of a module at the toplevel. *)
-
-let extraction_module m =
- check_inside_section ();
- check_inside_module ();
- begin match lang () with
- | Toplevel -> error_toplevel ()
- | Scheme -> error_scheme ()
- | _ -> ()
- end;
- let q = snd (qualid_of_reference m) in
- let mp =
- try Nametab.locate_module q with Not_found -> error_unknown_module q
- in
- let b = is_modfile mp in
- let prm = {modular=b; mod_name = id_of_string ""; to_appear= []} in
- Visit.reset ();
- Visit.add_mp mp;
- let env = Global.env () in
- let l = List.rev (environment_until None) in
- let struc =
- List.rev_map (fun (mp,m) -> mp, unpack (extract_meb env (Some mp) b m)) l
- in
- let struc = optimize_struct prm None struc in
- let struc =
- let bmp = base_mp mp in
- try [bmp, List.assoc bmp struc] with Not_found -> assert false
- in
- print_structure_to_file None prm struc;
- Visit.reset ();
- reset_tables ()
+ reset ()
(*s (Recursive) Extraction of a library. The vernacular command is
\verb!(Recursive) Extraction Library! [M]. *)
-let module_file_name m = match lang () with
- | Ocaml -> let f = String.uncapitalize (string_of_id m) in f^".ml", f^".mli"
- | Haskell -> let f = String.capitalize (string_of_id m) in f^".hs", f^".hi"
- | _ -> assert false
-
-let dir_module_of_id m =
- let q = make_short_qualid m in
- try Nametab.full_name_module q with Not_found -> error_unknown_module q
-
let extraction_library is_rec m =
- check_inside_section ();
- check_inside_module ();
- begin match lang () with
- | Toplevel -> error_toplevel ()
- | Scheme -> error_scheme ()
- | _ -> ()
- end;
- let dir_m = dir_module_of_id m in
- Visit.reset ();
+ init true;
+ let dir_m =
+ let q = make_short_qualid 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_meb env (Some mp) true meb)) :: l
+ then (mp, unpack (extract_seb env (Some mp) true meb)) :: l
else l
in
let struc = List.fold_left select [] l in
- let dummy_prm = {modular=true; mod_name=m; to_appear=[]} in
- let struc = optimize_struct dummy_prm None struc in
+ let struc = optimize_struct [] struc in
+ warning_axioms ();
+ record_contents_fstlev struc;
let rec print = function
| [] -> ()
| (MPfile dir, _) :: l when not is_rec && dir <> dir_m -> print l
| (MPfile dir, sel) as e :: l ->
let short_m = snd (split_dirpath dir) in
- let f = module_file_name short_m in
- let prm = {modular=true;mod_name=short_m;to_appear=[]} in
- print_structure_to_file (Some f) prm [e];
+ print_structure_to_file (module_filename short_m) [e];
print l
| _ -> assert false
in
print struc;
- Visit.reset ();
- reset_tables ()
-
-
-
-
-
+ reset ()
diff --git a/contrib/extraction/extract_env.mli b/contrib/extraction/extract_env.mli
index a09464a1..8d906985 100644
--- a/contrib/extraction/extract_env.mli
+++ b/contrib/extraction/extract_env.mli
@@ -6,15 +6,18 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: extract_env.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
+(*i $Id: extract_env.mli 10895 2008-05-07 16:06:26Z letouzey $ i*)
(*s This module declares the extraction commands. *)
open Names
open Libnames
-val extraction : reference -> unit
-val extraction_rec : reference list -> unit
-val extraction_file : string -> reference list -> unit
-val extraction_module : reference -> unit
+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/contrib/extraction/extraction.ml b/contrib/extraction/extraction.ml
index 6982ffc6..fdc84a64 100644
--- a/contrib/extraction/extraction.ml
+++ b/contrib/extraction/extraction.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: extraction.ml 10195 2007-10-08 01:47:55Z letouzey $ i*)
+(*i $Id: extraction.ml 10497 2008-02-01 12:18:37Z soubiran $ i*)
(*i*)
open Util
@@ -310,7 +310,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
with Not_found ->
(* First, if this inductive is aliased via a Module, *)
(* we process the original inductive. *)
- option_iter (fun kn -> ignore (extract_ind env kn)) mib.mind_equiv;
+ Option.iter (fun kn -> ignore (extract_ind env kn)) mib.mind_equiv;
(* Everything concerning parameters. *)
(* We do that first, since they are common to all the [mib]. *)
let mip0 = mib.mind_packets.(0) in
@@ -337,7 +337,10 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
{ind_info = Standard;
ind_nparams = npar;
ind_packets = packets;
- ind_equiv = mib.mind_equiv };
+ ind_equiv = match mib.mind_equiv with
+ | None -> NoEquiv
+ | Some kn -> Equiv kn
+ };
(* Second pass: we extract constructors *)
for i = 0 to mib.mind_ntypes - 1 do
let p = packets.(i) in
@@ -410,7 +413,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
(Inductive.type_of_inductive env (mib,mip0))
in
List.iter
- (option_iter
+ (Option.iter
(fun kn -> if Cset.mem kn !projs then add_projection n kn))
(lookup_projections ip)
with Not_found -> ()
@@ -421,7 +424,9 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
let i = {ind_info = ind_info;
ind_nparams = npar;
ind_packets = packets;
- ind_equiv = mib.mind_equiv}
+ ind_equiv = match mib.mind_equiv with
+ | None -> NoEquiv
+ | Some kn -> Equiv kn }
in
add_ind kn mib i;
i
@@ -750,7 +755,7 @@ and extract_case env mle ((kn,i) as ip,c,br) mlt =
end
else
(* Standard case: we apply [extract_branch]. *)
- MLcase (mi.ind_info, a, Array.init br_size extract_branch)
+ MLcase ((mi.ind_info,[]), a, Array.init br_size extract_branch)
(*s Extraction of a (co)-fixpoint. *)
@@ -828,18 +833,18 @@ let extract_constant env kn cb =
| 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 warning_info_ax r;
+ 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::l) n [] in
Dtype (r, ids, Taxiom)
| (Info,Default) ->
- if not (is_custom r) then warning_info_ax r;
+ 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) ->
- warning_log_ax r; Dtype (r, [], Tdummy Ktype)
+ add_log_axiom r; Dtype (r, [], Tdummy Ktype)
| (Logic,Default) ->
- warning_log_ax r; Dterm (r, MLdummy, Tdummy Kother))
+ 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)
@@ -871,6 +876,20 @@ let extract_constant_spec env kn cb =
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
+ | (_ , Default) -> None
+ | (Logic, TypeScheme) ->Some ([],Tdummy Ktype)
+ | (Info, TypeScheme) ->
+ let s,vl = type_sign_vl env typ in
+ (match cb.const_body with
+ | None -> assert false
+ | Some body ->
+ let db = db_from_sign s in
+ let t = extract_type_scheme env db (force body) (List.length s)
+ in Some ( vl, t) )
+
let extract_inductive env kn =
let ind = extract_ind env kn in
add_recursors env kn;
@@ -880,24 +899,6 @@ let extract_inductive env kn =
ind.ind_packets
in { ind with ind_packets = packets }
-(*s From a global reference to a ML declaration. *)
-
-let extract_declaration env r = match r with
- | ConstRef kn -> extract_constant env kn (Environ.lookup_constant kn env)
- | IndRef (kn,_) -> Dind (kn, extract_inductive env kn)
- | ConstructRef ((kn,_),_) -> Dind (kn, extract_inductive env kn)
- | VarRef kn -> assert false
-
-(*s Without doing complete extraction, just guess what a constant would be. *)
-
-type kind = Logical | Term | Type
-
-let constant_kind env cb =
- match flag_of_type env (Typeops.type_of_constant_type env cb.const_type) with
- | (Logic,_) -> Logical
- | (Info,TypeScheme) -> Type
- | (Info,Default) -> Term
-
(*s Is a [ml_decl] logical ? *)
let logical_decl = function
@@ -916,9 +917,3 @@ let logical_spec = function
| Sval (_,Tdummy _) -> true
| Sind (_,i) -> array_for_all (fun ip -> ip.ip_logical) i.ind_packets
| _ -> false
-
-
-
-
-
-
diff --git a/contrib/extraction/extraction.mli b/contrib/extraction/extraction.mli
index 1dfd7e1a..6d41b630 100644
--- a/contrib/extraction/extraction.mli
+++ b/contrib/extraction/extraction.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: extraction.mli 6303 2004-11-16 12:37:40Z sacerdot $ i*)
+(*i $Id: extraction.mli 10497 2008-02-01 12:18:37Z soubiran $ i*)
(*s Extraction from Coq terms to Miniml. *)
@@ -21,21 +21,13 @@ 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 -> kernel_name -> ml_ind
-(*s ML declaration corresponding to a Coq reference. *)
-
-val extract_declaration : env -> global_reference -> ml_decl
-
-(*s Without doing complete extraction, just guess what a constant would be. *)
-
-type kind = Logical | Term | Type
-
-val constant_kind : env -> constant_body -> kind
-
(*s Is a [ml_decl] or a [ml_spec] logical ? *)
val logical_decl : ml_decl -> bool
diff --git a/contrib/extraction/g_extraction.ml4 b/contrib/extraction/g_extraction.ml4
index 13b29c7b..cb95808d 100644
--- a/contrib/extraction/g_extraction.ml4
+++ b/contrib/extraction/g_extraction.ml4
@@ -31,19 +31,18 @@ VERNAC ARGUMENT EXTEND language
| [ "Ocaml" ] -> [ Ocaml ]
| [ "Haskell" ] -> [ Haskell ]
| [ "Scheme" ] -> [ Scheme ]
-| [ "Toplevel" ] -> [ Toplevel ]
END
(* Extraction commands *)
VERNAC COMMAND EXTEND Extraction
(* Extraction in the Coq toplevel *)
-| [ "Extraction" global(x) ] -> [ extraction x ]
-| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ extraction_rec l ]
+| [ "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) ]
- -> [ extraction_file f l ]
+ -> [ full_extraction (Some f) l ]
END
(* Modular extraction (one Coq library = one ML module) *)
diff --git a/contrib/extraction/haskell.ml b/contrib/extraction/haskell.ml
index f924396c..0ef225c0 100644
--- a/contrib/extraction/haskell.ml
+++ b/contrib/extraction/haskell.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: haskell.ml 8930 2006-06-09 02:14:34Z letouzey $ i*)
+(*i $Id: haskell.ml 10233 2007-10-17 23:29:08Z letouzey $ i*)
(*s Production of Haskell syntax. *)
@@ -18,7 +18,7 @@ open Libnames
open Table
open Miniml
open Mlutil
-open Ocaml
+open Common
(*s Haskell renaming issues. *)
@@ -30,22 +30,19 @@ let keywords =
"as"; "qualified"; "hiding" ; "unit" ; "unsafeCoerce" ]
Idset.empty
-let preamble prm used_modules (mldummy,tdummy,tunknown) magic =
- let pp_mp = function
- | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
- | _ -> assert false
- in
- (if not magic then mt ()
+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 prm.mod_name ++ str " where" ++ fnl ()
- ++ fnl() ++
- str "import qualified Prelude" ++ fnl() ++
- prlist (fun mp -> str "import qualified " ++ pp_mp mp ++ fnl ()) used_modules
- ++ fnl () ++
- (if not magic then mt ()
+ 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
@@ -54,16 +51,10 @@ unsafeCoerce = GHC.Base.unsafeCoerce#
-- HUGS
import qualified IOExts
unsafeCoerce = IOExts.unsafeCoerce
-#endif")
- ++
- fnl() ++ fnl()
+#endif" ++ fnl2 ())
++
- (if not mldummy then mt ()
- else
- str "__ = Prelude.error \"Logical or arity value used\""
- ++ fnl () ++ fnl())
-
-let preamble_sig prm used_modules (mldummy,tdummy,tunknown) = failwith "TODO"
+ (if not usf.mldummy then mt ()
+ else str "__ = Prelude.error \"Logical or arity value used\"" ++ fnl2 ())
let pp_abst = function
| [] -> (mt ())
@@ -73,17 +64,11 @@ let pp_abst = function
let pr_lower_id id = pr_id (lowercase_id id)
-(*s The pretty-printing functor. *)
+(*s The pretty-printer for haskell syntax *)
-module Make = functor(P : Mlpp_param) -> struct
-
-let local_mpl = ref ([] : module_path list)
-
-let pp_global r =
+let pp_global k r =
if is_inline_custom r then str (find_custom r)
- else P.pp_global !local_mpl r
-
-let empty_env () = [], P.globals()
+ else str (Common.pp_global k r)
(*s Pretty-printing of types. [par] is a boolean indicating whether parentheses
are needed or not. *)
@@ -96,13 +81,14 @@ 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 r
+ | Tglob (r,[]) -> pp_global Type r
| Tglob (r,l) ->
if r = IndRef (kn_sig,0) then
pp_type true vl (List.hd l)
else
pp_par par
- (pp_global r ++ spc () ++ prlist_with_sep spc (pp_type true vl) l)
+ (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)
@@ -151,20 +137,20 @@ let rec pp_expr par env args =
spc () ++ str "in") ++
spc () ++ hov 0 pp_a2)))
| MLglob r ->
- apply (pp_global r)
+ apply (pp_global Term r)
| MLcons (_,r,[]) ->
- assert (args=[]); pp_global r
+ assert (args=[]); pp_global Cons r
| MLcons (_,r,[a]) ->
assert (args=[]);
- pp_par par (pp_global r ++ spc () ++ pp_expr true env [] a)
+ pp_par par (pp_global Cons r ++ spc () ++ pp_expr true env [] a)
| MLcons (_,r,args') ->
assert (args=[]);
- pp_par par (pp_global r ++ spc () ++
+ pp_par par (pp_global Cons r ++ spc () ++
prlist_with_sep spc (pp_expr true env []) args')
- | MLcase (_,t, pv) ->
+ | MLcase ((_,factors),t, pv) ->
apply (pp_par par'
(v 0 (str "case " ++ pp_expr false env [] t ++ str " of" ++
- fnl () ++ str " " ++ pp_pat env pv)))
+ 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
@@ -177,11 +163,11 @@ let rec pp_expr par env args =
pp_apply (str "unsafeCoerce") par (pp_expr true env [] a :: args)
| MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"")
-and pp_pat env pv =
+and pp_pat env factors pv =
let pp_one_pat (name,ids,t) =
let ids,env' = push_vars (List.rev ids) env in
let par = expr_needs_par t in
- hov 2 (pp_global name ++
+ hov 2 (pp_global Cons name ++
(match ids with
| [] -> mt ()
| _ -> (str " " ++
@@ -189,7 +175,18 @@ and pp_pat env pv =
(fun () -> (spc ())) pr_id (List.rev ids))) ++
str " ->" ++ spc () ++ pp_expr par env' [] t)
in
- (prvect_with_sep (fun () -> (fnl () ++ str " ")) pp_one_pat pv)
+ prvecti
+ (fun i x -> if List.mem i factors then mt () else
+ (pp_one_pat pv.(i) ++
+ if factors = [] && i = Array.length pv - 1 then mt ()
+ else fnl () ++ str " ")) pv
+ ++
+ match factors with
+ | [] -> mt ()
+ | i::_ ->
+ let (_,ids,t) = pv.(i) in
+ let t = ast_lift (-List.length ids) t in
+ hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t)
(*s names of the functions ([ids]) are already pushed in [env],
and passed here just for convenience. *)
@@ -223,7 +220,7 @@ let pp_logical_ind packet =
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 (IndRef (kn,0)) ++ spc () ++
+ 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 () ++
@@ -233,7 +230,7 @@ let pp_singleton kn packet =
let pp_one_ind ip pl cv =
let pl = rename_tvars keywords pl in
let pp_constructor (r,l) =
- (pp_global r ++
+ (pp_global Cons r ++
match l with
| [] -> (mt ())
| _ -> (str " " ++
@@ -241,7 +238,7 @@ let pp_one_ind ip pl cv =
(fun () -> (str " ")) (pp_type true pl) l))
in
str (if Array.length cv = 0 then "type " else "data ") ++
- pp_global (IndRef ip) ++ str " " ++
+ 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"
@@ -269,9 +266,7 @@ let rec pp_ind first kn i ind =
let pp_string_parameters ids = prlist (fun id -> str id ++ str " ")
-let pp_decl mpl =
- local_mpl := mpl;
- function
+let pp_decl = function
| Dind (kn,i) when i.ind_info = Singleton ->
pp_singleton kn i.ind_packets.(0) ++ fnl ()
| Dind (kn,i) -> hov 0 (pp_ind true kn 0 i)
@@ -288,38 +283,51 @@ let pp_decl mpl =
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 r ++ spc () ++ st) ++ fnl () ++ fnl ()
+ 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 rv.(i) in
+ let e = pp_global Term rv.(i) in
e ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl ()
- ++ pp_function (empty_env ()) e defs.(i) ++ fnl () ++ 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 r in
+ 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) ++ fnl() ++ fnl ())
+ hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ())
else
- hov 0 (pp_function (empty_env ()) e a ++ fnl () ++ fnl ())
+ hov 0 (pp_function (empty_env ()) e a ++ fnl2 ())
-let pp_structure_elem mpl = function
- | (l,SEdecl d) -> pp_decl mpl d
+let pp_structure_elem = function
+ | (l,SEdecl d) -> pp_decl d
| (l,SEmodule m) ->
failwith "TODO: Haskell extraction of modules not implemented yet"
| (l,SEmodtype m) ->
failwith "TODO: Haskell extraction of modules not implemented yet"
let pp_struct =
- prlist (fun (mp,sel) -> prlist (pp_structure_elem [mp]) sel)
-
-let pp_signature s = failwith "TODO"
-
-end
-
+ 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";
+ capital_file = true;
+ preamble = preamble;
+ pp_struct = pp_struct;
+ sig_suffix = None;
+ sig_preamble = (fun _ _ _ -> mt ());
+ pp_sig = (fun _ -> mt ());
+ pp_decl = pp_decl;
+}
diff --git a/contrib/extraction/haskell.mli b/contrib/extraction/haskell.mli
index 106f7868..1af9c231 100644
--- a/contrib/extraction/haskell.mli
+++ b/contrib/extraction/haskell.mli
@@ -6,15 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: haskell.mli 7632 2005-12-01 14:35:21Z letouzey $ i*)
+(*i $Id: haskell.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
-open Pp
-open Names
-open Miniml
+val haskell_descr : Miniml.language_descr
-val keywords : Idset.t
-
-val preamble :
- extraction_params -> module_path list -> bool*bool*bool -> bool -> std_ppcmds
-
-module Make : functor(P : Mlpp_param) -> Mlpp
diff --git a/contrib/extraction/miniml.mli b/contrib/extraction/miniml.mli
index 3b4146f8..dfe4eb48 100644
--- a/contrib/extraction/miniml.mli
+++ b/contrib/extraction/miniml.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: miniml.mli 9456 2006-12-17 20:08:38Z letouzey $ i*)
+(*i $Id: miniml.mli 10497 2008-02-01 12:18:37Z soubiran $ i*)
(*s Target language for extraction: a core ML called MiniML. *)
@@ -58,6 +58,8 @@ type inductive_info =
| Standard
| Record of global_reference list
+type case_info = int list (* list of branches to merge in a _ pattern *)
+
(* 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,
@@ -76,11 +78,16 @@ type ml_ind_packet = {
(* [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 : kernel_name option
+ ind_equiv : equiv
}
(*s ML terms. *)
@@ -92,7 +99,7 @@ type ml_ast =
| MLletin of identifier * ml_ast * ml_ast
| MLglob of global_reference
| MLcons of inductive_info * global_reference * ml_ast list
- | MLcase of inductive_info * ml_ast *
+ | MLcase of (inductive_info*case_info) * ml_ast *
(global_reference * identifier list * ml_ast) array
| MLfix of int * identifier array * ml_ast array
| MLexn of string
@@ -119,9 +126,14 @@ type ml_specif =
| Smodtype of ml_module_type
and ml_module_type =
- | MTident of kernel_name
+ | MTident of module_path
| MTfunsig of mod_bound_id * ml_module_type * ml_module_type
| MTsig of mod_self_id * 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
@@ -149,24 +161,28 @@ type ml_structure = (module_path * ml_module_structure) list
type ml_signature = (module_path * ml_module_sig) list
-(*s Pretty-printing of MiniML in a given concrete syntax is parameterized
- by a function [pp_global] that pretty-prints global references.
- The resulting pretty-printer is a module of type [Mlpp] providing
- functions to print types, terms and declarations. *)
-
-module type Mlpp_param = sig
- val globals : unit -> Idset.t
- val pp_global : module_path list -> global_reference -> std_ppcmds
- val pp_module : module_path list -> module_path -> std_ppcmds
-end
-
-module type Mlpp = sig
- val pp_decl : module_path list -> ml_decl -> std_ppcmds
- val pp_struct : ml_structure -> std_ppcmds
- val pp_signature : ml_signature -> std_ppcmds
-end
-
-type extraction_params =
- { modular : bool;
- mod_name : identifier;
- to_appear : global_reference 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;
+ capital_file : bool; (* should we capitalize filenames ? *)
+ 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/contrib/extraction/mlutil.ml b/contrib/extraction/mlutil.ml
index 6bfedce5..79aeea33 100644
--- a/contrib/extraction/mlutil.ml
+++ b/contrib/extraction/mlutil.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: mlutil.ml 8886 2006-06-01 13:53:45Z letouzey $ i*)
+(*i $Id: mlutil.ml 10329 2007-11-21 21:21:36Z letouzey $ i*)
(*i*)
open Pp
@@ -573,14 +573,20 @@ let eta_red e =
if n = 0 then e
else match t with
| MLapp (f,a) ->
- let m = (List.length a) - n in
- if m < 0 then e
- else
- let a1,a2 = list_chop m a in
- let f = if m = 0 then f else MLapp (f,a1) in
- if test_eta_args_lift 0 n a2 && not (ast_occurs_itvl 1 n f)
- then ast_lift (-n) f
- else e
+ let m = List.length a in
+ let ids,body,args =
+ if m = n then
+ [], f, a
+ else if m < n then
+ snd (list_chop (n-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)].
@@ -658,20 +664,27 @@ let check_generalizable_case unsafe br =
if check_and_generalize br.(i) <> f then raise Impossible
done; f
-(*s Do all branches correspond to the same thing? *)
+(*s Detecting similar branches of a match *)
-let check_constant_case br =
- if Array.length br = 0 then raise Impossible;
- let (r,l,t) = br.(0) in
- let n = List.length l in
- if ast_occurs_itvl 1 n t then raise Impossible;
- let cst = ast_lift (-n) t in
- for i = 1 to Array.length br - 1 do
- let (r,l,t) = br.(i) in
- let n = List.length l in
- if (ast_occurs_itvl 1 n t) || (cst <> (ast_lift (-n) t))
- then raise Impossible
- done; cst
+(* If several branches of a match are equal (and independent from their
+ patterns) we will print them using a _ pattern. If _all_ branches
+ are equal, we remove the match.
+*)
+
+let common_branches br =
+ let tab = Hashtbl.create 13 in
+ for i = 0 to Array.length br - 1 do
+ let (r,ids,t) = br.(i) in
+ let n = List.length ids in
+ if not (ast_occurs_itvl 1 n t) then
+ let t = ast_lift (-n) t in
+ let l = try Hashtbl.find tab t with Not_found -> [] in
+ Hashtbl.replace tab t (i::l)
+ done;
+ let best = ref [] in
+ Hashtbl.iter
+ (fun _ l -> if List.length l > List.length !best then best := l) tab;
+ if List.length !best < 2 then [] else !best
(*s If all branches are functions, try to permut the case and the functions. *)
@@ -805,18 +818,20 @@ and simpl_case o i br e =
let f = check_generalizable_case o.opt_case_idg br in
simpl o (MLapp (MLlam (anonymous,f),[e]))
with Impossible ->
- try (* Is each branch independant of [e] ? *)
- if not o.opt_case_cst then raise Impossible;
- check_constant_case br
- with Impossible ->
+ (* Detect common branches *)
+ let common_br = if not o.opt_case_cst then [] else common_branches br in
+ if List.length common_br = Array.length br && br <> [||] then
+ let (_,ids,t) = br.(0) in ast_lift (-List.length ids) t
+ else
+ let new_i = (fst i, common_br) in
(* Swap the case and the lam if possible *)
if o.opt_case_fun
then
let ids,br = permut_case_fun br [] in
let n = List.length ids in
- if n <> 0 then named_lams ids (MLcase (i,ast_lift n e, br))
- else MLcase (i,e,br)
- else MLcase (i,e,br)
+ if n <> 0 then named_lams ids (MLcase (new_i,ast_lift n e, br))
+ else MLcase (new_i,e,br)
+ else MLcase (new_i,e,br)
let rec post_simpl = function
| MLletin(_,c,e) when (is_atomic (eta_red c)) ->
@@ -1122,13 +1137,15 @@ let is_not_strict t =
Futhermore we don't expand fixpoints. *)
let inline_test t =
- not (is_fix (eta_red t)) && (ml_size t < 12 && is_not_strict t)
+ 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 manual_inline_list =
let mp = MPfile (dirpath_of_string "Coq.Init.Wf") in
List.map (fun s -> (make_con mp empty_dirpath (mk_label s)))
[ "well_founded_induction_type"; "well_founded_induction";
- "Acc_rect"; "Acc_rec" ; "Acc_iter" ]
+ "Acc_rect"; "Acc_rec" ; "Acc_iter" ; "Fix" ]
let manual_inline = function
| ConstRef c -> List.mem c manual_inline_list
diff --git a/contrib/extraction/modutil.ml b/contrib/extraction/modutil.ml
index c9d4e237..48444509 100644
--- a/contrib/extraction/modutil.ml
+++ b/contrib/extraction/modutil.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: modutil.ml 9456 2006-12-17 20:08:38Z letouzey $ i*)
+(*i $Id: modutil.ml 10665 2008-03-14 12:10:09Z soubiran $ i*)
open Names
open Declarations
@@ -20,121 +20,34 @@ open Mod_subst
(*S Functions upon modules missing in [Modops]. *)
-(*s Add _all_ direct subobjects of a module, not only those exported.
- Build on the [Modops.add_signature] model. *)
-
-let add_structure mp msb env =
- let add_one env (l,elem) =
- let kn = make_kn mp empty_dirpath l in
- let con = make_con mp empty_dirpath l in
- match elem with
- | SEBconst cb -> Environ.add_constant con cb env
- | SEBmind mib -> Environ.add_mind kn mib env
- | SEBmodule mb -> Modops.add_module (MPdot (mp,l)) mb env
- | SEBmodtype mtb -> Environ.add_modtype kn mtb env
- in List.fold_left add_one env msb
-
-(*s Apply a module path substitution on a module.
- Build on the [Modops.subst_modtype] model. *)
-
-let rec subst_module sub mb =
- let mtb' = Modops.subst_modtype sub mb.mod_type
- and meb' = option_smartmap (subst_meb sub) mb.mod_expr
- and mtb'' = option_smartmap (Modops.subst_modtype sub) mb.mod_user_type
- and mpo' = option_smartmap (subst_mp sub) mb.mod_equiv in
- if (mtb'==mb.mod_type) && (meb'==mb.mod_expr) &&
- (mtb''==mb.mod_user_type) && (mpo'==mb.mod_equiv)
- then mb
- else { mod_expr= meb';
- mod_type=mtb';
- mod_user_type=mtb'';
- mod_equiv=mpo';
- mod_constraints=mb.mod_constraints }
-
-and subst_meb sub = function
- | MEBident mp -> MEBident (subst_mp sub mp)
- | MEBfunctor (mbid, mtb, meb) ->
- assert (not (occur_mbid mbid sub));
- MEBfunctor (mbid, Modops.subst_modtype sub mtb, subst_meb sub meb)
- | MEBstruct (msid, msb) ->
- assert (not (occur_msid msid sub));
- MEBstruct (msid, subst_msb sub msb)
- | MEBapply (meb, meb', c) ->
- MEBapply (subst_meb sub meb, subst_meb sub meb', c)
-
-and subst_msb sub msb =
- let subst_body = function
- | SEBconst cb -> SEBconst (subst_const_body sub cb)
- | SEBmind mib -> SEBmind (subst_mind sub mib)
- | SEBmodule mb -> SEBmodule (subst_module sub mb)
- | SEBmodtype mtb -> SEBmodtype (Modops.subst_modtype sub mtb)
- in List.map (fun (l,b) -> (l,subst_body b)) msb
-
(*s Change a msid in a module type, to follow a module expr.
Because of the "with" construct, the module type of a module can be a
[MTBsig] with a msid different from the one of the module. *)
let rec replicate_msid meb mtb = match meb,mtb with
- | MEBfunctor (_, _, meb), MTBfunsig (mbid, mtb1, mtb2) ->
+ | SEBfunctor (_, _, meb), SEBfunctor (mbid, mtb1, mtb2) ->
let mtb' = replicate_msid meb mtb2 in
- if mtb' == mtb2 then mtb else MTBfunsig (mbid, mtb1, mtb')
- | MEBstruct (msid, _), MTBsig (msid1, msig) when msid <> msid1 ->
+ if mtb' == mtb2 then mtb else SEBfunctor (mbid, mtb1, mtb')
+ | SEBstruct (msid, _), SEBstruct (msid1, msig) when msid <> msid1 ->
let msig' = Modops.subst_signature_msid msid1 (MPself msid) msig in
- if msig' == msig then MTBsig (msid, msig) else MTBsig (msid, msig')
+ if msig' == msig then SEBstruct (msid, msig) else SEBstruct (msid, msig')
| _ -> mtb
-
-(*S More functions concerning [module_path]. *)
-
-let rec mp_length = function
- | MPdot (mp, _) -> 1 + (mp_length mp)
- | _ -> 1
-
-let rec prefixes_mp mp = match mp with
- | MPdot (mp',_) -> MPset.add mp (prefixes_mp mp')
- | _ -> MPset.singleton mp
-
-let rec common_prefix prefixes_mp1 mp2 =
- if MPset.mem mp2 prefixes_mp1 then mp2
- else match mp2 with
- | MPdot (mp,_) -> common_prefix prefixes_mp1 mp
- | _ -> raise Not_found
-
-let common_prefix_from_list mp0 mpl =
- let prefixes_mp0 = prefixes_mp mp0 in
- let rec f = function
- | [] -> raise Not_found
- | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> f l
- in f mpl
-
-let rec modfile_of_mp mp = match mp with
- | MPfile _ -> mp
- | MPdot (mp,_) -> modfile_of_mp mp
- | _ -> raise Not_found
-
-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 labels_of_ref r =
- let mp,_,l =
- match r with
- ConstRef con -> repr_con con
- | IndRef (kn,_)
- | ConstructRef ((kn,_),_) -> repr_kn kn
- | VarRef _ -> assert false
- in
- parse_labels [l] mp
-
-let rec add_labels_mp mp = function
- | [] -> mp
- | l :: ll -> add_labels_mp (MPdot (mp,l)) ll
-
-
(*S Functions upon ML modules. *)
-
+let rec msid_of_mt = function
+ | MTident mp -> begin
+ match Modops.eval_struct (Global.env()) (SEBident mp) with
+ | SEBstruct(msid,_) -> MPself msid
+ | _ -> anomaly "Extraction:the With can't be applied to a funsig"
+ end
+ | MTwith(mt,_)-> msid_of_mt mt
+ | _ -> anomaly "Extraction:the With operator isn't applied to a name"
+
+let make_mp_with mp idl =
+ let idl_rev = List.rev idl in
+ let idl' = List.rev (List.tl idl_rev) in
+ (List.fold_left (fun mp id -> MPdot(mp,label_of_id id))
+ mp idl')
(*s Apply some functions upon all [ml_decl] and [ml_spec] found in a
[ml_structure]. *)
@@ -142,6 +55,16 @@ 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 mp = make_mp_with mp_mt idl in
+ let gr = ConstRef (
+ (make_con mp empty_dirpath
+ (label_of_id (
+ List.hd (List.rev idl))))) in
+ mt_iter mt;do_decl
+ (Dtype(gr,l,t))
+ | MTwith (mt,_)->mt_iter mt
| MTsig (_, sign) -> List.iter spec_iter sign
and spec_iter = function
| (_,Spec s) -> do_spec s
@@ -186,7 +109,7 @@ let ast_iter_references do_term do_cons do_type a =
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 i;
+ if lang () = Ocaml then record_iter_references do_term (fst i);
Array.iter (fun (r,_,_) -> do_cons r) v
| _ -> ()
in iter a
@@ -197,7 +120,9 @@ let ind_iter_references do_term do_cons do_type kn ind =
let packet_iter ip p =
do_type (IndRef ip);
if lang () = Ocaml then
- option_iter (fun kne -> do_type (IndRef (kne,snd ip))) ind.ind_equiv;
+ (match ind.ind_equiv with
+ | Equiv kne -> do_type (IndRef (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;
@@ -215,7 +140,7 @@ let decl_iter_references do_term do_cons do_type =
let spec_iter_references do_term do_cons do_type = function
| Sind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind
- | Stype (r,_,ot) -> do_type r; option_iter (type_iter_references do_type) ot
+ | 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
let struct_iter_references do_term do_cons do_type =
@@ -225,13 +150,13 @@ let struct_iter_references do_term do_cons do_type =
(*s Get all references used in one [ml_structure], either in [list] or [set]. *)
-type 'a updown = { mutable up : 'a ; mutable down : 'a }
+type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a }
let struct_get_references empty add struc =
- let o = { up = empty ; down = empty } in
- let do_term r = o.down <- add r o.down in
- let do_cons r = o.up <- add r o.up in
- let do_type = if lang () = Haskell then do_cons else do_term in
+ let o = { typ = empty ; trm = empty ; cons = empty } in
+ let do_type r = o.typ <- add r o.typ in
+ let do_term r = o.trm <- add r o.trm in
+ let do_cons r = o.cons <- add r o.cons in
struct_iter_references do_term do_cons do_type struc; o
let struct_get_references_set = struct_get_references Refset.empty Refset.add
@@ -248,7 +173,9 @@ end
let struct_get_references_list struc =
let o = struct_get_references Orefset.empty Orefset.add struc in
- { up = Orefset.list o.up; down = Orefset.list o.down }
+ { typ = Orefset.list o.typ;
+ trm = Orefset.list o.trm;
+ cons = Orefset.list o.cons }
(*s Searching occurrences of a particular term (no lifting done). *)
@@ -284,7 +211,7 @@ 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
+ | Stype (_,_,ot) -> Option.iter (type_search f) ot
| Sval (_,u) -> type_search f u
let struct_type_search f s =
@@ -360,38 +287,40 @@ let dfix_to_mlfix rv av i =
let c = Array.map (subst 0) av
in MLfix(i, ids, c)
-let rec optim prm s = function
+let rec optim to_appear s = function
| [] -> []
| (Dtype (r,_,Tdummy _) | Dterm(r,MLdummy,_)) as d :: l ->
- if List.mem r prm.to_appear then d :: (optim prm s l) else optim prm s 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 || prm.modular || List.mem r prm.to_appear
+ 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 prm s l)
- else optim prm s l
- | d :: l -> d :: (optim prm s l)
+ 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 prm s = function
+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 prm.modular && not (List.mem r prm.to_appear)
- then optim_se top prm s lse
+ 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 prm s lse)
+ 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
@@ -402,22 +331,22 @@ let rec optim_se top prm s = function
then s := Refmap.add rv.(i) (dfix_to_mlfix rv av i) !s
else all := false
done;
- if !all && top && not prm.modular
- && (array_for_all (fun r -> not (List.mem r prm.to_appear)) rv)
- then optim_se top prm s lse
- else (l,SEdecl (Dfix (rv, av, tv))) :: (optim_se top prm s lse)
+ 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 prm s m.ml_mod_expr}
- in (l,SEmodule m) :: (optim_se top prm s lse)
- | se :: lse -> se :: (optim_se top prm s 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 prm s = function
- | MEstruct (msid, lse) -> MEstruct (msid, optim_se false prm 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 prm s me, optim_me prm s me')
- | MEfunctor (mbid,mt,me) -> MEfunctor (mbid,mt, optim_me prm s 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)
-let optimize_struct prm before struc =
+let optimize_struct to_appear struc =
let subst = ref (Refmap.empty : ml_ast Refmap.t) in
- option_iter (fun l -> ignore (optim prm subst l)) before;
- List.map (fun (mp,lse) -> (mp, optim_se true prm subst lse)) struc
+ List.map (fun (mp,lse) -> (mp, optim_se true to_appear subst lse)) struc
diff --git a/contrib/extraction/modutil.mli b/contrib/extraction/modutil.mli
index 115a42ca..85d58a4b 100644
--- a/contrib/extraction/modutil.mli
+++ b/contrib/extraction/modutil.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: modutil.mli 8724 2006-04-20 09:57:01Z letouzey $ i*)
+(*i $Id: modutil.mli 10620 2008-03-05 10:54:41Z letouzey $ i*)
open Names
open Declarations
@@ -17,29 +17,9 @@ open Mod_subst
(*s Functions upon modules missing in [Modops]. *)
-(* Add _all_ direct subobjects of a module, not only those exported.
- Build on the [Modops.add_signature] model. *)
-
-val add_structure : module_path -> module_structure_body -> env -> env
-
-(* Apply a module path substitution on a module.
- Build on the [Modops.subst_modtype] model. *)
-
-val subst_module : substitution -> module_body -> module_body
-val subst_meb : substitution -> module_expr_body -> module_expr_body
-val subst_msb : substitution -> module_structure_body -> module_structure_body
-
(* Change a msid in a module type, to follow a module expr. *)
-val replicate_msid : module_expr_body -> module_type_body -> module_type_body
-
-(*s More utilities concerning [module_path]. *)
-
-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
-val add_labels_mp : module_path -> label list -> module_path
+val replicate_msid : struct_expr_body -> struct_expr_body -> struct_expr_body
(*s Functions upon ML modules. *)
@@ -52,10 +32,10 @@ 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 struct_iter_references : do_ref -> do_ref -> do_ref -> ml_structure -> unit
-type 'a updown = { mutable up : 'a ; mutable down : 'a }
+type 'a kinds = { mutable typ : 'a ; mutable trm : 'a; mutable cons : 'a }
-val struct_get_references_set : ml_structure -> Refset.t updown
-val struct_get_references_list : ml_structure -> global_reference list updown
+val struct_get_references_set : ml_structure -> Refset.t kinds
+val struct_get_references_list : ml_structure -> global_reference list kinds
val signature_of_structure : ml_structure -> ml_signature
@@ -65,7 +45,7 @@ val get_decl_in_structure : global_reference -> ml_structure -> ml_decl
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. *)
+ optimizations. The first argument is the list of objects we want to appear.
+*)
-val optimize_struct :
- extraction_params -> ml_decl list option -> ml_structure -> ml_structure
+val optimize_struct : global_reference list -> ml_structure -> ml_structure
diff --git a/contrib/extraction/ocaml.ml b/contrib/extraction/ocaml.ml
index 35f9a83c..64c80a2a 100644
--- a/contrib/extraction/ocaml.ml
+++ b/contrib/extraction/ocaml.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: ocaml.ml 9472 2007-01-05 15:49:32Z letouzey $ i*)
+(*i $Id: ocaml.ml 10592 2008-02-27 14:16:07Z letouzey $ i*)
(*s Production of Ocaml syntax. *)
@@ -19,10 +19,27 @@ open Table
open Miniml
open Mlutil
open Modutil
+open Common
+open Declarations
+
(*s Some utility functions. *)
-let pp_par par st = if par then str "(" ++ st ++ str ")" else st
+let rec msid_of_mt = function
+ | MTident mp -> begin
+ match Modops.eval_struct (Global.env()) (SEBident mp) with
+ | SEBstruct(msid,_) -> MPself msid
+ | _ -> anomaly "Extraction:the With can't be applied to a funsig"
+ end
+ | MTwith(mt,_)-> msid_of_mt mt
+ | _ -> anomaly "Extraction:the With operator isn't applied to a name"
+
+let make_mp_with mp idl =
+ let idl_rev = List.rev idl in
+ let idl' = List.rev (List.tl idl_rev) in
+ (List.fold_left (fun mp id -> MPdot(mp,label_of_id id))
+ mp idl')
+
let pp_tvar id =
let s = string_of_id id in
@@ -52,70 +69,12 @@ let pp_abst = function
str "fun " ++ prlist_with_sep (fun () -> str " ") pr_id l ++
str " ->" ++ spc ()
-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 space_if = function true -> str " " | false -> mt ()
-
-let sec_space_if = function true -> spc () | false -> mt ()
-
-let fnl2 () = fnl () ++ fnl ()
-
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 Generic renaming issues. *)
-
-let rec rename_id id avoid =
- if Idset.mem id avoid then rename_id (lift_ident id) avoid else id
-
-let lowercase_id id = id_of_string (String.uncapitalize (string_of_id id))
-let uppercase_id id = id_of_string (String.capitalize (string_of_id id))
-
-(* [pr_upper_id id] makes 2 String.copy lesser than [pr_id (uppercase_id id)] *)
-let pr_upper_id id = str (String.capitalize (string_of_id id))
-
-(*s de Bruijn environments for programs *)
-
-type env = identifier list * Idset.t
-
-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 Ocaml renaming issues. *)
let keywords =
@@ -130,46 +89,39 @@ let keywords =
"land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ; "unit" ; "_" ; "__" ]
Idset.empty
-let preamble _ used_modules (mldummy,tdummy,tunknown) _ =
- let pp_mp = function
- | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
- | _ -> assert false
- in
- prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules
- ++
- (if used_modules = [] then mt () else fnl ())
- ++
- (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() else mt())
- ++
- (if mldummy then
- str "let __ = let rec f _ = Obj.repr f in Obj.repr f" ++ fnl ()
- else mt ())
- ++
- (if tdummy || tunknown || mldummy then fnl () else mt ())
-
-let preamble_sig _ used_modules (_,tdummy,tunknown) =
- let pp_mp = function
- | MPfile d -> pr_upper_id (List.hd (repr_dirpath d))
- | _ -> assert false
- in
- prlist (fun mp -> str "open " ++ pp_mp mp ++ fnl ()) used_modules
- ++
- (if used_modules = [] then mt () else fnl ())
- ++
- (if tdummy || tunknown then str "type __ = Obj.t" ++ fnl() ++ fnl ()
- else mt())
+let pp_open mp = str ("open "^ string_of_modfile mp ^"\n")
-(*s The pretty-printing functor. *)
+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 ())
-module Make = functor(P : Mlpp_param) -> struct
+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())
-let local_mpl = ref ([] : module_path list)
+(*s The pretty-printer for Ocaml syntax*)
-let pp_global r =
+let pp_global k r =
if is_inline_custom r then str (find_custom r)
- else P.pp_global !local_mpl r
+ else str (Common.pp_global k r)
+
+let pp_modname mp = str (Common.pp_module mp)
-let empty_env () = [], P.globals ()
+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
@@ -187,12 +139,16 @@ let rec pp_type par vl t =
| Tmeta _ | Tvar' _ | Taxiom -> assert false
| Tvar i -> (try pp_tvar (List.nth vl (pred i))
with _ -> (str "'a" ++ int i))
- | Tglob (r,[]) -> pp_global r
+ | Tglob (r,[a1;a2]) when is_infix r ->
+ pp_par par
+ (pp_rec true a1 ++ spc () ++ str (get_infix r) ++ spc () ++
+ pp_rec true a2)
+ | Tglob (r,[]) -> pp_global Type r
| Tglob (r,l) ->
if r = IndRef (kn_sig,0) then
pp_tuple_light pp_rec l
else
- pp_tuple_light pp_rec l ++ spc () ++ pp_global r
+ 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)
@@ -206,10 +162,16 @@ let rec pp_type par vl t =
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 _ -> true
+ | MLcase (_,_,pv) -> not (is_ifthenelse pv)
| _ -> false
@@ -244,26 +206,31 @@ let rec pp_expr par env args =
(try
let args = list_skipn (projection_arity r) args in
let record = List.hd args in
- pp_apply (record ++ str "." ++ pp_global r) par (List.tl args)
- with _ -> apply (pp_global r))
+ pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args)
+ with _ -> apply (pp_global Term r))
| MLcons (Coinductive,r,[]) ->
assert (args=[]);
- pp_par par (str "lazy " ++ pp_global r)
+ 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 r ++ spc() ++ tuple ++str ")")
+ pp_par par (str "lazy (" ++ pp_global Cons r ++ spc() ++ tuple ++str ")")
| MLcons (_,r,[]) ->
assert (args=[]);
- pp_global r
+ 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) ++ spc () ++ str (get_infix r) ++
+ spc () ++ (pp_expr true env [] arg2))
| MLcons (_,r,args') ->
assert (args=[]);
let tuple = pp_tuple (pp_expr true env []) args' in
- pp_par par (pp_global r ++ spc () ++ tuple)
- | MLcase (i, t, pv) ->
+ pp_par par (pp_global Cons r ++ spc () ++ tuple)
+ | MLcase ((i,factors), t, pv) ->
let expr = if i = Coinductive then
(str "Lazy.force" ++ spc () ++ pp_expr true env [] t)
else
@@ -276,7 +243,7 @@ let rec pp_expr par env args =
match c with
| MLrel i when i <= n ->
apply (pp_par par' (pp_expr true env [] t ++ str "." ++
- pp_global (List.nth projs (n-i))))
+ 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
@@ -284,7 +251,7 @@ let rec pp_expr par env args =
let ids,env' = push_vars (List.rev ids) env in
(pp_apply
(pp_expr true env [] t ++ str "." ++
- pp_global (List.nth projs (n-i)))
+ pp_global Term (List.nth projs (n-i)))
par ((List.map (pp_expr true env' []) a) @ args))
| _ -> raise NoRecord
with NoRecord ->
@@ -297,11 +264,13 @@ let rec pp_expr par env args =
(hov 2 (str "let " ++ s1 ++ str " =" ++ spc () ++ expr)
++ spc () ++ str "in") ++
spc () ++ hov 0 s2)))
- else
- apply
+ else
+ apply
(pp_par par'
- (v 0 (str "match " ++ expr ++ str " with" ++
- fnl () ++ str " | " ++ pp_pat env i pv))))
+ (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
@@ -319,10 +288,21 @@ let rec pp_expr par env args =
and pp_record_pat (projs, args) =
str "{ " ++
prlist_with_sep (fun () -> str ";" ++ spc ())
- (fun (r,a) -> pp_global r ++ str " =" ++ spc () ++ a)
+ (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 ids) env in
let expr = pp_expr (expr_needs_par t) env' [] t in
@@ -330,33 +310,45 @@ and pp_one_pat env i (r,ids,t) =
let projs = find_projections i in
pp_record_pat (projs, List.rev_map pr_id ids), expr
with NoRecord ->
- let args =
- if ids = [] then (mt ())
- else str " " ++ pp_boxed_tuple pr_id (List.rev ids) in
- pp_global r ++ args, expr
+ (match List.rev ids with
+ | [i1;i2] when is_infix r ->
+ pr_id i1 ++ str " " ++ str (get_infix r) ++ str " " ++ pr_id i2
+ | [] -> pp_global Cons r
+ | ids -> pp_global Cons r ++ str " " ++ pp_boxed_tuple pr_id ids),
+ expr
-and pp_pat env i pv =
- prvect_with_sep (fun () -> (fnl () ++ str " | "))
- (fun x -> let s1,s2 = pp_one_pat env i x in
- hov 2 (s1 ++ str " ->" ++ spc () ++ s2)) pv
-
-and pp_function env f t =
+and pp_pat env (info,factors) pv =
+ prvecti
+ (fun i x -> if List.mem i factors then mt () else
+ let s1,s2 = pp_one_pat env info x in
+ hov 2 (s1 ++ str " ->" ++ spc () ++ s2) ++
+ (if factors = [] && i = Array.length pv-1 then mt ()
+ else fnl () ++ str " | ")) pv
+ ++
+ match factors with
+ | [] -> mt ()
+ | i::_ ->
+ let (_,ids,t) = pv.(i) in
+ let t = ast_lift (-List.length ids) t in
+ hov 2 (str "_ ->" ++ spc () ++ pp_expr (expr_needs_par t) env [] t)
+
+and pp_function env t =
let bl,t' = collect_lams t in
let bl,env' = push_vars bl env in
match t' with
- | MLcase(i,MLrel 1,pv) when i=Standard ->
+ | MLcase(i,MLrel 1,pv) when fst i=Standard ->
if not (ast_occurs 1 (MLcase(i,MLdummy,pv))) then
- (f ++ pr_binding (List.rev (List.tl bl)) ++
- str " = function" ++ fnl () ++
- v 0 (str " | " ++ pp_pat env' i pv))
+ pr_binding (List.rev (List.tl bl)) ++
+ str " = function" ++ fnl () ++
+ v 0 (str " | " ++ pp_pat env' i pv)
else
- (f ++ pr_binding (List.rev bl) ++
- str " = match " ++
- pr_id (List.hd bl) ++ str " with" ++ fnl () ++
- v 0 (str " | " ++ pp_pat env' i pv))
- | _ -> (f ++ pr_binding (List.rev bl) ++
- str " =" ++ fnl () ++ str " " ++
- hov 2 (pp_expr false env' [] t'))
+ 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. *)
@@ -366,93 +358,111 @@ and pp_fix par env i (ids,bl) args =
(v 0 (str "let rec " ++
prvect_with_sep
(fun () -> fnl () ++ str "and ")
- (fun (fi,ti) -> pp_function env (pr_id fi) ti)
+ (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 =
- str "(** val " ++ e ++ str " : " ++ pp_type false [] typ ++
- str " **)" ++ fnl2 ()
+ hov 4 (str "(** val " ++ e ++ str " :" ++ spc () ++ pp_type false [] typ ++
+ str " **)") ++ fnl2 ()
(*s Pretty-printing of [Dfix] *)
-let rec pp_Dfix init i ((rv,c,t) as fix) =
- if i >= Array.length rv then mt ()
- else
- if is_inline_custom rv.(i) then pp_Dfix init (i+1) fix
+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 e = pp_global rv.(i) in
- (if init then mt () else fnl2 ()) ++
- pp_val e t.(i) ++
- str (if init then "let rec " else "and ") ++
- (if is_custom rv.(i) then e ++ str " = " ++ str (find_custom rv.(i))
- else pp_function (empty_env ()) e c.(i)) ++
- pp_Dfix false (i+1) fix
-
+ 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 = function
- | None -> mt ()
- | Some ip_equiv ->
- str " = " ++ pp_parameters param_list ++ pp_global (IndRef ip_equiv)
+let pp_equiv param_list name = function
+ | NoEquiv, _ -> mt ()
+ | Equiv kn, i ->
+ str " = " ++ pp_parameters param_list ++ pp_global Type (IndRef (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 ip_equiv pl cv =
+let pp_one_ind prefix ip_equiv pl name cnames ctyps =
let pl = rename_tvars keywords pl in
- let pp_constructor (r,l) =
- hov 2 (str " | " ++ pp_global r ++
- match l with
- | [] -> mt ()
- | _ -> (str " of " ++
- prlist_with_sep
- (fun () -> spc () ++ str "* ") (pp_type true pl) l))
+ 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 ++ pp_global (IndRef ip) ++
- pp_equiv pl ip_equiv ++ str " =" ++
- if Array.length cv = 0 then str " unit (* empty inductive *)"
- else fnl () ++ v 0 (prvect_with_sep fnl pp_constructor
- (Array.mapi (fun i c -> ConstructRef (ip,i+1), c) cv))
+ 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 () ++
+ 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 (kn,0)) in
let l = rename_tvars keywords packet.ip_vars in
- hov 2 (str "type " ++ pp_parameters l ++
- pp_global (IndRef (kn,0)) ++ str " =" ++ spc () ++
+ 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 l = List.combine projs packet.ip_types.(0) in
+ let name = pp_global Type (IndRef (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 ++ pp_global (IndRef (kn,0)) ++
- pp_equiv pl ip_equiv ++ str " = { "++
+ str "type " ++ pp_parameters pl ++ name ++
+ pp_equiv pl name ip_equiv ++ str " = { "++
hov 0 (prlist_with_sep (fun () -> str ";" ++ spc ())
- (fun (r,t) -> pp_global r ++ str " : " ++ pp_type true pl t) l)
+ (fun (p,t) -> p ++ str " : " ++ pp_type true pl t) l)
++ str " }"
-let pp_coind ip pl =
- let r = IndRef ip in
+let pp_coind pl name =
let pl = rename_tvars keywords pl in
- pp_parameters pl ++ pp_global r ++ str " = " ++
- pp_parameters pl ++ str "__" ++ pp_global r ++ str " Lazy.t" ++
+ 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 (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 ((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 = (kn,i) in
- let ip_equiv = option_map (fun kn -> (kn,i)) ind.ind_equiv in
+ let ip_equiv = ind.ind_equiv, 0 in
let p = ind.ind_packets.(i) in
if is_custom (IndRef ip) then pp (i+1)
else begin
@@ -463,8 +473,9 @@ let pp_ind co kn ind =
begin
init := (fnl () ++ str "and ");
s ++
- (if co then pp_coind ip p.ip_vars else mt ())
- ++ pp_one_ind prefix ip ip_equiv p.ip_vars p.ip_types ++
+ (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
@@ -479,159 +490,248 @@ let pp_mind kn i =
| Singleton -> pp_singleton kn i.ind_packets.(0)
| Coinductive -> pp_ind true kn i
| Record projs ->
- let ip_equiv = option_map (fun kn -> (kn,0)) i.ind_equiv in
- pp_record kn projs ip_equiv i.ind_packets.(0)
+ pp_record kn projs (i.ind_equiv,0) i.ind_packets.(0)
| Standard -> pp_ind false kn i
-let pp_decl mpl =
- local_mpl := mpl;
- function
+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) ->
- if is_inline_custom r then failwith "empty phrase"
- else
- let pp_r = pp_global r in
- let l = rename_tvars keywords l in
- let ids, def = try
+ | 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 ->
+ 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" ++ spc () ++ ids ++ pp_r ++
- spc () ++ def)
+ in
+ hov 2 (str "type " ++ ids ++ name ++ spc () ++ def)
| Dterm (r, a, t) ->
- if is_inline_custom r then failwith "empty phrase"
- else
- let e = pp_global r in
- pp_val e t ++
- hov 0
- (str "let " ++
- if is_custom r then
- e ++ str " = " ++ str (find_custom r)
- else if is_projection r then
- let s = prvecti (fun _ -> str)
- (Array.make (projection_arity r) " _") in
- e ++ s ++ str " x = x." ++ e
- else pp_function (empty_env ()) e a)
+ 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 true 0 (rv,defs,typs)
-
-let pp_spec mpl =
- local_mpl := mpl;
- function
- | Sind (kn,i) -> pp_mind kn i
- | Sval (r,t) ->
- if is_inline_custom r then failwith "empty phrase"
- else
- hov 2 (str "val" ++ spc () ++ pp_global r ++ str " :" ++ spc () ++
- pp_type false [] t)
- | Stype (r,vl,ot) ->
- if is_inline_custom r then failwith "empty phrase"
- else
- 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" ++ spc () ++ ids ++ pp_global r ++ spc () ++ def)
-
-let rec pp_specif mpl = function
- | (_,Spec s) -> pp_spec mpl s
+ 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) ->
- hov 1
- (str "module " ++
- P.pp_module mpl (MPdot (List.hd mpl, l)) ++
- str " : " ++ fnl () ++ pp_module_type mpl None (* (Some l) *) mt)
+ let def = pp_module_type (Some l) mt in
+ let def' = pp_module_type (Some l) 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) ->
- hov 1
- (str "module type " ++
- P.pp_module mpl (MPdot (List.hd mpl, l)) ++
- str " = " ++ fnl () ++ pp_module_type mpl None mt)
-
-and pp_module_type mpl ol = function
+ let def = pp_module_type None 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 ol = function
| MTident kn ->
- let mp,_,l = repr_kn kn in P.pp_module mpl (MPdot (mp,l))
+ pp_modname kn
| MTfunsig (mbid, mt, mt') ->
- str "functor (" ++
- P.pp_module mpl (MPbound mbid) ++
- str ":" ++
- pp_module_type mpl None mt ++
- str ") ->" ++ fnl () ++
- pp_module_type mpl None mt'
+ let name = pp_modname (MPbound mbid) in
+ let typ = pp_module_type None mt in
+ let def = pp_module_type None mt' in
+ str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
| MTsig (msid, sign) ->
- let mpl = match ol, mpl with
- | None, _ -> (MPself msid) :: mpl
- | Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl
- | _ -> assert false
- in
- let l = map_succeed (pp_specif mpl) sign in
+ let tvm = top_visible_mp () in
+ Option.iter (fun l -> add_subst msid (MPdot (tvm, l))) ol;
+ let mp = MPself msid in
+ push_visible mp;
+ 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"
-
+ fnl () ++ str "end"
+ | MTwith(mt,ML_With_type(idl,vl,typ)) ->
+ let l = rename_tvars keywords vl in
+ let ids = pp_parameters l in
+ let mp_mt = msid_of_mt mt in
+ let mp = make_mp_with mp_mt idl in
+ let gr = ConstRef (
+ (make_con mp empty_dirpath
+ (label_of_id (
+ List.hd (List.rev idl))))) in
+ push_visible mp_mt;
+ let s = pp_module_type None mt ++
+ str " with type " ++
+ pp_global Type gr ++
+ ids in
+ pop_visible();
+ s ++ str "=" ++ spc () ++
+ pp_type false vl typ
+ | MTwith(mt,ML_With_module(idl,mp)) ->
+ let mp_mt=msid_of_mt mt in
+ push_visible mp_mt;
+ let s =
+ pp_module_type None mt ++
+ str " with module " ++
+ (pp_modname
+ (List.fold_left (fun mp id -> MPdot(mp,label_of_id id))
+ mp_mt idl))
+ ++ str " = "
+ in
+ pop_visible ();
+ s ++ (pp_modname mp)
+
+
let is_short = function MEident _ | MEapply _ -> true | _ -> false
-
-let rec pp_structure_elem mpl = function
- | (_,SEdecl d) -> pp_decl mpl d
+
+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 def = pp_module_expr (Some l) m.ml_mod_expr in
+ let name = pp_modname (MPdot (top_visible_mp (), l)) in
hov 1
- (str "module " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++
- (*i if you want signatures everywhere: i*)
- (*i str " :" ++ fnl () ++ i*)
- (*i pp_module_type mpl None m.ml_mod_type ++ fnl () ++ i*)
- str " = " ++
- (if (is_short m.ml_mod_expr) then mt () else fnl ()) ++
- pp_module_expr mpl (Some l) m.ml_mod_expr)
+ (str "module " ++ name ++ 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) ->
- hov 1
- (str "module type " ++ P.pp_module mpl (MPdot (List.hd mpl, l)) ++
- str " = " ++ fnl () ++ pp_module_type mpl None m)
-
-and pp_module_expr mpl ol = function
- | MEident mp' -> P.pp_module mpl mp'
+ let def = pp_module_type None 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 ol = function
+ | MEident mp' -> pp_modname mp'
| MEfunctor (mbid, mt, me) ->
- str "functor (" ++
- P.pp_module mpl (MPbound mbid) ++
- str ":" ++
- pp_module_type mpl None mt ++
- str ") ->" ++ fnl () ++
- pp_module_expr mpl None me
+ let name = pp_modname (MPbound mbid) in
+ let typ = pp_module_type None mt in
+ let def = pp_module_expr None me in
+ str "functor (" ++ name ++ str ":" ++ typ ++ str ") ->" ++ fnl () ++ def
| MEapply (me, me') ->
- pp_module_expr mpl None me ++ str "(" ++
- pp_module_expr mpl None me' ++ str ")"
+ pp_module_expr None me ++ str "(" ++ pp_module_expr None me' ++ str ")"
| MEstruct (msid, sel) ->
- let mpl = match ol, mpl with
- | None, _ -> (MPself msid) :: mpl
- | Some l, mp :: mpl -> (MPdot (mp,l)) :: mpl
- | _ -> assert false
- in
- let l = map_succeed (pp_structure_elem mpl) sel in
+ let tvm = top_visible_mp () in
+ let mp = match ol with None -> MPself msid | Some l -> MPdot (tvm,l) in
+ push_visible mp;
+ 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 pp_struct s =
- let pp mp s = pp_structure_elem [mp] s ++ fnl2 () in
- prlist (fun (mp,sel) -> prlist identity (map_succeed (pp mp) sel)) s
+ let pp mp s =
+ push_visible mp;
+ let p = pp_structure_elem s ++ fnl2 () in
+ pop_visible (); p
+ in
+ prlist_strict
+ (fun (mp,sel) -> prlist_strict identity (map_succeed (pp mp) sel)) s
let pp_signature s =
- let pp mp s = pp_specif [mp] s ++ fnl2 () in
- prlist (fun (mp,sign) -> prlist identity (map_succeed (pp mp) sign)) s
-
-let pp_decl mpl d =
- try pp_decl mpl d with Failure "empty phrase" -> mt ()
-
-end
-
+ let pp mp s =
+ push_visible mp;
+ let p = pp_specif s ++ fnl2 () in
+ pop_visible (); p
+ in
+ prlist_strict
+ (fun (mp,sign) -> prlist_strict identity (map_succeed (pp mp) sign)) s
+
+let pp_decl d =
+ try pp_decl d with Failure "empty phrase" -> mt ()
+
+let ocaml_descr = {
+ keywords = keywords;
+ file_suffix = ".ml";
+ capital_file = false;
+ 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/contrib/extraction/ocaml.mli b/contrib/extraction/ocaml.mli
index 8c521ccd..3d90e74c 100644
--- a/contrib/extraction/ocaml.mli
+++ b/contrib/extraction/ocaml.mli
@@ -6,49 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: ocaml.mli 7632 2005-12-01 14:35:21Z letouzey $ i*)
-
-(*s Some utility functions to be reused in module [Haskell]. *)
-
-open Pp
-open Names
-open Libnames
-open Miniml
-
-val pp_par : bool -> std_ppcmds -> std_ppcmds
-val pp_abst : identifier list -> 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
-
-val lowercase_id : identifier -> identifier
-val uppercase_id : identifier -> identifier
-
-val pr_upper_id : identifier -> std_ppcmds
-
-type env = identifier list * Idset.t
-
-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
-
-val keywords : Idset.t
-
-val preamble :
- extraction_params -> module_path list -> bool*bool*bool -> bool -> std_ppcmds
-
-val preamble_sig :
- extraction_params -> module_path list -> bool*bool*bool -> std_ppcmds
-
-(*s Production of Ocaml syntax. We export both a functor to be used for
- extraction in the Coq toplevel and a function to extract some
- declarations to a file. *)
-
-module Make : functor(P : Mlpp_param) -> Mlpp
-
-
-
+(*i $Id: ocaml.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
+val ocaml_descr : Miniml.language_descr
diff --git a/contrib/extraction/scheme.ml b/contrib/extraction/scheme.ml
index 7004a202..600f64db 100644
--- a/contrib/extraction/scheme.ml
+++ b/contrib/extraction/scheme.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: scheme.ml 7651 2005-12-16 03:19:20Z letouzey $ i*)
+(*i $Id: scheme.ml 10233 2007-10-17 23:29:08Z letouzey $ i*)
(*s Production of Scheme syntax. *)
@@ -18,7 +18,7 @@ open Libnames
open Miniml
open Mlutil
open Table
-open Ocaml
+open Common
(*s Scheme renaming issues. *)
@@ -29,17 +29,11 @@ let keywords =
"error"; "delay"; "force"; "_"; "__"]
Idset.empty
-let preamble _ _ (mldummy,_,_) _ =
- str ";; This extracted scheme code relies on some additional macros" ++
- fnl () ++
- str ";; available at http://www.pps.jussieu.fr/~letouzey/scheme" ++
- fnl () ++
- str "(load \"macros_extr.scm\")" ++
- fnl () ++ fnl () ++
- (if mldummy then
- str "(define __ (lambda (_) __))"
- ++ fnl () ++ fnl()
- else mt ())
+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
@@ -60,14 +54,11 @@ let pp_apply st _ = function
| [] -> st
| [a] -> hov 2 (paren (st ++ spc () ++ a))
| args -> hov 2 (paren (str "@ " ++ st ++
- (prlist (fun x -> spc () ++ x) args)))
+ (prlist_strict (fun x -> spc () ++ x) args)))
-(*s The pretty-printing functor. *)
+(*s The pretty-printer for Scheme syntax *)
-module Make = functor(P : Mlpp_param) -> struct
-
-let pp_global r = P.pp_global [initial_path] r
-let empty_env () = [], P.globals()
+let pp_global k r = str (Common.pp_global k r)
(*s Pretty-printing of expressions. *)
@@ -95,17 +86,17 @@ let rec pp_expr env args =
(pr_id (List.hd i) ++ spc () ++ pp_expr env [] a1))
++ spc () ++ hov 0 (pp_expr env' [] a2)))))
| MLglob r ->
- apply (pp_global r)
+ apply (pp_global Term r)
| MLcons (i,r,args') ->
assert (args=[]);
let st =
str "`" ++
- paren (pp_global r ++
+ 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 (i,t, pv) ->
+ | MLcase ((i,_),t, pv) ->
let e =
if i <> Coinductive then pp_expr env [] t
else paren (str "force" ++ spc () ++ pp_expr env [] t)
@@ -125,7 +116,7 @@ let rec pp_expr env args =
and pp_cons_args env = function
| MLcons (i,r,args) when i<>Coinductive ->
- paren (pp_global r ++
+ paren (pp_global Cons r ++
(if args = [] then mt () else spc ()) ++
prlist_with_sep spc (pp_cons_args env) args)
| e -> str "," ++ pp_expr env [] e
@@ -137,7 +128,7 @@ and pp_one_pat env (r,ids,t) =
if ids = [] then mt ()
else (str " " ++ prlist_with_sep spc pr_id (List.rev ids))
in
- (pp_global r ++ args), (pp_expr env' [] t)
+ (pp_global Cons r ++ args), (pp_expr env' [] t)
and pp_pat env pv =
prvect_with_sep fnl
@@ -160,11 +151,11 @@ and pp_fix env j (ids,bl) args =
(*s Pretty-printing of a declaration. *)
-let pp_decl _ = function
+let pp_decl = function
| Dind _ -> mt ()
| Dtype _ -> mt ()
| Dfix (rv, defs,_) ->
- let ppv = Array.map pp_global rv in
+ let ppv = Array.map (pp_global Term) rv in
prvect_with_sep fnl
(fun (pi,ti) ->
hov 2
@@ -177,23 +168,35 @@ let pp_decl _ = function
if is_inline_custom r then mt ()
else
if is_custom r then
- hov 2 (paren (str "define " ++ pp_global r ++ spc () ++
+ hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++
str (find_custom r))) ++ fnl () ++ fnl ()
else
- hov 2 (paren (str "define " ++ pp_global r ++ spc () ++
+ hov 2 (paren (str "define " ++ pp_global Term r ++ spc () ++
pp_expr (empty_env ()) [] a)) ++ fnl () ++ fnl ()
-let pp_structure_elem mp = function
- | (l,SEdecl d) -> pp_decl mp d
+let pp_structure_elem = function
+ | (l,SEdecl d) -> pp_decl d
| (l,SEmodule m) ->
failwith "TODO: Scheme extraction of modules not implemented yet"
| (l,SEmodtype m) ->
failwith "TODO: Scheme extraction of modules not implemented yet"
let pp_struct =
- prlist (fun (mp,sel) -> prlist (pp_structure_elem mp) sel)
-
-let pp_signature s = assert false
-
-end
-
+ 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";
+ capital_file = false;
+ preamble = preamble;
+ pp_struct = pp_struct;
+ sig_suffix = None;
+ sig_preamble = (fun _ _ _ -> mt ());
+ pp_sig = (fun _ -> mt ());
+ pp_decl = pp_decl;
+}
diff --git a/contrib/extraction/scheme.mli b/contrib/extraction/scheme.mli
index ef4a3a63..a88bb6db 100644
--- a/contrib/extraction/scheme.mli
+++ b/contrib/extraction/scheme.mli
@@ -6,22 +6,6 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: scheme.mli 7632 2005-12-01 14:35:21Z letouzey $ i*)
-
-(*s Some utility functions to be reused in module [Haskell]. *)
-
-open Pp
-open Miniml
-open Names
-
-val keywords : Idset.t
-
-val preamble :
- extraction_params -> module_path list -> bool*bool*bool -> bool -> std_ppcmds
-
-module Make : functor(P : Mlpp_param) -> Mlpp
-
-
-
-
+(*i $Id: scheme.mli 10232 2007-10-17 12:32:10Z letouzey $ i*)
+val scheme_descr : Miniml.language_descr
diff --git a/contrib/extraction/table.ml b/contrib/extraction/table.ml
index 6d39faee..abf461c1 100644
--- a/contrib/extraction/table.ml
+++ b/contrib/extraction/table.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: table.ml 10209 2007-10-09 21:49:37Z letouzey $ i*)
+(*i $Id: table.ml 10348 2007-12-06 17:36:14Z aspiwack $ i*)
open Names
open Term
@@ -20,37 +20,49 @@ open Util
open Pp
open Miniml
-(*S Utilities concerning [module_path] and [kernel_names] *)
+(*S Utilities about [module_path] and [kernel_names] and [global_reference] *)
-let occur_kn_in_ref kn =
- function
+let occur_kn_in_ref kn = function
| IndRef (kn',_)
| ConstructRef ((kn',_),_) -> kn = kn'
| ConstRef _ -> false
| VarRef _ -> assert false
-
-let modpath_of_r r = match r with
- | ConstRef kn -> con_modpath kn
- | IndRef (kn,_)
- | ConstructRef ((kn,_),_) -> modpath kn
- | VarRef _ -> assert false
-
-let label_of_r r = match r with
- | ConstRef kn -> con_label kn
- | IndRef (kn,_)
- | ConstructRef ((kn,_),_) -> label kn
- | VarRef _ -> assert false
-
-let current_toplevel () = fst (Lib.current_prefix ())
+
+let modpath_of_r = function
+ | ConstRef kn -> con_modpath kn
+ | IndRef (kn,_)
+ | ConstructRef ((kn,_),_) -> modpath kn
+ | VarRef _ -> assert false
+
+let label_of_r = function
+ | ConstRef kn -> con_label kn
+ | IndRef (kn,_)
+ | ConstructRef ((kn,_),_) -> label kn
+ | VarRef _ -> assert false
let rec base_mp = function
| MPdot (mp,l) -> base_mp mp
| mp -> mp
+let rec mp_length = function
+ | MPdot (mp, _) -> 1 + (mp_length mp)
+ | _ -> 1
+
let is_modfile = function
| MPfile _ -> true
| _ -> false
+let 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 ()
@@ -60,8 +72,56 @@ let at_toplevel mp =
let visible_kn kn = at_toplevel (base_mp (modpath kn))
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 mp = match mp with
+ | MPdot (mp,l) -> if n=1 then l else get_nth_label_mp (n-1) mp
+ | _ -> failwith "get_nth_label: not enough MPdot"
+
+let get_nth_label n r =
+ if n=0 then label_of_r r else get_nth_label_mp n (modpath_of_r r)
+
+let rec common_prefix prefixes_mp1 mp2 =
+ if MPset.mem mp2 prefixes_mp1 then mp2
+ else match mp2 with
+ | MPdot (mp,_) -> common_prefix prefixes_mp1 mp
+ | _ -> raise Not_found
+
+let common_prefix_from_list mp0 mpl =
+ let prefixes_mp0 = prefixes_mp mp0 in
+ let rec f = function
+ | [] -> raise Not_found
+ | mp1 :: l -> try common_prefix prefixes_mp0 mp1 with Not_found -> 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 labels_of_ref r =
+ let mp,_,l =
+ match r with
+ ConstRef con -> repr_con con
+ | IndRef (kn,_)
+ | ConstructRef ((kn,_),_) -> repr_kn kn
+ | VarRef _ -> assert false
+ in
+ parse_labels [l] 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)
@@ -109,11 +169,26 @@ 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 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 Tables synchronization. *)
let reset_tables () =
init_terms (); init_types (); init_inductives (); init_recursors ();
- init_projs ()
+ init_projs (); init_axioms ()
(*s Printing. *)
@@ -146,21 +221,34 @@ let pr_long_global r =
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 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 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 error_axiom_scheme r i =
err (str "The type scheme axiom " ++ spc () ++
pr_global r ++ spc () ++ str "needs " ++ pr_int i ++
str " type variable(s).")
-let warning_info_ax r =
- msg_warning (str "You must realize axiom " ++
- pr_global r ++ str " in the extracted code.")
-
-let warning_log_ax r =
- msg_warning (str "This extraction depends on logical axiom" ++ spc () ++
- pr_global r ++ str "." ++ spc() ++
- str "Having false logical axiom in the environment when extracting" ++
- spc () ++ str "may lead to incorrect or non-terminating ML terms.")
-
let check_inside_module () =
if Lib.is_modtype () then
err (str "You can't do that within a Module Type." ++ fnl () ++
@@ -186,15 +274,11 @@ let error_nb_cons () =
let error_module_clash s =
err (str ("There are two Coq modules with ML name " ^ s ^".\n") ++
- str "This is not allowed in ML. Please do some renaming first.")
+ 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_toplevel () =
- err (str "Toplevel pseudo-ML language can be used only at Coq toplevel.\n" ++
- str "You should use Extraction Language Ocaml or Haskell before.")
-
let error_scheme () =
err (str "No Scheme modular extraction available yet.")
@@ -203,9 +287,13 @@ let error_not_visible r =
str "For example, it may be inside an applied functor." ++
str "Use Recursive Extraction to get the whole environment.")
-let error_MPfile_as_mod d =
- err (str ("The whole file "^(string_of_dirpath d)^".v is used somewhere as a module.\n"^
- "Extraction cannot currently deal with this situation.\n"))
+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 "^(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 " ++ pr_global r ++ str " has an anonymous field." ++ fnl () ++
@@ -216,8 +304,16 @@ let check_loaded_modfile mp = match base_mp mp with
err (str ("Please load library "^(string_of_dirpath dp^" first.")))
| _ -> ()
+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 true
@@ -305,7 +401,7 @@ let _ = declare_int_option
(*s Extraction Lang *)
-type lang = Ocaml | Haskell | Scheme | Toplevel
+type lang = Ocaml | Haskell | Scheme
let lang_ref = ref Ocaml
@@ -327,7 +423,6 @@ let _ = declare_summary "Extraction Lang"
let extraction_language x = Lib.add_anonymous_leaf (extr_lang x)
-
(*s Extraction Inline/NoInline *)
let empty_inline_table = (Refset.empty,Refset.empty)
diff --git a/contrib/extraction/table.mli b/contrib/extraction/table.mli
index c9a4e8da..ca02cb4d 100644
--- a/contrib/extraction/table.mli
+++ b/contrib/extraction/table.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: table.mli 10209 2007-10-09 21:49:37Z letouzey $ i*)
+(*i $Id: table.mli 10245 2007-10-21 13:41:53Z letouzey $ i*)
open Names
open Libnames
@@ -14,39 +14,49 @@ open Miniml
open Declarations
val id_of_global : global_reference -> identifier
+val pr_long_global : global_reference -> Pp.std_ppcmds
+
(*s Warning and Error messages. *)
+val warning_axioms : unit -> unit
val error_axiom_scheme : global_reference -> int -> 'a
-val warning_info_ax : global_reference -> unit
-val warning_log_ax : global_reference -> unit
val error_constant : global_reference -> 'a
val error_inductive : global_reference -> 'a
val error_nb_cons : unit -> 'a
val error_module_clash : string -> 'a
val error_unknown_module : qualid -> 'a
-val error_toplevel : unit -> 'a
val error_scheme : unit -> 'a
val error_not_visible : global_reference -> 'a
-val error_MPfile_as_mod : dir_path -> '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
-(*s utilities concerning [module_path]. *)
+val info_file : string -> unit
+
+(*s utilities about [module_path] and [kernel_names] and [global_reference] *)
val occur_kn_in_ref : kernel_name -> global_reference -> bool
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 is_modfile : module_path -> bool
+val string_of_modfile : module_path -> string
val is_toplevel : module_path -> bool
val at_toplevel : module_path -> bool
val visible_kn : kernel_name -> 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
+val add_labels_mp : module_path -> label list -> module_path
+val get_nth_label_mp : int -> module_path -> label
+val get_nth_label : int -> global_reference -> label
+val labels_of_ref : global_reference -> module_path * label list
(*s Some table-related operations *)
@@ -66,6 +76,9 @@ 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 add_log_axiom : global_reference -> unit
+
val reset_tables : unit -> unit
(*s AutoInline parameter *)
@@ -95,9 +108,14 @@ val optims : unit -> opt_flag
(*s Target language. *)
-type lang = Ocaml | Haskell | Scheme | Toplevel
+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
diff --git a/contrib/extraction/test/.depend b/contrib/extraction/test/.depend
deleted file mode 100644
index 31d46eeb..00000000
--- a/contrib/extraction/test/.depend
+++ /dev/null
@@ -1,1136 +0,0 @@
-theories/Arith/arith.cmo: theories/Arith/arith.cmi
-theories/Arith/arith.cmx: theories/Arith/arith.cmi
-theories/Arith/between.cmo: theories/Arith/between.cmi
-theories/Arith/between.cmx: theories/Arith/between.cmi
-theories/Arith/bool_nat.cmo: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/Arith/peano_dec.cmi \
- theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
- theories/Arith/bool_nat.cmi
-theories/Arith/bool_nat.cmx: theories/Bool/sumbool.cmx \
- theories/Init/specif.cmx theories/Arith/peano_dec.cmx \
- theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
- theories/Arith/bool_nat.cmi
-theories/Arith/compare_dec.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi
-theories/Arith/compare_dec.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Arith/compare_dec.cmi
-theories/Arith/compare.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
- theories/Arith/compare.cmi
-theories/Arith/compare.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
- theories/Arith/compare.cmi
-theories/Arith/div2.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/Arith/div2.cmi
-theories/Arith/div2.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
- theories/Init/datatypes.cmx theories/Arith/div2.cmi
-theories/Arith/eqNat.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Arith/eqNat.cmi
-theories/Arith/eqNat.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Arith/eqNat.cmi
-theories/Arith/euclid.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
- theories/Arith/euclid.cmi
-theories/Arith/euclid.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
- theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
- theories/Arith/euclid.cmi
-theories/Arith/even.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/Arith/even.cmi
-theories/Arith/even.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
- theories/Arith/even.cmi
-theories/Arith/factorial.cmo: theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/Arith/factorial.cmi
-theories/Arith/factorial.cmx: theories/Init/peano.cmx \
- theories/Init/datatypes.cmx theories/Arith/factorial.cmi
-theories/Arith/gt.cmo: theories/Arith/gt.cmi
-theories/Arith/gt.cmx: theories/Arith/gt.cmi
-theories/Arith/le.cmo: theories/Arith/le.cmi
-theories/Arith/le.cmx: theories/Arith/le.cmi
-theories/Arith/lt.cmo: theories/Arith/lt.cmi
-theories/Arith/lt.cmx: theories/Arith/lt.cmi
-theories/Arith/max.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/Arith/max.cmi
-theories/Arith/max.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
- theories/Arith/max.cmi
-theories/Arith/min.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/Arith/min.cmi
-theories/Arith/min.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
- theories/Arith/min.cmi
-theories/Arith/minus.cmo: theories/Arith/minus.cmi
-theories/Arith/minus.cmx: theories/Arith/minus.cmi
-theories/Arith/mult.cmo: theories/Arith/plus.cmi theories/Init/datatypes.cmi \
- theories/Arith/mult.cmi
-theories/Arith/mult.cmx: theories/Arith/plus.cmx theories/Init/datatypes.cmx \
- theories/Arith/mult.cmi
-theories/Arith/peano_dec.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Arith/peano_dec.cmi
-theories/Arith/peano_dec.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Arith/peano_dec.cmi
-theories/Arith/plus.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/Arith/plus.cmi
-theories/Arith/plus.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
- theories/Arith/plus.cmi
-theories/Arith/wf_nat.cmo: theories/Init/datatypes.cmi \
- theories/Arith/wf_nat.cmi
-theories/Arith/wf_nat.cmx: theories/Init/datatypes.cmx \
- theories/Arith/wf_nat.cmi
-theories/Bool/boolEq.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Bool/boolEq.cmi
-theories/Bool/boolEq.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Bool/boolEq.cmi
-theories/Bool/bool.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/Bool/bool.cmi
-theories/Bool/bool.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
- theories/Bool/bool.cmi
-theories/Bool/bvector.cmo: theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/Bool/bool.cmi \
- theories/Bool/bvector.cmi
-theories/Bool/bvector.cmx: theories/Init/peano.cmx \
- theories/Init/datatypes.cmx theories/Bool/bool.cmx \
- theories/Bool/bvector.cmi
-theories/Bool/decBool.cmo: theories/Init/specif.cmi theories/Bool/decBool.cmi
-theories/Bool/decBool.cmx: theories/Init/specif.cmx theories/Bool/decBool.cmi
-theories/Bool/ifProp.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Bool/ifProp.cmi
-theories/Bool/ifProp.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Bool/ifProp.cmi
-theories/Bool/sumbool.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Bool/sumbool.cmi
-theories/Bool/sumbool.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Bool/sumbool.cmi
-theories/Bool/zerob.cmo: theories/Init/datatypes.cmi theories/Bool/zerob.cmi
-theories/Bool/zerob.cmx: theories/Init/datatypes.cmx theories/Bool/zerob.cmi
-theories/FSets/decidableTypeEx.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \
- theories/Init/datatypes.cmi theories/FSets/decidableTypeEx.cmi
-theories/FSets/decidableTypeEx.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedTypeEx.cmx theories/FSets/orderedType.cmx \
- theories/Init/datatypes.cmx theories/FSets/decidableTypeEx.cmi
-theories/FSets/decidableType.cmo: theories/Init/specif.cmi \
- theories/FSets/decidableType.cmi
-theories/FSets/decidableType.cmx: theories/Init/specif.cmx \
- theories/FSets/decidableType.cmi
-theories/FSets/fMapAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/FSets/int.cmi theories/FSets/fMapList.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/FSets/fMapAVL.cmi
-theories/FSets/fMapAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/Lists/list.cmx \
- theories/FSets/int.cmx theories/FSets/fMapList.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/FSets/fMapAVL.cmi
-theories/FSets/fMapFacts.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/FSets/fMapInterface.cmi \
- theories/Init/datatypes.cmi theories/FSets/fMapFacts.cmi
-theories/FSets/fMapFacts.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/FSets/fMapInterface.cmx \
- theories/Init/datatypes.cmx theories/FSets/fMapFacts.cmi
-theories/FSets/fMapInterface.cmo: theories/FSets/orderedType.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi \
- theories/FSets/fMapInterface.cmi
-theories/FSets/fMapInterface.cmx: theories/FSets/orderedType.cmx \
- theories/Lists/list.cmx theories/Init/datatypes.cmx \
- theories/FSets/fMapInterface.cmi
-theories/FSets/fMapIntMap.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \
- theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \
- theories/IntMap/map.cmi theories/Lists/list.cmi \
- theories/FSets/fMapList.cmi theories/Init/datatypes.cmi \
- theories/NArith/binNat.cmi theories/FSets/fMapIntMap.cmi
-theories/FSets/fMapIntMap.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/NArith/ndigits.cmx \
- theories/IntMap/mapiter.cmx theories/IntMap/mapcanon.cmx \
- theories/IntMap/map.cmx theories/Lists/list.cmx \
- theories/FSets/fMapList.cmx theories/Init/datatypes.cmx \
- theories/NArith/binNat.cmx theories/FSets/fMapIntMap.cmi
-theories/FSets/fMapList.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/FSets/fMapList.cmi
-theories/FSets/fMapList.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/Lists/list.cmx \
- theories/Init/datatypes.cmx theories/FSets/fMapList.cmi
-theories/FSets/fMapPositive.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/FSets/fMapPositive.cmi
-theories/FSets/fMapPositive.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/Lists/list.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/FSets/fMapPositive.cmi
-theories/FSets/fMaps.cmo: theories/FSets/fMaps.cmi
-theories/FSets/fMaps.cmx: theories/FSets/fMaps.cmi
-theories/FSets/fMapWeakFacts.cmo: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \
- theories/Init/datatypes.cmi theories/FSets/fMapWeakFacts.cmi
-theories/FSets/fMapWeakFacts.cmx: theories/Init/specif.cmx \
- theories/Lists/list.cmx theories/FSets/fMapWeakInterface.cmx \
- theories/Init/datatypes.cmx theories/FSets/fMapWeakFacts.cmi
-theories/FSets/fMapWeakInterface.cmo: theories/Lists/list.cmi \
- theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \
- theories/FSets/fMapWeakInterface.cmi
-theories/FSets/fMapWeakInterface.cmx: theories/Lists/list.cmx \
- theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \
- theories/FSets/fMapWeakInterface.cmi
-theories/FSets/fMapWeakList.cmo: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/FSets/decidableType.cmi \
- theories/Init/datatypes.cmi theories/FSets/fMapWeakList.cmi
-theories/FSets/fMapWeakList.cmx: theories/Init/specif.cmx \
- theories/Lists/list.cmx theories/FSets/decidableType.cmx \
- theories/Init/datatypes.cmx theories/FSets/fMapWeakList.cmi
-theories/FSets/fMapWeak.cmo: theories/FSets/fMapWeak.cmi
-theories/FSets/fMapWeak.cmx: theories/FSets/fMapWeak.cmi
-theories/FSets/fSetAVL.cmo: theories/Init/wf.cmi theories/Init/specif.cmi \
- theories/Init/peano.cmi theories/FSets/orderedType.cmi \
- theories/Lists/list.cmi theories/FSets/int.cmi \
- theories/FSets/fSetList.cmi theories/Init/datatypes.cmi \
- theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
- theories/FSets/fSetAVL.cmi
-theories/FSets/fSetAVL.cmx: theories/Init/wf.cmx theories/Init/specif.cmx \
- theories/Init/peano.cmx theories/FSets/orderedType.cmx \
- theories/Lists/list.cmx theories/FSets/int.cmx \
- theories/FSets/fSetList.cmx theories/Init/datatypes.cmx \
- theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
- theories/FSets/fSetAVL.cmi
-theories/FSets/fSetBridge.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
- theories/FSets/fSetBridge.cmi
-theories/FSets/fSetBridge.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/Lists/list.cmx \
- theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \
- theories/FSets/fSetBridge.cmi
-theories/FSets/fSetEqProperties.cmo: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/Init/peano.cmi \
- theories/FSets/orderedType.cmi theories/FSets/fSetProperties.cmi \
- theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
- theories/Bool/bool.cmi theories/FSets/fSetEqProperties.cmi
-theories/FSets/fSetEqProperties.cmx: theories/Init/specif.cmx \
- theories/Setoids/setoid.cmx theories/Init/peano.cmx \
- theories/FSets/orderedType.cmx theories/FSets/fSetProperties.cmx \
- theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \
- theories/Bool/bool.cmx theories/FSets/fSetEqProperties.cmi
-theories/FSets/fSetFacts.cmo: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \
- theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
- theories/FSets/fSetFacts.cmi
-theories/FSets/fSetFacts.cmx: theories/Init/specif.cmx \
- theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \
- theories/FSets/fSetInterface.cmx theories/Init/datatypes.cmx \
- theories/FSets/fSetFacts.cmi
-theories/FSets/fSetInterface.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/FSets/fSetInterface.cmi
-theories/FSets/fSetInterface.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/Lists/list.cmx \
- theories/Init/datatypes.cmx theories/FSets/fSetInterface.cmi
-theories/FSets/fSetList.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/FSets/fSetList.cmi
-theories/FSets/fSetList.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/Lists/list.cmx \
- theories/Init/datatypes.cmx theories/FSets/fSetList.cmi
-theories/FSets/fSetProperties.cmo: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/FSets/orderedType.cmi \
- theories/Lists/list.cmi theories/FSets/fSetInterface.cmi \
- theories/FSets/fSetFacts.cmi theories/Init/datatypes.cmi \
- theories/FSets/fSetProperties.cmi
-theories/FSets/fSetProperties.cmx: theories/Init/specif.cmx \
- theories/Setoids/setoid.cmx theories/FSets/orderedType.cmx \
- theories/Lists/list.cmx theories/FSets/fSetInterface.cmx \
- theories/FSets/fSetFacts.cmx theories/Init/datatypes.cmx \
- theories/FSets/fSetProperties.cmi
-theories/FSets/fSets.cmo: theories/FSets/fSets.cmi
-theories/FSets/fSets.cmx: theories/FSets/fSets.cmi
-theories/FSets/fSetToFiniteSet.cmo: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/FSets/fSetProperties.cmi theories/Init/datatypes.cmi \
- theories/FSets/fSetToFiniteSet.cmi
-theories/FSets/fSetToFiniteSet.cmx: theories/Init/specif.cmx \
- theories/Setoids/setoid.cmx theories/FSets/orderedTypeEx.cmx \
- theories/FSets/orderedType.cmx theories/Lists/list.cmx \
- theories/FSets/fSetProperties.cmx theories/Init/datatypes.cmx \
- theories/FSets/fSetToFiniteSet.cmi
-theories/FSets/fSetWeakFacts.cmo: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \
- theories/Init/datatypes.cmi theories/FSets/fSetWeakFacts.cmi
-theories/FSets/fSetWeakFacts.cmx: theories/Init/specif.cmx \
- theories/Setoids/setoid.cmx theories/FSets/fSetWeakInterface.cmx \
- theories/Init/datatypes.cmx theories/FSets/fSetWeakFacts.cmi
-theories/FSets/fSetWeakInterface.cmo: theories/Lists/list.cmi \
- theories/FSets/decidableType.cmi theories/Init/datatypes.cmi \
- theories/FSets/fSetWeakInterface.cmi
-theories/FSets/fSetWeakInterface.cmx: theories/Lists/list.cmx \
- theories/FSets/decidableType.cmx theories/Init/datatypes.cmx \
- theories/FSets/fSetWeakInterface.cmi
-theories/FSets/fSetWeakList.cmo: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/FSets/decidableType.cmi \
- theories/Init/datatypes.cmi theories/FSets/fSetWeakList.cmi
-theories/FSets/fSetWeakList.cmx: theories/Init/specif.cmx \
- theories/Lists/list.cmx theories/FSets/decidableType.cmx \
- theories/Init/datatypes.cmx theories/FSets/fSetWeakList.cmi
-theories/FSets/fSetWeak.cmo: theories/FSets/fSetWeak.cmi
-theories/FSets/fSetWeak.cmx: theories/FSets/fSetWeak.cmi
-theories/FSets/fSetWeakProperties.cmo: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/Lists/list.cmi \
- theories/FSets/fSetWeakInterface.cmi theories/FSets/fSetWeakFacts.cmi \
- theories/Init/datatypes.cmi theories/FSets/fSetWeakProperties.cmi
-theories/FSets/fSetWeakProperties.cmx: theories/Init/specif.cmx \
- theories/Setoids/setoid.cmx theories/Lists/list.cmx \
- theories/FSets/fSetWeakInterface.cmx theories/FSets/fSetWeakFacts.cmx \
- theories/Init/datatypes.cmx theories/FSets/fSetWeakProperties.cmi
-theories/FSets/int.cmo: theories/ZArith/zmax.cmi \
- theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
- theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
- theories/FSets/int.cmi
-theories/FSets/int.cmx: theories/ZArith/zmax.cmx \
- theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \
- theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
- theories/FSets/int.cmi
-theories/FSets/orderedTypeAlt.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \
- theories/FSets/orderedTypeAlt.cmi
-theories/FSets/orderedTypeAlt.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \
- theories/FSets/orderedTypeAlt.cmi
-theories/FSets/orderedTypeEx.cmo: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \
- theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi theories/ZArith/binInt.cmi \
- theories/FSets/orderedTypeEx.cmi
-theories/FSets/orderedTypeEx.cmx: theories/Init/specif.cmx \
- theories/FSets/orderedType.cmx theories/Init/datatypes.cmx \
- theories/Arith/compare_dec.cmx theories/NArith/binPos.cmx \
- theories/NArith/binNat.cmx theories/ZArith/binInt.cmx \
- theories/FSets/orderedTypeEx.cmi
-theories/FSets/orderedType.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/FSets/orderedType.cmi
-theories/FSets/orderedType.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/FSets/orderedType.cmi
-theories/Init/datatypes.cmo: theories/Init/datatypes.cmi
-theories/Init/datatypes.cmx: theories/Init/datatypes.cmi
-theories/Init/logic.cmo: theories/Init/logic.cmi
-theories/Init/logic.cmx: theories/Init/logic.cmi
-theories/Init/logic_Type.cmo: theories/Init/logic_Type.cmi
-theories/Init/logic_Type.cmx: theories/Init/logic_Type.cmi
-theories/Init/notations.cmo: theories/Init/notations.cmi
-theories/Init/notations.cmx: theories/Init/notations.cmi
-theories/Init/peano.cmo: theories/Init/datatypes.cmi theories/Init/peano.cmi
-theories/Init/peano.cmx: theories/Init/datatypes.cmx theories/Init/peano.cmi
-theories/Init/prelude.cmo: theories/Init/prelude.cmi
-theories/Init/prelude.cmx: theories/Init/prelude.cmi
-theories/Init/specif.cmo: theories/Init/datatypes.cmi \
- theories/Init/specif.cmi
-theories/Init/specif.cmx: theories/Init/datatypes.cmx \
- theories/Init/specif.cmi
-theories/Init/tactics.cmo: theories/Init/tactics.cmi
-theories/Init/tactics.cmx: theories/Init/tactics.cmi
-theories/Init/wf.cmo: theories/Init/wf.cmi
-theories/Init/wf.cmx: theories/Init/wf.cmi
-theories/IntMap/adalloc.cmo: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi theories/IntMap/adalloc.cmi
-theories/IntMap/adalloc.cmx: theories/Bool/sumbool.cmx \
- theories/Init/specif.cmx theories/NArith/ndec.cmx theories/IntMap/map.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/NArith/binNat.cmx theories/IntMap/adalloc.cmi
-theories/IntMap/allmaps.cmo: theories/IntMap/allmaps.cmi
-theories/IntMap/allmaps.cmx: theories/IntMap/allmaps.cmi
-theories/IntMap/fset.cmo: theories/Init/specif.cmi \
- theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
- theories/IntMap/map.cmi theories/Init/datatypes.cmi \
- theories/NArith/binNat.cmi theories/IntMap/fset.cmi
-theories/IntMap/fset.cmx: theories/Init/specif.cmx \
- theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
- theories/IntMap/map.cmx theories/Init/datatypes.cmx \
- theories/NArith/binNat.cmx theories/IntMap/fset.cmi
-theories/IntMap/lsort.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
- theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
- theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi \
- theories/NArith/binNat.cmi theories/IntMap/lsort.cmi
-theories/IntMap/lsort.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \
- theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
- theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \
- theories/Lists/list.cmx theories/Init/datatypes.cmx \
- theories/NArith/binNat.cmx theories/IntMap/lsort.cmi
-theories/IntMap/mapaxioms.cmo: theories/IntMap/mapaxioms.cmi
-theories/IntMap/mapaxioms.cmx: theories/IntMap/mapaxioms.cmi
-theories/IntMap/mapcanon.cmo: theories/Init/specif.cmi \
- theories/IntMap/map.cmi theories/IntMap/mapcanon.cmi
-theories/IntMap/mapcanon.cmx: theories/Init/specif.cmx \
- theories/IntMap/map.cmx theories/IntMap/mapcanon.cmi
-theories/IntMap/mapcard.cmo: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/Arith/plus.cmi \
- theories/Arith/peano_dec.cmi theories/Init/peano.cmi \
- theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
- theories/IntMap/map.cmi theories/Init/datatypes.cmi \
- theories/NArith/binNat.cmi theories/IntMap/mapcard.cmi
-theories/IntMap/mapcard.cmx: theories/Bool/sumbool.cmx \
- theories/Init/specif.cmx theories/Arith/plus.cmx \
- theories/Arith/peano_dec.cmx theories/Init/peano.cmx \
- theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
- theories/IntMap/map.cmx theories/Init/datatypes.cmx \
- theories/NArith/binNat.cmx theories/IntMap/mapcard.cmi
-theories/IntMap/mapc.cmo: theories/IntMap/mapc.cmi
-theories/IntMap/mapc.cmx: theories/IntMap/mapc.cmi
-theories/IntMap/mapfold.cmo: theories/Init/specif.cmi \
- theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
- theories/IntMap/fset.cmi theories/Init/datatypes.cmi \
- theories/IntMap/mapfold.cmi
-theories/IntMap/mapfold.cmx: theories/Init/specif.cmx \
- theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \
- theories/IntMap/fset.cmx theories/Init/datatypes.cmx \
- theories/IntMap/mapfold.cmi
-theories/IntMap/mapiter.cmo: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/NArith/ndigits.cmi \
- theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/NArith/binNat.cmi \
- theories/IntMap/mapiter.cmi
-theories/IntMap/mapiter.cmx: theories/Bool/sumbool.cmx \
- theories/Init/specif.cmx theories/NArith/ndigits.cmx \
- theories/NArith/ndec.cmx theories/IntMap/map.cmx theories/Lists/list.cmx \
- theories/Init/datatypes.cmx theories/NArith/binNat.cmx \
- theories/IntMap/mapiter.cmi
-theories/IntMap/maplists.cmo: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/NArith/ndec.cmi \
- theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
- theories/Lists/list.cmi theories/IntMap/fset.cmi \
- theories/Init/datatypes.cmi theories/IntMap/maplists.cmi
-theories/IntMap/maplists.cmx: theories/Bool/sumbool.cmx \
- theories/Init/specif.cmx theories/NArith/ndec.cmx \
- theories/IntMap/mapiter.cmx theories/IntMap/map.cmx \
- theories/Lists/list.cmx theories/IntMap/fset.cmx \
- theories/Init/datatypes.cmx theories/IntMap/maplists.cmi
-theories/IntMap/map.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi theories/IntMap/map.cmi
-theories/IntMap/map.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
- theories/NArith/ndigits.cmx theories/NArith/ndec.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/NArith/binNat.cmx theories/IntMap/map.cmi
-theories/IntMap/mapsubset.cmo: theories/IntMap/mapiter.cmi \
- theories/IntMap/map.cmi theories/IntMap/fset.cmi \
- theories/Init/datatypes.cmi theories/Bool/bool.cmi \
- theories/IntMap/mapsubset.cmi
-theories/IntMap/mapsubset.cmx: theories/IntMap/mapiter.cmx \
- theories/IntMap/map.cmx theories/IntMap/fset.cmx \
- theories/Init/datatypes.cmx theories/Bool/bool.cmx \
- theories/IntMap/mapsubset.cmi
-theories/Lists/list.cmo: theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/Lists/list.cmi
-theories/Lists/list.cmx: theories/Init/specif.cmx theories/Init/datatypes.cmx \
- theories/Lists/list.cmi
-theories/Lists/listSet.cmo: theories/Init/specif.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/Lists/listSet.cmi
-theories/Lists/listSet.cmx: theories/Init/specif.cmx theories/Lists/list.cmx \
- theories/Init/datatypes.cmx theories/Lists/listSet.cmi
-theories/Lists/monoList.cmo: theories/Init/datatypes.cmi \
- theories/Lists/monoList.cmi
-theories/Lists/monoList.cmx: theories/Init/datatypes.cmx \
- theories/Lists/monoList.cmi
-theories/Lists/setoidList.cmo: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi \
- theories/Lists/setoidList.cmi
-theories/Lists/setoidList.cmx: theories/Init/specif.cmx \
- theories/Lists/list.cmx theories/Init/datatypes.cmx \
- theories/Lists/setoidList.cmi
-theories/Lists/streams.cmo: theories/Init/datatypes.cmi \
- theories/Lists/streams.cmi
-theories/Lists/streams.cmx: theories/Init/datatypes.cmx \
- theories/Lists/streams.cmi
-theories/Lists/theoryList.cmo: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi \
- theories/Lists/theoryList.cmi
-theories/Lists/theoryList.cmx: theories/Init/specif.cmx \
- theories/Lists/list.cmx theories/Init/datatypes.cmx \
- theories/Lists/theoryList.cmi
-theories/Logic/berardi.cmo: theories/Logic/berardi.cmi
-theories/Logic/berardi.cmx: theories/Logic/berardi.cmi
-theories/Logic/choiceFacts.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Logic/choiceFacts.cmi
-theories/Logic/choiceFacts.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Logic/choiceFacts.cmi
-theories/Logic/classicalChoice.cmo: theories/Logic/classicalChoice.cmi
-theories/Logic/classicalChoice.cmx: theories/Logic/classicalChoice.cmi
-theories/Logic/classicalDescription.cmo: theories/Init/specif.cmi \
- theories/Logic/choiceFacts.cmi theories/Logic/classicalDescription.cmi
-theories/Logic/classicalDescription.cmx: theories/Init/specif.cmx \
- theories/Logic/choiceFacts.cmx theories/Logic/classicalDescription.cmi
-theories/Logic/classicalEpsilon.cmo: theories/Init/specif.cmi \
- theories/Logic/choiceFacts.cmi theories/Logic/classicalEpsilon.cmi
-theories/Logic/classicalEpsilon.cmx: theories/Init/specif.cmx \
- theories/Logic/choiceFacts.cmx theories/Logic/classicalEpsilon.cmi
-theories/Logic/classicalFacts.cmo: theories/Logic/classicalFacts.cmi
-theories/Logic/classicalFacts.cmx: theories/Logic/classicalFacts.cmi
-theories/Logic/classical.cmo: theories/Logic/classical.cmi
-theories/Logic/classical.cmx: theories/Logic/classical.cmi
-theories/Logic/classical_Pred_Set.cmo: theories/Logic/classical_Pred_Set.cmi
-theories/Logic/classical_Pred_Set.cmx: theories/Logic/classical_Pred_Set.cmi
-theories/Logic/classical_Pred_Type.cmo: \
- theories/Logic/classical_Pred_Type.cmi
-theories/Logic/classical_Pred_Type.cmx: \
- theories/Logic/classical_Pred_Type.cmi
-theories/Logic/classical_Prop.cmo: theories/Logic/eqdepFacts.cmi \
- theories/Logic/classical_Prop.cmi
-theories/Logic/classical_Prop.cmx: theories/Logic/eqdepFacts.cmx \
- theories/Logic/classical_Prop.cmi
-theories/Logic/classical_Type.cmo: theories/Logic/classical_Type.cmi
-theories/Logic/classical_Type.cmx: theories/Logic/classical_Type.cmi
-theories/Logic/classicalUniqueChoice.cmo: \
- theories/Logic/classicalUniqueChoice.cmi
-theories/Logic/classicalUniqueChoice.cmx: \
- theories/Logic/classicalUniqueChoice.cmi
-theories/Logic/decidable.cmo: theories/Logic/decidable.cmi
-theories/Logic/decidable.cmx: theories/Logic/decidable.cmi
-theories/Logic/diaconescu.cmo: theories/Init/specif.cmi \
- theories/Logic/diaconescu.cmi
-theories/Logic/diaconescu.cmx: theories/Init/specif.cmx \
- theories/Logic/diaconescu.cmi
-theories/Logic/eqdep_dec.cmo: theories/Init/specif.cmi \
- theories/Logic/eqdep_dec.cmi
-theories/Logic/eqdep_dec.cmx: theories/Init/specif.cmx \
- theories/Logic/eqdep_dec.cmi
-theories/Logic/eqdepFacts.cmo: theories/Logic/eqdepFacts.cmi
-theories/Logic/eqdepFacts.cmx: theories/Logic/eqdepFacts.cmi
-theories/Logic/eqdep.cmo: theories/Logic/eqdepFacts.cmi \
- theories/Logic/eqdep.cmi
-theories/Logic/eqdep.cmx: theories/Logic/eqdepFacts.cmx \
- theories/Logic/eqdep.cmi
-theories/Logic/hurkens.cmo: theories/Logic/hurkens.cmi
-theories/Logic/hurkens.cmx: theories/Logic/hurkens.cmi
-theories/Logic/jMeq.cmo: theories/Logic/jMeq.cmi
-theories/Logic/jMeq.cmx: theories/Logic/jMeq.cmi
-theories/Logic/proofIrrelevanceFacts.cmo: theories/Logic/eqdepFacts.cmi \
- theories/Logic/proofIrrelevanceFacts.cmi
-theories/Logic/proofIrrelevanceFacts.cmx: theories/Logic/eqdepFacts.cmx \
- theories/Logic/proofIrrelevanceFacts.cmi
-theories/Logic/proofIrrelevance.cmo: theories/Logic/proofIrrelevanceFacts.cmi \
- theories/Logic/proofIrrelevance.cmi
-theories/Logic/proofIrrelevance.cmx: theories/Logic/proofIrrelevanceFacts.cmx \
- theories/Logic/proofIrrelevance.cmi
-theories/Logic/relationalChoice.cmo: theories/Logic/relationalChoice.cmi
-theories/Logic/relationalChoice.cmx: theories/Logic/relationalChoice.cmi
-theories/NArith/binNat.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi
-theories/NArith/binNat.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/NArith/binNat.cmi
-theories/NArith/binPos.cmo: theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi
-theories/NArith/binPos.cmx: theories/Init/peano.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmi
-theories/NArith/nArith.cmo: theories/NArith/nArith.cmi
-theories/NArith/nArith.cmx: theories/NArith/nArith.cmi
-theories/NArith/ndec.cmo: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
- theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \
- theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
- theories/NArith/binPos.cmi theories/NArith/binNat.cmi \
- theories/NArith/ndec.cmi
-theories/NArith/ndec.cmx: theories/Bool/sumbool.cmx theories/Init/specif.cmx \
- theories/NArith/nnat.cmx theories/NArith/ndigits.cmx \
- theories/Init/datatypes.cmx theories/Arith/compare_dec.cmx \
- theories/NArith/binPos.cmx theories/NArith/binNat.cmx \
- theories/NArith/ndec.cmi
-theories/NArith/ndigits.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
- theories/Bool/bool.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi theories/NArith/ndigits.cmi
-theories/NArith/ndigits.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Bool/bvector.cmx \
- theories/Bool/bool.cmx theories/NArith/binPos.cmx \
- theories/NArith/binNat.cmx theories/NArith/ndigits.cmi
-theories/NArith/ndist.cmo: theories/NArith/ndigits.cmi theories/Arith/min.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi theories/NArith/ndist.cmi
-theories/NArith/ndist.cmx: theories/NArith/ndigits.cmx theories/Arith/min.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/NArith/binNat.cmx theories/NArith/ndist.cmi
-theories/NArith/nnat.cmo: theories/Init/datatypes.cmi \
- theories/NArith/binPos.cmi theories/NArith/binNat.cmi \
- theories/NArith/nnat.cmi
-theories/NArith/nnat.cmx: theories/Init/datatypes.cmx \
- theories/NArith/binPos.cmx theories/NArith/binNat.cmx \
- theories/NArith/nnat.cmi
-theories/NArith/pnat.cmo: theories/NArith/pnat.cmi
-theories/NArith/pnat.cmx: theories/NArith/pnat.cmi
-theories/QArith/qArith_base.cmo: theories/ZArith/zArith_dec.cmi \
- theories/Init/specif.cmi theories/Setoids/setoid.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/QArith/qArith_base.cmi
-theories/QArith/qArith_base.cmx: theories/ZArith/zArith_dec.cmx \
- theories/Init/specif.cmx theories/Setoids/setoid.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/QArith/qArith_base.cmi
-theories/QArith/qArith.cmo: theories/QArith/qArith.cmi
-theories/QArith/qArith.cmx: theories/QArith/qArith.cmi
-theories/QArith/qreals.cmo: theories/QArith/qArith_base.cmi \
- theories/ZArith/binInt.cmi theories/QArith/qreals.cmi
-theories/QArith/qreals.cmx: theories/QArith/qArith_base.cmx \
- theories/ZArith/binInt.cmx theories/QArith/qreals.cmi
-theories/QArith/qreduction.cmo: theories/ZArith/znumtheory.cmi \
- theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/QArith/qreduction.cmi
-theories/QArith/qreduction.cmx: theories/ZArith/znumtheory.cmx \
- theories/Setoids/setoid.cmx theories/QArith/qArith_base.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/QArith/qreduction.cmi
-theories/QArith/qring.cmo: theories/Init/specif.cmi \
- theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi \
- theories/QArith/qring.cmi
-theories/QArith/qring.cmx: theories/Init/specif.cmx \
- theories/QArith/qArith_base.cmx theories/Init/datatypes.cmx \
- theories/QArith/qring.cmi
-theories/Relations/newman.cmo: theories/Relations/newman.cmi
-theories/Relations/newman.cmx: theories/Relations/newman.cmi
-theories/Relations/operators_Properties.cmo: \
- theories/Relations/operators_Properties.cmi
-theories/Relations/operators_Properties.cmx: \
- theories/Relations/operators_Properties.cmi
-theories/Relations/relation_Definitions.cmo: \
- theories/Relations/relation_Definitions.cmi
-theories/Relations/relation_Definitions.cmx: \
- theories/Relations/relation_Definitions.cmi
-theories/Relations/relation_Operators.cmo: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/Relations/relation_Operators.cmi
-theories/Relations/relation_Operators.cmx: theories/Init/specif.cmx \
- theories/Lists/list.cmx theories/Relations/relation_Operators.cmi
-theories/Relations/relations.cmo: theories/Relations/relations.cmi
-theories/Relations/relations.cmx: theories/Relations/relations.cmi
-theories/Relations/rstar.cmo: theories/Relations/rstar.cmi
-theories/Relations/rstar.cmx: theories/Relations/rstar.cmi
-theories/Setoids/setoid.cmo: theories/Init/datatypes.cmi \
- theories/Setoids/setoid.cmi
-theories/Setoids/setoid.cmx: theories/Init/datatypes.cmx \
- theories/Setoids/setoid.cmi
-theories/Sets/classical_sets.cmo: theories/Sets/classical_sets.cmi
-theories/Sets/classical_sets.cmx: theories/Sets/classical_sets.cmi
-theories/Sets/constructive_sets.cmo: theories/Sets/constructive_sets.cmi
-theories/Sets/constructive_sets.cmx: theories/Sets/constructive_sets.cmi
-theories/Sets/cpo.cmo: theories/Sets/partial_Order.cmi theories/Sets/cpo.cmi
-theories/Sets/cpo.cmx: theories/Sets/partial_Order.cmx theories/Sets/cpo.cmi
-theories/Sets/ensembles.cmo: theories/Sets/ensembles.cmi
-theories/Sets/ensembles.cmx: theories/Sets/ensembles.cmi
-theories/Sets/finite_sets_facts.cmo: theories/Sets/finite_sets_facts.cmi
-theories/Sets/finite_sets_facts.cmx: theories/Sets/finite_sets_facts.cmi
-theories/Sets/finite_sets.cmo: theories/Sets/finite_sets.cmi
-theories/Sets/finite_sets.cmx: theories/Sets/finite_sets.cmi
-theories/Sets/image.cmo: theories/Sets/image.cmi
-theories/Sets/image.cmx: theories/Sets/image.cmi
-theories/Sets/infinite_sets.cmo: theories/Sets/infinite_sets.cmi
-theories/Sets/infinite_sets.cmx: theories/Sets/infinite_sets.cmi
-theories/Sets/integers.cmo: theories/Sets/partial_Order.cmi \
- theories/Init/datatypes.cmi theories/Sets/integers.cmi
-theories/Sets/integers.cmx: theories/Sets/partial_Order.cmx \
- theories/Init/datatypes.cmx theories/Sets/integers.cmi
-theories/Sets/multiset.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/Sets/multiset.cmi
-theories/Sets/multiset.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
- theories/Init/datatypes.cmx theories/Sets/multiset.cmi
-theories/Sets/partial_Order.cmo: theories/Sets/relations_1.cmi \
- theories/Sets/ensembles.cmi theories/Sets/partial_Order.cmi
-theories/Sets/partial_Order.cmx: theories/Sets/relations_1.cmx \
- theories/Sets/ensembles.cmx theories/Sets/partial_Order.cmi
-theories/Sets/permut.cmo: theories/Sets/permut.cmi
-theories/Sets/permut.cmx: theories/Sets/permut.cmi
-theories/Sets/powerset_Classical_facts.cmo: \
- theories/Sets/powerset_Classical_facts.cmi
-theories/Sets/powerset_Classical_facts.cmx: \
- theories/Sets/powerset_Classical_facts.cmi
-theories/Sets/powerset_facts.cmo: theories/Sets/powerset_facts.cmi
-theories/Sets/powerset_facts.cmx: theories/Sets/powerset_facts.cmi
-theories/Sets/powerset.cmo: theories/Sets/partial_Order.cmi \
- theories/Sets/ensembles.cmi theories/Sets/powerset.cmi
-theories/Sets/powerset.cmx: theories/Sets/partial_Order.cmx \
- theories/Sets/ensembles.cmx theories/Sets/powerset.cmi
-theories/Sets/relations_1_facts.cmo: theories/Sets/relations_1_facts.cmi
-theories/Sets/relations_1_facts.cmx: theories/Sets/relations_1_facts.cmi
-theories/Sets/relations_1.cmo: theories/Sets/relations_1.cmi
-theories/Sets/relations_1.cmx: theories/Sets/relations_1.cmi
-theories/Sets/relations_2_facts.cmo: theories/Sets/relations_2_facts.cmi
-theories/Sets/relations_2_facts.cmx: theories/Sets/relations_2_facts.cmi
-theories/Sets/relations_2.cmo: theories/Sets/relations_2.cmi
-theories/Sets/relations_2.cmx: theories/Sets/relations_2.cmi
-theories/Sets/relations_3_facts.cmo: theories/Sets/relations_3_facts.cmi
-theories/Sets/relations_3_facts.cmx: theories/Sets/relations_3_facts.cmi
-theories/Sets/relations_3.cmo: theories/Sets/relations_3.cmi
-theories/Sets/relations_3.cmx: theories/Sets/relations_3.cmi
-theories/Sets/uniset.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Sets/uniset.cmi
-theories/Sets/uniset.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Sets/uniset.cmi
-theories/Sorting/heap.cmo: theories/Init/specif.cmi \
- theories/Sorting/sorting.cmi theories/Init/peano.cmi \
- theories/Sets/multiset.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/Sorting/heap.cmi
-theories/Sorting/heap.cmx: theories/Init/specif.cmx \
- theories/Sorting/sorting.cmx theories/Init/peano.cmx \
- theories/Sets/multiset.cmx theories/Lists/list.cmx \
- theories/Init/datatypes.cmx theories/Sorting/heap.cmi
-theories/Sorting/permutation.cmo: theories/Init/specif.cmi \
- theories/Init/peano.cmi theories/Sets/multiset.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi \
- theories/Sorting/permutation.cmi
-theories/Sorting/permutation.cmx: theories/Init/specif.cmx \
- theories/Init/peano.cmx theories/Sets/multiset.cmx \
- theories/Lists/list.cmx theories/Init/datatypes.cmx \
- theories/Sorting/permutation.cmi
-theories/Sorting/permutEq.cmo: theories/Sorting/permutEq.cmi
-theories/Sorting/permutEq.cmx: theories/Sorting/permutEq.cmi
-theories/Sorting/permutSetoid.cmo: theories/Sorting/permutSetoid.cmi
-theories/Sorting/permutSetoid.cmx: theories/Sorting/permutSetoid.cmi
-theories/Sorting/sorting.cmo: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/Sorting/sorting.cmi
-theories/Sorting/sorting.cmx: theories/Init/specif.cmx \
- theories/Lists/list.cmx theories/Sorting/sorting.cmi
-theories/Strings/ascii.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/Bool/bool.cmi \
- theories/NArith/binPos.cmi theories/Strings/ascii.cmi
-theories/Strings/ascii.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
- theories/Init/datatypes.cmx theories/Bool/bool.cmx \
- theories/NArith/binPos.cmx theories/Strings/ascii.cmi
-theories/Strings/string.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Strings/ascii.cmi \
- theories/Strings/string.cmi
-theories/Strings/string.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/Strings/ascii.cmx \
- theories/Strings/string.cmi
-theories/Wellfounded/disjoint_Union.cmo: \
- theories/Wellfounded/disjoint_Union.cmi
-theories/Wellfounded/disjoint_Union.cmx: \
- theories/Wellfounded/disjoint_Union.cmi
-theories/Wellfounded/inclusion.cmo: theories/Wellfounded/inclusion.cmi
-theories/Wellfounded/inclusion.cmx: theories/Wellfounded/inclusion.cmi
-theories/Wellfounded/inverse_Image.cmo: \
- theories/Wellfounded/inverse_Image.cmi
-theories/Wellfounded/inverse_Image.cmx: \
- theories/Wellfounded/inverse_Image.cmi
-theories/Wellfounded/lexicographic_Exponentiation.cmo: \
- theories/Wellfounded/lexicographic_Exponentiation.cmi
-theories/Wellfounded/lexicographic_Exponentiation.cmx: \
- theories/Wellfounded/lexicographic_Exponentiation.cmi
-theories/Wellfounded/lexicographic_Product.cmo: \
- theories/Wellfounded/lexicographic_Product.cmi
-theories/Wellfounded/lexicographic_Product.cmx: \
- theories/Wellfounded/lexicographic_Product.cmi
-theories/Wellfounded/transitive_Closure.cmo: \
- theories/Wellfounded/transitive_Closure.cmi
-theories/Wellfounded/transitive_Closure.cmx: \
- theories/Wellfounded/transitive_Closure.cmi
-theories/Wellfounded/union.cmo: theories/Wellfounded/union.cmi
-theories/Wellfounded/union.cmx: theories/Wellfounded/union.cmi
-theories/Wellfounded/wellfounded.cmo: theories/Wellfounded/wellfounded.cmi
-theories/Wellfounded/wellfounded.cmx: theories/Wellfounded/wellfounded.cmi
-theories/Wellfounded/well_Ordering.cmo: theories/Init/specif.cmi \
- theories/Wellfounded/well_Ordering.cmi
-theories/Wellfounded/well_Ordering.cmx: theories/Init/specif.cmx \
- theories/Wellfounded/well_Ordering.cmi
-theories/ZArith/auxiliary.cmo: theories/ZArith/auxiliary.cmi
-theories/ZArith/auxiliary.cmx: theories/ZArith/auxiliary.cmi
-theories/ZArith/binInt.cmo: theories/Init/datatypes.cmi \
- theories/NArith/binPos.cmi theories/NArith/binNat.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/binInt.cmx: theories/Init/datatypes.cmx \
- theories/NArith/binPos.cmx theories/NArith/binNat.cmx \
- theories/ZArith/binInt.cmi
-theories/ZArith/wf_Z.cmo: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/wf_Z.cmi
-theories/ZArith/wf_Z.cmx: theories/Init/specif.cmx theories/Init/peano.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/wf_Z.cmi
-theories/ZArith/zabs.cmo: theories/Init/specif.cmi theories/ZArith/binInt.cmi \
- theories/ZArith/zabs.cmi
-theories/ZArith/zabs.cmx: theories/Init/specif.cmx theories/ZArith/binInt.cmx \
- theories/ZArith/zabs.cmi
-theories/ZArith/zArith_base.cmo: theories/ZArith/zArith_base.cmi
-theories/ZArith/zArith_base.cmx: theories/ZArith/zArith_base.cmi
-theories/ZArith/zArith_dec.cmo: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/zArith_dec.cmi
-theories/ZArith/zArith_dec.cmx: theories/Bool/sumbool.cmx \
- theories/Init/specif.cmx theories/Init/datatypes.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/zArith_dec.cmi
-theories/ZArith/zArith.cmo: theories/ZArith/zArith.cmi
-theories/ZArith/zArith.cmx: theories/ZArith/zArith.cmi
-theories/ZArith/zbinary.cmo: theories/ZArith/zeven.cmi \
- theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
- theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
- theories/ZArith/zbinary.cmi
-theories/ZArith/zbinary.cmx: theories/ZArith/zeven.cmx \
- theories/Init/datatypes.cmx theories/Bool/bvector.cmx \
- theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
- theories/ZArith/zbinary.cmi
-theories/ZArith/zbool.cmo: theories/ZArith/zeven.cmi \
- theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/zbool.cmi
-theories/ZArith/zbool.cmx: theories/ZArith/zeven.cmx \
- theories/ZArith/zArith_dec.cmx theories/Bool/sumbool.cmx \
- theories/Init/specif.cmx theories/Init/datatypes.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/zbool.cmi
-theories/ZArith/zcompare.cmo: theories/ZArith/zcompare.cmi
-theories/ZArith/zcompare.cmx: theories/ZArith/zcompare.cmi
-theories/ZArith/zcomplements.cmo: theories/ZArith/zabs.cmi \
- theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/zcomplements.cmi
-theories/ZArith/zcomplements.cmx: theories/ZArith/zabs.cmx \
- theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Lists/list.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/zcomplements.cmi
-theories/ZArith/zdiv.cmo: theories/ZArith/zbool.cmi \
- theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/zdiv.cmi
-theories/ZArith/zdiv.cmx: theories/ZArith/zbool.cmx \
- theories/ZArith/zArith_dec.cmx theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/zdiv.cmi
-theories/ZArith/zeven.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/zeven.cmi
-theories/ZArith/zeven.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/zeven.cmi
-theories/ZArith/zhints.cmo: theories/ZArith/zhints.cmi
-theories/ZArith/zhints.cmx: theories/ZArith/zhints.cmi
-theories/ZArith/zlogarithm.cmo: theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/zlogarithm.cmi
-theories/ZArith/zlogarithm.cmx: theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/zlogarithm.cmi
-theories/ZArith/zmax.cmo: theories/Init/datatypes.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/zmax.cmi
-theories/ZArith/zmax.cmx: theories/Init/datatypes.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/zmax.cmi
-theories/ZArith/zminmax.cmo: theories/ZArith/zminmax.cmi
-theories/ZArith/zminmax.cmx: theories/ZArith/zminmax.cmi
-theories/ZArith/zmin.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \
- theories/ZArith/zmin.cmi
-theories/ZArith/zmin.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \
- theories/ZArith/zmin.cmi
-theories/ZArith/zmisc.cmo: theories/Init/datatypes.cmi \
- theories/NArith/binPos.cmi theories/ZArith/binInt.cmi \
- theories/ZArith/zmisc.cmi
-theories/ZArith/zmisc.cmx: theories/Init/datatypes.cmx \
- theories/NArith/binPos.cmx theories/ZArith/binInt.cmx \
- theories/ZArith/zmisc.cmi
-theories/ZArith/znat.cmo: theories/ZArith/znat.cmi
-theories/ZArith/znat.cmx: theories/ZArith/znat.cmi
-theories/ZArith/znumtheory.cmo: theories/ZArith/zorder.cmi \
- theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \
- theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/znumtheory.cmi
-theories/ZArith/znumtheory.cmx: theories/ZArith/zorder.cmx \
- theories/ZArith/zdiv.cmx theories/ZArith/zArith_dec.cmx \
- theories/ZArith/wf_Z.cmx theories/Init/specif.cmx theories/Init/peano.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/znumtheory.cmi
-theories/ZArith/zorder.cmo: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/ZArith/binInt.cmi \
- theories/ZArith/zorder.cmi
-theories/ZArith/zorder.cmx: theories/Init/specif.cmx \
- theories/Init/datatypes.cmx theories/ZArith/binInt.cmx \
- theories/ZArith/zorder.cmi
-theories/ZArith/zpower.cmo: theories/ZArith/zmisc.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/zpower.cmi
-theories/ZArith/zpower.cmx: theories/ZArith/zmisc.cmx \
- theories/Init/datatypes.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/zpower.cmi
-theories/ZArith/zsqrt.cmo: theories/ZArith/zArith_dec.cmi \
- theories/Init/specif.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi theories/ZArith/zsqrt.cmi
-theories/ZArith/zsqrt.cmx: theories/ZArith/zArith_dec.cmx \
- theories/Init/specif.cmx theories/NArith/binPos.cmx \
- theories/ZArith/binInt.cmx theories/ZArith/zsqrt.cmi
-theories/ZArith/zwf.cmo: theories/ZArith/zwf.cmi
-theories/ZArith/zwf.cmx: theories/ZArith/zwf.cmi
-theories/Arith/bool_nat.cmi: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/Arith/peano_dec.cmi \
- theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi
-theories/Arith/compare_dec.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi
-theories/Arith/compare.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi
-theories/Arith/div2.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi
-theories/Arith/eqNat.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi
-theories/Arith/euclid.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi
-theories/Arith/even.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi
-theories/Arith/factorial.cmi: theories/Init/peano.cmi \
- theories/Init/datatypes.cmi
-theories/Arith/max.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi
-theories/Arith/min.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi
-theories/Arith/mult.cmi: theories/Arith/plus.cmi theories/Init/datatypes.cmi
-theories/Arith/peano_dec.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi
-theories/Arith/plus.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi
-theories/Arith/wf_nat.cmi: theories/Init/datatypes.cmi
-theories/Bool/boolEq.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi
-theories/Bool/bool.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi
-theories/Bool/bvector.cmi: theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/Bool/bool.cmi
-theories/Bool/decBool.cmi: theories/Init/specif.cmi
-theories/Bool/ifProp.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi
-theories/Bool/sumbool.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi
-theories/Bool/zerob.cmi: theories/Init/datatypes.cmi
-theories/FSets/decidableTypeEx.cmi: theories/Init/specif.cmi \
- theories/FSets/orderedTypeEx.cmi theories/FSets/orderedType.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/decidableType.cmi: theories/Init/specif.cmi
-theories/FSets/fMapAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/FSets/int.cmi theories/Init/datatypes.cmi \
- theories/NArith/binPos.cmi theories/ZArith/binInt.cmi
-theories/FSets/fMapFacts.cmi: theories/Init/specif.cmi \
- theories/FSets/fMapInterface.cmi theories/Init/datatypes.cmi
-theories/FSets/fMapInterface.cmi: theories/FSets/orderedType.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi
-theories/FSets/fMapIntMap.cmi: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/NArith/ndigits.cmi \
- theories/IntMap/mapiter.cmi theories/IntMap/mapcanon.cmi \
- theories/IntMap/map.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/NArith/binNat.cmi
-theories/FSets/fMapList.cmi: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/fMapPositive.cmi: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi
-theories/FSets/fMapWeakFacts.cmi: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/FSets/fMapWeakInterface.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/fMapWeakInterface.cmi: theories/Lists/list.cmi \
- theories/FSets/decidableType.cmi theories/Init/datatypes.cmi
-theories/FSets/fMapWeakList.cmi: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/FSets/decidableType.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/fSetAVL.cmi: theories/Init/wf.cmi theories/Init/specif.cmi \
- theories/Init/peano.cmi theories/FSets/orderedType.cmi \
- theories/Lists/list.cmi theories/FSets/int.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/FSets/fSetBridge.cmi: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi
-theories/FSets/fSetEqProperties.cmi: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/Init/peano.cmi \
- theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi \
- theories/Bool/bool.cmi
-theories/FSets/fSetFacts.cmi: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/FSets/fSetInterface.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/fSetInterface.cmi: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/fSetList.cmi: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/fSetProperties.cmi: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/Lists/list.cmi \
- theories/FSets/fSetInterface.cmi theories/Init/datatypes.cmi
-theories/FSets/fSetToFiniteSet.cmi: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/FSets/orderedTypeEx.cmi \
- theories/FSets/orderedType.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/fSetWeakFacts.cmi: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/FSets/fSetWeakInterface.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/fSetWeakInterface.cmi: theories/Lists/list.cmi \
- theories/FSets/decidableType.cmi theories/Init/datatypes.cmi
-theories/FSets/fSetWeakList.cmi: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/FSets/decidableType.cmi \
- theories/Init/datatypes.cmi
-theories/FSets/fSetWeakProperties.cmi: theories/Init/specif.cmi \
- theories/Setoids/setoid.cmi theories/Lists/list.cmi \
- theories/FSets/fSetWeakInterface.cmi theories/Init/datatypes.cmi
-theories/FSets/int.cmi: theories/ZArith/zmax.cmi \
- theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
- theories/NArith/binPos.cmi theories/ZArith/binInt.cmi
-theories/FSets/orderedTypeAlt.cmi: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Init/datatypes.cmi
-theories/FSets/orderedTypeEx.cmi: theories/Init/specif.cmi \
- theories/FSets/orderedType.cmi theories/Init/datatypes.cmi \
- theories/Arith/compare_dec.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi theories/ZArith/binInt.cmi
-theories/FSets/orderedType.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi
-theories/Init/peano.cmi: theories/Init/datatypes.cmi
-theories/Init/specif.cmi: theories/Init/datatypes.cmi
-theories/IntMap/adalloc.cmi: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/NArith/ndec.cmi theories/IntMap/map.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi
-theories/IntMap/fset.cmi: theories/Init/specif.cmi \
- theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
- theories/IntMap/map.cmi theories/Init/datatypes.cmi \
- theories/NArith/binNat.cmi
-theories/IntMap/lsort.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
- theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
- theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi \
- theories/NArith/binNat.cmi
-theories/IntMap/mapcanon.cmi: theories/Init/specif.cmi \
- theories/IntMap/map.cmi
-theories/IntMap/mapcard.cmi: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/Arith/plus.cmi \
- theories/Arith/peano_dec.cmi theories/Init/peano.cmi \
- theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
- theories/IntMap/map.cmi theories/Init/datatypes.cmi \
- theories/NArith/binNat.cmi
-theories/IntMap/mapfold.cmi: theories/Init/specif.cmi \
- theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
- theories/IntMap/fset.cmi theories/Init/datatypes.cmi
-theories/IntMap/mapiter.cmi: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/NArith/ndigits.cmi \
- theories/NArith/ndec.cmi theories/IntMap/map.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/NArith/binNat.cmi
-theories/IntMap/maplists.cmi: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/NArith/ndec.cmi \
- theories/IntMap/mapiter.cmi theories/IntMap/map.cmi \
- theories/Lists/list.cmi theories/IntMap/fset.cmi \
- theories/Init/datatypes.cmi
-theories/IntMap/map.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/NArith/ndigits.cmi theories/NArith/ndec.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi
-theories/IntMap/mapsubset.cmi: theories/IntMap/mapiter.cmi \
- theories/IntMap/map.cmi theories/IntMap/fset.cmi \
- theories/Init/datatypes.cmi theories/Bool/bool.cmi
-theories/Lists/list.cmi: theories/Init/specif.cmi theories/Init/datatypes.cmi
-theories/Lists/listSet.cmi: theories/Init/specif.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi
-theories/Lists/monoList.cmi: theories/Init/datatypes.cmi
-theories/Lists/setoidList.cmi: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi
-theories/Lists/streams.cmi: theories/Init/datatypes.cmi
-theories/Lists/theoryList.cmi: theories/Init/specif.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi
-theories/Logic/choiceFacts.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi
-theories/Logic/classicalDescription.cmi: theories/Init/specif.cmi \
- theories/Logic/choiceFacts.cmi
-theories/Logic/classicalEpsilon.cmi: theories/Init/specif.cmi \
- theories/Logic/choiceFacts.cmi
-theories/Logic/diaconescu.cmi: theories/Init/specif.cmi
-theories/Logic/eqdep_dec.cmi: theories/Init/specif.cmi
-theories/NArith/binNat.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi
-theories/NArith/binPos.cmi: theories/Init/peano.cmi \
- theories/Init/datatypes.cmi
-theories/NArith/ndec.cmi: theories/Bool/sumbool.cmi theories/Init/specif.cmi \
- theories/NArith/nnat.cmi theories/NArith/ndigits.cmi \
- theories/Init/datatypes.cmi theories/Arith/compare_dec.cmi \
- theories/NArith/binPos.cmi theories/NArith/binNat.cmi
-theories/NArith/ndigits.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
- theories/Bool/bool.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi
-theories/NArith/ndist.cmi: theories/NArith/ndigits.cmi theories/Arith/min.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/NArith/binNat.cmi
-theories/NArith/nnat.cmi: theories/Init/datatypes.cmi \
- theories/NArith/binPos.cmi theories/NArith/binNat.cmi
-theories/QArith/qArith_base.cmi: theories/ZArith/zArith_dec.cmi \
- theories/Init/specif.cmi theories/Setoids/setoid.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/QArith/qreals.cmi: theories/QArith/qArith_base.cmi \
- theories/ZArith/binInt.cmi
-theories/QArith/qreduction.cmi: theories/ZArith/znumtheory.cmi \
- theories/Setoids/setoid.cmi theories/QArith/qArith_base.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/QArith/qring.cmi: theories/Init/specif.cmi \
- theories/QArith/qArith_base.cmi theories/Init/datatypes.cmi
-theories/Relations/relation_Operators.cmi: theories/Init/specif.cmi \
- theories/Lists/list.cmi
-theories/Setoids/setoid.cmi: theories/Init/datatypes.cmi
-theories/Sets/cpo.cmi: theories/Sets/partial_Order.cmi
-theories/Sets/integers.cmi: theories/Sets/partial_Order.cmi \
- theories/Init/datatypes.cmi
-theories/Sets/multiset.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi
-theories/Sets/partial_Order.cmi: theories/Sets/relations_1.cmi \
- theories/Sets/ensembles.cmi
-theories/Sets/powerset.cmi: theories/Sets/partial_Order.cmi \
- theories/Sets/ensembles.cmi
-theories/Sets/uniset.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi
-theories/Sorting/heap.cmi: theories/Init/specif.cmi \
- theories/Sorting/sorting.cmi theories/Init/peano.cmi \
- theories/Sets/multiset.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi
-theories/Sorting/permutation.cmi: theories/Init/specif.cmi \
- theories/Init/peano.cmi theories/Sets/multiset.cmi \
- theories/Lists/list.cmi theories/Init/datatypes.cmi
-theories/Sorting/sorting.cmi: theories/Init/specif.cmi \
- theories/Lists/list.cmi
-theories/Strings/ascii.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/Bool/bool.cmi \
- theories/NArith/binPos.cmi
-theories/Strings/string.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/Strings/ascii.cmi
-theories/Wellfounded/well_Ordering.cmi: theories/Init/specif.cmi
-theories/ZArith/binInt.cmi: theories/Init/datatypes.cmi \
- theories/NArith/binPos.cmi theories/NArith/binNat.cmi
-theories/ZArith/wf_Z.cmi: theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zabs.cmi: theories/Init/specif.cmi theories/ZArith/binInt.cmi
-theories/ZArith/zArith_dec.cmi: theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zbinary.cmi: theories/ZArith/zeven.cmi \
- theories/Init/datatypes.cmi theories/Bool/bvector.cmi \
- theories/NArith/binPos.cmi theories/ZArith/binInt.cmi
-theories/ZArith/zbool.cmi: theories/ZArith/zeven.cmi \
- theories/ZArith/zArith_dec.cmi theories/Bool/sumbool.cmi \
- theories/Init/specif.cmi theories/Init/datatypes.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zcomplements.cmi: theories/ZArith/zabs.cmi \
- theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Lists/list.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zdiv.cmi: theories/ZArith/zbool.cmi \
- theories/ZArith/zArith_dec.cmi theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zeven.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zlogarithm.cmi: theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zmax.cmi: theories/Init/datatypes.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zmin.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/ZArith/binInt.cmi
-theories/ZArith/zmisc.cmi: theories/Init/datatypes.cmi \
- theories/NArith/binPos.cmi theories/ZArith/binInt.cmi
-theories/ZArith/znumtheory.cmi: theories/ZArith/zorder.cmi \
- theories/ZArith/zdiv.cmi theories/ZArith/zArith_dec.cmi \
- theories/ZArith/wf_Z.cmi theories/Init/specif.cmi theories/Init/peano.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zorder.cmi: theories/Init/specif.cmi \
- theories/Init/datatypes.cmi theories/ZArith/binInt.cmi
-theories/ZArith/zpower.cmi: theories/ZArith/zmisc.cmi \
- theories/Init/datatypes.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
-theories/ZArith/zsqrt.cmi: theories/ZArith/zArith_dec.cmi \
- theories/Init/specif.cmi theories/NArith/binPos.cmi \
- theories/ZArith/binInt.cmi
diff --git a/contrib/extraction/test/Makefile b/contrib/extraction/test/Makefile
deleted file mode 100644
index 65a54090..00000000
--- a/contrib/extraction/test/Makefile
+++ /dev/null
@@ -1,109 +0,0 @@
-#
-# General variables
-#
-
-TOPDIR=../../..
-
-# Files with axioms to be realized: can't be extracted directly
-
-AXIOMSVO:= \
-theories/Reals/% \
-theories/Num/%
-
-DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -path \*.svn\*))
-
-INCL:= $(patsubst %,-I %,$(DIRS))
-
-VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo))
-
-VO:= $(filter-out $(AXIOMSVO),$(VO))
-
-ML:= $(shell test -x v2ml && ./v2ml $(VO))
-
-MLI:= $(patsubst %.ml,%.mli,$(ML))
-
-CMO:= $(patsubst %.ml,%.cmo,$(ML))
-
-OSTDLIB:=$(shell (ocamlc -where))
-
-#
-# General rules
-#
-
-all: v2ml ml $(MLI) $(CMO)
-
-ml: $(ML)
-
-depend: #$(ML)
- rm -f .depend; ocamldep $(INCL) theories/*/*.ml theories/*/*.mli > .depend
-
-tree:
- mkdir -p $(DIRS)
- cp $(OSTDLIB)/pervasives.cmi $(OSTDLIB)/obj.cmi $(OSTDLIB)/lazy.cmi theories
-
-#%.mli:%.ml
-# ./make_mli $< > $@
-
-%.cmi:%.mli
- ocamlc -c $(INCL) -nostdlib $<
-
-%.cmo:%.ml
- ocamlc -c $(INCL) -nostdlib $<
-
-$(ML): ml2v
- ./extract $@
-
-clean:
- rm -f theories/*/*.ml* theories/*/*.cm*
-
-
-#
-# Utilities
-#
-
-open:
- find theories -name "*".ml -exec ./qualify2open \{\} \;
-
-undo_open:
- find theories -name "*".ml -exec mv \{\}.orig \{\} \;
-
-ml2v: ml2v.ml
- ocamlopt -o $@ $<
-
-v2ml: v2ml.ml
- ocamlopt -o $@ $<
- $(MAKE)
-
-#
-# Extraction of Reals
-#
-
-
-REALSAXIOMSVO:=theories/Reals/Rsyntax.vo
-
-REALSALLVO:=$(shell cd $(TOPDIR); ls -tr theories/Reals/*.vo)
-REALSVO:=$(filter-out $(REALSAXIOMSVO),$(REALSALLVO))
-REALSML:=$(shell test -x v2ml && ./v2ml $(REALSVO))
-REALSCMO:= $(patsubst %.ml,%.cmo,$(REALSML))
-
-reals: all realsml theories/Reals/addReals.cmo $(REALSCMO)
-
-realsml: $(REALSML)
-
-theories/Reals/addReals.ml:
- cp -f addReals theories/Reals/addReals.ml
-
-$(REALSML):
- ./extract $@
-
-
-#
-# The End
-#
-
-.PHONY: all tree clean reals realsml depend
-
-include .depend
-
-
-
diff --git a/contrib/extraction/test/Makefile.haskell b/contrib/extraction/test/Makefile.haskell
deleted file mode 100644
index 6e1e15d1..00000000
--- a/contrib/extraction/test/Makefile.haskell
+++ /dev/null
@@ -1,416 +0,0 @@
-#
-# General variables
-#
-
-TOPDIR=../../..
-
-# Files with axioms to be realized: can't be extracted directly
-
-AXIOMSVO:= \
-theories/Init/Prelude.vo \
-theories/Reals/% \
-theories/Num/%
-
-DIRS:= $(shell (cd $(TOPDIR);find theories -type d ! -name CVS))
-
-INCL:= $(patsubst %,-i%,$(DIRS))
-
-VO:= $(shell (cd $(TOPDIR);find theories -name \*.vo))
-
-VO:= $(filter-out $(AXIOMSVO),$(VO))
-
-HS:= $(shell test -x v2hs && ./v2hs $(VO))
-
-O:= $(patsubst %.hs,%.o,$(HS))
-
-#
-# General rules
-#
-
-all: v2hs hs $(O)
-
-hs: $(HS)
-
-tree:
- mkdir -p $(DIRS)
-
-%.o:%.hs
- ghc $(INCL) -c $<
-
-$(HS): hs2v
- ./extract.haskell $@
-
-clean:
- rm -f theories/*/*.h* theories/*/*.o
-
-
-#
-# Utilities
-#
-
-hs2v: hs2v.ml
- ocamlc -o $@ $<
-
-v2hs: v2hs.ml
- ocamlc -o $@ $<
- $(MAKE) -f Makefile.haskell
-
-
-#
-# The End
-#
-
-.PHONY: all tree clean depend
-
-# DO NOT DELETE: Beginning of Haskell dependencies
-theories/Arith/Between.o : theories/Arith/Between.hs
-theories/Arith/Bool_nat.o : theories/Arith/Bool_nat.hs
-theories/Arith/Bool_nat.o : theories/Bool/Sumbool.o
-theories/Arith/Bool_nat.o : theories/Init/Specif.o
-theories/Arith/Bool_nat.o : theories/Arith/Peano_dec.o
-theories/Arith/Bool_nat.o : theories/Init/Datatypes.o
-theories/Arith/Bool_nat.o : theories/Arith/Compare_dec.o
-theories/Arith/Compare_dec.o : theories/Arith/Compare_dec.hs
-theories/Arith/Compare_dec.o : theories/Init/Specif.o
-theories/Arith/Compare_dec.o : theories/Init/Logic.o
-theories/Arith/Compare_dec.o : theories/Init/Datatypes.o
-theories/Arith/Compare.o : theories/Arith/Compare.hs
-theories/Arith/Compare.o : theories/Init/Specif.o
-theories/Arith/Compare.o : theories/Init/Datatypes.o
-theories/Arith/Compare.o : theories/Arith/Compare_dec.o
-theories/Arith/Div2.o : theories/Arith/Div2.hs
-theories/Arith/Div2.o : theories/Init/Specif.o
-theories/Arith/Div2.o : theories/Init/Peano.o
-theories/Arith/Div2.o : theories/Init/Datatypes.o
-theories/Arith/EqNat.o : theories/Arith/EqNat.hs
-theories/Arith/EqNat.o : theories/Init/Specif.o
-theories/Arith/EqNat.o : theories/Init/Datatypes.o
-theories/Arith/Euclid.o : theories/Arith/Euclid.hs
-theories/Arith/Euclid.o : theories/Arith/Wf_nat.o
-theories/Arith/Euclid.o : theories/Init/Specif.o
-theories/Arith/Euclid.o : theories/Arith/Minus.o
-theories/Arith/Euclid.o : theories/Init/Datatypes.o
-theories/Arith/Euclid.o : theories/Arith/Compare_dec.o
-theories/Arith/Even.o : theories/Arith/Even.hs
-theories/Arith/Even.o : theories/Init/Specif.o
-theories/Arith/Even.o : theories/Init/Datatypes.o
-theories/Arith/Gt.o : theories/Arith/Gt.hs
-theories/Arith/Le.o : theories/Arith/Le.hs
-theories/Arith/Lt.o : theories/Arith/Lt.hs
-theories/Arith/Max.o : theories/Arith/Max.hs
-theories/Arith/Max.o : theories/Init/Specif.o
-theories/Arith/Max.o : theories/Init/Logic.o
-theories/Arith/Max.o : theories/Init/Datatypes.o
-theories/Arith/Min.o : theories/Arith/Min.hs
-theories/Arith/Min.o : theories/Init/Specif.o
-theories/Arith/Min.o : theories/Init/Logic.o
-theories/Arith/Min.o : theories/Init/Datatypes.o
-theories/Arith/Minus.o : theories/Arith/Minus.hs
-theories/Arith/Minus.o : theories/Init/Datatypes.o
-theories/Arith/Mult.o : theories/Arith/Mult.hs
-theories/Arith/Mult.o : theories/Arith/Plus.o
-theories/Arith/Mult.o : theories/Init/Datatypes.o
-theories/Arith/Peano_dec.o : theories/Arith/Peano_dec.hs
-theories/Arith/Peano_dec.o : theories/Init/Specif.o
-theories/Arith/Peano_dec.o : theories/Init/Datatypes.o
-theories/Arith/Plus.o : theories/Arith/Plus.hs
-theories/Arith/Plus.o : theories/Init/Specif.o
-theories/Arith/Plus.o : theories/Init/Logic.o
-theories/Arith/Plus.o : theories/Init/Datatypes.o
-theories/Arith/Wf_nat.o : theories/Arith/Wf_nat.hs
-theories/Arith/Wf_nat.o : theories/Init/Wf.o
-theories/Arith/Wf_nat.o : theories/Init/Logic.o
-theories/Arith/Wf_nat.o : theories/Init/Datatypes.o
-theories/Bool/BoolEq.o : theories/Bool/BoolEq.hs
-theories/Bool/BoolEq.o : theories/Init/Specif.o
-theories/Bool/BoolEq.o : theories/Init/Datatypes.o
-theories/Bool/Bool.o : theories/Bool/Bool.hs
-theories/Bool/Bool.o : theories/Init/Specif.o
-theories/Bool/Bool.o : theories/Init/Datatypes.o
-theories/Bool/DecBool.o : theories/Bool/DecBool.hs
-theories/Bool/DecBool.o : theories/Init/Specif.o
-theories/Bool/IfProp.o : theories/Bool/IfProp.hs
-theories/Bool/IfProp.o : theories/Init/Specif.o
-theories/Bool/IfProp.o : theories/Init/Datatypes.o
-theories/Bool/Sumbool.o : theories/Bool/Sumbool.hs
-theories/Bool/Sumbool.o : theories/Init/Specif.o
-theories/Bool/Sumbool.o : theories/Init/Datatypes.o
-theories/Bool/Zerob.o : theories/Bool/Zerob.hs
-theories/Bool/Zerob.o : theories/Init/Datatypes.o
-theories/Init/Datatypes.o : theories/Init/Datatypes.hs
-theories/Init/DatatypesSyntax.o : theories/Init/DatatypesSyntax.hs
-theories/Init/Logic.o : theories/Init/Logic.hs
-theories/Init/LogicSyntax.o : theories/Init/LogicSyntax.hs
-theories/Init/Logic_Type.o : theories/Init/Logic_Type.hs
-theories/Init/Logic_TypeSyntax.o : theories/Init/Logic_TypeSyntax.hs
-theories/Init/Peano.o : theories/Init/Peano.hs
-theories/Init/Peano.o : theories/Init/Datatypes.o
-theories/Init/Specif.o : theories/Init/Specif.hs
-theories/Init/Specif.o : theories/Init/Logic.o
-theories/Init/Specif.o : theories/Init/Datatypes.o
-theories/Init/SpecifSyntax.o : theories/Init/SpecifSyntax.hs
-theories/Init/Wf.o : theories/Init/Wf.hs
-theories/IntMap/Adalloc.o : theories/IntMap/Adalloc.hs
-theories/IntMap/Adalloc.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Adalloc.o : theories/Bool/Sumbool.o
-theories/IntMap/Adalloc.o : theories/Init/Specif.o
-theories/IntMap/Adalloc.o : theories/IntMap/Map.o
-theories/IntMap/Adalloc.o : theories/Init/Logic.o
-theories/IntMap/Adalloc.o : theories/Init/Datatypes.o
-theories/IntMap/Adalloc.o : theories/IntMap/Addr.o
-theories/IntMap/Adalloc.o : theories/IntMap/Addec.o
-theories/IntMap/Addec.o : theories/IntMap/Addec.hs
-theories/IntMap/Addec.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Addec.o : theories/Bool/Sumbool.o
-theories/IntMap/Addec.o : theories/Init/Specif.o
-theories/IntMap/Addec.o : theories/Init/Datatypes.o
-theories/IntMap/Addec.o : theories/IntMap/Addr.o
-theories/IntMap/Addr.o : theories/IntMap/Addr.hs
-theories/IntMap/Addr.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Addr.o : theories/Init/Specif.o
-theories/IntMap/Addr.o : theories/Init/Datatypes.o
-theories/IntMap/Addr.o : theories/Bool/Bool.o
-theories/IntMap/Adist.o : theories/IntMap/Adist.hs
-theories/IntMap/Adist.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Adist.o : theories/Arith/Min.o
-theories/IntMap/Adist.o : theories/Init/Datatypes.o
-theories/IntMap/Adist.o : theories/IntMap/Addr.o
-theories/IntMap/Allmaps.o : theories/IntMap/Allmaps.hs
-theories/IntMap/Fset.o : theories/IntMap/Fset.hs
-theories/IntMap/Fset.o : theories/Init/Specif.o
-theories/IntMap/Fset.o : theories/IntMap/Map.o
-theories/IntMap/Fset.o : theories/Init/Logic.o
-theories/IntMap/Fset.o : theories/Init/Datatypes.o
-theories/IntMap/Fset.o : theories/IntMap/Addr.o
-theories/IntMap/Fset.o : theories/IntMap/Addec.o
-theories/IntMap/Lsort.o : theories/IntMap/Lsort.hs
-theories/IntMap/Lsort.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Lsort.o : theories/Bool/Sumbool.o
-theories/IntMap/Lsort.o : theories/Init/Specif.o
-theories/IntMap/Lsort.o : theories/Lists/PolyList.o
-theories/IntMap/Lsort.o : theories/IntMap/Mapiter.o
-theories/IntMap/Lsort.o : theories/IntMap/Map.o
-theories/IntMap/Lsort.o : theories/Init/Logic.o
-theories/IntMap/Lsort.o : theories/Init/Datatypes.o
-theories/IntMap/Lsort.o : theories/Bool/Bool.o
-theories/IntMap/Lsort.o : theories/IntMap/Addr.o
-theories/IntMap/Lsort.o : theories/IntMap/Addec.o
-theories/IntMap/Mapaxioms.o : theories/IntMap/Mapaxioms.hs
-theories/IntMap/Mapcanon.o : theories/IntMap/Mapcanon.hs
-theories/IntMap/Mapcanon.o : theories/Init/Specif.o
-theories/IntMap/Mapcanon.o : theories/IntMap/Map.o
-theories/IntMap/Mapcard.o : theories/IntMap/Mapcard.hs
-theories/IntMap/Mapcard.o : theories/Bool/Sumbool.o
-theories/IntMap/Mapcard.o : theories/Init/Specif.o
-theories/IntMap/Mapcard.o : theories/Arith/Plus.o
-theories/IntMap/Mapcard.o : theories/Arith/Peano_dec.o
-theories/IntMap/Mapcard.o : theories/Init/Peano.o
-theories/IntMap/Mapcard.o : theories/IntMap/Map.o
-theories/IntMap/Mapcard.o : theories/Init/Logic.o
-theories/IntMap/Mapcard.o : theories/Init/Datatypes.o
-theories/IntMap/Mapcard.o : theories/IntMap/Addr.o
-theories/IntMap/Mapcard.o : theories/IntMap/Addec.o
-theories/IntMap/Mapc.o : theories/IntMap/Mapc.hs
-theories/IntMap/Mapfold.o : theories/IntMap/Mapfold.hs
-theories/IntMap/Mapfold.o : theories/Init/Specif.o
-theories/IntMap/Mapfold.o : theories/IntMap/Mapiter.o
-theories/IntMap/Mapfold.o : theories/IntMap/Map.o
-theories/IntMap/Mapfold.o : theories/Init/Logic.o
-theories/IntMap/Mapfold.o : theories/IntMap/Fset.o
-theories/IntMap/Mapfold.o : theories/Init/Datatypes.o
-theories/IntMap/Mapfold.o : theories/IntMap/Addr.o
-theories/IntMap/Map.o : theories/IntMap/Map.hs
-theories/IntMap/Map.o : theories/ZArith/Fast_integer.o
-theories/IntMap/Map.o : theories/Init/Specif.o
-theories/IntMap/Map.o : theories/Init/Peano.o
-theories/IntMap/Map.o : theories/Init/Datatypes.o
-theories/IntMap/Map.o : theories/IntMap/Addr.o
-theories/IntMap/Map.o : theories/IntMap/Addec.o
-theories/IntMap/Mapiter.o : theories/IntMap/Mapiter.hs
-theories/IntMap/Mapiter.o : theories/Bool/Sumbool.o
-theories/IntMap/Mapiter.o : theories/Init/Specif.o
-theories/IntMap/Mapiter.o : theories/Lists/PolyList.o
-theories/IntMap/Mapiter.o : theories/IntMap/Map.o
-theories/IntMap/Mapiter.o : theories/Init/Logic.o
-theories/IntMap/Mapiter.o : theories/Init/Datatypes.o
-theories/IntMap/Mapiter.o : theories/IntMap/Addr.o
-theories/IntMap/Mapiter.o : theories/IntMap/Addec.o
-theories/IntMap/Maplists.o : theories/IntMap/Maplists.hs
-theories/IntMap/Maplists.o : theories/Bool/Sumbool.o
-theories/IntMap/Maplists.o : theories/Init/Specif.o
-theories/IntMap/Maplists.o : theories/Lists/PolyList.o
-theories/IntMap/Maplists.o : theories/IntMap/Mapiter.o
-theories/IntMap/Maplists.o : theories/IntMap/Map.o
-theories/IntMap/Maplists.o : theories/Init/Logic.o
-theories/IntMap/Maplists.o : theories/IntMap/Fset.o
-theories/IntMap/Maplists.o : theories/Init/Datatypes.o
-theories/IntMap/Maplists.o : theories/Bool/Bool.o
-theories/IntMap/Maplists.o : theories/IntMap/Addr.o
-theories/IntMap/Maplists.o : theories/IntMap/Addec.o
-theories/IntMap/Mapsubset.o : theories/IntMap/Mapsubset.hs
-theories/IntMap/Mapsubset.o : theories/IntMap/Mapiter.o
-theories/IntMap/Mapsubset.o : theories/IntMap/Map.o
-theories/IntMap/Mapsubset.o : theories/IntMap/Fset.o
-theories/IntMap/Mapsubset.o : theories/Init/Datatypes.o
-theories/IntMap/Mapsubset.o : theories/Bool/Bool.o
-theories/Lists/ListSet.o : theories/Lists/ListSet.hs
-theories/Lists/ListSet.o : theories/Init/Specif.o
-theories/Lists/ListSet.o : theories/Lists/PolyList.o
-theories/Lists/ListSet.o : theories/Init/Logic.o
-theories/Lists/ListSet.o : theories/Init/Datatypes.o
-theories/Lists/PolyList.o : theories/Lists/PolyList.hs
-theories/Lists/PolyList.o : theories/Init/Specif.o
-theories/Lists/PolyList.o : theories/Init/Datatypes.o
-theories/Lists/PolyListSyntax.o : theories/Lists/PolyListSyntax.hs
-theories/Lists/Streams.o : theories/Lists/Streams.hs
-theories/Lists/Streams.o : theories/Init/Datatypes.o
-theories/Lists/TheoryList.o : theories/Lists/TheoryList.hs
-theories/Lists/TheoryList.o : theories/Init/Specif.o
-theories/Lists/TheoryList.o : theories/Lists/PolyList.o
-theories/Lists/TheoryList.o : theories/Bool/DecBool.o
-theories/Lists/TheoryList.o : theories/Init/Datatypes.o
-theories/Logic/Berardi.o : theories/Logic/Berardi.hs
-theories/Logic/ClassicalFacts.o : theories/Logic/ClassicalFacts.hs
-theories/Logic/Classical.o : theories/Logic/Classical.hs
-theories/Logic/Classical_Pred_Set.o : theories/Logic/Classical_Pred_Set.hs
-theories/Logic/Classical_Pred_Type.o : theories/Logic/Classical_Pred_Type.hs
-theories/Logic/Classical_Prop.o : theories/Logic/Classical_Prop.hs
-theories/Logic/Classical_Type.o : theories/Logic/Classical_Type.hs
-theories/Logic/Decidable.o : theories/Logic/Decidable.hs
-theories/Logic/Eqdep_dec.o : theories/Logic/Eqdep_dec.hs
-theories/Logic/Eqdep.o : theories/Logic/Eqdep.hs
-theories/Logic/Hurkens.o : theories/Logic/Hurkens.hs
-theories/Logic/JMeq.o : theories/Logic/JMeq.hs
-theories/Logic/ProofIrrelevance.o : theories/Logic/ProofIrrelevance.hs
-theories/Relations/Newman.o : theories/Relations/Newman.hs
-theories/Relations/Operators_Properties.o : theories/Relations/Operators_Properties.hs
-theories/Relations/Relation_Definitions.o : theories/Relations/Relation_Definitions.hs
-theories/Relations/Relation_Operators.o : theories/Relations/Relation_Operators.hs
-theories/Relations/Relation_Operators.o : theories/Init/Specif.o
-theories/Relations/Relation_Operators.o : theories/Lists/PolyList.o
-theories/Relations/Relations.o : theories/Relations/Relations.hs
-theories/Relations/Rstar.o : theories/Relations/Rstar.hs
-theories/Setoids/Setoid.o : theories/Setoids/Setoid.hs
-theories/Sets/Classical_sets.o : theories/Sets/Classical_sets.hs
-theories/Sets/Constructive_sets.o : theories/Sets/Constructive_sets.hs
-theories/Sets/Cpo.o : theories/Sets/Cpo.hs
-theories/Sets/Cpo.o : theories/Sets/Partial_Order.o
-theories/Sets/Ensembles.o : theories/Sets/Ensembles.hs
-theories/Sets/Finite_sets_facts.o : theories/Sets/Finite_sets_facts.hs
-theories/Sets/Finite_sets.o : theories/Sets/Finite_sets.hs
-theories/Sets/Image.o : theories/Sets/Image.hs
-theories/Sets/Infinite_sets.o : theories/Sets/Infinite_sets.hs
-theories/Sets/Integers.o : theories/Sets/Integers.hs
-theories/Sets/Integers.o : theories/Sets/Partial_Order.o
-theories/Sets/Integers.o : theories/Init/Datatypes.o
-theories/Sets/Multiset.o : theories/Sets/Multiset.hs
-theories/Sets/Multiset.o : theories/Init/Specif.o
-theories/Sets/Multiset.o : theories/Init/Peano.o
-theories/Sets/Multiset.o : theories/Init/Datatypes.o
-theories/Sets/Partial_Order.o : theories/Sets/Partial_Order.hs
-theories/Sets/Permut.o : theories/Sets/Permut.hs
-theories/Sets/Powerset_Classical_facts.o : theories/Sets/Powerset_Classical_facts.hs
-theories/Sets/Powerset_facts.o : theories/Sets/Powerset_facts.hs
-theories/Sets/Powerset.o : theories/Sets/Powerset.hs
-theories/Sets/Powerset.o : theories/Sets/Partial_Order.o
-theories/Sets/Relations_1_facts.o : theories/Sets/Relations_1_facts.hs
-theories/Sets/Relations_1.o : theories/Sets/Relations_1.hs
-theories/Sets/Relations_2_facts.o : theories/Sets/Relations_2_facts.hs
-theories/Sets/Relations_2.o : theories/Sets/Relations_2.hs
-theories/Sets/Relations_3_facts.o : theories/Sets/Relations_3_facts.hs
-theories/Sets/Relations_3.o : theories/Sets/Relations_3.hs
-theories/Sets/Uniset.o : theories/Sets/Uniset.hs
-theories/Sets/Uniset.o : theories/Init/Specif.o
-theories/Sets/Uniset.o : theories/Init/Datatypes.o
-theories/Sets/Uniset.o : theories/Bool/Bool.o
-theories/Sorting/Heap.o : theories/Sorting/Heap.hs
-theories/Sorting/Heap.o : theories/Init/Specif.o
-theories/Sorting/Heap.o : theories/Sorting/Sorting.o
-theories/Sorting/Heap.o : theories/Lists/PolyList.o
-theories/Sorting/Heap.o : theories/Sets/Multiset.o
-theories/Sorting/Heap.o : theories/Init/Logic.o
-theories/Sorting/Permutation.o : theories/Sorting/Permutation.hs
-theories/Sorting/Permutation.o : theories/Init/Specif.o
-theories/Sorting/Permutation.o : theories/Lists/PolyList.o
-theories/Sorting/Permutation.o : theories/Sets/Multiset.o
-theories/Sorting/Sorting.o : theories/Sorting/Sorting.hs
-theories/Sorting/Sorting.o : theories/Init/Specif.o
-theories/Sorting/Sorting.o : theories/Lists/PolyList.o
-theories/Sorting/Sorting.o : theories/Init/Logic.o
-theories/Wellfounded/Disjoint_Union.o : theories/Wellfounded/Disjoint_Union.hs
-theories/Wellfounded/Inclusion.o : theories/Wellfounded/Inclusion.hs
-theories/Wellfounded/Inverse_Image.o : theories/Wellfounded/Inverse_Image.hs
-theories/Wellfounded/Lexicographic_Exponentiation.o : theories/Wellfounded/Lexicographic_Exponentiation.hs
-theories/Wellfounded/Lexicographic_Product.o : theories/Wellfounded/Lexicographic_Product.hs
-theories/Wellfounded/Transitive_Closure.o : theories/Wellfounded/Transitive_Closure.hs
-theories/Wellfounded/Union.o : theories/Wellfounded/Union.hs
-theories/Wellfounded/Wellfounded.o : theories/Wellfounded/Wellfounded.hs
-theories/Wellfounded/Well_Ordering.o : theories/Wellfounded/Well_Ordering.hs
-theories/Wellfounded/Well_Ordering.o : theories/Init/Wf.o
-theories/Wellfounded/Well_Ordering.o : theories/Init/Specif.o
-theories/ZArith/Auxiliary.o : theories/ZArith/Auxiliary.hs
-theories/ZArith/Fast_integer.o : theories/ZArith/Fast_integer.hs
-theories/ZArith/Fast_integer.o : theories/Init/Peano.o
-theories/ZArith/Fast_integer.o : theories/Init/Datatypes.o
-theories/ZArith/Wf_Z.o : theories/ZArith/Wf_Z.hs
-theories/ZArith/Wf_Z.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Wf_Z.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Wf_Z.o : theories/Init/Specif.o
-theories/ZArith/Wf_Z.o : theories/Init/Peano.o
-theories/ZArith/Wf_Z.o : theories/Init/Logic.o
-theories/ZArith/Wf_Z.o : theories/Init/Datatypes.o
-theories/ZArith/Zarith_aux.o : theories/ZArith/Zarith_aux.hs
-theories/ZArith/Zarith_aux.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zarith_aux.o : theories/Init/Specif.o
-theories/ZArith/Zarith_aux.o : theories/Init/Datatypes.o
-theories/ZArith/ZArith_base.o : theories/ZArith/ZArith_base.hs
-theories/ZArith/ZArith_dec.o : theories/ZArith/ZArith_dec.hs
-theories/ZArith/ZArith_dec.o : theories/ZArith/Fast_integer.o
-theories/ZArith/ZArith_dec.o : theories/Bool/Sumbool.o
-theories/ZArith/ZArith_dec.o : theories/Init/Specif.o
-theories/ZArith/ZArith_dec.o : theories/Init/Logic.o
-theories/ZArith/ZArith.o : theories/ZArith/ZArith.hs
-theories/ZArith/Zbool.o : theories/ZArith/Zbool.hs
-theories/ZArith/Zbool.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zbool.o : theories/ZArith/Zmisc.o
-theories/ZArith/Zbool.o : theories/ZArith/ZArith_dec.o
-theories/ZArith/Zbool.o : theories/Bool/Sumbool.o
-theories/ZArith/Zbool.o : theories/Init/Specif.o
-theories/ZArith/Zbool.o : theories/Init/Datatypes.o
-theories/ZArith/Zcomplements.o : theories/ZArith/Zcomplements.hs
-theories/ZArith/Zcomplements.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zcomplements.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zcomplements.o : theories/ZArith/Wf_Z.o
-theories/ZArith/Zcomplements.o : theories/Init/Specif.o
-theories/ZArith/Zcomplements.o : theories/Init/Logic.o
-theories/ZArith/Zcomplements.o : theories/Init/Datatypes.o
-theories/ZArith/Zdiv.o : theories/ZArith/Zdiv.hs
-theories/ZArith/Zdiv.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zdiv.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zdiv.o : theories/ZArith/Zmisc.o
-theories/ZArith/Zdiv.o : theories/ZArith/ZArith_dec.o
-theories/ZArith/Zdiv.o : theories/Init/Specif.o
-theories/ZArith/Zdiv.o : theories/Init/Logic.o
-theories/ZArith/Zdiv.o : theories/Init/Datatypes.o
-theories/ZArith/Zhints.o : theories/ZArith/Zhints.hs
-theories/ZArith/Zlogarithm.o : theories/ZArith/Zlogarithm.hs
-theories/ZArith/Zlogarithm.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zlogarithm.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zmisc.o : theories/ZArith/Zmisc.hs
-theories/ZArith/Zmisc.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zmisc.o : theories/Init/Specif.o
-theories/ZArith/Zmisc.o : theories/Init/Datatypes.o
-theories/ZArith/Zpower.o : theories/ZArith/Zpower.hs
-theories/ZArith/Zpower.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zpower.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zpower.o : theories/ZArith/Zmisc.o
-theories/ZArith/Zpower.o : theories/Init/Logic.o
-theories/ZArith/Zpower.o : theories/Init/Datatypes.o
-theories/ZArith/Zsqrt.o : theories/ZArith/Zsqrt.hs
-theories/ZArith/Zsqrt.o : theories/ZArith/Zarith_aux.o
-theories/ZArith/Zsqrt.o : theories/ZArith/Fast_integer.o
-theories/ZArith/Zsqrt.o : theories/ZArith/ZArith_dec.o
-theories/ZArith/Zsqrt.o : theories/Init/Specif.o
-theories/ZArith/Zsqrt.o : theories/Init/Logic.o
-theories/ZArith/Zwf.o : theories/ZArith/Zwf.hs
-# DO NOT DELETE: End of Haskell dependencies
diff --git a/contrib/extraction/test/addReals b/contrib/extraction/test/addReals
deleted file mode 100644
index fb73d47b..00000000
--- a/contrib/extraction/test/addReals
+++ /dev/null
@@ -1,21 +0,0 @@
-open TypeSyntax
-open Fast_integer
-
-
-let total_order_T x y =
-if x = y then InleftT RightT
-else if x < y then InleftT LeftT
-else InrightT
-
-let rec int_to_positive i =
- if i = 1 then XH
- else
- if (i mod 2) = 0 then XO (int_to_positive (i/2))
- else XI (int_to_positive (i/2))
-
-let rec int_to_Z i =
- if i = 0 then ZERO
- else if i > 0 then POS (int_to_positive i)
- else NEG (int_to_positive (-i))
-
-let my_ceil x = int_to_Z (succ (int_of_float (floor x)))
diff --git a/contrib/extraction/test/custom/Adalloc b/contrib/extraction/test/custom/Adalloc
deleted file mode 100644
index e7204838..00000000
--- a/contrib/extraction/test/custom/Adalloc
+++ /dev/null
@@ -1,2 +0,0 @@
-Require Import BinNat.
-Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/Euclid b/contrib/extraction/test/custom/Euclid
deleted file mode 100644
index a58e3940..00000000
--- a/contrib/extraction/test/custom/Euclid
+++ /dev/null
@@ -1 +0,0 @@
-Extraction Inline Wf_nat.gt_wf_rec Wf_nat.lt_wf_rec.
diff --git a/contrib/extraction/test/custom/List b/contrib/extraction/test/custom/List
deleted file mode 100644
index ffee7dc9..00000000
--- a/contrib/extraction/test/custom/List
+++ /dev/null
@@ -1 +0,0 @@
-Extraction NoInline map.
diff --git a/contrib/extraction/test/custom/ListSet b/contrib/extraction/test/custom/ListSet
deleted file mode 100644
index c9bea52a..00000000
--- a/contrib/extraction/test/custom/ListSet
+++ /dev/null
@@ -1 +0,0 @@
-Extraction NoInline set_add set_mem.
diff --git a/contrib/extraction/test/custom/Lsort b/contrib/extraction/test/custom/Lsort
deleted file mode 100644
index 22ab18e3..00000000
--- a/contrib/extraction/test/custom/Lsort
+++ /dev/null
@@ -1,2 +0,0 @@
-Require Import BinNat.
-Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/Map b/contrib/extraction/test/custom/Map
deleted file mode 100644
index f024dbd7..00000000
--- a/contrib/extraction/test/custom/Map
+++ /dev/null
@@ -1,3 +0,0 @@
-Require Import BinNat.
-Extraction NoInline Ndouble Ndouble_plus_one.
-
diff --git a/contrib/extraction/test/custom/Mapcard b/contrib/extraction/test/custom/Mapcard
deleted file mode 100644
index 5932cf7b..00000000
--- a/contrib/extraction/test/custom/Mapcard
+++ /dev/null
@@ -1,4 +0,0 @@
-Require Import Plus.
-Extraction NoInline plus_is_one.
-Require Import BinNat.
-Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/Mapiter b/contrib/extraction/test/custom/Mapiter
deleted file mode 100644
index 22ab18e3..00000000
--- a/contrib/extraction/test/custom/Mapiter
+++ /dev/null
@@ -1,2 +0,0 @@
-Require Import BinNat.
-Extraction NoInline Ndouble Ndouble_plus_one.
diff --git a/contrib/extraction/test/custom/R_Ifp b/contrib/extraction/test/custom/R_Ifp
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/R_Ifp
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/R_sqr b/contrib/extraction/test/custom/R_sqr
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/R_sqr
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Ranalysis b/contrib/extraction/test/custom/Ranalysis
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Ranalysis
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Raxioms b/contrib/extraction/test/custom/Raxioms
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Raxioms
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rbase b/contrib/extraction/test/custom/Rbase
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rbase
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rbasic_fun b/contrib/extraction/test/custom/Rbasic_fun
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rbasic_fun
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rdefinitions b/contrib/extraction/test/custom/Rdefinitions
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rdefinitions
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Reals.v b/contrib/extraction/test/custom/Reals.v
deleted file mode 100644
index 45d0a224..00000000
--- a/contrib/extraction/test/custom/Reals.v
+++ /dev/null
@@ -1,17 +0,0 @@
-Require Import Reals.
-Extract Inlined Constant R => float.
-Extract Inlined Constant R0 => "0.0".
-Extract Inlined Constant R1 => "1.0".
-Extract Inlined Constant Rplus => "(+.)".
-Extract Inlined Constant Rmult => "( *.)".
-Extract Inlined Constant Ropp => "(~-.)".
-Extract Inlined Constant Rinv => "(fun x -> 1.0 /. x)".
-Extract Inlined Constant Rlt => "(<)".
-Extract Inlined Constant up => "AddReals.my_ceil".
-Extract Inlined Constant total_order_T => "AddReals.total_order_T".
-Extract Inlined Constant sqrt => "sqrt".
-Extract Inlined Constant sigma => "(fun l h -> sigma_aux l h (Minus.minus h l))".
-Extract Inlined Constant PI => "3.141593".
-Extract Inlined Constant cos => cos.
-Extract Inlined Constant sin => sin.
-Extract Inlined Constant derive_pt => "(fun f x -> ((f (x+.1E-5))-.(f x))*.1E5)".
diff --git a/contrib/extraction/test/custom/Rfunctions b/contrib/extraction/test/custom/Rfunctions
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rfunctions
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rgeom b/contrib/extraction/test/custom/Rgeom
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rgeom
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rlimit b/contrib/extraction/test/custom/Rlimit
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rlimit
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rseries b/contrib/extraction/test/custom/Rseries
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rseries
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rsigma b/contrib/extraction/test/custom/Rsigma
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rsigma
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/Rtrigo b/contrib/extraction/test/custom/Rtrigo
deleted file mode 100644
index d8f1b3e7..00000000
--- a/contrib/extraction/test/custom/Rtrigo
+++ /dev/null
@@ -1,2 +0,0 @@
-Load "custom/Reals".
-
diff --git a/contrib/extraction/test/custom/ZArith_dec b/contrib/extraction/test/custom/ZArith_dec
deleted file mode 100644
index 2201419e..00000000
--- a/contrib/extraction/test/custom/ZArith_dec
+++ /dev/null
@@ -1 +0,0 @@
-Extraction Inline Dcompare_inf Zcompare_rec.
diff --git a/contrib/extraction/test/custom/fast_integer b/contrib/extraction/test/custom/fast_integer
deleted file mode 100644
index e2b24953..00000000
--- a/contrib/extraction/test/custom/fast_integer
+++ /dev/null
@@ -1 +0,0 @@
-Extraction NoInline Zero_suivi_de Un_suivi_de.
diff --git a/contrib/extraction/test/e b/contrib/extraction/test/e
deleted file mode 100644
index 88b6c90b..00000000
--- a/contrib/extraction/test/e
+++ /dev/null
@@ -1,17 +0,0 @@
-
-(* To trace Extraction, you can use this file via: *)
-(* Drop. #use "e";; *)
-(* *)
-
-#use "include";;
-open Extraction;;
-open Miniml;;
-#trace extract_declaration;;
-go();;
-
-
-
-
-
-
-
diff --git a/contrib/extraction/test/extract b/contrib/extraction/test/extract
deleted file mode 100755
index 83444be3..00000000
--- a/contrib/extraction/test/extract
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/sh
-rm -f /tmp/extr$$.v
-vfile=`./ml2v $1`
-d=`dirname $vfile`
-n=`basename $vfile .v`
-if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi
-echo "Cd \"$d\". Extraction Library $n. " >> /tmp/extr$$.v
-../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v
-out=$?
-rm -f /tmp/extr$$.v
-exit $out
-
diff --git a/contrib/extraction/test/extract.haskell b/contrib/extraction/test/extract.haskell
deleted file mode 100755
index d11bc706..00000000
--- a/contrib/extraction/test/extract.haskell
+++ /dev/null
@@ -1,12 +0,0 @@
-#!/bin/sh
-rm -f /tmp/extr$$.v
-vfile=`./hs2v $1`
-d=`dirname $vfile`
-n=`basename $vfile .v`
-if [ -e custom/$n ]; then cat custom/$n > /tmp/extr$$.v; fi
-echo "Cd \"$d\". Extraction Language Haskell. Extraction Library $n. " >> /tmp/extr$$.v
-../../../bin/coqtop.opt -silent -batch -require $n -load-vernac-source /tmp/extr$$.v
-out=$?
-rm -f /tmp/extr$$.v
-exit $out
-
diff --git a/contrib/extraction/test/hs2v.ml b/contrib/extraction/test/hs2v.ml
deleted file mode 100644
index fd8b9b26..00000000
--- a/contrib/extraction/test/hs2v.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-let _ =
- for j = 1 to ((Array.length Sys.argv)-1) do
- let fml = Sys.argv.(j) in
- let f = Filename.chop_extension fml in
- let fv = f ^ ".v" in
- if Sys.file_exists ("../../../" ^ fv) then
- print_string (fv^" ")
- else
- let d = Filename.dirname f in
- let b = String.uncapitalize (Filename.basename f) in
- let fv = Filename.concat d (b ^ ".v ") in
- print_string fv
- done;
- print_newline()
diff --git a/contrib/extraction/test/make_mli b/contrib/extraction/test/make_mli
deleted file mode 100755
index 40ee496e..00000000
--- a/contrib/extraction/test/make_mli
+++ /dev/null
@@ -1,17 +0,0 @@
-#!/usr/bin/awk -We $0
-
-{ match($0,"^open")
- if (RLENGTH>0) state=1
- match($0,"^type")
- if (RLENGTH>0) state=1
- match($0,"^\(\*\* ")
- if (RLENGTH>0) state=2
- match($0,"^let")
- if (RLENGTH>0) state=0
- match($0,"^and")
- if ((RLENGTH>0) && (state==2)) state=0
- if ((RLENGTH>0) && (state==1)) state=1
- gsub("\(\*\* ","")
- gsub("\*\*\)","")
- if (state>0) print
-}
diff --git a/contrib/extraction/test/ml2v.ml b/contrib/extraction/test/ml2v.ml
deleted file mode 100644
index 363ea642..00000000
--- a/contrib/extraction/test/ml2v.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-let _ =
- for j = 1 to ((Array.length Sys.argv)-1) do
- let fml = Sys.argv.(j) in
- let f = Filename.chop_extension fml in
- let fv = f ^ ".v" in
- if Sys.file_exists ("../../../" ^ fv) then
- print_string (fv^" ")
- else
- let d = Filename.dirname f in
- let b = String.capitalize (Filename.basename f) in
- let fv = Filename.concat d (b ^ ".v ") in
- print_string fv
- done;
- print_newline()
diff --git a/contrib/extraction/test/v2hs.ml b/contrib/extraction/test/v2hs.ml
deleted file mode 100644
index 88632875..00000000
--- a/contrib/extraction/test/v2hs.ml
+++ /dev/null
@@ -1,9 +0,0 @@
-let _ =
- for j = 1 to ((Array.length Sys.argv) -1) do
- let s = Sys.argv.(j) in
- let b = Filename.chop_extension (Filename.basename s) in
- let b = String.capitalize b in
- let d = Filename.dirname s in
- print_string (Filename.concat d (b ^ ".hs "))
- done;
- print_newline()
diff --git a/contrib/extraction/test/v2ml.ml b/contrib/extraction/test/v2ml.ml
deleted file mode 100644
index 245a1b1e..00000000
--- a/contrib/extraction/test/v2ml.ml
+++ /dev/null
@@ -1,9 +0,0 @@
-let _ =
- for j = 1 to ((Array.length Sys.argv) -1) do
- let s = Sys.argv.(j) in
- let b = Filename.chop_extension (Filename.basename s) in
- let b = String.uncapitalize b in
- let d = Filename.dirname s in
- print_string (Filename.concat d (b ^ ".ml "))
- done;
- print_newline()
diff --git a/contrib/field/field.ml4 b/contrib/field/field.ml4
index dab5a45c..dea79773 100644
--- a/contrib/field/field.ml4
+++ b/contrib/field/field.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: field.ml4 9273 2006-10-25 11:30:36Z barras $ *)
+(* $Id: field.ml4 10076 2007-08-16 11:16:43Z notin $ *)
open Names
open Pp
@@ -159,7 +159,7 @@ let field g =
| Some (eq,t::args) when eq = (Coqlib.build_coq_eq_data()).Coqlib.eq -> t
| _ -> 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 ())
+ (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 *)
diff --git a/contrib/first-order/formula.ml b/contrib/firstorder/formula.ml
index 0be468aa..3e49cd9c 100644
--- a/contrib/first-order/formula.ml
+++ b/contrib/firstorder/formula.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: formula.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
+(* $Id: formula.ml 10785 2008-04-13 21:41:54Z herbelin $ *)
open Hipattern
open Names
@@ -120,7 +120,7 @@ type side = Hyp | Concl | Hint
let no_atoms = (false,{positive=[];negative=[]})
-let dummy_id=VarRef (id_of_string "")
+let dummy_id=VarRef (id_of_string "_") (* "_" cannot be parsed *)
let build_atoms gl metagen side cciterm =
let trivial =ref false
diff --git a/contrib/first-order/formula.mli b/contrib/firstorder/formula.mli
index 8703045c..8703045c 100644
--- a/contrib/first-order/formula.mli
+++ b/contrib/firstorder/formula.mli
diff --git a/contrib/first-order/g_ground.ml4 b/contrib/firstorder/g_ground.ml4
index 366f563b..f7b0a546 100644
--- a/contrib/first-order/g_ground.ml4
+++ b/contrib/firstorder/g_ground.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_ground.ml4 9154 2006-09-20 17:18:18Z corbinea $ *)
+(* $Id: g_ground.ml4 10346 2007-12-05 21:11:19Z aspiwack $ *)
open Formula
open Sequent
@@ -97,23 +97,24 @@ let normalize_evaluables=
(Tacexpr.InHypType id)) *)
TACTIC EXTEND firstorder
- [ "firstorder" tactic_opt(t) "with" ne_reference_list(l) ] ->
- [ gen_ground_tac true (option_map eval_tactic t) (Ids l) ]
-| [ "firstorder" tactic_opt(t) "using" ne_preident_list(l) ] ->
- [ gen_ground_tac true (option_map eval_tactic t) (Bases l) ]
+ [ "firstorder" tactic_opt(t) "using" ne_reference_list(l) ] ->
+ [ gen_ground_tac true (Option.map eval_tactic t) (Ids l) ]
+| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] ->
+ [ gen_ground_tac true (Option.map eval_tactic t) (Bases l) ]
| [ "firstorder" tactic_opt(t) ] ->
- [ gen_ground_tac true (option_map eval_tactic t) Void ]
+ [ gen_ground_tac true (Option.map eval_tactic t) Void ]
END
TACTIC EXTEND gintuition
[ "gintuition" tactic_opt(t) ] ->
- [ gen_ground_tac false (option_map eval_tactic t) Void ]
+ [ gen_ground_tac false (Option.map eval_tactic t) Void ]
END
let default_declarative_automation gls =
- tclORELSE
- (Cctac.congruence_tac !congruence_depth [])
+ tclORELSE
+ (tclORELSE (Auto.h_trivial [] None)
+ (Cctac.congruence_tac !congruence_depth []))
(gen_ground_tac true
(Some (tclTHEN
default_solver
diff --git a/contrib/first-order/ground.ml b/contrib/firstorder/ground.ml
index bccac6df..f4661869 100644
--- a/contrib/first-order/ground.ml
+++ b/contrib/firstorder/ground.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ground.ml 9537 2007-01-26 10:05:04Z corbinea $ *)
+(* $Id: ground.ml 9549 2007-01-28 23:30:12Z corbinea $ *)
open Formula
open Sequent
diff --git a/contrib/first-order/ground.mli b/contrib/firstorder/ground.mli
index 621f99db..621f99db 100644
--- a/contrib/first-order/ground.mli
+++ b/contrib/firstorder/ground.mli
diff --git a/contrib/first-order/instances.ml b/contrib/firstorder/instances.ml
index 254d7b84..1432207d 100644
--- a/contrib/first-order/instances.ml
+++ b/contrib/firstorder/instances.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: instances.ml 8654 2006-03-22 15:36:58Z msozeau $ i*)
+(*i $Id: instances.ml 10410 2007-12-31 13:11:55Z msozeau $ i*)
open Formula
open Sequent
@@ -125,9 +125,9 @@ let mk_open_instance id gl m t=
let rec raux n t=
if n=0 then t else
match t with
- RLambda(loc,name,_,t0)->
+ RLambda(loc,name,k,_,t0)->
let t1=raux (n-1) t0 in
- RLambda(loc,name,RHole (dummy_loc,Evd.BinderType name),t1)
+ 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)
diff --git a/contrib/first-order/instances.mli b/contrib/firstorder/instances.mli
index 7667c89f..7667c89f 100644
--- a/contrib/first-order/instances.mli
+++ b/contrib/firstorder/instances.mli
diff --git a/contrib/first-order/rules.ml b/contrib/firstorder/rules.ml
index 6c51eda3..b8b56548 100644
--- a/contrib/first-order/rules.ml
+++ b/contrib/firstorder/rules.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: rules.ml 8878 2006-05-30 16:44:25Z herbelin $ *)
+(* $Id: rules.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
open Util
open Names
@@ -78,7 +78,7 @@ let and_tac backtrack continue seq=
let or_tac backtrack continue seq=
tclORELSE
- (any_constructor (Some (tclCOMPLETE (wrap 0 true continue seq))))
+ (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq))))
backtrack
let arrow_tac backtrack continue seq=
@@ -204,8 +204,8 @@ let ll_forall_tac prod backtrack id continue seq=
let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str
let defined_connectives=lazy
- [[],EvalConstRef (destConst (constant "not"));
- [],EvalConstRef (destConst (constant "iff"))]
+ [all_occurrences,EvalConstRef (destConst (constant "not"));
+ all_occurrences,EvalConstRef (destConst (constant "iff"))]
let normalize_evaluables=
onAllClauses
@@ -213,4 +213,4 @@ let normalize_evaluables=
None->unfold_in_concl (Lazy.force defined_connectives)
| Some ((_,id),_)->
unfold_in_hyp (Lazy.force defined_connectives)
- (([],id),Tacexpr.InHypTypeOnly))
+ ((Rawterm.all_occurrences_expr,id),Tacexpr.InHypTypeOnly))
diff --git a/contrib/first-order/rules.mli b/contrib/firstorder/rules.mli
index 3798d8d4..3798d8d4 100644
--- a/contrib/first-order/rules.mli
+++ b/contrib/firstorder/rules.mli
diff --git a/contrib/first-order/sequent.ml b/contrib/firstorder/sequent.ml
index 805700b0..c832d30f 100644
--- a/contrib/first-order/sequent.ml
+++ b/contrib/firstorder/sequent.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: sequent.ml 7925 2006-01-24 23:20:39Z herbelin $ *)
+(* $Id: sequent.ml 10824 2008-04-21 13:57:03Z msozeau $ *)
open Term
open Util
@@ -281,7 +281,7 @@ let create_with_auto_hints l depth gl=
searchtable_map dbname
with Not_found->
error ("Firstorder: "^dbname^" : No such Hint database") in
- Hint_db.iter g hdb in
+ Hint_db.iter g (snd hdb) in
List.iter h l;
!seqref
diff --git a/contrib/first-order/sequent.mli b/contrib/firstorder/sequent.mli
index 47fb74c7..47fb74c7 100644
--- a/contrib/first-order/sequent.mli
+++ b/contrib/firstorder/sequent.mli
diff --git a/contrib/first-order/unify.ml b/contrib/firstorder/unify.ml
index 1dd13cbe..1dd13cbe 100644
--- a/contrib/first-order/unify.ml
+++ b/contrib/firstorder/unify.ml
diff --git a/contrib/first-order/unify.mli b/contrib/firstorder/unify.mli
index 9fbe3dda..9fbe3dda 100644
--- a/contrib/first-order/unify.mli
+++ b/contrib/firstorder/unify.mli
diff --git a/contrib/fourier/Fourier_util.v b/contrib/fourier/Fourier_util.v
index c3257b7d..6a9ab051 100644
--- a/contrib/fourier/Fourier_util.v
+++ b/contrib/fourier/Fourier_util.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Fourier_util.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id: Fourier_util.v 10710 2008-03-23 09:24:09Z herbelin $ *)
Require Export Rbase.
Comments "Lemmas used by the tactic Fourier".
@@ -152,7 +152,7 @@ apply Rlt_irrefl.
ring.
Qed.
-Lemma Rlt_not_le : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d.
+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).
diff --git a/contrib/fourier/fourierR.ml b/contrib/fourier/fourierR.ml
index f9518bcb..114d5f9c 100644
--- a/contrib/fourier/fourierR.ml
+++ b/contrib/fourier/fourierR.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: fourierR.ml 7760 2005-12-30 10:49:13Z herbelin $ *)
+(* $Id: fourierR.ml 10790 2008-04-14 22:34:19Z herbelin $ *)
@@ -258,11 +258,11 @@ 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 c ->
- try (Hashtbl.find hvar x;())
- with _-> nvar:=(!nvar)+1;
- Hashtbl.add hvar x (!nvar))
- f.hflin.fhom)
+ 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
@@ -334,7 +334,7 @@ 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 = lazy (constant_fourier "Rlt_not_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,
@@ -404,7 +404,7 @@ let tac_zero_inf_false 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))
+ (tclTHEN (apply (get coq_Rlt_not_le_frac_opp))
(tac_zero_inf_pos gl (-n,d)))
;;
@@ -492,7 +492,7 @@ let rec fourier gl=
in tac gl)
with _ ->
(* les hypothèses *)
- let hyps = List.map (fun (h,t)-> (mkVar h,(body_of_type t)))
+ 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))
@@ -503,8 +503,7 @@ let rec fourier gl=
let res=fourier_lineq (!lineq) in
let tac=ref tclIDTAC in
if res=[]
- then (print_string "Tactic Fourier fails.\n";
- flush stdout)
+ 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)]->
diff --git a/contrib/recdef/Recdef.v b/contrib/funind/Recdef.v
index 2d206220..2d206220 100644
--- a/contrib/recdef/Recdef.v
+++ b/contrib/funind/Recdef.v
diff --git a/contrib/funind/functional_principles_proofs.ml b/contrib/funind/functional_principles_proofs.ml
index 975cf60b..3d80bd00 100644
--- a/contrib/funind/functional_principles_proofs.ml
+++ b/contrib/funind/functional_principles_proofs.ml
@@ -47,7 +47,7 @@ let observe_tac_stream s tac g =
let observe_tac s tac g = observe_tac_stream (str s) tac g
(* let tclTRYD tac = *)
-(* if !Options.debug || do_observe () *)
+(* if !Flags.debug || do_observe () *)
(* then (fun g -> try (\* do_observe_tac "" *\)tac g with _ -> tclIDTAC g) *)
(* else tac *)
@@ -140,7 +140,7 @@ let change_hyp_with_using msg hyp_id t tac : tactic =
[tclTHENLIST
[
(* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]);
- (* observe_tac "change_hyp_with_using rename " *) (h_rename prov_id hyp_id)
+ (* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id])
]] g
exception TOREMOVE
@@ -573,7 +573,7 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id
tclTHENLIST[
forward None (Genarg.IntroIdentifier prov_hid) (mkApp(mkVar hid,args));
thin [hid];
- (h_rename prov_hid hid)
+ h_rename [prov_hid,hid]
] g
)
( (*
@@ -637,7 +637,7 @@ let build_proof
[
h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
thin dyn_infos.rec_hyps;
- pattern_option [[-1],t] None;
+ pattern_option [(false,[1]),t] None;
h_simplest_case t;
(fun g' ->
let g'_nb_prod = nb_prod (pf_concl g') in
@@ -882,7 +882,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
let f_def = Global.lookup_constant (destConst f) in
let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in
let f_body =
- force (out_some f_def.const_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
@@ -910,7 +910,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num =
let rec_id = pf_nth_hyp_id g 1 in
tclTHENSEQ
[(* observe_tac "generalize_non_dep in generate_equation_lemma" *) (generalize_non_dep rec_id);
- (* observe_tac "h_case" *) (h_case (mkVar rec_id,Rawterm.NoBindings));
+ (* observe_tac "h_case" *) (h_case false (mkVar rec_id,Rawterm.NoBindings));
intros_reflexivity] g
)
]
@@ -933,8 +933,8 @@ 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 (out_some finfos.equation_lemma)
- with (Not_found | Failure "out_some" as e) ->
+ 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
@@ -943,7 +943,7 @@ let do_replace params rec_arg_num rev_args_id f fun_num all_funs g =
generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num;
let _ =
match e with
- | Failure "out_some" ->
+ | Option.IsNone ->
let finfos = find_Function_infos (destConst f) in
update_Function
{finfos with
@@ -1141,7 +1141,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
then
(* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1))
else
- h_mutual_fix this_fix_info.name (this_fix_info.idx + 1)
+ h_mutual_fix false this_fix_info.name (this_fix_info.idx + 1)
other_fix_infos
| _ -> anomaly "Not a valid information"
in
@@ -1246,7 +1246,7 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams :
in
let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
tclTHENSEQ
- [unfold_in_concl [([],Names.EvalConstRef fname)];
+ [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)];
let do_prove =
build_proof
interactive_proof
@@ -1347,19 +1347,27 @@ let build_clause eqs =
{
Tacexpr.onhyps =
Some (List.map
- (fun id -> ([],id),Tacexpr.InHyp)
+ (fun id -> (Rawterm.all_occurrences_expr,id),Tacexpr.InHyp)
eqs
);
- Tacexpr.onconcl = false;
- Tacexpr.concl_occs = []
+ Tacexpr.concl_occs = Rawterm.no_occurrences_expr
}
let rec rewrite_eqs_in_eqs eqs =
match eqs with
| [] -> tclIDTAC
| eq::eqs ->
+
tclTHEN
- (tclMAP (fun id -> tclTRY (Equality.general_rewrite_in true id (mkVar eq))) eqs)
+ (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 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 =
@@ -1373,21 +1381,26 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
[ tclTHENSEQ
[
keep (tcc_hyps@eqs);
-
apply (Lazy.force acc_inv);
(fun g ->
if is_mes
then
- unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))] g
+ 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));
- rewrite_eqs_in_eqs eqs;
- (observe_tac "finishing"
- (tclCOMPLETE (
- Eauto.gen_eauto false (false,5) [] (Some []))
+ 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]
+ [empty_transparent_state, Auto.Hint_db.empty]
+ )
)
)
]
@@ -1445,7 +1458,7 @@ let prove_principle_for_gen
let wf_tac =
if is_mes
then
- (fun b -> Recdef.tclUSER_if_not_mes b None)
+ (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
@@ -1502,16 +1515,16 @@ let prove_principle_for_gen
| 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 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
@@ -1527,7 +1540,7 @@ let prove_principle_for_gen
Elim.h_decompose_and (mkVar hid);
(fun g ->
let new_hyps = pf_ids_of_hyps g in
- tcc_list := list_diff new_hyps (hid::hyps);
+ tcc_list := List.rev (list_subtract new_hyps (hid::hyps));
if !tcc_list = []
then
begin
@@ -1593,14 +1606,15 @@ let prove_principle_for_gen
(* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *)
(* observe_tac "new_prove_with_tcc" *)
- (new_prove_with_tcc
+ (new_prove_with_tcc
is_mes acc_inv fix_id
- !tcc_list
- ((List.map
+
+ (!tcc_list@(List.map
(fun (na,_,_) -> (Nameops.out_name na))
(princ_info.args@princ_info.params)
- )@ (acc_rec_arg_id::eqs))
+ )@ ([acc_rec_arg_id])) eqs
)
+
);
is_valid = is_valid_hypothesis predicates_names
}
diff --git a/contrib/funind/functional_principles_types.ml b/contrib/funind/functional_principles_types.ml
index 8ad2e72b..16076479 100644
--- a/contrib/funind/functional_principles_types.ml
+++ b/contrib/funind/functional_principles_types.ml
@@ -115,7 +115,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
it_mkProd_or_LetIn
~init:
(it_mkProd_or_LetIn
- ~init:(option_fold_right
+ ~init:(Option.fold_right
mkProd_or_LetIn
princ_type_info.indarg
princ_type_info.concl
@@ -384,7 +384,7 @@ let generate_functional_principle
{ const_entry_body = value;
const_entry_type = None;
const_entry_opaque = false;
- const_entry_boxed = Options.boxed_definitions()
+ const_entry_boxed = Flags.boxed_definitions()
}
in
ignore(
@@ -394,7 +394,7 @@ let generate_functional_principle
Decl_kinds.IsDefinition (Decl_kinds.Scheme)
)
);
- Options.if_verbose
+ Flags.if_verbose
(fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined"))
name;
names := name :: !names
@@ -561,6 +561,15 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent
(fun _ _ _ -> ())
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
@@ -642,10 +651,12 @@ let build_scheme 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));
- Options.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id
+ 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
diff --git a/contrib/funind/indfun_main.ml4 b/contrib/funind/g_indfun.ml4
index 9cee9edc..dae76f2d 100644
--- a/contrib/funind/indfun_main.ml4
+++ b/contrib/funind/g_indfun.ml4
@@ -29,20 +29,37 @@ let pr_bindings prc prlc = function
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 (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,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 (fun c -> prc (snd c)) (fun c -> prlc (snd c)) bl)
+
+let pr_fun_ind_using_typed prc prlc _ opt_c =
+ match opt_c with
+ | None -> mt ()
+ | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc (p,b))
+
ARGUMENT EXTEND fun_ind_using
TYPED AS constr_with_bindings_opt
- PRINTED BY pr_fun_ind_using
+ 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
@@ -131,7 +148,7 @@ END
VERNAC ARGUMENT EXTEND binder2
[ "(" ne_ident_list(idl) ":" lconstr(c) ")"] ->
[
- LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,c) ]
+ LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) ]
END
@@ -152,7 +169,7 @@ VERNAC ARGUMENT EXTEND rec_definition2
| Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id
| Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args"
in
- (try ignore(Util.list_index (Name id) names - 1); annot
+ (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)
@@ -166,7 +183,7 @@ VERNAC ARGUMENT EXTEND rec_definition2
| Some an ->
check_exists_args an
in
- (id, ni, bl, type_, def) ]
+ ((Util.dummy_loc,id), ni, bl, type_, def) ]
END
@@ -300,7 +317,7 @@ let mkEq typ c1 c2 =
let poseq_unsafe idunsafe cstr gl =
let typ = Tacmach.pf_type_of gl cstr in
tclTHEN
- (Tactics.letin_tac true (Name idunsafe) cstr allClauses)
+ (Tactics.letin_tac None (Name idunsafe) cstr allClauses)
(tclTHENFIRST
(Tactics.assert_as true IntroAnonymous (mkEq typ (mkVar idunsafe) cstr))
Tactics.reflexivity)
@@ -446,25 +463,23 @@ VERNAC COMMAND EXTEND Showindinfo
END
VERNAC COMMAND EXTEND MergeFunind
- [ "Mergeschemes" lconstr(c) "with" lconstr(c') "using" ident(id) ] ->
+ [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")"
+ "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] ->
[
- let c1 = Constrintern.interp_constr Evd.empty (Global.env()) c in
- let c2 = Constrintern.interp_constr Evd.empty (Global.env()) c' in
- let id1,args1 =
- try
- let hd,args = destApp c1 in
- if Term.isInd hd then hd , args
- else raise (Util.error "Ill-formed (fst) argument")
- with Invalid_argument _
- -> Util.error ("Bad argument form for merging schemes") in
- let id2,args2 =
- try
- let hd,args = destApp c2 in
- if isInd hd then hd , args
- else raise (Util.error "Ill-formed (snd) argument")
- with Invalid_argument _
- -> Util.error ("Bad argument form for merging schemes") in
- (* TOFO: enlever le ignore et declarer l'inductif *)
- ignore(Merge.merge c1 c2 args1 args2 id)
+ 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/contrib/funind/indfun.ml b/contrib/funind/indfun.ml
index 82bee01f..a6cbb321 100644
--- a/contrib/funind/indfun.ml
+++ b/contrib/funind/indfun.ml
@@ -22,8 +22,8 @@ let is_rec_info scheme_info =
let choose_dest_or_ind scheme_info =
if is_rec_info scheme_info
- then Tactics.new_induct
- else Tactics.new_destruct
+ then Tactics.new_induct false
+ else Tactics.new_destruct false
let functional_induction with_clean c princl pat =
@@ -48,8 +48,8 @@ let functional_induction with_clean c princl pat =
| InType -> finfo.rect_lemma
in
let princ = (* then we get the principle *)
- try mkConst (out_some princ_option )
- with Failure "out_some" ->
+ 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*)
@@ -77,7 +77,7 @@ let functional_induction with_clean c princl pat =
if princ_infos.Tactics.farg_in_concl
then [c] else []
in
- List.map (fun c -> Tacexpr.ElimOnConstr c) (args@c_list)
+ List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list)
in
let princ' = Some (princ,bindings) in
let princ_vars =
@@ -120,7 +120,8 @@ let functional_induction with_clean c princl pat =
princ_infos
args_as_induction_constr
princ'
- pat)
+ pat
+ None)
subst_and_reduce
g
@@ -139,14 +140,14 @@ type newfixpoint_expr =
let rec abstract_rawconstr c = function
| [] -> c
| Topconstr.LocalRawDef (x,b)::bl -> Topconstr.mkLetInC(x,b,abstract_rawconstr c bl)
- | Topconstr.LocalRawAssum (idl,t)::bl ->
- List.fold_right (fun x b -> Topconstr.mkLambdaC([x],t,b)) idl
+ | 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:([],impls)
- ~allow_soapp:false ~ltacvars:([],[]) c
+ ~allow_patvar:false ~ltacvars:([],[]) c
(*
@@ -160,7 +161,7 @@ let build_newrecursive
in
let (rec_sign,rec_impls) =
List.fold_left
- (fun (env,impls) (recname,_,bl,arityc,_) ->
+ (fun (env,impls) ((_,recname),_,bl,arityc,_) ->
let arityc = Command.generalize_constr_expr arityc bl in
let arity = Constrintern.interp_type sigma env0 arityc in
let impl =
@@ -213,7 +214,7 @@ let rec is_rec names =
| 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) ->
+ | 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
@@ -224,7 +225,7 @@ let rec is_rec names =
)
b
| RApp(_,f,args) -> List.exists (lookup names) (f::args)
- | RCases(_,_,el,brl) ->
+ | RCases(_,_,_,el,brl) ->
List.exists (fun (e,_) -> lookup names e) el ||
List.exists (lookup_br names) brl
and lookup_br names (_,idl,_,rt) =
@@ -266,7 +267,7 @@ let derive_inversion fix_names =
)
with e ->
msg_warning
- (str "Cannot build functional inversion principle" ++
+ (str "Cannot built inversion information" ++
if do_observe () then Cerrors.explain_exn e else mt ())
with _ -> ()
@@ -297,7 +298,7 @@ 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 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
@@ -318,7 +319,7 @@ let generate_principle on_error
f_R_mut)
in
let fname_kn (fname,_,_,_,_) =
- let f_ref = Ident (dummy_loc,fname) in
+ let f_ref = Ident fname in
locate_with_msg
(pr_reference f_ref++str ": Not an inductive type!")
locate_constant
@@ -351,17 +352,17 @@ let generate_principle on_error
let register_struct is_rec fixpoint_exprl =
match fixpoint_exprl with
- | [(fname,_,bl,ret_type,body),_] when not is_rec ->
+ | [((_,fname),_,bl,ret_type,body),_] when not is_rec ->
Command.declare_definition
fname
- (Decl_kinds.Global,Options.boxed_definitions (),Decl_kinds.Definition)
+ (Decl_kinds.Global,Flags.boxed_definitions (),Decl_kinds.Definition)
bl
None
body
(Some ret_type)
(fun _ _ -> ())
| _ ->
- Command.build_recursive fixpoint_exprl (Options.boxed_definitions())
+ Command.build_recursive 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
@@ -402,7 +403,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
)
)
in
- Topconstr.CApp (dummy_loc,(None,Topconstr.mkIdentC (id_of_string "eq")),
+ Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))),
[(f_app_args,None);(body,None)])
in
let eq = Command.generalize_constr_expr unbounded_eq args in
@@ -434,7 +435,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b
| None ->
begin
match args with
- | [Topconstr.LocalRawAssum ([(_,Name x)],t)] -> t,x
+ | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x
| _ -> error "Recursive argument must be specified"
end
| Some wf_args ->
@@ -442,7 +443,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b
match
List.find
(function
- | Topconstr.LocalRawAssum(l,t) ->
+ | Topconstr.LocalRawAssum(l,k,t) ->
List.exists
(function (_,Name id) -> id = wf_args | _ -> false)
l
@@ -450,7 +451,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b
)
args
with
- | Topconstr.LocalRawAssum(_,t) -> t,wf_args
+ | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args
| _ -> assert false
with Not_found -> assert false
in
@@ -462,7 +463,7 @@ let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type b
let fun_from_mes =
let applied_mes =
Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in
- Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],wf_arg_type,applied_mes)
+ 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])
@@ -475,7 +476,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
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))] ->
+ | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] ->
let pre_hook =
generate_principle
on_error
@@ -488,7 +489,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
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))] ->
+ | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] ->
let pre_hook =
generate_principle
on_error
@@ -503,20 +504,15 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
true
| _ ->
let fix_names =
- List.map (function (name,_,_,_,_) -> name) fixpoint_exprl
+ 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 names =
- List.map
- snd
- (Topconstr.names_of_local_assums args)
- in
let annot =
- try Some (list_index (Name id) names - 1), Topconstr.CStructRec
+ try Some (dummy_loc, id), Topconstr.CStructRec
with Not_found ->
raise (UserError("",str "Cannot find argument " ++
Ppconstr.pr_id id))
@@ -529,7 +525,8 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
(dummy_loc,"Function",
Pp.str "the recursive argument needs to be specified in Function")
else
- (name,(Some 0, Topconstr.CStructRec),args,types,body),
+ let loc, na = List.hd names in
+ (name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body),
(None:Vernacexpr.decl_notation)
| (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_->
error
@@ -539,7 +536,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp
in
(* ok all the expressions are structural *)
let fix_names =
- List.map (function (name,_,_,_,_) -> name) fixpoint_exprl
+ 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;
@@ -570,11 +567,11 @@ let rec add_args id new_args b =
CArrow(loc,add_args id new_args b1, add_args id new_args b2)
| CProdN(loc,nal,b1) ->
CProdN(loc,
- List.map (fun (nal,b2) -> (nal,add_args id new_args b2)) nal,
+ 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,b2) -> (nal,add_args id new_args b2)) nal,
+ 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)
@@ -588,22 +585,22 @@ let rec add_args id new_args b =
| 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,b_option,cel,cal) ->
- CCases(loc,option_map (add_args id new_args) b_option,
+ | 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,
+ (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),
+ 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),
+ (na,Option.map (add_args id new_args) b_option),
add_args id new_args b2,
add_args id new_args b3
)
@@ -644,13 +641,15 @@ let rec chop_n_arrow n t =
let new_n =
let rec aux (n:int) = function
[] -> n
- | (nal,t'')::nal_ta' ->
+ | (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)),t'')::nal_ta',t')
+ let new_t' =
+ Topconstr.CProdN(dummy_loc,
+ ((snd (list_chop n nal)),k,t'')::nal_ta',t')
in
raise (Stop new_t')
in
@@ -668,12 +667,12 @@ let rec get_args b t : Topconstr.local_binder list *
| Topconstr.CLambdaN (loc, (nal_ta), b') ->
begin
let n =
- (List.fold_left (fun n (nal,_) ->
+ (List.fold_left (fun n (nal,_,_) ->
n+List.length nal) 0 nal_ta )
in
let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in
- (List.map (fun (nal,ta) ->
- (Topconstr.LocalRawAssum (nal,ta))) nal_ta)@nal_tas, b'',t''
+ (List.map (fun (nal,k,ta) ->
+ (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t''
end
| _ -> [],b,t
@@ -711,26 +710,13 @@ let make_graph (f_ref:global_reference) =
let l =
List.map
(fun (id,(n,recexp),bl,t,b) ->
- let bl' =
- List.flatten
- (List.map
- (function
- | Topconstr.LocalRawDef (na,_)-> []
- | Topconstr.LocalRawAssum (nal,_) -> nal
- )
- bl
- )
- in
- let rec_id =
- match List.nth bl' (out_some n) with
- |(_,Name id) -> id | _ -> anomaly ""
- in
+ let loc, rec_id = Option.get n in
let new_args =
List.flatten
(List.map
(function
| Topconstr.LocalRawDef (na,_)-> []
- | Topconstr.LocalRawAssum (nal,_) ->
+ | Topconstr.LocalRawAssum (nal,_,_) ->
List.map
(fun (loc,n) ->
CRef(Libnames.Ident(loc, Nameops.out_name n)))
@@ -739,7 +725,7 @@ let make_graph (f_ref:global_reference) =
nal_tas
)
in
- let b' = add_args id new_args b in
+ let b' = add_args (snd id) new_args b in
(id, Some (Struct rec_id),nal_tas@bl,t,b')
)
fixexprl
@@ -747,13 +733,13 @@ let make_graph (f_ref:global_reference) =
l
| _ ->
let id = id_of_label (con_label c) in
- [(id,None,nal_tas,t,b)]
+ [((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)))
+ (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id)))
expr_list
diff --git a/contrib/funind/indfun_common.ml b/contrib/funind/indfun_common.ml
index 13b242d5..4010b49d 100644
--- a/contrib/funind/indfun_common.ml
+++ b/contrib/funind/indfun_common.ml
@@ -76,7 +76,7 @@ let chop_rlambda_n =
then List.rev acc,rt
else
match rt with
- | Rawterm.RLambda(_,name,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
+ | 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",
@@ -90,7 +90,7 @@ let chop_rprod_n =
then List.rev acc,rt
else
match rt with
- | Rawterm.RProd(_,name,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
+ | 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 []
@@ -131,7 +131,7 @@ let coq_constant s =
(Coqlib.init_modules @ Coqlib.arith_modules) s;;
let constant sl s =
- constr_of_reference
+ constr_of_global
(Nametab.locate (make_qualid(Names.make_dirpath
(List.map id_of_string (List.rev sl)))
(id_of_string s)));;
@@ -153,7 +153,7 @@ open Entries
open Decl_kinds
open Declare
let definition_message id =
- Options.if_verbose message ((string_of_id id) ^ " is defined")
+ Flags.if_verbose message ((string_of_id id) ^ " is defined")
let save with_clean id const (locality,kind) hook =
@@ -237,24 +237,29 @@ let with_full_print f a =
let old_implicit_args = Impargs.is_implicit_args ()
and old_strict_implicit_args = Impargs.is_strict_implicit_args ()
and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in
- let old_rawprint = !Options.raw_print in
- Options.raw_print := true;
+ let old_rawprint = !Flags.raw_print in
+ let old_dump = !Flags.dump 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;
+ Flags.dump := false;
try
let res = f a in
Impargs.make_implicit_args old_implicit_args;
Impargs.make_strict_implicit_args old_strict_implicit_args;
Impargs.make_contextual_implicit_args old_contextual_implicit_args;
- Options.raw_print := old_rawprint;
+ Flags.raw_print := old_rawprint;
+ Flags.dump := old_dump;
res
with
| e ->
Impargs.make_implicit_args old_implicit_args;
Impargs.make_strict_implicit_args old_strict_implicit_args;
Impargs.make_contextual_implicit_args old_contextual_implicit_args;
- Options.raw_print := old_rawprint;
+ Flags.raw_print := old_rawprint;
+ Flags.dump := old_dump;
raise e
@@ -319,12 +324,12 @@ let subst_Function (_,subst,finfos) =
in
let function_constant' = do_subst_con finfos.function_constant in
let graph_ind' = do_subst_ind finfos.graph_ind in
- let equation_lemma' = Util.option_smartmap do_subst_con finfos.equation_lemma in
- let correctness_lemma' = Util.option_smartmap do_subst_con finfos.correctness_lemma in
- let completeness_lemma' = Util.option_smartmap do_subst_con finfos.completeness_lemma in
- let rect_lemma' = Util.option_smartmap do_subst_con finfos.rect_lemma in
- let rec_lemma' = Util.option_smartmap do_subst_con finfos.rec_lemma in
- let prop_lemma' = Util.option_smartmap do_subst_con finfos.prop_lemma 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 &&
@@ -354,12 +359,12 @@ let export_Function infos = Some 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' = Util.option_smartmap Lib.discharge_con finfos.equation_lemma
- and correctness_lemma' = Util.option_smartmap Lib.discharge_con finfos.correctness_lemma
- and completeness_lemma' = Util.option_smartmap Lib.discharge_con finfos.completeness_lemma
- and rect_lemma' = Util.option_smartmap Lib.discharge_con finfos.rect_lemma
- and rec_lemma' = Util.option_smartmap Lib.discharge_con finfos.rec_lemma
- and prop_lemma' = Util.option_smartmap Lib.discharge_con finfos.prop_lemma
+ 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 &&
@@ -387,12 +392,12 @@ 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 := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++
- str "completeness_lemma :=" ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++
- str "correctness_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.correctness_lemma (mt ()) ) ++ fnl () ++
- str "rect_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++
- str "rec_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++
- str "prop_lemma := " ++ (Util.option_fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (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 =
diff --git a/contrib/funind/invfun.ml b/contrib/funind/invfun.ml
index c7a3d164..63d44916 100644
--- a/contrib/funind/invfun.ml
+++ b/contrib/funind/invfun.ml
@@ -16,6 +16,7 @@ open Tacticals
open Tactics
open Indfun_common
open Tacmach
+open Termops
open Sign
open Hiddentac
@@ -23,13 +24,13 @@ open Hiddentac
let pr_binding prc =
function
- | loc, Rawterm.NamedHyp id, c -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c)
- | loc, Rawterm.AnonHyp n, c -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c)
+ | loc, 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
+ Util.prlist_with_sep spc (fun (_,c) -> prc c) 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
@@ -59,13 +60,13 @@ let observennl strm =
let do_observe_tac s tac g =
- try let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in
- let v = tac g in msgnl (goal ++ fnl () ++ 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 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 =
@@ -314,7 +315,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
| None -> (id::pre_args,pre_tac)
| Some b ->
(pre_args,
- tclTHEN (h_reduce (Rawterm.Unfold([[],EvalVarRef id])) allHyps) pre_tac
+ tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac
)
else (pre_args,pre_tac)
@@ -425,7 +426,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
List.fold_left2
(fun (bindings,avoid) (x,_,_) p ->
let id = Nameops.next_ident_away (Nameops.out_name x) avoid in
- (dummy_loc,Rawterm.NamedHyp id,p)::bindings,id::avoid
+ (dummy_loc,Rawterm.NamedHyp id,inj_open p)::bindings,id::avoid
)
([],pf_ids_of_hyps g)
princ_infos.params
@@ -435,7 +436,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
List.rev (fst (List.fold_left2
(fun (bindings,avoid) (x,_,_) p ->
let id = Nameops.next_ident_away (Nameops.out_name x) avoid in
- (dummy_loc,Rawterm.NamedHyp id,nf_zeta p)::bindings,id::avoid)
+ (dummy_loc,Rawterm.NamedHyp id,inj_open (nf_zeta p))::bindings,id::avoid)
([],avoid)
princ_infos.predicates
(lemmas)))
@@ -461,14 +462,14 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem
]
g
-(* [generalize_depedent_of x hyp g]
+(* [generalize_dependent_of x hyp g]
generalize every hypothesis which depends of [x] but [hyp]
*)
-let generalize_depedent_of x hyp g =
+let generalize_dependent_of x hyp g =
tclMAP
(function
| (id,None,t) when not (id = hyp) &&
- (Termops.occur_var (pf_env g) x t) -> h_generalize [mkVar id]
+ (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id])
| _ -> tclIDTAC
)
(pf_hyps g)
@@ -490,12 +491,17 @@ and intros_with_rewrite_aux : tactic =
| Prod(_,t,t') ->
begin
match kind_of_term t with
- | App(eq,args) when (eq_constr eq eq_ind) ->
- if isVar args.(1)
+ | 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_depedent_of (destVar args.(1)) id;
+ generalize_dependent_of (destVar args.(1)) id;
tclTRY (Equality.rewriteLR (mkVar id));
intros_with_rewrite
]
@@ -513,7 +519,7 @@ and intros_with_rewrite_aux : tactic =
Tauto.tauto g
| Case(_,_,v,_) ->
tclTHENSEQ[
- h_case (v,Rawterm.NoBindings);
+ h_case false (v,Rawterm.NoBindings);
intros_with_rewrite
] g
| LetIn _ ->
@@ -550,7 +556,7 @@ let rec reflexivity_with_destruct_cases g =
match kind_of_term (snd (destApp (pf_concl g))).(2) with
| Case(_,_,v,_) ->
tclTHENSEQ[
- h_case (v,Rawterm.NoBindings);
+ h_case false (v,Rawterm.NoBindings);
intros;
observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
]
@@ -567,9 +573,9 @@ let rec reflexivity_with_destruct_cases g =
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.discr id g
+ then Equality.discrHyp id g
else if Equality.injectable (pf_env g) (project g) t1 t2
- then tclTHENSEQ [Equality.inj [] id;thin [id];intros_with_rewrite] g
+ then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g
else tclIDTAC g
| _ -> tclIDTAC g
)
@@ -665,8 +671,8 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
if infos.is_general || Rtree.is_infinite graph_def.mind_recargs
then
let eq_lemma =
- try out_some (infos).equation_lemma
- with Failure "out_some" -> anomaly "Cannot find equation lemma"
+ try Option.get (infos).equation_lemma
+ with Option.IsNone -> anomaly "Cannot find equation lemma"
in
tclTHENSEQ[
tclMAP h_intro ids;
@@ -682,7 +688,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
h_generalize (List.map mkVar ids);
thin ids
]
- else unfold_in_concl [([],Names.EvalConstRef (destConst f))]
+ else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))]
in
(* The proof of each branche itself *)
let ind_number = ref 0 in
@@ -706,7 +712,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
(* we expand the definition of the function *)
observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids);
(* introduce hypothesis with some rewrite *)
- (intros_with_rewrite);
+ observe_tac "intros_with_rewrite" intros_with_rewrite;
(* The proof is (almost) complete *)
observe_tac "reflexivity" (reflexivity_with_destruct_cases)
]
@@ -720,7 +726,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
(h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
h_intro graph_principle_id;
observe_tac "" (tclTHEN_i
- (observe_tac "elim" ((elim (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings)))))
+ (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
@@ -769,7 +775,7 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g
Array.of_list
(List.map
(fun entry ->
- (entry.Entries.const_entry_body, out_some entry.Entries.const_entry_type )
+ (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))
)
@@ -960,13 +966,13 @@ let invfun qhyp f =
in
try
let finfos = find_Function_infos f in
- let f_correct = mkConst(out_some finfos.correctness_lemma)
+ 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"
- | Failure "out_some" -> error "Cannot use equivalence with graph!"
+ | Option.IsNone -> error "Cannot use equivalence with graph!"
let invfun qhyp f g =
@@ -983,23 +989,23 @@ let invfun qhyp f g =
try
if not (isConst f1) then failwith "";
let finfos = find_Function_infos (destConst f1) in
- let f_correct = mkConst(out_some finfos.correctness_lemma)
+ 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 "" | Failure "out_some" | Not_found ->
+ 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(out_some finfos.correctness_lemma)
+ 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")
- | Failure "out_some" ->
+ | Option.IsNone ->
if do_observe ()
then
error "Cannot use equivalence with graph for any side of the equality"
diff --git a/contrib/funind/merge.ml b/contrib/funind/merge.ml
index 1b796a81..ec456aae 100644
--- a/contrib/funind/merge.ml
+++ b/contrib/funind/merge.ml
@@ -9,13 +9,16 @@
(* 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
@@ -25,6 +28,8 @@ open Rawtermops
(** {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
@@ -110,6 +115,19 @@ let prNamedLDecl s lc =
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
@@ -193,7 +211,7 @@ type linked_var =
| Funres
(** When merging two graphs, parameters may become regular arguments,
- and thus be shifted. This type describe the result of computing
+ and thus be shifted. This type describes the result of computing
the changes. *)
type 'a shifted_params =
{
@@ -237,39 +255,47 @@ type 'a merged_arg =
| 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 *)
+ 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) *)
+
+ (** 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) *)
+
+ (** Array of links of the second inductive (point to the first ind param/args) *)
lnk2: int merged_arg array;
- (* number of rec params of ind1 which remai rec param in merge *)
- nrecprms1: int;
- (* number of other rec params of ind1 (which become non parm) *)
- notherprms1:int;
- (* number of functional result params of ind2 (which become non parm) *)
- nfunresprms1:int;
- (* list of decl of rec parms from ind1 which remain parms *)
+
+ (** rec params which remain rec param (ie not linked) *)
recprms1: rel_declaration list;
- (* List of other rec parms from ind1 *)
- otherprms1: rel_declaration list; (* parms that became args *)
- funresprms1: rel_declaration list; (* parms that are functional result args *)
- (* number of rec params of ind2 which remain rec param in merge (and not linked) *)
+ recprms2: rel_declaration list;
+ nrecprms1: int;
nrecprms2: int;
- (* number of other params of ind2 (which become non rec parm) *)
+
+ (** 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;
- (* number of functional result params of ind2 (which become non parm) *)
+
+ (** 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;
- (* list of decl of rec parms from ind2 which remain parms (and not linked) *)
- recprms2: rel_declaration list;
- (* List of other rec parms from ind2 (which are linked or become non parm) *)
- otherprms2: rel_declaration list;
- funresprms2: rel_declaration list; (* parms that are functional result args *)
}
@@ -288,7 +314,11 @@ let pr_merginfo x =
let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false
-let isArg_stable x = match x with Arg_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
@@ -346,6 +376,24 @@ let verify_inds mib1 mib2 =
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} *)
@@ -366,6 +414,7 @@ let verify_inds mib1 mib2 =
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
@@ -409,15 +458,29 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in
let bldprms arity_ctxt mlnk =
list_fold_lefti
- (fun i (acc1,acc2,acc3) x ->
+ (fun i (acc1,acc2,acc3,acc4) x ->
+ prstr (pr_merginfo mlnk.(i));prstr "\n";
match mlnk.(i) with
- | Prm_stable _ -> x::acc1 , acc2 , acc3
- | Prm_arg _ | Arg_stable _ -> acc1 , x::acc2 , acc3
- | Arg_funres -> acc1 , acc2 , x::acc3
- | _ -> acc1 , acc2 , acc3) (* Prm_linked and Arg_xxx = forget it *)
- ([],[],[]) arity_ctxt in
- let recprms1,otherprms1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in
- let recprms2,otherprms2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in
+ | 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;
@@ -429,14 +492,18 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
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;
}
@@ -447,45 +514,61 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
exception NoMerge
-(* lnk is an link array of *all* args (from 1 and 2) *)
-let merge_app c1 c2 id1 id2 shift filter_shift_stable =
+let 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
- | _ -> raise NoMerge
-
-let merge_app_unsafe c1 c2 shift filter_shift_stable =
+ | 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)
- | _ -> raise NoMerge
+ (* 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 nrach 1 with all rec calls of branch 2. *)
+ calls of branch 1 with all rec calls of branch 2. *)
(* TODO: reecrire cette heuristique (jusqu'a merge_types) *)
-let onefoud = ref false (* Ugly *)
-
-let rec merge_rec_hyps shift accrec (ltyp:(Names.name * Rawterm.rawconstr) list)
- filter_shift_stable =
+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,(RApp(_,f, largs) as t)) :: lt when isVarf ind2name f ->
- let _ = onefoud := true in
- let rechyps =
- List.map
- (fun (nme,ind) ->
- match ind with
- | RApp(_,i,args) ->
- nme, merge_app_unsafe ind t shift filter_shift_stable
- | _ -> assert false)
- accrec in
+ | (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
@@ -494,50 +577,58 @@ let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift =
List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec
-let find_app (nme:identifier) (ltyp: (name * rawconstr) list) =
+let find_app (nme:identifier) ltyp =
try
ignore
(List.map
(fun x ->
match x with
- | _,(RApp(_,f,_)) when isVarf nme f -> raise (Found 0)
+ | _,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) list)
- concl1 (ltyp2:(name * rawconstr) list) concl2
- : (name * rawconstr) list * rawconstr =
+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,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp1 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,tp) -> prNamedRConstr (string_of_name nm) tp) ltyp2 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 _ = if isrec2 then prstr " ISREC2 TRUE" else prstr " ISREC2 FALSE" in
- let _ = if isrec1 then prstr " ISREC1 TRUE\n" else prstr " ISREC1 FALSE\n" in
let rechyps =
if isrec1 && isrec2
- then merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable
+ 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",concl2])
- filter_shift_stable
+ 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",concl1] ltyp2
+ then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2
filter_shift_stable_right
- else [] in
+ else ltyp2 in
let _ = prstr"\nrechyps : " in
- let _ = List.iter
- (fun (nm,tp) -> prNamedRConstr (string_of_name nm) tp) rechyps 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
@@ -548,15 +639,22 @@ let rec merge_types shift accrec1 (ltyp1:(name * rawconstr) list)
let _ = prstr "FIN " in
let _ = prNamedRConstr "concl" concl in
let _ = prstr "\n" in
+
rechyps , concl
- | (nme,t1)as e ::lt1 ->
- match t1 with
+ | (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,t1) :: recres) , recconcl2
+ ((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
@@ -578,9 +676,9 @@ let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array)
let build_link_map allargs1 allargs2 lnk =
let allargs1 =
- Array.of_list (List.rev (List.map (fun (x,y) -> id_of_name x) allargs1)) in
+ 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,y) -> id_of_name x) allargs2)) in
+ Array.of_list (List.rev (List.map (fun (x,_,_) -> id_of_name x) allargs2)) in
build_link_map_aux allargs1 allargs2 lnk
@@ -598,7 +696,7 @@ let build_link_map allargs1 allargs2 lnk =
forall recparams1 (recparams2 without linked params),
forall ordparams1 (ordparams2 without linked params),
- H1a' -> H2a' -> ... -> H2a' -> H2b' -> ...
+ H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ...
-> (newI x1 ... z1 x2 y2 ...z2 without linked params)
where Hix' have been adapted, ie:
@@ -621,21 +719,27 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr)
shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in
let nargs2 =
shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in
- let allargs1,rest1 = raw_decompose_prod_n nargs1 typcstr1 in
- let allargs2,rest2 = raw_decompose_prod_n nargs2 typcstr2 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 rest1 in
- let hyps2,concl2' = raw_decompose_prod 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 typ = raw_compose_prod concl2 (List.rev ltyp) 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 typwithprms = raw_compose_prod typ (List.rev revargs2 @ List.rev revargs1) 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
@@ -661,22 +765,16 @@ let merge_constructor_id id1 id2 shift:identifier =
constructor [(name*type)]. These are translated to rawterms
first, each of them having distinct var names. *)
let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
- (typcstr1:(identifier * types) list)
- (typcstr2:(identifier * types) list) : (identifier * rawconstr) list =
+ (typcstr1:(identifier * rawconstr) list)
+ (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list =
List.flatten
(List.map
- (fun (id1,typ1) ->
- let typ1 = substitterm 0 (mkRel 1) (mkVar ind1name) typ1 in
- let rawtyp1 = Detyping.detype false (Idset.elements avoid) [] typ1 in
- let idsoftyp1:Idset.t = ids_of_rawterm rawtyp1 in
+ (fun (id1,rawtyp1) ->
List.map
- (fun (id2,typ2) ->
- let typ2 = substitterm 0 (mkRel 1) (mkVar ind2name) typ2 in
- (* Avoid also rawtyp1 names *)
- let avoid2 = Idset.union avoid idsoftyp1 in
- let rawtyp2 = Detyping.detype false (Idset.elements avoid2) [] typ2 in
+ (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)
@@ -685,22 +783,33 @@ let rec merge_constructors (shift:merge_infos) (avoid:Idset.t)
inductive bodies [oib1] and [oib2], linking with [lnk], params
info in [shift], avoiding identifiers in [avoid]. *)
let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
- (oib2:one_inductive_body) : (identifier * rawconstr) list =
- let lcstr1 = Array.to_list oib1.mind_user_lc in
- let lcstr2 = Array.to_list oib2.mind_user_lc in
+ (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();
- merge_constructors shift avoid lcstr1 lcstr2
+ params1,params2,merge_constructors shift avoid3 lcstr1 lcstr2
-(** [build_raw_params prms_decl avoid] returns a list of variables
- attributed to the list of decl [prms_decl], avoiding names in
- [avoid]. *)
-let build_raw_params prms_decl avoid =
- let dummy_constr = compose_prod prms_decl mkProp in
- let dummy_rawconstr = Detyping.detype false avoid [] dummy_constr in
- let res,_ = raw_decompose_prod dummy_rawconstr in
- res , (avoid @ (Idset.elements (ids_of_rawterm dummy_rawconstr)))
(** [merge_mutual_inductive_body lnk mib1 mib2 shift] merge mutual
inductive bodies [mib1] and [mib2] linking vars with
@@ -708,42 +817,35 @@ let build_raw_params prms_decl avoid =
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) =
+ (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) =
(* Mutual not treated, we take first ind body of each. *)
- let nprms1 = mib1.mind_nparams_rec in (* n# of rec uniform parms of mib1 *)
- let prms1 = (* rec uniform parms of mib1 *)
- List.map (fun (x,_,y) -> x,y) (fst (list_chop nprms1 mib1.mind_params_ctxt)) in
-
- (* useless: *)
- let prms1_named,avoid' = build_raw_params prms1 [] in
- let prms2_named,avoid = build_raw_params prms1 avoid' in
- let avoid:Idset.t = List.fold_right Idset.add avoid Idset.empty in
- (* *** *)
-
- merge_inductive_body shift avoid mib1.mind_packets.(0) mib2.mind_packets.(0)
+ 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 params1 params2 shift (concl:constr) =
- let params = shift.recprms1 @ shift.recprms2 in
- let resparams, _ =
+let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
+ let params = prms2 @ prms1 in
+ let resparams =
List.fold_left
- (fun (acc,env) (nme,_,tp) ->
- let typ = Constrextern.extern_constr false env tp in
- let newenv = Environ.push_rel (nme,None,tp) env in
- LocalRawAssum ([(dummy_loc,nme)] , typ) :: acc , newenv)
- ([],Global.env())
- params in
+ (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)],typ] , acc) , newenv)
+ CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv)
(concl,Global.env())
- (shift.otherprms1@shift.otherprms2@shift.funresprms1@shift.funresprms2) in
+ (shift.funresprms2 @ shift.funresprms1
+ @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in
resparams,arity
@@ -752,20 +854,37 @@ let merge_rec_params_and_arity params1 params2 shift (concl:constr) =
induct_expr corresponding to the the list of constructor types
[rawlist], named ident.
FIXME: params et cstr_expr (arity) *)
-let rawterm_list_to_inductive_expr mib1 mib2 shift
+let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
(rawlist:(identifier * rawconstr) list):inductive_expr =
- let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *)
- Options.with_option Options.raw_print (Constrextern.extern_rawtype Idset.empty) x in
let lident = dummy_loc, shift.ident in
let bindlist , cstr_expr = (* params , arities *)
- merge_rec_params_and_arity
- mib1.mind_params_ctxt mib2.mind_params_ctxt shift mkSet in
+ 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 , 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. *)
@@ -777,35 +896,124 @@ let merge_inductive (ind1: inductive) (ind2: inductive)
let _ = verify_inds mib1 mib2 in (* raises an exception if something wrong *)
(* compute params that become ordinary args (because linked to ord. args) *)
let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in
- let rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in
- let indexpr = rawterm_list_to_inductive_expr mib1 mib2 shift_prm rawlist in
+ 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 *)
Command.build_mutual [(indexpr,None)] true (* means: not coinductive *)
-
-let merge (cstr1:constr) (cstr2:constr) (args1:constr array) (args2:constr array) id =
- let env = Global.env() in
- let ind1,_cstrlist1 = Inductiveops.find_inductive env Evd.empty cstr1 in
- let ind2,_cstrlist2 = Inductiveops.find_inductive env Evd.empty cstr2 in
- let lnk1 = (* args1 are unlinked. FIXME? mergescheme (G x x) ?? *)
- Array.mapi (fun i c -> Unlinked) args1 in
- let _ = lnk1.(Array.length lnk1 - 1) <- Funres in (* last arg is functional result *)
- let lnk2 = (* args2 may be linked to args1 members. FIXME: same
- as above: vars may be linked inside args2?? *)
+(* 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 args1 (fun i x -> x=c) with
| Some j -> Linked j
| None -> Unlinked)
args2 in
- let _ = lnk2.(Array.length lnk2 - 1) <- Funres in (* last arg is functional result *)
- let resa = merge_inductive ind1 ind2 lnk1 lnk2 id in
- resa
-
-
-
+ (* 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",
diff --git a/contrib/funind/rawterm_to_relation.ml b/contrib/funind/rawterm_to_relation.ml
index b34a1097..08a97fd2 100644
--- a/contrib/funind/rawterm_to_relation.ml
+++ b/contrib/funind/rawterm_to_relation.ml
@@ -368,7 +368,7 @@ let raw_push_named (na,raw_value,raw_typ) env =
match na with
| Anonymous -> env
| Name id ->
- let value = Util.option_map (Pretyping.Default.understand Evd.empty env) raw_value in
+ 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
@@ -398,12 +398,12 @@ let add_pat_variables pat typ env : Environ.env =
| Anonymous -> assert false
| Name id ->
let new_t = substl ctxt t in
- let new_v = option_map (substl ctxt) v 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 ())
+ 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)
)
@@ -446,7 +446,7 @@ let rec pattern_to_term_and_type env typ = function
let patl_as_term =
List.map2 (pattern_to_term_and_type env) (List.rev cs_args_types) patternl
in
- mkRApp(mkRRef(Libnames.ConstructRef constr),
+ mkRApp(mkRRef(ConstructRef constr),
implicit_args@patl_as_term
)
@@ -586,7 +586,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
| RProd _ -> error "Cannot apply a type"
end (* end of the application treatement *)
- | RLambda(_,n,t,b) ->
+ | 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
@@ -601,7 +601,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
let new_env = raw_push_named (new_n,None,t) env in
let b_res = build_entry_lc new_env funnames avoid b in
combine_results (combine_lam new_n) t_res b_res
- | RProd(_,n,t,b) ->
+ | 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
@@ -627,7 +627,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
in
let b_res = build_entry_lc new_env funnames avoid b in
combine_results (combine_letin n) v_res b_res
- | RCases(_,_,el,brl) ->
+ | RCases(_,_,_,el,brl) ->
(* we create the discrimination function
and treat the case itself
*)
@@ -689,7 +689,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return =
build_entry_lc env funnames avoid b
| RDynamic _ -> error "Not handled RDynamic"
and build_entry_lc_from_case env funname make_discr
- (el:tomatch_tuple)
+ (el:tomatch_tuples)
(brl:Rawterm.cases_clauses) avoid :
rawconstr build_entry_return =
match el with
@@ -865,7 +865,7 @@ let is_res id =
*)
let rec rebuild_cons nb_args relname args crossed_types depth rt =
match rt with
- | RProd(_,n,t,b) ->
+ | 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
@@ -928,7 +928,7 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt =
(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,t,b) ->
+ | 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
@@ -944,7 +944,7 @@ let rec rebuild_cons nb_args relname args crossed_types depth rt =
then
new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude)
else
- RProd(dummy_loc,n,t,new_b),Idset.filter not_free_in_t id_to_exclude
+ 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 *)
@@ -1016,11 +1016,12 @@ let rec compute_cst_params relnames params = function
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) ->
+ | 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 *)
+ | RCases _ ->
+ params (* If there is still cases at this point they can only be
+ discriminitation ones *)
| RSort _ -> params
| RHole _ -> params
| RIf _ | RRec _ | RCast _ | RDynamic _ ->
@@ -1153,7 +1154,7 @@ let do_build_inductive
else
Topconstr.CProdN
(dummy_loc,
- [[(dummy_loc,n)],Constrextern.extern_rawconstr Idset.empty t],
+ [[(dummy_loc,n)],Topconstr.default_binder_kind,Constrextern.extern_rawconstr Idset.empty t],
acc
)
)
@@ -1173,7 +1174,7 @@ let do_build_inductive
Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t)
else
Topconstr.LocalRawAssum
- ([(dummy_loc,n)], Constrextern.extern_rawconstr Idset.empty t)
+ ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t)
)
rels_params
in
@@ -1181,8 +1182,8 @@ let do_build_inductive
Array.map (List.map
(fun (id,t) ->
false,((dummy_loc,id),
- Options.with_option
- Options.raw_print
+ Flags.with_option
+ Flags.raw_print
(Constrextern.extern_rawtype Idset.empty) ((* zeta_normalize *) t)
)
))
@@ -1218,7 +1219,7 @@ let do_build_inductive
(* in *)
let _time2 = System.get_time () in
try
- with_full_print (Options.silently (Command.build_mutual rel_inds)) true
+ with_full_print (Flags.silently (Command.build_mutual rel_inds)) true
with
| UserError(s,msg) as e ->
let _time3 = System.get_time () in
diff --git a/contrib/funind/rawtermops.ml b/contrib/funind/rawtermops.ml
index 113ddd8b..92396af5 100644
--- a/contrib/funind/rawtermops.ml
+++ b/contrib/funind/rawtermops.ml
@@ -12,10 +12,10 @@ let idmap_is_empty m = m = Idmap.empty
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,t,b)
-let mkRProd(n,t,b) = RProd(dummy_loc,n,t,b)
+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,rto,l,brl)
+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))
@@ -26,27 +26,59 @@ let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t))
*)
let raw_decompose_prod =
let rec raw_decompose_prod args = function
- | RProd(_,n,t,b) ->
+ | 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) ->
+ | 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); *)
@@ -103,15 +135,17 @@ let change_vars =
change_vars mapping rt',
List.map (change_vars mapping) rtl
)
- | RLambda(loc,name,t,b) ->
+ | 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,t,b) ->
+ | RProd(loc,name,k,t,b) ->
RProd(loc,
name,
+ k,
change_vars mapping t,
change_vars (remove_name_from_mapping mapping name) b
)
@@ -125,12 +159,12 @@ let change_vars =
let new_mapping = List.fold_left remove_name_from_mapping mapping nal in
RLetTuple(loc,
nal,
- (na, option_map (change_vars mapping) rto),
+ (na, Option.map (change_vars mapping) rto),
change_vars mapping b,
change_vars new_mapping e
)
- | RCases(loc,infos,el,brl) ->
- RCases(loc,
+ | 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
@@ -138,7 +172,7 @@ let change_vars =
| RIf(loc,b,(na,e_option),lhs,rhs) ->
RIf(loc,
change_vars mapping b,
- (na,option_map (change_vars mapping) e_option),
+ (na,Option.map (change_vars mapping) e_option),
change_vars mapping lhs,
change_vars mapping rhs
)
@@ -229,21 +263,21 @@ let rec alpha_rt excluded rt =
let new_rt =
match rt with
| RRef _ | RVar _ | REvar _ | RPatVar _ -> rt
- | RLambda(loc,Anonymous,t,b) ->
+ | RLambda(loc,Anonymous,k,t,b) ->
let new_id = Nameops.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,new_t,new_b)
- | RProd(loc,Anonymous,t,b) ->
+ 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,new_t,new_b)
+ 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,t,b) ->
+ | RLambda(loc,Name id,k,t,b) ->
let new_id = Nameops.next_ident_away id excluded in
let t,b =
if new_id = id
@@ -255,8 +289,8 @@ let rec alpha_rt excluded rt =
let new_excluded = new_id::excluded in
let new_t = alpha_rt new_excluded t in
let new_b = alpha_rt new_excluded b in
- RLambda(loc,Name new_id,new_t,new_b)
- | RProd(loc,Name id,t,b) ->
+ RLambda(loc,Name new_id,k,new_t,new_b)
+ | RProd(loc,Name id,k,t,b) ->
let new_id = Nameops.next_ident_away id excluded in
let new_excluded = new_id::excluded in
let t,b =
@@ -268,7 +302,7 @@ let rec alpha_rt excluded rt =
in
let new_t = alpha_rt new_excluded t in
let new_b = alpha_rt new_excluded b in
- RProd(loc,Name new_id,new_t,new_b)
+ RProd(loc,Name new_id,k,new_t,new_b)
| RLetIn(loc,Name id,t,b) ->
let new_id = Nameops.next_ident_away id excluded in
let t,b =
@@ -306,20 +340,20 @@ let rec alpha_rt excluded rt =
if idmap_is_empty mapping
then rto,t,b
else let replace = change_vars mapping in
- (option_map replace rto, t,replace b)
+ (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
+ 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,infos,el,brl) ->
+ | RCases(loc,sty,infos,el,brl) ->
let new_el =
List.map (function (rt,i) -> alpha_rt excluded rt, i) el
in
- RCases(loc,infos,new_el,List.map (alpha_br excluded) brl)
+ 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),
+ (na,Option.map (alpha_rt excluded) e_o),
alpha_rt excluded lhs,
alpha_rt excluded rhs
)
@@ -357,17 +391,16 @@ let is_free_in id =
| 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) ->
+ | 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) ->
+ | 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)
@@ -428,17 +461,19 @@ let replace_var_by_term x_id term =
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,t,b) ->
+ | 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,t,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
)
@@ -455,19 +490,19 @@ let replace_var_by_term x_id term =
| RLetTuple(loc,nal,(na,rto),def,b) ->
RLetTuple(loc,
nal,
- (na,option_map replace_var_by_pattern rto),
+ (na,Option.map replace_var_by_pattern rto),
replace_var_by_pattern def,
replace_var_by_pattern b
)
- | RCases(loc,infos,el,brl) ->
- RCases(loc,
+ | 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),
+ (na,Option.map replace_var_by_pattern e_option),
replace_var_by_pattern lhs,
replace_var_by_pattern rhs
)
@@ -558,15 +593,15 @@ let ids_of_rawterm c =
| RVar (_,id) -> id::acc
| RApp (loc,g,args) ->
ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc
- | RLambda (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
- | RProd (loc,na,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc
+ | 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,rtntypopt,tml,brchl) ->
+ | 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 _) -> []
@@ -590,15 +625,17 @@ let zeta_normalize =
zeta_normalize_term rt',
List.map zeta_normalize_term rtl
)
- | RLambda(loc,name,t,b) ->
+ | RLambda(loc,name,k,t,b) ->
RLambda(loc,
name,
+ k,
zeta_normalize_term t,
zeta_normalize_term b
)
- | RProd(loc,name,t,b) ->
+ | RProd(loc,name,k,t,b) ->
RProd(loc,
- name,
+ name,
+ k,
zeta_normalize_term t,
zeta_normalize_term b
)
@@ -608,19 +645,19 @@ let zeta_normalize =
| RLetTuple(loc,nal,(na,rto),def,b) ->
RLetTuple(loc,
nal,
- (na,option_map zeta_normalize_term rto),
+ (na,Option.map zeta_normalize_term rto),
zeta_normalize_term def,
zeta_normalize_term b
)
- | RCases(loc,infos,el,brl) ->
- RCases(loc,
+ | 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),
+ (na,Option.map zeta_normalize_term e_option),
zeta_normalize_term lhs,
zeta_normalize_term rhs
)
@@ -659,24 +696,23 @@ let expand_as =
with Not_found -> rt
end
| RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args)
- | RLambda(loc,na,t,b) -> RLambda(loc,na,expand_as map t, expand_as map b)
- | RProd(loc,na,t,b) -> RProd(loc,na,expand_as map t, expand_as map b)
+ | 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),
+ 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),
+ 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,po,el,brl) ->
- RCases(loc, option_map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el,
+ | 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)
+ (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt)
in
expand_as Idmap.empty
diff --git a/contrib/funind/rawtermops.mli b/contrib/funind/rawtermops.mli
index 9647640c..358c6ba6 100644
--- a/contrib/funind/rawtermops.mli
+++ b/contrib/funind/rawtermops.mli
@@ -22,7 +22,7 @@ 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_tuple * cases_clauses -> 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
@@ -31,8 +31,14 @@ val mkRCast : rawconstr* rawconstr -> rawconstr
These are analogous to the ones constrs
*)
val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr
+val raw_decompose_prod_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)
diff --git a/contrib/recdef/recdef.ml4 b/contrib/funind/recdef.ml
index 40832677..c9bf2f1f 100644
--- a/contrib/recdef/recdef.ml4
+++ b/contrib/funind/recdef.ml
@@ -8,6 +8,8 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
+(* $Id: recdef.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
+
open Term
open Termops
open Environ
@@ -25,6 +27,7 @@ open Typing
open Tacmach
open Tactics
open Nametab
+open Decls
open Declare
open Decl_kinds
open Tacred
@@ -67,7 +70,8 @@ let h_intros l =
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 s)++(str " ")++(str "finished")); v
+ 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 );
@@ -106,7 +110,7 @@ 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 Options.is_verbose () then msgnl(str s);;
+let message s = if Flags.is_verbose () then msgnl(str s);;
let def_of_const t =
match (kind_of_term t) with
@@ -146,9 +150,9 @@ let rank_for_arg_list h =
| x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in
rank_aux 0;;
-let rec (find_call_occs:
- constr -> constr -> (constr list ->constr)*(constr list list)) =
- fun f expr ->
+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]
@@ -159,7 +163,7 @@ let rec (find_call_occs:
| a::upper_tl ->
(match find_aux upper_tl with
(cf, ((arg1::args) as args_for_upper_tl)) ->
- (match find_call_occs f a with
+ (match find_call_occs nb_lam f a with
cf2, (_ :: _ as other_args) ->
let rec avoid_duplicates args =
match args with
@@ -183,7 +187,7 @@ let rec (find_call_occs:
other_args'@args_for_upper_tl
| _, [] -> (fun x -> a::cf x), args_for_upper_tl)
| _, [] ->
- (match find_call_occs f a with
+ (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
@@ -192,33 +196,48 @@ let rec (find_call_occs:
| cf, args ->
(fun l -> mkApp (g, Array.of_list (cf l))), args
end
- | Rel(_) -> error "find_call_occs : Rel"
+ | 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(_) -> error "find_call_occs : Sort"
- | Cast(b,_,_) -> find_call_occs f b
+ | Sort(_) -> (fun l -> expr), []
+ | Cast(b,_,_) -> find_call_occs nb_lam f b
| Prod(_,_,_) -> error "find_call_occs : Prod"
- | Lambda(_,_,_) -> error "find_call_occs : Lambda"
- | LetIn(_,_,_,_) -> error "find_call_occs : let in"
+ | 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 f a with
+ (match find_call_occs nb_lam f a with
cf, (arg1::args) -> (fun l -> mkCase(i, t, (cf l), r)),(arg1::args)
- | _ -> (fun l -> mkCase(i, t, a, r)),[])
+ | _ -> (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 constant sl s =
- constr_of_reference
+ constr_of_global
(locate (make_qualid(Names.make_dirpath
(List.map id_of_string (List.rev sl)))
(id_of_string s)));;
@@ -257,8 +276,8 @@ 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_reference (delayed_force iter_ref))
-let max_constr = function () -> (constr_of_reference (delayed_force max_ref))
+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"
@@ -268,44 +287,61 @@ let coq_conj = function () -> find_reference ["Coq";"Init";"Logic"] "conj"
let nat = function () -> (coq_constant "nat")
let lt = function () -> (coq_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 ->
- (* commentaire de Yves: on pourra avoir des problemes si
- a n'est pas bien type dans l'environnement du but *)
let type_of_a = pf_type_of g a in
- (tclTHEN (generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])])
- (tclTHEN
- (fun g2 ->
- change_in_concl None
- (pattern_occs [([2], a)] (pf_env g2) Evd.empty (pf_concl g2))
- g2)
- (simplest_case a))) g);;
-
-let rec mk_intros_and_continue (extra_eqn:bool)
- cont_function (eqs:constr list) (expr:constr) g =
- 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 extra_eqn cont_function eqs
- (subst1 (mkVar new_n) b)) g
- | _ ->
- if extra_eqn then
+ 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 =
+ 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 teq eq))
+ (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences 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 = destApp ty_teq in
+ 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
@@ -313,22 +349,44 @@ let rec mk_intros_and_continue (extra_eqn:bool)
]
g
else
- cont_function eqs expr g
-
+ tclTHENSEQ[
+ thin thin_intros;
+ h_intros thin_intros;
+ cont_function eqs expr
+ ] g
+ 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)) g
+ | _ ->
+ assert false
+(* finalize () *)
let const_of_ref = function
ConstRef kn -> kn
| _ -> anomaly "ConstRef expected"
-let simpl_iter () =
+let simpl_iter clause =
reduce
- (Lazy
+ (Lazy
{rBeta=true;rIota=true;rZeta= true; rDelta=false;
rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
- onConcl
+(* (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 is_mes l g =
+let tclUSER tac is_mes l g =
let clear_tac =
match l with
| None -> h_clear true []
@@ -338,8 +396,11 @@ let tclUSER is_mes l g =
[
clear_tac;
if is_mes
- then unfold_in_concl [([], evaluable_of_global_reference (delayed_force ltof_ref))]
- else tclIDTAC
+ then tclTHEN
+ (unfold_in_concl [(all_occurrences, evaluable_of_global_reference
+ (delayed_force ltof_ref))])
+ tac
+ else tac
]
g
@@ -358,22 +419,22 @@ let base_leaf_terminate (func:global_reference) eqs expr =
[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();
- unfold_constr func;
- list_rewrite true eqs;
- default_auto ] g);;
+ 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 ...
@@ -402,8 +463,7 @@ let rec compute_le_proofs = function
apply_with_bindings
(le_trans,
ExplicitBindings[dummy_loc,NamedHyp m_id,a])
- g
- )
+ g)
[compute_le_proofs tl;
tclORELSE (apply (delayed_force le_n)) assumption])
@@ -436,10 +496,10 @@ let rec list_cond_rewrite k def pmax cond_eqs le_proofs =
Nameops.out_name k_na,Nameops.out_name def_na
in
tclTHENS
- (general_rewrite_bindings false
+ (general_rewrite_bindings false all_occurrences
(mkVar eq,
ExplicitBindings[dummy_loc, NamedHyp k_id, mkVar k;
- dummy_loc, NamedHyp def_id, mkVar def]))
+ 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
)
@@ -469,12 +529,12 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs
];
observe_tac "clearing k " (clear [k]);
observe_tac "intros k h' def" (h_intros [k;h';def]);
- observe_tac "simple_iter" (simpl_iter());
+ observe_tac "simple_iter" (simpl_iter onConcl);
observe_tac "unfold functional"
- (unfold_in_concl[([1],evaluable_of_global_reference func)]);
+ (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]);
observe_tac "rewriting equations"
(list_rewrite true eqs);
- observe_tac "cond rewrite" (list_cond_rewrite k def bound cond_eqs le_proofs);
+ 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 ->
@@ -498,7 +558,7 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs
(mkVar pmax) ((mkVar pmax)::le_proofs)
(heq::cond_eqs)] g;;
-let string_match s =
+let string_match s =
if String.length s < 3 then failwith "string_match";
try
for i = 0 to 3 do
@@ -513,7 +573,7 @@ let retrieve_acc_var g =
(fun id -> string_match (string_of_id id);id)
hyps
-let rec introduce_all_values is_mes acc_inv func context_fn
+let rec introduce_all_values concl_tac is_mes acc_inv func context_fn
eqs hrec args values specs =
(match args with
[] ->
@@ -530,16 +590,19 @@ let rec introduce_all_values is_mes acc_inv func context_fn
let hspec = next_global_ident_away true hspec_id ids in
let tac =
observe_tac "introduce_all_values" (
- introduce_all_values is_mes acc_inv func context_fn eqs
+ 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))))
+ (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)))
- [ observe_tac "h_assumption" h_assumption
+ [(* tclTHEN (tclTRY(list_rewrite true eqs)) *)
+ (observe_tac "h_assumption" h_assumption)
;
tclTHENLIST
[
@@ -547,6 +610,7 @@ let rec introduce_all_values is_mes acc_inv func context_fn
observe_tac "user proof"
(fun g ->
tclUSER
+ concl_tac
is_mes
(Some (hrec::hspec::(retrieve_acc_var g)@specs))
g
@@ -559,70 +623,61 @@ let rec introduce_all_values is_mes acc_inv func context_fn
)
-let rec_leaf_terminate is_mes acc_inv hrec (func:global_reference) eqs expr =
- match find_call_occs (mkVar (get_f (constr_of_reference func))) expr with
+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 is_mes acc_inv func context_fn eqs hrec args [] [])
+ (introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] [])
-let proveterminate is_mes acc_inv (hrec:identifier)
+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 (_, t, a, l) ->
- (match find_call_occs f_constr a with
- _,[] ->
- tclTHENS
- (fun g ->
- (* let _ = msgnl(str "entering mkCaseEq") in *)
- let v = (mkCaseEq a) g in
- (* let _ = msgnl (str "exiting mkCaseEq") in *)
- v
- )
- (List.map
- (mk_intros_and_continue true proveterminate eqs)
- (Array.to_list l)
- )
- | _, _::_ ->
- (
- match find_call_occs 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 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
- (* let _ = msgnl(str "exiting proveterminate") in *)
+ 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
+ with e -> begin msgerrnl(str "failure in proveterminate"); raise e end
in
proveterminate
-let hyp_terminates func =
- let a_arrow_b = arg_type (constr_of_reference func) in
- let rev_args,b = decompose_prod a_arrow_b in
+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_reference func::mkRel 1::
+ constr_of_global func::mkRel 1::
List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args)
)
)
@@ -647,11 +702,10 @@ let hyp_terminates func =
-let tclUSER_if_not_mes is_mes names_to_suppress =
+let tclUSER_if_not_mes concl_tac is_mes names_to_suppress =
if is_mes
- then
- tclCOMPLETE (h_apply (delayed_force well_founded_ltof,Rawterm.NoBindings))
- else tclUSER is_mes names_to_suppress
+ 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 =
@@ -710,8 +764,7 @@ let termination_proof_header is_mes input_type ids args_id relation
(* this gives the accessibility argument *)
observe_tac
"apply wf_thm"
- (h_apply ((mkApp(mkVar wf_thm,
- [|mkVar rec_arg_id |])),Rawterm.NoBindings)
+ (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))
)
]
;
@@ -720,13 +773,13 @@ let termination_proof_header is_mes input_type ids args_id relation
[observe_tac "generalize"
(onNLastHyps (nargs+1)
(fun (id,_,_) ->
- tclTHEN (generalize [mkVar id]) (h_clear false [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 hrec acc_inv)
+ observe_tac "tac" (tac wf_rec_arg hrec acc_inv)
]
]
) g
@@ -743,18 +796,18 @@ let rec instantiate_lambda t l =
;;
-let whole_start is_mes func input_type relation rec_arg_num : tactic =
+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_reference func)) 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_global_ident_away true f_id ids
| Anonymous -> anomaly "Anonymous function"
in
- let n_names_types,_ = decompose_lam body1 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,_) ->
@@ -777,30 +830,29 @@ let whole_start is_mes func input_type relation rec_arg_num : tactic =
relation
rec_arg_num
rec_arg_id
- (fun hrec acc_inv g ->
+ (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
+ (rec_leaf_terminate (mkVar f_id) concl_tac)
[]
expr
)
g
)
- tclUSER_if_not_mes
+ (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 )
-
+ List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs )
let build_and_l l =
let and_constr = Coqlib.build_coq_and () in
@@ -814,7 +866,7 @@ let build_and_l l =
let c,tac,nb = f pl in
mk_and p1 c,
tclTHENS
- (apply (constr_of_reference conj_constr))
+ (apply (constr_of_global conj_constr))
[tclIDTAC;
tac
],nb+1
@@ -849,23 +901,24 @@ let build_new_goal_type () =
res
-
+ (*
let prove_with_tcc lemma _ : tactic =
fun gls ->
let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in
tclTHENSEQ
[
- generalize [lemma];
+ h_generalize [lemma];
h_intro hid;
Elim.h_decompose_and (mkVar hid);
gen_eauto(* default_eauto *) false (false,5) [] (Some [])
(* default_auto *)
]
gls
+ *)
-let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal) =
+let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) =
let current_proof_name = get_current_proof_name () in
let name = match goal_name with
| Some s -> s
@@ -879,14 +932,58 @@ let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal
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
- Array.iteri
- (fun i _ ->
- by (observe_tac ("reusing lemma "^(string_of_id na)) (prove_with_tcc lemma i)))
- (Array.make nb_goal ())
- ;
- ref := Some lemma ;
- defined ();
+ 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_global_ident_away true 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];
+(* list_iter_i *)
+(* (fun i v -> *)
+(* msgnl (str "hyp" ++ int i ++ str " " ++ *)
+(* Nameops.pr_id v ++ fnl () ++ fnl())) *)
+(* !lid; *)
+ 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;
+ tclTHEN
+ (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))
+ e_assumption
+ g)
+;
+ Command.save_named opacity;
in
start_proof
na
@@ -904,7 +1001,7 @@ let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal
(fun c ->
tclTHENSEQ
[intros;
- h_apply (interp_constr Evd.empty (Global.env()) c,Rawterm.NoBindings);
+ h_simplest_apply (interp_constr Evd.empty (Global.env()) c);
tclCOMPLETE Auto.default_auto
]
)
@@ -913,11 +1010,13 @@ let open_new_goal using_lemmas ref goal_name (gls_type,decompose_and_tac,nb_goal
g);
try
by tclIDTAC; (* raises UserError _ if the proof is complete *)
- if Options.is_verbose () then (pp (Printer.pr_open_subgoals()))
+ if Flags.is_verbose () then (pp (Printer.pr_open_subgoals()))
with UserError _ ->
defined ()
-
+;;
+
+
let com_terminate
tcc_lemma_name
tcc_lemma_ref
@@ -926,21 +1025,29 @@ let com_terminate
input_type
relation
rec_arg_num
- thm_name using_lemmas hook =
- let (evmap, env) = Command.get_current_context() in
- start_proof thm_name
- (Global, Proof Lemma) (Environ.named_context_val env)
- (hyp_terminates fonctional_ref) hook;
- by (observe_tac "whole_start" (whole_start 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) = Command.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 using_lemmas tcc_lemma_ref
+ 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 ()
+
@@ -964,7 +1071,7 @@ let (value_f:constr list -> global_reference -> constr) =
in
let fun_body =
RCases
- (d0,None,
+ (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
@@ -978,7 +1085,7 @@ let (value_f:constr list -> global_reference -> constr) =
List.fold_left2
(fun acc x_id a ->
RLambda
- (d0, Name x_id, RDynamic(d0, constr_in a),
+ (d0, Name x_id, Explicit, RDynamic(d0, constr_in a),
acc
)
)
@@ -1000,27 +1107,24 @@ let (declare_f : identifier -> logical_kind -> constr list -> 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_global_ident_away true 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_reference term_f in
+ let terminate_constr = constr_of_global term_f in
let nargs = nb_prod (type_of_const terminate_constr) in
- let x =
- let rec f ids n =
- if n = 0
- then []
- else
- let x = next_global_ident_away true x_id ids in
- x::f (x::ids) (n-1)
- in
- f ids nargs
- in
+ let x = n_x_id ids nargs in
tclTHENLIST [
h_intros x;
- observe_tac "unfold_constr f" (unfold_constr f);
- observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x))));
- observe_tac "prove_eq" (cont_tactic x)] g
-;;
+ 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
@@ -1039,37 +1143,40 @@ let base_leaf_eq func eqs f_id g =
(mkApp(mkVar heq1,
[|mkApp (delayed_force coq_S, [|mkVar p|]);
mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|])));
- simpl_iter();
- unfold_in_concl [([1], evaluable_of_global_reference func)];
+ simpl_iter onConcl;
+ tclTRY (unfold_in_concl [((true,[1]), evaluable_of_global_reference func)]);
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
+
+let rec introduce_all_values_eq cont_tac functional termine
f p heq1 pmax bounds le_proofs eqs ids =
function
[] ->
+ let heq2 = next_global_ident_away true heq_id ids in
tclTHENLIST
- [tclTHENS
+ [forward None (IntroIdentifier 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))]
+ ((all_occurrences_expr, heq2), Tacexpr.InHyp);
+ tclTHENS
(fun gls ->
- let t_eq = compute_renamed_type gls (mkVar heq1) 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
+ 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
- general_rewrite_bindings false
- (mkVar heq1,
- ExplicitBindings[dummy_loc,NamedHyp k_id,
- f_S(f_S(mkVar pmax));
- dummy_loc,NamedHyp def_id,
- f]) gls )
+ observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences
+ (mkVar heq2,
+ ExplicitBindings[dummy_loc,NamedHyp def_id,
+ f]) false) gls)
[tclTHENLIST
- [simpl_iter();
- unfold_constr (reference_of_constr functional);
- list_rewrite true eqs; cont_tac pmax le_proofs];
+ [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 ->
@@ -1102,8 +1209,9 @@ let rec introduce_all_values_eq cont_tac functional termine
tclTHENLIST
[cont_tac pmax' le_proofs';
h_intros [heq;heq2];
- rewriteLR (mkVar heq2);
- tclTHENS
+ 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 =
@@ -1112,18 +1220,20 @@ let rec introduce_all_values_eq cont_tac functional termine
let def_na,_,_ = destProd t in
Nameops.out_name k_na,Nameops.out_name def_na
in
- general_rewrite_bindings false
- (mkVar heq,
+ let c_b = (mkVar heq,
ExplicitBindings
[dummy_loc, NamedHyp k_id,
f_S(mkVar pmax');
- dummy_loc, NamedHyp def_id, f])
- g
+ dummy_loc, NamedHyp def_id, f])
+ in
+ observe_tac "general_rewrite_bindings" ( (general_rewrite_bindings false all_occurrences
+ c_b false))
+ g
)
[tclIDTAC;
tclTHENLIST
[apply (delayed_force le_lt_n_Sm);
- compute_le_proofs le_proofs']]])
+ 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]
@@ -1141,84 +1251,95 @@ let rec_leaf_eq termine f ids functional eqs expr fn args =
let hle1 = next_global_ident_away true hle_id ids in
let ids = hle1::ids in
tclTHENLIST
- [h_intros [v;hex];
+ [observe_tac "intros v hex" (h_intros [v;hex]);
simplest_elim (mkVar hex);
h_intros [p;heq1];
- generalize [mkApp(delayed_force le_n,[|mkVar p|])];
+ h_generalize [mkApp(delayed_force le_n,[|mkVar p|])];
h_intros [hle1];
- introduce_all_values_eq
+ observe_tac "introduce_all_values_eq" (introduce_all_values_eq
(fun _ _ -> tclIDTAC)
- functional termine f p heq1 p [] [] eqs ids args;
- apply (delayed_force refl_equal)]
+ 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
- (match kind_of_term expr with
- Case(_,t,a,l) ->
- (match find_call_occs f a with
- _,[] ->
- tclTHENS(mkCaseEq a)(* (simplest_case a) *)
- (List.map
- (fun expr -> observe_tac "mk_intros_and_continue" (mk_intros_and_continue true
- (prove_eq termine f functional) eqs expr))
- (Array.to_list l))
+ (eqs:constr list) (expr:constr) =
+(* tclTRY *)
+ (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 f expr with
- _,[] -> base_leaf_eq functional eqs f
- | fn,args ->
- fun g ->
- let ids = ids_of_named_context (pf_hyps g) in
- rec_leaf_eq termine f ids
- (constr_of_reference functional)
- eqs expr fn args g))
+ (match find_call_occs 0 f expr with
+ _,[] -> base_leaf_eq functional eqs f
+ | fn,args ->
+ fun g ->
+ let ids = ids_of_named_context (pf_hyps g) in
+ rec_leaf_eq termine f ids
+ (constr_of_global functional)
+ eqs expr fn args g))
| _ ->
- (match find_call_occs f expr with
+ (match find_call_occs 0 f expr with
_,[] -> 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_reference functional)
+ 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) = Command.get_current_context() in
- let f_constr = (constr_of_reference f_ref) 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 ->
+ (fun x ->
prove_eq
- (constr_of_reference terminate_ref)
+ (constr_of_global terminate_ref)
f_constr
functional_ref
[]
(instantiate_lambda
- (def_of_const (constr_of_reference functional_ref))
+ (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);
-*)
- Options.silently defined ();
+(* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *)
+(* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *)
+ Flags.silently (fun () ->Command.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 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
@@ -1232,7 +1353,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
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' := " ++ Printer.pr_lconstr_env env eq' ++ fnl () ++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))
@@ -1259,31 +1380,33 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
let term_ref = Nametab.locate (make_short_qualid term_id) in
let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
(* message "start second proof"; *)
- let continue = ref true in
+ 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 (Pp.msgnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e); continue := false)
- else (ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
- anomaly "Cannot create equation Lemma")
+ 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 !continue
+ if not !stop
then
- let eq_ref = Nametab.locate (make_short_qualid equation_id ) in
- let f_ref = destConst (constr_of_reference f_ref)
- and functional_ref = destConst (constr_of_reference functional_ref)
- and eq_ref = destConst (constr_of_reference 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 Options.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" )
- )
+ let eq_ref = Nametab.locate (make_short_qualid 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
@@ -1294,7 +1417,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
relation rec_arg_num
term_id
using_lemmas
- hook
+ (List.length res_vars)
+ hook
with e ->
begin
ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ());
@@ -1303,22 +1427,4 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
end
-VERNAC COMMAND EXTEND RecursiveDefinition
- [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf)
- constr(proof) integer_opt(rec_arg_num) constr(eq) ] ->
- [
- warning "Recursive Definition is obsolete. Use Function instead";
- ignore(proof);ignore(wf);
- let rec_arg_num =
- match rec_arg_num with
- | None -> 1
- | Some n -> n
- in
- recursive_definition false f [] type_of_f r rec_arg_num eq (fun _ _ _ _ _ _ _ _ -> ()) []]
-| [ "Recursive" "Definition" ident(f) constr(type_of_f) constr(r) constr(wf)
- "[" ne_constr_list(proof) "]" constr(eq) ] ->
- [ ignore(proof);ignore(wf);recursive_definition false f [] type_of_f r 1 eq (fun _ _ _ _ _ _ _ _ -> ()) []]
-END
-
-
diff --git a/contrib/funind/tacinv.ml4 b/contrib/funind/tacinv.ml4
deleted file mode 100644
index 5d19079b..00000000
--- a/contrib/funind/tacinv.ml4
+++ /dev/null
@@ -1,872 +0,0 @@
-(*i camlp4deps: "parsing/grammar.cma" i*)
-
-(*s FunInv Tactic: inversion following the shape of a function. *)
-
-(* Deprecated: see indfun_main.ml4 instead *)
-
-(* Don't delete this file yet, it may be used for other purposes *)
-
-(*i*)
-open Termops
-open Equality
-open Names
-open Pp
-open Tacmach
-open Proof_type
-open Tacinterp
-open Tactics
-open Tacticals
-open Term
-open Util
-open Printer
-open Reductionops
-open Inductiveops
-open Coqlib
-open Refine
-open Typing
-open Declare
-open Decl_kinds
-open Safe_typing
-open Vernacinterp
-open Evd
-open Environ
-open Entries
-open Setoid_replace
-open Tacinvutils
-(*i*)
-
-module Smap = Map.Make(struct type t = constr let compare = compare end)
-let smap_to_list m = Smap.fold (fun c cb l -> (c,cb)::l) m []
-let merge_smap m1 m2 = Smap.fold (fun c cb m -> Smap.add c cb m) m1 m2
-let rec listsuf i l = if i<=0 then l else listsuf (i-1) (List.tl l)
-let rec listpref i l = if i<=0 then [] else List.hd l :: listpref (i-1) (List.tl l)
-let rec split3 l =
- List.fold_right (fun (e1,e2,e3) (a,b,c) -> (e1::a),(e2::b),(e3::c)) l ([],[],[])
-
-let mkthesort = mkProp (* would like to put Type here, but with which index? *)
-
-(* this is the prefix used to name equality hypothesis generated by
- case analysis*)
-let equality_hyp_string = "_eg_"
-
-(* bug de refine: on doit ssavoir sur quelle hypothese on se trouve. valeur
- initiale au debut de l'appel a la fonction proofPrinc: 1. *)
-let nthhyp = ref 1
-
-let debug i = prstr ("DEBUG "^ string_of_int i ^"\n")
-let pr2constr = (fun c1 c2 -> prconstr c1; prstr " <---> "; prconstr c2)
-(* Operations on names *)
-let id_of_name = function
- Anonymous -> id_of_string "H"
- | Name id -> id;;
-let string_of_name nme = string_of_id (id_of_name nme)
- (*end debugging *)
-
-(* Interpretation of constr's *)
-let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
-
-(*s specific manipulations on constr *)
-let lift1_leqs leq=
- List.map
- (function (r,(typofg,g,d))
- -> lift 1 r, (lift 1 typofg, lift 1 g , lift 1 d)) leq
-
-let lift1_relleqs leq= List.map (function (r,x) -> lift 1 r,x) leq
-
-(* WARNING: In the types, we don't lift the rels in the type. This is
- intentional. Use with care. *)
-let lift1_lvars lvars= List.map
- (function x,(nme,c) -> lift 1 x, (nme, (*lift 1*) c)) lvars
-
-let pop1_levar levars = List.map (function ev,tev -> ev, popn 1 tev) levars
-
-
-let rec add_n_dummy_prod t n =
- if n<=0 then t
- else add_n_dummy_prod (mkNamedProd (id_of_string "DUMMY") mkthesort t) (n-1)
-
-(* [add_lambdas t gl [csr1;csr2...]] returns [[x1:type of csr1]
- [x2:type of csr2] t [csr <- x1 ...]], names of abstracted variables
- are not specified *)
-let rec add_lambdas t gl lcsr =
- match lcsr with
- | [] -> t
- | csr::lcsr' ->
- let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in
- lambda_id hyp_csr hyptyp (add_lambdas t gl lcsr')
-
-(* [add_pis t gl [csr1;csr2...]] returns ([x1] :type of [csr1]
- [x2]:type of csr2) [t]*)
-let rec add_pis t gl lcsr =
- match lcsr with
- | [] -> t
- | csr::lcsr' ->
- let hyp_csr,hyptyp = csr,(pf_type_of gl csr) in
- prod_id hyp_csr hyptyp (add_pis t gl lcsr')
-
-let mkProdEg teq eql eqr concl =
- mkProd (name_of_string "eg", mkEq teq eql eqr, lift 1 concl)
-
-let eqs_of_beqs x =
- List.map (function (_,(a,b,c)) -> (Anonymous, mkEq a b c)) x
-
-
-let rec eqs_of_beqs_named_aux s i l =
- match l with
- | [] -> []
- | (r,(a,b,c))::l' ->
- (Name(id_of_string (s^ string_of_int i)), mkEq a b c)
- ::eqs_of_beqs_named_aux s (i-1) l'
-
-
-let eqs_of_beqs_named s l = eqs_of_beqs_named_aux s (List.length l) l
-
-let rec patternify ltypes c nme =
- match ltypes with
- | [] -> c
- | (mv,t)::ltypes' ->
- let c'= substitterm 0 mv (mkRel 1) c in
- let tlift = lift (List.length ltypes') t in
- let res =
- patternify ltypes' (mkLambda (newname_append nme "rec", tlift, c')) nme in
- res
-
-let rec npatternify ltypes c =
- match ltypes with
- | [] -> c
- | (mv,nme,t)::ltypes' ->
- let c'= substitterm 0 mv (mkRel 1) c in
- let tlift = lift (List.length ltypes') t in
- let res =
- npatternify ltypes' (mkLambda (newname_append nme "", tlift, c')) in
- res
-
-(* fait une application (c m1 m2...mn, où mi est une evar, on rend également
- la liste des evar munies de leur type) *)
-let rec apply_levars c lmetav =
- match lmetav with
- | [] -> [],c
- | (i,typ) :: lmetav' ->
- let levars,trm = apply_levars c lmetav' in
- let exkey = mknewexist() in
- ((exkey,typ)::levars), applistc trm [mkEvar exkey]
- (* EXPERIMENT le refine est plus long si on met un cast:
- ((exkey,typ)::levars), mkCast ((applistc trm [mkEvar exkey]),typ) *)
-
-
-let prod_change_concl c newconcl =
- let lv,_ = decompose_prod c in prod_it newconcl lv
-
-let lam_change_concl c newconcl =
- let lv,_ = decompose_prod c in lam_it newconcl lv
-
-
-let rec mkAppRel c largs n =
- match largs with
- | [] -> c
- | arg::largs' ->
- let newc = mkApp (c,[|(mkRel n)|]) in mkAppRel newc largs' (n-1)
-
-let applFull c typofc =
- let lv,t = decompose_prod typofc in
- let ltyp = List.map fst lv in
- let res = mkAppRel c ltyp (List.length ltyp) in
- res
-
-(* Take two terms with same structure and return a map of deBruijn from the
- first to the second. Only DeBruijn should be different between the two
- terms. *)
-let rec build_rel_map typ type_of_b =
- match (kind_of_term typ), (kind_of_term type_of_b) with
- Evar _ , Evar _ -> Smap.empty
- | Const c1, Const c2 when c1=c2 -> Smap.empty
- | Ind c1, Ind c2 when c1=c2 -> Smap.empty
- | Rel i, Rel j when i=j -> Smap.empty
- | Rel i, Rel j -> Smap.add typ type_of_b Smap.empty
- | Prod (name,c1,c2), Prod (nameb,c1b,c2b) ->
- let map1 = build_rel_map c1 c1b in
- let map2 = build_rel_map (pop c2) (pop c2b) in
- merge_smap map1 map2
- | App (f,args), App (fb,argsb) when Array.length args = Array.length argsb ->
- build_rel_map_list (Array.to_list args) (Array.to_list argsb)
- | _,_ -> failwith ("Could not generate case annotation. "^
- "Incompatibility between annotation and actual type")
-
-and build_rel_map_list ltyp ltype_of_b =
- List.fold_left2 (fun a b c -> merge_smap a (build_rel_map b c))
- Smap.empty ltyp ltype_of_b
-
-
-(*s Use (and proof) of the principle *)
-
-(* This is the type of the argument of [proofPrinc] *)
-
-type mimickinfo =
- {
- concl: constr; (* conclusion voulue, cad (xi:ti)gl, ou gl est le but a
- prouver, et xi:ti correspondent aux arguments donnés à
- la tactique. On enlèvera un produit à chaque fois
- qu'on rencontrera un binder, sans lift ou pop.
- Initialement: une seule conclusion, puis specifique à
- chaque branche. *)
- absconcl: constr array; (* conclusions patternisées pour pouvoir être
- appliquées = un predicat pour chaque fixpt
- mutuel. *)
- mimick: constr; (* le terme qu'on imite. On plongera dedans au fur et
- à mesure, sans lift ni pop. *)
- env: env; (* The global typing environment, we will add thing in it when
- going inside the term (push_rel, push_rec_types) *)
- sigma: Evd.evar_map;
- nmefonc: constr array; (* la constante correspondant à la fonction
- appelée, permet de remplacer les appels
- recursifs par des appels à la constante
- correspondante (non pertinent (et inutile) si
- on permet l'appel de la tactique sur une terme
- donné directement (au lieu d'une constante
- comme pour l'instant)). *)
- fonc: int * int; (* bornes des indices des variable correspondant aux
- appels récursifs (plusieurs car fixp. mutuels),
- utile pour reconnaître les appels récursifs
- (ATTENTION: initialement vide, reste vide tant qu'on
- n'est pas dans un fix). *)
- doeqs: bool; (* this reference is to toggle building of equalities during
- the building of the principle (default is true) *)
- fix: bool; (* did I already went through a fix or case constr? lambdas
- found before a case or a fix are treated as parameters of
- the induction principle *)
- lst_vars: (constr*(name*constr)) list ; (* Variables rencontrées jusque là *)
- lst_eqs: (Term.constr * (Term.constr * Term.constr * Term.constr)) list ;
- (* liste d'équations engendrées au cours du
- parcours, cette liste grandit à chaque
- case, et il faut lifter le tout à chaque
- binder *)
- lst_recs: constr list ; (* appels récursifs rencontrés jusque là *)
- }
-
-(* This is the return type of [proofPrinc] *)
-type 'a funind = (* 'A = CONTR OU CONSTR ARRAY *)
- {
-
- princ:'a; (* le (ou les) principe(s) demandé(s), il contient des meta
- variables représentant soit des trous à prouver plus tard,
- soit les conclusions à compléter avant de rendre le terme
- (suivant qu'on utilise le principe pour faire refine ou
- functional scheme). Il y plusieurs conclusions si plusieurs
- fonction mutuellement récursives) voir la suite. *)
- evarlist: (constr*Term.types) list; (* [(ev1,tev1);(ev2,tev2)...]]
- l'ensemble des meta variables
- correspondant à des trous. [evi]
- est la meta variable, [tevi] est
- son type. *)
- hypnum: (int*int*int) list; (* [[(in,jn,kn)...]] sont les nombres
- respectivement de variables, d'équations,
- et d'hypothèses de récurrence pour le but
- n. Permet de faire le bon nombre d'intros
- et des rewrite au bons endroits dans la
- suite. *)
- mutfixmetas: constr array ; (* un tableau de meta variables correspondant
- à chacun des prédicats mutuellement
- récursifs construits. *)
- conclarray: types array; (* un tableau contenant les conclusions
- respectives de chacun des prédicats
- mutuellement récursifs. Permet de finir la
- construction du principe. *)
- params:(constr*name*constr) list; (* [[(metavar,param,tparam)..]] la
- liste des paramètres (les lambdas
- au-dessus du fix) du fixpoint si
- fixpoint il y a, le paramètre est
- une meta var, dont on stocke le nom
- et le type. TODO: utiliser la
- structure adequat? *)
- }
-
-
-
-let empty_funind_constr =
- {
- princ = mkProp;
- evarlist = [];
- hypnum = [];
- mutfixmetas = [||];
- conclarray = [||];
- params = []
- }
-
-let empty_funind_array =
- { empty_funind_constr with
- princ = [||];
- }
-
-(* Replace the calls to the function (recursive calls) by calls to the
- corresponding constant *)
-let replace_reccalls mi b =
- let d,f = mi.fonc in
- let res = ref b in
- let _ = for i = d to f do
- res := substitterm 0 (mkRel i) mi.nmefonc.(f-i) !res done in
- !res
-
-
-
-(* collects all information of match branches stored in [l] *)
-let rec collect_cases l =
- match l with
- | [||] -> empty_funind_array
- | arr ->
- let x = arr.(0) in
- let resrec = collect_cases (Array.sub arr 1 (Array.length arr - 1)) in
- { x with
- princ= Array.append [|x.princ|] resrec.princ;
- evarlist = x.evarlist@resrec.evarlist;
- hypnum = x.hypnum@resrec.hypnum;
- }
-
-let collect_pred l =
- let l1,l2,l3 = split3 l in
- Array.of_list l1 , Array.of_list l2 , Array.of_list l3
-
-
-(* [build_pred n tarr] builds the right predicates for each element of [tarr]
- (of type: [type array] of size [n]). Return the list of triples:
- (?i ,
- fun (x1:t1) ... (xn:tn) => (?i x1...xn) ,
- forall (x1:t1) ... (xn:tn), (?i x1...xn)),
- where ti's are deduced from elements of tarr, which are of the form:
- t1 -> t2 -> ... -> tn -> <nevermind>. *)
-let rec build_pred n tarr =
- if n >= Array.length tarr (* iarr *) then []
- else
- let ftyp = Array.get tarr n in
- let gl = mknewmeta() in
- let gl_app = applFull gl ftyp in
- let pis = prod_change_concl ftyp gl_app in
- let gl_abstr = lam_change_concl ftyp gl_app in
- (gl,gl_abstr,pis):: build_pred (n+1) tarr
-
-
-let heq_prefix = "H_eq_"
-
-type kind_of_hyp = Var | Eq (*| Rec*)
-
-(* the main function, build the principle by exploring the term and reproduce
- the same structure. *)
-let rec proofPrinc mi: constr funind =
- match kind_of_term mi.mimick with
- (* Fixpoint: we reproduce the Fix, fonc becomes (1,nbofmutf) to point on
- the name of recursive calls *)
- | Fix((iarr,i),(narr,tarr,carr)) ->
- (* We construct the right predicates for each mutual fixpt *)
- let evararr,newabsconcl,pisarr = collect_pred (build_pred 0 tarr) in
- let newenv = push_rec_types (narr,tarr,carr) mi.env in
- let anme',aappel_rec,llevar,llposeq =
- collect_fix mi 0 iarr narr carr pisarr newabsconcl newenv in
- let anme = Array.map (fun nme -> newname_append nme "_ind") anme' in
- {
- princ = mkFix((iarr,i),(anme, pisarr,aappel_rec));
- evarlist= pop1_levar llevar; (* llevar are put outside the fix, so we pop 1 *)
- hypnum = llposeq;
- mutfixmetas = evararr;
- conclarray = pisarr;
- params = []
- }
- (* <pcase> Cases b of arrPt end.*)
- | Case (cinfo, pcase, b, arrPt) ->
- let prod_pcase,_ = decompose_lam pcase in
- let _nmeb,_ = List.hd prod_pcase in
- let newb'= apply_leqtrpl_t b mi.lst_eqs in
- let type_of_b = Typing.type_of mi.env mi.sigma b in
- (* Replace the recursive calls to the function by calls to the constant *)
- let newb = replace_reccalls mi newb' in
- let cases = collect_cases (Array.mapi (fold_proof mi b type_of_b newb) arrPt) in
- (* the match (case) annotation must be transformed, see [build_pcase] below *)
- let newpcase = build_pcase mi pcase b type_of_b newb in
- let trm' = mkCase (cinfo,newpcase,newb, cases.princ) in
- { cases with
- princ = if mi.doeqs then mkApp (trm',[|(mkRefl type_of_b newb)|]) else trm';
- params = [] (* FIX: fix parms here (fixpt inside a match)*)
- }
-
-
- | Lambda(nme, typ, cstr) ->
- let _, _, cconcl = destProd mi.concl in
- let d,f=mi.fonc in
- let newenv = push_rel (nme,None,typ) mi.env in
- let newlst_var = (* if this lambda is a param, then don't add it here *)
- if mi.fix then (mkRel 1,(nme,typ)) :: lift1_lvars mi.lst_vars
- else (*(mkRel 1,(nme,typ)) :: *) lift1_lvars mi.lst_vars in
- let newmi = {mi with concl=cconcl; mimick=cstr; env=newenv;
- fonc = (if d > 0 then d+1 else 0) , (if f > 0 then f+1 else 0);
- lst_vars = newlst_var ; lst_eqs = lift1_leqs mi.lst_eqs;
- lst_recs = lift1L mi.lst_recs} in
- let resrec = proofPrinc newmi in
- (* are we inside a fixpoint or a case? then this is a normal lambda *)
- if mi.fix
- then { resrec with princ = mkLambda (nme,typ,resrec.princ) ; params = [] }
- else (* otherwise this is a parameter *)
- let metav = mknewmeta() in
- let substmeta t = popn 1 (substitterm 0 (mkRel 1) metav t) in
- { resrec with
- princ = substmeta resrec.princ;
- evarlist = List.map (fun (ev,tev) -> ev, substmeta tev) resrec.evarlist;
- conclarray = Array.map substmeta resrec.conclarray;
- params = (metav,nme,typ) :: resrec.params
- }
-
-
- | LetIn(nme,cstr1, typ, cstr) ->
- failwith ("I don't deal with let ins yet. "^
- "Please expand them before applying this function.")
-
- | u ->
- let varrels = List.rev (List.map fst mi.lst_vars) in
- let varnames = List.map snd mi.lst_vars in
- let nb_vars = List.length varnames in
- let nb_eqs = List.length mi.lst_eqs in
- let _eqrels = List.map fst mi.lst_eqs in
- (* [terms_recs]: appel rec du fixpoint, On concatène les appels recs
- trouvés dans les let in et les Cases avec ceux trouves dans u (ie
- mi.mimick). *)
- (* TODO: il faudra gérer plusieurs pt fixes imbriqués ? *)
- let terms_recs = mi.lst_recs @ hdMatchSub_cpl mi.mimick mi.fonc in
- (*c construction du terme: application successive des variables, des
- egalites et des appels rec, a la variable existentielle correspondant a
- l'hypothese de recurrence en cours. *)
- (* d'abord, on fabrique les types des appels recursifs en replacant le nom
- de des fonctions par les predicats dans [terms_recs]: [(f_i t u v)]
- devient [(P_i t u v)] *)
- (* TODO optimiser ici: *)
- let appsrecpred = exchange_reli_arrayi_L mi.absconcl mi.fonc terms_recs in
- let typeofhole'' = prod_it_anonym_lift mi.concl appsrecpred in
- let typeofhole = prodn nb_vars varnames typeofhole'' in
- (* Un bug de refine m'oblige à mettre ici un H (meta variable à ce point,
- mais remplacé par H avant le refine) au lieu d'un '?', je mettrai les
- '?' à la fin comme ça [(([H1,H2,H3...] ...) ? ? ?)] *)
- let newmeta = mknewmeta() in
- let concl_with_var = applistc newmeta varrels in
- let conclrecs = applistc concl_with_var terms_recs in
- { empty_funind_constr with
- princ = conclrecs;
- evarlist = [ newmeta , typeofhole ];
- hypnum = [ nb_vars , List.length terms_recs , nb_eqs ];
- conclarray = mi.absconcl;
- }
-
-
-(* C'est un peu compliqué ici: en cas de type inductif vraiment dépendant
- l'annotation de type du case [pcase] contient des lambdas supplémentaires
- en tête. Je les récupère dans la variable [suppllam_pcase]. Le problème est
- que la conclusion de l'annotation du nouveauacse doit faire référence à ces
- variables plutôt qu'à celle de l'exterieur. Ce qui suit permet de changer
- les reference de newpcase' pour pointer vers les lambda du piquant. On
- procède comme suit: on repère les rels qui pointent à l'interieur de
- l'annotation dans la fonction initiale et on les relie à celle du type
- voulu pour le case, pour ça ([build_rel_map]) on parcourt en même temps le
- dernier lambda du piquant ([typ]) (qui contient le type de l'argument du
- case) et le type attendu pour le case ([type_of_b]) et on construit un
- map. Ensuite on remplace les rels correspondant dans la preuve construite
- en suivant le map. *)
-
-and build_pcase mi pcase b type_of_b newb =
- let prod_pcase,_ = decompose_lam pcase in
- let nme,typ = List.hd prod_pcase in
- (* je remplace b par rel1 (apres avoir lifte un coup) dans la future
- annotation du futur case: ensuite je mettrai un lambda devant *)
- let typeof_case'' = substitterm 0 (lift 1 b) (mkRel 1) (lift 1 mi.concl) in
- let suppllam_pcase = List.tl prod_pcase in
- let suppllam_pcasel = List.length suppllam_pcase in
- let rel_smap =
- if suppllam_pcasel=0 then Smap.empty else (* FIX: is this test necessary ? *)
- build_rel_map (lift suppllam_pcasel type_of_b) typ in
- let newpcase''' =
- Smap.fold (fun e e' acc -> substitterm 0 e (lift 1 e') acc)
- rel_smap typeof_case'' in
- let neweq = mkEq (lift (suppllam_pcasel + 1) type_of_b)
- (lift (suppllam_pcasel + 1) newb) (mkRel 1) in
- let newpcase'' =
- if mi.doeqs
- then mkProd (name_of_string "eg", neweq, lift 1 newpcase''')
- else newpcase''' in
- (* construction du dernier lambda du piquant. *)
- let newpcase' = mkLambda (newname_append nme "_ind" ,typ, newpcase'') in
- (* ajout des lambdas supplémentaires (type dépendant) du piquant. *)
- lamn suppllam_pcasel suppllam_pcase newpcase'
-
-
-(* [fold_proof mi b typeofb newb l n] rend le resultat de l'appel recursif sur
- cstr (correpsondant au ième elt de [arrPt] ci-dessus et donc au ième
- constructeur de [typeofb]), appele avec les bons arguments: [mi.concl]
- devient [(DUMMY1:t1;...;DUMMY:tn)concl'], ou [n] est le nombre d'arguments
- du constructeur considéré, et [concl'] est [mi.concl] ou l'on a réécrit [b]
- en ($c_n$ [rel1]...). *)
-and fold_proof mi b type_of_b newb i cstr =
- let new_lst_recs = mi.lst_recs @ hdMatchSub_cpl b mi.fonc in
- (* mise a jour de concl pour l'interieur du case, concl'= concl[b <- C x3
- x2 x1... ], sans quoi les annotations ne sont plus coherentes *)
- let cstr_appl,nargs = nth_dep_constructor type_of_b i in
- let concl'' =
- substitterm 0 (lift nargs b) cstr_appl (lift nargs mi.concl) in
- let neweq = mkEq type_of_b newb (popn nargs cstr_appl) in
- let concl_dummy = add_n_dummy_prod concl'' nargs in
- let lsteqs_rew = apply_eq_leqtrpl mi.lst_eqs neweq in
- let new_lsteqs = (mkRel (-nargs),(type_of_b,newb, popn nargs cstr_appl))::lsteqs_rew in
- let a',a'' = decompose_lam_n nargs cstr in
- let newa'' =
- if mi.doeqs
- then mkLambda (name_of_string heq_prefix,lift nargs neweq,lift 1 a'')
- else a'' in
- let newmimick = lamn nargs a' newa'' in
- let b',b'' = decompose_prod_n nargs concl_dummy in
- let newb'' =
- if mi.doeqs
- then mkProd (name_of_string heq_prefix,lift nargs neweq,lift 1 b'')
- else b'' in
- let newconcl = prodn nargs b' newb'' in
- let newmi = {mi with mimick=newmimick; concl=newconcl; fix=true;
- lst_eqs= new_lsteqs; lst_recs = new_lst_recs} in
- proofPrinc newmi
-
-
-and collect_fix mi n iarr narr carr pisarr newabsconcl newenv =
- if n >= Array.length iarr then [||],[||],[],[]
- else
- let nme = Array.get narr n in
- let c = Array.get carr n in
- (* rappelle sur le sous-terme, on ajoute un niveau de
- profondeur (lift) parce que Fix est un binder. *)
- let newmi = {mi with concl=(pisarr.(n)); absconcl=newabsconcl;
- mimick=c; fonc=(1,((Array.length iarr)));env=newenv;fix=true;
- lst_vars=lift1_lvars mi.lst_vars; lst_eqs=lift1_leqs mi.lst_eqs;
- lst_recs= lift1L mi.lst_recs;} in
- let resrec = proofPrinc newmi in
- let lnme,lappel_rec,llevar,llposeq =
- collect_fix mi (n+1) iarr narr carr pisarr newabsconcl newenv in
- Array.append [|nme|] lnme , Array.append [|resrec.princ|] lappel_rec
- , (resrec.evarlist@llevar) , (resrec.hypnum@llposeq)
-
-let mkevarmap_aux ex = let x,y = ex in (mkevarmap_from_listex x),y
-
-
-(* TODO: deal with any term, not only a constant. *)
-let interp_fonc_tacarg fonctac gl =
- (* [fonc] is the constr corresponding to fontact not unfolded,
- if [fonctac] is a (qualified) name then this is a [const] ?. *)
-(* let fonc = constr_of_Constr fonctac in *)
- (* TODO: replace the [with _ -> ] by something more precise in
- the following. *)
- (* [def_fonc] is the definition of fonc. TODO: We should do this only
- if [fonc] is a const, and take [fonc] otherwise.*)
- try fonctac, pf_const_value gl (destConst fonctac)
- with _ -> failwith ("don't know how to deal with this function "
- ^"(DEBUG:is it a constante?)")
-
-
-
-
-(* [invfun_proof fonc def_fonc gl_abstr pis] builds the principle,
- following the shape of [def_fonc], [fonc] is the constant
- corresponding to [def_func] (or a reduced form of it ?), gl_abstr and
- pis are the goal to be proved, of the form [x,y...]g and (x.y...)g.
-
- This function calls the big function proofPrinc. *)
-
-let invfun_proof fonc def_fonc gl_abstr pis env sigma =
- let mi = {concl=pis; absconcl=gl_abstr; mimick=def_fonc; env=env;
- sigma=sigma; nmefonc=fonc; fonc=(0,0); doeqs=true; fix=false ;
- lst_vars = []; lst_eqs = []; lst_recs = []} in
- proofPrinc mi
-
-(* Do intros [i] times, then do rewrite on all introduced hyps which are called
- like [heq_prefix], FIX: have another filter than the name. *)
-let rec iterintro i =
- if i<=0 then tclIDTAC else
- tclTHEN
- (tclTHEN
- intro
- (iterintro (i-1)))
- (fun gl ->
- (tclREPEAT
- (tclNTH_HYP i
- (fun hyp ->
- let hypname = (string_of_id (destVar hyp)) in
- let sub =
- try String.sub hypname 0 (String.length heq_prefix)
- with _ -> "" (* different than [heq_prefix] *) in
- if sub=heq_prefix then rewriteLR hyp else tclFAIL 0 (str "Cannot rewrite"))
- )) gl)
-
-
-(*
- (fun hyp gl ->
- let _ = prstr ("nthhyp= "^ string_of_int i) in
- if isConst hyp && ((name_of_const hyp)==heq_prefix) then
- let _ = prstr "YES\n" in
- rewriteLR hyp gl
- else
- let _ = prstr "NO\n" in
- tclIDTAC gl)
- *)
-
-(* [invfun_basic C listargs_ids gl dorew lposeq] builds the tactic
- which:
- \begin{itemize}
- \item Do refine on C (the induction principle),
- \item try to Clear listargs_ids
- \item if boolean dorew is true, then intro all new hypothesis, and
- try rewrite on those hypothesis that are equalities.
- \end{itemize}
-*)
-
-let invfun_basic open_princ_proof_applied listargs_ids gl dorew lposeq =
- (tclTHEN_i
- (tclTHEN
- (tclTHEN
- (* Refine on the right term (following the sheme of the
- given function) *)
- (fun gl -> refine open_princ_proof_applied gl)
- (* Clear the hypothesis given as arguments of the tactic
- (because they are generalized) *)
- (tclTHEN simpl_in_concl (tclTRY (clear listargs_ids))))
- (* Now we introduce the created hypothesis, and try rewrite on
- equalities due to case analysis *)
- (fun gl -> (tclIDTAC gl)))
- (fun i gl ->
- if not dorew then tclIDTAC gl
- else
- (* d,m,f correspond respectively to vars, induction hyps and
- equalities*)
- let d,m,f = List.nth lposeq (i-1) in
- tclTHEN (iterintro (d)) (tclDO m (tclTRY intro)) gl)
- )
- gl
-
-
-
-
-(* This function trys to reduce instanciated arguments, provided they
- are of the form [(C t u v...)] where [C] is a constructor, and
- provided that the argument is not the argument of a fixpoint (i.e. the
- argument corresponds to a simple lambda) . *)
-let rec applistc_iota cstr lcstr env sigma =
- match lcstr with
- | [] -> cstr,[]
- | arg::lcstr' ->
- let arghd =
- if isApp arg then let x,_ = destApp arg in x else arg in
- if isConstruct arghd (* of the form [(C ...)]*)
- then
- applistc_iota (Tacred.nf env sigma (nf_beta (applistc cstr [arg])))
- lcstr' env sigma
- else
- try
- let nme,typ,suite = destLambda cstr in
- let c, l = applistc_iota suite lcstr' env sigma in
- mkLambda (nme,typ,c), arg::l
- with _ -> cstr,arg::lcstr' (* the arg does not correspond to a lambda*)
-
-
-
-(* TODO: ne plus mettre les sous-but à l'exterieur, mais à l'intérieur (le bug
- de refine est normalement resolu). Ca permettra 2 choses: d'une part que
- les preuves soient plus simple, et d'autre part de fabriquer un terme de
- refine qui pourra s'aapliquer SANS FAIRE LES INTROS AVANT, ce qui est bcp
- mieux car fonctionne comme induction et plus comme inversion (pas de perte
- de connexion entre les hypothèse et les variables). *)
-
-(*s Tactic that makes induction and case analysis following the shape
- of a function (idf) given with arguments (listargs) *)
-let invfun c l dorew gl =
-(* \begin{itemize}
- \item [fonc] = the constant corresponding to the function
- (necessary for equalities of the form [(f x1 x2 ...)=...] where
- [f] is the recursive function).
- \item [def_fonc] = body of the function, where let ins have
- been expanded. *)
- let fonc, def_fonc' = interp_fonc_tacarg c gl in
- let def_fonc'',listargs' =
- applistc_iota def_fonc' l (pf_env gl) (project gl) in
- let def_fonc = expand_letins def_fonc'' in
- (* quantifies on previously generalized arguments.
- [(x1:T1)...g[arg1 <- x1 ...]] *)
- let pis = add_pis (pf_concl gl) gl listargs' in
- (* princ_proof builds the principle *)
- let _ = resetmeta() in
- let pr = invfun_proof [|fonc|] def_fonc [||] pis (pf_env gl) (project gl) in
- (* Generalize the goal. [[x1:T1][x2:T2]... g[arg1 <- x1 ...]]. *)
- let gl_abstr' = add_lambdas (pf_concl gl) gl listargs' in
- (* apply parameters immediately *)
- let gl_abstr =
- applistc gl_abstr' (List.map (fun (x,y,z) -> x) (List.rev pr.params)) in
- (* we apply args of the fix now, the parameters will be applied later *)
- let princ_proof_applied_args =
- applistc pr.princ (listsuf (List.length pr.params) listargs') in
- (* parameters are still there so patternify must not take them -> lift *)
- let princ_proof_applied_lift =
- lift (List.length pr.evarlist) princ_proof_applied_args in
- let princ_applied_hyps'' = patternify (List.rev pr.evarlist)
- princ_proof_applied_lift (Name (id_of_string "Hyp")) in
- (* if there was a fix, we will not add "Q" as in funscheme, so we make a pop,
- TODO: find were we made the lift in proofPrinc instead and supress it here,
- and add lift in funscheme. *)
- let princ_applied_hyps' =
- if Array.length pr.mutfixmetas > 0 then popn 1 princ_applied_hyps''
- else princ_applied_hyps'' in
- (* if there is was fix, we have to replace the meta representing the
- predicate of the goal by the abstracted goal itself. *)
- let princ_applied_hyps =
- if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*)
- (substit_red 0 (pr.mutfixmetas.(0)) gl_abstr princ_applied_hyps')
- else princ_applied_hyps' (* No Fixpoint *) in
- let _ = prNamedConstr "princ_applied_hyps" princ_applied_hyps in
- (* Same thing inside levar *)
- let newlevar' =
- if Array.length pr.mutfixmetas > 0 then(* mutual Fixpoint not treated in the tactic*)
- List.map (fun (x,y) -> x,substit_red 0 (pr.mutfixmetas.(0)) gl_abstr y) pr.evarlist
- else pr.evarlist
- in
- (* replace params metavar by real args *)
- let rec replace_parms lparms largs t =
- match lparms, largs with
- [], _ -> t
- | ((p,_,_)::lp), (a::la) -> let t'= substitterm 0 p a t in replace_parms lp la t'
- | _, _ -> error "problem with number of args." in
- let princ_proof_applied = replace_parms pr.params listargs' princ_applied_hyps in
- let _ = prNamedLConstr "levar:" (List.map fst newlevar') in
- let _ = prNamedLConstr "levar types:" (List.map snd newlevar') in
- let _ = prNamedConstr "princ_proof_applied" princ_proof_applied in
- (* replace also in levar *)
- let newlevar =
- List.rev (List.map (fun (x,y) -> x, replace_parms pr.params listargs' y) newlevar') in
-(*
- (* replace params metavar by abstracted variables *)
- let princ_proof_params = npatternify (List.rev pr.params) princ_applied_hyps in
- (* we apply now the real parameters *)
- let princ_proof_applied =
- applistc princ_proof_params (listpref (List.length pr.params) listargs') in
-*)
- let princ_applied_evars = apply_levars princ_proof_applied newlevar in
- let open_princ_proof_applied = princ_applied_evars in
- let _ = prNamedConstr "princ_applied_evars" (snd princ_applied_evars) in
- let _ = prNamedLConstr "evars" (List.map snd (fst princ_applied_evars)) in
- let listargs_ids = List.map destVar (List.filter isVar listargs') in
- (* debug: impression du but*)
- let lgl = Evd.to_list (sig_sig gl) in
- let _ = prNamedLConstr "\ngl= " (List.map (fun x -> (snd x).evar_concl) lgl) in
- let _ = prstr "fin gl \n\n" in
- invfun_basic (mkevarmap_aux open_princ_proof_applied) listargs_ids
- gl dorew pr.hypnum
-
-(* function must be a constant, all arguments must be given. *)
-let invfun_verif c l dorew gl =
- if not (isConst c) then error "given function is not a constant"
- else
- let x,_ = decompose_prod (pf_type_of gl c) in
- if List.length x = List.length l then
- try invfun c l dorew gl
- with UserError (x,y) -> raise (UserError (x,y))
- else error "wrong number of arguments for the function"
-
-
-
-
-(* Construction of the functional scheme. *)
-let buildFunscheme fonc mutflist =
- let def_fonc = expand_letins (def_of_const fonc) in
- let ftyp = type_of (Global.env ()) Evd.empty fonc in
- let _ = resetmeta() in
- let gl = mknewmeta() in
- let gl_app = applFull gl ftyp in
- let pis = prod_change_concl ftyp gl_app in
- (* Here we call the function invfun_proof, that effectively
- builds the scheme *)
-(* let princ_proof,levar,_,evararr,absc,parms = *)
- let _ = prstr "Recherche du principe... lancement de invfun_proof\n" in
- let pr = invfun_proof mutflist def_fonc [||] pis (Global.env()) Evd.empty in
- (* parameters are still there (unboud rel), and patternify must not take them
- -> lift*)
- let princ_proof_lift = lift (List.length pr.evarlist) pr.princ in
- let princ_proof_hyps =
- patternify (List.rev pr.evarlist) princ_proof_lift (Name (id_of_string "Hyp")) in
- let rec princ_replace_metas ev abs i t =
- if i>= Array.length ev then t
- else (* fix? *)
- princ_replace_metas ev abs (i+1)
- (mkLambda (
- (Name (id_of_string ("Q"^(string_of_int i)))),
- prod_change_concl (lift 0 abs.(i)) mkthesort,
- (substitterm 0 ev.(i) (mkRel 1) (lift 0 t))))
- in
- let rec princ_replace_params params t =
- List.fold_left (
- fun acc (ev,nam,typ) ->
- mkLambda (Name (id_of_name nam) , typ,
- substitterm 0 ev (mkRel 1) (lift 0 acc)))
- t (List.rev params) in
- if Array.length pr.mutfixmetas = 0 (* Is there a Fixpoint? *)
- then (* No Fixpoint *)
- princ_replace_params pr.params (mkLambda ((Name (id_of_string "Q")),
- prod_change_concl ftyp mkthesort,
- (substitterm 0 gl (mkRel 1) princ_proof_hyps)))
- else (* there is a fix -> add parameters + replace metas *)
- let princ_rpl =
- princ_replace_metas pr.mutfixmetas pr.conclarray 0 princ_proof_hyps in
- princ_replace_params pr.params princ_rpl
-
-
-
-(* Declaration of the functional scheme. *)
-let declareFunScheme f fname mutflist =
- let _ = prstr "Recherche du perincipe...\n" in
- let id_to_cstr id =
- try constr_of_id (Global.env()) id
- with
- Not_found -> error (string_of_id id ^ " not found in the environment") in
- let flist = if mutflist=[] then [f] else mutflist in
- let fcstrlist = Array.of_list (List.map id_to_cstr flist) in
- let idf = id_to_cstr f in
- let scheme = buildFunscheme idf fcstrlist in
- let _ = prstr "Principe:" in
- let _ = prconstr scheme in
- let ce = {
- const_entry_body = scheme;
- const_entry_type = None;
- const_entry_opaque = false;
- const_entry_boxed = true } in
- let _= ignore (declare_constant fname (DefinitionEntry ce,IsDefinition Scheme)) in
- ()
-
-
-
-TACTIC EXTEND functional_induction
- [ "old" "functional" "induction" constr(c) ne_constr_list(l) ]
- -> [ invfun_verif c l true ]
-END
-
-VERNAC COMMAND EXTEND FunctionalScheme
- [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for"
- ident(c) "with" ne_ident_list(l) ]
- -> [ declareFunScheme c na l ]
-| [ "Old" "Functional" "Scheme" ident(na) ":=" "Induction" "for" ident (c) ]
- -> [ declareFunScheme c na [] ]
-END
-
-
-
-
-
-(*
-*** Local Variables: ***
-*** compile-command: "make -C ../.. contrib/funind/tacinv.cmo" ***
-*** tuareg-default-indent:1 ***
-*** tuareg-begin-indent:1 ***
-*** tuareg-let-indent:1 ***
-*** tuareg-match-indent:-1 ***
-*** tuareg-try-indent:1 ***
-*** tuareg-with-indent:1 ***
-*** tuareg-if-then-else-inden:1 ***
-*** fill-column: 78 ***
-*** indent-tabs-mode: nil ***
-*** test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v" ***
-*** End: ***
-*)
-
-
diff --git a/contrib/funind/tacinvutils.ml b/contrib/funind/tacinvutils.ml
deleted file mode 100644
index ce775e0b..00000000
--- a/contrib/funind/tacinvutils.ml
+++ /dev/null
@@ -1,284 +0,0 @@
-(* tacinvutils.ml *)
-(*s utilities *)
-
-(*i*)
-open Names
-open Util
-open Term
-open Termops
-open Coqlib
-open Pp
-open Printer
-open Inductiveops
-open Environ
-open Declarations
-open Nameops
-open Evd
-open Sign
-open Reductionops
-(*i*)
-
-(*s printing of constr -- 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" " ++ pr_lconstr c ++ str"\n")
-let prlistconstr lc = List.iter prconstr lc
-let prstr s = msg(str s)
-
-let prchr () = msg (str" (ret) \n")
-let prNamedConstr s c =
- begin
- msg(str "");
- msg(str(s^"==>\n ") ++ pr_lconstr c ++ str "\n<==\n");
- msg(str "");
- end
-
-let prNamedLConstr_aux lc =
- List.iter (prNamedConstr "#>") lc
-
-let prNamedLConstr s lc =
- begin
- prstr s;
- prNamedLConstr_aux lc
- end
-
-
-(* FIXME: ref 1, pas bon, si? *)
-let evarcpt = ref 0
-let metacpt = ref 0
-let mknewexist ()=
- begin
- evarcpt := !evarcpt+1;
- !evarcpt,[||]
- end
-
-let resetexist ()= evarcpt := 0
-
-let mknewmeta ()=
- begin
- metacpt := !metacpt+1;
- mkMeta (!metacpt)
- end
-
-let resetmeta () = metacpt := 0
-
-let rec mkevarmap_from_listex lex =
- match lex with
- | [] -> Evd.empty
- | ((ex,_),typ)::lex' ->
-(* let _ = prstr "mkevarmap" in
- let _ = prstr ("evar n. " ^ string_of_int ex ^ " ") in
- let _ = prstr "OF TYPE: " in
- let _ = prconstr typ in*)
- let info = {
- evar_concl = typ;
- evar_hyps = empty_named_context_val;
- evar_body = Evar_empty;
- evar_extra = None} in
- Evd.add (mkevarmap_from_listex lex') ex info
-
-let mkEq typ c1 c2 =
- mkApp (build_coq_eq(),[| typ; c1; c2|])
-
-let mkRefl typ c1 =
- mkApp ((build_coq_eq_data()).refl, [| typ; c1|])
-
-let rec popn i c = if i<=0 then c else pop (popn (i-1) c)
-
-
-(* Operations on names *)
-let id_of_name = function
- Anonymous -> id_of_string "H"
- | Name id -> id;;
-let string_of_name nme = string_of_id (id_of_name nme)
-let name_of_string str = Name (id_of_string str)
-let newname_append nme str =
- Name(id_of_string ((string_of_id (id_of_name nme))^str))
-
-(* 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 apply_eqtrpl eq t =
- let r,(tb,b,by_t) = eq in
- substitterm 0 b by_t t
-
-let apply_eqtrpl_lt lt eq = List.map (apply_eqtrpl eq) lt
-
-let apply_leqtrpl_t t leq =
- List.fold_left (fun x y -> apply_eqtrpl y x) t leq
-
-
-let apply_refl_term eq t =
- let _,arr = destApp eq in
- let reli= (Array.get arr 1) in
- let by_t= (Array.get arr 2) in
- substitterm 0 reli by_t t
-
-let apply_eq_leqtrpl leq eq =
- List.map
- (function (r,(tb,b,t)) ->
- r,(tb,
- (if isRel b then b else (apply_refl_term eq b)), apply_refl_term eq t))
- leq
-
-
-
-(* [(a b c) a] -> true *)
-let constr_head_match u t=
- if isApp u
- then
- let uhd,args= destApp u in
- uhd=t
- else false
-
-(* My operations on constr *)
-let lift1L l = (List.map (lift 1) l)
-let mkArrow_lift t1 t2 = mkArrow t1 (lift 1 t2)
-let mkProd_liftc nme c1 c2 = mkProd (nme,c1,(lift 1 c2))
-(* prod_it_lift x [a1 a2 ...] *)
-let prod_it_lift ini lcpl =
- List.fold_right (function a,b -> (fun c -> mkProd_liftc a b c)) ini lcpl;;
-
-let prod_it_anonym_lift trm lst = List.fold_right mkArrow_lift lst trm
-
-let lam_it_anonymous trm lst =
- List.fold_right
- (fun elt res -> mkLambda(Name(id_of_string "Hrec"),elt,res)) lst trm
-
-let lambda_id id typeofid cstr =
- let cstr' = mkNamedLambda (id_of_string "FUNX") typeofid cstr in
- substitterm 0 id (mkRel 0) cstr'
-
-let prod_id id typeofid cstr =
- let cstr' = mkNamedProd (id_of_string "FUNX") typeofid cstr in
- substitterm 0 id (mkRel 0) cstr'
-
-
-
-
-
-let nth_dep_constructor indtype n =
- let sigma = Evd.empty and env = Global.env() in
- let indtypedef = find_rectype env sigma indtype in
- let indfam,_ = dest_ind_type indtypedef in
- let arr_cstr_summary = get_constructors env indfam in
- let cstr_sum = Array.get arr_cstr_summary n in
- build_dependent_constructor cstr_sum, cstr_sum.cs_nargs
-
-
-let rec buildrefl_from_eqs eqs =
- match eqs with
- | [] -> []
- | cstr::eqs' ->
- let eq,args = destApp cstr in
- (mkRefl (Array.get args 0) (Array.get args 2))
- :: (buildrefl_from_eqs eqs')
-
-
-
-
-(* list of occurrences of a term inside another *)
-(* Cofix will be wrong, not sure Fix is correct too *)
-let rec hdMatchSub u t=
- let subres =
- match kind_of_term u with
- | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> hdMatchSub (lift 1 cstr) t
- | Fix (_,(lna,tl,bl)) ->
- Array.fold_left
- (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) t)
- [] bl
- | LetIn _ -> assert false
- (* Correct? *)
- | _ -> fold_constr (fun l cstr -> l @ hdMatchSub cstr t) [] u
- in
- if constr_head_match u t then u :: subres else subres
-
-
-(* let hdMatchSub_list u lt = List.flatten (List.map (hdMatchSub u) lt) *)
-let hdMatchSub_cpl u (d,f) =
- let res = ref [] in
- begin
- for i = d to f do res := hdMatchSub u (mkRel i) @ !res done;
- !res
- end
-
-
-(* destApplication raises an exception if [t] is not an application *)
-let exchange_hd_prod subst_hd t =
- let hd,args= destApplication t in mkApp (subst_hd,args)
-
-(* substitute t by by_t in head of products inside in_u, reduces each
- product found *)
-let rec substit_red prof t by_t in_u =
- if constr_head_match in_u (lift prof t)
- then
- let x = whd_beta (exchange_hd_prod (lift prof by_t) in_u) in
- x
- else
- map_constr_with_binders succ (fun i u -> substit_red i t by_t u) prof in_u
-
-(* [exchange_reli_arrayi t=(reli x y ...) tarr (d,f)] exchange each
- reli by tarr.(f-i). *)
-let exchange_reli_arrayi tarr (d,f) t =
- let hd,args= destApp t in
- let i = destRel hd in
- let res = whd_beta (mkApp (tarr.(f-i) ,args)) in
- res
-
-let exchange_reli_arrayi_L tarr (d,f) =
- List.map (exchange_reli_arrayi tarr (d,f))
-
-
-(* expand all letins in a term, before building the principle. *)
-let rec expand_letins mimick =
- match kind_of_term mimick with
- | LetIn(nme,cstr1, typ, cstr) ->
- let cstr' = substitterm 0 (mkRel 1) (lift 1 cstr1) cstr in
- expand_letins (pop cstr')
- | x -> map_constr expand_letins mimick
-
-
-(* Valeur d'une constante, or identity *)
-let def_of_const t =
- match kind_of_term t with
- | Const sp ->
- (try
- match Global.lookup_constant sp with
- {const_body=Some c} -> force c
- |_ -> assert false
- with _ -> assert false)
- | _ -> t
-
-(* nom d'une constante. Must be a constante. x*)
-let name_of_const t =
- match (kind_of_term t) with
- Const cst -> Names.string_of_label (Names.con_label cst)
- |_ -> assert false
- ;;
-
-
-(*i
-*** Local Variables:
-*** compile-command: "make -k tacinvutils.cmo"
-*** test-tactic: "../../bin/coqtop -translate -q -batch -load-vernac-source ../../test-suite/success/Funind.v"
-*** End:
-i*)
-
diff --git a/contrib/funind/tacinvutils.mli b/contrib/funind/tacinvutils.mli
deleted file mode 100644
index 64b21213..00000000
--- a/contrib/funind/tacinvutils.mli
+++ /dev/null
@@ -1,80 +0,0 @@
-(* tacinvutils.ml *)
-(*s utilities *)
-
-(*i*)
-open Termops
-open Equality
-open Names
-open Pp
-open Tacmach
-open Proof_type
-open Tacinterp
-open Tactics
-open Tacticals
-open Term
-open Util
-open Printer
-open Reductionops
-open Inductiveops
-open Coqlib
-open Refine
-open Evd
-(*i*)
-
-(* printing debugging *)
-val prconstr: constr -> unit
-val prlistconstr: constr list -> unit
-val prNamedConstr:string -> constr -> unit
-val prNamedLConstr:string -> constr list -> unit
-val prstr: string -> unit
-
-
-val mknewmeta: unit -> constr
-val mknewexist: unit -> existential
-val resetmeta: unit -> unit (* safe *)
-val resetexist: unit -> unit (* be careful with this one *)
-val mkevarmap_from_listex: (Term.existential * Term.types) list -> evar_map
-val mkEq: types -> constr -> constr -> constr
-(* let mkEq typ c1 c2 = mkApp (build_coq_eq_data.eq(),[| typ; c1; c2|]) *)
-val mkRefl: types -> constr -> constr
-val buildrefl_from_eqs: constr list -> constr list
-(* typ c1 = mkApp ((constant ["Coq"; "Init"; "Logic"] "refl_equal"), [| typ; c1|]) *)
-
-val nth_dep_constructor: constr -> int -> (constr*int)
-
-val prod_it_lift: (name*constr) list -> constr -> constr
-val prod_it_anonym_lift: constr -> constr list -> constr
-val lam_it_anonymous: constr -> constr list -> constr
-val lift1L: (constr list) -> constr list
-val popn: int -> constr -> constr
-val lambda_id: constr -> constr -> constr -> constr
-val prod_id: constr -> constr -> constr -> constr
-
-
-val name_of_string : string -> name
-val newname_append: name -> string -> name
-
-val apply_eqtrpl: constr*(constr*constr*constr) -> constr -> constr
-val substitterm: int -> constr -> constr -> constr -> constr
-val apply_leqtrpl_t:
- constr -> (constr*(constr*constr*constr)) list -> constr
-val apply_eq_leqtrpl:
- (constr*(constr*constr*constr)) list -> constr -> (constr*(constr*constr*constr)) list
-(* val apply_leq_lt: constr list -> constr list -> constr list *)
-
-val hdMatchSub: constr -> constr -> constr list
-val hdMatchSub_cpl: constr -> int*int -> constr list
-val exchange_hd_prod: constr -> constr -> constr
-val exchange_reli_arrayi_L: constr array -> int*int -> constr list -> constr list
-val substit_red: int -> constr -> constr -> constr -> constr
-val expand_letins: constr -> constr
-
-val def_of_const: constr -> constr
-val name_of_const: constr -> string
-
-(*i
- *** Local Variables: ***
- *** compile-command: "make -C ../.. contrib/funind/tacinvutils.cmi" ***
- *** End: ***
-i*)
-
diff --git a/contrib/interface/COPYRIGHT b/contrib/interface/COPYRIGHT
index 2fb11c6b..23aeb6bb 100644
--- a/contrib/interface/COPYRIGHT
+++ b/contrib/interface/COPYRIGHT
@@ -1,8 +1,9 @@
(*****************************************************************************)
(* *)
-(* Coq support for the Pcoq Graphical Interface of Coq *)
+(* Coq support for the Pcoq and tmEgg Graphical Interfaces of Coq *)
(* *)
(* Copyright (C) 1999-2004 INRIA Sophia-Antipolis (Lemme team) *)
+(* Copyright (C) 2006,2007 Lionel Elie Mamane *)
(* *)
(*****************************************************************************)
@@ -10,6 +11,9 @@ The current directory contrib/interface implements Coq support for the
Pcoq Graphical Interface of Coq. It has been developed by Yves Bertot
with contributions from Loïc Pottier and Laurence Rideau.
+Modifications by Lionel Elie Mamane <lionel@mamane.lu> for
+generalising the protocol to suit other Coq interfaces.
+
The Pcoq Graphical Interface (see http://www-sop.inria.fr/lemme/pcoq)
is developed by the Lemme team at INRIA Sophia-Antipolis (see
http://www-sop.inria.fr/lemme)
diff --git a/contrib/interface/ascent.mli b/contrib/interface/ascent.mli
index ef1d095e..32338523 100644
--- a/contrib/interface/ascent.mli
+++ b/contrib/interface/ascent.mli
@@ -113,7 +113,6 @@ and ct_COMMAND =
| CT_module_type_decl of ct_ID * ct_MODULE_BINDER_LIST * ct_MODULE_TYPE_OPT
| CT_no_inline of ct_ID_NE_LIST
| CT_omega_flag of ct_OMEGA_MODE * ct_OMEGA_FEATURE
- | CT_opaque of ct_ID_NE_LIST
| CT_open_scope of ct_ID
| CT_print
| CT_print_about of ct_ID
@@ -189,13 +188,13 @@ and ct_COMMAND =
| CT_show_script
| CT_show_tree
| CT_solve of ct_INT * ct_TACTIC_COM * ct_DOTDOT_OPT
+ | CT_strategy of ct_LEVEL_LIST
| CT_suspend
| CT_syntax_macro of ct_ID * ct_FORMULA * ct_INT_OPT
| CT_tactic_definition of ct_TAC_DEF_NE_LIST
| CT_test_natural_feature of ct_NATURAL_FEATURE * ct_ID
| CT_theorem_struct of ct_THEOREM_GOAL * ct_PROOF_SCRIPT
| CT_time of ct_COMMAND
- | CT_transparent of ct_ID_NE_LIST
| CT_undo of ct_INT_OPT
| CT_unfocus
| CT_unset_option of ct_TABLE
@@ -204,6 +203,12 @@ and ct_COMMAND =
| CT_user_vernac of ct_ID * ct_VARG_LIST
| CT_variable of ct_VAR * ct_BINDER_NE_LIST
| CT_write_module of ct_ID * ct_STRING_OPT
+and ct_LEVEL_LIST =
+ CT_level_list of (ct_LEVEL * ct_ID_LIST) list
+and ct_LEVEL =
+ CT_Opaque
+ | CT_Level of ct_INT
+ | CT_Expand
and ct_COMMAND_LIST =
CT_command_list of ct_COMMAND * ct_COMMAND list
and ct_COMMENT =
diff --git a/contrib/interface/blast.ml b/contrib/interface/blast.ml
index dc27cf98..6ec0fac4 100644
--- a/contrib/interface/blast.ml
+++ b/contrib/interface/blast.ml
@@ -151,7 +151,7 @@ let pp_string x =
let unify_e_resolve (c,clenv) gls =
let clenv' = connect_clenv gls clenv in
let _ = clenv_unique_resolver false clenv' gls in
- vernac_e_resolve_constr c gls
+ Hiddentac.h_simplest_eapply c gls
let rec e_trivial_fail_db db_list local_db goal =
let tacl =
@@ -161,33 +161,36 @@ let rec e_trivial_fail_db db_list local_db goal =
let d = pf_last_hyp g' in
let hintl = make_resolve_hyp (pf_env g') (project g') d in
(e_trivial_fail_db db_list
- (Hint_db.add_list hintl local_db) g'))) ::
+ (add_hint_list hintl local_db) g'))) ::
(List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
in
tclFIRST (List.map tclCOMPLETE tacl) goal
and e_my_find_search db_list local_db hdc concl =
let hdc = head_of_constr_reference hdc in
+ let flags = Auto.auto_unif_flags in
let hintl =
if occur_existential concl then
- list_map_append (Hint_db.map_all hdc) (local_db::db_list)
+ list_map_append (fun (st, db) -> List.map (fun x -> ({flags with Unification.modulo_delta = st}, x))
+ (Hint_db.map_all hdc db)) (local_db::db_list)
else
- list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list)
+ list_map_append (fun (st, db) -> List.map (fun x -> ({flags with Unification.modulo_delta = st}, x))
+ (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
in
let tac_of_hint =
- fun ({pri=b; pat = p; code=t} as _patac) ->
+ fun (st, ({pri=b; pat = p; code=t} as _patac)) ->
(b,
let tac =
match t with
- | Res_pf (term,cl) -> unify_resolve (term,cl)
+ | Res_pf (term,cl) -> unify_resolve st (term,cl)
| ERes_pf (term,cl) -> unify_e_resolve (term,cl)
| Give_exact (c) -> e_give_exact_constr c
| Res_pf_THEN_trivial_fail (term,cl) ->
tclTHEN (unify_e_resolve (term,cl))
(e_trivial_fail_db db_list local_db)
- | Unfold_nth c -> unfold_in_concl [[],c]
+ | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
| Extern tacast -> Auto.conclPattern concl
- (out_some p) tacast
+ (Option.get p) tacast
in
(free_try tac,fmt_autotactic t))
(*i
@@ -227,8 +230,8 @@ module MySearchProblem = struct
depth : int; (*r depth of search before failing *)
tacres : goal list sigma * validation;
last_tactic : std_ppcmds;
- dblist : Auto.Hint_db.t list;
- localdb : Auto.Hint_db.t list }
+ dblist : Auto.hint_db list;
+ localdb : Auto.hint_db list }
let success s = (sig_it (fst s.tacres)) = []
@@ -242,9 +245,6 @@ module MySearchProblem = struct
with e when Logic.catchable_exception e ->
filter_tactics (glls,v) tacl
- let rec list_addn n x l =
- if n = 0 then l else x :: (list_addn (pred n) x l)
-
(* Ordering of states is lexicographic on depth (greatest first) then
number of remaining goals. *)
let compare s s' =
@@ -279,7 +279,7 @@ module MySearchProblem = struct
let hintl =
make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
in
- let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
+ let ldb = add_hint_list hintl (List.hd s.localdb) in
{ depth = s.depth; tacres = res;
last_tactic = pp; dblist = s.dblist;
localdb = ldb :: List.tl s.localdb })
@@ -337,7 +337,7 @@ let e_breadth_search debug n db_list local_db gl =
with Not_found -> error "EAuto: breadth first search failed"
let e_search_auto debug (n,p) db_list gl =
- let local_db = make_local_hint_db [] gl in
+ let local_db = make_local_hint_db true [] gl in
if n = 0 then
e_depth_search debug p db_list local_db gl
else
@@ -357,7 +357,7 @@ let full_eauto debug n gl =
let dbnames = current_db_names () in
let dbnames = list_subtract dbnames ["v62"] in
let db_list = List.map searchtable_map dbnames in
- let _local_db = make_local_hint_db [] gl in
+ let _local_db = make_local_hint_db true [] gl in
tclTRY (e_search_auto debug n db_list) gl
let my_full_eauto n gl = full_eauto false (n,0) gl
@@ -375,7 +375,7 @@ let rec trivial_fail_db db_list local_db gl =
tclTHEN intro
(fun g'->
let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
- in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g')
+ in trivial_fail_db db_list (add_hint_list hintl local_db) g')
in
tclFIRST
(assumption::intro_tac::
@@ -383,27 +383,29 @@ let rec trivial_fail_db db_list local_db gl =
(trivial_resolve db_list local_db (pf_concl gl)))) gl
and my_find_search db_list local_db hdc concl =
+ let flags = Auto.auto_unif_flags in
let tacl =
if occur_existential concl then
- list_map_append (fun db -> Hint_db.map_all hdc db) (local_db::db_list)
+ list_map_append (fun (st, db) -> List.map (fun x -> {flags with Unification.modulo_delta = st}, x)
+ (Hint_db.map_all hdc db)) (local_db::db_list)
else
- list_map_append (fun db -> Hint_db.map_auto (hdc,concl) db)
- (local_db::db_list)
+ list_map_append (fun (st, db) -> List.map (fun x -> {flags with Unification.modulo_delta = st}, x)
+ (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list)
in
List.map
- (fun ({pri=b; pat=p; code=t} as _patac) ->
+ (fun (st, {pri=b; pat=p; code=t} as _patac) ->
(b,
match t with
- | Res_pf (term,cl) -> unify_resolve (term,cl)
+ | Res_pf (term,cl) -> unify_resolve st (term,cl)
| ERes_pf (_,c) -> (fun gl -> error "eres_pf")
| Give_exact c -> exact_check c
| Res_pf_THEN_trivial_fail (term,cl) ->
tclTHEN
- (unify_resolve (term,cl))
+ (unify_resolve st (term,cl))
(trivial_fail_db db_list local_db)
- | Unfold_nth c -> unfold_in_concl [[],c]
+ | Unfold_nth c -> unfold_in_concl [all_occurrences,c]
| Extern tacast ->
- conclPattern concl (out_some p) tacast))
+ conclPattern concl (Option.get p) tacast))
tacl
and trivial_resolve db_list local_db cl =
@@ -470,11 +472,12 @@ let rec search_gen decomp n db_list local_db extra_sign goal =
try
[make_apply_entry (pf_env g') (project g')
(true,false)
- (mkVar hid,body_of_type htyp)]
+ None
+ (mkVar hid,htyp)]
with Failure _ -> []
in
(free_try
- (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d])
+ (search_gen decomp n db_list (add_hint_list hintl local_db) [d])
g'))
in
let rec_tacs =
@@ -497,7 +500,7 @@ let full_auto n gl =
let dbnames = list_subtract dbnames ["v62"] in
let db_list = List.map searchtable_map dbnames in
let hyps = pf_hyps gl in
- tclTRY (search n db_list (make_local_hint_db [] gl) hyps) gl
+ tclTRY (search n db_list (make_local_hint_db false [] gl) hyps) gl
let default_full_auto gl = full_auto !default_search_depth gl
(************************************************************************)
diff --git a/contrib/interface/centaur.ml4 b/contrib/interface/centaur.ml4
index 730e055b..a4dc0eac 100644
--- a/contrib/interface/centaur.ml4
+++ b/contrib/interface/centaur.ml4
@@ -1,11 +1,28 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
+(*
+ * This file has been modified by Lionel Elie Mamane <lionel@mamane.lu>
+ * to implement the following features
+ * - Terms (optionally) as pretty-printed string and not trees
+ * - (Optionally) give most commands their usual Coq semantics
+ * - Add the backtracking information to the status message.
+ * in the following time period
+ * - May-November 2006
+ * and
+ * - Make use of new Command.save_hook to generate dependencies at
+ * save-time.
+ * in
+ * - June 2007
+ *)
+
(*Toplevel loop for the communication between Coq and Centaur *)
open Names;;
open Nameops;;
open Util;;
open Term;;
open Pp;;
+open Ppconstr;;
+open Prettyp;;
open Libnames;;
open Libobject;;
open Library;;
@@ -43,6 +60,7 @@ open Showproof;;
open Showproof_ct;;
open Tacexpr;;
open Vernacexpr;;
+open Printer;;
let pcoq_started = ref None;;
@@ -51,6 +69,11 @@ let if_pcoq f a =
let text_proof_flag = ref "en";;
+let pcoq_history = ref true;;
+
+let assert_pcoq_history f a =
+ if !pcoq_history then f a else error "Pcoq-style history tracking deactivated";;
+
let current_proof_name () =
try
string_of_id (get_current_proof_name ())
@@ -85,10 +108,33 @@ let kill_proof_node index =
History.border_length (current_proof_name());;
+type vtp_tree =
+ | P_rl of ct_RULE_LIST
+ | P_r of ct_RULE
+ | P_s_int of ct_SIGNED_INT_LIST
+ | P_pl of ct_PREMISES_LIST
+ | P_cl of ct_COMMAND_LIST
+ | P_t of ct_TACTIC_COM
+ | P_text of ct_TEXT
+ | P_ids of ct_ID_LIST;;
+
+let print_tree t =
+ (match t with
+ | P_rl x -> fRULE_LIST x
+ | P_r x -> fRULE x
+ | P_s_int x -> fSIGNED_INT_LIST x
+ | P_pl x -> fPREMISES_LIST x
+ | P_cl x -> fCOMMAND_LIST x
+ | P_t x -> fTACTIC_COM x
+ | P_text x -> fTEXT x
+ | P_ids x -> fID_LIST x)
+ ++ (str "e\nblabla\n");;
+
+
(*Message functions, the text of these messages is recognized by the protocols *)
(*of CtCoq *)
let ctf_header message_name request_id =
- fnl () ++ str "message" ++ fnl() ++ str message_name ++ fnl() ++
+ str "message" ++ fnl() ++ str message_name ++ fnl() ++
int request_id ++ fnl();;
let ctf_acknowledge_command request_id command_count opt_exn =
@@ -97,14 +143,20 @@ let ctf_acknowledge_command request_id command_count opt_exn =
let g_count =
List.length
(fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in
- g_count, (min g_count !current_goal_index)
+ g_count, !current_goal_index
else
- (0, 0) in
+ (0, 0)
+ and statnum = Lib.current_command_label ()
+ and dpth = let d = Pfedit.current_proof_depth() in if d >= 0 then d else 0
+ and pending = CT_id_list (List.map xlate_ident (Pfedit.get_all_proof_names())) in
(ctf_header "acknowledge" request_id ++
int command_count ++ fnl() ++
int goal_count ++ fnl () ++
int goal_index ++ fnl () ++
str (current_proof_name()) ++ fnl() ++
+ int statnum ++ fnl() ++
+ print_tree (P_ids pending) ++
+ int dpth ++ fnl() ++
(match opt_exn with
Some e -> Cerrors.explain_exn e
| None -> mt ()) ++ fnl() ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ());;
@@ -126,6 +178,8 @@ let ctf_PathGoalMessage () =
let ctf_GoalReqIdMessage = ctf_header "single_goal_state";;
+let ctf_GoalsReqIdMessage = ctf_header "goals_state";;
+
let ctf_NewStateMessage = ctf_header "fresh_state";;
let ctf_SavedMessage () = fnl () ++ str "message" ++ fnl () ++
@@ -153,39 +207,16 @@ let ctf_ResetIdentMessage request_id s =
ctf_header "reset_ident" request_id ++ str s ++ fnl () ++
str "E-n-d---M-e-s-s-a-g-e" ++ fnl();;
-type vtp_tree =
- | P_rl of ct_RULE_LIST
- | P_r of ct_RULE
- | P_s_int of ct_SIGNED_INT_LIST
- | P_pl of ct_PREMISES_LIST
- | P_cl of ct_COMMAND_LIST
- | P_t of ct_TACTIC_COM
- | P_text of ct_TEXT
- | P_ids of ct_ID_LIST;;
-
-let print_tree t =
- (match t with
- | P_rl x -> fRULE_LIST x
- | P_r x -> fRULE x
- | P_s_int x -> fSIGNED_INT_LIST x
- | P_pl x -> fPREMISES_LIST x
- | P_cl x -> fCOMMAND_LIST x
- | P_t x -> fTACTIC_COM x
- | P_text x -> fTEXT x
- | P_ids x -> fID_LIST x);
- print_string "e\nblabla\n";;
-
-
let break_happened = ref false;;
let output_results stream vtp_tree =
let _ = Sys.signal Sys.sigint
(Sys.Signal_handle(fun i -> (break_happened := true;()))) in
- msg stream;
- match vtp_tree with
- Some t -> print_tree t
- | None -> ();;
+ msg (stream ++
+ (match vtp_tree with
+ Some t -> print_tree t
+ | None -> mt()));;
let output_results_nl stream =
let _ = Sys.signal Sys.sigint
@@ -221,20 +252,18 @@ let print_past_goal index =
let show_nth n =
try
- let pf = proof_of_pftreestate (get_pftreestate()) in
- if (!text_proof_flag<>"off") then
- (if n=0
- then output_results (ctf_TextMessage !global_request_id)
- (Some (P_text (show_proof !text_proof_flag [])))
- else
- let path = History.get_nth_open_path (current_proof_name()) n in
- output_results (ctf_TextMessage !global_request_id)
- (Some (P_text (show_proof !text_proof_flag path))))
- else
- output_results (ctf_GoalReqIdMessage !global_request_id)
- (let goal = List.nth (fst (frontier pf))
- (n - 1) in
- (Some (P_r (translate_goal goal))))
+ output_results (ctf_GoalReqIdMessage !global_request_id
+ ++ pr_nth_open_subgoal n)
+ None
+ with
+ | Invalid_argument s ->
+ error "No focused proof (No proof-editing in progress)";;
+
+let show_subgoals () =
+ try
+ output_results (ctf_GoalReqIdMessage !global_request_id
+ ++ pr_open_subgoals ())
+ None
with
| Invalid_argument s ->
error "No focused proof (No proof-editing in progress)";;
@@ -275,39 +304,24 @@ let ctf_EmptyGoalMessage id =
fnl () ++ str "Empty Goal is a no-op. Fun oh fun." ++ fnl ();;
-let print_check judg =
- let {uj_val=value; uj_type=typ} = judg in
- let value_ct_ast =
- (try translate_constr false (Global.env()) value
- with UserError(f,str) ->
- raise(UserError(f,Printer.pr_lconstr value ++
- fnl () ++ str ))) in
- let type_ct_ast =
- (try translate_constr false (Global.env()) typ
- with UserError(f,str) ->
- raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in
- ((ctf_SearchResults !global_request_id),
- (Some (P_pl
- (CT_premises_list
- [CT_coerce_TYPED_FORMULA_to_PREMISE
- (CT_typed_formula(value_ct_ast,type_ct_ast)
- )]))));;
-
-let ct_print_eval ast red_fun env judg =
-((if refining() then traverse_to []);
-let {uj_val=value; uj_type=typ} = judg in
-let nvalue = red_fun value
-(* // Attention , ici il faut peut être utiliser des environnemenst locaux *)
-and ntyp = nf_betaiota typ in
-(ctf_SearchResults !global_request_id,
- Some (P_pl
- (CT_premises_list
- [CT_eval_result
- (xlate_formula ast,
- translate_constr false env nvalue,
- translate_constr false env ntyp)]))));;
-
-
+let print_check env judg =
+ ((ctf_SearchResults !global_request_id) ++
+ print_judgment env judg,
+ None);;
+
+let ct_print_eval red_fun env evmap ast judg =
+ (if refining() then traverse_to []);
+ let {uj_val=value; uj_type=typ} = judg in
+ let nvalue = (red_fun env evmap) value
+ (* // Attention , ici il faut peut être utiliser des environnemenst locaux *)
+ and ntyp = nf_betaiota typ in
+ print_tree
+ (P_pl
+ (CT_premises_list
+ [CT_eval_result
+ (xlate_formula ast,
+ translate_constr false env nvalue,
+ translate_constr false env ntyp)]));;
let pbp_tac_pcoq =
pbp_tac (function (x:raw_tactic_expr) ->
@@ -330,6 +344,7 @@ let dad_tac_pcoq =
</cpa> *)
let search_output_results () =
+ (* LEM: See comments for pcoq_search *)
output_results
(ctf_SearchResults !global_request_id)
(Some (P_pl (CT_premises_list
@@ -393,7 +408,7 @@ let inspect n =
oname, Lib.Leaf lobj ->
(match oname, object_tag lobj with
(sp,_), "VARIABLE" ->
- let (_, _, v) = get_variable (basename sp) in
+ let (_, _, v) = Global.lookup_named (basename sp) in
add_search2 (Nametab.locate (qualid_of_sp sp)) v
| (sp,kn), "CONSTANT" ->
let typ = Typeops.type_of_constant (Global.env()) (constant_of_kn kn) in
@@ -491,19 +506,19 @@ VERNAC COMMAND EXTEND OutputGoal
END
VERNAC COMMAND EXTEND OutputGoal
- [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ simulate_solve n tac ]
+ [ "Goal" "Cmd" natural(n) "with" tactic(tac) ] -> [ assert_pcoq_history (simulate_solve n) tac ]
END
VERNAC COMMAND EXTEND KillProofAfter
-| [ "Kill" "Proof" "after" natural(n) ] -> [ kill_node_verbose n ]
+| [ "Kill" "Proof" "after" natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ]
END
VERNAC COMMAND EXTEND KillProofAt
-| [ "Kill" "Proof" "at" natural(n) ] -> [ kill_node_verbose n ]
+| [ "Kill" "Proof" "at" natural(n) ] -> [ assert_pcoq_history kill_node_verbose n ]
END
VERNAC COMMAND EXTEND KillSubProof
- [ "Kill" "SubProof" natural(n) ] -> [ logical_kill n ]
+ [ "Kill" "SubProof" natural(n) ] -> [ assert_pcoq_history logical_kill n ]
END
VERNAC COMMAND EXTEND PcoqReset
@@ -515,18 +530,17 @@ VERNAC COMMAND EXTEND PcoqResetInitial
END
let start_proof_hook () =
- History.start_proof (current_proof_name());
+ if !pcoq_history then History.start_proof (current_proof_name());
current_goal_index := 1
let solve_hook n =
- let name = current_proof_name () in
- let old_n_count = History.border_length name in
- let pf = proof_of_pftreestate (get_pftreestate ()) in
- let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in
- begin
- current_goal_index := n;
- History.push_command name n n_goals
- end
+ current_goal_index := n;
+ if !pcoq_history then
+ let name = current_proof_name () in
+ let old_n_count = History.border_length name in
+ let pf = proof_of_pftreestate (get_pftreestate ()) in
+ let n_goals = (List.length (fst (frontier pf))) + 1 - old_n_count in
+ History.push_command name n n_goals
let abort_hook s = output_results_nl (ctf_AbortedMessage !global_request_id s)
@@ -535,6 +549,12 @@ let interp_search_about_item = function
| SearchString s -> GlobSearchString s
let pcoq_search s l =
+ (* LEM: I don't understand why this is done in this way (redoing the
+ * match on s here) instead of making the code in
+ * parsing/search.ml call the right function instead of
+ * "plain_display". Investigates this later.
+ * TODO
+ *)
ctv_SEARCH_LIST:=[];
begin match s with
| SearchAbout sl ->
@@ -581,27 +601,25 @@ let hyp_search_pattern c l =
(Some
(P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));;
let pcoq_print_name ref =
- let results = xlate_vernac_list (name_to_ast ref) in
output_results
- (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl ())
- (Some (P_cl results))
+ (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl () ++ print_name ref )
+ None
-let pcoq_print_check j =
- let a,b = print_check j in output_results a b
+let pcoq_print_check env j =
+ let a,b = print_check env j in output_results a b
-let pcoq_print_eval redfun env c j =
- let strm, vtp = ct_print_eval c redfun env j in
- output_results strm vtp;;
+let pcoq_print_eval redfun env evmap c j =
+ output_results
+ (ctf_SearchResults !global_request_id
+ ++ Prettyp.print_eval redfun env evmap c j)
+ None;;
open Vernacentries
let pcoq_show_goal = function
| Some n -> show_nth n
- | None ->
- if !pcoq_started = Some true (* = debug *) then
- msg (Printer.pr_open_subgoals ())
- else errorlabstrm "show_goal"
- (str "Show must be followed by an integer in Centaur mode");;
+ | None -> show_subgoals ()
+;;
let pcoq_hook = {
start_proof = start_proof_hook;
@@ -614,6 +632,165 @@ let pcoq_hook = {
show_goal = pcoq_show_goal
}
+let pcoq_term_pr = {
+ pr_constr_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_constr_expr c));
+ (* In future translate_constr false (Global.env())
+ * Except with right bool/env which I'll get :)
+ *)
+ pr_lconstr_expr = (fun c -> fFORMULA (xlate_formula c) ++ str "(pcoq_lconstr_expr of " ++ (default_term_pr.pr_lconstr_expr c) ++ str ")");
+ pr_pattern_expr = (fun c -> str "pcoq_pattern_expr\n" ++ (default_term_pr.pr_pattern_expr c));
+ pr_lpattern_expr = (fun c -> str "pcoq_constr_expr\n" ++ (default_term_pr.pr_lpattern_expr c))
+}
+
+let start_pcoq_trees () =
+ set_term_pr pcoq_term_pr
+
+(* BEGIN functions for object_pr *)
+
+(* These functions in general mirror what name_to_ast does in a subcase,
+ and then print the corresponding object as a PCoq tree. *)
+
+let object_to_ast_template object_to_ast_list sp =
+ let l = object_to_ast_list sp in
+ VernacList (List.map (fun x -> (dummy_loc, x)) l)
+
+let pcoq_print_object_template object_to_ast_list sp =
+ let results = xlate_vernac_list (object_to_ast_template object_to_ast_list sp) in
+ print_tree (P_cl results)
+
+(* This function mirror what print_check does *)
+
+let pcoq_print_typed_value_in_env env (value, typ) =
+ let value_ct_ast =
+ (try translate_constr false (Global.env()) value
+ with UserError(f,str) ->
+ raise(UserError(f,Printer.pr_lconstr value ++
+ fnl () ++ str ))) in
+ let type_ct_ast =
+ (try translate_constr false (Global.env()) typ
+ with UserError(f,str) ->
+ raise(UserError(f, Printer.pr_lconstr value ++ fnl() ++ str))) in
+ print_tree
+ (P_pl
+ (CT_premises_list
+ [CT_coerce_TYPED_FORMULA_to_PREMISE
+ (CT_typed_formula(value_ct_ast,type_ct_ast)
+ )]))
+;;
+
+(* This function mirrors what show_nth does *)
+
+let pcoq_pr_subgoal n gl =
+ try
+ print_tree
+ (if (!text_proof_flag<>"off") then
+ (* This is a horrendeous hack; it ignores the "gl" argument
+ and just takes the currently focused proof. This will bite
+ us back one day.
+ TODO: Fix this.
+ *)
+ (
+ if not !pcoq_history then error "Text mode requires Pcoq history tracking.";
+ if n=0
+ then (P_text (show_proof !text_proof_flag []))
+ else
+ let path = History.get_nth_open_path (current_proof_name()) n in
+ (P_text (show_proof !text_proof_flag path)))
+ else
+ (let goal = List.nth gl (n - 1) in
+ (P_r (translate_goal goal))))
+ with
+ | Invalid_argument _
+ | Failure "nth"
+ | Not_found -> error "No such goal";;
+
+let pcoq_pr_subgoals close_cmd evar gl =
+ (*LEM: TODO: we should check for evar emptiness or not, and do something *)
+ try
+ print_tree
+ (if (!text_proof_flag<>"off") then
+ raise (Anomaly ("centaur.ml4:pcoq_pr_subgoals", str "Text mode show all subgoals not implemented"))
+ else
+ (P_rl (translate_goals gl)))
+ with
+ | Invalid_argument _
+ | Failure "nth"
+ | Not_found -> error "No such goal";;
+
+
+(* END functions for object_pr *)
+
+let pcoq_object_pr = {
+ print_inductive = pcoq_print_object_template inductive_to_ast_list;
+ (* TODO: Check what that with_infos means, and adapt accordingly *)
+ print_constant_with_infos = pcoq_print_object_template constant_to_ast_list;
+ print_section_variable = pcoq_print_object_template variable_to_ast_list;
+ print_syntactic_def = pcoq_print_object_template (fun x -> errorlabstrm "print"
+ (str "printing of syntax definitions not implemented in PCoq syntax"));
+ (* TODO: These are placeholders only; write them *)
+ print_module = (fun x y -> str "pcoq_print_module not implemented");
+ print_modtype = (fun x -> str "pcoq_print_modtype not implemented");
+ print_named_decl = (fun x -> str "pcoq_print_named_decl not implemented");
+ (* TODO: Find out what the first argument x (a bool) is about and react accordingly *)
+ print_leaf_entry = (fun x -> pcoq_print_object_template leaf_entry_to_ast_list);
+ print_library_entry = (fun x y -> Some (str "pcoq_print_library_entry not implemented"));
+ print_context = (fun x y z -> str "pcoq_print_context not implemented");
+ print_typed_value_in_env = pcoq_print_typed_value_in_env;
+ Prettyp.print_eval = ct_print_eval;
+};;
+
+let pcoq_printer_pr = {
+ pr_subgoals = pcoq_pr_subgoals;
+ pr_subgoal = pcoq_pr_subgoal;
+ pr_goal = (fun x -> str "pcoq_pr_goal not implemented");
+};;
+
+
+let start_pcoq_objects () =
+ set_object_pr pcoq_object_pr;
+ set_printer_pr pcoq_printer_pr
+
+let start_default_objects () =
+ set_object_pr default_object_pr;
+ set_printer_pr default_printer_pr
+
+let full_name_of_ref r =
+ (match r with
+ | VarRef _ -> str "VAR"
+ | ConstRef _ -> str "CST"
+ | IndRef _ -> str "IND"
+ | ConstructRef _ -> str "CSR")
+ ++ str " " ++ (pr_sp (Nametab.sp_of_global r))
+ (* LEM TODO: Cleanly separate path from id (see Libnames.string_of_path) *)
+
+let string_of_ref =
+ (*LEM TODO: Will I need the Var/Const/Ind/Construct info?*)
+ Depends.o Libnames.string_of_path Nametab.sp_of_global
+
+let print_depends compute_depends ptree =
+ output_results (List.fold_left (fun x y -> x ++ (full_name_of_ref y) ++ fnl())
+ (str "This object depends on:" ++ fnl())
+ (compute_depends ptree))
+ None
+
+let output_depends compute_depends ptree =
+ (* Using an ident list for that is arguably stretching it, but less effort than touching the vtp types *)
+ output_results (ctf_header "depends" !global_request_id ++
+ print_tree (P_ids (CT_id_list (List.map
+ (fun x -> CT_ident (string_of_ref x))
+ (compute_depends ptree)))))
+ None
+
+let gen_start_depends_dumps print_depends print_depends' print_depends'' print_depends''' =
+ Command.set_declare_definition_hook (print_depends' (Depends.depends_of_definition_entry ~acc:[]));
+ Command.set_declare_assumption_hook (print_depends (fun (c:types) -> Depends.depends_of_constr c []));
+ Command.set_start_hook (print_depends (fun c -> Depends.depends_of_constr c []));
+ Command.set_save_hook (print_depends'' (Depends.depends_of_pftreestate Depends.depends_of_pftree));
+ Refiner.set_solve_hook (print_depends''' (fun pt -> Depends.depends_of_pftree_head pt []))
+
+let start_depends_dumps () = gen_start_depends_dumps output_depends output_depends output_depends output_depends
+
+let start_depends_dumps_debug () = gen_start_depends_dumps print_depends print_depends print_depends print_depends
TACTIC EXTEND pbp
| [ "pbp" ident_opt(idopt) natural_list(nl) ] ->
@@ -635,7 +812,6 @@ let start_pcoq_mode debug =
(* <\cpa>
start_dad();
</cpa> *)
- declare_in_coq();
(* The following ones are added to enable rich comments in pcoq *)
(* TODO ...
add_tactic "Image" (fun _ -> tclIDTAC);
@@ -649,6 +825,8 @@ let start_pcoq_mode debug =
List.iter (fun (a,b) -> overwriting_vinterp_add a b) non_debug_changes;
*)
set_pcoq_hook pcoq_hook;
+ start_pcoq_objects();
+ Flags.print_emacs := false; Pp.make_pp_nonemacs();
end;;
@@ -681,3 +859,23 @@ END
VERNAC COMMAND EXTEND StartPcoqDebug
| [ "Start" "Pcoq" "Debug" "Mode" ] -> [ start_pcoq_debug () ]
END
+
+VERNAC COMMAND EXTEND StartPcoqTerms
+| [ "Start" "Pcoq" "Trees" ] -> [ start_pcoq_trees () ]
+END
+
+VERNAC COMMAND EXTEND StartPcoqObjects
+| [ "Start" "Pcoq" "Objects" ] -> [ start_pcoq_objects () ]
+END
+
+VERNAC COMMAND EXTEND StartDefaultObjects
+| [ "Start" "Default" "Objects" ] -> [ start_default_objects () ]
+END
+
+VERNAC COMMAND EXTEND StartDependencyDumps
+| [ "Start" "Dependency" "Dumps" ] -> [ start_depends_dumps () ]
+END
+
+VERNAC COMMAND EXTEND StopPcoqHistory
+| [ "Stop" "Pcoq" "History" ] -> [ pcoq_history := false ]
+END
diff --git a/contrib/interface/debug_tac.ml4 b/contrib/interface/debug_tac.ml4
index 890bb3ce..aad3a765 100644
--- a/contrib/interface/debug_tac.ml4
+++ b/contrib/interface/debug_tac.ml4
@@ -113,7 +113,7 @@ let count_subgoals2
let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function
TacThens (a,l) ->
(fun report_holder -> checked_thens report_holder a l)
- | TacThen (a,b) ->
+ | TacThen (a,[||],b,[||]) ->
(fun report_holder -> checked_then report_holder a b)
| t ->
(fun report_holder g ->
@@ -279,7 +279,7 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) =
| Failed n -> TacId []
| Tree_fail r -> reconstruct_success_tac a r
| Mismatch (n,p) -> a)
- | TacThen (a,b) ->
+ | TacThen (a,[||],b,[||]) ->
(function
Report_node(true, n, l) -> tac
| Report_node(false, n, rl) ->
@@ -340,7 +340,7 @@ Tacinterp.add_tactic "OnThen" on_then;;
let rec clean_path tac l =
match tac, l with
- | TacThen (a,b), fst::tl ->
+ | TacThen (a,[||],b,[||]), fst::tl ->
fst::(clean_path (if fst = 1 then a else b) tl)
| TacThens (a,l), 1::tl ->
1::(clean_path a tl)
@@ -390,7 +390,7 @@ let rec report_error
| t::tl -> (report_error t the_goal the_ast returned_path (n::2::path))::
(fold_num (n + 1) tl) in
fold_num 1 l)
- | TacThen (a,b) ->
+ | TacThen (a,[||],b,[||]) ->
let the_count = ref 1 in
tclTHEN
(fun g ->
@@ -398,7 +398,7 @@ let rec report_error
report_error a the_goal the_ast returned_path (1::path) g
with
e ->
- (the_ast := TacThen (!the_ast, b);
+ (the_ast := TacThen (!the_ast,[||], b,[||]);
raise e))
(fun g ->
try
diff --git a/contrib/interface/depends.ml b/contrib/interface/depends.ml
new file mode 100644
index 00000000..dd40c5cc
--- /dev/null
+++ b/contrib/interface/depends.ml
@@ -0,0 +1,454 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant *)
+(* <O___,, * *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1, *)
+(* * or (at your option) any later version. *)
+(************************************************************************)
+
+(* Copyright © 2007, Lionel Elie Mamane <lionel@mamane.lu> *)
+
+(* This 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 *)
+(* Lesser General Public License for more details. *)
+
+(* You should have received a copy of the GNU Lesser General Public *)
+(* License along with this library; if not, write to the Free Software *)
+(* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, *)
+(* MA 02110-1301, USA *)
+
+
+(* LEM TODO: a .mli file *)
+
+open Refiner
+open Proof_type
+open Rawterm
+open Term
+open Libnames
+open Util
+open Tacexpr
+open Entries
+
+(* DBG utilities, to be removed *)
+let print_bool b = print_string (string_of_bool b)
+let string_of_ppcmds p = Pp.pp_with Format.str_formatter p; Format.flush_str_formatter()
+let acc_str f = List.fold_left (fun a b -> a ^ (f b) ^ "+") "O"
+(* End utilities, to be removed *)
+
+let explore_tree pfs =
+ print_string "explore_tree called\n";
+ print_string "pfs is a top: ";
+ (* We expect yes. *)
+ print_string (if (is_top_pftreestate pfs) then "yes" else "no");
+ print_newline();
+ let rec explain_tree (pt:proof_tree) =
+ match pt.ref with
+ | None -> "none"
+ | Some (Prim p, l) -> "<Prim (" ^ (explain_prim p) ^ ") | " ^ (acc_str explain_tree l) ^ ">"
+ | Some (Nested (t,p), l) -> "<Nested (" ^ explain_compound t ^ ", " ^ (explain_tree p) ^ ") | " ^ (acc_str explain_tree l) ^ ">"
+ | Some (Decl_proof _, _) -> "Decl_proof"
+ | Some (Daimon, _) -> "Daimon"
+ and explain_compound cr =
+ match cr with
+ | Tactic (texp, b) -> "Tactic (" ^ (string_of_ppcmds (Tactic_printer.pr_tactic texp)) ^ ", " ^ (string_of_bool b) ^ ")"
+ | Proof_instr (b, instr) -> "Proof_instr (" ^ (string_of_bool b) ^ (string_of_ppcmds (Tactic_printer.pr_proof_instr instr)) ^ ")"
+ and explain_prim = function
+ | Refine c -> "Refine " ^ (string_of_ppcmds (Printer.prterm c))
+ | Intro identifier -> "Intro"
+ | Intro_replacing identifier -> "Intro_replacing"
+ | Cut (bool, identifier, types) -> "Cut"
+ | FixRule (identifier, int, l) -> "FixRule"
+ | Cofix (identifier, l) -> "Cofix"
+ | Convert_concl (types, cast_kind) -> "Convert_concl"
+ | Convert_hyp named_declaration -> "Convert_hyp"
+ | Thin identifier_list -> "Thin"
+ | ThinBody identifier_list -> "ThinBody"
+ | Move (bool, identifier, identifier') -> "Move"
+ | Rename (identifier, identifier') -> "Rename"
+ | Change_evars -> "Change_evars"
+ in
+ let pt = proof_of_pftreestate pfs in
+ (* We expect 0 *)
+ print_string "Number of open subgoals: ";
+ print_int pt.open_subgoals;
+ print_newline();
+ print_string "First rule is a ";
+ print_string (explain_tree pt);
+ print_newline()
+
+
+let o f g x = f (g x)
+let fst_of_3 (x, _, _) = x
+let snd_of_3 (_, x, _) = x
+let trd_of_3 (_, _, x) = x
+
+(* TODO: These for now return a Libnames.global_reference, but a
+ prooftree will also depend on things like tactic declarations, etc
+ so we may need a new type for that. *)
+let rec depends_of_hole_kind hk acc = match hk with
+ | Evd.ImplicitArg (gr,_) -> gr::acc
+ | Evd.TomatchTypeParameter (ind, _) -> (IndRef ind)::acc
+ | Evd.BinderType _
+ | Evd.QuestionMark _
+ | Evd.CasesType
+ | Evd.InternalHole
+ | Evd.GoalEvar
+ | Evd.ImpossibleCase -> acc
+
+let depends_of_'a_cast_type depends_of_'a act acc = match act with
+ | CastConv (ck, a) -> depends_of_'a a acc
+ | CastCoerce -> acc
+
+let depends_of_'a_bindings depends_of_'a ab acc = match ab with
+ | ImplicitBindings al -> list_union_map depends_of_'a al acc
+ | ExplicitBindings apl -> list_union_map (fun x y -> depends_of_'a (trd_of_3 x) y) apl acc
+ | NoBindings -> acc
+
+let depends_of_'a_with_bindings depends_of_'a (a, ab) acc =
+ depends_of_'a a (depends_of_'a_bindings depends_of_'a ab acc)
+
+(* let depends_of_constr_with_bindings = depends_of_'a_with_bindings depends_of_constr *)
+(* and depends_of_open_constr_with_bindings = depends_of_'a_with_bindings depends_of_open_let *)
+
+let depends_of_'a_induction_arg depends_of_'a aia acc = match aia with
+ | ElimOnConstr a -> depends_of_'a a acc
+ | ElimOnIdent _ ->
+ (* TODO: Check that this really refers only to an hypothesis (not a section variable, etc.)
+ * It *seems* thaat section variables are seen as hypotheses, so we have a problem :-(
+
+ * Plan: Load all section variables before anything in that
+ * section and call the user's proof script "brittle" and refuse
+ * to handle if it breaks because of that
+ *)
+ acc
+ | ElimOnAnonHyp _ -> acc
+
+let depends_of_'a_or_var depends_of_'a aov acc = match aov with
+ | ArgArg a -> depends_of_'a a acc
+ | ArgVar _ -> acc
+
+let depends_of_'a_with_occurences depends_of_'a (_,a) acc =
+ depends_of_'a a acc
+
+let depends_of_'a_'b_red_expr_gen depends_of_'a reg acc = match reg with
+ (* TODO: dirty assumption that the 'b doesn't make any dependency *)
+ | Red _
+ | Hnf
+ | Cbv _
+ | Lazy _
+ | Unfold _
+ | ExtraRedExpr _
+ | CbvVm -> acc
+ | Simpl awoo ->
+ Option.fold_right
+ (depends_of_'a_with_occurences depends_of_'a)
+ awoo
+ acc
+ | Fold al -> list_union_map depends_of_'a al acc
+ | Pattern awol ->
+ list_union_map
+ (depends_of_'a_with_occurences depends_of_'a)
+ awol
+ acc
+
+let depends_of_'a_'b_inversion_strength depends_of_'a is acc = match is with
+ (* TODO: dirty assumption that the 'b doesn't make any dependency *)
+ | NonDepInversion _ -> acc
+ | DepInversion (_, ao, _) -> Option.fold_right depends_of_'a ao acc
+ | InversionUsing (a, _) -> depends_of_'a a acc
+
+let depends_of_'a_pexistential depends_of_'a (_, aa) acc = array_union_map depends_of_'a aa acc
+
+let depends_of_named_vals nvs acc =
+ (* TODO: I'm stopping here because I have noooo idea what to do with values... *)
+ acc
+
+let depends_of_inductive ind acc = (IndRef ind)::acc
+
+let rec depends_of_constr c acc = match kind_of_term c with
+ | Rel _ -> acc
+ | Var id -> (VarRef id)::acc
+ | Meta _ -> acc
+ | Evar ev -> depends_of_'a_pexistential depends_of_constr ev acc
+ | Sort _ -> acc
+ | Cast (c, _, t) -> depends_of_constr c (depends_of_constr t acc)
+ | Prod (_, t, t') -> depends_of_constr t (depends_of_constr t' acc)
+ | Lambda (_, t, c) -> depends_of_constr t (depends_of_constr c acc)
+ | LetIn (_, c, t, c') -> depends_of_constr c (depends_of_constr t (depends_of_constr c' acc))
+ | App (c, ca) -> depends_of_constr c (array_union_map depends_of_constr ca acc)
+ | Const cnst -> (ConstRef cnst)::acc
+ | Ind ind -> (IndRef ind)::acc
+ | Construct cons -> (ConstructRef cons)::acc
+ | Case (_, c, c', ca) -> depends_of_constr c (depends_of_constr c' (array_union_map depends_of_constr ca acc))
+ | Fix (_, (_, ta, ca))
+ | CoFix (_, (_, ta, ca)) -> array_union_map depends_of_constr ca (array_union_map depends_of_constr ta acc)
+and depends_of_evar_map evm acc =
+ Evd.fold (fun ev evi -> depends_of_evar_info evi) evm acc
+and depends_of_evar_info evi acc =
+ (* TODO: evi.evar_extra contains a dynamic... Figure out what to do with it. *)
+ depends_of_constr evi.Evd.evar_concl (depends_of_evar_body evi.Evd.evar_body (depends_of_named_context_val evi.Evd.evar_hyps acc))
+and depends_of_evar_body evb acc = match evb with
+ | Evd.Evar_empty -> acc
+ | Evd.Evar_defined c -> depends_of_constr c acc
+and depends_of_named_context nc acc = list_union_map depends_of_named_declaration nc acc
+and depends_of_named_context_val ncv acc =
+ depends_of_named_context (Environ.named_context_of_val ncv) (depends_of_named_vals (Environ.named_vals_of_val ncv) acc)
+and depends_of_named_declaration (_,co,t) acc = depends_of_constr t (Option.fold_right depends_of_constr co acc)
+
+
+
+let depends_of_open_constr (evm,c) acc =
+ depends_of_constr c (depends_of_evar_map evm acc)
+
+let rec depends_of_rawconstr rc acc = match rc with
+ | RRef (_,r) -> r::acc
+ | RVar (_, id) -> (VarRef id)::acc
+ | REvar (_, _, rclo) -> Option.fold_right depends_of_rawconstr_list rclo acc
+ | RPatVar _ -> acc
+ | RApp (_, rc, rcl) -> depends_of_rawconstr rc (depends_of_rawconstr_list rcl acc)
+ | RLambda (_, _, _, rct, rcb)
+ | RProd (_, _, _, rct, rcb)
+ | RLetIn (_, _, rct, rcb) -> depends_of_rawconstr rcb (depends_of_rawconstr rct acc)
+ | RCases (_, _, rco, tmt, cc) ->
+ (* LEM TODO: handle the cc *)
+ (Option.fold_right depends_of_rawconstr rco
+ (list_union_map
+ (fun (rc, pp) acc ->
+ Option.fold_right (fun (_,ind,_,_) acc -> (IndRef ind)::acc) (snd pp)
+ (depends_of_rawconstr rc acc))
+ tmt
+ acc))
+ | RLetTuple (_,_,(_,rco),rc0,rc1) ->
+ depends_of_rawconstr rc1 (depends_of_rawconstr rc0 (Option.fold_right depends_of_rawconstr rco acc))
+ | RIf (_, rcC, (_, rco), rcT, rcF) -> let dorc = depends_of_rawconstr in
+ dorc rcF (dorc rcT (dorc rcF (dorc rcC (Option.fold_right dorc rco acc))))
+ | RRec (_, _, _, rdla, rca0, rca1) -> let dorca = array_union_map depends_of_rawconstr in
+ dorca rca0 (dorca rca1 (array_union_map
+ (list_union_map (fun (_,_,rco,rc) acc -> depends_of_rawconstr rc (Option.fold_right depends_of_rawconstr rco acc)))
+ rdla
+ acc))
+ | RSort _ -> acc
+ | RHole (_, hk) -> depends_of_hole_kind hk acc
+ | RCast (_, rc, rcct) -> depends_of_rawconstr rc (depends_of_'a_cast_type depends_of_rawconstr rcct acc)
+ | RDynamic (_, dyn) -> failwith "Depends of a dyn not implemented yet" (* TODO: figure out how these dyns are used*)
+and depends_of_rawconstr_list l = list_union_map depends_of_rawconstr l
+
+let depends_of_rawconstr_and_expr (rc, _) acc =
+ (* TODO Le constr_expr représente le même terme que le rawconstr. Vérifier ça. *)
+ depends_of_rawconstr rc acc
+
+let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of_'tac =
+ (* TODO:
+ * Dirty assumptions that the 'id, 'cst, 'ref don't generate dependencies
+ *)
+ let rec depends_of_tacexpr texp acc = match texp with
+ | TacAtom (_, atexpr) -> depends_of_atomic_tacexpr atexpr acc
+ | TacThen (tac0, taca0, tac1, taca1) ->
+ depends_of_tacexpr tac0 (array_union_map depends_of_tacexpr taca0 (depends_of_tacexpr tac1 (array_union_map depends_of_tacexpr taca1 acc)))
+ | TacThens (tac, tacl) ->
+ depends_of_tacexpr tac (list_union_map depends_of_tacexpr tacl acc)
+ | TacFirst tacl -> list_union_map depends_of_tacexpr tacl acc
+ | TacComplete tac -> depends_of_tacexpr tac acc
+ | TacSolve tacl -> list_union_map depends_of_tacexpr tacl acc
+ | TacTry tac -> depends_of_tacexpr tac acc
+ | TacOrelse (tac0, tac1) -> depends_of_tacexpr tac0 (depends_of_tacexpr tac1 acc)
+ | TacDo (_, tac) -> depends_of_tacexpr tac acc
+ | TacRepeat tac -> depends_of_tacexpr tac acc
+ | TacProgress tac -> depends_of_tacexpr tac acc
+ | TacAbstract (tac, _) -> depends_of_tacexpr tac acc
+ | TacId _
+ | TacFail _ -> acc
+ | TacInfo tac -> depends_of_tacexpr tac acc
+ | TacLetIn (_, igtal, tac) ->
+ depends_of_tacexpr
+ tac
+ (list_union_map
+ (fun x y -> depends_of_tac_arg (snd x) y)
+ igtal
+ acc)
+ | TacMatch (_, tac, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match not implemented yet"
+ | TacMatchContext (_, _, tacexpr_mrl) -> failwith "depends_of_tacexpr of a Match Context not implemented yet"
+ | TacFun tacfa -> depends_of_tac_fun_ast tacfa acc
+ | TacArg tacarg -> depends_of_tac_arg tacarg acc
+ and depends_of_atomic_tacexpr atexpr acc = let depends_of_'constr_with_bindings = depends_of_'a_with_bindings depends_of_'constr in match atexpr with
+ (* Basic tactics *)
+ | TacIntroPattern _
+ | TacIntrosUntil _
+ | TacIntroMove _
+ | TacAssumption -> acc
+ | TacExact c
+ | TacExactNoCheck c
+ | TacVmCastNoCheck c -> depends_of_'constr c acc
+ | TacApply (_, _, cb) -> depends_of_'constr_with_bindings cb acc
+ | TacElim (_, cwb, cwbo) ->
+ depends_of_'constr_with_bindings cwb
+ (Option.fold_right depends_of_'constr_with_bindings cwbo acc)
+ | TacElimType c -> depends_of_'constr c acc
+ | TacCase (_, cb) -> depends_of_'constr_with_bindings cb acc
+ | TacCaseType c -> depends_of_'constr c acc
+ | TacFix _
+ | TacMutualFix _
+ | TacCofix _
+ | TacMutualCofix _ -> failwith "depends_of_atomic_tacexpr of a Tac(Mutual)(Co)Fix not implemented yet"
+ | TacCut c -> depends_of_'constr c acc
+ | TacAssert (taco, _, c) ->
+ Option.fold_right depends_of_'tac taco (depends_of_'constr c acc)
+ | TacGeneralize cl ->
+ list_union_map depends_of_'constr (List.map (fun ((_,c),_) -> c) cl)
+ acc
+ | TacGeneralizeDep c -> depends_of_'constr c acc
+ | TacLetTac (_,c,_,_) -> depends_of_'constr c acc
+
+ (* Derived basic tactics *)
+ | TacSimpleInduction _
+ | TacSimpleDestruct _
+ | TacDoubleInduction _ -> acc
+ | TacNewInduction (_, cwbial, cwbo, _, _)
+ | TacNewDestruct (_, cwbial, cwbo, _, _) ->
+ list_union_map (depends_of_'a_induction_arg depends_of_'constr_with_bindings)
+ cwbial
+ (Option.fold_right depends_of_'constr_with_bindings cwbo acc)
+ | TacDecomposeAnd c
+ | TacDecomposeOr c -> depends_of_'constr c acc
+ | TacDecompose (il, c) -> depends_of_'constr c (list_union_map depends_of_'ind il acc)
+ | TacSpecialize (_,cwb) -> depends_of_'constr_with_bindings cwb acc
+ | TacLApply c -> depends_of_'constr c acc
+
+ (* Automation tactics *)
+ | TacTrivial (cl, bs) ->
+ (* TODO: Maybe make use of bs: list of hint bases to be used. *)
+ list_union_map depends_of_'constr cl acc
+ | TacAuto (_, cs, bs) ->
+ (* TODO: Maybe make use of bs: list of hint bases to be used.
+ None -> all ("with *")
+ Some list -> a list, "core" added implicitly *)
+ list_union_map depends_of_'constr cs acc
+ | TacAutoTDB _ -> acc
+ | TacDestructHyp _ -> acc
+ | TacDestructConcl -> acc
+ | TacSuperAuto _ -> (* TODO: this reference thing is scary*)
+ acc
+ | TacDAuto _ -> acc
+
+ (* Context management *)
+ | TacClear _
+ | TacClearBody _
+ | TacMove _
+ | TacRename _
+ | TacRevert _ -> acc
+
+ (* Constructors *)
+ | TacLeft (_,cb)
+ | TacRight (_,cb)
+ | TacSplit (_, _, cb)
+ | TacConstructor (_, _, cb) -> depends_of_'a_bindings depends_of_'constr cb acc
+ | TacAnyConstructor (_,taco) -> Option.fold_right depends_of_'tac taco acc
+
+ (* Conversion *)
+ | TacReduce (reg,_) ->
+ depends_of_'a_'b_red_expr_gen depends_of_'constr reg acc
+ | TacChange (cwoo, c, _) ->
+ depends_of_'constr
+ c
+ (Option.fold_right (depends_of_'a_with_occurences depends_of_'constr) cwoo acc)
+
+ (* Equivalence relations *)
+ | TacReflexivity
+ | TacSymmetry _ -> acc
+ | TacTransitivity c -> depends_of_'constr c acc
+
+ (* Equality and inversion *)
+ | TacRewrite (_,cbl,_,_) -> list_union_map (o depends_of_'constr_with_bindings (fun (_,_,x)->x)) cbl acc
+ | TacInversion (is, _) -> depends_of_'a_'b_inversion_strength depends_of_'constr is acc
+
+ (* For ML extensions *)
+ | TacExtend (_, _, cgal) -> failwith "depends of TacExtend not implemented because depends of a generic_argument not implemented"
+
+ (* For syntax extensions *)
+ | TacAlias (_,_,gal,(_,gte)) -> failwith "depends of a TacAlias not implemented because depends of a generic_argument not implemented"
+ and depends_of_tac_fun_ast tfa acc = failwith "depend_of_tac_fun_ast not implemented yet"
+ and depends_of_tac_arg ta acc = match ta with
+ | TacDynamic (_,d) -> failwith "Don't know what to do with a Dyn in tac_arg"
+ | TacVoid -> acc
+ | MetaIdArg _ -> failwith "Don't know what to do with a MetaIdArg in tac_arg"
+ | ConstrMayEval me -> failwith "TODO: depends_of_tac_arg of a ConstrMayEval"
+ | IntroPattern _ -> acc
+ | Reference ltc -> acc (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *)
+ | Integer _ -> acc
+ | TacCall (_,ltc,l) -> (* TODO: This assumes the "ltac constant" cannot somehow refer to a named object... *)
+ list_union_map depends_of_tac_arg l acc
+ | TacExternal (_,_,_,l) -> list_union_map depends_of_tac_arg l acc
+ | TacFreshId _ -> acc
+ | Tacexp tac ->
+ depends_of_'tac tac acc
+ in
+ depends_of_tacexpr
+
+let rec depends_of_glob_tactic_expr (gte:glob_tactic_expr) acc =
+ depends_of_gen_tactic_expr
+ depends_of_rawconstr_and_expr
+ (depends_of_'a_or_var depends_of_inductive)
+ depends_of_glob_tactic_expr
+ gte
+ acc
+
+let rec depends_of_tacexpr te acc =
+ depends_of_gen_tactic_expr
+ depends_of_open_constr
+ depends_of_inductive
+ depends_of_glob_tactic_expr
+ te
+ acc
+
+let depends_of_compound_rule cr acc = match cr with
+ | Tactic (texp, _) -> depends_of_tacexpr texp acc
+ | Proof_instr (b, instr) ->
+ (* TODO: What is the boolean b? Should check. *)
+ failwith "Dependency calculation of Proof_instr not implemented yet"
+and depends_of_prim_rule pr acc = match pr with
+ | Refine c -> depends_of_constr c acc
+ | Intro id -> acc
+ | Intro_replacing id -> acc
+ | Cut (_, _, t) -> depends_of_constr t acc (* TODO: check what 2nd argument contains *)
+ | FixRule (_, _, l) -> list_union_map (o depends_of_constr trd_of_3) l acc (* TODO: check what the arguments contain *)
+ | Cofix (_, l) -> list_union_map (o depends_of_constr snd) l acc (* TODO: check what the arguments contain *)
+ | Convert_concl (t, _) -> depends_of_constr t acc
+ | Convert_hyp (_, None, t) -> depends_of_constr t acc
+ | Convert_hyp (_, (Some c), t) -> depends_of_constr c (depends_of_constr t acc)
+ | Thin _ -> acc
+ | ThinBody _ -> acc
+ | Move _ -> acc
+ | Rename _ -> acc
+ | Change_evars -> acc
+
+let rec depends_of_pftree pt acc =
+ match pt.ref with
+ | None -> acc
+ | Some (Prim pr , l) -> depends_of_prim_rule pr (list_union_map depends_of_pftree l acc)
+ | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p (list_union_map depends_of_pftree l acc))
+ | Some (Decl_proof _ , l) -> list_union_map depends_of_pftree l acc
+ | Some (Daimon, l) -> list_union_map depends_of_pftree l acc
+
+let rec depends_of_pftree_head pt acc =
+ match pt.ref with
+ | None -> acc
+ | Some (Prim pr , l) -> depends_of_prim_rule pr acc
+ | Some (Nested (t, p), l) -> depends_of_compound_rule t (depends_of_pftree p acc)
+ | Some (Decl_proof _ , l) -> acc
+ | Some (Daimon, l) -> acc
+
+let depends_of_pftreestate depends_of_pftree pfs =
+(* print_string "depends_of_pftreestate called\n"; *)
+(* explore_tree pfs; *)
+ let pt = proof_of_pftreestate pfs in
+ assert (is_top_pftreestate pfs);
+ assert (pt.open_subgoals = 0);
+ depends_of_pftree pt []
+
+let depends_of_definition_entry de ~acc =
+ Option.fold_right
+ depends_of_constr
+ de.const_entry_type
+ (depends_of_constr de.const_entry_body acc)
diff --git a/contrib/interface/name_to_ast.ml b/contrib/interface/name_to_ast.ml
index 9a503cfb..6b17e739 100644
--- a/contrib/interface/name_to_ast.ml
+++ b/contrib/interface/name_to_ast.ml
@@ -28,7 +28,7 @@ let convert_env =
let convert_binder env (na, b, c) =
match b with
| Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b)
- | None -> LocalRawAssum ([dummy_loc,na], extern_constr true env c) in
+ | None -> LocalRawAssum ([dummy_loc,na], default_binder_kind, extern_constr true env c) in
let rec cvrec env = function
[] -> []
| b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in
@@ -134,14 +134,14 @@ let implicits_to_ast_list implicits =
let make_variable_ast name typ implicits =
(VernacAssumption
- ((Local,Definitional),
- [false,([dummy_loc,name], constr_to_ast (body_of_type typ))]))
+ ((Local,Definitional),false,(*inline flag*)
+ [false,([dummy_loc,name], constr_to_ast typ)]))
::(implicits_to_ast_list implicits);;
let make_definition_ast name c typ implicits =
- VernacDefinition ((Global,false,Definition), (dummy_loc,name), DefineBody ([], None,
- (constr_to_ast c), Some (constr_to_ast (body_of_type typ))),
+ VernacDefinition ((Global,false,Definition), (dummy_loc,name),
+ DefineBody ([], None, constr_to_ast c, Some (constr_to_ast typ)),
(fun _ _ -> ()))
::(implicits_to_ast_list implicits);;
@@ -158,7 +158,7 @@ let constant_to_ast_list kn =
make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l)
let variable_to_ast_list sp =
- let (id, c, v) = get_variable sp in
+ let (id, c, v) = Global.lookup_named sp in
let l = implicits_of_global (VarRef sp) in
(match c with
None ->
diff --git a/contrib/interface/name_to_ast.mli b/contrib/interface/name_to_ast.mli
index b8c2d7dc..f9e83b5e 100644
--- a/contrib/interface/name_to_ast.mli
+++ b/contrib/interface/name_to_ast.mli
@@ -1 +1,5 @@
val name_to_ast : Libnames.reference -> Vernacexpr.vernac_expr;;
+val inductive_to_ast_list : Names.mutual_inductive -> Vernacexpr.vernac_expr list;;
+val constant_to_ast_list : Names.constant -> Vernacexpr.vernac_expr list;;
+val variable_to_ast_list : Names.variable -> Vernacexpr.vernac_expr list;;
+val leaf_entry_to_ast_list : (Libnames.section_path * Names.mutual_inductive) * Libobject.obj -> Vernacexpr.vernac_expr list;;
diff --git a/contrib/interface/parse.ml b/contrib/interface/parse.ml
index 8cca7614..bf8614b4 100644
--- a/contrib/interface/parse.ml
+++ b/contrib/interface/parse.ml
@@ -21,18 +21,19 @@ type parsed_tree =
| P_i of ct_INT;;
let print_parse_results n msg =
- print_string "message\nparsed\n";
- print_int n;
- print_string "\n";
- (match msg with
- | P_cl x -> fCOMMAND_LIST x
- | P_c x -> fCOMMAND x
- | P_t x -> fTACTIC_COM x
- | P_f x -> fFORMULA x
- | P_id x -> fID x
- | P_s x -> fSTRING x
- | P_i x -> fINT x);
- print_string "e\nblabla\n";
+ Pp.msg
+ ( str "message\nparsed\n" ++
+ int n ++
+ str "\n" ++
+ (match msg with
+ | P_cl x -> fCOMMAND_LIST x
+ | P_c x -> fCOMMAND x
+ | P_t x -> fTACTIC_COM x
+ | P_f x -> fFORMULA x
+ | P_id x -> fID x
+ | P_s x -> fSTRING x
+ | P_i x -> fINT x) ++
+ str "e\nblabla\n");
flush stdout;;
let ctf_SyntaxErrorMessage reqid pps =
@@ -329,7 +330,7 @@ let add_path_action reqid string_arg =
let print_version_action () =
msgnl (mt ());
- msgnl (str "$Id: parse.ml 9397 2006-11-21 21:50:54Z herbelin $");;
+ msgnl (str "$Id: parse.ml 9476 2007-01-10 15:44:44Z lmamane $");;
let load_syntax_action reqid module_name =
msg (str "loading " ++ str module_name ++ str "... ");
diff --git a/contrib/interface/pbp.ml b/contrib/interface/pbp.ml
index d2f71bfc..06b957d9 100644
--- a/contrib/interface/pbp.ml
+++ b/contrib/interface/pbp.ml
@@ -156,29 +156,29 @@ let make_pbp_pattern x =
let rec make_then = function
| [] -> TacId []
| [t] -> t
- | t1::t2::l -> make_then (TacThen (t1,t2)::l)
+ | t1::t2::l -> make_then (TacThen (t1,[||],t2,[||])::l)
let make_pbp_atomic_tactic = function
| PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption))
| PbpTryAssumption (Some a) ->
TacTry (TacAtom (zz, TacExact (make_var a)))
| PbpExists x ->
- TacAtom (zz, TacSplit (true,ImplicitBindings [make_pbp_pattern x]))
+ TacAtom (zz, TacSplit (false,true,ImplicitBindings [make_pbp_pattern x]))
| PbpGeneralize (h,args) ->
let l = List.map make_pbp_pattern args in
- TacAtom (zz, TacGeneralize [make_app (make_var h) l])
- | PbpLeft -> TacAtom (zz, TacLeft NoBindings)
- | PbpRight -> TacAtom (zz, TacRight NoBindings)
+ TacAtom (zz, TacGeneralize [((true,[]),make_app (make_var h) l),Anonymous])
+ | PbpLeft -> TacAtom (zz, TacLeft (false,NoBindings))
+ | PbpRight -> TacAtom (zz, TacRight (false,NoBindings))
| PbpIntros l -> TacAtom (zz, TacIntroPattern l)
| PbpLApply h -> TacAtom (zz, TacLApply (make_var h))
- | PbpApply h -> TacAtom (zz, TacApply (make_var h,NoBindings))
+ | PbpApply h -> TacAtom (zz, TacApply (true,false,(make_var h,NoBindings)))
| PbpElim (hyp_name, names) ->
let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in
TacAtom
- (zz, TacElim ((make_var hyp_name,ExplicitBindings bind),None))
+ (zz, TacElim (false,(make_var hyp_name,ExplicitBindings bind),None))
| PbpTryClear l ->
TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l)))
- | PbpSplit -> TacAtom (zz, TacSplit (false,NoBindings));;
+ | PbpSplit -> TacAtom (zz, TacSplit (false,false,NoBindings));;
let rec make_pbp_tactic = function
| PbpThen tl -> make_then (List.map make_pbp_atomic_tactic tl)
diff --git a/contrib/interface/showproof.ml b/contrib/interface/showproof.ml
index 4bec7350..953fb5e7 100644
--- a/contrib/interface/showproof.ml
+++ b/contrib/interface/showproof.ml
@@ -166,7 +166,7 @@ let rule_to_ntactic r =
let rt =
(match r with
Nested(Tactic (t,_),_) -> t
- | Prim (Refine h) -> TacAtom (dummy_loc,TacExact h)
+ | Prim (Refine h) -> TacAtom (dummy_loc,TacExact (Tactics.inj_open h))
| _ -> TacAtom (dummy_loc, TacIntroPattern [])) in
if rule_is_complex r
then (match rt with
@@ -1183,8 +1183,8 @@ let rec natural_ntree ig ntree =
TacIntroPattern _ -> natural_intros ig lh g gs ltree
| TacIntroMove _ -> natural_intros ig lh g gs ltree
| TacFix (_,n) -> natural_fix ig lh g gs n ltree
- | TacSplit (_,NoBindings) -> natural_split ig lh g gs ge [] ltree
- | TacSplit(_,ImplicitBindings l) -> natural_split ig lh g gs ge l ltree
+ | TacSplit (_,_,NoBindings) -> natural_split ig lh g gs ge [] ltree
+ | TacSplit(_,_,ImplicitBindings l) -> natural_split ig lh g gs ge (List.map snd l) ltree
| TacGeneralize l -> natural_generalize ig lh g gs ge l ltree
| TacRight _ -> natural_right ig lh g gs ltree
| TacLeft _ -> natural_left ig lh g gs ltree
@@ -1202,17 +1202,18 @@ let rec natural_ntree ig ntree =
| TacExtend (_,"InductionIntro",[a]) ->
let id=(out_gen wit_ident a) in
natural_induction ig lh g gs ge id ltree true
- | TacApply (c,_) -> natural_apply ig lh g gs c ltree
- | TacExact c -> natural_exact ig lh g gs c ltree
- | TacCut c -> natural_cut ig lh g gs c ltree
+ | TacApply (_,false,(c,_)) -> natural_apply ig lh g gs (snd c) ltree
+ | TacExact c -> natural_exact ig lh g gs (snd c) ltree
+ | TacCut c -> natural_cut ig lh g gs (snd c) ltree
| TacExtend (_,"CutIntro",[a]) ->
let _c = out_gen wit_constr a in
natural_cutintro ig lh g gs a ltree
- | TacCase (c,_) -> natural_case ig lh g gs ge c ltree false
+ | TacCase (_,(c,_)) -> natural_case ig lh g gs ge (snd c) ltree false
| TacExtend (_,"CaseIntro",[a]) ->
let c = out_gen wit_constr a in
natural_case ig lh g gs ge c ltree true
- | TacElim ((c,_),_) -> natural_elim ig lh g gs ge c ltree false
+ | TacElim (_,(c,_),_) ->
+ natural_elim ig lh g gs ge (snd c) ltree false
| TacExtend (_,"ElimIntro",[a]) ->
let c = out_gen wit_constr a in
natural_elim ig lh g gs ge c ltree true
@@ -1611,7 +1612,7 @@ and natural_fix ig lh g gs narg ltree =
| _ -> assert false
and natural_reduce ig lh g gs ge mode la ltree =
match la with
- {onhyps=Some[];onconcl=true} ->
+ {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr ->
spv
[ (natural_lhyp lh ig.ihsg);
(show_goal2 lh ig g gs "");
@@ -1619,7 +1620,7 @@ and natural_reduce ig lh g gs ge mode la ltree =
{ihsg=All_subgoals_hyp;isgintro="simpl"})
ltree)
]
- | {onhyps=Some[hyp]; onconcl=false} ->
+ | {onhyps=Some[hyp]} when la.concl_occs = no_occurrences_expr ->
spv
[ (natural_lhyp lh ig.ihsg);
(show_goal2 lh ig g gs "");
@@ -1651,7 +1652,7 @@ and natural_split ig lh g gs ge la ltree =
| _ -> assert false
and natural_generalize ig lh g gs ge la ltree =
match la with
- [arg] ->
+ [(_,(_,arg)),_] ->
let _env= (gLOB ge) in
let arg1= (*dbize env*) arg in
let _type_arg=type_of (Global.env()) Evd.empty arg in
diff --git a/contrib/interface/translate.ml b/contrib/interface/translate.ml
index 6e4782be..559860b2 100644
--- a/contrib/interface/translate.ml
+++ b/contrib/interface/translate.ml
@@ -75,3 +75,6 @@ let translate_path l =
(*translates a path and a goal into a centaur-tree --> RULE *)
let translate_goal (g:goal) =
CT_rule(translate_sign (evar_env g), translate_constr true (evar_env g) g.evar_concl);;
+
+let translate_goals (gl: goal list) =
+ CT_rule_list (List.map translate_goal gl);;
diff --git a/contrib/interface/translate.mli b/contrib/interface/translate.mli
index 65d8331b..34841fc4 100644
--- a/contrib/interface/translate.mli
+++ b/contrib/interface/translate.mli
@@ -5,6 +5,7 @@ open Environ;;
open Term;;
val translate_goal : goal -> ct_RULE;;
+val translate_goals : goal list -> ct_RULE_LIST;;
(* The boolean argument indicates whether names from the environment should *)
(* be avoided (same interpretation as for prterm_env and ast_of_constr) *)
val translate_constr : bool -> env -> constr -> ct_FORMULA;;
diff --git a/contrib/interface/vtp.ml b/contrib/interface/vtp.ml
index 166a0cbf..551ad3a3 100644
--- a/contrib/interface/vtp.ml
+++ b/contrib/interface/vtp.ml
@@ -1,103 +1,108 @@
open Ascent;;
+open Pp;;
+
+(* LEM: This is actually generated automatically *)
let fNODE s n =
- print_string "n\n";
- print_string ("vernac$" ^ s);
- print_string "\n";
- print_int n;
- print_string "\n";;
+ (str "n\n") ++
+ (str ("vernac$" ^ s)) ++
+ (str "\n") ++
+ (int n) ++
+ (str "\n");;
let fATOM s1 =
- print_string "a\n";
- print_string ("vernac$" ^ s1);
- print_string "\n";;
+ (str "a\n") ++
+ (str ("vernac$" ^ s1)) ++
+ (str "\n");;
-let f_atom_string = print_string;;
-let f_atom_int = print_int;;
+let f_atom_string = str;;
+let f_atom_int = int;;
let rec fAST = function
| CT_coerce_ID_OR_INT_to_AST x -> fID_OR_INT x
| CT_coerce_ID_OR_STRING_to_AST x -> fID_OR_STRING x
| CT_coerce_SINGLE_OPTION_VALUE_to_AST x -> fSINGLE_OPTION_VALUE x
| CT_astnode(x1, x2) ->
- fID x1;
- fAST_LIST x2;
+ fID x1 ++
+ fAST_LIST x2 ++
fNODE "astnode" 2
| CT_astpath(x1) ->
- fID_LIST x1;
+ fID_LIST x1 ++
fNODE "astpath" 1
| CT_astslam(x1, x2) ->
- fID_OPT x1;
- fAST x2;
+ fID_OPT x1 ++
+ fAST x2 ++
fNODE "astslam" 2
and fAST_LIST = function
| CT_ast_list l ->
- (List.iter fAST l);
+ (List.fold_left (++) (mt()) (List.map fAST l)) ++
fNODE "ast_list" (List.length l)
and fBINARY = function
-| CT_binary x -> fATOM "binary";
- (f_atom_int x);
- print_string "\n"and fBINDER = function
+| CT_binary x -> fATOM "binary" ++
+ (f_atom_int x) ++
+ str "\n"
+and fBINDER = function
| CT_coerce_DEF_to_BINDER x -> fDEF x
| CT_binder(x1, x2) ->
- fID_OPT_NE_LIST x1;
- fFORMULA x2;
+ fID_OPT_NE_LIST x1 ++
+ fFORMULA x2 ++
fNODE "binder" 2
| CT_binder_coercion(x1, x2) ->
- fID_OPT_NE_LIST x1;
- fFORMULA x2;
+ fID_OPT_NE_LIST x1 ++
+ fFORMULA x2 ++
fNODE "binder_coercion" 2
and fBINDER_LIST = function
| CT_binder_list l ->
- (List.iter fBINDER l);
+ (List.fold_left (++) (mt()) (List.map fBINDER l)) ++
fNODE "binder_list" (List.length l)
and fBINDER_NE_LIST = function
| CT_binder_ne_list(x,l) ->
- fBINDER x;
- (List.iter fBINDER l);
+ fBINDER x ++
+ (List.fold_left (++) (mt()) (List.map fBINDER l)) ++
fNODE "binder_ne_list" (1 + (List.length l))
and fBINDING = function
| CT_binding(x1, x2) ->
- fID_OR_INT x1;
- fFORMULA x2;
+ fID_OR_INT x1 ++
+ fFORMULA x2 ++
fNODE "binding" 2
and fBINDING_LIST = function
| CT_binding_list l ->
- (List.iter fBINDING l);
+ (List.fold_left (++) (mt()) (List.map fBINDING l)) ++
fNODE "binding_list" (List.length l)
and fBOOL = function
| CT_false -> fNODE "false" 0
| CT_true -> fNODE "true" 0
and fCASE = function
-| CT_case x -> fATOM "case";
- (f_atom_string x);
- print_string "\n"and fCLAUSE = function
+| CT_case x -> fATOM "case" ++
+ (f_atom_string x) ++
+ str "\n"
+and fCLAUSE = function
| CT_clause(x1, x2) ->
- fHYP_LOCATION_LIST_OR_STAR x1;
- fSTAR_OPT x2;
+ fHYP_LOCATION_LIST_OR_STAR x1 ++
+ fSTAR_OPT x2 ++
fNODE "clause" 2
and fCOERCION_OPT = function
| CT_coerce_NONE_to_COERCION_OPT x -> fNONE x
| CT_coercion_atm -> fNODE "coercion_atm" 0
and fCOFIXTAC = function
| CT_cofixtac(x1, x2) ->
- fID x1;
- fFORMULA x2;
+ fID x1 ++
+ fFORMULA x2 ++
fNODE "cofixtac" 2
and fCOFIX_REC = function
| CT_cofix_rec(x1, x2, x3, x4) ->
- fID x1;
- fBINDER_LIST x2;
- fFORMULA x3;
- fFORMULA x4;
+ fID x1 ++
+ fBINDER_LIST x2 ++
+ fFORMULA x3 ++
+ fFORMULA x4 ++
fNODE "cofix_rec" 4
and fCOFIX_REC_LIST = function
| CT_cofix_rec_list(x,l) ->
- fCOFIX_REC x;
- (List.iter fCOFIX_REC l);
+ fCOFIX_REC x ++
+ (List.fold_left (++) (mt()) (List.map fCOFIX_REC l)) ++
fNODE "cofix_rec_list" (1 + (List.length l))
and fCOFIX_TAC_LIST = function
| CT_cofix_tac_list l ->
- (List.iter fCOFIXTAC l);
+ (List.fold_left (++) (mt()) (List.map fCOFIXTAC l)) ++
fNODE "cofix_tac_list" (List.length l)
and fCOMMAND = function
| CT_coerce_COMMAND_LIST_to_COMMAND x -> fCOMMAND_LIST x
@@ -105,479 +110,476 @@ and fCOMMAND = function
| CT_coerce_SECTION_BEGIN_to_COMMAND x -> fSECTION_BEGIN x
| CT_coerce_THEOREM_GOAL_to_COMMAND x -> fTHEOREM_GOAL x
| CT_abort(x1) ->
- fID_OPT_OR_ALL x1;
+ fID_OPT_OR_ALL x1 ++
fNODE "abort" 1
| CT_abstraction(x1, x2, x3) ->
- fID x1;
- fFORMULA x2;
- fINT_LIST x3;
+ fID x1 ++
+ fFORMULA x2 ++
+ fINT_LIST x3 ++
fNODE "abstraction" 3
| CT_add_field(x1, x2, x3, x4) ->
- fFORMULA x1;
- fFORMULA x2;
- fFORMULA x3;
- fFORMULA_OPT x4;
+ fFORMULA x1 ++
+ fFORMULA x2 ++
+ fFORMULA x3 ++
+ fFORMULA_OPT x4 ++
fNODE "add_field" 4
| CT_add_natural_feature(x1, x2) ->
- fNATURAL_FEATURE x1;
- fID x2;
+ fNATURAL_FEATURE x1 ++
+ fID x2 ++
fNODE "add_natural_feature" 2
| CT_addpath(x1, x2) ->
- fSTRING x1;
- fID_OPT x2;
+ fSTRING x1 ++
+ fID_OPT x2 ++
fNODE "addpath" 2
| CT_arguments_scope(x1, x2) ->
- fID x1;
- fID_OPT_LIST x2;
+ fID x1 ++
+ fID_OPT_LIST x2 ++
fNODE "arguments_scope" 2
| CT_bind_scope(x1, x2) ->
- fID x1;
- fID_NE_LIST x2;
+ fID x1 ++
+ fID_NE_LIST x2 ++
fNODE "bind_scope" 2
| CT_cd(x1) ->
- fSTRING_OPT x1;
+ fSTRING_OPT x1 ++
fNODE "cd" 1
| CT_check(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "check" 1
| CT_class(x1) ->
- fID x1;
+ fID x1 ++
fNODE "class" 1
| CT_close_scope(x1) ->
- fID x1;
+ fID x1 ++
fNODE "close_scope" 1
| CT_coercion(x1, x2, x3, x4, x5) ->
- fLOCAL_OPT x1;
- fIDENTITY_OPT x2;
- fID x3;
- fID x4;
- fID x5;
+ fLOCAL_OPT x1 ++
+ fIDENTITY_OPT x2 ++
+ fID x3 ++
+ fID x4 ++
+ fID x5 ++
fNODE "coercion" 5
| CT_cofix_decl(x1) ->
- fCOFIX_REC_LIST x1;
+ fCOFIX_REC_LIST x1 ++
fNODE "cofix_decl" 1
| CT_compile_module(x1, x2, x3) ->
- fVERBOSE_OPT x1;
- fID x2;
- fSTRING_OPT x3;
+ fVERBOSE_OPT x1 ++
+ fID x2 ++
+ fSTRING_OPT x3 ++
fNODE "compile_module" 3
| CT_declare_module(x1, x2, x3, x4) ->
- fID x1;
- fMODULE_BINDER_LIST x2;
- fMODULE_TYPE_CHECK x3;
- fMODULE_EXPR x4;
+ fID x1 ++
+ fMODULE_BINDER_LIST x2 ++
+ fMODULE_TYPE_CHECK x3 ++
+ fMODULE_EXPR x4 ++
fNODE "declare_module" 4
| CT_define_notation(x1, x2, x3, x4) ->
- fSTRING x1;
- fFORMULA x2;
- fMODIFIER_LIST x3;
- fID_OPT x4;
+ fSTRING x1 ++
+ fFORMULA x2 ++
+ fMODIFIER_LIST x3 ++
+ fID_OPT x4 ++
fNODE "define_notation" 4
| CT_definition(x1, x2, x3, x4, x5) ->
- fDEFN x1;
- fID x2;
- fBINDER_LIST x3;
- fDEF_BODY x4;
- fFORMULA_OPT x5;
+ fDEFN x1 ++
+ fID x2 ++
+ fBINDER_LIST x3 ++
+ fDEF_BODY x4 ++
+ fFORMULA_OPT x5 ++
fNODE "definition" 5
| CT_delim_scope(x1, x2) ->
- fID x1;
- fID x2;
+ fID x1 ++
+ fID x2 ++
fNODE "delim_scope" 2
| CT_delpath(x1) ->
- fSTRING x1;
+ fSTRING x1 ++
fNODE "delpath" 1
| CT_derive_depinversion(x1, x2, x3, x4) ->
- fINV_TYPE x1;
- fID x2;
- fFORMULA x3;
- fSORT_TYPE x4;
+ fINV_TYPE x1 ++
+ fID x2 ++
+ fFORMULA x3 ++
+ fSORT_TYPE x4 ++
fNODE "derive_depinversion" 4
| CT_derive_inversion(x1, x2, x3, x4) ->
- fINV_TYPE x1;
- fINT_OPT x2;
- fID x3;
- fID x4;
+ fINV_TYPE x1 ++
+ fINT_OPT x2 ++
+ fID x3 ++
+ fID x4 ++
fNODE "derive_inversion" 4
| CT_derive_inversion_with(x1, x2, x3, x4) ->
- fINV_TYPE x1;
- fID x2;
- fFORMULA x3;
- fSORT_TYPE x4;
+ fINV_TYPE x1 ++
+ fID x2 ++
+ fFORMULA x3 ++
+ fSORT_TYPE x4 ++
fNODE "derive_inversion_with" 4
| CT_explain_proof(x1) ->
- fINT_LIST x1;
+ fINT_LIST x1 ++
fNODE "explain_proof" 1
| CT_explain_prooftree(x1) ->
- fINT_LIST x1;
+ fINT_LIST x1 ++
fNODE "explain_prooftree" 1
| CT_export_id(x1) ->
- fID_NE_LIST x1;
+ fID_NE_LIST x1 ++
fNODE "export_id" 1
| CT_extract_to_file(x1, x2) ->
- fSTRING x1;
- fID_NE_LIST x2;
+ fSTRING x1 ++
+ fID_NE_LIST x2 ++
fNODE "extract_to_file" 2
| CT_extraction(x1) ->
- fID_OPT x1;
+ fID_OPT x1 ++
fNODE "extraction" 1
| CT_fix_decl(x1) ->
- fFIX_REC_LIST x1;
+ fFIX_REC_LIST x1 ++
fNODE "fix_decl" 1
| CT_focus(x1) ->
- fINT_OPT x1;
+ fINT_OPT x1 ++
fNODE "focus" 1
| CT_go(x1) ->
- fINT_OR_LOCN x1;
+ fINT_OR_LOCN x1 ++
fNODE "go" 1
| CT_guarded -> fNODE "guarded" 0
| CT_hint_destruct(x1, x2, x3, x4, x5, x6) ->
- fID x1;
- fINT x2;
- fDESTRUCT_LOCATION x3;
- fFORMULA x4;
- fTACTIC_COM x5;
- fID_LIST x6;
+ fID x1 ++
+ fINT x2 ++
+ fDESTRUCT_LOCATION x3 ++
+ fFORMULA x4 ++
+ fTACTIC_COM x5 ++
+ fID_LIST x6 ++
fNODE "hint_destruct" 6
| CT_hint_extern(x1, x2, x3, x4) ->
- fINT x1;
- fFORMULA x2;
- fTACTIC_COM x3;
- fID_LIST x4;
+ fINT x1 ++
+ fFORMULA x2 ++
+ fTACTIC_COM x3 ++
+ fID_LIST x4 ++
fNODE "hint_extern" 4
| CT_hintrewrite(x1, x2, x3, x4) ->
- fORIENTATION x1;
- fFORMULA_NE_LIST x2;
- fID x3;
- fTACTIC_COM x4;
+ fORIENTATION x1 ++
+ fFORMULA_NE_LIST x2 ++
+ fID x3 ++
+ fTACTIC_COM x4 ++
fNODE "hintrewrite" 4
| CT_hints(x1, x2, x3) ->
- fID x1;
- fID_NE_LIST x2;
- fID_LIST x3;
+ fID x1 ++
+ fID_NE_LIST x2 ++
+ fID_LIST x3 ++
fNODE "hints" 3
| CT_hints_immediate(x1, x2) ->
- fFORMULA_NE_LIST x1;
- fID_LIST x2;
+ fFORMULA_NE_LIST x1 ++
+ fID_LIST x2 ++
fNODE "hints_immediate" 2
| CT_hints_resolve(x1, x2) ->
- fFORMULA_NE_LIST x1;
- fID_LIST x2;
+ fFORMULA_NE_LIST x1 ++
+ fID_LIST x2 ++
fNODE "hints_resolve" 2
| CT_hyp_search_pattern(x1, x2) ->
- fFORMULA x1;
- fIN_OR_OUT_MODULES x2;
+ fFORMULA x1 ++
+ fIN_OR_OUT_MODULES x2 ++
fNODE "hyp_search_pattern" 2
| CT_implicits(x1, x2) ->
- fID x1;
- fID_LIST_OPT x2;
+ fID x1 ++
+ fID_LIST_OPT x2 ++
fNODE "implicits" 2
| CT_import_id(x1) ->
- fID_NE_LIST x1;
+ fID_NE_LIST x1 ++
fNODE "import_id" 1
| CT_ind_scheme(x1) ->
- fSCHEME_SPEC_LIST x1;
+ fSCHEME_SPEC_LIST x1 ++
fNODE "ind_scheme" 1
| CT_infix(x1, x2, x3, x4) ->
- fSTRING x1;
- fID x2;
- fMODIFIER_LIST x3;
- fID_OPT x4;
+ fSTRING x1 ++
+ fID x2 ++
+ fMODIFIER_LIST x3 ++
+ fID_OPT x4 ++
fNODE "infix" 4
| CT_inline(x1) ->
- fID_NE_LIST x1;
+ fID_NE_LIST x1 ++
fNODE "inline" 1
| CT_inspect(x1) ->
- fINT x1;
+ fINT x1 ++
fNODE "inspect" 1
| CT_kill_node(x1) ->
- fINT x1;
+ fINT x1 ++
fNODE "kill_node" 1
| CT_load(x1, x2) ->
- fVERBOSE_OPT x1;
- fID_OR_STRING x2;
+ fVERBOSE_OPT x1 ++
+ fID_OR_STRING x2 ++
fNODE "load" 2
| CT_local_close_scope(x1) ->
- fID x1;
+ fID x1 ++
fNODE "local_close_scope" 1
| CT_local_define_notation(x1, x2, x3, x4) ->
- fSTRING x1;
- fFORMULA x2;
- fMODIFIER_LIST x3;
- fID_OPT x4;
+ fSTRING x1 ++
+ fFORMULA x2 ++
+ fMODIFIER_LIST x3 ++
+ fID_OPT x4 ++
fNODE "local_define_notation" 4
| CT_local_hint_destruct(x1, x2, x3, x4, x5, x6) ->
- fID x1;
- fINT x2;
- fDESTRUCT_LOCATION x3;
- fFORMULA x4;
- fTACTIC_COM x5;
- fID_LIST x6;
+ fID x1 ++
+ fINT x2 ++
+ fDESTRUCT_LOCATION x3 ++
+ fFORMULA x4 ++
+ fTACTIC_COM x5 ++
+ fID_LIST x6 ++
fNODE "local_hint_destruct" 6
| CT_local_hint_extern(x1, x2, x3, x4) ->
- fINT x1;
- fFORMULA x2;
- fTACTIC_COM x3;
- fID_LIST x4;
+ fINT x1 ++
+ fFORMULA x2 ++
+ fTACTIC_COM x3 ++
+ fID_LIST x4 ++
fNODE "local_hint_extern" 4
| CT_local_hints(x1, x2, x3) ->
- fID x1;
- fID_NE_LIST x2;
- fID_LIST x3;
+ fID x1 ++
+ fID_NE_LIST x2 ++
+ fID_LIST x3 ++
fNODE "local_hints" 3
| CT_local_hints_immediate(x1, x2) ->
- fFORMULA_NE_LIST x1;
- fID_LIST x2;
+ fFORMULA_NE_LIST x1 ++
+ fID_LIST x2 ++
fNODE "local_hints_immediate" 2
| CT_local_hints_resolve(x1, x2) ->
- fFORMULA_NE_LIST x1;
- fID_LIST x2;
+ fFORMULA_NE_LIST x1 ++
+ fID_LIST x2 ++
fNODE "local_hints_resolve" 2
| CT_local_infix(x1, x2, x3, x4) ->
- fSTRING x1;
- fID x2;
- fMODIFIER_LIST x3;
- fID_OPT x4;
+ fSTRING x1 ++
+ fID x2 ++
+ fMODIFIER_LIST x3 ++
+ fID_OPT x4 ++
fNODE "local_infix" 4
| CT_local_open_scope(x1) ->
- fID x1;
+ fID x1 ++
fNODE "local_open_scope" 1
| CT_local_reserve_notation(x1, x2) ->
- fSTRING x1;
- fMODIFIER_LIST x2;
+ fSTRING x1 ++
+ fMODIFIER_LIST x2 ++
fNODE "local_reserve_notation" 2
| CT_locate(x1) ->
- fID x1;
+ fID x1 ++
fNODE "locate" 1
| CT_locate_file(x1) ->
- fSTRING x1;
+ fSTRING x1 ++
fNODE "locate_file" 1
| CT_locate_lib(x1) ->
- fID x1;
+ fID x1 ++
fNODE "locate_lib" 1
| CT_locate_notation(x1) ->
- fSTRING x1;
+ fSTRING x1 ++
fNODE "locate_notation" 1
| CT_mind_decl(x1, x2) ->
- fCO_IND x1;
- fIND_SPEC_LIST x2;
+ fCO_IND x1 ++
+ fIND_SPEC_LIST x2 ++
fNODE "mind_decl" 2
| CT_ml_add_path(x1) ->
- fSTRING x1;
+ fSTRING x1 ++
fNODE "ml_add_path" 1
| CT_ml_declare_modules(x1) ->
- fSTRING_NE_LIST x1;
+ fSTRING_NE_LIST x1 ++
fNODE "ml_declare_modules" 1
| CT_ml_print_modules -> fNODE "ml_print_modules" 0
| CT_ml_print_path -> fNODE "ml_print_path" 0
| CT_module(x1, x2, x3, x4) ->
- fID x1;
- fMODULE_BINDER_LIST x2;
- fMODULE_TYPE_CHECK x3;
- fMODULE_EXPR x4;
+ fID x1 ++
+ fMODULE_BINDER_LIST x2 ++
+ fMODULE_TYPE_CHECK x3 ++
+ fMODULE_EXPR x4 ++
fNODE "module" 4
| CT_module_type_decl(x1, x2, x3) ->
- fID x1;
- fMODULE_BINDER_LIST x2;
- fMODULE_TYPE_OPT x3;
+ fID x1 ++
+ fMODULE_BINDER_LIST x2 ++
+ fMODULE_TYPE_OPT x3 ++
fNODE "module_type_decl" 3
| CT_no_inline(x1) ->
- fID_NE_LIST x1;
+ fID_NE_LIST x1 ++
fNODE "no_inline" 1
| CT_omega_flag(x1, x2) ->
- fOMEGA_MODE x1;
- fOMEGA_FEATURE x2;
+ fOMEGA_MODE x1 ++
+ fOMEGA_FEATURE x2 ++
fNODE "omega_flag" 2
-| CT_opaque(x1) ->
- fID_NE_LIST x1;
- fNODE "opaque" 1
| CT_open_scope(x1) ->
- fID x1;
+ fID x1 ++
fNODE "open_scope" 1
| CT_print -> fNODE "print" 0
| CT_print_about(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_about" 1
| CT_print_all -> fNODE "print_all" 0
| CT_print_classes -> fNODE "print_classes" 0
| CT_print_ltac id ->
- fID id;
+ fID id ++
fNODE "print_ltac" 1
| CT_print_coercions -> fNODE "print_coercions" 0
| CT_print_grammar(x1) ->
- fGRAMMAR x1;
+ fGRAMMAR x1 ++
fNODE "print_grammar" 1
| CT_print_graph -> fNODE "print_graph" 0
| CT_print_hint(x1) ->
- fID_OPT x1;
+ fID_OPT x1 ++
fNODE "print_hint" 1
| CT_print_hintdb(x1) ->
- fID_OR_STAR x1;
+ fID_OR_STAR x1 ++
fNODE "print_hintdb" 1
| CT_print_rewrite_hintdb(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_rewrite_hintdb" 1
| CT_print_id(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_id" 1
| CT_print_implicit(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_implicit" 1
| CT_print_loadpath -> fNODE "print_loadpath" 0
| CT_print_module(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_module" 1
| CT_print_module_type(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_module_type" 1
| CT_print_modules -> fNODE "print_modules" 0
| CT_print_natural(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_natural" 1
| CT_print_natural_feature(x1) ->
- fNATURAL_FEATURE x1;
+ fNATURAL_FEATURE x1 ++
fNODE "print_natural_feature" 1
| CT_print_opaqueid(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_opaqueid" 1
| CT_print_path(x1, x2) ->
- fID x1;
- fID x2;
+ fID x1 ++
+ fID x2 ++
fNODE "print_path" 2
| CT_print_proof(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_proof" 1
| CT_print_scope(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_scope" 1
| CT_print_setoids -> fNODE "print_setoids" 0
| CT_print_scopes -> fNODE "print_scopes" 0
| CT_print_section(x1) ->
- fID x1;
+ fID x1 ++
fNODE "print_section" 1
| CT_print_states -> fNODE "print_states" 0
| CT_print_tables -> fNODE "print_tables" 0
| CT_print_universes(x1) ->
- fSTRING_OPT x1;
+ fSTRING_OPT x1 ++
fNODE "print_universes" 1
| CT_print_visibility(x1) ->
- fID_OPT x1;
+ fID_OPT x1 ++
fNODE "print_visibility" 1
| CT_proof(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "proof" 1
| CT_proof_no_op -> fNODE "proof_no_op" 0
| CT_proof_with(x1) ->
- fTACTIC_COM x1;
+ fTACTIC_COM x1 ++
fNODE "proof_with" 1
| CT_pwd -> fNODE "pwd" 0
| CT_quit -> fNODE "quit" 0
| CT_read_module(x1) ->
- fID x1;
+ fID x1 ++
fNODE "read_module" 1
| CT_rec_ml_add_path(x1) ->
- fSTRING x1;
+ fSTRING x1 ++
fNODE "rec_ml_add_path" 1
| CT_recaddpath(x1, x2) ->
- fSTRING x1;
- fID_OPT x2;
+ fSTRING x1 ++
+ fID_OPT x2 ++
fNODE "recaddpath" 2
| CT_record(x1, x2, x3, x4, x5, x6) ->
- fCOERCION_OPT x1;
- fID x2;
- fBINDER_LIST x3;
- fFORMULA x4;
- fID_OPT x5;
- fRECCONSTR_LIST x6;
+ fCOERCION_OPT x1 ++
+ fID x2 ++
+ fBINDER_LIST x3 ++
+ fFORMULA x4 ++
+ fID_OPT x5 ++
+ fRECCONSTR_LIST x6 ++
fNODE "record" 6
| CT_remove_natural_feature(x1, x2) ->
- fNATURAL_FEATURE x1;
- fID x2;
+ fNATURAL_FEATURE x1 ++
+ fID x2 ++
fNODE "remove_natural_feature" 2
| CT_require(x1, x2, x3) ->
- fIMPEXP x1;
- fSPEC_OPT x2;
- fID_NE_LIST_OR_STRING x3;
+ fIMPEXP x1 ++
+ fSPEC_OPT x2 ++
+ fID_NE_LIST_OR_STRING x3 ++
fNODE "require" 3
| CT_reserve(x1, x2) ->
- fID_NE_LIST x1;
- fFORMULA x2;
+ fID_NE_LIST x1 ++
+ fFORMULA x2 ++
fNODE "reserve" 2
| CT_reserve_notation(x1, x2) ->
- fSTRING x1;
- fMODIFIER_LIST x2;
+ fSTRING x1 ++
+ fMODIFIER_LIST x2 ++
fNODE "reserve_notation" 2
| CT_reset(x1) ->
- fID x1;
+ fID x1 ++
fNODE "reset" 1
| CT_reset_section(x1) ->
- fID x1;
+ fID x1 ++
fNODE "reset_section" 1
| CT_restart -> fNODE "restart" 0
| CT_restore_state(x1) ->
- fID x1;
+ fID x1 ++
fNODE "restore_state" 1
| CT_resume(x1) ->
- fID_OPT x1;
+ fID_OPT x1 ++
fNODE "resume" 1
| CT_save(x1, x2) ->
- fTHM_OPT x1;
- fID_OPT x2;
+ fTHM_OPT x1 ++
+ fID_OPT x2 ++
fNODE "save" 2
| CT_scomments(x1) ->
- fSCOMMENT_CONTENT_LIST x1;
+ fSCOMMENT_CONTENT_LIST x1 ++
fNODE "scomments" 1
| CT_search(x1, x2) ->
- fID x1;
- fIN_OR_OUT_MODULES x2;
+ fID x1 ++
+ fIN_OR_OUT_MODULES x2 ++
fNODE "search" 2
| CT_search_about(x1, x2) ->
- fID_OR_STRING_NE_LIST x1;
- fIN_OR_OUT_MODULES x2;
+ fID_OR_STRING_NE_LIST x1 ++
+ fIN_OR_OUT_MODULES x2 ++
fNODE "search_about" 2
| CT_search_pattern(x1, x2) ->
- fFORMULA x1;
- fIN_OR_OUT_MODULES x2;
+ fFORMULA x1 ++
+ fIN_OR_OUT_MODULES x2 ++
fNODE "search_pattern" 2
| CT_search_rewrite(x1, x2) ->
- fFORMULA x1;
- fIN_OR_OUT_MODULES x2;
+ fFORMULA x1 ++
+ fIN_OR_OUT_MODULES x2 ++
fNODE "search_rewrite" 2
| CT_section_end(x1) ->
- fID x1;
+ fID x1 ++
fNODE "section_end" 1
| CT_section_struct(x1, x2, x3) ->
- fSECTION_BEGIN x1;
- fSECTION_BODY x2;
- fCOMMAND x3;
+ fSECTION_BEGIN x1 ++
+ fSECTION_BODY x2 ++
+ fCOMMAND x3 ++
fNODE "section_struct" 3
| CT_set_natural(x1) ->
- fID x1;
+ fID x1 ++
fNODE "set_natural" 1
| CT_set_natural_default -> fNODE "set_natural_default" 0
| CT_set_option(x1) ->
- fTABLE x1;
+ fTABLE x1 ++
fNODE "set_option" 1
| CT_set_option_value(x1, x2) ->
- fTABLE x1;
- fSINGLE_OPTION_VALUE x2;
+ fTABLE x1 ++
+ fSINGLE_OPTION_VALUE x2 ++
fNODE "set_option_value" 2
| CT_set_option_value2(x1, x2) ->
- fTABLE x1;
- fID_OR_STRING_NE_LIST x2;
+ fTABLE x1 ++
+ fID_OR_STRING_NE_LIST x2 ++
fNODE "set_option_value2" 2
| CT_sethyp(x1) ->
- fINT x1;
+ fINT x1 ++
fNODE "sethyp" 1
| CT_setundo(x1) ->
- fINT x1;
+ fINT x1 ++
fNODE "setundo" 1
| CT_show_existentials -> fNODE "show_existentials" 0
| CT_show_goal(x1) ->
- fINT_OPT x1;
+ fINT_OPT x1 ++
fNODE "show_goal" 1
| CT_show_implicit(x1) ->
- fINT x1;
+ fINT x1 ++
fNODE "show_implicit" 1
| CT_show_intro -> fNODE "show_intro" 0
| CT_show_intros -> fNODE "show_intros" 0
@@ -587,97 +589,103 @@ and fCOMMAND = function
| CT_show_script -> fNODE "show_script" 0
| CT_show_tree -> fNODE "show_tree" 0
| CT_solve(x1, x2, x3) ->
- fINT x1;
- fTACTIC_COM x2;
- fDOTDOT_OPT x3;
+ fINT x1 ++
+ fTACTIC_COM x2 ++
+ fDOTDOT_OPT x3 ++
fNODE "solve" 3
+| CT_strategy(CT_level_list x1) ->
+ List.fold_left (++) (mt())
+ (List.map (fun(l,q) -> fLEVEL l ++ fID_LIST q ++ fNODE "pair"2) x1) ++
+ fNODE "strategy" (List.length x1)
| CT_suspend -> fNODE "suspend" 0
| CT_syntax_macro(x1, x2, x3) ->
- fID x1;
- fFORMULA x2;
- fINT_OPT x3;
+ fID x1 ++
+ fFORMULA x2 ++
+ fINT_OPT x3 ++
fNODE "syntax_macro" 3
| CT_tactic_definition(x1) ->
- fTAC_DEF_NE_LIST x1;
+ fTAC_DEF_NE_LIST x1 ++
fNODE "tactic_definition" 1
| CT_test_natural_feature(x1, x2) ->
- fNATURAL_FEATURE x1;
- fID x2;
+ fNATURAL_FEATURE x1 ++
+ fID x2 ++
fNODE "test_natural_feature" 2
| CT_theorem_struct(x1, x2) ->
- fTHEOREM_GOAL x1;
- fPROOF_SCRIPT x2;
+ fTHEOREM_GOAL x1 ++
+ fPROOF_SCRIPT x2 ++
fNODE "theorem_struct" 2
| CT_time(x1) ->
- fCOMMAND x1;
+ fCOMMAND x1 ++
fNODE "time" 1
-| CT_transparent(x1) ->
- fID_NE_LIST x1;
- fNODE "transparent" 1
| CT_undo(x1) ->
- fINT_OPT x1;
+ fINT_OPT x1 ++
fNODE "undo" 1
| CT_unfocus -> fNODE "unfocus" 0
| CT_unset_option(x1) ->
- fTABLE x1;
+ fTABLE x1 ++
fNODE "unset_option" 1
| CT_unsethyp -> fNODE "unsethyp" 0
| CT_unsetundo -> fNODE "unsetundo" 0
| CT_user_vernac(x1, x2) ->
- fID x1;
- fVARG_LIST x2;
+ fID x1 ++
+ fVARG_LIST x2 ++
fNODE "user_vernac" 2
| CT_variable(x1, x2) ->
- fVAR x1;
- fBINDER_NE_LIST x2;
+ fVAR x1 ++
+ fBINDER_NE_LIST x2 ++
fNODE "variable" 2
| CT_write_module(x1, x2) ->
- fID x1;
- fSTRING_OPT x2;
+ fID x1 ++
+ fSTRING_OPT x2 ++
fNODE "write_module" 2
+and fLEVEL = function
+| CT_Opaque -> fNODE "opaque" 0
+| CT_Level n -> fINT n ++ fNODE "level" 1
+| CT_Expand -> fNODE "expand" 0
and fCOMMAND_LIST = function
| CT_command_list(x,l) ->
- fCOMMAND x;
- (List.iter fCOMMAND l);
+ fCOMMAND x ++
+ (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++
fNODE "command_list" (1 + (List.length l))
and fCOMMENT = function
-| CT_comment x -> fATOM "comment";
- (f_atom_string x);
- print_string "\n"and fCOMMENT_S = function
+| CT_comment x -> fATOM "comment" ++
+ (f_atom_string x) ++
+ str "\n"
+and fCOMMENT_S = function
| CT_comment_s l ->
- (List.iter fCOMMENT l);
+ (List.fold_left (++) (mt()) (List.map fCOMMENT l)) ++
fNODE "comment_s" (List.length l)
and fCONSTR = function
| CT_constr(x1, x2) ->
- fID x1;
- fFORMULA x2;
+ fID x1 ++
+ fFORMULA x2 ++
fNODE "constr" 2
| CT_constr_coercion(x1, x2) ->
- fID x1;
- fFORMULA x2;
+ fID x1 ++
+ fFORMULA x2 ++
fNODE "constr_coercion" 2
and fCONSTR_LIST = function
| CT_constr_list l ->
- (List.iter fCONSTR l);
+ (List.fold_left (++) (mt()) (List.map fCONSTR l)) ++
fNODE "constr_list" (List.length l)
and fCONTEXT_HYP_LIST = function
| CT_context_hyp_list l ->
- (List.iter fPREMISE_PATTERN l);
+ (List.fold_left (++) (mt()) (List.map fPREMISE_PATTERN l)) ++
fNODE "context_hyp_list" (List.length l)
and fCONTEXT_PATTERN = function
| CT_coerce_FORMULA_to_CONTEXT_PATTERN x -> fFORMULA x
| CT_context(x1, x2) ->
- fID_OPT x1;
- fFORMULA x2;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
fNODE "context" 2
and fCONTEXT_RULE = function
| CT_context_rule(x1, x2, x3) ->
- fCONTEXT_HYP_LIST x1;
- fCONTEXT_PATTERN x2;
- fTACTIC_COM x3;
+ fCONTEXT_HYP_LIST x1 ++
+ fCONTEXT_PATTERN x2 ++
+ fTACTIC_COM x3 ++
fNODE "context_rule" 3
| CT_def_context_rule(x1) ->
- fTACTIC_COM x1;
+ fTACTIC_COM x1 ++
fNODE "def_context_rule" 1
and fCONVERSION_FLAG = function
| CT_beta -> fNODE "beta" 0
@@ -687,49 +695,52 @@ and fCONVERSION_FLAG = function
| CT_zeta -> fNODE "zeta" 0
and fCONVERSION_FLAG_LIST = function
| CT_conversion_flag_list l ->
- (List.iter fCONVERSION_FLAG l);
+ (List.fold_left (++) (mt()) (List.map fCONVERSION_FLAG l)) ++
fNODE "conversion_flag_list" (List.length l)
and fCONV_SET = function
| CT_unf l ->
- (List.iter fID l);
+ (List.fold_left (++) (mt()) (List.map fID l)) ++
fNODE "unf" (List.length l)
| CT_unfbut l ->
- (List.iter fID l);
+ (List.fold_left (++) (mt()) (List.map fID l)) ++
fNODE "unfbut" (List.length l)
and fCO_IND = function
-| CT_co_ind x -> fATOM "co_ind";
- (f_atom_string x);
- print_string "\n"and fDECL_NOTATION_OPT = function
+| CT_co_ind x -> fATOM "co_ind" ++
+ (f_atom_string x) ++
+ str "\n"
+and fDECL_NOTATION_OPT = function
| CT_coerce_NONE_to_DECL_NOTATION_OPT x -> fNONE x
| CT_decl_notation(x1, x2, x3) ->
- fSTRING x1;
- fFORMULA x2;
- fID_OPT x3;
+ fSTRING x1 ++
+ fFORMULA x2 ++
+ fID_OPT x3 ++
fNODE "decl_notation" 3
and fDEF = function
| CT_def(x1, x2) ->
- fID_OPT x1;
- fFORMULA x2;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
fNODE "def" 2
and fDEFN = function
-| CT_defn x -> fATOM "defn";
- (f_atom_string x);
- print_string "\n"and fDEFN_OR_THM = function
+| CT_defn x -> fATOM "defn" ++
+ (f_atom_string x) ++
+ str "\n"
+and fDEFN_OR_THM = function
| CT_coerce_DEFN_to_DEFN_OR_THM x -> fDEFN x
| CT_coerce_THM_to_DEFN_OR_THM x -> fTHM x
and fDEF_BODY = function
| CT_coerce_CONTEXT_PATTERN_to_DEF_BODY x -> fCONTEXT_PATTERN x
| CT_coerce_EVAL_CMD_to_DEF_BODY x -> fEVAL_CMD x
| CT_type_of(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "type_of" 1
and fDEF_BODY_OPT = function
| CT_coerce_DEF_BODY_to_DEF_BODY_OPT x -> fDEF_BODY x
| CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT x -> fFORMULA_OPT x
and fDEP = function
-| CT_dep x -> fATOM "dep";
- (f_atom_string x);
- print_string "\n"and fDESTRUCTING = function
+| CT_dep x -> fATOM "dep" ++
+ (f_atom_string x) ++
+ str "\n"
+and fDESTRUCTING = function
| CT_coerce_NONE_to_DESTRUCTING x -> fNONE x
| CT_destructing -> fNODE "destructing" 0
and fDESTRUCT_LOCATION = function
@@ -741,54 +752,54 @@ and fDOTDOT_OPT = function
| CT_dotdot -> fNODE "dotdot" 0
and fEQN = function
| CT_eqn(x1, x2) ->
- fMATCH_PATTERN_NE_LIST x1;
- fFORMULA x2;
+ fMATCH_PATTERN_NE_LIST x1 ++
+ fFORMULA x2 ++
fNODE "eqn" 2
and fEQN_LIST = function
| CT_eqn_list l ->
- (List.iter fEQN l);
+ (List.fold_left (++) (mt()) (List.map fEQN l)) ++
fNODE "eqn_list" (List.length l)
and fEVAL_CMD = function
| CT_eval(x1, x2, x3) ->
- fINT_OPT x1;
- fRED_COM x2;
- fFORMULA x3;
+ fINT_OPT x1 ++
+ fRED_COM x2 ++
+ fFORMULA x3 ++
fNODE "eval" 3
and fFIXTAC = function
| CT_fixtac(x1, x2, x3) ->
- fID x1;
- fINT x2;
- fFORMULA x3;
+ fID x1 ++
+ fINT x2 ++
+ fFORMULA x3 ++
fNODE "fixtac" 3
and fFIX_BINDER = function
| CT_coerce_FIX_REC_to_FIX_BINDER x -> fFIX_REC x
| CT_fix_binder(x1, x2, x3, x4) ->
- fID x1;
- fINT x2;
- fFORMULA x3;
- fFORMULA x4;
+ fID x1 ++
+ fINT x2 ++
+ fFORMULA x3 ++
+ fFORMULA x4 ++
fNODE "fix_binder" 4
and fFIX_BINDER_LIST = function
| CT_fix_binder_list(x,l) ->
- fFIX_BINDER x;
- (List.iter fFIX_BINDER l);
+ fFIX_BINDER x ++
+ (List.fold_left (++) (mt()) (List.map fFIX_BINDER l)) ++
fNODE "fix_binder_list" (1 + (List.length l))
and fFIX_REC = function
| CT_fix_rec(x1, x2, x3, x4, x5) ->
- fID x1;
- fBINDER_NE_LIST x2;
- fID_OPT x3;
- fFORMULA x4;
- fFORMULA x5;
+ fID x1 ++
+ fBINDER_NE_LIST x2 ++
+ fID_OPT x3 ++
+ fFORMULA x4 ++
+ fFORMULA x5 ++
fNODE "fix_rec" 5
and fFIX_REC_LIST = function
| CT_fix_rec_list(x,l) ->
- fFIX_REC x;
- (List.iter fFIX_REC l);
+ fFIX_REC x ++
+ (List.fold_left (++) (mt()) (List.map fFIX_REC l)) ++
fNODE "fix_rec_list" (1 + (List.length l))
and fFIX_TAC_LIST = function
| CT_fix_tac_list l ->
- (List.iter fFIXTAC l);
+ (List.fold_left (++) (mt()) (List.map fFIXTAC l)) ++
fNODE "fix_tac_list" (List.length l)
and fFORMULA = function
| CT_coerce_BINARY_to_FORMULA x -> fBINARY x
@@ -797,90 +808,90 @@ and fFORMULA = function
| CT_coerce_SORT_TYPE_to_FORMULA x -> fSORT_TYPE x
| CT_coerce_TYPED_FORMULA_to_FORMULA x -> fTYPED_FORMULA x
| CT_appc(x1, x2) ->
- fFORMULA x1;
- fFORMULA_NE_LIST x2;
+ fFORMULA x1 ++
+ fFORMULA_NE_LIST x2 ++
fNODE "appc" 2
| CT_arrowc(x1, x2) ->
- fFORMULA x1;
- fFORMULA x2;
+ fFORMULA x1 ++
+ fFORMULA x2 ++
fNODE "arrowc" 2
| CT_bang(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "bang" 1
| CT_cases(x1, x2, x3) ->
- fMATCHED_FORMULA_NE_LIST x1;
- fFORMULA_OPT x2;
- fEQN_LIST x3;
+ fMATCHED_FORMULA_NE_LIST x1 ++
+ fFORMULA_OPT x2 ++
+ fEQN_LIST x3 ++
fNODE "cases" 3
| CT_cofixc(x1, x2) ->
- fID x1;
- fCOFIX_REC_LIST x2;
+ fID x1 ++
+ fCOFIX_REC_LIST x2 ++
fNODE "cofixc" 2
| CT_elimc(x1, x2, x3, x4) ->
- fCASE x1;
- fFORMULA_OPT x2;
- fFORMULA x3;
- fFORMULA_LIST x4;
+ fCASE x1 ++
+ fFORMULA_OPT x2 ++
+ fFORMULA x3 ++
+ fFORMULA_LIST x4 ++
fNODE "elimc" 4
| CT_existvarc -> fNODE "existvarc" 0
| CT_fixc(x1, x2) ->
- fID x1;
- fFIX_BINDER_LIST x2;
+ fID x1 ++
+ fFIX_BINDER_LIST x2 ++
fNODE "fixc" 2
| CT_if(x1, x2, x3, x4) ->
- fFORMULA x1;
- fRETURN_INFO x2;
- fFORMULA x3;
- fFORMULA x4;
+ fFORMULA x1 ++
+ fRETURN_INFO x2 ++
+ fFORMULA x3 ++
+ fFORMULA x4 ++
fNODE "if" 4
| CT_inductive_let(x1, x2, x3, x4) ->
- fFORMULA_OPT x1;
- fID_OPT_NE_LIST x2;
- fFORMULA x3;
- fFORMULA x4;
+ fFORMULA_OPT x1 ++
+ fID_OPT_NE_LIST x2 ++
+ fFORMULA x3 ++
+ fFORMULA x4 ++
fNODE "inductive_let" 4
| CT_labelled_arg(x1, x2) ->
- fID x1;
- fFORMULA x2;
+ fID x1 ++
+ fFORMULA x2 ++
fNODE "labelled_arg" 2
| CT_lambdac(x1, x2) ->
- fBINDER_NE_LIST x1;
- fFORMULA x2;
+ fBINDER_NE_LIST x1 ++
+ fFORMULA x2 ++
fNODE "lambdac" 2
| CT_let_tuple(x1, x2, x3, x4) ->
- fID_OPT_NE_LIST x1;
- fRETURN_INFO x2;
- fFORMULA x3;
- fFORMULA x4;
+ fID_OPT_NE_LIST x1 ++
+ fRETURN_INFO x2 ++
+ fFORMULA x3 ++
+ fFORMULA x4 ++
fNODE "let_tuple" 4
| CT_letin(x1, x2) ->
- fDEF x1;
- fFORMULA x2;
+ fDEF x1 ++
+ fFORMULA x2 ++
fNODE "letin" 2
| CT_notation(x1, x2) ->
- fSTRING x1;
- fFORMULA_LIST x2;
+ fSTRING x1 ++
+ fFORMULA_LIST x2 ++
fNODE "notation" 2
| CT_num_encapsulator(x1, x2) ->
- fNUM_TYPE x1;
- fFORMULA x2;
+ fNUM_TYPE x1 ++
+ fFORMULA x2 ++
fNODE "num_encapsulator" 2
| CT_prodc(x1, x2) ->
- fBINDER_NE_LIST x1;
- fFORMULA x2;
+ fBINDER_NE_LIST x1 ++
+ fFORMULA x2 ++
fNODE "prodc" 2
| CT_proj(x1, x2) ->
- fFORMULA x1;
- fFORMULA_NE_LIST x2;
+ fFORMULA x1 ++
+ fFORMULA_NE_LIST x2 ++
fNODE "proj" 2
and fFORMULA_LIST = function
| CT_formula_list l ->
- (List.iter fFORMULA l);
+ (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++
fNODE "formula_list" (List.length l)
and fFORMULA_NE_LIST = function
| CT_formula_ne_list(x,l) ->
- fFORMULA x;
- (List.iter fFORMULA l);
+ fFORMULA x ++
+ (List.fold_left (++) (mt()) (List.map fFORMULA l)) ++
fNODE "formula_ne_list" (1 + (List.length l))
and fFORMULA_OPT = function
| CT_coerce_FORMULA_to_FORMULA_OPT x -> fFORMULA x
@@ -893,44 +904,46 @@ and fGRAMMAR = function
and fHYP_LOCATION = function
| CT_coerce_UNFOLD_to_HYP_LOCATION x -> fUNFOLD x
| CT_intype(x1, x2) ->
- fID x1;
- fINT_LIST x2;
+ fID x1 ++
+ fINT_LIST x2 ++
fNODE "intype" 2
| CT_invalue(x1, x2) ->
- fID x1;
- fINT_LIST x2;
+ fID x1 ++
+ fINT_LIST x2 ++
fNODE "invalue" 2
and fHYP_LOCATION_LIST_OR_STAR = function
| CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR x -> fSTAR x
| CT_hyp_location_list l ->
- (List.iter fHYP_LOCATION l);
+ (List.fold_left (++) (mt()) (List.map fHYP_LOCATION l)) ++
fNODE "hyp_location_list" (List.length l)
and fID = function
-| CT_ident x -> fATOM "ident";
- (f_atom_string x);
- print_string "\n"| CT_metac(x1) ->
- fINT x1;
+| CT_ident x -> fATOM "ident" ++
+ (f_atom_string x) ++
+ str "\n"
+| CT_metac(x1) ->
+ fINT x1 ++
fNODE "metac" 1
-| CT_metaid x -> fATOM "metaid";
- (f_atom_string x);
- print_string "\n"and fIDENTITY_OPT = function
+| CT_metaid x -> fATOM "metaid" ++
+ (f_atom_string x) ++
+ str "\n"
+and fIDENTITY_OPT = function
| CT_coerce_NONE_to_IDENTITY_OPT x -> fNONE x
| CT_identity -> fNODE "identity" 0
and fID_LIST = function
| CT_id_list l ->
- (List.iter fID l);
+ (List.fold_left (++) (mt()) (List.map fID l)) ++
fNODE "id_list" (List.length l)
and fID_LIST_LIST = function
| CT_id_list_list l ->
- (List.iter fID_LIST l);
+ (List.fold_left (++) (mt()) (List.map fID_LIST l)) ++
fNODE "id_list_list" (List.length l)
and fID_LIST_OPT = function
| CT_coerce_ID_LIST_to_ID_LIST_OPT x -> fID_LIST x
| CT_coerce_NONE_to_ID_LIST_OPT x -> fNONE x
and fID_NE_LIST = function
| CT_id_ne_list(x,l) ->
- fID x;
- (List.iter fID l);
+ fID x ++
+ (List.fold_left (++) (mt()) (List.map fID l)) ++
fNODE "id_ne_list" (1 + (List.length l))
and fID_NE_LIST_OR_STAR = function
| CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR x -> fID_NE_LIST x
@@ -943,12 +956,12 @@ and fID_OPT = function
| CT_coerce_NONE_to_ID_OPT x -> fNONE x
and fID_OPT_LIST = function
| CT_id_opt_list l ->
- (List.iter fID_OPT l);
+ (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++
fNODE "id_opt_list" (List.length l)
and fID_OPT_NE_LIST = function
| CT_id_opt_ne_list(x,l) ->
- fID_OPT x;
- (List.iter fID_OPT l);
+ fID_OPT x ++
+ (List.fold_left (++) (mt()) (List.map fID_OPT l)) ++
fNODE "id_opt_ne_list" (1 + (List.length l))
and fID_OPT_OR_ALL = function
| CT_coerce_ID_OPT_to_ID_OPT_OR_ALL x -> fID_OPT x
@@ -968,8 +981,8 @@ and fID_OR_STRING = function
| CT_coerce_STRING_to_ID_OR_STRING x -> fSTRING x
and fID_OR_STRING_NE_LIST = function
| CT_id_or_string_ne_list(x,l) ->
- fID_OR_STRING x;
- (List.iter fID_OR_STRING l);
+ fID_OR_STRING x ++
+ (List.fold_left (++) (mt()) (List.map fID_OR_STRING l)) ++
fNODE "id_or_string_ne_list" (1 + (List.length l))
and fIMPEXP = function
| CT_coerce_NONE_to_IMPEXP x -> fNONE x
@@ -977,40 +990,41 @@ and fIMPEXP = function
| CT_import -> fNODE "import" 0
and fIND_SPEC = function
| CT_ind_spec(x1, x2, x3, x4, x5) ->
- fID x1;
- fBINDER_LIST x2;
- fFORMULA x3;
- fCONSTR_LIST x4;
- fDECL_NOTATION_OPT x5;
+ fID x1 ++
+ fBINDER_LIST x2 ++
+ fFORMULA x3 ++
+ fCONSTR_LIST x4 ++
+ fDECL_NOTATION_OPT x5 ++
fNODE "ind_spec" 5
and fIND_SPEC_LIST = function
| CT_ind_spec_list l ->
- (List.iter fIND_SPEC l);
+ (List.fold_left (++) (mt()) (List.map fIND_SPEC l)) ++
fNODE "ind_spec_list" (List.length l)
and fINT = function
-| CT_int x -> fATOM "int";
- (f_atom_int x);
- print_string "\n"and fINTRO_PATT = function
+| CT_int x -> fATOM "int" ++
+ (f_atom_int x) ++
+ str "\n"
+and fINTRO_PATT = function
| CT_coerce_ID_to_INTRO_PATT x -> fID x
| CT_disj_pattern(x,l) ->
- fINTRO_PATT_LIST x;
- (List.iter fINTRO_PATT_LIST l);
+ fINTRO_PATT_LIST x ++
+ (List.fold_left (++) (mt()) (List.map fINTRO_PATT_LIST l)) ++
fNODE "disj_pattern" (1 + (List.length l))
and fINTRO_PATT_LIST = function
| CT_intro_patt_list l ->
- (List.iter fINTRO_PATT l);
+ (List.fold_left (++) (mt()) (List.map fINTRO_PATT l)) ++
fNODE "intro_patt_list" (List.length l)
and fINTRO_PATT_OPT = function
| CT_coerce_ID_OPT_to_INTRO_PATT_OPT x -> fID_OPT x
| CT_coerce_INTRO_PATT_to_INTRO_PATT_OPT x -> fINTRO_PATT x
and fINT_LIST = function
| CT_int_list l ->
- (List.iter fINT l);
+ (List.fold_left (++) (mt()) (List.map fINT l)) ++
fNODE "int_list" (List.length l)
and fINT_NE_LIST = function
| CT_int_ne_list(x,l) ->
- fINT x;
- (List.iter fINT l);
+ fINT x ++
+ (List.fold_left (++) (mt()) (List.map fINT l)) ++
fNODE "int_ne_list" (1 + (List.length l))
and fINT_OPT = function
| CT_coerce_INT_to_INT_OPT x -> fINT x
@@ -1028,21 +1042,21 @@ and fINV_TYPE = function
and fIN_OR_OUT_MODULES = function
| CT_coerce_NONE_to_IN_OR_OUT_MODULES x -> fNONE x
| CT_in_modules(x1) ->
- fID_NE_LIST x1;
+ fID_NE_LIST x1 ++
fNODE "in_modules" 1
| CT_out_modules(x1) ->
- fID_NE_LIST x1;
+ fID_NE_LIST x1 ++
fNODE "out_modules" 1
and fLET_CLAUSE = function
| CT_let_clause(x1, x2, x3) ->
- fID x1;
- fTACTIC_OPT x2;
- fLET_VALUE x3;
+ fID x1 ++
+ fTACTIC_OPT x2 ++
+ fLET_VALUE x3 ++
fNODE "let_clause" 3
and fLET_CLAUSES = function
| CT_let_clauses(x,l) ->
- fLET_CLAUSE x;
- (List.iter fLET_CLAUSE l);
+ fLET_CLAUSE x ++
+ (List.fold_left (++) (mt()) (List.map fLET_CLAUSE l)) ++
fNODE "let_clauses" (1 + (List.length l))
and fLET_VALUE = function
| CT_coerce_DEF_BODY_to_LET_VALUE x -> fDEF_BODY x
@@ -1051,120 +1065,121 @@ and fLOCAL_OPT = function
| CT_coerce_NONE_to_LOCAL_OPT x -> fNONE x
| CT_local -> fNODE "local" 0
and fLOCN = function
-| CT_locn x -> fATOM "locn";
- (f_atom_string x);
- print_string "\n"and fMATCHED_FORMULA = function
+| CT_locn x -> fATOM "locn" ++
+ (f_atom_string x) ++
+ str "\n"
+and fMATCHED_FORMULA = function
| CT_coerce_FORMULA_to_MATCHED_FORMULA x -> fFORMULA x
| CT_formula_as(x1, x2) ->
- fFORMULA x1;
- fID_OPT x2;
+ fFORMULA x1 ++
+ fID_OPT x2 ++
fNODE "formula_as" 2
| CT_formula_as_in(x1, x2, x3) ->
- fFORMULA x1;
- fID_OPT x2;
- fFORMULA x3;
+ fFORMULA x1 ++
+ fID_OPT x2 ++
+ fFORMULA x3 ++
fNODE "formula_as_in" 3
| CT_formula_in(x1, x2) ->
- fFORMULA x1;
- fFORMULA x2;
+ fFORMULA x1 ++
+ fFORMULA x2 ++
fNODE "formula_in" 2
and fMATCHED_FORMULA_NE_LIST = function
| CT_matched_formula_ne_list(x,l) ->
- fMATCHED_FORMULA x;
- (List.iter fMATCHED_FORMULA l);
+ fMATCHED_FORMULA x ++
+ (List.fold_left (++) (mt()) (List.map fMATCHED_FORMULA l)) ++
fNODE "matched_formula_ne_list" (1 + (List.length l))
and fMATCH_PATTERN = function
| CT_coerce_ID_OPT_to_MATCH_PATTERN x -> fID_OPT x
| CT_coerce_NUM_to_MATCH_PATTERN x -> fNUM x
| CT_pattern_app(x1, x2) ->
- fMATCH_PATTERN x1;
- fMATCH_PATTERN_NE_LIST x2;
+ fMATCH_PATTERN x1 ++
+ fMATCH_PATTERN_NE_LIST x2 ++
fNODE "pattern_app" 2
| CT_pattern_as(x1, x2) ->
- fMATCH_PATTERN x1;
- fID_OPT x2;
+ fMATCH_PATTERN x1 ++
+ fID_OPT x2 ++
fNODE "pattern_as" 2
| CT_pattern_delimitors(x1, x2) ->
- fNUM_TYPE x1;
- fMATCH_PATTERN x2;
+ fNUM_TYPE x1 ++
+ fMATCH_PATTERN x2 ++
fNODE "pattern_delimitors" 2
| CT_pattern_notation(x1, x2) ->
- fSTRING x1;
- fMATCH_PATTERN_LIST x2;
+ fSTRING x1 ++
+ fMATCH_PATTERN_LIST x2 ++
fNODE "pattern_notation" 2
and fMATCH_PATTERN_LIST = function
| CT_match_pattern_list l ->
- (List.iter fMATCH_PATTERN l);
+ (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++
fNODE "match_pattern_list" (List.length l)
and fMATCH_PATTERN_NE_LIST = function
| CT_match_pattern_ne_list(x,l) ->
- fMATCH_PATTERN x;
- (List.iter fMATCH_PATTERN l);
+ fMATCH_PATTERN x ++
+ (List.fold_left (++) (mt()) (List.map fMATCH_PATTERN l)) ++
fNODE "match_pattern_ne_list" (1 + (List.length l))
and fMATCH_TAC_RULE = function
| CT_match_tac_rule(x1, x2) ->
- fCONTEXT_PATTERN x1;
- fLET_VALUE x2;
+ fCONTEXT_PATTERN x1 ++
+ fLET_VALUE x2 ++
fNODE "match_tac_rule" 2
and fMATCH_TAC_RULES = function
| CT_match_tac_rules(x,l) ->
- fMATCH_TAC_RULE x;
- (List.iter fMATCH_TAC_RULE l);
+ fMATCH_TAC_RULE x ++
+ (List.fold_left (++) (mt()) (List.map fMATCH_TAC_RULE l)) ++
fNODE "match_tac_rules" (1 + (List.length l))
and fMODIFIER = function
| CT_entry_type(x1, x2) ->
- fID x1;
- fID x2;
+ fID x1 ++
+ fID x2 ++
fNODE "entry_type" 2
| CT_format(x1) ->
- fSTRING x1;
+ fSTRING x1 ++
fNODE "format" 1
| CT_lefta -> fNODE "lefta" 0
| CT_nona -> fNODE "nona" 0
| CT_only_parsing -> fNODE "only_parsing" 0
| CT_righta -> fNODE "righta" 0
| CT_set_item_level(x1, x2) ->
- fID_NE_LIST x1;
- fINT_OR_NEXT x2;
+ fID_NE_LIST x1 ++
+ fINT_OR_NEXT x2 ++
fNODE "set_item_level" 2
| CT_set_level(x1) ->
- fINT x1;
+ fINT x1 ++
fNODE "set_level" 1
and fMODIFIER_LIST = function
| CT_modifier_list l ->
- (List.iter fMODIFIER l);
+ (List.fold_left (++) (mt()) (List.map fMODIFIER l)) ++
fNODE "modifier_list" (List.length l)
and fMODULE_BINDER = function
| CT_module_binder(x1, x2) ->
- fID_NE_LIST x1;
- fMODULE_TYPE x2;
+ fID_NE_LIST x1 ++
+ fMODULE_TYPE x2 ++
fNODE "module_binder" 2
and fMODULE_BINDER_LIST = function
| CT_module_binder_list l ->
- (List.iter fMODULE_BINDER l);
+ (List.fold_left (++) (mt()) (List.map fMODULE_BINDER l)) ++
fNODE "module_binder_list" (List.length l)
and fMODULE_EXPR = function
| CT_coerce_ID_OPT_to_MODULE_EXPR x -> fID_OPT x
| CT_module_app(x1, x2) ->
- fMODULE_EXPR x1;
- fMODULE_EXPR x2;
+ fMODULE_EXPR x1 ++
+ fMODULE_EXPR x2 ++
fNODE "module_app" 2
and fMODULE_TYPE = function
| CT_coerce_ID_to_MODULE_TYPE x -> fID x
| CT_module_type_with_def(x1, x2, x3) ->
- fMODULE_TYPE x1;
- fID_LIST x2;
- fFORMULA x3;
+ fMODULE_TYPE x1 ++
+ fID_LIST x2 ++
+ fFORMULA x3 ++
fNODE "module_type_with_def" 3
| CT_module_type_with_mod(x1, x2, x3) ->
- fMODULE_TYPE x1;
- fID_LIST x2;
- fID x3;
+ fMODULE_TYPE x1 ++
+ fID_LIST x2 ++
+ fID x3 ++
fNODE "module_type_with_mod" 3
and fMODULE_TYPE_CHECK = function
| CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK x -> fMODULE_TYPE_OPT x
| CT_only_check(x1) ->
- fMODULE_TYPE x1;
+ fMODULE_TYPE x1 ++
fNODE "only_check" 1
and fMODULE_TYPE_OPT = function
| CT_coerce_ID_OPT_to_MODULE_TYPE_OPT x -> fID_OPT x
@@ -1176,12 +1191,14 @@ and fNATURAL_FEATURE = function
and fNONE = function
| CT_none -> fNODE "none" 0
and fNUM = function
-| CT_int_encapsulator x -> fATOM "int_encapsulator";
- (f_atom_string x);
- print_string "\n"and fNUM_TYPE = function
-| CT_num_type x -> fATOM "num_type";
- (f_atom_string x);
- print_string "\n"and fOMEGA_FEATURE = function
+| CT_int_encapsulator x -> fATOM "int_encapsulator" ++
+ (f_atom_string x) ++
+ str "\n"
+and fNUM_TYPE = function
+| CT_num_type x -> fATOM "num_type" ++
+ (f_atom_string x) ++
+ str "\n"
+and fOMEGA_FEATURE = function
| CT_coerce_STRING_to_OMEGA_FEATURE x -> fSTRING x
| CT_flag_action -> fNODE "flag_action" 0
| CT_flag_system -> fNODE "flag_system" 0
@@ -1195,13 +1212,13 @@ and fORIENTATION = function
| CT_rl -> fNODE "rl" 0
and fPATTERN = function
| CT_pattern_occ(x1, x2) ->
- fINT_LIST x1;
- fFORMULA x2;
+ fINT_LIST x1 ++
+ fFORMULA x2 ++
fNODE "pattern_occ" 2
and fPATTERN_NE_LIST = function
| CT_pattern_ne_list(x,l) ->
- fPATTERN x;
- (List.iter fPATTERN l);
+ fPATTERN x ++
+ (List.fold_left (++) (mt()) (List.map fPATTERN l)) ++
fNODE "pattern_ne_list" (1 + (List.length l))
and fPATTERN_OPT = function
| CT_coerce_NONE_to_PATTERN_OPT x -> fNONE x
@@ -1209,146 +1226,147 @@ and fPATTERN_OPT = function
and fPREMISE = function
| CT_coerce_TYPED_FORMULA_to_PREMISE x -> fTYPED_FORMULA x
| CT_eval_result(x1, x2, x3) ->
- fFORMULA x1;
- fFORMULA x2;
- fFORMULA x3;
+ fFORMULA x1 ++
+ fFORMULA x2 ++
+ fFORMULA x3 ++
fNODE "eval_result" 3
| CT_premise(x1, x2) ->
- fID x1;
- fFORMULA x2;
+ fID x1 ++
+ fFORMULA x2 ++
fNODE "premise" 2
and fPREMISES_LIST = function
| CT_premises_list l ->
- (List.iter fPREMISE l);
+ (List.fold_left (++) (mt()) (List.map fPREMISE l)) ++
fNODE "premises_list" (List.length l)
and fPREMISE_PATTERN = function
| CT_premise_pattern(x1, x2) ->
- fID_OPT x1;
- fCONTEXT_PATTERN x2;
+ fID_OPT x1 ++
+ fCONTEXT_PATTERN x2 ++
fNODE "premise_pattern" 2
and fPROOF_SCRIPT = function
| CT_proof_script l ->
- (List.iter fCOMMAND l);
+ (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++
fNODE "proof_script" (List.length l)
and fRECCONSTR = function
| CT_defrecconstr(x1, x2, x3) ->
- fID_OPT x1;
- fFORMULA x2;
- fFORMULA_OPT x3;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
+ fFORMULA_OPT x3 ++
fNODE "defrecconstr" 3
| CT_defrecconstr_coercion(x1, x2, x3) ->
- fID_OPT x1;
- fFORMULA x2;
- fFORMULA_OPT x3;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
+ fFORMULA_OPT x3 ++
fNODE "defrecconstr_coercion" 3
| CT_recconstr(x1, x2) ->
- fID_OPT x1;
- fFORMULA x2;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
fNODE "recconstr" 2
| CT_recconstr_coercion(x1, x2) ->
- fID_OPT x1;
- fFORMULA x2;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
fNODE "recconstr_coercion" 2
and fRECCONSTR_LIST = function
| CT_recconstr_list l ->
- (List.iter fRECCONSTR l);
+ (List.fold_left (++) (mt()) (List.map fRECCONSTR l)) ++
fNODE "recconstr_list" (List.length l)
and fREC_TACTIC_FUN = function
| CT_rec_tactic_fun(x1, x2, x3) ->
- fID x1;
- fID_OPT_NE_LIST x2;
- fTACTIC_COM x3;
+ fID x1 ++
+ fID_OPT_NE_LIST x2 ++
+ fTACTIC_COM x3 ++
fNODE "rec_tactic_fun" 3
and fREC_TACTIC_FUN_LIST = function
| CT_rec_tactic_fun_list(x,l) ->
- fREC_TACTIC_FUN x;
- (List.iter fREC_TACTIC_FUN l);
+ fREC_TACTIC_FUN x ++
+ (List.fold_left (++) (mt()) (List.map fREC_TACTIC_FUN l)) ++
fNODE "rec_tactic_fun_list" (1 + (List.length l))
and fRED_COM = function
| CT_cbv(x1, x2) ->
- fCONVERSION_FLAG_LIST x1;
- fCONV_SET x2;
+ fCONVERSION_FLAG_LIST x1 ++
+ fCONV_SET x2 ++
fNODE "cbv" 2
| CT_fold(x1) ->
- fFORMULA_LIST x1;
+ fFORMULA_LIST x1 ++
fNODE "fold" 1
| CT_hnf -> fNODE "hnf" 0
| CT_lazy(x1, x2) ->
- fCONVERSION_FLAG_LIST x1;
- fCONV_SET x2;
+ fCONVERSION_FLAG_LIST x1 ++
+ fCONV_SET x2 ++
fNODE "lazy" 2
| CT_pattern(x1) ->
- fPATTERN_NE_LIST x1;
+ fPATTERN_NE_LIST x1 ++
fNODE "pattern" 1
| CT_red -> fNODE "red" 0
| CT_cbvvm -> fNODE "vm_compute" 0
| CT_simpl(x1) ->
- fPATTERN_OPT x1;
+ fPATTERN_OPT x1 ++
fNODE "simpl" 1
| CT_unfold(x1) ->
- fUNFOLD_NE_LIST x1;
+ fUNFOLD_NE_LIST x1 ++
fNODE "unfold" 1
and fRETURN_INFO = function
| CT_coerce_NONE_to_RETURN_INFO x -> fNONE x
| CT_as_and_return(x1, x2) ->
- fID_OPT x1;
- fFORMULA x2;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
fNODE "as_and_return" 2
| CT_return(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "return" 1
and fRULE = function
| CT_rule(x1, x2) ->
- fPREMISES_LIST x1;
- fFORMULA x2;
+ fPREMISES_LIST x1 ++
+ fFORMULA x2 ++
fNODE "rule" 2
and fRULE_LIST = function
| CT_rule_list l ->
- (List.iter fRULE l);
+ (List.fold_left (++) (mt()) (List.map fRULE l)) ++
fNODE "rule_list" (List.length l)
and fSCHEME_SPEC = function
| CT_scheme_spec(x1, x2, x3, x4) ->
- fID x1;
- fDEP x2;
- fFORMULA x3;
- fSORT_TYPE x4;
+ fID x1 ++
+ fDEP x2 ++
+ fFORMULA x3 ++
+ fSORT_TYPE x4 ++
fNODE "scheme_spec" 4
and fSCHEME_SPEC_LIST = function
| CT_scheme_spec_list(x,l) ->
- fSCHEME_SPEC x;
- (List.iter fSCHEME_SPEC l);
+ fSCHEME_SPEC x ++
+ (List.fold_left (++) (mt()) (List.map fSCHEME_SPEC l)) ++
fNODE "scheme_spec_list" (1 + (List.length l))
and fSCOMMENT_CONTENT = function
| CT_coerce_FORMULA_to_SCOMMENT_CONTENT x -> fFORMULA x
| CT_coerce_ID_OR_STRING_to_SCOMMENT_CONTENT x -> fID_OR_STRING x
and fSCOMMENT_CONTENT_LIST = function
| CT_scomment_content_list l ->
- (List.iter fSCOMMENT_CONTENT l);
+ (List.fold_left (++) (mt()) (List.map fSCOMMENT_CONTENT l)) ++
fNODE "scomment_content_list" (List.length l)
and fSECTION_BEGIN = function
| CT_section(x1) ->
- fID x1;
+ fID x1 ++
fNODE "section" 1
and fSECTION_BODY = function
| CT_section_body l ->
- (List.iter fCOMMAND l);
+ (List.fold_left (++) (mt()) (List.map fCOMMAND l)) ++
fNODE "section_body" (List.length l)
and fSIGNED_INT = function
| CT_coerce_INT_to_SIGNED_INT x -> fINT x
| CT_minus(x1) ->
- fINT x1;
+ fINT x1 ++
fNODE "minus" 1
and fSIGNED_INT_LIST = function
| CT_signed_int_list l ->
- (List.iter fSIGNED_INT l);
+ (List.fold_left (++) (mt()) (List.map fSIGNED_INT l)) ++
fNODE "signed_int_list" (List.length l)
and fSINGLE_OPTION_VALUE = function
| CT_coerce_INT_to_SINGLE_OPTION_VALUE x -> fINT x
| CT_coerce_STRING_to_SINGLE_OPTION_VALUE x -> fSTRING x
and fSORT_TYPE = function
-| CT_sortc x -> fATOM "sortc";
- (f_atom_string x);
- print_string "\n"and fSPEC_LIST = function
+| CT_sortc x -> fATOM "sortc" ++
+ (f_atom_string x) ++
+ str "\n"
+and fSPEC_LIST = function
| CT_coerce_BINDING_LIST_to_SPEC_LIST x -> fBINDING_LIST x
| CT_coerce_FORMULA_LIST_to_SPEC_LIST x -> fFORMULA_LIST x
and fSPEC_OPT = function
@@ -1360,12 +1378,13 @@ and fSTAR_OPT = function
| CT_coerce_NONE_to_STAR_OPT x -> fNONE x
| CT_coerce_STAR_to_STAR_OPT x -> fSTAR x
and fSTRING = function
-| CT_string x -> fATOM "string";
- (f_atom_string x);
- print_string "\n"and fSTRING_NE_LIST = function
+| CT_string x -> fATOM "string" ++
+ (f_atom_string x) ++
+ str "\n"
+and fSTRING_NE_LIST = function
| CT_string_ne_list(x,l) ->
- fSTRING x;
- (List.iter fSTRING l);
+ fSTRING x ++
+ (List.fold_left (++) (mt()) (List.map fSTRING l)) ++
fNODE "string_ne_list" (1 + (List.length l))
and fSTRING_OPT = function
| CT_coerce_NONE_to_STRING_OPT x -> fNONE x
@@ -1373,8 +1392,8 @@ and fSTRING_OPT = function
and fTABLE = function
| CT_coerce_ID_to_TABLE x -> fID x
| CT_table(x1, x2) ->
- fID x1;
- fID x2;
+ fID x1 ++
+ fID x2 ++
fNODE "table" 2
and fTACTIC_ARG = function
| CT_coerce_EVAL_CMD_to_TACTIC_ARG x -> fEVAL_CMD x
@@ -1384,429 +1403,429 @@ and fTACTIC_ARG = function
| CT_void -> fNODE "void" 0
and fTACTIC_ARG_LIST = function
| CT_tactic_arg_list(x,l) ->
- fTACTIC_ARG x;
- (List.iter fTACTIC_ARG l);
+ fTACTIC_ARG x ++
+ (List.fold_left (++) (mt()) (List.map fTACTIC_ARG l)) ++
fNODE "tactic_arg_list" (1 + (List.length l))
and fTACTIC_COM = function
| CT_abstract(x1, x2) ->
- fID_OPT x1;
- fTACTIC_COM x2;
+ fID_OPT x1 ++
+ fTACTIC_COM x2 ++
fNODE "abstract" 2
| CT_absurd(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "absurd" 1
| CT_any_constructor(x1) ->
- fTACTIC_OPT x1;
+ fTACTIC_OPT x1 ++
fNODE "any_constructor" 1
| CT_apply(x1, x2) ->
- fFORMULA x1;
- fSPEC_LIST x2;
+ fFORMULA x1 ++
+ fSPEC_LIST x2 ++
fNODE "apply" 2
| CT_assert(x1, x2) ->
- fID_OPT x1;
- fFORMULA x2;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
fNODE "assert" 2
| CT_assumption -> fNODE "assumption" 0
| CT_auto(x1) ->
- fINT_OPT x1;
+ fINT_OPT x1 ++
fNODE "auto" 1
| CT_auto_with(x1, x2) ->
- fINT_OPT x1;
- fID_NE_LIST_OR_STAR x2;
+ fINT_OPT x1 ++
+ fID_NE_LIST_OR_STAR x2 ++
fNODE "auto_with" 2
| CT_autorewrite(x1, x2) ->
- fID_NE_LIST x1;
- fTACTIC_OPT x2;
+ fID_NE_LIST x1 ++
+ fTACTIC_OPT x2 ++
fNODE "autorewrite" 2
| CT_autotdb(x1) ->
- fINT_OPT x1;
+ fINT_OPT x1 ++
fNODE "autotdb" 1
| CT_case_type(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "case_type" 1
| CT_casetac(x1, x2) ->
- fFORMULA x1;
- fSPEC_LIST x2;
+ fFORMULA x1 ++
+ fSPEC_LIST x2 ++
fNODE "casetac" 2
| CT_cdhyp(x1) ->
- fID x1;
+ fID x1 ++
fNODE "cdhyp" 1
| CT_change(x1, x2) ->
- fFORMULA x1;
- fCLAUSE x2;
+ fFORMULA x1 ++
+ fCLAUSE x2 ++
fNODE "change" 2
| CT_change_local(x1, x2, x3) ->
- fPATTERN x1;
- fFORMULA x2;
- fCLAUSE x3;
+ fPATTERN x1 ++
+ fFORMULA x2 ++
+ fCLAUSE x3 ++
fNODE "change_local" 3
| CT_clear(x1) ->
- fID_NE_LIST x1;
+ fID_NE_LIST x1 ++
fNODE "clear" 1
| CT_clear_body(x1) ->
- fID_NE_LIST x1;
+ fID_NE_LIST x1 ++
fNODE "clear_body" 1
| CT_cofixtactic(x1, x2) ->
- fID_OPT x1;
- fCOFIX_TAC_LIST x2;
+ fID_OPT x1 ++
+ fCOFIX_TAC_LIST x2 ++
fNODE "cofixtactic" 2
| CT_condrewrite_lr(x1, x2, x3, x4) ->
- fTACTIC_COM x1;
- fFORMULA x2;
- fSPEC_LIST x3;
- fID_OPT x4;
+ fTACTIC_COM x1 ++
+ fFORMULA x2 ++
+ fSPEC_LIST x3 ++
+ fID_OPT x4 ++
fNODE "condrewrite_lr" 4
| CT_condrewrite_rl(x1, x2, x3, x4) ->
- fTACTIC_COM x1;
- fFORMULA x2;
- fSPEC_LIST x3;
- fID_OPT x4;
+ fTACTIC_COM x1 ++
+ fFORMULA x2 ++
+ fSPEC_LIST x3 ++
+ fID_OPT x4 ++
fNODE "condrewrite_rl" 4
| CT_constructor(x1, x2) ->
- fINT x1;
- fSPEC_LIST x2;
+ fINT x1 ++
+ fSPEC_LIST x2 ++
fNODE "constructor" 2
| CT_contradiction -> fNODE "contradiction" 0
| CT_contradiction_thm(x1, x2) ->
- fFORMULA x1;
- fSPEC_LIST x2;
+ fFORMULA x1 ++
+ fSPEC_LIST x2 ++
fNODE "contradiction_thm" 2
| CT_cut(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "cut" 1
| CT_cutrewrite_lr(x1, x2) ->
- fFORMULA x1;
- fID_OPT x2;
+ fFORMULA x1 ++
+ fID_OPT x2 ++
fNODE "cutrewrite_lr" 2
| CT_cutrewrite_rl(x1, x2) ->
- fFORMULA x1;
- fID_OPT x2;
+ fFORMULA x1 ++
+ fID_OPT x2 ++
fNODE "cutrewrite_rl" 2
| CT_dauto(x1, x2) ->
- fINT_OPT x1;
- fINT_OPT x2;
+ fINT_OPT x1 ++
+ fINT_OPT x2 ++
fNODE "dauto" 2
| CT_dconcl -> fNODE "dconcl" 0
| CT_decompose_list(x1, x2) ->
- fID_NE_LIST x1;
- fFORMULA x2;
+ fID_NE_LIST x1 ++
+ fFORMULA x2 ++
fNODE "decompose_list" 2
| CT_decompose_record(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "decompose_record" 1
| CT_decompose_sum(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "decompose_sum" 1
| CT_depinversion(x1, x2, x3, x4) ->
- fINV_TYPE x1;
- fID_OR_INT x2;
- fINTRO_PATT_OPT x3;
- fFORMULA_OPT x4;
+ fINV_TYPE x1 ++
+ fID_OR_INT x2 ++
+ fINTRO_PATT_OPT x3 ++
+ fFORMULA_OPT x4 ++
fNODE "depinversion" 4
| CT_deprewrite_lr(x1) ->
- fID x1;
+ fID x1 ++
fNODE "deprewrite_lr" 1
| CT_deprewrite_rl(x1) ->
- fID x1;
+ fID x1 ++
fNODE "deprewrite_rl" 1
| CT_destruct(x1) ->
- fID_OR_INT x1;
+ fID_OR_INT x1 ++
fNODE "destruct" 1
| CT_dhyp(x1) ->
- fID x1;
+ fID x1 ++
fNODE "dhyp" 1
| CT_discriminate_eq(x1) ->
- fID_OR_INT_OPT x1;
+ fID_OR_INT_OPT x1 ++
fNODE "discriminate_eq" 1
| CT_do(x1, x2) ->
- fID_OR_INT x1;
- fTACTIC_COM x2;
+ fID_OR_INT x1 ++
+ fTACTIC_COM x2 ++
fNODE "do" 2
| CT_eapply(x1, x2) ->
- fFORMULA x1;
- fSPEC_LIST x2;
+ fFORMULA x1 ++
+ fSPEC_LIST x2 ++
fNODE "eapply" 2
| CT_eauto(x1, x2) ->
- fID_OR_INT_OPT x1;
- fID_OR_INT_OPT x2;
+ fID_OR_INT_OPT x1 ++
+ fID_OR_INT_OPT x2 ++
fNODE "eauto" 2
| CT_eauto_with(x1, x2, x3) ->
- fID_OR_INT_OPT x1;
- fID_OR_INT_OPT x2;
- fID_NE_LIST_OR_STAR x3;
+ fID_OR_INT_OPT x1 ++
+ fID_OR_INT_OPT x2 ++
+ fID_NE_LIST_OR_STAR x3 ++
fNODE "eauto_with" 3
| CT_elim(x1, x2, x3) ->
- fFORMULA x1;
- fSPEC_LIST x2;
- fUSING x3;
+ fFORMULA x1 ++
+ fSPEC_LIST x2 ++
+ fUSING x3 ++
fNODE "elim" 3
| CT_elim_type(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "elim_type" 1
| CT_exact(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "exact" 1
| CT_exact_no_check(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "exact_no_check" 1
| CT_vm_cast_no_check(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "vm_cast_no_check" 1
| CT_exists(x1) ->
- fSPEC_LIST x1;
+ fSPEC_LIST x1 ++
fNODE "exists" 1
| CT_fail(x1, x2) ->
- fID_OR_INT x1;
- fSTRING_OPT x2;
+ fID_OR_INT x1 ++
+ fSTRING_OPT x2 ++
fNODE "fail" 2
| CT_first(x,l) ->
- fTACTIC_COM x;
- (List.iter fTACTIC_COM l);
+ fTACTIC_COM x ++
+ (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
fNODE "first" (1 + (List.length l))
| CT_firstorder(x1) ->
- fTACTIC_OPT x1;
+ fTACTIC_OPT x1 ++
fNODE "firstorder" 1
| CT_firstorder_using(x1, x2) ->
- fTACTIC_OPT x1;
- fID_NE_LIST x2;
+ fTACTIC_OPT x1 ++
+ fID_NE_LIST x2 ++
fNODE "firstorder_using" 2
| CT_firstorder_with(x1, x2) ->
- fTACTIC_OPT x1;
- fID_NE_LIST x2;
+ fTACTIC_OPT x1 ++
+ fID_NE_LIST x2 ++
fNODE "firstorder_with" 2
| CT_fixtactic(x1, x2, x3) ->
- fID_OPT x1;
- fINT x2;
- fFIX_TAC_LIST x3;
+ fID_OPT x1 ++
+ fINT x2 ++
+ fFIX_TAC_LIST x3 ++
fNODE "fixtactic" 3
| CT_formula_marker(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "formula_marker" 1
| CT_fresh(x1) ->
- fSTRING_OPT x1;
+ fSTRING_OPT x1 ++
fNODE "fresh" 1
| CT_generalize(x1) ->
- fFORMULA_NE_LIST x1;
+ fFORMULA_NE_LIST x1 ++
fNODE "generalize" 1
| CT_generalize_dependent(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "generalize_dependent" 1
| CT_idtac(x1) ->
- fSTRING_OPT x1;
+ fSTRING_OPT x1 ++
fNODE "idtac" 1
| CT_induction(x1) ->
- fID_OR_INT x1;
+ fID_OR_INT x1 ++
fNODE "induction" 1
| CT_info(x1) ->
- fTACTIC_COM x1;
+ fTACTIC_COM x1 ++
fNODE "info" 1
| CT_injection_eq(x1) ->
- fID_OR_INT_OPT x1;
+ fID_OR_INT_OPT x1 ++
fNODE "injection_eq" 1
| CT_instantiate(x1, x2, x3) ->
- fINT x1;
- fFORMULA x2;
- fCLAUSE x3;
+ fINT x1 ++
+ fFORMULA x2 ++
+ fCLAUSE x3 ++
fNODE "instantiate" 3
| CT_intro(x1) ->
- fID_OPT x1;
+ fID_OPT x1 ++
fNODE "intro" 1
| CT_intro_after(x1, x2) ->
- fID_OPT x1;
- fID x2;
+ fID_OPT x1 ++
+ fID x2 ++
fNODE "intro_after" 2
| CT_intros(x1) ->
- fINTRO_PATT_LIST x1;
+ fINTRO_PATT_LIST x1 ++
fNODE "intros" 1
| CT_intros_until(x1) ->
- fID_OR_INT x1;
+ fID_OR_INT x1 ++
fNODE "intros_until" 1
| CT_inversion(x1, x2, x3, x4) ->
- fINV_TYPE x1;
- fID_OR_INT x2;
- fINTRO_PATT_OPT x3;
- fID_LIST x4;
+ fINV_TYPE x1 ++
+ fID_OR_INT x2 ++
+ fINTRO_PATT_OPT x3 ++
+ fID_LIST x4 ++
fNODE "inversion" 4
| CT_left(x1) ->
- fSPEC_LIST x1;
+ fSPEC_LIST x1 ++
fNODE "left" 1
| CT_let_ltac(x1, x2) ->
- fLET_CLAUSES x1;
- fLET_VALUE x2;
+ fLET_CLAUSES x1 ++
+ fLET_VALUE x2 ++
fNODE "let_ltac" 2
| CT_lettac(x1, x2, x3) ->
- fID_OPT x1;
- fFORMULA x2;
- fCLAUSE x3;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
+ fCLAUSE x3 ++
fNODE "lettac" 3
| CT_match_context(x,l) ->
- fCONTEXT_RULE x;
- (List.iter fCONTEXT_RULE l);
+ fCONTEXT_RULE x ++
+ (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++
fNODE "match_context" (1 + (List.length l))
| CT_match_context_reverse(x,l) ->
- fCONTEXT_RULE x;
- (List.iter fCONTEXT_RULE l);
+ fCONTEXT_RULE x ++
+ (List.fold_left (++) (mt()) (List.map fCONTEXT_RULE l)) ++
fNODE "match_context_reverse" (1 + (List.length l))
| CT_match_tac(x1, x2) ->
- fTACTIC_COM x1;
- fMATCH_TAC_RULES x2;
+ fTACTIC_COM x1 ++
+ fMATCH_TAC_RULES x2 ++
fNODE "match_tac" 2
| CT_move_after(x1, x2) ->
- fID x1;
- fID x2;
+ fID x1 ++
+ fID x2 ++
fNODE "move_after" 2
| CT_new_destruct(x1, x2, x3) ->
- (List.iter fFORMULA_OR_INT x1); (* Julien F. Est-ce correct? *)
- fUSING x2;
- fINTRO_PATT_OPT x3;
+ (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Julien F. Est-ce correct? *)
+ fUSING x2 ++
+ fINTRO_PATT_OPT x3 ++
fNODE "new_destruct" 3
| CT_new_induction(x1, x2, x3) ->
- (List.iter fFORMULA_OR_INT x1); (* Pierre C. Est-ce correct? *)
- fUSING x2;
- fINTRO_PATT_OPT x3;
+ (List.fold_left (++) (mt()) (List.map fFORMULA_OR_INT x1)) ++ (* Pierre C. Est-ce correct? *)
+ fUSING x2 ++
+ fINTRO_PATT_OPT x3 ++
fNODE "new_induction" 3
| CT_omega -> fNODE "omega" 0
| CT_orelse(x1, x2) ->
- fTACTIC_COM x1;
- fTACTIC_COM x2;
+ fTACTIC_COM x1 ++
+ fTACTIC_COM x2 ++
fNODE "orelse" 2
| CT_parallel(x,l) ->
- fTACTIC_COM x;
- (List.iter fTACTIC_COM l);
+ fTACTIC_COM x ++
+ (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
fNODE "parallel" (1 + (List.length l))
| CT_pose(x1, x2) ->
- fID_OPT x1;
- fFORMULA x2;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
fNODE "pose" 2
| CT_progress(x1) ->
- fTACTIC_COM x1;
+ fTACTIC_COM x1 ++
fNODE "progress" 1
| CT_prolog(x1, x2) ->
- fFORMULA_LIST x1;
- fINT x2;
+ fFORMULA_LIST x1 ++
+ fINT x2 ++
fNODE "prolog" 2
| CT_rec_tactic_in(x1, x2) ->
- fREC_TACTIC_FUN_LIST x1;
- fTACTIC_COM x2;
+ fREC_TACTIC_FUN_LIST x1 ++
+ fTACTIC_COM x2 ++
fNODE "rec_tactic_in" 2
| CT_reduce(x1, x2) ->
- fRED_COM x1;
- fCLAUSE x2;
+ fRED_COM x1 ++
+ fCLAUSE x2 ++
fNODE "reduce" 2
| CT_refine(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "refine" 1
| CT_reflexivity -> fNODE "reflexivity" 0
| CT_rename(x1, x2) ->
- fID x1;
- fID x2;
+ fID x1 ++
+ fID x2 ++
fNODE "rename" 2
| CT_repeat(x1) ->
- fTACTIC_COM x1;
+ fTACTIC_COM x1 ++
fNODE "repeat" 1
| CT_replace_with(x1, x2,x3,x4) ->
- fFORMULA x1;
- fFORMULA x2;
- fCLAUSE x3;
- fTACTIC_OPT x4;
+ fFORMULA x1 ++
+ fFORMULA x2 ++
+ fCLAUSE x3 ++
+ fTACTIC_OPT x4 ++
fNODE "replace_with" 4
| CT_rewrite_lr(x1, x2, x3) ->
- fFORMULA x1;
- fSPEC_LIST x2;
- fCLAUSE x3;
+ fFORMULA x1 ++
+ fSPEC_LIST x2 ++
+ fCLAUSE x3 ++
fNODE "rewrite_lr" 3
| CT_rewrite_rl(x1, x2, x3) ->
- fFORMULA x1;
- fSPEC_LIST x2;
- fCLAUSE x3;
+ fFORMULA x1 ++
+ fSPEC_LIST x2 ++
+ fCLAUSE x3 ++
fNODE "rewrite_rl" 3
| CT_right(x1) ->
- fSPEC_LIST x1;
+ fSPEC_LIST x1 ++
fNODE "right" 1
| CT_ring(x1) ->
- fFORMULA_LIST x1;
+ fFORMULA_LIST x1 ++
fNODE "ring" 1
| CT_simple_user_tac(x1, x2) ->
- fID x1;
- fTACTIC_ARG_LIST x2;
+ fID x1 ++
+ fTACTIC_ARG_LIST x2 ++
fNODE "simple_user_tac" 2
| CT_simplify_eq(x1) ->
- fID_OR_INT_OPT x1;
+ fID_OR_INT_OPT x1 ++
fNODE "simplify_eq" 1
| CT_specialize(x1, x2, x3) ->
- fINT_OPT x1;
- fFORMULA x2;
- fSPEC_LIST x3;
+ fINT_OPT x1 ++
+ fFORMULA x2 ++
+ fSPEC_LIST x3 ++
fNODE "specialize" 3
| CT_split(x1) ->
- fSPEC_LIST x1;
+ fSPEC_LIST x1 ++
fNODE "split" 1
| CT_subst(x1) ->
- fID_LIST x1;
+ fID_LIST x1 ++
fNODE "subst" 1
| CT_superauto(x1, x2, x3, x4) ->
- fINT_OPT x1;
- fID_LIST x2;
- fDESTRUCTING x3;
- fUSINGTDB x4;
+ fINT_OPT x1 ++
+ fID_LIST x2 ++
+ fDESTRUCTING x3 ++
+ fUSINGTDB x4 ++
fNODE "superauto" 4
| CT_symmetry(x1) ->
- fCLAUSE x1;
+ fCLAUSE x1 ++
fNODE "symmetry" 1
| CT_tac_double(x1, x2) ->
- fID_OR_INT x1;
- fID_OR_INT x2;
+ fID_OR_INT x1 ++
+ fID_OR_INT x2 ++
fNODE "tac_double" 2
| CT_tacsolve(x,l) ->
- fTACTIC_COM x;
- (List.iter fTACTIC_COM l);
+ fTACTIC_COM x ++
+ (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
fNODE "tacsolve" (1 + (List.length l))
| CT_tactic_fun(x1, x2) ->
- fID_OPT_NE_LIST x1;
- fTACTIC_COM x2;
+ fID_OPT_NE_LIST x1 ++
+ fTACTIC_COM x2 ++
fNODE "tactic_fun" 2
| CT_then(x,l) ->
- fTACTIC_COM x;
- (List.iter fTACTIC_COM l);
+ fTACTIC_COM x ++
+ (List.fold_left (++) (mt()) (List.map fTACTIC_COM l)) ++
fNODE "then" (1 + (List.length l))
| CT_transitivity(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "transitivity" 1
| CT_trivial -> fNODE "trivial" 0
| CT_trivial_with(x1) ->
- fID_NE_LIST_OR_STAR x1;
+ fID_NE_LIST_OR_STAR x1 ++
fNODE "trivial_with" 1
| CT_truecut(x1, x2) ->
- fID_OPT x1;
- fFORMULA x2;
+ fID_OPT x1 ++
+ fFORMULA x2 ++
fNODE "truecut" 2
| CT_try(x1) ->
- fTACTIC_COM x1;
+ fTACTIC_COM x1 ++
fNODE "try" 1
| CT_use(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "use" 1
| CT_use_inversion(x1, x2, x3) ->
- fID_OR_INT x1;
- fFORMULA x2;
- fID_LIST x3;
+ fID_OR_INT x1 ++
+ fFORMULA x2 ++
+ fID_LIST x3 ++
fNODE "use_inversion" 3
| CT_user_tac(x1, x2) ->
- fID x1;
- fTARG_LIST x2;
+ fID x1 ++
+ fTARG_LIST x2 ++
fNODE "user_tac" 2
and fTACTIC_OPT = function
| CT_coerce_NONE_to_TACTIC_OPT x -> fNONE x
| CT_coerce_TACTIC_COM_to_TACTIC_OPT x -> fTACTIC_COM x
and fTAC_DEF = function
| CT_tac_def(x1, x2) ->
- fID x1;
- fTACTIC_COM x2;
+ fID x1 ++
+ fTACTIC_COM x2 ++
fNODE "tac_def" 2
and fTAC_DEF_NE_LIST = function
| CT_tac_def_ne_list(x,l) ->
- fTAC_DEF x;
- (List.iter fTAC_DEF l);
+ fTAC_DEF x ++
+ (List.fold_left (++) (mt()) (List.map fTAC_DEF l)) ++
fNODE "tac_def_ne_list" (1 + (List.length l))
and fTARG = function
| CT_coerce_BINDING_to_TARG x -> fBINDING x
@@ -1824,81 +1843,83 @@ and fTARG = function
| CT_coerce_UNFOLD_NE_LIST_to_TARG x -> fUNFOLD_NE_LIST x
and fTARG_LIST = function
| CT_targ_list l ->
- (List.iter fTARG l);
+ (List.fold_left (++) (mt()) (List.map fTARG l)) ++
fNODE "targ_list" (List.length l)
and fTERM_CHANGE = function
| CT_check_term(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "check_term" 1
| CT_inst_term(x1, x2) ->
- fID x1;
- fFORMULA x2;
+ fID x1 ++
+ fFORMULA x2 ++
fNODE "inst_term" 2
and fTEXT = function
| CT_coerce_ID_to_TEXT x -> fID x
| CT_text_formula(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "text_formula" 1
| CT_text_h l ->
- (List.iter fTEXT l);
+ (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
fNODE "text_h" (List.length l)
| CT_text_hv l ->
- (List.iter fTEXT l);
+ (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
fNODE "text_hv" (List.length l)
| CT_text_op l ->
- (List.iter fTEXT l);
+ (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
fNODE "text_op" (List.length l)
| CT_text_path(x1) ->
- fSIGNED_INT_LIST x1;
+ fSIGNED_INT_LIST x1 ++
fNODE "text_path" 1
| CT_text_v l ->
- (List.iter fTEXT l);
+ (List.fold_left (++) (mt()) (List.map fTEXT l)) ++
fNODE "text_v" (List.length l)
and fTHEOREM_GOAL = function
| CT_goal(x1) ->
- fFORMULA x1;
+ fFORMULA x1 ++
fNODE "goal" 1
| CT_theorem_goal(x1, x2, x3, x4) ->
- fDEFN_OR_THM x1;
- fID x2;
- fBINDER_LIST x3;
- fFORMULA x4;
+ fDEFN_OR_THM x1 ++
+ fID x2 ++
+ fBINDER_LIST x3 ++
+ fFORMULA x4 ++
fNODE "theorem_goal" 4
and fTHM = function
-| CT_thm x -> fATOM "thm";
- (f_atom_string x);
- print_string "\n"and fTHM_OPT = function
+| CT_thm x -> fATOM "thm" ++
+ (f_atom_string x) ++
+ str "\n"
+and fTHM_OPT = function
| CT_coerce_NONE_to_THM_OPT x -> fNONE x
| CT_coerce_THM_to_THM_OPT x -> fTHM x
and fTYPED_FORMULA = function
| CT_typed_formula(x1, x2) ->
- fFORMULA x1;
- fFORMULA x2;
+ fFORMULA x1 ++
+ fFORMULA x2 ++
fNODE "typed_formula" 2
and fUNFOLD = function
| CT_coerce_ID_to_UNFOLD x -> fID x
| CT_unfold_occ(x1, x2) ->
- fID x1;
- fINT_NE_LIST x2;
+ fID x1 ++
+ fINT_NE_LIST x2 ++
fNODE "unfold_occ" 2
and fUNFOLD_NE_LIST = function
| CT_unfold_ne_list(x,l) ->
- fUNFOLD x;
- (List.iter fUNFOLD l);
+ fUNFOLD x ++
+ (List.fold_left (++) (mt()) (List.map fUNFOLD l)) ++
fNODE "unfold_ne_list" (1 + (List.length l))
and fUSING = function
| CT_coerce_NONE_to_USING x -> fNONE x
| CT_using(x1, x2) ->
- fFORMULA x1;
- fSPEC_LIST x2;
+ fFORMULA x1 ++
+ fSPEC_LIST x2 ++
fNODE "using" 2
and fUSINGTDB = function
| CT_coerce_NONE_to_USINGTDB x -> fNONE x
| CT_usingtdb -> fNODE "usingtdb" 0
and fVAR = function
-| CT_var x -> fATOM "var";
- (f_atom_string x);
- print_string "\n"and fVARG = function
+| CT_var x -> fATOM "var" ++
+ (f_atom_string x) ++
+ str "\n"
+and fVARG = function
| CT_coerce_AST_to_VARG x -> fAST x
| CT_coerce_AST_LIST_to_VARG x -> fAST_LIST x
| CT_coerce_BINDER_to_VARG x -> fBINDER x
@@ -1916,7 +1937,7 @@ and fVAR = function
| CT_coerce_VARG_LIST_to_VARG x -> fVARG_LIST x
and fVARG_LIST = function
| CT_varg_list l ->
- (List.iter fVARG l);
+ (List.fold_left (++) (mt()) (List.map fVARG l)) ++
fNODE "varg_list" (List.length l)
and fVERBOSE_OPT = function
| CT_coerce_NONE_to_VERBOSE_OPT x -> fNONE x
diff --git a/contrib/interface/vtp.mli b/contrib/interface/vtp.mli
index fe30b317..d7bd8db5 100644
--- a/contrib/interface/vtp.mli
+++ b/contrib/interface/vtp.mli
@@ -1,15 +1,16 @@
open Ascent;;
+open Pp;;
-val fCOMMAND_LIST : ct_COMMAND_LIST -> unit;;
-val fCOMMAND : ct_COMMAND -> unit;;
-val fTACTIC_COM : ct_TACTIC_COM -> unit;;
-val fFORMULA : ct_FORMULA -> unit;;
-val fID : ct_ID -> unit;;
-val fSTRING : ct_STRING -> unit;;
-val fINT : ct_INT -> unit;;
-val fRULE_LIST : ct_RULE_LIST -> unit;;
-val fRULE : ct_RULE -> unit;;
-val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> unit;;
-val fPREMISES_LIST : ct_PREMISES_LIST -> unit;;
-val fID_LIST : ct_ID_LIST -> unit;;
-val fTEXT : ct_TEXT -> unit;; \ No newline at end of file
+val fCOMMAND_LIST : ct_COMMAND_LIST -> std_ppcmds;;
+val fCOMMAND : ct_COMMAND -> std_ppcmds;;
+val fTACTIC_COM : ct_TACTIC_COM -> std_ppcmds;;
+val fFORMULA : ct_FORMULA -> std_ppcmds;;
+val fID : ct_ID -> std_ppcmds;;
+val fSTRING : ct_STRING -> std_ppcmds;;
+val fINT : ct_INT -> std_ppcmds;;
+val fRULE_LIST : ct_RULE_LIST -> std_ppcmds;;
+val fRULE : ct_RULE -> std_ppcmds;;
+val fSIGNED_INT_LIST : ct_SIGNED_INT_LIST -> std_ppcmds;;
+val fPREMISES_LIST : ct_PREMISES_LIST -> std_ppcmds;;
+val fID_LIST : ct_ID_LIST -> std_ppcmds;;
+val fTEXT : ct_TEXT -> std_ppcmds;;
diff --git a/contrib/interface/xlate.ml b/contrib/interface/xlate.ml
index df03a579..7d1f57fe 100644
--- a/contrib/interface/xlate.ml
+++ b/contrib/interface/xlate.ml
@@ -15,12 +15,6 @@ open Libnames;;
open Goptions;;
-let in_coq_ref = ref false;;
-
-let declare_in_coq () = in_coq_ref:=true;;
-
-let in_coq () = !in_coq_ref;;
-
(* // Verify whether this is dead code, as of coq version 7 *)
(* The following three sentences have been added to cope with a change
of strategy from the Coq team in the way rules construct ast's. The
@@ -203,6 +197,10 @@ let xlate_int_or_var_opt_to_int_opt = function
| Some (ArgVar _) -> xlate_error "int_or_var: TODO"
| None -> CT_coerce_NONE_to_INT_OPT CT_none
+let apply_or_by_notation f = function
+ | AN x -> f x
+ | ByNotation _ -> xlate_error "TODO: ByNotation"
+
let tac_qualid_to_ct_ID ref =
CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref)))
@@ -307,14 +305,10 @@ let make_fix_struct (n,bl) =
let names = names_of_local_assums bl in
let nn = List.length names in
if nn = 1 || n = None then ctv_ID_OPT_NONE
- else
- let n = out_some n in
- if n < nn then xlate_id_opt(List.nth names n)
- else xlate_error "unexpected result of parsing for Fixpoint";;
-
+ else ctf_ID_OPT_SOME(CT_ident (string_of_id (snd (Option.get n))));;
let rec xlate_binder = function
- (l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
+ (l,k,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
and xlate_return_info = function
| (Some Anonymous, None) | (None, None) ->
CT_coerce_NONE_to_RETURN_INFO CT_none
@@ -327,7 +321,7 @@ and xlate_formula_opt =
| Some e -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula e)
and xlate_binder_l = function
- LocalRawAssum(l,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
+ LocalRawAssum(l,_,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t)
| LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n,
xlate_formula v))
and
@@ -336,7 +330,7 @@ and
| a::l -> CT_match_pattern_ne_list(xlate_match_pattern a,
List.map xlate_match_pattern l)
and translate_one_equation = function
- (_,[lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a)
+ (_,[_,lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a)
| _ -> xlate_error "TODO: disjunctive multiple patterns"
and
xlate_binder_ne_list = function
@@ -379,8 +373,8 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
(xlate_formula f, List.map xlate_formula_expl l'))
| CApp(_, (_,f), l) ->
CT_appc(xlate_formula f, xlate_formula_expl_ne_list l)
- | CCases (_, _, [], _) -> assert false
- | CCases (_, ret_type, tm::tml, eqns)->
+ | CCases (_, _, _, [], _) -> assert false
+ | CCases (_, _, ret_type, tm::tml, eqns)->
CT_cases(CT_matched_formula_ne_list(xlate_matched_formula tm,
List.map xlate_matched_formula tml),
xlate_formula_opt ret_type,
@@ -418,23 +412,16 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function
CT_coerce_ID_to_FORMULA(CT_metaid (string_of_id s))
| CPatVar (_, (true, s)) ->
xlate_error "Second order variable not supported"
- | CEvar (_, _) -> xlate_error "CEvar not supported"
+ | CEvar _ -> xlate_error "CEvar not supported"
| CCoFix (_, (_, id), lm::lmi) ->
- let strip_mutcorec (fid, bl,arf, ardef) =
+ let strip_mutcorec ((_, fid), bl,arf, ardef) =
CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
xlate_formula arf, xlate_formula ardef) in
CT_cofixc(xlate_ident id,
(CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi)))
| CFix (_, (_, id), lm::lmi) ->
- let strip_mutrec (fid, (n, ro), bl, arf, ardef) =
- let (struct_arg,bl,arf,ardef) =
- (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *)
- (* By the way, how could [bl = []] happen in V8 syntax ? *)
- if bl = [] then
- let n = out_some n in
- let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in
- (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef)
- else (make_fix_struct (n, bl),bl,arf,ardef) in
+ let strip_mutrec ((_, fid), (n, ro), bl, arf, ardef) =
+ let struct_arg = make_fix_struct (n, bl) in
let arf = xlate_formula arf in
let ardef = xlate_formula ardef in
match xlate_binder_list bl with
@@ -461,7 +448,7 @@ and xlate_matched_formula = function
CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f)
and xlate_formula_expl = function
(a, None) -> xlate_formula a
- | (a, Some (_,ExplByPos i)) ->
+ | (a, Some (_,ExplByPos (i, _))) ->
xlate_error "explicitation of implicit by rank not supported"
| (a, Some (_,ExplByName i)) ->
CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a)
@@ -477,24 +464,31 @@ let (xlate_ident_or_metaid:
AI (_, x) -> xlate_ident x
| MetaId(_, x) -> CT_metaid x;;
+let nums_of_occs (b,nums) =
+ if b then nums
+ else List.map (function ArgArg x -> ArgArg (-x) | y -> y) nums
+
let xlate_hyp = function
| AI (_,id) -> xlate_ident id
| MetaId _ -> xlate_error "MetaId should occur only in quotations"
let xlate_hyp_location =
function
- | (nums, AI (_,id)), InHypTypeOnly ->
- CT_intype(xlate_ident id, nums_or_var_to_int_list nums)
- | (nums, AI (_,id)), InHypValueOnly ->
- CT_invalue(xlate_ident id, nums_or_var_to_int_list nums)
- | ([], AI (_,id)), InHyp ->
+ | (occs, AI (_,id)), InHypTypeOnly ->
+ CT_intype(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs))
+ | (occs, AI (_,id)), InHypValueOnly ->
+ CT_invalue(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs))
+ | (occs, AI (_,id)), InHyp when occs = all_occurrences_expr ->
CT_coerce_UNFOLD_to_HYP_LOCATION
(CT_coerce_ID_to_UNFOLD (xlate_ident id))
- | (a::l, AI (_,id)), InHyp ->
+ | ((_,a::l as occs), AI (_,id)), InHyp ->
+ let nums = nums_of_occs occs in
+ let a = List.hd nums and l = List.tl nums in
CT_coerce_UNFOLD_to_HYP_LOCATION
(CT_unfold_occ (xlate_ident id,
CT_int_ne_list(num_or_var_to_int a,
nums_or_var_to_int_list_aux l)))
+ | (_, AI (_,id)), InHyp -> xlate_error "Unused" (* (true,]) *)
| (_, MetaId _),_ ->
xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)"
@@ -507,7 +501,7 @@ let xlate_clause cls =
| Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in
CT_clause
(hyps_info,
- if cls.onconcl then
+ if cls.concl_occs <> no_occurrences_expr then
CT_coerce_STAR_to_STAR_OPT CT_star
else
CT_coerce_NONE_to_STAR_OPT CT_none)
@@ -606,14 +600,15 @@ let strip_targ_intropatt =
| _ -> xlate_error "strip_targ_intropatt";;
let get_flag r =
- let conv_flags, red_ids =
+ let conv_flags, red_ids =
+ let csts = List.map (apply_or_by_notation tac_qualid_to_ct_ID) r.rConst in
if r.rDelta then
- [CT_delta], CT_unfbut (List.map tac_qualid_to_ct_ID r.rConst)
+ [CT_delta], CT_unfbut csts
else
(if r.rConst = []
then (* probably useless: just for compatibility *) []
else [CT_delta]),
- CT_unf (List.map tac_qualid_to_ct_ID r.rConst) in
+ CT_unf csts in
let conv_flags = if r.rBeta then CT_beta::conv_flags else conv_flags in
let conv_flags = if r.rIota then CT_iota::conv_flags else conv_flags in
let conv_flags = if r.rZeta then CT_zeta::conv_flags else conv_flags in
@@ -633,6 +628,8 @@ let rec xlate_intro_pattern =
| IntroWildcard -> CT_coerce_ID_to_INTRO_PATT(CT_ident "_" )
| IntroIdentifier c -> CT_coerce_ID_to_INTRO_PATT(xlate_ident c)
| IntroAnonymous -> xlate_error "TODO: IntroAnonymous"
+ | IntroFresh _ -> xlate_error "TODO: IntroFresh"
+ | IntroRewrite _ -> xlate_error "TODO: IntroRewrite"
let compute_INV_TYPE = function
FullInversionClear -> CT_inv_clear
@@ -663,7 +660,8 @@ let xlate_largs_to_id_opt largs =
| _ -> assert false;;
let xlate_int_or_constr = function
- ElimOnConstr a -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a)
+ ElimOnConstr (a,NoBindings) -> CT_coerce_FORMULA_to_FORMULA_OR_INT(xlate_formula a)
+ | ElimOnConstr _ -> xlate_error "TODO: ElimOnConstr with bindings"
| ElimOnIdent(_,i) ->
CT_coerce_ID_OR_INT_to_FORMULA_OR_INT
(CT_coerce_ID_to_ID_OR_INT(xlate_ident i))
@@ -676,9 +674,13 @@ let xlate_using = function
| Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);;
let xlate_one_unfold_block = function
- ([],qid) -> CT_coerce_ID_to_UNFOLD(tac_qualid_to_ct_ID qid)
- | (n::nums, qid) ->
- CT_unfold_occ(tac_qualid_to_ct_ID qid, nums_or_var_to_int_ne_list n nums)
+ ((true,[]),qid) ->
+ CT_coerce_ID_to_UNFOLD(apply_or_by_notation tac_qualid_to_ct_ID qid)
+ | (((_,_::_) as occs), qid) ->
+ let l = nums_of_occs occs in
+ CT_unfold_occ(apply_or_by_notation tac_qualid_to_ct_ID qid,
+ nums_or_var_to_int_ne_list (List.hd l) (List.tl l))
+ | ((false,[]), qid) -> xlate_error "Unused"
;;
let xlate_with_names = function
@@ -739,7 +741,8 @@ and xlate_red_tactic =
| CbvVm -> CT_cbvvm
| Hnf -> CT_hnf
| Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE
- | Simpl (Some (l,c)) ->
+ | Simpl (Some (occs,c)) ->
+ let l = nums_of_occs occs in
CT_simpl
(CT_coerce_PATTERN_to_PATTERN_OPT
(CT_pattern_occ
@@ -758,9 +761,9 @@ and xlate_red_tactic =
| Fold formula_list ->
CT_fold(CT_formula_list(List.map xlate_formula formula_list))
| Pattern l ->
- let pat_list = List.map (fun (nums,c) ->
+ let pat_list = List.map (fun (occs,c) ->
CT_pattern_occ
- (CT_int_list (nums_or_var_to_int_list_aux nums),
+ (CT_int_list (nums_or_var_to_int_list_aux (nums_of_occs occs)),
xlate_formula c)) l in
(match pat_list with
| first :: others -> CT_pattern (CT_pattern_ne_list (first, others))
@@ -770,21 +773,23 @@ and xlate_red_tactic =
and xlate_local_rec_tac = function
(* TODO LATER: local recursive tactics and global ones should be handled in
the same manner *)
- | ((_,x),(argl,tac)) ->
+ | ((_,x),Tacexp (TacFun (argl,tac))) ->
let fst, rest = xlate_largs_to_id_opt argl in
CT_rec_tactic_fun(xlate_ident x,
CT_id_opt_ne_list(fst, rest),
xlate_tactic tac)
+ | _ -> xlate_error "TODO: more general argument of 'let rec in'"
and xlate_tactic =
function
| TacFun (largs, t) ->
let fst, rest = xlate_largs_to_id_opt largs in
CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t)
- | TacThen (t1,t2) ->
+ | TacThen (t1,[||],t2,[||]) ->
(match xlate_tactic t1 with
CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2])
| t -> CT_then (t,[xlate_tactic t2]))
+ | TacThen _ -> xlate_error "TacThen generalization TODO"
| TacThens(t1,[]) -> assert false
| TacThens(t1,t::l) ->
let ct = xlate_tactic t in
@@ -831,36 +836,31 @@ and xlate_tactic =
| TacMatchContext (false,true,rule1::rules) ->
CT_match_context_reverse(xlate_context_rule rule1,
List.map xlate_context_rule rules)
- | TacLetIn (l, t) ->
+ | TacLetIn (false, l, t) ->
let cvt_clause =
function
- ((_,s),None,ConstrMayEval v) ->
+ ((_,s),ConstrMayEval v) ->
CT_let_clause(xlate_ident s,
CT_coerce_NONE_to_TACTIC_OPT CT_none,
CT_coerce_DEF_BODY_to_LET_VALUE
(formula_to_def_body v))
- | ((_,s),None,Tacexp t) ->
+ | ((_,s),Tacexp t) ->
CT_let_clause(xlate_ident s,
CT_coerce_NONE_to_TACTIC_OPT CT_none,
CT_coerce_TACTIC_COM_to_LET_VALUE
(xlate_tactic t))
- | ((_,s),None,t) ->
+ | ((_,s),t) ->
CT_let_clause(xlate_ident s,
CT_coerce_NONE_to_TACTIC_OPT CT_none,
CT_coerce_TACTIC_COM_to_LET_VALUE
- (xlate_call_or_tacarg t))
- | ((_,s),Some c,t) ->
- CT_let_clause(xlate_ident s,
- CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic c),
- CT_coerce_TACTIC_COM_to_LET_VALUE
- (xlate_call_or_tacarg t)) in
+ (xlate_call_or_tacarg t)) in
let cl_l = List.map cvt_clause l in
(match cl_l with
| [] -> assert false
| fst::others ->
CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t))
- | TacLetRecIn([], _) -> xlate_error "recursive definition with no definition"
- | TacLetRecIn(f1::l, t) ->
+ | TacLetIn(true, [], _) -> xlate_error "recursive definition with no definition"
+ | TacLetIn(true, f1::l, t) ->
let tl = CT_rec_tactic_fun_list
(xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in
CT_rec_tactic_in(tl, xlate_tactic t)
@@ -917,6 +917,7 @@ and xlate_tac =
| TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b)
| TacChange (Some(l,c), f, b) ->
(* TODO LATER: combine with other constructions of pattern_occ *)
+ let l = nums_of_occs l in
CT_change_local(
CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l),
xlate_formula c),
@@ -946,18 +947,22 @@ and xlate_tac =
xlate_error "TODO: injection as"
| TacFix (idopt, n) ->
CT_fixtactic (xlate_ident_opt idopt, CT_int n, CT_fix_tac_list [])
- | TacMutualFix (id, n, fixtac_list) ->
+ | TacMutualFix (false, id, n, fixtac_list) ->
let f (id,n,c) = CT_fixtac (xlate_ident id, CT_int n, xlate_formula c) in
CT_fixtactic
(ctf_ID_OPT_SOME (xlate_ident id), CT_int n,
CT_fix_tac_list (List.map f fixtac_list))
+ | TacMutualFix (true, id, n, fixtac_list) ->
+ xlate_error "TODO: non user-visible fix"
| TacCofix idopt ->
CT_cofixtactic (xlate_ident_opt idopt, CT_cofix_tac_list [])
- | TacMutualCofix (id, cofixtac_list) ->
+ | TacMutualCofix (false, id, cofixtac_list) ->
let f (id,c) = CT_cofixtac (xlate_ident id, xlate_formula c) in
CT_cofixtactic
(CT_coerce_ID_to_ID_OPT (xlate_ident id),
CT_cofix_tac_list (List.map f cofixtac_list))
+ | TacMutualCofix (true, id, cofixtac_list) ->
+ xlate_error "TODO: non user-visible cofix"
| TacIntrosUntil (NamedHyp id) ->
CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id))
| TacIntrosUntil (AnonHyp n) ->
@@ -975,10 +980,12 @@ and xlate_tac =
| TacIntroMove (Some id, None) ->
CT_intros (CT_intro_patt_list[CT_coerce_ID_to_INTRO_PATT(xlate_ident id)])
| TacIntroMove (None, None) -> CT_intro (CT_coerce_NONE_to_ID_OPT CT_none)
- | TacLeft bindl -> CT_left (xlate_bindings bindl)
- | TacRight bindl -> CT_right (xlate_bindings bindl)
- | TacSplit (false,bindl) -> CT_split (xlate_bindings bindl)
- | TacSplit (true,bindl) -> CT_exists (xlate_bindings bindl)
+ | TacLeft (false,bindl) -> CT_left (xlate_bindings bindl)
+ | TacRight (false,bindl) -> CT_right (xlate_bindings bindl)
+ | TacSplit (false,false,bindl) -> CT_split (xlate_bindings bindl)
+ | TacSplit (false,true,bindl) -> CT_exists (xlate_bindings bindl)
+ | TacSplit _ | TacRight _ | TacLeft _ ->
+ xlate_error "TODO: esplit, eright, etc"
| TacExtend (_,"replace", [c1; c2;cl;tac_opt]) ->
let c1 = xlate_formula (out_gen rawwit_constr c1) in
let c2 = xlate_formula (out_gen rawwit_constr c2) in
@@ -991,7 +998,7 @@ and xlate_tac =
let cl_as_xlate_arg =
{cl_as_clause with
Tacexpr.onhyps =
- option_map
+ Option.map
(fun l ->
List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l
)
@@ -1009,12 +1016,15 @@ and xlate_tac =
CT_coerce_TACTIC_COM_to_TACTIC_OPT tac
in
CT_replace_with (c1, c2,cl,tac_opt)
- | TacRewrite(b,cbindl,cl) ->
+ | TacRewrite(false,[b,Precisely 1,cbindl],cl,None) ->
let cl = xlate_clause cl
and c = xlate_formula (fst cbindl)
and bindl = xlate_bindings (snd cbindl) in
if b then CT_rewrite_lr (c, bindl, cl)
else CT_rewrite_rl (c, bindl, cl)
+ | TacRewrite(_,_,_,Some _) -> xlate_error "TODO: rewrite by"
+ | TacRewrite(false,_,cl,_) -> xlate_error "TODO: rewrite of several hyps at once"
+ | TacRewrite(true,_,cl,_) -> xlate_error "TODO: erewrite"
| TacExtend (_,"conditional_rewrite", [t; b; cbindl]) ->
let t = out_gen rawwit_main_tactic t in
let b = out_gen Extraargs.rawwit_orient b in
@@ -1127,10 +1137,9 @@ and xlate_tac =
(match out_gen rawwit_int_or_var n with
| ArgVar _ -> xlate_error ""
| ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n))
- | TacExtend (_,"eapply", [cbindl]) ->
- let (c,bindl) = out_gen rawwit_constr_with_bindings cbindl in
- let c = xlate_formula c and bindl = xlate_bindings bindl in
- CT_eapply (c, bindl)
+ (* eapply now represented by TacApply (true,cbindl)
+ | TacExtend (_,"eapply", [cbindl]) ->
+*)
| TacTrivial ([],Some []) -> CT_trivial
| TacTrivial ([],None) ->
CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star)
@@ -1141,25 +1150,36 @@ and xlate_tac =
xlate_error "TODO: trivial using"
| TacReduce (red, l) ->
CT_reduce (xlate_red_tactic red, xlate_clause l)
- | TacApply (c,bindl) ->
+ | TacApply (true,false,(c,bindl)) ->
CT_apply (xlate_formula c, xlate_bindings bindl)
- | TacConstructor (n_or_meta, bindl) ->
+ | TacApply (true,true,(c,bindl)) ->
+ CT_eapply (xlate_formula c, xlate_bindings bindl)
+ | TacApply (false,_,_) -> xlate_error "TODO: simple (e)apply"
+ | TacConstructor (false,n_or_meta, bindl) ->
let n = match n_or_meta with AI n -> n | MetaId _ -> xlate_error ""
in CT_constructor (CT_int n, xlate_bindings bindl)
+ | TacConstructor _ -> xlate_error "TODO: econstructor"
| TacSpecialize (nopt, (c,sl)) ->
CT_specialize (xlate_int_opt nopt, xlate_formula c, xlate_bindings sl)
| TacGeneralize [] -> xlate_error ""
- | TacGeneralize (first :: cl) ->
+ | TacGeneralize ((((true,[]),first),Anonymous) :: cl)
+ when List.for_all (fun ((o,_),na) -> o = all_occurrences_expr
+ & na = Anonymous) cl ->
CT_generalize
- (CT_formula_ne_list (xlate_formula first, List.map xlate_formula cl))
+ (CT_formula_ne_list (xlate_formula first,
+ List.map (fun ((_,c),_) -> xlate_formula c) cl))
+ | TacGeneralize _ -> xlate_error "TODO: Generalize at and as"
| TacGeneralizeDep c ->
CT_generalize_dependent (xlate_formula c)
| TacElimType c -> CT_elim_type (xlate_formula c)
| TacCaseType c -> CT_case_type (xlate_formula c)
- | TacElim ((c1,sl), u) ->
+ | TacElim (false,(c1,sl), u) ->
CT_elim (xlate_formula c1, xlate_bindings sl, xlate_using u)
- | TacCase (c1,sl) ->
+ | TacCase (false,(c1,sl)) ->
CT_casetac (xlate_formula c1, xlate_bindings sl)
+ | TacElim (true,_,_) | TacCase (true,_)
+ | TacNewDestruct (true,_,_,_,_) | TacNewInduction (true,_,_,_,_) ->
+ xlate_error "TODO: eelim, ecase, edestruct, einduction"
| TacSimpleInduction h -> CT_induction (xlate_quantified_hypothesis h)
| TacSimpleDestruct h -> CT_destruct (xlate_quantified_hypothesis h)
| TacCut c -> CT_cut (xlate_formula c)
@@ -1167,8 +1187,8 @@ and xlate_tac =
| TacDecompose ([],c) ->
xlate_error "Decompose : empty list of identifiers?"
| TacDecompose (id::l,c) ->
- let id' = tac_qualid_to_ct_ID id in
- let l' = List.map tac_qualid_to_ct_ID l in
+ let id' = apply_or_by_notation tac_qualid_to_ct_ID id in
+ let l' = List.map (apply_or_by_notation tac_qualid_to_ct_ID) l in
CT_decompose_list(CT_id_ne_list(id',l'),xlate_formula c)
| TacDecomposeAnd c -> CT_decompose_record (xlate_formula c)
| TacDecomposeOr c -> CT_decompose_sum(xlate_formula c)
@@ -1178,6 +1198,7 @@ and xlate_tac =
let idl' = List.map xlate_hyp idl in
CT_clear (CT_id_ne_list (xlate_hyp id, idl'))
| TacClear (true,_) -> xlate_error "TODO: 'clear - idl' and 'clear'"
+ | TacRevert _ -> xlate_error "TODO: revert"
| (*For translating tactics/Inv.v *)
TacInversion (NonDepInversion (k,idl,l),quant_hyp) ->
CT_inversion(compute_INV_TYPE k, xlate_quantified_hypothesis quant_hyp,
@@ -1192,30 +1213,36 @@ and xlate_tac =
CT_use_inversion (id, xlate_formula c,
CT_id_list (List.map xlate_hyp idlist))
| TacExtend (_,"omega", []) -> CT_omega
- | TacRename (id1, id2) -> CT_rename(xlate_hyp id1, xlate_hyp id2)
+ | TacRename [id1, id2] -> CT_rename(xlate_hyp id1, xlate_hyp id2)
+ | TacRename _ -> xlate_error "TODO: add support for n-ary rename"
| TacClearBody([]) -> assert false
| TacClearBody(a::l) ->
CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l))
- | TacDAuto (a, b) ->
+ | TacDAuto (a, b, []) ->
CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b)
- | TacNewDestruct(a,b,c) ->
- CT_new_destruct (* Julien F. : est-ce correct *)
+ | TacDAuto (a, b, _) ->
+ xlate_error "TODO: dauto using"
+ | TacNewDestruct(false,a,b,c,None) ->
+ CT_new_destruct
(List.map xlate_int_or_constr a, xlate_using b,
xlate_with_names c)
- | TacNewInduction(a,b,c) ->
- CT_new_induction (* Pierre C. : est-ce correct *)
+ | TacNewInduction(false,a,b,c,None) ->
+ CT_new_induction
(List.map xlate_int_or_constr a, xlate_using b,
xlate_with_names c)
+ | TacNewDestruct(false,a,b,c,_) -> xlate_error "TODO: destruct in"
+ | TacNewInduction(false,a,b,c,_) ->xlate_error "TODO: induction in"
(*| TacInstantiate (a, b, cl) ->
CT_instantiate(CT_int a, xlate_formula b,
assert false) *)
- | TacLetTac (na, c, cl) when cl = nowhere ->
+ | TacLetTac (na, c, cl, true) when cl = nowhere ->
CT_pose(xlate_id_opt_aux na, xlate_formula c)
- | TacLetTac (na, c, cl) ->
+ | TacLetTac (na, c, cl, true) ->
CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c,
(* TODO LATER: This should be shared with Unfold,
but the structures are different *)
xlate_clause cl)
+ | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember"
| TacAssert (None, IntroIdentifier id, c) ->
CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c)
| TacAssert (None, IntroAnonymous, c) ->
@@ -1226,16 +1253,18 @@ and xlate_tac =
CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c)
| TacAssert _ ->
xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'"
- | TacAnyConstructor(Some tac) ->
+ | TacAnyConstructor(false,Some tac) ->
CT_any_constructor
(CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac))
- | TacAnyConstructor(None) ->
+ | TacAnyConstructor(false,None) ->
CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none)
+ | TacAnyConstructor _ -> xlate_error "TODO: econstructor"
| TacExtend(_, "ring", [args]) ->
CT_ring
(CT_formula_list
(List.map xlate_formula
(out_gen (wit_list0 rawwit_constr) args)))
+ | TacExtend (_, "f_equal", _) -> xlate_error "TODO: f_equal"
| TacExtend (_,id, l) ->
print_endline ("Extratactics : "^ id);
CT_user_tac (CT_ident id, CT_targ_list (List.map coerce_genarg_to_TARG l))
@@ -1299,7 +1328,7 @@ and coerce_genarg_to_TARG x =
(snd (out_gen
(rawwit_open_constr_gen b) x))))
| ExtraArgType s as y when Pcoq.is_tactic_genarg y ->
- let n = out_some (Pcoq.tactic_genarg_level s) in
+ let n = Option.get (Pcoq.tactic_genarg_level s) in
let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in
CT_coerce_TACTIC_COM_to_TARG t
| ConstrWithBindingsArgType -> xlate_error "TODO: generic constr with bindings"
@@ -1392,7 +1421,7 @@ let coerce_genarg_to_VARG x =
| ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument"
| QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument"
| ExtraArgType s as y when Pcoq.is_tactic_genarg y ->
- let n = out_some (Pcoq.tactic_genarg_level s) in
+ let n = Option.get (Pcoq.tactic_genarg_level s) in
let t = xlate_tactic (out_gen (Pcoq.rawwit_tactic n) x) in
CT_coerce_TACTIC_OPT_to_VARG (CT_coerce_TACTIC_COM_to_TACTIC_OPT t)
| OpenConstrArgType _ -> xlate_error "TODO: generic open constr"
@@ -1563,7 +1592,9 @@ let rec xlate_module_type = function
| CWith_Module((_, idl), (_, qid)) ->
CT_module_type_with_mod(mty1,
CT_id_list (List.map xlate_ident idl),
- CT_ident (xlate_qualid qid)));;
+ CT_ident (xlate_qualid qid)))
+ | CMTEapply (_,_) -> xlate_error "TODO: Funsig application";;
+
let xlate_module_binder_list (l:module_binder list) =
CT_module_binder_list
@@ -1596,8 +1627,8 @@ let rec xlate_vernac =
| VernacDeclareTacticDefinition (true, tacs) ->
(match List.map
(function
- ((_, id), body) ->
- CT_tac_def(CT_ident (string_of_id id), xlate_tactic body))
+ (id, _, body) ->
+ CT_tac_def(reference_to_ct_ID id, xlate_tactic body))
tacs with
[] -> assert false
| fst::tacs1 ->
@@ -1714,7 +1745,7 @@ let rec xlate_vernac =
CT_id_ne_list(n1, names), dblist)
| HintsExtern (n, c, t) ->
CT_hint_extern(CT_int n, xlate_formula c, xlate_tactic t, dblist)
- | HintsResolve l | HintsImmediate l ->
+ | HintsImmediate l ->
let f1, formulas = match List.map xlate_formula l with
a :: tl -> a, tl
| _ -> failwith "" in
@@ -1731,6 +1762,23 @@ let rec xlate_vernac =
HintsResolve _ -> CT_hints_resolve(l', dblist)
| HintsImmediate _ -> CT_hints_immediate(l', dblist)
| _ -> assert false)
+ | HintsResolve l ->
+ let f1, formulas = match List.map xlate_formula (List.map snd l) with
+ a :: tl -> a, tl
+ | _ -> failwith "" in
+ let l' = CT_formula_ne_list(f1, formulas) in
+ if local then
+ (match h with
+ HintsResolve _ ->
+ CT_local_hints_resolve(l', dblist)
+ | HintsImmediate _ ->
+ CT_local_hints_immediate(l', dblist)
+ | _ -> assert false)
+ else
+ (match h with
+ HintsResolve _ -> CT_hints_resolve(l', dblist)
+ | HintsImmediate _ -> CT_hints_immediate(l', dblist)
+ | _ -> assert false)
| HintsUnfold l ->
let n1, names = match List.map loc_qualid_to_ct_ID l with
n1 :: names -> n1, names
@@ -1766,13 +1814,11 @@ let rec xlate_vernac =
ctf_ID_OPT_SOME (xlate_ident s))
| VernacEndProof Admitted ->
CT_save (CT_coerce_THM_to_THM_OPT (CT_thm "Admitted"), ctv_ID_OPT_NONE)
- | VernacSetOpacity (false, id :: idl) ->
- CT_transparent(CT_id_ne_list(loc_qualid_to_ct_ID id,
- List.map loc_qualid_to_ct_ID idl))
- | VernacSetOpacity (true, id :: idl)
- -> CT_opaque (CT_id_ne_list(loc_qualid_to_ct_ID id,
- List.map loc_qualid_to_ct_ID idl))
- | VernacSetOpacity (_, []) -> xlate_error "Shouldn't occur"
+ | VernacSetOpacity (_,l) ->
+ CT_strategy(CT_level_list
+ (List.map (fun (l,q) ->
+ (level_to_ct_LEVEL l,
+ CT_id_list(List.map loc_qualid_to_ct_ID q))) l))
| VernacUndo n -> CT_undo (CT_coerce_INT_to_INT_OPT (CT_int n))
| VernacShow (ShowGoal nopt) -> CT_show_goal (xlate_int_opt nopt)
| VernacShow ShowNode -> CT_show_node
@@ -1799,7 +1845,7 @@ let rec xlate_vernac =
| PrintOpaqueName id -> CT_print_opaqueid (loc_qualid_to_ct_ID id)
| PrintSectionContext id -> CT_print_section (loc_qualid_to_ct_ID id)
| PrintModules -> CT_print_modules
- | PrintGrammar (phylum, name) -> CT_print_grammar CT_grammar_none
+ | PrintGrammar name -> CT_print_grammar CT_grammar_none
| PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star)
| PrintHintDbName id ->
CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id))
@@ -1819,6 +1865,12 @@ let rec xlate_vernac =
CT_print_path (xlate_class id1, xlate_class id2)
| PrintCanonicalConversions ->
xlate_error "TODO: Print Canonical Structures"
+ | PrintAssumptions _ ->
+ xlate_error "TODO: Print Needed Assumptions"
+ | PrintInstances _ ->
+ xlate_error "TODO: Print Instances"
+ | PrintTypeClasses ->
+ xlate_error "TODO: Print TypeClasses"
| PrintInspect n -> CT_inspect (CT_int n)
| PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s)
| PrintSetoids -> CT_print_setoids
@@ -1837,12 +1889,14 @@ let rec xlate_vernac =
| VernacBeginSection (_,id) ->
CT_coerce_SECTION_BEGIN_to_COMMAND (CT_section (xlate_ident id))
| VernacEndSegment (_,id) -> CT_section_end (xlate_ident id)
- | VernacStartTheoremProof (k, (_,s), (bl,c), _, _) ->
+ | VernacStartTheoremProof (k, [Some (_,s), (bl,c)], _, _) ->
CT_coerce_THEOREM_GOAL_to_COMMAND(
CT_theorem_goal (CT_coerce_THM_to_DEFN_OR_THM (xlate_thm k), xlate_ident s,
xlate_binder_list bl, xlate_formula c))
+ | VernacStartTheoremProof _ ->
+ xlate_error "TODO: Mutually dependent theorems"
| VernacSuspend -> CT_suspend
- | VernacResume idopt -> CT_resume (xlate_ident_opt (option_map snd idopt))
+ | VernacResume idopt -> CT_resume (xlate_ident_opt (Option.map snd idopt))
| VernacDefinition (k,(_,s),ProveBody (bl,typ),_) ->
CT_coerce_THEOREM_GOAL_to_COMMAND
(CT_theorem_goal
@@ -1853,8 +1907,9 @@ let rec xlate_vernac =
(xlate_defn kind, xlate_ident s, xlate_binder_list bl,
cvt_optional_eval_for_definition c red_option,
xlate_formula_opt typ_opt)
- | VernacAssumption (kind, b) ->
- CT_variable (xlate_var kind, cvt_vernac_binders b)
+ | VernacAssumption (kind,inline ,b) ->xlate_error "TODO: Parameter Inline"
+ (*inline : bool -> automatic delta reduction at fonctor application*)
+ (* CT_variable (xlate_var kind, cvt_vernac_binders b)*)
| VernacCheckMayEval (None, numopt, c) ->
CT_check (xlate_formula c)
| VernacSearch (s,x) ->
@@ -1884,7 +1939,7 @@ let rec xlate_vernac =
(_, (add_coercion, (_,s)), binders, c1,
rec_constructor_or_none, field_list) ->
let record_constructor =
- xlate_ident_opt (option_map snd rec_constructor_or_none) in
+ xlate_ident_opt (Option.map snd rec_constructor_or_none) in
CT_record
((if add_coercion then CT_coercion_atm else
CT_coerce_NONE_to_COERCION_OPT(CT_none)),
@@ -1902,15 +1957,8 @@ let rec xlate_vernac =
(CT_co_ind co_or_ind, CT_ind_spec_list (List.map strip_mutind lmi))
| VernacFixpoint ([],_) -> xlate_error "mutual recursive"
| VernacFixpoint ((lm :: lmi),boxed) ->
- let strip_mutrec ((fid, (n, ro), bl, arf, ardef), _ntn) =
- let (struct_arg,bl,arf,ardef) =
- (* Pierre L: could the case [n=None && bl=[]] happen ? Normally not *)
- (* By the way, how could [bl = []] happen in V8 syntax ? *)
- if bl = [] then
- let n = out_some n in
- let (bl,arf,ardef) = Ppconstr.split_fix (n+1) arf ardef in
- (xlate_id_opt(List.nth (names_of_local_assums bl) n),bl,arf,ardef)
- else (make_fix_struct (n, bl),bl,arf,ardef) in
+ let strip_mutrec (((_,fid), (n, ro), bl, arf, ardef), _ntn) =
+ let struct_arg = make_fix_struct (n, bl) in
let arf = xlate_formula arf in
let ardef = xlate_formula ardef in
match xlate_binder_list bl with
@@ -1922,26 +1970,35 @@ let rec xlate_vernac =
(CT_fix_rec_list (strip_mutrec lm, List.map strip_mutrec lmi))
| VernacCoFixpoint ([],boxed) -> xlate_error "mutual corecursive"
| VernacCoFixpoint ((lm :: lmi),boxed) ->
- let strip_mutcorec ((fid, bl, arf, ardef), _ntn) =
+ let strip_mutcorec (((_,fid), bl, arf, ardef), _ntn) =
CT_cofix_rec (xlate_ident fid, xlate_binder_list bl,
xlate_formula arf, xlate_formula ardef) in
CT_cofix_decl
(CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))
| VernacScheme [] -> xlate_error "induction scheme"
| VernacScheme (lm :: lmi) ->
- let strip_ind ((_,id), depstr, inde, sort) =
+ let strip_ind = function
+ | (Some (_,id), InductionScheme (depstr, inde, sort)) ->
CT_scheme_spec
(xlate_ident id, xlate_dep depstr,
CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde),
- xlate_sort sort) in
+ xlate_sort sort)
+ | (None, InductionScheme (depstr, inde, sort)) ->
+ CT_scheme_spec
+ (xlate_ident (id_of_string ""), xlate_dep depstr,
+ CT_coerce_ID_to_FORMULA (loc_qualid_to_ct_ID inde),
+ xlate_sort sort)
+ | (_, EqualityScheme _) -> xlate_error "TODO: Scheme Equality" in
CT_ind_scheme
(CT_scheme_spec_list (strip_ind lm, List.map strip_ind lmi))
- | VernacSyntacticDefinition (id, c, false, _) ->
+ | VernacCombinedScheme _ -> xlate_error "TODO: Combined Scheme"
+ | VernacSyntacticDefinition ((_,id), ([],c), false, _) ->
CT_syntax_macro (xlate_ident id, xlate_formula c, xlate_int_opt None)
- | VernacSyntacticDefinition (id, c, true, _) ->
- xlate_error "TODO: Local abbreviations"
+ | VernacSyntacticDefinition ((_,id), _, _, _) ->
+ xlate_error"TODO: Local abbreviations and abbreviations with parameters"
(* Modules and Module Types *)
- | VernacDeclareModuleType((_, id), bl, mty_o) ->
+ | VernacInclude (_) -> xlate_error "TODO : Include "
+ | VernacDeclareModuleType((_, id), bl, mty_o) ->
CT_module_type_decl(xlate_ident id,
xlate_module_binder_list bl,
match mty_o with
@@ -2051,6 +2108,12 @@ let rec xlate_vernac =
| Local -> CT_local in
CT_coercion (local_opt, id_opt, xlate_ident id1,
xlate_class id2, xlate_class id3)
+
+ (* Type Classes *)
+ | VernacDeclareInstance _|VernacContext _|
+ VernacInstance (_, _, _, _, _)|VernacClass (_, _, _, _, _) ->
+ xlate_error "TODO: Type Classes commands"
+
| VernacResetName id -> CT_reset (xlate_ident (snd id))
| VernacResetInitial -> CT_restore_state (CT_ident "Initial")
| VernacExtend (s, l) ->
@@ -2073,10 +2136,10 @@ let rec xlate_vernac =
CT_coerce_ID_LIST_to_ID_LIST_OPT
(CT_id_list
(List.map
- (function ExplByPos x
+ (function ExplByPos (x,_), _, _
-> xlate_error
"explication argument by rank is obsolete"
- | ExplByName id -> CT_ident (string_of_id id)) l)))
+ | ExplByName id, _, _ -> CT_ident (string_of_id id)) l)))
| VernacDeclareImplicits(false, id, opt_positions) ->
xlate_error "TODO: Implicit Arguments Global"
| VernacReserve((_,a)::l, f) ->
@@ -2096,13 +2159,15 @@ let rec xlate_vernac =
let table1 =
match table with
PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
- | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+ | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
+ | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
CT_set_option(table1)
| VernacSetOption (table, v) ->
let table1 =
match table with
PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
- | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+ | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
+ | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
let value =
match v with
| BoolValue _ -> assert false
@@ -2115,7 +2180,8 @@ let rec xlate_vernac =
let table1 =
match table with
PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
- | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+ | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
+ | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
CT_unset_option(table1)
| VernacAddOption (table, l) ->
let values =
@@ -2130,7 +2196,8 @@ let rec xlate_vernac =
let table1 =
match table with
PrimaryTable(s) -> CT_coerce_ID_to_TABLE(CT_ident s)
- | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2) in
+ | SecondaryTable(s1,s2) -> CT_table(CT_ident s1, CT_ident s2)
+ | TertiaryTable(s1,s2,s3) -> xlate_error "TODO: TertiaryTable" in
CT_set_option_value2(table1, CT_id_or_string_ne_list(fst, values1))
| VernacImport(true, a::l) ->
CT_export_id(CT_id_ne_list(reference_to_ct_ID a,
@@ -2140,13 +2207,17 @@ let rec xlate_vernac =
List.map reference_to_ct_ID l))
| VernacImport(_, []) -> assert false
| VernacProof t -> CT_proof_with(xlate_tactic t)
- | VernacVar _ -> xlate_error "Grammar vernac obsolete"
| (VernacGlobalCheck _|VernacPrintOption _|
VernacMemOption (_, _)|VernacRemoveOption (_, _)
| VernacBack _ | VernacBacktrack _ |VernacBackTo _|VernacRestoreState _| VernacWriteState _|
VernacSolveExistential (_, _)|VernacCanonical _ |
- VernacTacticNotation _)
- -> xlate_error "TODO: vernac";;
+ VernacTacticNotation _ | VernacUndoTo _ | VernacRemoveName _)
+ -> xlate_error "TODO: vernac"
+and level_to_ct_LEVEL = function
+ Conv_oracle.Opaque -> CT_Opaque
+ | Conv_oracle.Level n -> CT_Level (CT_int n)
+ | Conv_oracle.Expand -> CT_Expand;;
+
let rec xlate_vernac_list =
function
diff --git a/contrib/interface/xlate.mli b/contrib/interface/xlate.mli
index bedb4ac8..2e2b95fe 100644
--- a/contrib/interface/xlate.mli
+++ b/contrib/interface/xlate.mli
@@ -6,4 +6,3 @@ val xlate_formula : Topconstr.constr_expr -> ct_FORMULA;;
val xlate_ident : Names.identifier -> ct_ID;;
val xlate_vernac_list : Vernacexpr.vernac_expr -> ct_COMMAND_LIST;;
-val declare_in_coq : (unit -> unit);;
diff --git a/contrib/jprover/jall.ml b/contrib/jprover/jall.ml
index a2a72676..a9ebe5b6 100644
--- a/contrib/jprover/jall.ml
+++ b/contrib/jprover/jall.ml
@@ -31,23 +31,6 @@
* Modified by: Aleksey Nogin <nogin@cs.cornell.edu>
*)
-(*: All of Huang's modifications of this file are quoted or denoted
- by comments followed by a colon.
-:*)
-
-(*:
-open Mp_debug
-
-open Refiner.Refiner
-open Term
-open TermType
-open TermOp
-open TermSubst
-open TermMan
-open RefineError
-open Opname
-:*)
-
open Jterm
open Opname
open Jlogic
@@ -55,10 +38,6 @@ open Jtunify
let ruletable = Jlogic.ruletable
-(*:
-let free_var_op = make_opname ["free_variable";"Jprover"]
-let jprover_op = make_opname ["string";"Jprover"]
-:*)
let free_var_op = make_opname ["free_variable"; "Jprover"]
let jprover_op = make_opname ["jprover"; "string"]
@@ -1308,23 +1287,6 @@ struct
(* append renamed paramater "r" to non-quantifier subformulae
of renamed quantifier formulae *)
-(*: BUG :*)
-(*:
- let make_new_eigenvariable term =
- let op = (dest_term term).term_op in
- let opn = (dest_op op).op_name in
- let opnam = dest_opname opn in
- match opnam with
- [] ->
- raise jprover_bug
- | ofirst::orest ->
- let ofname = List.hd orest in
- let new_eigen_var = (ofname^"_r"^(string_of_int (!eigen_counter))) in
- eigen_counter := !eigen_counter + 1;
-(* print_endline ("New Counter :"^(string_of_int (!eigen_counter))); *)
- mk_string_term jprover_op new_eigen_var
-:*)
-
let make_new_eigenvariable term =
let op = (dest_term term).term_op in
let opa = (dest_op op).op_params in
@@ -2485,30 +2447,6 @@ struct
let dbt = dest_bterm bt in
(dbt.bterm)::(collect_subterms r)
- (*: Bug! :*)
-(*: let rec collect_delta_terms = function
- [] -> []
- | t::r ->
- let dt = dest_term t in
- let top = dt.term_op
- and tterms = dt.term_terms in
- let dop = dest_op top in
- let don = dest_opname dop.op_name in
- match don with
- [] ->
- let sub_terms = collect_subterms tterms in
- collect_delta_terms (sub_terms @ r)
- | op1::opr ->
- if op1 = "jprover" then
- match opr with
- [] -> raise (Invalid_argument "Jprover: delta position missing")
- | delta::_ ->
- delta::(collect_delta_terms r)
- else
- let sub_terms = collect_subterms tterms in
- collect_delta_terms (sub_terms @ r)
-:*)
-
let rec collect_delta_terms = function
[] -> []
| t::r ->
@@ -3219,23 +3157,7 @@ struct
| (v,termlist)::r ->
let dterms = collect_delta_terms termlist in
begin
-(*: print_stringlist dterms;
- mbreak "add_sigmaQ:1\n";
- Format.open_box 0;
- print_endline " ";
- print_endline "sigmaQ: ";
- print_string (v^" = ");
- print_term_list termlist;
- Format.force_newline ();
- print_stringlist dterms;
- Format.force_newline ();
- Format.print_flush ();
- mbreak "add_sigmaQ:2\n";
-:*)
let new_ordering = add_arrowsQ v dterms ordering in
-(*: print_ordering new_ordering;
- mbreak "add_sigmaQ:3\n";
-:*)
let (rest_pairs,rest_ordering) = add_sigmaQ r new_ordering in
((v,dterms)::rest_pairs),rest_ordering
end
@@ -3303,7 +3225,6 @@ struct
let jqunify term1 term2 sigmaQ =
let app_term1,app_term2 = apply_2_sigmaQ term1 term2 sigmaQ in
try
-(*: let tauQ = unify_mm app_term1 app_term2 String_set.StringSet.empty in :*)
let tauQ = unify_mm app_term1 app_term2 StringSet.empty in
let (mult,oel) = multiply sigmaQ tauQ in
(mult,oel)
@@ -3740,19 +3661,7 @@ let rec subst_replace subst_list t =
[] -> t
| (old_t,new_t)::r ->
let inter_term = var_subst t old_t "dummy" in
-(*: print_string "(";
- print_term stdout old_t;
- print_string " --> ";
- print_term stdout new_t;
- print_string ")\n";
- print_term stdout t;
- print_newline ();
- print_term stdout inter_term;
- print_newline (); :*)
let new_term = subst1 inter_term "dummy" new_t in
-(*: print_term stdout new_term;
- print_newline ();
- mbreak "\n+++========----- ---------..........\n"; :*)
subst_replace r new_term
let rename_pos x m =
@@ -3950,10 +3859,6 @@ exception Failed_connections
let path_checker atom_rel atom_sets qprefixes init_ordering logic =
let con = connections atom_rel [] in
-(*: print_endline "";
- print_endline ("number of connections: "^(string_of_int (List.length con)));
- mbreak "#connec\n";
-:*)
let rec provable path closed (orderingQ,reduction_ordering) eqlist (sigmaQ,sigmaJ) =
let rec check_connections (reduction_partners,extension_partners) ext_atom =
@@ -4470,7 +4375,6 @@ let rec create_output rule_list input_map =
and new_term2 = apply_var_subst next_term2 var_mapping
and (a,b) = pos
in
-(*: print_string (a^"+++"^b^"\n"); :*)
(* kick away the first argument, the position *)
(JLogic.append_inf (create_output r input_map) (b,new_term1) (a,new_term2) rule)
@@ -4514,8 +4418,6 @@ let rec make_test_interface rule_list input_map =
(**************************************************************)
-(*: modified for Coq :*)
-
let decomp_pos pos =
let {name=n; address=a; label=l} = pos in
(n,(a,l))
@@ -4590,8 +4492,6 @@ let gen_prover mult_limit logic calculus hyps concls =
(* from the LJmc to the LJ proof *)
create_coq_input (create_output sequent_proof input_map) idl
-(*: end of coq modification :*)
-
let prover mult_limit hyps concl = gen_prover mult_limit "J" "LJ" hyps [concl]
(************* test with propositional proof reconstruction ************)
@@ -4658,7 +4558,6 @@ let do_prove mult_limit termlist logic calculus =
print_endline "";
print_endline "";
Format.print_flush ();
-(*: let _ = input_char stdin in :*)
let reconstr_proof = reconstruct ftree red_ordering sigmaQ ext_proof logic calculus in
let sequent_proof = make_test_interface reconstr_proof input_map in
Format.open_box 0;
@@ -4676,7 +4575,7 @@ let do_prove mult_limit termlist logic calculus =
Format.force_newline ();
Format.force_newline ();
Format.print_flush ();
- tt ptree; (*: print proof tree :*)
+ tt ptree;
Format.print_flush ();
print_endline "";
print_endline ""
diff --git a/contrib/jprover/jprover.ml4 b/contrib/jprover/jprover.ml4
index 294943f7..5fd763c3 100644
--- a/contrib/jprover/jprover.ml4
+++ b/contrib/jprover/jprover.ml4
@@ -410,7 +410,7 @@ i*)
| Negl -> dyn_negl s1
| Allr -> dyn_allr (JT.dest_var t2)
| Alll -> dyn_alll s1 s2 (constr_of_jterm t2)
- | Exr -> dyn_exr (constr_of_jterm t2)
+ | Exr -> dyn_exr (Tactics.inj_open (constr_of_jterm t2))
| Exl -> dyn_exl s1 s2 (JT.dest_var t2)
| Ax -> T.assumption (*i TCL.tclIDTAC i*)
| Truer -> dyn_truer
diff --git a/contrib/micromega/CheckerMaker.v b/contrib/micromega/CheckerMaker.v
new file mode 100644
index 00000000..93b4d213
--- /dev/null
+++ b/contrib/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/contrib/micromega/Env.v b/contrib/micromega/Env.v
new file mode 100644
index 00000000..40db9e46
--- /dev/null
+++ b/contrib/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 (/contrib/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/contrib/micromega/EnvRing.v b/contrib/micromega/EnvRing.v
new file mode 100644
index 00000000..04e68272
--- /dev/null
+++ b/contrib/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/contrib/micromega/LICENSE.sos b/contrib/micromega/LICENSE.sos
new file mode 100644
index 00000000..5aadfa2a
--- /dev/null
+++ b/contrib/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/contrib/micromega/MExtraction.v b/contrib/micromega/MExtraction.v
new file mode 100644
index 00000000..a5ac92db
--- /dev/null
+++ b/contrib/micromega/MExtraction.v
@@ -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 *)
+(************************************************************************)
+(* *)
+(* 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 VarMap.
+Require Import RingMicromega.
+Require Import NArith.
+
+Extraction "micromega.ml" List.map simpl_cone map_cone indexes n_of_Z Nnat.N_of_nat ZTautoChecker QTautoChecker find.
diff --git a/contrib/micromega/Micromegatac.v b/contrib/micromega/Micromegatac.v
new file mode 100644
index 00000000..13c7eace
--- /dev/null
+++ b/contrib/micromega/Micromegatac.v
@@ -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 *)
+(************************************************************************)
+(* *)
+(* 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.
+
+Ltac micromegac dom d :=
+ let tac := lazymatch dom with
+ | Z =>
+ micromegap 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 =>
+ rmicromegap d ;
+ 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.
+
+Tactic Notation "micromega" constr(dom) int_or_var(n) := micromegac dom n.
+Tactic Notation "micromega" constr(dom) := micromegac dom ltac:-1.
+
+Ltac zfarkas := omicronp ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity.
+
+Ltac omicron dom :=
+ let tac := lazymatch dom with
+ | Z =>
+ zomicronp ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | Q =>
+ qomicronp ;
+ 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 =>
+ romicronp ;
+ 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 sos dom :=
+ let tac := lazymatch dom with
+ | Z =>
+ sosp ;
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity
+ | _ => fail "Unsupported domain"
+ end in tac.
+
+
diff --git a/contrib/micromega/OrderedRing.v b/contrib/micromega/OrderedRing.v
new file mode 100644
index 00000000..149b7731
--- /dev/null
+++ b/contrib/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/contrib/micromega/QMicromega.v b/contrib/micromega/QMicromega.v
new file mode 100644
index 00000000..9e95f6c4
--- /dev/null
+++ b/contrib/micromega/QMicromega.v
@@ -0,0 +1,259 @@
+(************************************************************************)
+(* 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 Qring.
+
+(* Qsrt has been removed from the library ? *)
+Definition Qsrt : ring_theory 0 1 Qplus Qmult Qminus Qopp Qeq.
+Proof.
+ constructor.
+ exact Qplus_0_l.
+ exact Qplus_comm.
+ exact Qplus_assoc.
+ exact Qmult_1_l.
+ exact Qmult_comm.
+ exact Qmult_assoc.
+ exact Qmult_plus_distr_l.
+ reflexivity.
+ exact Qplus_opp_r.
+Qed.
+
+
+Add Ring Qring : Qsrt.
+
+Lemma Qmult_neutral : forall x , 0 * x == 0.
+Proof.
+ intros.
+ compute.
+ reflexivity.
+Qed.
+
+(* Is there any qarith database ? *)
+
+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.
+ apply Qle_refl.
+ apply Qle_antisym ; auto.
+ eapply Qle_trans ; eauto.
+ apply Qlt_le_weak ; auto.
+ apply (Qlt_not_eq n m H H0) ; auto.
+ destruct (Qle_lt_or_eq _ _ H0) ; auto.
+ tauto.
+ 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_neutral.
+ auto.
+ compute in H.
+ discriminate.
+Qed.
+
+Definition Qeq_bool (p q : Q) : bool := Zeq_bool (Qnum p * ' Qden q)%Z (Qnum q * ' Qden p)%Z.
+
+Definition Qle_bool (x y : Q) : bool := Zle_bool (Qnum x * ' Qden y)%Z (Qnum y * ' Qden x)%Z.
+
+Require ZMicromega.
+
+Lemma Qeq_bool_ok : forall x y, Qeq_bool x y = true -> x == y.
+Proof.
+ intros.
+ unfold Qeq_bool in H.
+ unfold Qeq.
+ apply (Zeqb_ok _ _ H).
+Qed.
+
+
+Lemma Qeq_bool_neq : forall x y, Qeq_bool x y = false -> ~ x == y.
+Proof.
+ unfold Qeq_bool,Qeq.
+ red ; intros ; subst.
+ rewrite H0 in H.
+ apply (ZMicromega.Zeq_bool_neq _ _ H).
+ reflexivity.
+Qed.
+
+Lemma Qle_bool_imp_le : forall x y : Q, Qle_bool x y = true -> x <= y.
+Proof.
+ unfold Qle_bool, Qle.
+ intros.
+ apply Zle_bool_imp_le ; auto.
+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_ok ; 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.
+ 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 => Qge
+| OpLt => Qlt
+| OpGt => Qgt
+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 Qminus Qopp Qeq Qle Qlt (fun x => x) (fun x => x) (pow_N 1 Qmult).
+
+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_simpl : forall env f, Qeval_nformula env f = (let (p, op) := f in Qeval_op1 op (Qeval_expr env p)).
+Proof.
+ intros.
+ destruct f.
+ rewrite Qeval_expr_compat.
+ reflexivity.
+Qed.
+
+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) (fun x => x) (pow_N 1 Qmult) env d).
+Qed.
+
+Definition QWitness := ConeMember Q.
+
+Definition QWeakChecker := check_normalised_formulas 0 1 Qplus Qmult Qminus Qopp 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 QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool :=
+ @tauto_checker (Formula Q) (NFormula Q) (@cnf_normalise Q) (@cnf_negate Q) 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).
+ intros. rewrite Qeval_formula_compat. unfold Qeval_formula'. now apply (cnf_negate_correct Qsor).
+ intros t w0.
+ apply QWeakChecker_sound.
+Qed.
+
+
diff --git a/contrib/micromega/RMicromega.v b/contrib/micromega/RMicromega.v
new file mode 100644
index 00000000..ef28db32
--- /dev/null
+++ b/contrib/micromega/RMicromega.v
@@ -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 *)
+(************************************************************************)
+(* *)
+(* 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.
+
+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 Zeqb_ok ; auto.
+ apply R_power_theory.
+ intros x y.
+ intro.
+ apply IZR_neq.
+ apply ZMicromega.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_formula :=
+ eval_formula Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
+
+
+Definition Reval_nformula :=
+ eval_nformula 0 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR Nnat.nat_of_N pow.
+
+
+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 Nnat.nat_of_N pow env d).
+Qed.
+
+Definition RWitness := ConeMember Z.
+
+Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult Zminus Zopp 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 RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool :=
+ @tauto_checker (Formula Z) (NFormula Z) (@cnf_normalise Z) (@cnf_negate Z) 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. unfold Reval_formula. now apply (cnf_normalise_correct Rsor).
+ intros. unfold Reval_formula. now apply (cnf_negate_correct Rsor).
+ intros t w0.
+ apply RWeakChecker_sound.
+Qed.
+
+
diff --git a/contrib/micromega/Refl.v b/contrib/micromega/Refl.v
new file mode 100644
index 00000000..801d8b21
--- /dev/null
+++ b/contrib/micromega/Refl.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 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/contrib/micromega/RingMicromega.v b/contrib/micromega/RingMicromega.v
new file mode 100644
index 00000000..6885b82c
--- /dev/null
+++ b/contrib/micromega/RingMicromega.v
@@ -0,0 +1,779 @@
+(************************************************************************)
+(* 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 PExprC := PExpr C. (* arbitrary expressions built from +, *, - *)
+Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
+(*****)
+(*Definition Env := Env R. (* For interpreting PExprC *)*)
+Definition PolEnv := Env R. (* For interpreting PolC *)
+(*****)
+(*Definition Env := list R.
+Definition PolEnv := list R.*)
+(*****)
+
+(* What benefit do we get, in the case of EnvRing, from defining eval_pexpr
+explicitely below and not through PEeval, as the following lemma says? The
+function eval_pexpr seems to be a straightforward special case of PEeval
+when the environment (i.e., the second last argument of PEeval) of type
+off_map (which is (option positive * t)) is (None, env). *)
+
+(*****)
+Fixpoint eval_pexpr (l : PolEnv) (pe : PExprC) {struct pe} : R :=
+match pe with
+| PEc c => phi c
+| PEX j => l j
+| PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
+| PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
+| PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
+| PEopp pe1 => - (eval_pexpr l pe1)
+| PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
+end.
+
+
+Lemma eval_pexpr_simpl : forall (l : PolEnv) (pe : PExprC),
+ eval_pexpr l pe =
+ match pe with
+ | PEc c => phi c
+ | PEX j => l j
+ | PEadd pe1 pe2 => (eval_pexpr l pe1) + (eval_pexpr l pe2)
+ | PEsub pe1 pe2 => (eval_pexpr l pe1) - (eval_pexpr l pe2)
+ | PEmul pe1 pe2 => (eval_pexpr l pe1) * (eval_pexpr l pe2)
+ | PEopp pe1 => - (eval_pexpr l pe1)
+ | PEpow pe1 n => rpow (eval_pexpr l pe1) (pow_phi n)
+ end.
+Proof.
+ intros ; destruct pe ; reflexivity.
+Qed.
+
+
+
+Lemma eval_pexpr_PEeval : forall (env : PolEnv) (pe : PExprC),
+ eval_pexpr env pe =
+ PEeval rplus rtimes rminus ropp phi pow_phi rpow env pe.
+Proof.
+induction pe; simpl; intros.
+reflexivity.
+reflexivity.
+rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
+rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
+rewrite <- IHpe1; rewrite <- IHpe2; reflexivity.
+rewrite <- IHpe; reflexivity.
+rewrite <- IHpe; reflexivity.
+Qed.
+(*****)
+(*Definition eval_pexpr : Env -> PExprC -> R :=
+ PEeval 0 rplus rtimes rminus ropp phi pow_phi rpow.*)
+(*****)
+
+Inductive Op1 : Set := (* relations with 0 *)
+| Equal (* == 0 *)
+| NonEqual (* ~= 0 *)
+| Strict (* > 0 *)
+| NonStrict (* >= 0 *).
+
+Definition NFormula := (PExprC * 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_pexpr env p).
+
+
+Definition OpMult (o o' : Op1) : Op1 :=
+match o with
+| Equal => Equal
+| NonStrict => NonStrict (* (OpMult NonStrict Equal) could be defined as Equal *)
+| Strict => o'
+| NonEqual => NonEqual (* does not matter what we return here; see the following lemmas *)
+end.
+
+Definition OpAdd (o o': Op1) : Op1 :=
+match o with
+| Equal => o'
+| NonStrict =>
+ match o' with
+ | Strict => Strict
+ | _ => NonStrict
+ end
+| Strict => Strict
+| NonEqual => NonEqual (* does not matter what we return here *)
+end.
+
+Lemma OpMultNonEqual :
+ forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpMult o o' <> NonEqual.
+Proof.
+intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
+try (intro H; apply H1; reflexivity);
+try (intro H; apply H2; reflexivity).
+Qed.
+
+Lemma OpAdd_NonEqual :
+ forall o o' : Op1, o <> NonEqual -> o' <> NonEqual -> OpAdd o o' <> NonEqual.
+Proof.
+intros o o' H1 H2; destruct o; destruct o'; simpl; try discriminate;
+try (intro H; apply H1; reflexivity);
+try (intro H; apply H2; reflexivity).
+Qed.
+
+Lemma OpMult_sound :
+ forall (o o' : Op1) (x y : R), o <> NonEqual -> o' <> NonEqual ->
+ eval_op1 o x -> eval_op1 o' y -> eval_op1 (OpMult o o') (x * y).
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' x y H1 H2 H3 H4.
+rewrite H3; now rewrite (Rtimes_0_l sor).
+elimtype False; now apply H1.
+destruct o'.
+rewrite H4; now rewrite (Rtimes_0_r sor).
+elimtype False; now apply H2.
+now apply (Rtimes_pos_pos sor).
+apply (Rtimes_nonneg_nonneg sor); [le_less | assumption].
+destruct o'.
+rewrite H4, (Rtimes_0_r sor); le_equal.
+elimtype False; now apply H2.
+apply (Rtimes_nonneg_nonneg sor); [assumption | le_less].
+now apply (Rtimes_nonneg_nonneg sor).
+Qed.
+
+Lemma OpAdd_sound :
+ forall (o o' : Op1) (e e' : R), o <> NonEqual -> o' <> NonEqual ->
+ eval_op1 o e -> eval_op1 o' e' -> eval_op1 (OpAdd o o') (e + e').
+Proof.
+unfold eval_op1; destruct o; simpl; intros o' e e' H1 H2 H3 H4.
+destruct o'.
+now rewrite H3, H4, (Rplus_0_l sor).
+elimtype False; now apply H2.
+now rewrite H3, (Rplus_0_l sor).
+now rewrite H3, (Rplus_0_l sor).
+elimtype False; now apply H1.
+destruct o'.
+now rewrite H4, (Rplus_0_r sor).
+elimtype False; now apply H2.
+now apply (Rplus_pos_pos sor).
+now apply (Rplus_pos_nonneg sor).
+destruct o'.
+now rewrite H4, (Rplus_0_r sor).
+elimtype False; now apply H2.
+now apply (Rplus_nonneg_pos sor).
+now apply (Rplus_nonneg_nonneg sor).
+Qed.
+
+(* We consider a monoid whose generators are polynomials from the
+hypotheses of the form (p ~= 0). Thus it follows from the hypotheses that
+every element of the monoid (i.e., arbitrary product of generators) is ~=
+0. Therefore, the square of every element is > 0. *)
+
+Inductive Monoid (l : list NFormula) : PExprC -> Prop :=
+| M_One : Monoid l (PEc cI)
+| M_In : forall p : PExprC, In (p, NonEqual) l -> Monoid l p
+| M_Mult : forall (e1 e2 : PExprC), Monoid l e1 -> Monoid l e2 -> Monoid l (PEmul e1 e2).
+
+(* Do we really need to rely on the intermediate definition of monoid ?
+ InC why the restriction NonEqual ?
+ Could not we consider the IsIdeal as a IsMult ?
+ The same for IsSquare ?
+*)
+
+Inductive Cone (l : list (NFormula)) : PExprC -> Op1 -> Prop :=
+| InC : forall p op, In (p, op) l -> op <> NonEqual -> Cone l p op
+| IsIdeal : forall p, Cone l p Equal -> forall p', Cone l (PEmul p p') Equal
+| IsSquare : forall p, Cone l (PEmul p p) NonStrict
+| IsMonoid : forall p, Monoid l p -> Cone l (PEmul p p) Strict
+| IsMult : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEmul p q) (OpMult op oq)
+| IsAdd : forall p op q oq, Cone l p op -> Cone l q oq -> Cone l (PEadd p q) (OpAdd op oq)
+| IsPos : forall c : C, cltb cO c = true -> Cone l (PEc c) Strict
+| IsZ : Cone l (PEc cO) Equal.
+
+(* As promised, if all hypotheses are true in some environment, then every
+member of the monoid is nonzero in this environment *)
+
+Lemma monoid_nonzero : forall (l : list NFormula) (env : PolEnv),
+ (forall f : NFormula, In f l -> eval_nformula env f) ->
+ forall p : PExprC, Monoid l p -> eval_pexpr env p ~= 0.
+Proof.
+intros l env H1 p H2. induction H2 as [| f H | e1 e2 H3 IH1 H4 IH2]; simpl.
+rewrite addon.(SORrm).(morph1). apply (Rneq_symm sor). apply (Rneq_0_1 sor).
+apply H1 in H. now simpl in H.
+simpl in IH1, IH2. apply (Rtimes_neq_0 sor). now split.
+Qed.
+
+(* If all members of a cone base are true in some environment, then every
+member of the cone is true as well *)
+
+Lemma cone_true :
+ forall (l : list NFormula) (env : PolEnv),
+ (forall (f : NFormula), In f l -> eval_nformula env f) ->
+ forall (p : PExprC) (op : Op1), Cone l p op ->
+ op <> NonEqual /\ eval_nformula env (p, op).
+Proof.
+intros l env H1 p op H2. induction H2; simpl in *.
+split. assumption. apply H1 in H. now unfold eval_nformula in H.
+split. discriminate. destruct IHCone as [_ H3]. rewrite H3. now rewrite (Rtimes_0_l sor).
+split. discriminate. apply (Rtimes_square_nonneg sor).
+split. discriminate. apply <- (Rlt_le_neq sor). split. apply (Rtimes_square_nonneg sor).
+apply (Rneq_symm sor). apply (Rtimes_neq_0 sor). split; now apply monoid_nonzero with l.
+destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
+split. now apply OpMultNonEqual. now apply OpMult_sound.
+destruct IHCone1 as [IH1 IH2]; destruct IHCone2 as [IH3 IH4].
+split. now apply OpAdd_NonEqual. now apply OpAdd_sound.
+split. discriminate. rewrite <- addon.(SORrm).(morph0). now apply cltb_sound.
+split. discriminate. apply addon.(SORrm).(morph0).
+Qed.
+
+(* Every element of a monoid is a product of some generators; therefore,
+to determine an element we can give a list of generators' indices *)
+
+Definition MonoidMember : Set := list nat.
+
+Inductive ConeMember : Type :=
+| S_In : nat -> ConeMember
+| S_Ideal : PExprC -> ConeMember -> ConeMember
+| S_Square : PExprC -> ConeMember
+| S_Monoid : MonoidMember -> ConeMember
+| S_Mult : ConeMember -> ConeMember -> ConeMember
+| S_Add : ConeMember -> ConeMember -> ConeMember
+| S_Pos : C -> ConeMember
+| S_Z : ConeMember.
+
+Definition nformula_times (f f' : NFormula) : NFormula :=
+let (p, op) := f in
+ let (p', op') := f' in
+ (PEmul p p', OpMult op op').
+
+Definition nformula_plus (f f' : NFormula) : NFormula :=
+let (p, op) := f in
+ let (p', op') := f' in
+ (PEadd p p', OpAdd op op').
+
+Definition nformula_times_0 (p : PExprC) (f : NFormula) : NFormula :=
+let (q, op) := f in
+ match op with
+ | Equal => (PEmul q p, Equal)
+ | _ => f
+ end.
+
+Fixpoint eval_monoid (l : list NFormula) (ns : MonoidMember) {struct ns} : PExprC :=
+match ns with
+| nil => PEc cI
+| n :: ns =>
+ let p := match nth n l (PEc cI, NonEqual) with
+ | (q, NonEqual) => q
+ | _ => PEc cI
+ end in
+ PEmul p (eval_monoid l ns)
+end.
+
+Theorem eval_monoid_in_monoid :
+ forall (l : list NFormula) (ns : MonoidMember), Monoid l (eval_monoid l ns).
+Proof.
+intro l; induction ns; simpl in *.
+constructor.
+apply M_Mult; [| assumption].
+destruct (nth_in_or_default a l (PEc cI, NonEqual)).
+destruct (nth a l (PEc cI, NonEqual)). destruct o; try constructor. assumption.
+rewrite e; simpl. constructor.
+Qed.
+
+(* Provides the cone member from the witness, i.e., ConeMember *)
+Fixpoint eval_cone (l : list NFormula) (cm : ConeMember) {struct cm} : NFormula :=
+match cm with
+| S_In n => match nth n l (PEc cO, Equal) with
+ | (_, NonEqual) => (PEc cO, Equal)
+ | f => f
+ end
+| S_Ideal p cm' => nformula_times_0 p (eval_cone l cm')
+| S_Square p => (PEmul p p, NonStrict)
+| S_Monoid m => let p := eval_monoid l m in (PEmul p p, Strict)
+| S_Mult p q => nformula_times (eval_cone l p) (eval_cone l q)
+| S_Add p q => nformula_plus (eval_cone l p) (eval_cone l q)
+| S_Pos c => if cltb cO c then (PEc c, Strict) else (PEc cO, Equal)
+| S_Z => (PEc cO, Equal)
+end.
+
+Theorem eval_cone_in_cone :
+ forall (l : list NFormula) (cm : ConeMember),
+ let (p, op) := eval_cone l cm in Cone l p op.
+Proof.
+intros l cm; induction cm; simpl.
+destruct (nth_in_or_default n l (PEc cO, Equal)).
+destruct (nth n l (PEc cO, Equal)). destruct o; try (now apply InC). apply IsZ.
+rewrite e. apply IsZ.
+destruct (eval_cone l cm). destruct o; simpl; try assumption. now apply IsIdeal.
+apply IsSquare.
+apply IsMonoid. apply eval_monoid_in_monoid.
+destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_times. now apply IsMult.
+destruct (eval_cone l cm1). destruct (eval_cone l cm2). unfold nformula_plus. now apply IsAdd.
+case_eq (cO [<] c) ; intros ; [apply IsPos ; auto| apply IsZ].
+apply IsZ.
+Qed.
+
+(* (inconsistent_cone_member l p) means (p, op) is in the cone for some op
+(> 0, >= 0, == 0, or ~= 0) and this formula is inconsistent. This fact
+implies that l is inconsistent, as shown by the next lemma. Inconsistency
+of a formula (p, op) can be established by normalizing p and showing that
+it is a constant c for which (c, op) is false. (This is only a sufficient,
+not necessary, condition, of course.) Membership in the cone can be
+verified if we have a certificate. *)
+
+Definition inconsistent_cone_member (l : list NFormula) (p : PExprC) :=
+ exists op : Op1, Cone l p op /\
+ forall env : PolEnv, ~ eval_op1 op (eval_pexpr env p).
+
+(* If some element of a cone is inconsistent, then the base of the cone
+is also inconsistent *)
+
+Lemma prove_inconsistent :
+ forall (l : list NFormula) (p : PExprC),
+ inconsistent_cone_member l p -> forall env, make_impl (eval_nformula env) l False.
+Proof.
+intros l p H env.
+destruct H as [o [wit H]].
+apply -> make_conj_impl.
+intro H1. apply H with env.
+pose proof (@cone_true l env) as H2.
+cut (forall f : NFormula, In f l -> eval_nformula env f). intro H3.
+apply (proj2 (H2 H3 p o wit)). intro. now apply make_conj_in.
+Qed.
+
+Definition normalise_pexpr : PExprC -> PolC :=
+ norm_aux cO cI cplus ctimes cminus copp ceqb.
+
+(* The following definition we don't really need, hence it is commented *)
+(*Definition eval_pol : PolEnv -> PolC -> R := Pphi 0 rplus rtimes phi.*)
+
+(* roughly speaking, normalise_pexpr_correct is a proof of
+ forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
+
+(*****)
+Definition normalise_pexpr_correct :=
+let Rops_wd := mk_reqe rplus rtimes ropp req
+ sor.(SORplus_wd)
+ sor.(SORtimes_wd)
+ sor.(SORopp_wd) in
+ norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt))
+ addon.(SORrm) addon.(SORpower).
+(*****)
+(*Definition normalise_pexpr_correct :=
+let Rops_wd := mk_reqe rplus rtimes ropp req
+ sor.(SORplus_wd)
+ sor.(SORtimes_wd)
+ sor.(SORopp_wd) in
+ norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth sor.(SORsetoid) Rops_wd sor.(SORrt))
+ addon.(SORrm) addon.(SORpower) nil.*)
+(*****)
+
+(* 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 normalise_pexpr e with
+ | Pc c =>
+ match op with
+ | Equal => cneqb c cO
+ | NonStrict => c [<] cO
+ | Strict => c [<=] cO
+ | NonEqual => false (* eval_cone never returns (p, NonEqual) *)
+ end
+ | _ => false (* not a constant *)
+ end.
+
+Lemma check_inconsistent_sound :
+ forall (p : PExprC) (op : Op1),
+ check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pexpr env p).
+Proof.
+intros p op H1 env. unfold check_inconsistent, normalise_pexpr in H1.
+destruct op; simpl;
+(*****)
+rewrite eval_pexpr_PEeval;
+(*****)
+(*unfold eval_pexpr;*)
+(*****)
+rewrite normalise_pexpr_correct;
+destruct (norm_aux cO cI cplus ctimes cminus copp ceqb p); simpl; try discriminate H1;
+try rewrite <- addon.(SORrm).(morph0); trivial.
+now apply cneqb_sound.
+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 -> ConeMember -> bool :=
+ fun l cm => check_inconsistent (eval_cone l cm).
+
+Lemma checker_nf_sound :
+ forall (l : list NFormula) (cm : ConeMember),
+ 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.
+case_eq (eval_cone l cm). intros p op H1.
+apply prove_inconsistent with p. unfold inconsistent_cone_member. exists op. split.
+pose proof (eval_cone_in_cone l cm) as H2. now rewrite H1 in H2.
+apply check_inconsistent_sound. now rewrite <- H1.
+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.
+
+Record Formula : Type := {
+ Flhs : PExprC;
+ Fop : Op2;
+ Frhs : PExprC
+}.
+
+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 normalise (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+ match op with
+ | OpEq => (PEsub lhs rhs, Equal)
+ | OpNEq => (PEsub lhs rhs, NonEqual)
+ | OpLe => (PEsub rhs lhs, NonStrict)
+ | OpGe => (PEsub lhs rhs, NonStrict)
+ | OpGt => (PEsub lhs rhs, Strict)
+ | OpLt => (PEsub rhs lhs, Strict)
+ end.
+
+Definition negate (f : Formula) : NFormula :=
+let (lhs, op, rhs) := f in
+ match op with
+ | OpEq => (PEsub rhs lhs, NonEqual)
+ | OpNEq => (PEsub rhs lhs, Equal)
+ | OpLe => (PEsub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
+ | OpGe => (PEsub rhs lhs, Strict)
+ | OpGt => (PEsub rhs lhs, NonStrict)
+ | OpLt => (PEsub lhs rhs, NonStrict)
+end.
+
+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 *.
+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.
+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
+ match o with
+ | OpEq =>
+ (PEsub lhs rhs, Strict)::(PEsub rhs lhs , Strict)::nil
+ | OpNEq => (PEsub lhs rhs,Equal) :: nil
+ | OpGt => (PEsub rhs lhs,NonStrict) :: nil
+ | OpLt => (PEsub lhs rhs,NonStrict) :: nil
+ | OpGe => (PEsub rhs lhs , Strict) :: nil
+ | OpLe => (PEsub 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;
+ 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
+ match o with
+ | OpEq => (PEsub lhs rhs,Equal) :: nil
+ | OpNEq => (PEsub lhs rhs ,Strict)::(PEsub rhs lhs,Strict)::nil
+ | OpGt => (PEsub lhs rhs,Strict) :: nil
+ | OpLt => (PEsub rhs lhs,Strict) :: nil
+ | OpGe => (PEsub lhs rhs,NonStrict) :: nil
+ | OpLe => (PEsub 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 ;
+ 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_pexpr 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.
+
+(** Some syntactic simplifications of expressions and cone elements *)
+
+
+Fixpoint simpl_expr (e:PExprC) : PExprC :=
+ match e with
+ | PEmul y z => let y' := simpl_expr y in let z' := simpl_expr z in
+ match y' , z' with
+ | PEc c , z' => if ceqb c cI then z' else PEmul y' z'
+ | _ , _ => PEmul y' z'
+ end
+ | PEadd x y => PEadd (simpl_expr x) (simpl_expr y)
+ | _ => e
+ end.
+
+
+Definition simpl_cone (e:ConeMember) : ConeMember :=
+ match e with
+ | S_Square t => match simpl_expr t with
+ | PEc c => if ceqb cO c then S_Z else S_Pos (ctimes c c)
+ | x => S_Square x
+ end
+ | S_Mult t1 t2 =>
+ match t1 , t2 with
+ | S_Z , x => S_Z
+ | x , S_Z => S_Z
+ | S_Pos c , S_Pos c' => S_Pos (ctimes c c')
+ | S_Pos p1 , S_Mult (S_Pos p2) x => S_Mult (S_Pos (ctimes p1 p2)) x
+ | S_Pos p1 , S_Mult x (S_Pos p2) => S_Mult (S_Pos (ctimes p1 p2)) x
+ | S_Mult (S_Pos p2) x , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x
+ | S_Mult x (S_Pos p2) , S_Pos p1 => S_Mult (S_Pos (ctimes p1 p2)) x
+ | S_Pos x , S_Add y z => S_Add (S_Mult (S_Pos x) y) (S_Mult (S_Pos x) z)
+ | S_Pos c , _ => if ceqb cI c then t2 else S_Mult t1 t2
+ | _ , S_Pos c => if ceqb cI c then t1 else S_Mult t1 t2
+ | _ , _ => e
+ end
+ | S_Add t1 t2 =>
+ match t1 , t2 with
+ | S_Z , x => x
+ | x , S_Z => x
+ | x , y => S_Add x y
+ end
+ | _ => e
+ end.
+
+
+
+End Micromega.
+
diff --git a/contrib/micromega/Tauto.v b/contrib/micromega/Tauto.v
new file mode 100644
index 00000000..ef48efa6
--- /dev/null
+++ b/contrib/micromega/Tauto.v
@@ -0,0 +1,324 @@
+(************************************************************************)
+(* 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.
+
diff --git a/contrib/micromega/VarMap.v b/contrib/micromega/VarMap.v
new file mode 100644
index 00000000..240c0fb7
--- /dev/null
+++ b/contrib/micromega/VarMap.v
@@ -0,0 +1,258 @@
+(************************************************************************)
+(* 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 (/contrib/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 /contrib/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/contrib/micromega/ZCoeff.v b/contrib/micromega/ZCoeff.v
new file mode 100644
index 00000000..ced67e39
--- /dev/null
+++ b/contrib/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/contrib/micromega/ZMicromega.v b/contrib/micromega/ZMicromega.v
new file mode 100644
index 00000000..94c83f73
--- /dev/null
+++ b/contrib/micromega/ZMicromega.v
@@ -0,0 +1,714 @@
+(************************************************************************)
+(* 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.
+
+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.
+
+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 Zeq_bool_neq : forall x y, Zeq_bool x y = false -> x <> y.
+Proof.
+ red ; intros.
+ subst.
+ unfold Zeq_bool in H.
+ rewrite Zcompare_refl in H.
+ discriminate.
+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 Zeqb_ok ; auto.
+ constructor.
+ reflexivity.
+ intros x y.
+ apply Zeq_bool_neq ; auto.
+ apply Zle_bool_imp_le.
+Qed.
+
+
+(*Definition Zeval_expr := eval_pexpr 0 Zplus Zmult Zminus Zopp (fun x => x) (fun x => Z_of_N x) (Zpower).*)
+
+Fixpoint Zeval_expr (env: PolEnv Z) (e: PExpr Z) : Z :=
+ match e with
+ | PEc c => c
+ | PEX j => env j
+ | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
+ | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
+ | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
+ | PEopp pe1 => - (Zeval_expr env pe1)
+ | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n)
+ end.
+
+Lemma Zeval_expr_simpl : forall env e,
+ Zeval_expr env e =
+ match e with
+ | PEc c => c
+ | PEX j => env j
+ | PEadd pe1 pe2 => (Zeval_expr env pe1) + (Zeval_expr env pe2)
+ | PEsub pe1 pe2 => (Zeval_expr env pe1) - (Zeval_expr env pe2)
+ | PEmul pe1 pe2 => (Zeval_expr env pe1) * (Zeval_expr env pe2)
+ | PEopp pe1 => - (Zeval_expr env pe1)
+ | PEpow pe1 n => Zpower (Zeval_expr env pe1) (Z_of_N n)
+ end.
+Proof.
+ destruct e ; reflexivity.
+Qed.
+
+
+Definition Zeval_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 = Zeval_expr' env e.
+Proof.
+ induction e ; simpl ; subst ; try congruence.
+ rewrite IHe.
+ apply ZNpower.
+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 (e: PolEnv Z) (ff : Formula Z) :=
+ let (lhs,o,rhs) := ff in Zeval_op2 o (Zeval_expr e lhs) (Zeval_expr e 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.
+ intros.
+ unfold Zeval_formula.
+ destruct f.
+ repeat rewrite Zeval_expr_compat.
+ unfold Zeval_formula'.
+ unfold Zeval_expr'.
+ split ; destruct Fop ; simpl; auto with zarith.
+Qed.
+
+
+
+Definition Zeval_nformula :=
+ eval_nformula 0 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt (fun x => x) (fun x => x) (pow_N 1 Zmult).
+
+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_simpl : forall env f, Zeval_nformula env f = (let (p, op) := f in Zeval_op1 op (Zeval_expr env p)).
+Proof.
+ intros.
+ destruct f.
+ rewrite Zeval_expr_compat.
+ reflexivity.
+Qed.
+
+Lemma Zeval_nformula_dec : forall env d, (Zeval_nformula env d) \/ ~ (Zeval_nformula env d).
+Proof.
+ exact (fun env d =>eval_nformula_dec Zsor (fun x => x) (fun x => x) (pow_N 1%Z Zmult) env d).
+Qed.
+
+Definition ZWitness := ConeMember Z.
+
+Definition ZWeakChecker := check_normalised_formulas 0 1 Zplus Zmult Zminus Zopp Zeq_bool Zle_bool.
+
+Lemma ZWeakChecker_sound : forall (l : list (NFormula Z)) (cm : ZWitness),
+ ZWeakChecker l cm = true ->
+ forall env, make_impl (Zeval_nformula env) l False.
+Proof.
+ intros l cm H.
+ intro.
+ unfold Zeval_nformula.
+ apply (checker_nf_sound Zsor ZSORaddon l cm).
+ unfold ZWeakChecker in H.
+ exact H.
+Qed.
+
+Definition xnormalise (t:Formula Z) : list (NFormula Z) :=
+ let (lhs,o,rhs) := t in
+ match o with
+ | OpEq =>
+ ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
+ | OpNEq => (PEsub lhs rhs,Equal) :: nil
+ | OpGt => (PEsub rhs lhs,NonStrict) :: nil
+ | OpLt => (PEsub lhs rhs,NonStrict) :: nil
+ | OpGe => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
+ | OpLe => (PEsub lhs (PEadd rhs (PEc 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 (Zeval_nformula env) (normalise t) <-> Zeval_formula env t.
+Proof.
+ unfold normalise, xnormalise ; simpl ; intros env t.
+ rewrite Zeval_formula_compat.
+ unfold eval_cnf.
+ destruct t as [lhs o rhs]; case_eq o ; simpl;
+ 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).
+Qed.
+
+Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) :=
+ let (lhs,o,rhs) := t in
+ match o with
+ | OpEq => (PEsub lhs rhs,Equal) :: nil
+ | OpNEq => ((PEsub lhs (PEadd rhs (PEc 1))),NonStrict)::((PEsub rhs (PEadd lhs (PEc 1))),NonStrict)::nil
+ | OpGt => (PEsub lhs (PEadd rhs (PEc 1)),NonStrict) :: nil
+ | OpLt => (PEsub rhs (PEadd lhs (PEc 1)),NonStrict) :: nil
+ | OpGe => (PEsub lhs rhs,NonStrict) :: nil
+ | OpLe => (PEsub 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 (Zeval_nformula env) (negate t) <-> ~ Zeval_formula env t.
+Proof.
+ unfold negate, xnegate ; simpl ; intros env t.
+ rewrite Zeval_formula_compat.
+ unfold eval_cnf.
+ destruct t as [lhs o rhs]; case_eq o ; simpl ;
+ 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 ;
+ intuition (auto with zarith).
+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.
+
+Lemma narrow_interval_upper_bound : forall a b x, a > 0 -> a * x <= b -> x <= Zdiv b a.
+Proof.
+ unfold Zdiv.
+ intros.
+ generalize (Z_div_mod b a H).
+ destruct (Zdiv_eucl b a).
+ intros.
+ destruct H1.
+ destruct H2.
+ subst.
+ assert (HH :x <= z \/ z <= x -1) 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 _ _ _ H4 H1).
+ intros.
+ ring_simplify in H5.
+ rewrite Zmult_comm in H5.
+ auto with zarith.
+Qed.
+
+
+(* In this case, a certificate is made of a pair of inequations, in 1 variable,
+ that do not have an integer solution.
+ => modify the fourier elimination
+ *)
+Require Import QArith.
+
+
+Inductive ProofTerm : Type :=
+| RatProof : ZWitness -> ProofTerm
+| CutProof : PExprC Z -> Q -> ZWitness -> ProofTerm -> ProofTerm
+| EnumProof : Q -> PExprC Z -> Q -> ZWitness -> ZWitness -> list ProofTerm -> ProofTerm.
+
+(* 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.
+
+
+Definition cutChecker (l:list (NFormula Z)) (e: PExpr Z) (lb:Q) (pf : ZWitness) : option (NFormula Z) :=
+ let (lb,lc) := (makeLb e lb,makeLbCut e lb) in
+ if ZWeakChecker (neg_nformula lb::l) pf then Some lc else None.
+
+
+Fixpoint ZChecker (l:list (NFormula Z)) (pf : ProofTerm) {struct pf} : bool :=
+ match pf with
+ | RatProof pf => ZWeakChecker l pf
+ | CutProof e q pf rst =>
+ match cutChecker l e q pf with
+ | None => false
+ | Some c => ZChecker (c::l) rst
+ end
+ | EnumProof lb e ub pf1 pf2 rst =>
+ match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
+ | None , _ | _ , None => false
+ | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
+ (fix label (pfs:list ProofTerm) :=
+ fun lb ub =>
+ match pfs with
+ | nil => if Z_gt_dec lb ub then true else false
+ | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub)
+ end)
+ rst lb' ub'
+ end
+ end.
+
+
+Lemma ZChecker_simpl : forall (pf : ProofTerm) (l:list (NFormula Z)),
+ ZChecker l pf =
+ match pf with
+ | RatProof pf => ZWeakChecker l pf
+ | CutProof e q pf rst =>
+ match cutChecker l e q pf with
+ | None => false
+ | Some c => ZChecker (c::l) rst
+ end
+ | EnumProof lb e ub pf1 pf2 rst =>
+ match cutChecker l e lb pf1 , cutChecker l (PEopp e) (Qopp ub) pf2 with
+ | None , _ | _ , None => false
+ | Some _ , Some _ => let (lb',ub') := (qceiling lb, Zopp (qceiling (- ub))) in
+ (fix label (pfs:list ProofTerm) :=
+ fun lb ub =>
+ match pfs with
+ | nil => if Z_gt_dec lb ub then true else false
+ | pf::rsr => andb (ZChecker ((PEsub e (PEc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub)
+ end)
+ rst lb' ub'
+ end
+ end.
+Proof.
+ destruct pf ; reflexivity.
+Qed.
+
+(*
+Fixpoint depth (n:nat) : ProofTerm -> option nat :=
+ match n with
+ | O => fun pf => None
+ | S n =>
+ fun pf =>
+ match pf with
+ | RatProof _ => Some O
+ | CutProof _ _ _ p => option_map S (depth n p)
+ | EnumProof _ _ _ _ _ l =>
+ let f := fun pf x =>
+ match x , depth n pf with
+ | None , _ | _ , None => None
+ | Some n1 , Some n2 => Some (Max.max n1 n2)
+ end in
+ List.fold_right f (Some O) l
+ end
+ end.
+*)
+Fixpoint bdepth (pf : ProofTerm) : nat :=
+ match pf with
+ | RatProof _ => O
+ | 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 p c c0 y, In y l -> ltof ProofTerm bdepth y (EnumProof a b p c c0 l).
+Proof.
+ induction l.
+ simpl.
+ tauto.
+ simpl.
+ intros.
+ destruct H.
+ subst.
+ unfold ltof.
+ simpl.
+ generalize ( (fold_right
+ (fun (pf : ProofTerm) (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).
+ omega.
+ generalize (IHl a0 b p c c0 y H).
+ unfold ltof.
+ simpl.
+ generalize ( (fold_right (fun (pf : ProofTerm) (x : nat) => Max.max (bdepth pf) x) 0%nat
+ l)).
+ intros.
+ generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n).
+ omega.
+Qed.
+
+Lemma lb_lbcut : forall env e q, Zeval_nformula env (makeLb e q) -> Zeval_nformula env (makeLbCut e q).
+Proof.
+ unfold makeLb, makeLbCut.
+ destruct q.
+ rewrite Zeval_nformula_simpl.
+ rewrite Zeval_nformula_simpl.
+ unfold Zeval_op1.
+ rewrite Zeval_expr_simpl.
+ rewrite Zeval_expr_simpl.
+ rewrite Zeval_expr_simpl.
+ intro.
+ rewrite Zeval_expr_simpl.
+ revert H.
+ generalize (Zeval_expr env e).
+ rewrite Zeval_expr_simpl.
+ rewrite Zeval_expr_simpl.
+ unfold qceiling.
+ intros.
+ assert ( z >= ceiling Qnum (' Qden))%Z.
+ apply narrow_interval_lower_bound.
+ compute.
+ reflexivity.
+ destruct z ; auto with zarith.
+ auto with zarith.
+Qed.
+
+Lemma cutChecker_sound : forall e lb pf l res, cutChecker l e lb pf = Some res ->
+ forall env, make_impl (Zeval_nformula env) l (Zeval_nformula env res).
+Proof.
+ unfold cutChecker.
+ intros.
+ revert H.
+ case_eq (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf); intros ; [idtac | discriminate].
+ generalize (ZWeakChecker_sound _ _ H env).
+ intros.
+ inversion H0 ; subst ; clear H0.
+ apply -> make_conj_impl.
+ simpl in H1.
+ rewrite <- make_conj_impl in H1.
+ intros.
+ apply -> neg_nformula_sound ; auto.
+ red ; intros.
+ apply H1 ; auto.
+ clear H H1 H0.
+ generalize (lb_lbcut env e lb).
+ intros.
+ destruct (Zeval_nformula_dec env ((neg_nformula (makeLb e lb)))).
+ auto.
+ rewrite -> neg_nformula_sound in H0.
+ assert (HH := H H0).
+ rewrite <- neg_nformula_sound in HH.
+ tauto.
+ reflexivity.
+ unfold makeLb.
+ destruct lb.
+ reflexivity.
+Qed.
+
+
+Lemma cutChecker_sound_bound : forall e lb pf l res, cutChecker l e lb pf = Some res ->
+ forall env, make_conj (Zeval_nformula env) l -> (Zeval_expr env e >= qceiling lb)%Z.
+Proof.
+ intros.
+ generalize (cutChecker_sound _ _ _ _ _ H env).
+ intros.
+ rewrite <- (make_conj_impl) in H1.
+ generalize (H1 H0).
+ unfold cutChecker in H.
+ destruct (ZWeakChecker (neg_nformula (makeLb e lb) :: l) pf).
+ unfold makeLbCut in H.
+ inversion H ; subst.
+ clear H.
+ simpl.
+ rewrite Zeval_expr_compat.
+ unfold Zeval_expr'.
+ auto with zarith.
+ discriminate.
+Qed.
+
+
+Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (Zeval_nformula env) l False.
+Proof.
+ induction w using (well_founded_ind (well_founded_ltof _ bdepth)).
+ destruct w.
+ (* RatProof *)
+ simpl.
+ intros.
+ eapply ZWeakChecker_sound.
+ apply H0.
+ (* CutProof *)
+ simpl.
+ intro.
+ case_eq (cutChecker l p q z) ; intros.
+ generalize (cutChecker_sound _ _ _ _ _ H0 env).
+ intro.
+ assert (make_impl (Zeval_nformula env) (n::l) False).
+ eapply (H w) ; auto.
+ unfold ltof.
+ simpl.
+ auto with arith.
+ simpl in H3.
+ rewrite <- make_conj_impl in H2.
+ rewrite <- make_conj_impl in H3.
+ rewrite <- make_conj_impl.
+ tauto.
+ discriminate.
+ (* EnumProof *)
+ intro.
+ rewrite ZChecker_simpl.
+ case_eq (cutChecker l0 p q z).
+ rename q into llb.
+ case_eq (cutChecker l0 (PEopp p) (- q0) z0).
+ intros.
+ rename q0 into uub.
+ (* get the bounds of the enum *)
+ rewrite <- make_conj_impl.
+ intro.
+ assert (qceiling llb <= Zeval_expr env p <= - qceiling ( - uub))%Z.
+ generalize (cutChecker_sound_bound _ _ _ _ _ H0 env H3).
+ generalize (cutChecker_sound_bound _ _ _ _ _ H1 env H3).
+ intros.
+ rewrite Zeval_expr_simpl in H5.
+ auto with zarith.
+ clear H0 H1.
+ revert H2 H3 H4.
+ generalize (qceiling llb) (- qceiling (- uub))%Z.
+ set (FF := (fix label (pfs : list ProofTerm) (lb ub : Z) {struct pfs} : bool :=
+ match pfs with
+ | nil => if Z_gt_dec lb ub then true else false
+ | pf :: rsr =>
+ (ZChecker ((PEsub p (PEc lb), Equal) :: l0) pf &&
+ label rsr (lb + 1)%Z ub)%bool
+ end)).
+ intros z1 z2.
+ intros.
+ assert (forall x, z1 <= x <= z2 -> exists pr,
+ (In pr l /\
+ ZChecker ((PEsub p (PEc x),Equal) :: l0) pr = true))%Z.
+ clear H.
+ revert H2.
+ clear H4.
+ revert z1 z2.
+ induction l;simpl ;intros.
+ destruct (Z_gt_dec z1 z2).
+ intros.
+ apply False_ind ; omega.
+ discriminate.
+ intros.
+ simpl in H2.
+ 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 (IHl _ _ H1 _ H4).
+ destruct H5.
+ exists x0 ; split;auto.
+ (*/asser *)
+ destruct (H0 _ H4) as [pr [Hin Hcheker]].
+ assert (make_impl (Zeval_nformula env) ((PEsub p (PEc (Zeval_expr env p)),Equal) :: l0) False).
+ apply (H pr);auto.
+ apply in_bdepth ; auto.
+ rewrite <- make_conj_impl in H1.
+ apply H1.
+ rewrite make_conj_cons.
+ split ;auto.
+ rewrite Zeval_nformula_simpl;
+ unfold Zeval_op1;
+ rewrite Zeval_expr_simpl.
+ generalize (Zeval_expr env p).
+ intros.
+ rewrite Zeval_expr_simpl.
+ auto with zarith.
+ intros ; discriminate.
+ intros ; discriminate.
+Qed.
+
+Definition ZTautoChecker (f : BFormula (Formula Z)) (w: list ProofTerm): bool :=
+ @tauto_checker (Formula Z) (NFormula Z) normalise negate ProofTerm 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 Zeval_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.
+
+
+Open Scope Z_scope.
+
+
+Fixpoint map_cone (f: nat -> nat) (e:ZWitness) : ZWitness :=
+ match e with
+ | S_In n => S_In _ (f n)
+ | S_Ideal e cm => S_Ideal e (map_cone f cm)
+ | S_Square _ => e
+ | S_Monoid l => S_Monoid _ (List.map f l)
+ | S_Mult cm1 cm2 => S_Mult (map_cone f cm1) (map_cone f cm2)
+ | S_Add cm1 cm2 => S_Add (map_cone f cm1) (map_cone f cm2)
+ | _ => e
+ end.
+
+Fixpoint indexes (e:ZWitness) : list nat :=
+ match e with
+ | S_In n => n::nil
+ | S_Ideal e cm => indexes cm
+ | S_Square e => nil
+ | S_Monoid l => l
+ | S_Mult cm1 cm2 => (indexes cm1)++ (indexes cm2)
+ | S_Add cm1 cm2 => (indexes cm1)++ (indexes cm2)
+ | _ => nil
+ end.
+
+(** 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 := Zeval_formula.
+
+Definition prod_pos_nat := prod positive nat.
+
+Require Import Int.
+
+
+Definition n_of_Z (z:Z) : BinNat.N :=
+ match z with
+ | Z0 => N0
+ | Zpos p => Npos p
+ | Zneg p => N0
+ end.
+
+
+
diff --git a/contrib/micromega/certificate.ml b/contrib/micromega/certificate.ml
new file mode 100644
index 00000000..88e882e6
--- /dev/null
+++ b/contrib/micromega/certificate.ml
@@ -0,0 +1,618 @@
+(************************************************************************)
+(* 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
+
+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
+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 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 -> Mc.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.S_Mult(t1, t2) ->
+ simpl_cone (Mc.S_Mult (rec_simpl_cone t1, rec_simpl_cone t2))
+ | Mc.S_Add(t1,t2) ->
+ simpl_cone (Mc.S_Add (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.S_Add (x,r) -> cone_list r (x::l)
+ | _ -> c :: l in
+
+ let factorise c1 c2 =
+ match c1 , c2 with
+ | Mc.S_Ideal(x,y) , Mc.S_Ideal(x',y') ->
+ if x = x' then Some (Mc.S_Ideal(x, Mc.S_Add(y,y'))) else None
+ | Mc.S_Mult(x,y) , Mc.S_Mult(x',y') ->
+ if x = x' then Some (Mc.S_Mult(x, Mc.S_Add(y,y'))) else None
+ | _ -> None in
+
+ let rec rebuild_cone l pending =
+ match l with
+ | [] -> (match pending with
+ | None -> Mc.S_Z
+ | Some p -> p
+ )
+ | e::l ->
+ (match pending with
+ | None -> rebuild_cone l (Some e)
+ | Some p -> (match factorise p e with
+ | None -> Mc.S_Add(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
+ | [] -> None
+ | e::cert' ->
+ let cst = match compare_big_int e zero_big_int with
+ | 0 -> Mc.S_Z
+ | 1 -> Mc.S_Pos (bint_to_cst e)
+ | _ -> failwith "positivity error"
+ in
+ let rec scalar_product cert l =
+ match cert with
+ | [] -> Mc.S_Z
+ | 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.S_Add (
+ Mc.S_Ideal (Mc.PEc ( bint_to_cst c), Mc.S_In (Ml2C.nat i)),
+ r)
+ | 0 -> r
+ | _ -> Mc.S_Add (
+ Mc.S_Mult (Mc.S_Pos (bint_to_cst c), Mc.S_In (Ml2C.nat i)),
+ r) in
+
+ Some ((factorise_linear_cone
+ (simplify_cone n_spec (Mc.S_Add (cst, scalar_product cert' li)))))
+
+
+exception Found of Monomial.t
+
+let raw_certificate l =
+ let sys = build_linear_system l in
+ try
+ match Fourier.find_point sys with
+ | None -> None
+ | Some 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 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 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 (c,i) -> let (Mc.Pair(x,y)) = c in
+ 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)
+
+(* 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)
+
+
+open Interval
+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
+
+(* Beurk... this code is a shame *)
+
+let rec zlinear_prover sys = xzlinear_prover [] sys
+
+and xzlinear_prover enum l : (Mc.proofTerm option) =
+ match linear_prover z_spec l with
+ | Some prf -> Some (Mc.RatProof prf)
+ | None ->
+ let ll = List.fold_right (fun (Mc.Pair(e,k)) r -> match k with
+ Mc.NonEqual -> r
+ | k -> (dev_form z_spec e ,
+ match k with
+ | Mc.Strict | Mc.NonStrict -> Ge
+ (* Loss of precision -- weakness of fourier*)
+ | Mc.Equal -> Eq
+ | Mc.NonEqual -> failwith "Cannot happen") :: r) l [] in
+
+ let (sys,var) = make_linear_system ll in
+ let res =
+ match Fourier.find_Q_interval sys with
+ | Some(i,x,j) -> if i =/ j
+ then Some(i,Vect.set x (Int 1) Vect.null,i) else None
+ | None -> None in
+ let res = match res with
+ | None ->
+ begin
+ let candidates = List.fold_right
+ (fun cstr acc ->
+ let gcd = Big_int (Vect.gcd cstr.coeffs) in
+ let vect = Vect.mul (Int 1 // gcd) cstr.coeffs in
+ if mem eq vect enum then acc
+ else ((vect,Fourier.optimise vect sys)::acc)) sys [] in
+ let candidates = List.fold_left (fun l (x,i) ->
+ match i with
+ None -> (x,Empty)::l
+ | Some i -> (x,i)::l) [] (candidates) in
+ match List.fold_left (fun (x1,i1) (x2,i2) ->
+ if smaller_itv i1 i2
+ then (x1,i1) else (x2,i2)) (Vect.null,Itv(None,None)) candidates
+ with
+ | (i,Empty) -> None
+ | (x,Itv(Some i, Some j)) -> Some(i,x,j)
+ | (x,Point n) -> Some(n,x,n)
+ | x -> match Fourier.find_Q_interval sys with
+ | None -> None
+ | Some(i,x,j) ->
+ if i =/ j
+ then Some(i,Vect.set x (Int 1) Vect.null,i)
+ else None
+ end
+ | _ -> res in
+
+ match res 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
+ (Mc.Pair(pplus (pmult (pconst ubd) expr) (popp (pconst ubn)),
+ Mc.NonStrict) :: l),
+ (* lb <= x -> lb > x *)
+ linear_prover z_spec
+ (Mc.Pair( pplus (popp (pmult (pconst lbd) expr)) (pconst lbn) ,
+ Mc.NonStrict)::l)
+ with
+ | Some cub , Some clb ->
+ (match zlinear_enum (e::enum) expr
+ (ceiling_num lb) (floor_num ub) l
+ with
+ | None -> None
+ | Some prf ->
+ Some (Mc.EnumProof(Ml2C.q lb,expr,Ml2C.q ub,clb,cub,prf)))
+ | _ -> None
+ )
+ | _ -> None
+and xzlinear_enum enum expr clb cub l =
+ if clb >/ cub
+ then Some Mc.Nil
+ else
+ let pexpr = pplus (popp (pconst (Ml2C.bigint (numerator clb)))) expr in
+ let sys' = (Mc.Pair(pexpr, Mc.Equal))::l in
+ match xzlinear_prover enum sys' with
+ | None -> if debug then print_string "zlp?"; None
+ | Some prf -> if debug then print_string "zlp!";
+ match zlinear_enum enum expr (clb +/ (Int 1)) cub l with
+ | None -> None
+ | Some prfl -> Some (Mc.Cons(prf,prfl))
+
+and zlinear_enum enum expr clb cub l =
+ let res = xzlinear_enum enum expr clb cub l in
+ if debug then Printf.printf "zlinear_enum %s %s -> %s\n"
+ (string_of_num clb)
+ (string_of_num cub)
+ (match res with
+ | None -> "None"
+ | Some r -> "Some") ; res
+
diff --git a/contrib/micromega/coq_micromega.ml b/contrib/micromega/coq_micromega.ml
new file mode 100644
index 00000000..29e2a183
--- /dev/null
+++ b/contrib/micromega/coq_micromega.ml
@@ -0,0 +1,1290 @@
+(************************************************************************)
+(* 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 Mutils
+let debug = false
+
+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
+
+type ('a,'b) formula =
+ | TT
+ | FF
+ | X of 'b
+ | A of 'a * Names.name
+ | C of ('a,'b) formula * ('a,'b) formula * Names.name
+ | D of ('a,'b) formula * ('a,'b) formula * Names.name
+ | N of ('a,'b) formula * Names.name
+ | I of ('a,'b) formula * ('a,'b) formula * Names.name
+
+let none = Names.Anonymous
+
+let tag_formula t f =
+ match f with
+ | A(x,_) -> A(x,t)
+ | C(x,y,_) -> C(x,y,t)
+ | D(x,y,_) -> D(x,y,t)
+ | N(x,_) -> N(x,t)
+ | I(x,y,_) -> I(x,y,t)
+ | _ -> f
+
+let tt = []
+let ff = [ [] ]
+
+
+type ('constant,'contr) sentence =
+ ('constant Micromega.formula, 'contr) formula
+
+let cnf negate normalise f =
+ let negate a =
+ CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) cl) (negate a) in
+
+ let normalise a =
+ CoqToCaml.list (fun cl -> CoqToCaml.list (fun x -> x) 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 (pol : bool) f =
+ 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 (* ?? *)
+ | A(x,t) -> if pol then normalise x else negate x
+ | N(e,t) -> xcnf (not pol) e
+ | C(e1,e2,t) ->
+ (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2)
+ | D(e1,e2,t) ->
+ (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2)
+ | I(e1,e2,t) ->
+ (if pol then or_cnf else and_cnf) (xcnf (not pol) e1) (xcnf pol e2) in
+
+ xcnf true f
+
+
+
+module M =
+struct
+ open Coqlib
+ open Term
+ (* let constant = gen_constant_in_modules "Omicron" coq_modules*)
+
+
+ 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"];
+ ["LRing_normalise"]]
+
+ let constant = gen_constant_in_modules "ZMicromega" coq_modules
+
+ let coq_and = lazy (constant "and")
+ let coq_or = lazy (constant "or")
+ let coq_not = lazy (constant "not")
+ let coq_iff = lazy (constant "iff")
+ let coq_True = lazy (constant "True")
+ let coq_False = lazy (constant "False")
+
+ let coq_cons = lazy (constant "cons")
+ let coq_nil = lazy (constant "nil")
+ let coq_list = lazy (constant "list")
+
+ let coq_O = lazy (constant "O")
+ let coq_S = lazy (constant "S")
+ let coq_nat = lazy (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_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_Build_Witness = lazy (constant "Build_Witness")
+
+
+ let coq_Qmake = lazy (constant "Qmake")
+
+ let coq_proofTerm = lazy (constant "ProofTerm")
+ 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 (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_N_of_Z = lazy
+ (gen_constant_in_modules "ZArithRing"
+ [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z")
+
+
+ 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_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_S_In = lazy (constant "S_In")
+ let coq_S_Square = lazy (constant "S_Square")
+ let coq_S_Monoid = lazy (constant "S_Monoid")
+ let coq_S_Ideal = lazy (constant "S_Ideal")
+ let coq_S_Mult = lazy (constant "S_Mult")
+ let coq_S_Add = lazy (constant "S_Add")
+ let coq_S_Pos = lazy (constant "S_Pos")
+ let coq_S_Z = lazy (constant "S_Z")
+ 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_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")
+
+ 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
+
+
+
+
+ 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
+
+ module Mc = Micromega
+
+ 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 (Mc.Pair (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) ->
+ (
+ match Term.kind_of_term c with
+ Term.Construct((n,j),i) ->
+ if Names.string_of_kn n = "Coq.QArith.QArith_base#<>#Q"
+ then {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) }
+ else raise ParseError
+ | _ -> raise ParseError
+ )
+ | _ -> raise ParseError
+
+ let rec parse_list parse_elt term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.Nil
+ | 2 -> Mc.Cons(parse_elt c.(1), parse_list parse_elt c.(2))
+ | i -> raise ParseError
+
+
+ let rec dump_list typ dump_elt l =
+ match l with
+ | Mc.Nil -> Term.mkApp(Lazy.force coq_nil,[| typ |])
+ | Mc.Cons(e,l) -> Term.mkApp(Lazy.force coq_cons,
+ [| typ; dump_elt e;dump_list typ dump_elt l|])
+
+ let rec dump_ml_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_ml_list typ dump_elt l|])
+
+
+
+ let pp_list op cl elt o l =
+ let rec _pp o l =
+ match l with
+ | Mc.Nil -> ()
+ | Mc.Cons(e,Mc.Nil) -> Printf.fprintf o "%a" elt e
+ | Mc.Cons(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 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
+
+
+ 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 rec dump_monoid l = dump_list (Lazy.force coq_nat) dump_nat l
+
+ let rec dump_cone typ dump_z e =
+ let z = Lazy.force typ in
+ let rec dump_cone e =
+ match e with
+ | Mc.S_In n -> mkApp(Lazy.force coq_S_In,[| z; dump_nat n |])
+ | Mc.S_Ideal(e,c) -> mkApp(Lazy.force coq_S_Ideal,
+ [| z; dump_expr z dump_z e ; dump_cone c |])
+ | Mc.S_Square e -> mkApp(Lazy.force coq_S_Square,
+ [| z;dump_expr z dump_z e|])
+ | Mc.S_Monoid l -> mkApp (Lazy.force coq_S_Monoid,
+ [|z; dump_monoid l|])
+ | Mc.S_Add(e1,e2) -> mkApp(Lazy.force coq_S_Add,
+ [| z; dump_cone e1; dump_cone e2|])
+ | Mc.S_Mult(e1,e2) -> mkApp(Lazy.force coq_S_Mult,
+ [| z; dump_cone e1; dump_cone e2|])
+ | Mc.S_Pos p -> mkApp(Lazy.force coq_S_Pos,[| z; dump_z p|])
+ | Mc.S_Z -> mkApp( Lazy.force coq_S_Z,[| z|]) in
+ dump_cone e
+
+
+ let pp_cone pp_z o e =
+ let rec pp_cone o e =
+ match e with
+ | Mc.S_In n ->
+ Printf.fprintf o "(S_In %a)%%nat" pp_nat n
+ | Mc.S_Ideal(e,c) ->
+ Printf.fprintf o "(S_Ideal %a %a)" pp_expr e pp_cone c
+ | Mc.S_Square e ->
+ Printf.fprintf o "(S_Square %a)" pp_expr e
+ | Mc.S_Monoid l ->
+ Printf.fprintf o "(S_Monoid %a)" (pp_list "[" "]" pp_nat) l
+ | Mc.S_Add(e1,e2) ->
+ Printf.fprintf o "(S_Add %a %a)" pp_cone e1 pp_cone e2
+ | Mc.S_Mult(e1,e2) ->
+ Printf.fprintf o "(S_Mult %a %a)" pp_cone e1 pp_cone e2
+ | Mc.S_Pos p ->
+ Printf.fprintf o "(S_Pos %a)%%positive" pp_z p
+ | Mc.S_Z ->
+ Printf.fprintf o "S_Z" in
+ pp_cone o e
+
+
+
+
+ let rec parse_op term =
+ let (i,c) = get_left_construct term in
+ match i with
+ | 1 -> Mc.OpEq
+ | 2 -> Mc.OpLe
+ | 3 -> Mc.OpGe
+ | 4 -> Mc.OpGt
+ | 5 -> Mc.OpLt
+ | i -> raise ParseError
+
+
+ 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 o {Mc.flhs = l ; Mc.fop = op ; Mc.frhs = r } =
+ Printf.fprintf o"(%a %a %a)" pp_expr l pp_op op pp_expr 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 parse_zop (op,args) =
+ match kind_of_term op with
+ | Const x ->
+ (match Names.string_of_con x with
+ | "Coq.ZArith.BinInt#<>#Zgt" -> (Mc.OpGt, args.(0), args.(1))
+ | "Coq.ZArith.BinInt#<>#Zge" -> (Mc.OpGe, args.(0), args.(1))
+ | "Coq.ZArith.BinInt#<>#Zlt" -> (Mc.OpLt, args.(0), args.(1))
+ | "Coq.ZArith.BinInt#<>#Zle" -> (Mc.OpLe, args.(0), args.(1))
+ (*| "Coq.Init.Logic#<>#not" -> Mc.OpNEq (* for backward compat *)*)
+ | s -> raise ParseError
+ )
+ | Ind(n,0) ->
+ (match Names.string_of_kn n with
+ | "Coq.Init.Logic#<>#eq" ->
+ if args.(0) <> Lazy.force coq_Z
+ then raise ParseError
+ else (Mc.OpEq, args.(1), args.(2))
+ | _ -> raise ParseError)
+ | _ -> failwith "parse_zop"
+
+
+ let parse_rop (op,args) =
+ try
+ match kind_of_term op with
+ | Const x ->
+ (match Names.string_of_con x with
+ | "Coq.Reals.Rdefinitions#<>#Rgt" -> (Mc.OpGt, args.(0), args.(1))
+ | "Coq.Reals.Rdefinitions#<>#Rge" -> (Mc.OpGe, args.(0), args.(1))
+ | "Coq.Reals.Rdefinitions#<>#Rlt" -> (Mc.OpLt, args.(0), args.(1))
+ | "Coq.Reals.Rdefinitions#<>#Rle" -> (Mc.OpLe, args.(0), args.(1))
+ (*| "Coq.Init.Logic#<>#not"-> Mc.OpNEq (* for backward compat *)*)
+ | s -> raise ParseError
+ )
+ | Ind(n,0) ->
+ (match Names.string_of_kn n with
+ | "Coq.Init.Logic#<>#eq" ->
+ (* if args.(0) <> Lazy.force coq_R
+ then raise ParseError
+ else*) (Mc.OpEq, args.(1), args.(2))
+ | _ -> raise ParseError)
+ | _ -> failwith "parse_rop"
+ with x ->
+ (Pp.pp (Pp.str "parse_rop failure ") ;
+ Pp.pp (Printer.prterm op) ; Pp.pp_flush ())
+ ; raise x
+
+
+ let parse_qop (op,args) =
+ (
+ (match kind_of_term op with
+ | Const x ->
+ (match Names.string_of_con x with
+ | "Coq.QArith.QArith_base#<>#Qgt" -> Mc.OpGt
+ | "Coq.QArith.QArith_base#<>#Qge" -> Mc.OpGe
+ | "Coq.QArith.QArith_base#<>#Qlt" -> Mc.OpLt
+ | "Coq.QArith.QArith_base#<>#Qle" -> Mc.OpLe
+ | "Coq.QArith.QArith_base#<>#Qeq" -> Mc.OpEq
+ | s -> raise ParseError
+ )
+ | _ -> failwith "parse_zop") , args.(0) , args.(1))
+
+
+ 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
+
+
+ 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 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 ops_spec (Names.string_of_con c) 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 ->
+ let (expr,env) = parse_expr env args.(0) in
+ let exp = (parse_exp args.(1)) in
+ (Mc.PEpow(expr, exp) , env)
+ | 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 = function
+ | "Coq.ZArith.BinInt#<>#Zplus" -> Binop (fun x y -> Mc.PEadd(x,y))
+ | "Coq.ZArith.BinInt#<>#Zminus" -> Binop (fun x y -> Mc.PEsub(x,y))
+ | "Coq.ZArith.BinInt#<>#Zmult" -> Binop (fun x y -> Mc.PEmul (x,y))
+ | "Coq.ZArith.BinInt#<>#Zopp" -> Opp
+ | "Coq.ZArith.Zpow_def#<>#Zpower" -> Power
+ | s -> Ukn s
+
+let qop_spec = function
+ | "Coq.QArith.QArith_base#<>#Qplus" -> Binop (fun x y -> Mc.PEadd(x,y))
+ | "Coq.QArith.QArith_base#<>#Qminus" -> Binop (fun x y -> Mc.PEsub(x,y))
+ | "Coq.QArith.QArith_base#<>#Qmult" -> Binop (fun x y -> Mc.PEmul (x,y))
+ | "Coq.QArith.QArith_base#<>#Qopp" -> Opp
+ | "Coq.QArith.QArith_base#<>#Qpower" -> Power
+ | s -> Ukn s
+
+let rop_spec = function
+ | "Coq.Reals.Rdefinitions#<>#Rplus" -> Binop (fun x y -> Mc.PEadd(x,y))
+ | "Coq.Reals.Rdefinitions#<>#Rminus" -> Binop (fun x y -> Mc.PEsub(x,y))
+ | "Coq.Reals.Rdefinitions#<>#Rmult" -> Binop (fun x y -> Mc.PEmul (x,y))
+ | "Coq.Reals.Rdefinitions#<>#Ropp" -> Opp
+ | "Coq.Reals.Rpow_def#<>#pow" -> Power
+ | s -> Ukn s
+
+
+
+
+
+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 ->
+ (match Names.string_of_con x with
+ | "Coq.Reals.Rdefinitions#<>#R0" -> Mc.Z0
+ | "Coq.Reals.Rdefinitions#<>#R1" -> Mc.Zpos Mc.XH
+ | _ -> raise ParseError
+ )
+ | _ -> raise ParseError
+
+
+let parse_zexpr =
+ parse_expr zconstant (fun x -> Mc.n_of_Z (parse_z x)) zop_spec
+let parse_qexpr =
+ parse_expr qconstant (fun x -> Mc.n_of_Z (parse_z x)) qop_spec
+let parse_rexpr =
+ parse_expr rconstant (fun x -> Mc.n_of_nat (parse_nat x)) 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 parse_conj parse_arith env term =
+ match kind_of_term term with
+ | App(l,rst) ->
+ (match kind_of_term l with
+ | Ind (n,_) ->
+ ( match Names.string_of_kn n with
+ | "Coq.Init.Logic#<>#and" ->
+ let (e1,env) = parse_arith env rst.(0) in
+ let (e2,env) = parse_conj parse_arith env rst.(1) in
+ (Mc.Cons(e1,e2),env)
+ | _ -> (* This might be an equality *)
+ let (e,env) = parse_arith env term in
+ (Mc.Cons(e,Mc.Nil),env))
+ | _ -> (* This is an arithmetic expression *)
+ let (e,env) = parse_arith env term in
+ (Mc.Cons(e,Mc.Nil),env))
+ | _ -> failwith "parse_conj(2)"
+
+
+
+ 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,none)
+ let mkD f1 f2 = D(f1,f2,none)
+ let mkIff f1 f2 = C(I(f1,f2,none),I(f2,f2,none),none)
+ let mkI f1 f2 = I(f1,f2,none)
+
+ let mkformula_binary g term f1 f2 =
+ match f1 , f2 with
+ | X _ , X _ -> X(term)
+ | _ -> g f1 f2
+
+ let parse_formula parse_atom env term =
+ let parse_atom env t = try let (at,env) = parse_atom env t in (A(at,none), env) with _ -> (X(t),env) in
+
+ let rec xparse_formula env term =
+ match kind_of_term term with
+ | App(l,rst) ->
+ (match rst with
+ | [|a;b|] when l = Lazy.force coq_and ->
+ let f,env = xparse_formula env a in
+ let g,env = xparse_formula env b in
+ mkformula_binary mkC term f g,env
+ | [|a;b|] when l = Lazy.force coq_or ->
+ let f,env = xparse_formula env a in
+ let g,env = xparse_formula env b in
+ mkformula_binary mkD term f g,env
+ | [|a|] when l = Lazy.force coq_not ->
+ let (f,env) = xparse_formula env a in (N(f,none), env)
+ | [|a;b|] when l = Lazy.force coq_iff ->
+ let f,env = xparse_formula env a in
+ let g,env = xparse_formula env b in
+ mkformula_binary mkIff term f g,env
+ | _ -> parse_atom env term)
+ | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
+ let f,env = xparse_formula env a in
+ let g,env = xparse_formula env b in
+ mkformula_binary mkI term f g,env
+ | _ when term = Lazy.force coq_True -> (TT,env)
+ | _ when term = Lazy.force coq_False -> (FF,env)
+ | _ -> X(term),env in
+ xparse_formula env term
+
+ 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")
+
+ 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
+
+
+ (* Backward compat *)
+
+ let rec parse_concl parse_arith env term =
+ match kind_of_term term with
+ | Prod(_,expr,rst) -> (* a -> b *)
+ let (lhs,rhs,env) = parse_concl parse_arith env rst in
+ let (e,env) = parse_arith env expr in
+ (Mc.Cons(e,lhs),rhs,env)
+ | App(_,_) ->
+ let (conj, env) = parse_conj parse_arith env term in
+ (Mc.Nil,conj,env)
+ | Ind(n,_) ->
+ (match (Names.string_of_kn n) with
+ | "Coq.Init.Logic#<>#False" -> (Mc.Nil,Mc.Nil,env)
+ | s ->
+ print_string s ; flush stdout;
+ failwith "parse_concl")
+ | _ -> failwith "parse_concl"
+
+
+ let rec parse_hyps parse_arith env goal_hyps hyps =
+ match hyps with
+ | [] -> ([],goal_hyps,env)
+ | (i,t)::l ->
+ let (li,lt,env) = parse_hyps parse_arith env goal_hyps l in
+ try
+ let (c,env) = parse_arith env t in
+ (i::li, Mc.Cons(c,lt), env)
+ with x ->
+ (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
+ (li,lt,env)
+
+
+ let parse_goal parse_arith env hyps term =
+ try
+ let (lhs,rhs,env) = parse_concl parse_arith env term in
+ let (li,lt,env) = parse_hyps parse_arith env lhs hyps in
+ (li,lt,rhs,env)
+ with Failure x -> raise ParseError
+ (* backward compat *)
+
+
+ (* ! reverse the list of bindings *)
+ let set l concl =
+ let rec _set acc = function
+ | [] -> acc
+ | (e::l) ->
+ let (name,expr,typ) = e in
+ _set (Term.mkNamedLetIn
+ (Names.id_of_string name)
+ expr typ acc) l in
+ _set concl l
+
+
+end
+
+open M
+
+
+let rec sig_of_cone = function
+ | Mc.S_In n -> [CoqToCaml.nat n]
+ | Mc.S_Ideal(e,w) -> sig_of_cone w
+ | Mc.S_Mult(w1,w2) ->
+ (sig_of_cone w1)@(sig_of_cone w2)
+ | Mc.S_Add(w1,w2) -> (sig_of_cone w1)@(sig_of_cone w2)
+ | _ -> []
+
+let same_proof sg cl1 cl2 =
+ let cl1 = CoqToCaml.list (fun x -> x) cl1 in
+ let cl2 = CoqToCaml.list (fun x -> x) cl2 in
+ 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.S_In n -> Names.Idset.union tgs
+ (snd (List.nth clause (CoqToCaml.nat n) ))
+ | Mc.S_Ideal(e,w) -> xtags tgs w
+ | Mc.S_Mult (w1,w2) | Mc.S_Add(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 =
+ let l = CoqToCaml.list (fun x -> x) polys1 in
+ try_any prover l
+
+let rec witness prover l1 l2 =
+ match l2 with
+ | Micromega.Nil -> Some (Micromega.Nil)
+ | Micromega.Cons(e,l2) ->
+ match find_witness prover (Micromega.Cons( e,l1)) with
+ | None -> None
+ | Some w ->
+ (match witness prover l1 l2 with
+ | None -> None
+ | Some l -> Some (Micromega.Cons (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.RatProof cone ->
+ Term.mkApp(Lazy.force coq_ratProof, [|dump_cone coq_Z dump_z cone|])
+ | Micromega.CutProof(e,q,cone,prf) ->
+ Term.mkApp(Lazy.force coq_cutProof,
+ [| dump_expr (Lazy.force coq_Z) dump_z e ;
+ dump_q q ;
+ dump_cone coq_Z dump_z cone ;
+ dump_proof_term prf|])
+ | Micromega.EnumProof( q1,e1,q2,c1,c2,prfs) ->
+ Term.mkApp (Lazy.force coq_enumProof,
+ [| dump_q q1 ; dump_expr (Lazy.force coq_Z) dump_z e1 ; dump_q q2;
+ dump_cone coq_Z dump_z c1 ; dump_cone 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.RatProof cone -> Printf.fprintf o "R[%a]" (pp_cone pp_z) cone
+ | Micromega.CutProof(e,q,_,p) -> failwith "not implemented"
+ | Micromega.EnumProof(q1,e1,q2,c1,c2,rst) ->
+ Printf.fprintf o "EP[%a,%a,%a,%a,%a,%a]"
+ pp_q q1 pp_expr e1 pp_q q2 (pp_cone pp_z) c1 (pp_cone pp_z) c2
+ (pp_list "[" "]" pp_proof_term) rst
+
+let rec parse_hyps parse_arith env hyps =
+ match hyps with
+ | [] -> ([],env)
+ | (i,t)::l ->
+ let (lhyps,env) = parse_hyps parse_arith env l in
+ try
+ let (c,env) = parse_formula parse_arith env t in
+ ((i,c)::lhyps, env)
+ with _ -> (lhyps,env)
+ (*(if debug then Printf.printf "parse_arith : %s\n" x);*)
+
+
+exception ParseError
+
+let parse_goal parse_arith env hyps term =
+ (* try*)
+ let (f,env) = parse_formula parse_arith env term in
+ let (lhyps,env) = parse_hyps parse_arith env hyps in
+ (lhyps,f,env)
+ (* with Failure x -> raise ParseError*)
+
+
+type ('a, 'b) domain_spec = {
+ typ : Term.constr; (* Z, Q , R *)
+ coeff : Term.constr ; (* Z, Q *)
+ dump_coeff : 'a -> Term.constr ;
+ proof_typ : Term.constr ;
+ dump_proof : 'b -> 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_cone 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_cone coq_Z dump_z
+}
+
+
+
+
+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
+
+
+let detect_duplicates cnf wit =
+ let cnf = CoqToCaml.list (fun x -> x) cnf in
+ let wit = CoqToCaml.list (fun x -> x) wit in
+
+ let rec xdup cnf wit =
+ match wit with
+ | [] -> []
+ | w :: wit ->
+ let sg = sig_of_cone w in
+ match cnf with
+ | [] -> []
+ | e::cnf ->
+ let (dups,cnf) = (List.partition (fun x -> same_proof sg e x) cnf) in
+ dups@(xdup cnf wit) in
+ xdup cnf wit
+
+let find_witness prover polys1 =
+ try_any prover polys1
+
+
+let witness_list_with_tags prover l =
+
+ let rec xwitness_list l =
+ match l with
+ | [] -> Some([])
+ | e::l ->
+ match find_witness prover (List.map fst 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_without_tags 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 prover l =
+ let rec xwitness_list l =
+ match l with
+ | Micromega.Nil -> Some(Micromega.Nil)
+ | Micromega.Cons(e,l) ->
+ match find_witness prover e with
+ | None -> None
+ | Some w ->
+ (match xwitness_list l with
+ | None -> None
+ | Some l -> Some (Micromega.Cons(w,l))
+ ) in
+ xwitness_list l
+
+
+
+
+let is_singleton = function [] -> true | [e] -> true | _ -> false
+
+
+let micromega_tauto negate normalise spec prover env polys1 polys2 gl =
+ let spec = Lazy.force spec in
+ let (ff,ids) =
+ List.fold_right
+ (fun (id,f) (cc,ids) ->
+ match f with
+ X _ -> (cc,ids)
+ | _ -> (I(tag_formula (Names.Name id) f,cc,none), id::ids))
+ polys1 (polys2,[]) in
+
+ let cnf_ff = cnf negate normalise ff in
+
+ if debug then
+ (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 ()) ;
+
+ match witness_list_without_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 (ff,res,ids) = (ff,res,List.map Term.mkVar ids) in
+ let res' = dump_ml_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
+
+
+let micromega_gen parse_arith negate normalise 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
+
+
+let lift_ratproof prover l =
+ match prover l with
+ | None -> None
+ | Some c -> Some (Mc.RatProof c)
+
+
+type csdpcert = Certificate.Mc.z Certificate.Mc.coneMember option
+type micromega_polys = (Micromega.z Mc.pExpr, Mc.op1) Micromega.prod list
+type provername = string * int option
+
+let call_csdpcert provername poly =
+ let tmp_to,ch_to = Filename.open_temp_file "csdpcert" ".in" in
+ let tmp_from = Filename.temp_file "csdpcert" ".out" in
+ output_value ch_to (provername,poly : provername * micromega_polys);
+ close_out ch_to;
+ let cmdname =
+ Filename.concat Coq_config.bindir
+ ("csdpcert" ^ Coq_config.exec_extension) in
+ let c = Sys.command (cmdname ^" "^ tmp_to ^" "^ tmp_from) in
+ (try Sys.remove tmp_to with _ -> ());
+ if c <> 0 then Util.error ("Failed to call csdp certificate generator");
+ let ch_from = open_in tmp_from in
+ let cert = (input_value ch_from : csdpcert) in
+ close_in ch_from; Sys.remove tmp_from;
+ cert
+
+let omicron gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+ [lift_ratproof
+ (Certificate.linear_prover Certificate.z_spec), "fourier refutation" ] gl
+
+
+let qomicron gl =
+ micromega_gen parse_qarith Mc.cnf_negate Mc.cnf_normalise qq_domain_spec
+ [ Certificate.linear_prover Certificate.q_spec, "fourier refutation" ] gl
+
+let romicron gl =
+ micromega_gen parse_rarith Mc.cnf_negate Mc.cnf_normalise rz_domain_spec
+ [ Certificate.linear_prover Certificate.z_spec, "fourier refutation" ] gl
+
+
+let rmicromega i gl =
+ micromega_gen parse_rarith Mc.negate Mc.normalise rz_domain_spec
+ [ call_csdpcert ("real_nonlinear_prover", Some i), "fourier refutation" ] gl
+
+
+let micromega i gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+ [lift_ratproof (call_csdpcert ("real_nonlinear_prover",Some i)),
+ "fourier refutation" ] gl
+
+
+let sos gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+ [lift_ratproof (call_csdpcert ("pure_sos", None)), "pure sos refutation"] gl
+
+let zomicron gl =
+ micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec
+ [Certificate.zlinear_prover, "zprover"] gl
diff --git a/contrib/micromega/csdpcert.ml b/contrib/micromega/csdpcert.ml
new file mode 100644
index 00000000..cfaf6ae1
--- /dev/null
+++ b/contrib/micromega/csdpcert.ml
@@ -0,0 +1,333 @@
+(************************************************************************)
+(* 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
+
+module Mc = Micromega
+module Ml2C = Mutils.CamlToCoq
+module C2Ml = Mutils.CoqToCaml
+
+let debug = false
+
+module M =
+struct
+ open Mc
+
+ let rec expr_to_term = function
+ | PEc z -> Const (Big_int (C2Ml.z_big_int 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)
+
+
+ let rec term_to_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_expr p1, term_to_expr p2)
+ | Add(p1,p2) -> PEadd(term_to_expr p1, term_to_expr p2)
+ | Opp p -> PEopp (term_to_expr p)
+ | Pow(t,n) -> PEpow (term_to_expr t,Ml2C.n n)
+ | Sub(t1,t2) -> PEsub (term_to_expr t1, term_to_expr t2)
+ | _ -> failwith "term_to_expr: not implemented"
+
+ let term_to_expr e =
+ let e' = term_to_expr e in
+ if debug
+ then Printf.printf "term_to_expr : %s - %s\n"
+ (string_of_poly (poly_of_term e))
+ (string_of_poly (poly_of_term (expr_to_term e')));
+ e'
+
+end
+open M
+
+open List
+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 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)
+
+
+let is_eq = function Mc.Equal -> true | _ -> false
+let is_le = function Mc.NonStrict -> true | _ -> false
+let is_lt = function Mc.Strict -> true | _ -> false
+
+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 cert_of_pos eq le lt ll l pos =
+ let s,pos = (scale_certificate pos) in
+ let rec _cert_of_pos = function
+ Axiom_eq i -> let idx = get_index_of_ith_match is_eq i l in
+ Mc.S_In (Ml2C.nat idx)
+ | Axiom_le i -> let idx = get_index_of_ith_match is_le i l in
+ Mc.S_In (Ml2C.nat idx)
+ | Axiom_lt i -> let idx = get_index_of_ith_match is_lt i l in
+ Mc.S_In (Ml2C.nat idx)
+ | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
+ | Rational_eq n | Rational_le n | Rational_lt n ->
+ if compare_num n (Int 0) = 0 then Mc.S_Z else
+ Mc.S_Pos (Ml2C.bigint (big_int_of_num n))
+ | Square t -> Mc.S_Square (term_to_expr t)
+ | Eqmul (t, y) -> Mc.S_Ideal(term_to_expr t, _cert_of_pos y)
+ | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z)
+ | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
+ s, Certificate.simplify_cone Certificate.z_spec (_cert_of_pos pos)
+
+
+let term_of_cert l pos =
+ let l = List.map fst' l in
+ let rec _cert_of_pos = function
+ | Mc.S_In i -> expr_to_term (List.nth l (C2Ml.nat i))
+ | Mc.S_Pos p -> Const (C2Ml.num p)
+ | Mc.S_Z -> Const (Int 0)
+ | Mc.S_Square t -> Mul(expr_to_term t, expr_to_term t)
+ | Mc.S_Monoid m -> List.fold_right
+ (fun x m -> Mul (expr_to_term (List.nth l (C2Ml.nat x)),m))
+ (C2Ml.list (fun x -> x) m) (Const (Int 1))
+ | Mc.S_Ideal (t, y) -> Mul(expr_to_term t, _cert_of_pos y)
+ | Mc.S_Add (y, z) -> Add (_cert_of_pos y, _cert_of_pos z)
+ | Mc.S_Mult (y, z) -> Mul (_cert_of_pos y, _cert_of_pos z) in
+ (_cert_of_pos pos)
+
+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 l =
+ print_string "print_list_term\n";
+ List.iter (fun (Mc.Pair(e,k)) -> Printf.printf "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")) l ;
+ print_string "\n"
+
+
+let partition_expr l =
+ let rec f i = function
+ | [] -> ([],[],[])
+ | Mc.Pair(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)
+
+let cert_of_pos pos =
+ let s,pos = (scale_certificate pos) in
+ let rec _cert_of_pos = function
+ Axiom_eq i -> Mc.S_In (Ml2C.nat i)
+ | Axiom_le i -> Mc.S_In (Ml2C.nat i)
+ | Axiom_lt i -> Mc.S_In (Ml2C.nat i)
+ | Monoid l -> Mc.S_Monoid (Ml2C.list Ml2C.nat l)
+ | Rational_eq n | Rational_le n | Rational_lt n ->
+ if compare_num n (Int 0) = 0 then Mc.S_Z else
+ Mc.S_Pos (Ml2C.bigint (big_int_of_num n))
+ | Square t -> Mc.S_Square (term_to_expr t)
+ | Eqmul (t, y) -> Mc.S_Ideal(term_to_expr t, _cert_of_pos y)
+ | Sum (y, z) -> Mc.S_Add (_cert_of_pos y, _cert_of_pos z)
+ | Product (y, z) -> Mc.S_Mult (_cert_of_pos y, _cert_of_pos z) in
+ s, Certificate.simplify_cone Certificate.z_spec (_cert_of_pos pos)
+
+(* The exploration is probably not complete - for simple cases, it works... *)
+let real_nonlinear_prover d l =
+ 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
+
+ let s,proof' = scale_certificate proof in
+ let cert = snd (cert_of_pos proof') in
+ if debug
+ then Printf.printf "cert poly : %s\n"
+ (string_of_poly (poly_of_term (term_of_cert l cert)));
+ match Mc.zWeakChecker (Ml2C.list (fun x -> x) l) cert with
+ | Mc.True -> Some cert
+ | Mc.False -> (print_string "buggy certificate" ; flush stdout) ;None
+ with
+ | Sos.TooDeep -> None
+
+
+(* This is somewhat buggy, over Z, strict inequality vanish... *)
+let pure_sos l =
+ (* 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
+ Some cert
+ with
+ | Not_found -> (* This is no strict inequality *) None
+ | x -> None
+
+
+type micromega_polys = (Micromega.z Mc.pExpr, Mc.op1) Micromega.prod list
+type csdp_certificate = Certificate.Mc.z Certificate.Mc.coneMember option
+type provername = string * int option
+
+let main () =
+ if Array.length Sys.argv <> 3 then
+ (Printf.printf "Usage: csdpcert inputfile outputfile\n"; exit 1);
+ let input_file = Sys.argv.(1) in
+ let output_file = Sys.argv.(2) in
+ let inch = open_in input_file in
+ let (prover,poly) = (input_value inch : provername * micromega_polys) in
+ close_in inch;
+ let cert =
+ match prover with
+ | "real_nonlinear_prover", Some d -> real_nonlinear_prover d poly
+ | "pure_sos", None -> pure_sos poly
+ | prover, _ -> (Printf.printf "unknown prover: %s\n" prover; exit 1) in
+ let outch = open_out output_file in
+ output_value outch (cert:csdp_certificate);
+ close_out outch;
+ exit 0;;
+
+let _ = main () in ()
diff --git a/contrib/micromega/g_micromega.ml4 b/contrib/micromega/g_micromega.ml4
new file mode 100644
index 00000000..259b5d4b
--- /dev/null
+++ b/contrib/micromega/g_micromega.ml4
@@ -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 *)
+(************************************************************************)
+(* *)
+(* Micromega: A reflexive tactic using the Positivstellensatz *)
+(* *)
+(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: g_micromega.ml4 10947 2008-05-19 19:10:40Z herbelin $ *)
+
+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 Micromega
+| [ "micromegap" int_or_var(i) ] -> [ Coq_micromega.micromega (out_arg i) ]
+| [ "micromegap" ] -> [ Coq_micromega.micromega (-1) ]
+END
+
+TACTIC EXTEND Sos
+[ "sosp" ] -> [ Coq_micromega.sos]
+END
+
+
+TACTIC EXTEND Omicron
+[ "omicronp" ] -> [ Coq_micromega.omicron]
+END
+
+TACTIC EXTEND QOmicron
+[ "qomicronp" ] -> [ Coq_micromega.qomicron]
+END
+
+
+TACTIC EXTEND ZOmicron
+[ "zomicronp" ] -> [ Coq_micromega.zomicron]
+END
+
+TACTIC EXTEND ROmicron
+[ "romicronp" ] -> [ Coq_micromega.romicron]
+END
+
+TACTIC EXTEND RMicromega
+| [ "rmicromegap" int_or_var(i) ] -> [ Coq_micromega.rmicromega (out_arg i) ]
+| [ "rmicromegap" ] -> [ Coq_micromega.rmicromega (-1) ]
+END
diff --git a/contrib/micromega/mfourier.ml b/contrib/micromega/mfourier.ml
new file mode 100644
index 00000000..415d3a3e
--- /dev/null
+++ b/contrib/micromega/mfourier.ml
@@ -0,0 +1,667 @@
+(************************************************************************)
+(* 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 *)
+(* *)
+(************************************************************************)
+
+(* Yet another implementation of Fourier *)
+open Num
+
+module Cmp =
+ (* How to compare pairs, lists ... *)
+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 xhash res l =
+ match l with
+ | [] -> res
+ | e::l -> xhash ((hash e) lxor res) l in
+ xhash (Hashtbl.hash []) l
+
+end
+
+module Interval =
+struct
+ (** The type of intervals. **)
+ type intrvl = Empty | Point of num | Itv of num option * num option
+
+ (**
+ Different intervals can denote the same set of variables e.g.,
+ Point n && Itv (Some n, Some n)
+ Itv (Some x) (Some y) && Empty if x > y
+ see the 'belongs_to' function.
+ **)
+
+ (* The set of numerics that belong to an interval *)
+ let belongs_to n = function
+ | Empty -> false
+ | Point x -> n =/ x
+ | Itv(Some x, Some y) -> x <=/ n && n <=/ y
+ | Itv(None,Some y) -> n <=/ y
+ | Itv(Some x,None) -> x <=/ n
+ | Itv(None,None) -> true
+
+ let string_of_bound = function
+ | None -> "oo"
+ | Some n -> Printf.sprintf "Bd(%s)" (string_of_num n)
+
+ let string_of_intrvl = function
+ | Empty -> "[]"
+ | Point n -> Printf.sprintf "[%s]" (string_of_num n)
+ | Itv(bd1,bd2) ->
+ Printf.sprintf "[%s,%s]" (string_of_bound bd1) (string_of_bound bd2)
+
+ let pick_closed_to_zero = function
+ | Empty -> None
+ | Point n -> Some n
+ | Itv(None,None) -> Some (Int 0)
+ | Itv(None,Some i) ->
+ Some (if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i)
+ | Itv(Some i,None) ->
+ Some (if i <=/ (Int 0) then Int 0 else ceiling_num i)
+ | Itv(Some i,Some j) ->
+ Some (
+ 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)
+
+ type status =
+ | O | Qonly | Z | Q
+
+ let interval_kind = function
+ | Empty -> O
+ | Point n -> if ceiling_num n =/ n then Z else Qonly
+ | Itv(None,None) -> Z
+ | Itv(None,Some i) -> if ceiling_num i <>/ i then Q else Z
+ | Itv(Some i,None) -> if ceiling_num i <>/ i then Q else Z
+ | Itv(Some i,Some j) ->
+ if ceiling_num i <>/ i or floor_num j <>/ j then Q else Z
+
+ let empty_z = function
+ | Empty -> true
+ | Point n -> ceiling_num n <>/ n
+ | Itv(None,None) | Itv(None,Some _) | Itv(Some _,None) -> false
+ | Itv(Some i,Some j) -> ceiling_num i >/ floor_num j
+
+
+ let normalise b1 b2 =
+ match b1 , b2 with
+ | Some i , Some j ->
+ (match compare_num i j with
+ | 1 -> Empty
+ | 0 -> Point i
+ | _ -> Itv(b1,b2)
+ )
+ | _ -> Itv(b1,b2)
+
+
+
+ let min x y =
+ match x , y with
+ | None , x | x , None -> x
+ | Some i , Some j -> Some (min_num i j)
+
+ let max x y =
+ match x , y with
+ | None , x | x , None -> x
+ | Some i , Some j -> Some (max_num i j)
+
+ let inter i1 i2 =
+ match i1,i2 with
+ | Empty , _ -> Empty
+ | _ , Empty -> Empty
+ | Point n , Point m -> if n =/ m then i1 else Empty
+ | Point n , Itv (mn,mx) | Itv (mn,mx) , Point n->
+ if (match mn with
+ | None -> true
+ | Some mn -> mn <=/ n) &&
+ (match mx with
+ | None -> true
+ | Some mx -> n <=/ mx) then Point n else Empty
+ | Itv (min1,max1) , Itv (min2,max2) ->
+ let bmin = max min1 min2
+ and bmax = min max1 max2 in
+ normalise bmin bmax
+
+ (* a.x >= b*)
+ let bound_of_constraint (a,b) =
+ match compare_num a (Int 0) with
+ | 0 ->
+ if compare_num b (Int 0) = 1
+ then Empty
+ (*actually this is a contradiction failwith "bound_of_constraint" *)
+ else Itv (None,None)
+ | 1 -> Itv (Some (div_num b a),None)
+ | -1 -> Itv (None, Some (div_num b a))
+ | x -> failwith "bound_of_constraint(2)"
+
+
+ let bounded x =
+ match x with
+ | Itv(None,_) | Itv(_,None) -> false
+ | _ -> true
+
+
+ let range = function
+ | Empty -> Some (Int 0)
+ | Point n -> Some (Int (if ceiling_num n =/ n then 1 else 0))
+ | Itv(None,_) | Itv(_,None)-> None
+ | Itv(Some i,Some j) -> Some (floor_num j -/ceiling_num i +/ (Int 1))
+
+ (* Returns the interval of smallest range *)
+ let smaller_itv i1 i2 =
+ match range i1 , range i2 with
+ | None , _ -> false
+ | _ , None -> true
+ | Some i , Some j -> i <=/ j
+
+end
+open Interval
+
+(* A set of constraints *)
+module Sys(V:Vector.S) (* : Vector.SystemS with module Vect = V*) =
+struct
+
+ module Vect = V
+
+ module Cstr = Vector.Cstr(V)
+ open Cstr
+
+
+ module CMap = Map.Make(
+ struct
+ type t = Vect.t
+ let compare = Vect.compare
+ end)
+
+ module CstrBag =
+ struct
+
+ type mut_itv = { mutable itv : intrvl}
+
+ type t = mut_itv CMap.t
+
+ exception Contradiction
+
+ let cstr_to_itv cstr =
+ let (n,l) = V.normalise cstr.coeffs in
+ if n =/ (Int 0)
+ then (Vect.null, bound_of_constraint (Int 0,cstr.cst)) (* Might be empty *)
+ else
+ match cstr.op with
+ | Eq -> let n = cstr.cst // n in (l, Point n)
+ | Ge ->
+ match compare_num n (Int 0) with
+ | 0 -> failwith "intrvl_of_constraint"
+ | 1 -> (l,Itv (Some (cstr.cst // n), None))
+ | -1 -> (l, Itv(None,Some (cstr.cst // n)))
+ | _ -> failwith "cstr_to_itv"
+
+
+ let empty = CMap.empty
+
+
+
+
+ let is_empty = CMap.is_empty
+
+ let find_vect v bag =
+ try
+ (bag,CMap.find v bag)
+ with Not_found -> let x = { itv = Itv(None,None)} in (CMap.add v x bag ,x)
+
+
+ let add (v,b) bag =
+ match b with
+ | Empty -> raise Contradiction
+ | Itv(None,None) -> bag
+ | _ ->
+ let (bag,intrl) = find_vect v bag in
+ match inter b intrl.itv with
+ | Empty -> raise Contradiction
+ | itv -> intrl.itv <- itv ; bag
+
+ exception Found of cstr
+
+ let find_equation bag =
+ try
+ CMap.fold (fun v i () ->
+ match i.itv with
+ | Point n -> let e = {coeffs = v ; op = Eq ; cst = n}
+ in raise (Found e)
+ | _ -> () ) bag () ; None
+ with Found c -> Some c
+
+
+ let fold f bag acc =
+ CMap.fold (fun v itv acc ->
+ match itv.itv with
+ | Empty | Itv(None,None) -> failwith "fold Empty"
+ | Itv(None ,Some i) ->
+ f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
+ | Point n -> f {coeffs = v ; op = Eq ; cst = n} acc
+ | Itv(x,y) ->
+ (match x with
+ | None -> (fun x -> x)
+ | Some i -> f {coeffs = v ; op = Ge ; cst = i})
+ (match y with
+ | None -> acc
+ | Some i ->
+ f {coeffs = V.mul (Int (-1)) v ; op = Ge ; cst = minus_num i} acc
+ ) ) bag acc
+
+
+ let remove l _ = failwith "remove:Not implemented"
+
+ module Map =
+ Map.Make(
+ struct
+ type t = int
+ let compare : int -> int -> int = Pervasives.compare
+ end)
+
+ let split f (t:t) =
+ let res =
+ fold (fun e m -> let i = f e in
+ Map.add i (add (cstr_to_itv e)
+ (try Map.find i m with
+ Not_found -> empty)) m) t Map.empty in
+ (fun i -> try Map.find i res with Not_found -> empty)
+
+ type map = (int list * int list) Map.t
+
+
+ let status (b:t) =
+ let _ , map = fold (fun c ( (idx:int),(res: map)) ->
+ ( idx + 1,
+ List.fold_left (fun (res:map) (pos,s) ->
+ let (lp,ln) = try Map.find pos res with Not_found -> ([],[]) in
+ match s with
+ | Vect.Pos -> Map.add pos (idx::lp,ln) res
+ | Vect.Neg ->
+ Map.add pos (lp, idx::ln) res) res
+ (Vect.status c.coeffs))) b (0,Map.empty) in
+ Map.fold (fun k e res -> (k,e)::res) map []
+
+
+ type it = num CMap.t
+
+ let iterator x = x
+
+ let element it = failwith "element:Not implemented"
+
+ end
+end
+
+module Fourier(Vect : Vector.S) =
+struct
+ module Vect = Vect
+ module Sys = Sys( Vect)
+ module Cstr = Sys.Cstr
+ module Bag = Sys.CstrBag
+
+ open Cstr
+ open Sys
+
+ let debug = false
+
+ let print_bag msg b =
+ print_endline msg;
+ CstrBag.fold (fun e () -> print_endline (Cstr.string_of_cstr e)) b ()
+
+ let print_bag_file file msg b =
+ let f = open_out file in
+ output_string f msg;
+ CstrBag.fold (fun e () ->
+ Printf.fprintf f "%s\n" (Cstr.string_of_cstr e)) b ()
+
+
+ (* A system with only inequations --
+ *)
+ let partition i m =
+ let splitter cstr = compare_num (Vect.get i cstr.coeffs ) (Int 0) in
+ let split = CstrBag.split splitter m in
+ (split (-1) , split 0, split 1)
+
+
+ (* op of the result is arbitrary Ge *)
+ let lin_comb n1 c1 n2 c2 =
+ { coeffs = Vect.lin_comb n1 c1.coeffs n2 c2.coeffs ;
+ op = Ge ;
+ cst = (n1 */ c1.cst) +/ (n2 */ c2.cst)}
+
+ (* BUG? : operator of the result ? *)
+
+ let combine_project i c1 c2 =
+ let p = Vect.get i c1.coeffs
+ and n = Vect.get i c2.coeffs in
+ assert (n </ Int 0 && p >/ Int 0) ;
+ let nopp = minus_num n in
+ let c =lin_comb nopp c1 p c2 in
+ let op = if c1.op = Ge || c2.op = Ge then Ge else Eq in
+ CstrBag.cstr_to_itv {coeffs = c.coeffs ; op = op ; cst= c.cst }
+
+
+ let project i m =
+ let (neg,zero,pos) = partition i m in
+ let project1 cpos acc =
+ CstrBag.fold (fun cneg res ->
+ CstrBag.add (combine_project i cpos cneg) res) neg acc in
+ (CstrBag.fold project1 pos zero)
+
+ (* Given a vector [x1 -> v1; ... ; xn -> vn]
+ and a constraint {x1 ; .... xn >= c }
+ *)
+ let evaluate_constraint i map cstr =
+ let {coeffs = _coeffs ; op = _op ; cst = _cst} = cstr in
+ let vi = Vect.get i _coeffs in
+ let v = Vect.set i (Int 0) _coeffs in
+ (vi, _cst -/ Vect.dotp map v)
+
+
+ let rec bounds m itv =
+ match m with
+ | [] -> itv
+ | e::m -> bounds m (inter itv (bound_of_constraint e))
+
+
+
+ let compare_status (i,(lp,ln)) (i',(lp',ln')) =
+ let cmp = Pervasives.compare
+ ((List.length lp) * (List.length ln))
+ ((List.length lp') * (List.length ln')) in
+ if cmp = 0
+ then Pervasives.compare i i'
+ else cmp
+
+ let cardinal m = CstrBag.fold (fun _ x -> x + 1) m 0
+
+ let lightest_projection l c m =
+ let bound = c in
+ if debug then (Printf.printf "l%i" bound; flush stdout) ;
+ let rec xlight best l =
+ match l with
+ | [] -> best
+ | i::l ->
+ let proj = (project i m) in
+ let cproj = cardinal proj in
+ (*Printf.printf " p %i " cproj; flush stdout;*)
+ match best with
+ | None ->
+ if cproj < bound
+ then Some(cproj,proj,i)
+ else xlight (Some(cproj,proj,i)) l
+ | Some (cbest,_,_) ->
+ if cproj < cbest
+ then
+ if cproj < bound then Some(cproj,proj,i)
+ else xlight (Some(cproj,proj,i)) l
+ else xlight best l in
+ match xlight None l with
+ | None -> None
+ | Some(_,p,i) -> Some (p,i)
+
+
+
+ exception Equality of cstr
+
+ let find_equality m = Bag.find_equation m
+
+
+
+ let pivot (n,v) eq ge =
+ assert (eq.op = Eq) ;
+ let res =
+ match
+ compare_num v (Int 0),
+ compare_num (Vect.get n ge.coeffs) (Int 0)
+ with
+ | 0 , _ -> failwith "Buggy"
+ | _ ,0 -> (CstrBag.cstr_to_itv ge)
+ | 1 , -1 -> combine_project n eq ge
+ | -1 , 1 -> combine_project n ge eq
+ | 1 , 1 ->
+ combine_project n ge
+ {coeffs = Vect.mul (Int (-1)) eq.coeffs;
+ op = eq.op ;
+ cst = minus_num eq.cst}
+ | -1 , -1 ->
+ combine_project n
+ {coeffs = Vect.mul (Int (-1)) eq.coeffs;
+ op = eq.op ; cst = minus_num eq.cst} ge
+ | _ -> failwith "pivot" in
+ res
+
+ let check_cstr v c =
+ let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
+ let vl = Vect.dotp v _coeffs in
+ match _op with
+ | Eq -> vl =/ _cst
+ | Ge -> vl >= _cst
+
+
+ let forall p sys =
+ try
+ CstrBag.fold (fun c () -> if p c then () else raise Not_found) sys (); true
+ with Not_found -> false
+
+
+ let check_sys v sys = forall (check_cstr v) sys
+
+ let check_null_cstr c =
+ let {coeffs = _coeffs ; op = _op ; cst = _cst} = c in
+ match _op with
+ | Eq -> (Int 0) =/ _cst
+ | Ge -> (Int 0) >= _cst
+
+ let check_null sys = forall check_null_cstr sys
+
+
+ let optimise_ge
+ quick_check choose choose_idx return_empty return_ge return_eq m =
+ let c = cardinal m in
+ let bound = 2 * c in
+ if debug then (Printf.printf "optimise_ge: %i\n" c; flush stdout);
+
+ let rec xoptimise m =
+ if debug then (Printf.printf "x%i" (cardinal m) ; flush stdout);
+ if debug then (print_bag "xoptimise" m ; flush stdout);
+ if quick_check m
+ then return_empty m
+ else
+ match find_equality m with
+ | None -> xoptimise_ge m
+ | Some eq -> xoptimise_eq eq m
+
+ and xoptimise_ge m =
+ begin
+ let c = cardinal m in
+ let l = List.map fst (List.sort compare_status (CstrBag.status m)) in
+ let idx = choose bound l c m in
+ match idx with
+ | None -> return_empty m
+ | Some (proj,i) ->
+ match xoptimise proj with
+ | None -> None
+ | Some mapping -> return_ge m i mapping
+ end
+ and xoptimise_eq eq m =
+ let l = List.map fst (Vect.status eq.coeffs) in
+ match choose_idx l with
+ | None -> (*if l = [] then None else*) return_empty m
+ | Some i ->
+ let p = (i,Vect.get i eq.coeffs) in
+ let m' = CstrBag.fold
+ (fun ge res -> CstrBag.add (pivot p eq ge) res) m CstrBag.empty in
+ match xoptimise ( m') with
+ | None -> None
+ | Some mapp -> return_eq m eq i mapp in
+ try
+ let res = xoptimise m in res
+ with CstrBag.Contradiction -> (*print_string "contradiction" ;*) None
+
+
+
+ let minimise m =
+ let opt_zero_choose bound l c m =
+ if c > bound
+ then lightest_projection l c m
+ else match l with
+ | [] -> None
+ | i::_ -> Some (project i m, i) in
+
+ let choose_idx = function [] -> None | x::l -> Some x in
+
+ let opt_zero_return_empty m = Some Vect.null in
+
+
+ let opt_zero_return_ge m i mapping =
+ let (it:intrvl) = CstrBag.fold (fun cstr itv -> Interval.inter
+ (bound_of_constraint (evaluate_constraint i mapping cstr)) itv) m
+ (Itv (None, None)) in
+ match pick_closed_to_zero it with
+ | None -> print_endline "Cannot pick" ; None
+ | Some v ->
+ let res = (Vect.set i v mapping) in
+ if debug
+ then Printf.printf "xoptimise res %i [%s]" i (Vect.string res) ;
+ Some res in
+
+ let opt_zero_return_eq m eq i mapp =
+ let (a,b) = evaluate_constraint i mapp eq in
+ Some (Vect.set i (div_num b a) mapp) in
+
+ optimise_ge check_null opt_zero_choose
+ choose_idx opt_zero_return_empty opt_zero_return_ge opt_zero_return_eq m
+
+ let normalise cstr = [CstrBag.cstr_to_itv cstr]
+
+ let find_point l =
+ (* List.iter (fun e -> print_endline (Cstr.string_of_cstr e)) l;*)
+ try
+ let m = List.fold_left (fun sys e -> CstrBag.add (CstrBag.cstr_to_itv e) sys)
+ CstrBag.empty l in
+ match minimise m with
+ | None -> None
+ | Some res ->
+ if debug then Printf.printf "[%s]" (Vect.string res);
+ Some res
+ with CstrBag.Contradiction -> None
+
+
+ let find_q_interval_for x m =
+ if debug then Printf.printf "find_q_interval_for %i\n" x ;
+
+ let choose bound l c m =
+ let rec xchoose l =
+ match l with
+ | [] -> None
+ | i::l -> if i = x then xchoose l else Some (project i m,i) in
+ xchoose l in
+
+ let rec choose_idx = function
+ [] -> None
+ | e::l -> if e = x then choose_idx l else Some e in
+
+ let return_empty m = (* Beurk *)
+ (* returns the interval of x *)
+ Some (CstrBag.fold (fun cstr itv ->
+ let i = if cstr.op = Eq
+ then Point (cstr.cst // Vect.get x cstr.coeffs)
+ else if Vect.is_null (Vect.set x (Int 0) cstr.coeffs)
+ then bound_of_constraint (Vect.get x cstr.coeffs , cstr.cst)
+ else itv
+ in
+ Interval.inter i itv) m (Itv (None, None))) in
+
+ let return_ge m i res = Some res in
+
+ let return_eq m eq i res = Some res in
+
+ try
+ optimise_ge
+ (fun x -> false) choose choose_idx return_empty return_ge return_eq m
+ with CstrBag.Contradiction -> None
+
+
+ let find_q_intervals sys =
+ let variables =
+ List.map fst (List.sort compare_status (CstrBag.status sys)) in
+ List.map (fun x -> (x,find_q_interval_for x sys)) variables
+
+ let pp_option f o = function
+ None -> Printf.fprintf o "None"
+ | Some x -> Printf.fprintf o "Some %a" f x
+
+ let optimise vect sys =
+ (* we have to modify the system with a dummy variable *)
+ let fresh =
+ List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 sys in
+ assert (List.for_all (fun x -> Vect.get fresh x.coeffs =/ Int 0) sys);
+ let cstr = {
+ coeffs = Vect.set fresh (Int (-1)) vect ;
+ op = Eq ;
+ cst = (Int 0)} in
+ try
+ find_q_interval_for fresh
+ (List.fold_left
+ (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg)
+ CstrBag.empty (cstr::sys))
+ with CstrBag.Contradiction -> None
+
+
+ let optimise vect sys =
+ let res = optimise vect sys in
+ if debug
+ then Printf.printf "optimise %s -> %a\n"
+ (Vect.string vect) (pp_option (fun o x -> Printf.printf "%s" (string_of_intrvl x))) res
+ ; res
+
+ let find_Q_interval sys =
+ try
+ let sys =
+ (List.fold_left
+ (fun bg c -> CstrBag.add (CstrBag.cstr_to_itv c) bg) CstrBag.empty sys) in
+ let candidates =
+ List.fold_left
+ (fun l (x,i) -> match i with
+ None -> (x,Empty)::l
+ | Some i -> (x,i)::l) [] (find_q_intervals sys) in
+ match List.fold_left
+ (fun (x1,i1) (x2,i2) ->
+ if smaller_itv i1 i2
+ then (x1,i1) else (x2,i2)) (-1,Itv(None,None)) candidates
+ with
+ | (i,Empty) -> None
+ | (x,Itv(Some i, Some j)) -> Some(i,x,j)
+ | (x,Point n) -> Some(n,x,n)
+ | _ -> None
+ with CstrBag.Contradiction -> None
+
+
+end
+
diff --git a/contrib/micromega/micromega.ml b/contrib/micromega/micromega.ml
new file mode 100644
index 00000000..e151e4e1
--- /dev/null
+++ b/contrib/micromega/micromega.ml
@@ -0,0 +1,1512 @@
+type __ = Obj.t
+let __ = let rec f _ = Obj.repr f in Obj.repr f
+
+type bool =
+ | True
+ | False
+
+(** val negb : bool -> bool **)
+
+let negb = function
+ | True -> False
+ | False -> True
+
+type nat =
+ | O
+ | S of nat
+
+type 'a option =
+ | Some of 'a
+ | None
+
+type ('a, 'b) prod =
+ | Pair of 'a * 'b
+
+type comparison =
+ | Eq
+ | Lt
+ | Gt
+
+(** val compOpp : comparison -> comparison **)
+
+let compOpp = function
+ | Eq -> Eq
+ | Lt -> Gt
+ | Gt -> Lt
+
+type sumbool =
+ | Left
+ | Right
+
+type 'a sumor =
+ | Inleft of 'a
+ | Inright
+
+type 'a list =
+ | Nil
+ | Cons of 'a * 'a list
+
+(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
+
+let rec app l m =
+ match l with
+ | Nil -> m
+ | Cons (a, l1) -> Cons (a, (app l1 m))
+
+(** val nth : nat -> 'a1 list -> 'a1 -> 'a1 **)
+
+let rec nth n0 l default =
+ match n0 with
+ | O -> (match l with
+ | Nil -> default
+ | Cons (x, l') -> x)
+ | S m ->
+ (match l with
+ | Nil -> default
+ | Cons (x, t0) -> nth m t0 default)
+
+(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
+
+let rec map f = function
+ | Nil -> Nil
+ | Cons (a, t0) -> Cons ((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)
+
+type n =
+ | N0
+ | Npos of positive
+
+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 dcompare_inf : comparison -> sumbool sumor **)
+
+let dcompare_inf = function
+ | Eq -> Inleft Left
+ | Lt -> Inleft Right
+ | Gt -> Inright
+
+(** val zcompare_rec :
+ z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
+
+let zcompare_rec x y h1 h2 h3 =
+ match dcompare_inf (zcompare x y) with
+ | Inleft x0 -> (match x0 with
+ | Left -> h1 __
+ | Right -> h2 __)
+ | Inright -> h3 __
+
+(** val z_gt_dec : z -> z -> sumbool **)
+
+let z_gt_dec x y =
+ zcompare_rec x y (fun _ -> Right) (fun _ -> Right) (fun _ -> Left)
+
+(** 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) prod **)
+
+let rec zdiv_eucl_POS a b =
+ match a with
+ | XI a' ->
+ let Pair (q0, r) = zdiv_eucl_POS a' b in
+ let r' = zplus (zmult (Zpos (XO XH)) r) (Zpos XH) in
+ (match zgt_bool b r' with
+ | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
+ | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
+ (zminus r' b)))
+ | XO a' ->
+ let Pair (q0, r) = zdiv_eucl_POS a' b in
+ let r' = zmult (Zpos (XO XH)) r in
+ (match zgt_bool b r' with
+ | True -> Pair ((zmult (Zpos (XO XH)) q0), r')
+ | False -> Pair ((zplus (zmult (Zpos (XO XH)) q0) (Zpos XH)),
+ (zminus r' b)))
+ | XH ->
+ (match zge_bool b (Zpos (XO XH)) with
+ | True -> Pair (Z0, (Zpos XH))
+ | False -> Pair ((Zpos XH), Z0))
+
+(** val zdiv_eucl : z -> z -> (z, z) prod **)
+
+let zdiv_eucl a b =
+ match a with
+ | Z0 -> Pair (Z0, Z0)
+ | Zpos a' ->
+ (match b with
+ | Z0 -> Pair (Z0, Z0)
+ | Zpos p -> zdiv_eucl_POS a' b
+ | Zneg b' ->
+ let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
+ (match r with
+ | Z0 -> Pair ((zopp q0), Z0)
+ | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zplus b r))))
+ | Zneg a' ->
+ (match b with
+ | Z0 -> Pair (Z0, Z0)
+ | Zpos p ->
+ let Pair (q0, r) = zdiv_eucl_POS a' b in
+ (match r with
+ | Z0 -> Pair ((zopp q0), Z0)
+ | _ -> Pair ((zopp (zplus q0 (Zpos XH))), (zminus b r)))
+ | Zneg b' ->
+ let Pair (q0, r) = zdiv_eucl_POS a' (Zpos b') in
+ Pair (q0, (zopp r)))
+
+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 ->
+ (match peq ceqb p2 p'0 with
+ | True -> peq ceqb q0 q'
+ | False -> 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 ->
+ (match ceqb c cO with
+ | True ->
+ (match q0 with
+ | Pc c0 -> q0
+ | Pinj (j', q1) -> Pinj ((pplus XH j'), q1)
+ | PX (p2, p3, p4) -> Pinj (XH, q0))
+ | False -> PX (p, i, q0))
+ | Pinj (p2, p3) -> PX (p, i, q0)
+ | PX (p', i', q') ->
+ (match peq ceqb q' (p0 cO) with
+ | True -> PX (p', (pplus i' i), q0)
+ | False -> 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 =
+ match ceqb c cO with
+ | True -> p0 cO
+ | False ->
+ (match ceqb c cI with
+ | True -> p
+ | False -> 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')))
+
+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 =
+ Nil
+
+(** val ff : 'a1 cnf **)
+
+let ff =
+ Cons (Nil, Nil)
+
+(** 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
+ | Nil -> tt
+ | Cons (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 -> (match pol0 with
+ | True -> tt
+ | False -> ff)
+ | FF -> (match pol0 with
+ | True -> ff
+ | False -> tt)
+ | X -> ff
+ | A x -> (match pol0 with
+ | True -> normalise0 x
+ | False -> negate0 x)
+ | Cj (e1, e2) ->
+ (match pol0 with
+ | True ->
+ and_cnf (xcnf normalise0 negate0 pol0 e1)
+ (xcnf normalise0 negate0 pol0 e2)
+ | False ->
+ or_cnf (xcnf normalise0 negate0 pol0 e1)
+ (xcnf normalise0 negate0 pol0 e2))
+ | D (e1, e2) ->
+ (match pol0 with
+ | True ->
+ or_cnf (xcnf normalise0 negate0 pol0 e1)
+ (xcnf normalise0 negate0 pol0 e2)
+ | False ->
+ and_cnf (xcnf normalise0 negate0 pol0 e1)
+ (xcnf normalise0 negate0 pol0 e2))
+ | N e -> xcnf normalise0 negate0 (negb pol0) e
+ | I (e1, e2) ->
+ (match pol0 with
+ | True ->
+ or_cnf (xcnf normalise0 negate0 (negb pol0) e1)
+ (xcnf normalise0 negate0 pol0 e2)
+ | False ->
+ 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
+ | Nil -> True
+ | Cons (e, f0) ->
+ (match l with
+ | Nil -> False
+ | Cons (c, l0) ->
+ (match checker e c with
+ | True -> cnf_checker checker f0 l0
+ | False -> 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 pExprC = 'c pExpr
+
+type 'c polC = 'c pol
+
+type op1 =
+ | Equal
+ | NonEqual
+ | Strict
+ | NonStrict
+
+type 'c nFormula = ('c pExprC, op1) prod
+
+type monoidMember = nat list
+
+type 'c coneMember =
+ | S_In of nat
+ | S_Ideal of 'c pExprC * 'c coneMember
+ | S_Square of 'c pExprC
+ | S_Monoid of monoidMember
+ | S_Mult of 'c coneMember * 'c coneMember
+ | S_Add of 'c coneMember * 'c coneMember
+ | S_Pos of 'c
+ | S_Z
+
+(** val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
+
+let nformula_times f f' =
+ let Pair (p, op) = f in
+ let Pair (p', op') = f' in
+ Pair ((PEmul (p, p')),
+ (match op with
+ | Equal -> Equal
+ | NonEqual -> NonEqual
+ | Strict -> op'
+ | NonStrict -> NonStrict))
+
+(** val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula **)
+
+let nformula_plus f f' =
+ let Pair (p, op) = f in
+ let Pair (p', op') = f' in
+ Pair ((PEadd (p, p')),
+ (match op with
+ | Equal -> op'
+ | NonEqual -> NonEqual
+ | Strict -> Strict
+ | NonStrict -> (match op' with
+ | Strict -> Strict
+ | _ -> NonStrict)))
+
+(** val eval_monoid :
+ 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC **)
+
+let rec eval_monoid cI l = function
+ | Nil -> PEc cI
+ | Cons (n0, ns0) -> PEmul
+ ((let Pair (q0, o) = nth n0 l (Pair ((PEc cI), NonEqual)) in
+ (match o with
+ | NonEqual -> q0
+ | _ -> PEc cI)), (eval_monoid cI l ns0))
+
+(** val eval_cone :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
+ nFormula list -> 'a1 coneMember -> 'a1 nFormula **)
+
+let rec eval_cone cO cI ceqb cleb l = function
+ | S_In n0 ->
+ let Pair (p, o) = nth n0 l (Pair ((PEc cO), Equal)) in
+ (match o with
+ | NonEqual -> Pair ((PEc cO), Equal)
+ | _ -> nth n0 l (Pair ((PEc cO), Equal)))
+ | S_Ideal (p, cm') ->
+ let f = eval_cone cO cI ceqb cleb l cm' in
+ let Pair (q0, op) = f in
+ (match op with
+ | Equal -> Pair ((PEmul (q0, p)), Equal)
+ | _ -> f)
+ | S_Square p -> Pair ((PEmul (p, p)), NonStrict)
+ | S_Monoid m -> let p = eval_monoid cI l m in Pair ((PEmul (p, p)), Strict)
+ | S_Mult (p, q0) ->
+ nformula_times (eval_cone cO cI ceqb cleb l p)
+ (eval_cone cO cI ceqb cleb l q0)
+ | S_Add (p, q0) ->
+ nformula_plus (eval_cone cO cI ceqb cleb l p)
+ (eval_cone cO cI ceqb cleb l q0)
+ | S_Pos c ->
+ (match match cleb cO c with
+ | True -> negb (ceqb cO c)
+ | False -> False with
+ | True -> Pair ((PEc c), Strict)
+ | False -> Pair ((PEc cO), Equal))
+ | S_Z -> Pair ((PEc cO), Equal)
+
+(** val normalise_pexpr :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC **)
+
+let normalise_pexpr cO cI cplus ctimes cminus copp ceqb x =
+ norm_aux cO cI cplus ctimes cminus copp ceqb x
+
+(** val check_inconsistent :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
+ -> 'a1 nFormula -> bool **)
+
+let check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb = function
+ | Pair (e, op) ->
+ (match normalise_pexpr cO cI cplus ctimes cminus copp ceqb e with
+ | Pc c ->
+ (match op with
+ | Equal -> negb (ceqb c cO)
+ | NonEqual -> False
+ | Strict -> cleb c cO
+ | NonStrict ->
+ (match cleb c cO with
+ | True -> negb (ceqb c cO)
+ | False -> False))
+ | _ -> False)
+
+(** val check_normalised_formulas :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool)
+ -> 'a1 nFormula list -> 'a1 coneMember -> bool **)
+
+let check_normalised_formulas cO cI cplus ctimes cminus copp ceqb cleb l cm =
+ check_inconsistent cO cI cplus ctimes cminus copp ceqb cleb
+ (eval_cone cO cI ceqb cleb l cm)
+
+type op2 =
+ | OpEq
+ | OpNEq
+ | OpLe
+ | OpGe
+ | OpLt
+ | OpGt
+
+type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
+
+(** val flhs : 'a1 formula -> 'a1 pExprC **)
+
+let flhs x = x.flhs
+
+(** val fop : 'a1 formula -> op2 **)
+
+let fop x = x.fop
+
+(** val frhs : 'a1 formula -> 'a1 pExprC **)
+
+let frhs x = x.frhs
+
+(** val xnormalise : 'a1 formula -> 'a1 nFormula list **)
+
+let xnormalise t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+ (match o with
+ | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
+ ((PEsub (rhs, lhs)), Strict)), Nil)))
+ | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+ | OpLe -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil)
+ | OpGe -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
+ | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+ | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
+
+(** val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf **)
+
+let cnf_normalise t0 =
+ map (fun x -> Cons (x, Nil)) (xnormalise t0)
+
+(** val xnegate : 'a1 formula -> 'a1 nFormula list **)
+
+let xnegate t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+ (match o with
+ | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+ | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), (Cons ((Pair
+ ((PEsub (rhs, lhs)), Strict)), Nil)))
+ | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
+ | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+ | OpLt -> Cons ((Pair ((PEsub (rhs, lhs)), Strict)), Nil)
+ | OpGt -> Cons ((Pair ((PEsub (lhs, rhs)), Strict)), Nil))
+
+(** val cnf_negate : 'a1 formula -> 'a1 nFormula cnf **)
+
+let cnf_negate t0 =
+ map (fun x -> Cons (x, Nil)) (xnegate t0)
+
+(** val simpl_expr :
+ 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC **)
+
+let rec simpl_expr cI ceqb e = match e with
+ | PEadd (x, y) -> PEadd ((simpl_expr cI ceqb x), (simpl_expr cI ceqb y))
+ | PEmul (y, z0) ->
+ let y' = simpl_expr cI ceqb y in
+ (match y' with
+ | PEc c ->
+ (match ceqb c cI with
+ | True -> simpl_expr cI ceqb z0
+ | False -> PEmul (y', (simpl_expr cI ceqb z0)))
+ | _ -> PEmul (y', (simpl_expr cI ceqb z0)))
+ | _ -> e
+
+(** val simpl_cone :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1
+ coneMember -> 'a1 coneMember **)
+
+let simpl_cone cO cI ctimes ceqb e = match e with
+ | S_Square t0 ->
+ (match simpl_expr cI ceqb t0 with
+ | PEc c ->
+ (match ceqb cO c with
+ | True -> S_Z
+ | False -> S_Pos (ctimes c c))
+ | _ -> S_Square (simpl_expr cI ceqb t0))
+ | S_Mult (t1, t2) ->
+ (match t1 with
+ | S_Mult (x, x0) ->
+ (match x with
+ | S_Pos p2 ->
+ (match t2 with
+ | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x0)
+ | S_Z -> S_Z
+ | _ -> e)
+ | _ ->
+ (match x0 with
+ | S_Pos p2 ->
+ (match t2 with
+ | S_Pos c -> S_Mult ((S_Pos (ctimes c p2)), x)
+ | S_Z -> S_Z
+ | _ -> e)
+ | _ ->
+ (match t2 with
+ | S_Pos c ->
+ (match ceqb cI c with
+ | True -> t1
+ | False -> S_Mult (t1, t2))
+ | S_Z -> S_Z
+ | _ -> e)))
+ | S_Pos c ->
+ (match t2 with
+ | S_Mult (x, x0) ->
+ (match x with
+ | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x0)
+ | _ ->
+ (match x0 with
+ | S_Pos p2 -> S_Mult ((S_Pos (ctimes c p2)), x)
+ | _ ->
+ (match ceqb cI c with
+ | True -> t2
+ | False -> S_Mult (t1, t2))))
+ | S_Add (y, z0) -> S_Add ((S_Mult ((S_Pos c), y)), (S_Mult
+ ((S_Pos c), z0)))
+ | S_Pos c0 -> S_Pos (ctimes c c0)
+ | S_Z -> S_Z
+ | _ ->
+ (match ceqb cI c with
+ | True -> t2
+ | False -> S_Mult (t1, t2)))
+ | S_Z -> S_Z
+ | _ ->
+ (match t2 with
+ | S_Pos c ->
+ (match ceqb cI c with
+ | True -> t1
+ | False -> S_Mult (t1, t2))
+ | S_Z -> S_Z
+ | _ -> e))
+ | S_Add (t1, t2) ->
+ (match t1 with
+ | S_Z -> t2
+ | _ -> (match t2 with
+ | S_Z -> t1
+ | _ -> S_Add (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 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)
+
+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 coneMember
+
+(** val zWeakChecker : z nFormula list -> z coneMember -> bool **)
+
+let zWeakChecker x x0 =
+ check_normalised_formulas Z0 (Zpos XH) zplus zmult zminus zopp zeq_bool
+ zle_bool x x0
+
+(** val xnormalise0 : z formula -> z nFormula list **)
+
+let xnormalise0 t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+ (match o with
+ | OpEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+ NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
+ XH)))))), NonStrict)), Nil)))
+ | OpNEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+ | OpLe -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+ NonStrict)), Nil)
+ | OpGe -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
+ NonStrict)), Nil)
+ | OpLt -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+ | OpGt -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil))
+
+(** val normalise : z formula -> z nFormula cnf **)
+
+let normalise t0 =
+ map (fun x -> Cons (x, Nil)) (xnormalise0 t0)
+
+(** val xnegate0 : z formula -> z nFormula list **)
+
+let xnegate0 t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
+ (match o with
+ | OpEq -> Cons ((Pair ((PEsub (lhs, rhs)), Equal)), Nil)
+ | OpNEq -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+ NonStrict)), (Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos
+ XH)))))), NonStrict)), Nil)))
+ | OpLe -> Cons ((Pair ((PEsub (rhs, lhs)), NonStrict)), Nil)
+ | OpGe -> Cons ((Pair ((PEsub (lhs, rhs)), NonStrict)), Nil)
+ | OpLt -> Cons ((Pair ((PEsub (rhs, (PEadd (lhs, (PEc (Zpos XH)))))),
+ NonStrict)), Nil)
+ | OpGt -> Cons ((Pair ((PEsub (lhs, (PEadd (rhs, (PEc (Zpos XH)))))),
+ NonStrict)), Nil))
+
+(** val negate : z formula -> z nFormula cnf **)
+
+let negate t0 =
+ map (fun x -> Cons (x, Nil)) (xnegate0 t0)
+
+(** val ceiling : z -> z -> z **)
+
+let ceiling a b =
+ let Pair (q0, r) = zdiv_eucl a b in
+ (match r with
+ | Z0 -> q0
+ | _ -> zplus q0 (Zpos XH))
+
+type proofTerm =
+ | RatProof of zWitness
+ | CutProof of z pExprC * q * zWitness * proofTerm
+ | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
+
+(** val makeLb : z pExpr -> q -> z nFormula **)
+
+let makeLb v q0 =
+ let { qnum = n0; qden = d } = q0 in
+ Pair ((PEsub ((PEmul ((PEc (Zpos d)), v)), (PEc n0))), NonStrict)
+
+(** val qceiling : q -> z **)
+
+let qceiling q0 =
+ let { qnum = n0; qden = d } = q0 in ceiling n0 (Zpos d)
+
+(** val makeLbCut : z pExprC -> q -> z nFormula **)
+
+let makeLbCut v q0 =
+ Pair ((PEsub (v, (PEc (qceiling q0)))), NonStrict)
+
+(** val neg_nformula : z nFormula -> (z pExpr, op1) prod **)
+
+let neg_nformula = function
+ | Pair (e, o) -> Pair ((PEopp (PEadd (e, (PEc (Zpos XH))))), o)
+
+(** val cutChecker :
+ z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option **)
+
+let cutChecker l e lb pf =
+ match zWeakChecker (Cons ((neg_nformula (makeLb e lb)), l)) pf with
+ | True -> Some (makeLbCut e lb)
+ | False -> None
+
+(** val zChecker : z nFormula list -> proofTerm -> bool **)
+
+let rec zChecker l = function
+ | RatProof pf0 -> zWeakChecker l pf0
+ | CutProof (e, q0, pf0, rst) ->
+ (match cutChecker l e q0 pf0 with
+ | Some c -> zChecker (Cons (c, l)) rst
+ | None -> False)
+ | EnumProof (lb, e, ub, pf1, pf2, rst) ->
+ (match cutChecker l e lb pf1 with
+ | Some n0 ->
+ (match cutChecker l (PEopp e) (qopp ub) pf2 with
+ | Some n1 ->
+ let rec label pfs lb0 ub0 =
+ match pfs with
+ | Nil ->
+ (match z_gt_dec lb0 ub0 with
+ | Left -> True
+ | Right -> False)
+ | Cons (pf0, rsr) ->
+ (match zChecker (Cons ((Pair ((PEsub (e, (PEc
+ lb0))), Equal)), l)) pf0 with
+ | True -> label rsr (zplus lb0 (Zpos XH)) ub0
+ | False -> False)
+ in label rst (qceiling lb) (zopp (qceiling (qopp ub)))
+ | None -> False)
+ | None -> False)
+
+(** val zTautoChecker : z formula bFormula -> proofTerm list -> bool **)
+
+let zTautoChecker f w =
+ tauto_checker normalise negate zChecker f w
+
+(** val map_cone : (nat -> nat) -> zWitness -> zWitness **)
+
+let rec map_cone f e = match e with
+ | S_In n0 -> S_In (f n0)
+ | S_Ideal (e0, cm) -> S_Ideal (e0, (map_cone f cm))
+ | S_Monoid l -> S_Monoid (map f l)
+ | S_Mult (cm1, cm2) -> S_Mult ((map_cone f cm1), (map_cone f cm2))
+ | S_Add (cm1, cm2) -> S_Add ((map_cone f cm1), (map_cone f cm2))
+ | _ -> e
+
+(** val indexes : zWitness -> nat list **)
+
+let rec indexes = function
+ | S_In n0 -> Cons (n0, Nil)
+ | S_Ideal (e0, cm) -> indexes cm
+ | S_Monoid l -> l
+ | S_Mult (cm1, cm2) -> app (indexes cm1) (indexes cm2)
+ | S_Add (cm1, cm2) -> app (indexes cm1) (indexes cm2)
+ | _ -> Nil
+
+(** val n_of_Z : z -> n **)
+
+let n_of_Z = function
+ | Zpos p -> Npos p
+ | _ -> N0
+
+(** val qeq_bool : q -> q -> bool **)
+
+let qeq_bool p q0 =
+ zeq_bool (zmult p.qnum (Zpos q0.qden)) (zmult q0.qnum (Zpos p.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))
+
+type qWitness = q coneMember
+
+(** val qWeakChecker : q nFormula list -> q coneMember -> bool **)
+
+let qWeakChecker x x0 =
+ check_normalised_formulas { qnum = Z0; qden = XH } { qnum = (Zpos XH);
+ qden = XH } qplus qmult qminus qopp qeq_bool qle_bool x x0
+
+(** val qTautoChecker : q formula bFormula -> qWitness list -> bool **)
+
+let qTautoChecker f w =
+ tauto_checker (fun x -> cnf_normalise x) (fun x ->
+ cnf_negate x) qWeakChecker f w
+
diff --git a/contrib/micromega/micromega.mli b/contrib/micromega/micromega.mli
new file mode 100644
index 00000000..f94f091e
--- /dev/null
+++ b/contrib/micromega/micromega.mli
@@ -0,0 +1,398 @@
+type __ = Obj.t
+
+type bool =
+ | True
+ | False
+
+val negb : bool -> bool
+
+type nat =
+ | O
+ | S of nat
+
+type 'a option =
+ | Some of 'a
+ | None
+
+type ('a, 'b) prod =
+ | Pair of 'a * 'b
+
+type comparison =
+ | Eq
+ | Lt
+ | Gt
+
+val compOpp : comparison -> comparison
+
+type sumbool =
+ | Left
+ | Right
+
+type 'a sumor =
+ | Inleft of 'a
+ | Inright
+
+type 'a list =
+ | Nil
+ | Cons of 'a * 'a list
+
+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
+
+type n =
+ | N0
+ | Npos of positive
+
+type z =
+ | Z0
+ | Zpos of positive
+ | Zneg of positive
+
+val zdouble_plus_one : z -> z
+
+val zdouble_minus_one : z -> z
+
+val zdouble : z -> z
+
+val zPminus : positive -> positive -> z
+
+val zplus : z -> z -> z
+
+val zopp : z -> z
+
+val zminus : z -> z -> z
+
+val zmult : z -> z -> z
+
+val zcompare : z -> z -> comparison
+
+val dcompare_inf : comparison -> sumbool sumor
+
+val zcompare_rec : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
+
+val z_gt_dec : z -> z -> sumbool
+
+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) prod
+
+val zdiv_eucl : z -> z -> (z, z) prod
+
+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
+
+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 pExprC = 'c pExpr
+
+type 'c polC = 'c pol
+
+type op1 =
+ | Equal
+ | NonEqual
+ | Strict
+ | NonStrict
+
+type 'c nFormula = ('c pExprC, op1) prod
+
+type monoidMember = nat list
+
+type 'c coneMember =
+ | S_In of nat
+ | S_Ideal of 'c pExprC * 'c coneMember
+ | S_Square of 'c pExprC
+ | S_Monoid of monoidMember
+ | S_Mult of 'c coneMember * 'c coneMember
+ | S_Add of 'c coneMember * 'c coneMember
+ | S_Pos of 'c
+ | S_Z
+
+val nformula_times : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
+
+val nformula_plus : 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula
+
+val eval_monoid : 'a1 -> 'a1 nFormula list -> monoidMember -> 'a1 pExprC
+
+val eval_cone :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula
+ list -> 'a1 coneMember -> 'a1 nFormula
+
+val normalise_pexpr :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 polC
+
+val check_inconsistent :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
+ nFormula -> bool
+
+val check_normalised_formulas :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
+ 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1
+ nFormula list -> 'a1 coneMember -> bool
+
+type op2 =
+ | OpEq
+ | OpNEq
+ | OpLe
+ | OpGe
+ | OpLt
+ | OpGt
+
+type 'c formula = { flhs : 'c pExprC; fop : op2; frhs : 'c pExprC }
+
+val flhs : 'a1 formula -> 'a1 pExprC
+
+val fop : 'a1 formula -> op2
+
+val frhs : 'a1 formula -> 'a1 pExprC
+
+val xnormalise : 'a1 formula -> 'a1 nFormula list
+
+val cnf_normalise : 'a1 formula -> 'a1 nFormula cnf
+
+val xnegate : 'a1 formula -> 'a1 nFormula list
+
+val cnf_negate : 'a1 formula -> 'a1 nFormula cnf
+
+val simpl_expr : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pExprC -> 'a1 pExprC
+
+val simpl_cone :
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 coneMember
+ -> 'a1 coneMember
+
+type q = { qnum : z; qden : positive }
+
+val qnum : q -> z
+
+val qden : q -> positive
+
+val qplus : q -> q -> q
+
+val qmult : q -> q -> q
+
+val qopp : q -> q
+
+val qminus : q -> q -> q
+
+type 'a t =
+ | Empty
+ | Leaf of 'a
+ | Node of 'a t * 'a * 'a t
+
+val find : 'a1 -> 'a1 t -> positive -> 'a1
+
+type zWitness = z coneMember
+
+val zWeakChecker : z nFormula list -> z coneMember -> bool
+
+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 proofTerm =
+ | RatProof of zWitness
+ | CutProof of z pExprC * q * zWitness * proofTerm
+ | EnumProof of q * z pExprC * q * zWitness * zWitness * proofTerm list
+
+val makeLb : z pExpr -> q -> z nFormula
+
+val qceiling : q -> z
+
+val makeLbCut : z pExprC -> q -> z nFormula
+
+val neg_nformula : z nFormula -> (z pExpr, op1) prod
+
+val cutChecker :
+ z nFormula list -> z pExpr -> q -> zWitness -> z nFormula option
+
+val zChecker : z nFormula list -> proofTerm -> bool
+
+val zTautoChecker : z formula bFormula -> proofTerm list -> bool
+
+val map_cone : (nat -> nat) -> zWitness -> zWitness
+
+val indexes : zWitness -> nat list
+
+val n_of_Z : z -> n
+
+val qeq_bool : q -> q -> bool
+
+val qle_bool : q -> q -> bool
+
+type qWitness = q coneMember
+
+val qWeakChecker : q nFormula list -> q coneMember -> bool
+
+val qTautoChecker : q formula bFormula -> qWitness list -> bool
+
diff --git a/contrib/micromega/mutils.ml b/contrib/micromega/mutils.ml
new file mode 100644
index 00000000..2473608f
--- /dev/null
+++ b/contrib/micromega/mutils.ml
@@ -0,0 +1,305 @@
+(************************************************************************)
+(* 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 fst' (Micromega.Pair(x,y)) = x
+let snd' (Micromega.Pair(x,y)) = y
+
+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 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 rec list elt l =
+ match l with
+ | Nil -> []
+ | Cons(e,l) -> (elt e)::(list elt l)
+
+ 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)}
+
+
+ let list elt l = List.fold_right (fun x l -> Cons(elt x, l)) l Nil
+
+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
diff --git a/contrib/micromega/sos.ml b/contrib/micromega/sos.ml
new file mode 100644
index 00000000..e3d72ed9
--- /dev/null
+++ b/contrib/micromega/sos.ml
@@ -0,0 +1,1919 @@
+(* ========================================================================= *)
+(* - This code originates from John Harrison's HOL LIGHT 2.20 *)
+(* (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 *)
+(* - Addition of a csdp cache by the Coq development team *)
+(* ========================================================================= *)
+
+(* ========================================================================= *)
+(* Nonlinear universal reals procedure using SOS decomposition. *)
+(* ========================================================================= *)
+
+open Num;;
+open List;;
+
+let debugging = ref false;;
+
+exception Sanity;;
+
+exception Unsolvable;;
+
+(* ------------------------------------------------------------------------- *)
+(* 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);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* term?? *)
+(* ------------------------------------------------------------------------- *)
+
+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);;
+
+
+(* ------------------------------------------------------------------------- *)
+(* 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;;
+
+
+
+(* ------------------------------------------------------------------------- *)
+(* 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);;
+
+(* ------------------------------------------------------------------------- *)
+(* 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_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. *)
+(* ------------------------------------------------------------------------- *)
+
+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 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,[]) -> h | (h,[x]) -> h +/ x | _ -> failwith "decimalsig") 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,[]) -> h | (h,[x]) -> h */ power_num (Int 10) x | _ ->
+ failwith "exponent");;
+
+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_csdpoutput =
+ let rec skipupto dscr prs inp =
+ (dscr ++ prs >> snd
+ || some (fun c -> true) ++ skipupto dscr prs >> snd) inp in
+ let ignore inp = (),[] in
+ let csdpoutput =
+ (decimal ++ many(a " " ++ decimal >> snd) >> (fun (h,t) -> h::t)) ++
+ (a " " ++ a "\n" ++ ignore) >> ((o) vector_of_list fst) in
+ mkparser csdpoutput;;
+
+(* ------------------------------------------------------------------------- *)
+(* 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;;
+
+(* ------------------------------------------------------------------------- *)
+(* The same thing with CSDP. *)
+(* Modified by the Coq development team to use a cache *)
+(* ------------------------------------------------------------------------- *)
+
+let buffer_add_line buff line =
+ Buffer.add_string buff line; Buffer.add_char buff '\n'
+
+let string_of_file filename =
+ let fd = open_in filename in
+ let buff = Buffer.create 16 in
+ try while true do buffer_add_line buff (input_line fd) done; failwith ""
+ with End_of_file -> (close_in fd; Buffer.contents buff)
+
+let file_of_string filename s =
+ let fd = Pervasives.open_out filename in
+ output_string fd s; close_out fd
+
+let request_mark = "*** REQUEST ***"
+let answer_mark = "*** ANSWER ***"
+let end_mark = "*** END ***"
+let infeasible_mark = "Infeasible\n"
+let failure_mark = "Failure\n"
+
+let cache_name = "csdp.cache"
+
+let look_in_cache string_problem =
+ let n = String.length string_problem in
+ try
+ let inch = open_in cache_name in
+ let rec search () =
+ while input_line inch <> request_mark do () done;
+ let i = ref 0 in
+ while !i < n & string_problem.[!i] = input_char inch do incr i done;
+ if !i < n or input_line inch <> answer_mark then
+ search ()
+ else begin
+ let buff = Buffer.create 16 in
+ let line = ref (input_line inch) in
+ while (!line <> end_mark) do
+ buffer_add_line buff !line; line := input_line inch
+ done;
+ close_in inch;
+ Buffer.contents buff
+ end in
+ try search () with End_of_file -> close_in inch; raise Not_found
+ with Sys_error _ -> raise Not_found
+
+let flush_to_cache string_problem string_result =
+ try
+ let flags = [Open_append;Open_text;Open_creat] in
+ let outch = open_out_gen flags 0o666 cache_name in
+ begin
+ try
+ Printf.fprintf outch "%s\n" request_mark;
+ Printf.fprintf outch "%s" string_problem;
+ Printf.fprintf outch "%s\n" answer_mark;
+ Printf.fprintf outch "%s" string_result;
+ Printf.fprintf outch "%s\n" end_mark;
+ with Sys_error _ as e -> close_out outch; raise e
+ end;
+ close_out outch
+ with Sys_error _ ->
+ print_endline "Warning: Could not open or write to csdp cache"
+
+exception CsdpInfeasible
+
+let run_csdp dbg string_problem =
+ try
+ let res = look_in_cache string_problem in
+ if res = infeasible_mark then raise CsdpInfeasible;
+ if res = failure_mark then failwith "csdp error";
+ res
+ with Not_found ->
+ let input_file = Filename.temp_file "sos" ".dat-s" in
+ let output_file = Filename.temp_file "sos" ".dat-s" in
+ let temp_path = Filename.dirname input_file in
+ let params_file = Filename.concat temp_path "param.csdp" in
+ file_of_string input_file string_problem;
+ 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
+ if rv = 1 or rv = 2 then
+ (flush_to_cache string_problem infeasible_mark; raise CsdpInfeasible);
+ if rv = 127 then
+ (print_string "csdp not found, exiting..."; exit 1);
+ if rv <> 0 & rv <> 3 (* reduced accuracy *) then
+ (flush_to_cache string_problem failure_mark;
+ failwith("csdp: error "^string_of_int rv));
+ let string_result = string_of_file output_file in
+ flush_to_cache string_problem string_result;
+ if not dbg then
+ (Sys.remove input_file; Sys.remove output_file; Sys.remove params_file);
+ string_result
+
+let csdp obj mats =
+ try parse_csdpoutput (run_csdp !debugging (sdpa_of_problem "" obj mats))
+ with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
+
+(* ------------------------------------------------------------------------- *)
+(* 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
+ try ignore (run_csdp false (sdpa_of_problem "" obj mats)); true
+ with CsdpInfeasible -> false
+
+(* ------------------------------------------------------------------------- *)
+(* 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 (m::ms) -> if in_convex_hull ms m then ms else ms@[m]
+ | _ -> failwith "augment1"
+ 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 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 (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 x = epoly_cmul (Int(-1)) x;;
+
+let epoly_add x = combine equation_add is_undefined x;;
+
+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 csdp_blocks nblocks blocksizes obj mats =
+ let string_problem = sdpa_of_blockproblem "" nblocks blocksizes obj mats in
+ try parse_csdpoutput (run_csdp !debugging string_problem)
+ with CsdpInfeasible -> failwith "csdp: Problem is infeasible"
+
+(* ------------------------------------------------------------------------- *)
+(* 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
+ (*let d = foldl (fun a (i,j) c -> max a (max i j)) 0 m 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
+ : poly list * (positivstellensatz * (num * poly) list) list =
+
+ 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_blocks 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;;
+
+
+let term_of_monoid l1 m = itlist (fun i m -> Mul (nth l1 i,m)) m (Const num_1)
+
+let rec term_of_pos l1 x = match x with
+ Axiom_eq i -> failwith "term_of_pos"
+ | Axiom_le i -> nth l1 i
+ | Axiom_lt i -> nth l1 i
+ | Monoid m -> term_of_monoid l1 m
+ | Rational_eq n -> Const n
+ | Rational_le n -> Const n
+ | Rational_lt n -> Const n
+ | Square t -> Pow (t, 2)
+ | Eqmul (t, y) -> Mul (t, term_of_pos l1 y)
+ | Sum (y, z) -> Add (term_of_pos l1 y, term_of_pos l1 z)
+ | Product (y, z) -> Mul (term_of_pos l1 y, term_of_pos l1 z);;
+
+
+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 term. *)
+(* ------------------------------------------------------------------------- *)
+
+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));;
+
+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
+
+
+(* patch to remove zero polynomials from equalities.
+ In this case, hol light loops *)
+
+let real_nonlinear_prover depthmax eqs les lts =
+ let eq = map poly_of_term eqs
+ and le = map poly_of_term les
+ and lt = map poly_of_term lts in
+ let pol = itlist poly_mul lt (poly_const num_1)
+ and lep = map (fun (t,i) -> t,Axiom_le i) (zip le (0--(length le - 1)))
+ and ltp = map (fun (t,i) -> t,Axiom_lt i) (zip lt (0--(length lt - 1)))
+ and eqp = itlist2 (fun t i res ->
+ if t = undefined then res else (t,Axiom_eq i)::res) eq (0--(length eq - 1)) []
+ in
+
+ let proof =
+ let leq = lep @ ltp in
+ let eq = List.map fst eqp in
+ let tryall d =
+ let e = multidegree pol (*and pol' = poly_neg pol*) in
+ let k = if e = 0 then 1 else d / e 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_until depthmax tryall 0 in
+ let proofs_ideal =
+ map2 (fun q i -> Eqmul(term_of_poly q,i))
+ cert_ideal (List.map snd eqp)
+ and proofs_cone = map term_of_sos cert_cone
+ and proof_ne =
+ if lt = [] 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
+ end_itlist (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in
+ if !debugging then (print_string("Translating proof certificate to Coq"); print_newline());
+ proof;;
+
+
+(* ------------------------------------------------------------------------- *)
+(* Now pure SOS stuff. *)
+(* ------------------------------------------------------------------------- *)
+
+(* ------------------------------------------------------------------------- *)
+(* 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;;
+
+(* ------------------------------------------------------------------------- *)
+(* 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 lpps2 = allpairs monomial_mul lpps lpps in*)
+(* let lpp2_classes =
+ setify(map (fun m ->
+ setify(map (fun vars' -> changevariables_monomial (zip vars vars') m)
+ invariants)) lpps2) 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: poly -> Num.num * (( Num.num * poly) list)) =
+sumofsquares_general_symmetry csdp;;
diff --git a/contrib/micromega/sos.mli b/contrib/micromega/sos.mli
new file mode 100644
index 00000000..31c9518c
--- /dev/null
+++ b/contrib/micromega/sos.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 *)
+(************************************************************************)
+
+
+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)
+
+type positivstellensatz =
+ Axiom_eq of int
+ | Axiom_le of int
+ | Axiom_lt of int
+ | Rational_eq of Num.num
+ | Rational_le of Num.num
+ | Rational_lt of Num.num
+ | Square of term
+ | Monoid of int list
+ | Eqmul of term * positivstellensatz
+ | Sum of positivstellensatz * positivstellensatz
+ | Product of positivstellensatz * positivstellensatz
+
+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
+
+exception TooDeep
+
+val deepen_until : int -> (int -> 'a) -> int -> 'a
+
+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/contrib/micromega/vector.ml b/contrib/micromega/vector.ml
new file mode 100644
index 00000000..fee4ebfc
--- /dev/null
+++ b/contrib/micromega/vector.ml
@@ -0,0 +1,674 @@
+(************************************************************************)
+(* 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 Num
+
+module type S =
+sig
+ type t
+
+ val fresh : t -> int
+
+ val null : t
+
+ val is_null : t -> bool
+
+ val get : int -> t -> num
+
+ val update : int -> (num -> num) -> t -> t
+ (* behaviour is undef if index < 0 -- might loop*)
+
+ val set : int -> num -> t -> t
+
+ (*
+ For efficiency...
+
+ val get_update : int -> (num -> num) -> t -> num * t
+ *)
+
+ val mul : num -> t -> t
+
+ val uminus : t -> t
+
+ val add : t -> t -> t
+
+ val dotp : t -> t -> num
+
+ val lin_comb : num -> t -> num -> t -> t
+ (* lin_comb n1 t1 n2 t2 = (n1 * t1) + (n2 * t2) *)
+
+ val gcd : t -> Big_int.big_int
+
+ val normalise : t -> num * t
+
+ val hash : t -> int
+
+ val compare : t -> t -> int
+
+ type it
+
+ val iterator : t -> it
+ val element : it -> (num*it) option
+
+ val string : t -> string
+
+ type status = Pos | Neg
+
+ (* the result list is ordered by fst *)
+ val status : t -> (int * status) list
+
+ val from_list : num list -> t
+ val to_list : t -> num list
+
+end
+
+
+module type SystemS =
+sig
+
+ module Vect : S
+
+ module Cstr :
+ sig
+ type kind = Eq | Ge
+ val string_of_kind : kind -> string
+ type cstr = {coeffs : Vect.t ; op : kind ; cst : num}
+ val string_of_cstr : cstr -> string
+ val compare : cstr -> cstr -> int
+ end
+ open Cstr
+
+
+ module CstrBag :
+ sig
+ type t
+ exception Contradiction
+
+ val empty : t
+
+ val is_empty : t -> bool
+
+ val add : cstr -> t -> t
+ (* c can be deduced from add c t *)
+
+ val find : (cstr -> bool) -> t -> cstr option
+
+ val fold : (cstr -> 'a -> 'a) -> t -> 'a -> 'a
+
+ val status : t -> (int * (int list * int list)) list
+ (* aggregate of vector statuses *)
+
+ val remove : cstr -> t -> t
+
+ (* remove_list the ith element -- it is the ith element visited by 'fold' *)
+
+ val split : (cstr -> int) -> t -> (int -> t)
+
+ type it
+ val iterator : t -> it
+ val element : it -> (cstr*it) option
+
+ end
+
+end
+
+let zero_num = Int 0
+let unit_num = Int 1
+
+
+
+
+module Cstr(V:S) =
+struct
+ type kind = Eq | Ge
+ let string_of_kind = function Eq -> "Eq" | Ge -> "Ge"
+
+ type cstr = {coeffs : V.t ; op : kind ; cst : num}
+
+ let string_of_cstr {coeffs =a ; op = b ; cst =c} =
+ Printf.sprintf "{coeffs = %s;op=%s;cst=%s}" (V.string a) (string_of_kind b) (string_of_num c)
+
+ type t = cstr
+ let compare
+ {coeffs = v1 ; op = op1 ; cst = c1}
+ {coeffs = v2 ; op = op2 ; cst = c2} =
+ Mutils.Cmp.compare_lexical [
+ (fun () -> V.compare v1 v2);
+ (fun () -> Pervasives.compare op1 op2);
+ (fun () -> compare_num c1 c2)
+ ]
+
+
+end
+
+
+
+module VList : S with type t = num list =
+struct
+ type t = num list
+
+ let fresh l = failwith "not implemented"
+
+ let null = []
+
+ let is_null = List.for_all ((=/) zero_num)
+
+ let normalise l = failwith "Not implemented"
+ (*match l with (* Buggy : What if the first num is zero! *)
+ | [] -> (Int 0,[])
+ | [n] -> (n,[Int 1])
+ | n::l -> (n, (Int 1) :: List.map (fun x -> x // n) l)
+ *)
+
+
+ let get i l = try List.nth l i with _ -> zero_num
+
+ (* This is not tail-recursive *)
+ let rec update i f t =
+ match t with
+ | [] -> if i = 0 then [f zero_num] else (zero_num)::(update (i-1) f [])
+ | e::t -> if i = 0 then (f e)::t else e::(update (i-1) f t)
+
+ let rec set i n t =
+ match t with
+ | [] -> if i = 0 then [n] else (zero_num)::(set (i-1) n [])
+ | e::t -> if i = 0 then (n)::t else e::(set (i-1) n t)
+
+
+
+
+ let rec mul z t =
+ match z with
+ | Int 0 -> null
+ | Int 1 -> t
+ | _ -> List.map (mult_num z) t
+
+ let uminus t = mul (Int (-1)) t
+
+ let rec add t1 t2 =
+ match t1,t2 with
+ | [], _ -> t2
+ | _ , [] -> t1
+ | e1::t1,e2::t2 -> (e1 +/ e2 )::(add t1 t2)
+
+ let dotp t1 t2 =
+ let rec _dotp t1 t2 acc =
+ match t1, t2 with
+ | [] , _ -> acc
+ | _ , [] -> acc
+ | e1::t1,e2::t2 -> _dotp t1 t2 (acc +/ (e1 */ e2)) in
+ _dotp t1 t2 zero_num
+
+ let add_mul n t1 t2 =
+ match n with
+ | Int 0 -> t2
+ | Int 1 -> add t1 t2
+ | _ ->
+ let rec _add_mul t1 t2 =
+ match t1,t2 with
+ | [], _ -> t2
+ | _ , [] -> mul n t1
+ | e1::t1,e2::t2 -> ( (n */e1) +/ e2 )::(_add_mul t1 t2) in
+ _add_mul t1 t2
+
+ let lin_comb n1 t1 n2 t2 =
+ match n1,n2 with
+ | Int 0 , _ -> mul n2 t2
+ | Int 1 , _ -> add_mul n2 t2 t1
+ | _ , Int 0 -> mul n1 t1
+ | _ , Int 1 -> add_mul n1 t1 t2
+ | _ ->
+ let rec _lin_comb t1 t2 =
+ match t1,t2 with
+ | [], _ -> mul n2 t2
+ | _ , [] -> mul n1 t1
+ | e1::t1,e2::t2 -> ( (n1 */e1) +/ (n2 */ e2 ))::(_lin_comb t1 t2) in
+ _lin_comb t1 t2
+
+ (* could be computed on the fly *)
+ let gcd t =Mutils.gcd_list t
+
+
+
+
+ let hash = Mutils.Cmp.hash_list int_of_num
+
+ let compare = Mutils.Cmp.compare_list compare_num
+
+ type it = t
+ let iterator (x:t) : it = x
+ let element it =
+ match it with
+ | [] -> None
+ | e::l -> Some (e,l)
+
+ (* TODO: Buffer! *)
+ let string l = List.fold_right (fun n s -> (string_of_num n)^";"^s) l ""
+
+ type status = Pos | Neg
+
+ let status l =
+ let rec xstatus i l =
+ match l with
+ | [] -> []
+ | e::l ->
+ begin
+ match compare_num e (Int 0) with
+ | 1 -> (i,Pos):: (xstatus (i+1) l)
+ | 0 -> xstatus (i+1) l
+ | -1 -> (i,Neg) :: (xstatus (i+1) l)
+ | _ -> assert false
+ end in
+ xstatus 0 l
+
+ let from_list l = l
+ let to_list l = l
+
+end
+
+module VMap : S =
+struct
+ module Map = Map.Make(struct type t = int let compare (x:int) (y:int) = Pervasives.compare x y end)
+
+ type t = num Map.t
+
+ let null = Map.empty
+
+ let fresh m = failwith "not implemented"
+
+ let is_null = Map.is_empty
+
+ let normalise m = failwith "Not implemented"
+
+
+
+ let get i l = try Map.find i l with _ -> zero_num
+
+ let update i f t =
+ try
+ let res = f (Map.find i t) in
+ if res =/ zero_num
+ then Map.remove i t
+ else Map.add i res t
+ with
+ Not_found ->
+ let res = f zero_num in
+ if res =/ zero_num then t else Map.add i res t
+
+ let set i n t =
+ if n =/ zero_num then Map.remove i t
+ else Map.add i n t
+
+
+ let rec mul z t =
+ match z with
+ | Int 0 -> null
+ | Int 1 -> t
+ | _ -> Map.map (mult_num z) t
+
+ let uminus t = mul (Int (-1)) t
+
+
+ let map2 f m1 m2 =
+ let res,m2' =
+ Map.fold (fun k e (res,m2) ->
+ let v = f e (get k m2) in
+ if v =/ zero_num
+ then (res,Map.remove k m2)
+ else (Map.add k v res,Map.remove k m2)) m1 (Map.empty,m2) in
+ Map.fold (fun k e res ->
+ let v = f zero_num e in
+ if v =/ zero_num
+ then res else Map.add k v res) m2' res
+
+ let add t1 t2 = map2 (+/) t1 t2
+
+
+ let dotp t1 t2 =
+ Map.fold (fun k e res ->
+ res +/ (e */ get k t2)) t1 zero_num
+
+
+
+ let add_mul n t1 t2 =
+ match n with
+ | Int 0 -> t2
+ | Int 1 -> add t1 t2
+ | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2
+
+ let lin_comb n1 t1 n2 t2 =
+ match n1,n2 with
+ | Int 0 , _ -> mul n2 t2
+ | Int 1 , _ -> add_mul n2 t2 t1
+ | _ , Int 0 -> mul n1 t1
+ | _ , Int 1 -> add_mul n1 t1 t2
+ | _ -> map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2
+
+
+ let hash map = Map.fold (fun k e res -> k lxor (int_of_num e) lxor res) map 0
+
+ let compare = Map.compare compare_num
+
+ type it = t * int
+
+ let iterator (x:t) : it = (x,0)
+
+ let element (mp,id) =
+ try
+ Some (Map.find id mp, (mp, id+1))
+ with
+ Not_found -> None
+
+ (* TODO: Buffer! *)
+ type status = Pos | Neg
+
+ let status l = Map.fold (fun k e l ->
+ match compare_num e (Int 0) with
+ | 1 -> (k,Pos)::l
+ | 0 -> l
+ | -1 -> (k,Neg) :: l
+ | _ -> assert false) l []
+ let from_list l =
+ let rec from_list i l map =
+ match l with
+ | [] -> map
+ | e::l -> from_list (i+1) l (if e <>/ Int 0 then Map.add i e map else map) in
+ from_list 0 l Map.empty
+
+ let gcd m =
+ let res = Map.fold (fun _ e x -> Big_int.gcd_big_int x (Mutils.numerator e)) m Big_int.zero_big_int in
+ if Big_int.compare_big_int res Big_int.zero_big_int = 0
+ then Big_int.unit_big_int else res
+
+
+ let to_list m =
+ let l = List.rev (Map.fold (fun k e l -> (k,e)::l) m []) in
+ 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 l
+
+ let string l = VList.string (to_list l)
+
+
+end
+
+
+module VSparse : S =
+struct
+
+ type t = (int*num) list
+
+ let null = []
+
+ let fresh l = List.fold_left (fun acc (i,_) -> max (i+1) acc) 0 l
+
+ let is_null l = l = []
+
+ let rec is_sorted l =
+ match l with
+ | [] -> true
+ | [e] -> true
+ | (i,_)::(j,x)::l -> i < j && is_sorted ((j,x)::l)
+
+
+ let check l = (List.for_all (fun (_,n) -> compare_num n (Int 0) <> 0) l) && (is_sorted l)
+
+ (* let get i t =
+ assert (check t);
+ try List.assoc i t with Not_found -> zero_num *)
+
+ let rec get (i:int) t =
+ match t with
+ | [] -> zero_num
+ | (j,n)::t ->
+ match compare i j with
+ | 0 -> n
+ | 1 -> get i t
+ | _ -> zero_num
+
+ 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 update i f t =
+ assert (check t);
+ let res = update i f t in
+ assert (check t) ; res
+
+
+ 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 rec map f l =
+ match l with
+ | [] -> []
+ | (i,e)::l -> cons i (f e) (map f l)
+
+ let rec mul z t =
+ match z with
+ | Int 0 -> null
+ | Int 1 -> t
+ | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t
+
+ let mul z t =
+ assert (check t) ;
+ let res = mul z t in
+ assert (check res) ;
+ res
+
+ let uminus t = mul (Int (-1)) t
+
+
+ let normalise l =
+ match l with
+ | [] -> (Int 0,[])
+ | (i,n)::_ -> (n, mul ((Int 1) // n) l)
+
+
+ let rec map2 f m1 m2 =
+ match m1, m2 with
+ | [] , [] -> []
+ | l , [] -> map (fun x -> f x zero_num) l
+ | [] ,l -> map (f zero_num) l
+ | (i,e)::l1,(i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> cons i (f e e') (map2 f l1 l2)
+ | -1 -> cons i (f e zero_num) (map2 f l1 m2)
+ | 1 -> cons i' (f zero_num e') (map2 f m1 l2)
+ | _ -> assert false
+
+ (* let add t1 t2 = map2 (+/) t1 t2*)
+
+ let rec add (m1:t) (m2:t) =
+ match m1, m2 with
+ | [] , [] -> []
+ | l , [] -> l
+ | [] ,l -> l
+ | (i,e)::l1,(i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> cons i ( e +/ e') (add l1 l2)
+ | -1 -> (i,e) :: (add l1 m2)
+ | 1 -> (i', e') :: (add m1 l2)
+ | _ -> assert false
+
+
+
+
+ let add t1 t2 =
+ assert (check t1 && check t2);
+ let res = add t1 t2 in
+ assert (check res);
+ res
+
+
+ let rec dotp (t1:t) (t2:t) =
+ match t1, t2 with
+ | [] , _ -> zero_num
+ | _ , [] -> zero_num
+ | (i,e)::l1 , (i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> (e */ e') +/ (dotp l1 l2)
+ | -1 -> dotp l1 t2
+ | 1 -> dotp t1 l2
+ | _ -> assert false
+
+ let dotp t1 t2 =
+ assert (check t1 && check t2) ; dotp t1 t2
+
+ let add_mul n t1 t2 =
+ match n with
+ | Int 0 -> t2
+ | Int 1 -> add t1 t2
+ | _ -> map2 (fun x y -> (n */ x) +/ y) t1 t2
+
+ let add_mul n (t1:t) (t2:t) =
+ match n with
+ | Int 0 -> t2
+ | Int 1 -> add t1 t2
+ | _ ->
+ let rec xadd_mul m1 m2 =
+ match m1, m2 with
+ | [] , [] -> []
+ | _ , [] -> mul n m1
+ | [] , _ -> m2
+ | (i,e)::l1,(i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> cons i ( n */ e +/ e') (xadd_mul l1 l2)
+ | -1 -> (i,n */ e) :: (xadd_mul l1 m2)
+ | 1 -> (i', e') :: (xadd_mul m1 l2)
+ | _ -> assert false in
+ xadd_mul t1 t2
+
+
+
+
+ let lin_comb n1 t1 n2 t2 =
+ match n1,n2 with
+ | Int 0 , _ -> mul n2 t2
+ | Int 1 , _ -> add_mul n2 t2 t1
+ | _ , Int 0 -> mul n1 t1
+ | _ , Int 1 -> add_mul n1 t1 t2
+ | _ -> (*map2 (fun x y -> (n1 */ x) +/ (n2 */ y)) t1 t2*)
+ let rec xlin_comb m1 m2 =
+ match m1, m2 with
+ | [] , [] -> []
+ | _ , [] -> mul n1 m1
+ | [] , _ -> mul n2 m2
+ | (i,e)::l1,(i',e')::l2 ->
+ match Pervasives.compare i i' with
+ | 0 -> cons i ( n1 */ e +/ n2 */ e') (xlin_comb l1 l2)
+ | -1 -> (i,n1 */ e) :: (xlin_comb l1 m2)
+ | 1 -> (i', n2 */ e') :: (xlin_comb m1 l2)
+ | _ -> assert false in
+ xlin_comb t1 t2
+
+
+
+
+
+ let lin_comb n1 t1 n2 t2 =
+ assert (check t1 && check t2);
+ let res = lin_comb n1 t1 n2 t2 in
+ assert (check res); res
+
+ let hash = Mutils.Cmp.hash_list (fun (x,y) -> (Hashtbl.hash x) lxor (int_of_num y))
+
+
+ let compare = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical
+ [
+ (fun () -> Pervasives.compare (fst x) (fst y));
+ (fun () -> compare_num (snd x) (snd y))])
+
+ (*
+ let compare (x:t) (y:t) =
+ let rec xcompare acc1 acc2 x y =
+ match x , y with
+ | [] , [] -> xcomp acc1 acc2
+ | [] , _ -> -1
+ | _ , [] -> 1
+ | (i,n1)::l1 , (j,n2)::l2 ->
+ match Pervasives.compare i j with
+ | 0 -> xcompare (n1::acc1) (n2::acc2) l1 l2
+ | c -> c
+ and xcomp acc1 acc2 = Mutils.Cmp.compare_list compare_num acc1 acc2 in
+ xcompare [] [] x y
+ *)
+
+ type it = t
+
+ let iterator (x:t) : it = x
+
+ let element l = failwith "Not_implemented"
+
+ (* TODO: Buffer! *)
+ type status = Pos | Neg
+
+ let status l = List.map (fun (i,e) ->
+ match compare_num e (Int 0) with
+ | 1 -> i,Pos
+ | -1 -> i,Neg
+ | _ -> assert false) l
+
+ 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
+
+ let res = xfrom_list 0 l in
+ assert (check res) ; res
+
+
+ let gcd m =
+ let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Mutils.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 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 to_list l =
+ assert (check l);
+ to_list l
+
+
+ let string l = VList.string (to_list l)
+
+end
diff --git a/contrib/omega/Omega.v b/contrib/omega/Omega.v
index 66f86a49..ee823502 100644
--- a/contrib/omega/Omega.v
+++ b/contrib/omega/Omega.v
@@ -9,15 +9,16 @@
(* *)
(* Omega: a solver of quantifier-free problems in Presburger Arithmetic *)
(* *)
-(* Pierre Crégut (CNET, Lannion, France) *)
+(* Pierre Crégut (CNET, Lannion, France) *)
(* *)
(**************************************************************************)
-(* $Id: Omega.v 8642 2006-03-17 10:09:02Z notin $ *)
+(* $Id: Omega.v 10028 2007-07-18 22:38:06Z letouzey $ *)
(* We do not require [ZArith] anymore, but only what's necessary for Omega *)
Require Export ZArith_base.
Require Export OmegaLemmas.
+Require Export PreOmega.
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
diff --git a/contrib/omega/PreOmega.v b/contrib/omega/PreOmega.v
new file mode 100644
index 00000000..47e22a97
--- /dev/null
+++ b/contrib/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/contrib/omega/coq_omega.ml b/contrib/omega/coq_omega.ml
index be9ea5ae..84092812 100644
--- a/contrib/omega/coq_omega.ml
+++ b/contrib/omega/coq_omega.ml
@@ -13,7 +13,7 @@
(* *)
(**************************************************************************)
-(* $Id: coq_omega.ml 9963 2007-07-09 14:02:20Z letouzey $ *)
+(* $Id: coq_omega.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
open Util
open Pp
@@ -128,12 +128,12 @@ let intern_id,unintern_id =
let mk_then = tclTHENLIST
-let exists_tac c = constructor_tac (Some 1) 1 (Rawterm.ImplicitBindings [c])
+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 [[], Lazy.force s]
+let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s]
let rev_assoc k =
let rec loop = function
@@ -180,8 +180,6 @@ 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_INFEEIEUR = lazy (constant "Lt")
-let coq_Eq = lazy (constant "Eq")
let coq_Zplus = lazy (constant "Zplus")
let coq_Zmult = lazy (constant "Zmult")
let coq_Zopp = lazy (constant "Zopp")
@@ -1227,7 +1225,7 @@ let replay_history tactic_normalisation =
(clear [aux]);
(intros_using [id]);
(loop l) ];
- tclTHEN (exists_tac eq1) reflexivity ]
+ tclTHEN (exists_tac (inj_open eq1)) reflexivity ]
| SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l ->
let id1 = new_identifier ()
and id2 = new_identifier () in
diff --git a/contrib/omega/g_omega.ml4 b/contrib/omega/g_omega.ml4
index 01592ebe..02545b30 100644
--- a/contrib/omega/g_omega.ml4
+++ b/contrib/omega/g_omega.ml4
@@ -15,10 +15,33 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(* $Id: g_omega.ml4 7734 2005-12-26 14:06:51Z herbelin $ *)
+(* $Id: g_omega.ml4 10028 2007-07-18 22:38:06Z letouzey $ *)
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_solver ]
+| [ "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/contrib/ring/LegacyRing.v b/contrib/ring/LegacyRing.v
index dc8635bd..40323b3d 100644
--- a/contrib/ring/LegacyRing.v
+++ b/contrib/ring/LegacyRing.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Ring.v 5920 2004-07-16 20:01:26Z herbelin $ *)
+(* $Id: LegacyRing.v 10739 2008-04-01 14:45:20Z herbelin $ *)
Require Export Bool.
Require Export LegacyRing_theory.
diff --git a/contrib/ring/LegacyRing_theory.v b/contrib/ring/LegacyRing_theory.v
index 5df927a6..d15d18a6 100644
--- a/contrib/ring/LegacyRing_theory.v
+++ b/contrib/ring/LegacyRing_theory.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: LegacyRing_theory.v 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id: LegacyRing_theory.v 9370 2006-11-13 09:21:31Z herbelin $ *)
Require Export Bool.
@@ -153,7 +153,7 @@ 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_sym : forall n m:A, n * m = m * n;
+ 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;
@@ -165,7 +165,7 @@ Variable T : Ring_Theory.
Let plus_comm := Th_plus_comm T.
Let plus_assoc := Th_plus_assoc T.
-Let mult_comm := Th_mult_sym 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.
diff --git a/contrib/ring/Ring_abstract.v b/contrib/ring/Ring_abstract.v
index 115ed5ca..c2467ebf 100644
--- a/contrib/ring/Ring_abstract.v
+++ b/contrib/ring/Ring_abstract.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Ring_abstract.v 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id: Ring_abstract.v 9370 2006-11-13 09:21:31Z herbelin $ *)
Require Import LegacyRing_theory.
Require Import Quote.
@@ -428,7 +428,7 @@ Fixpoint interp_ap (p:apolynomial) : A :=
Hint Resolve (Th_plus_comm T).
Hint Resolve (Th_plus_assoc T).
Hint Resolve (Th_plus_assoc2 T).
-Hint Resolve (Th_mult_sym 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).
diff --git a/contrib/ring/Ring_normalize.v b/contrib/ring/Ring_normalize.v
index 4a082396..e8d9f1ee 100644
--- a/contrib/ring/Ring_normalize.v
+++ b/contrib/ring/Ring_normalize.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Ring_normalize.v 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id: Ring_normalize.v 10913 2008-05-09 14:40:04Z herbelin $ *)
Require Import LegacyRing_theory.
Require Import Quote.
@@ -774,7 +774,7 @@ 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_sym 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).
@@ -897,6 +897,6 @@ End rings.
Infix "+" := Pplus : ring_scope.
Infix "*" := Pmult : ring_scope.
Notation "- x" := (Popp x) : ring_scope.
-Notation "[ x ]" := (Pvar x) (at level 1) : ring_scope.
+Notation "[ x ]" := (Pvar x) (at level 0) : ring_scope.
Delimit Scope ring_scope with ring.
diff --git a/contrib/ring/Setoid_ring_normalize.v b/contrib/ring/Setoid_ring_normalize.v
index 56329ade..8eb49a37 100644
--- a/contrib/ring/Setoid_ring_normalize.v
+++ b/contrib/ring/Setoid_ring_normalize.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Setoid_ring_normalize.v 6662 2005-02-02 21:33:14Z sacerdot $ *)
+(* $Id: Setoid_ring_normalize.v 9370 2006-11-13 09:21:31Z herbelin $ *)
Require Import Setoid_ring_theory.
Require Import Quote.
@@ -1032,7 +1032,7 @@ 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_sym 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).
diff --git a/contrib/ring/Setoid_ring_theory.v b/contrib/ring/Setoid_ring_theory.v
index ae6610d3..88abd7de 100644
--- a/contrib/ring/Setoid_ring_theory.v
+++ b/contrib/ring/Setoid_ring_theory.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Setoid_ring_theory.v 6662 2005-02-02 21:33:14Z sacerdot $ *)
+(* $Id: Setoid_ring_theory.v 10631 2008-03-06 18:17:24Z msozeau $ *)
Require Export Bool.
Require Export Setoid.
@@ -177,7 +177,7 @@ 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_sym : forall n m:A, n * m == m * n;
+ 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;
@@ -189,7 +189,7 @@ Variable T : Setoid_Ring_Theory.
Let plus_comm := STh_plus_comm T.
Let plus_assoc := STh_plus_assoc T.
-Let mult_comm := STh_mult_sym 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.
@@ -245,7 +245,7 @@ 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)); auto.
+setoid_replace (a + 0) with (a + (a + - a)) by auto.
rewrite (plus_assoc a a (- a)).
rewrite H.
apply opp_def.
diff --git a/contrib/ring/quote.ml b/contrib/ring/quote.ml
index e0a6cba3..7cd22a36 100644
--- a/contrib/ring/quote.ml
+++ b/contrib/ring/quote.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: quote.ml 9178 2006-09-26 11:18:22Z barras $ *)
+(* $Id: quote.ml 10790 2008-04-14 22:34:19Z herbelin $ *)
(* The `Quote' tactic *)
@@ -191,8 +191,11 @@ let decomp_term c = kind_of_term (strip_outer_cast c)
?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive
type [typ] *)
-let coerce_meta_out id = int_of_string (string_of_id id)
-let coerce_meta_in n = id_of_string (string_of_int n)
+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
diff --git a/contrib/ring/ring.ml b/contrib/ring/ring.ml
index 6b82b75b..3d13a254 100644
--- a/contrib/ring/ring.ml
+++ b/contrib/ring/ring.ml
@@ -6,13 +6,13 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: ring.ml 9179 2006-09-26 12:13:06Z barras $ *)
+(* $Id: ring.ml 11094 2008-06-10 19:35:23Z herbelin $ *)
(* ML part of the Ring tactic *)
open Pp
open Util
-open Options
+open Flags
open Term
open Names
open Libnames
@@ -193,7 +193,7 @@ let _ =
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
+ let oppm' = Option.smartmap (subst_mps subst) morph.oppm in
if plusm' == morph.plusm
&& multm' == morph.multm
&& oppm' == morph.oppm then
@@ -215,15 +215,15 @@ let subst_set subst cset =
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_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_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
@@ -826,9 +826,11 @@ let raw_polynom th op lc gl =
c'''i; ci; c'i_eq_c''i |]))))
(tclTHENS
(tclORELSE
- (Setoid_replace.general_s_rewrite true c'i_eq_c''i
+ (Setoid_replace.general_s_rewrite true
+ Termops.all_occurrences c'i_eq_c''i
~new_goals:[])
- (Setoid_replace.general_s_rewrite false c'i_eq_c''i
+ (Setoid_replace.general_s_rewrite false
+ Termops.all_occurrences c'i_eq_c''i
~new_goals:[]))
[tac]))
else
diff --git a/contrib/romega/ROmega.v b/contrib/romega/ROmega.v
index 19933873..68bc43bb 100644
--- a/contrib/romega/ROmega.v
+++ b/contrib/romega/ROmega.v
@@ -1,10 +1,11 @@
(*************************************************************************
PROJET RNRT Calife - 2001
- Author: Pierre Crégut - France Télécom R&D
+ Author: Pierre Crégut - France Télécom R&D
Licence : LGPL version 2.1
*************************************************************************)
Require Import ReflOmegaCore.
-
+Require Export Setoid.
+Require Export PreOmega.
diff --git a/contrib/romega/ReflOmegaCore.v b/contrib/romega/ReflOmegaCore.v
index d20cafc1..9d379548 100644
--- a/contrib/romega/ReflOmegaCore.v
+++ b/contrib/romega/ReflOmegaCore.v
@@ -7,32 +7,852 @@
*************************************************************************)
-Require Import Arith.
-Require Import List.
-Require Import Bool.
-Require Import ZArith_base.
-Require Import OmegaLemmas.
-
-Open Scope Z_scope.
-
-(* \subsection{Definition of basic types} *)
-
-(* \subsubsection{Environment of propositions (lists) *)
-Inductive PropList : Type :=
- | Pnil : PropList
- | Pcons : Prop -> PropList -> PropList.
-
-(* Access function for the environment with a default *)
-Fixpoint nthProp (n : nat) (l : PropList) (default : Prop) {struct l} :
- Prop :=
- match n, l with
- | O, Pcons x l' => x
- | O, other => default
- | S m, Pnil => default
- | S m, Pcons x t => nthProp m t default
- end.
+Require Import List Bool Sumbool EqNat Setoid Ring_theory Decidable.
+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.
+
+ Require Import ZArith_base.
+ 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; elimtype False.
+
+ 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{Définition of reified integer expressions}
+(* \subsubsection{Definition of reified integer expressions}
Terms are either:
\begin{itemize}
\item integers [Tint]
@@ -41,7 +861,7 @@ Fixpoint nthProp (n : nat) (l : PropList) (default : Prop) {struct l} :
The last two are translated in additions and products. *)
Inductive term : Set :=
- | Tint : Z -> term
+ | Tint : int -> term
| Tplus : term -> term -> term
| Tmult : term -> term -> term
| Tminus : term -> term -> term
@@ -49,6 +869,7 @@ Inductive term : Set :=
| Tvar : nat -> term.
Delimit Scope romega_scope with term.
+Arguments Scope Tint [Int_scope].
Arguments Scope Tplus [romega_scope romega_scope].
Arguments Scope Tmult [romega_scope romega_scope].
Arguments Scope Tminus [romega_scope romega_scope].
@@ -58,20 +879,21 @@ Infix "+" := Tplus : romega_scope.
Infix "*" := Tmult : romega_scope.
Infix "-" := Tminus : romega_scope.
Notation "- x" := (Topp x) : romega_scope.
-Notation "[ x ]" := (Tvar x) (at level 1) : 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 (* egalité entre termes *)
- | LeqTerm : term -> term -> proposition (* plus petit ou egal *)
- | TrueTerm : proposition (* vrai *)
- | FalseTerm : proposition (* faux *)
- | Tnot : proposition -> proposition (* négation *)
+ | 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
@@ -87,7 +909,7 @@ Notation hyps := (list proposition).
(* Definition of lists of subgoals (set of open goals) *)
Notation lhyps := (list hyps).
-(* a syngle goal packed in a subgoal list *)
+(* a single goal packed in a subgoal list *)
Notation singleton := (fun a : hyps => a :: nil).
(* an absurd goal *)
@@ -110,24 +932,22 @@ Inductive t_fusion : Set :=
(* \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 *)
+ (* 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 *)
+ (* 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 *)
+ (* 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_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
@@ -152,261 +972,98 @@ Inductive step : Set :=
the trace coming from the decision procedure Omega. *)
Inductive t_omega : Set :=
- (* n = 0 n!= 0 *)
+ (* n = 0 and n!= 0 *)
| O_CONSTANT_NOT_NUL : nat -> t_omega
- | O_CONSTANT_NEG :
- nat -> t_omega
- (* division et approximation of an equation *)
- | O_DIV_APPROX :
- Z ->
- Z ->
- term ->
- nat ->
- t_omega -> nat -> t_omega
- (* no solution because no exact division *)
- | O_NOT_EXACT_DIVIDE :
- Z -> Z -> term -> nat -> nat -> t_omega
- (* exact division *)
- | O_EXACT_DIVIDE : Z -> term -> nat -> t_omega -> nat -> t_omega
- | O_SUM : Z -> nat -> Z -> nat -> list t_fusion -> t_omega -> 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 : Z -> step -> nat -> nat -> t_omega -> 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. *)
-(* \subsubsection{Règles pour normaliser les hypothèses} *)
-(* Ces règles indiquent comment normaliser les propositions utiles
- de chaque hypothèse utile avant la décomposition des hypothèses et
- incluent l'étape d'inversion pour la suppression des négations *)
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.
-(* Liste des normalisations a effectuer : avec un constructeur dans le
- type [p_step] permettant
- de parcourir à la fois les branches gauches et droit, on pourrait n'avoir
- qu'une normalisation par hypothèse. Et comme toutes les hypothèses sont
- utiles (sinon on ne les inclurait pas), on pourrait remplacer [h_step]
- par une simple liste *)
+
+(* 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{Règles pour décomposer les hypothèses} *)
-(* Ce type permet de se diriger dans les constructeurs logiques formant les
- prédicats des hypothèses pour aller les décomposer. Ils permettent
- en particulier d'extraire une hypothèse d'une conjonction avec
- éventuellement le bon niveau de négations. *)
+(* \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.
-(* Ce type permet d'extraire les composants utiles des hypothèses : que ce
- soit des hypothèses générées par éclatement d'une disjonction, ou
- des équations. Le constructeur terminal indique comment résoudre le système
- obtenu en recourrant au type de trace d'Omega [t_omega] *)
+(* 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{Egalité décidable efficace} *)
-(* Pour chaque type de donnée réifié, on calcule un test d'égalité efficace.
- Ce n'est pas le cas de celui rendu par [Decide Equality].
+(* \subsection{Efficient decidable equality} *)
+(* For each reified data-type, we define an efficient equality test.
+ It is not the one produced by [Decide Equality].
- Puis on prouve deux théorèmes permettant d'éliminer de telles égalités :
+ 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} *)
-(* Ces deux tactiques permettent de résoudre pas mal de cas. L'une pour
- les théorèmes positifs, l'autre pour les théorèmes négatifs *)
-
-Ltac absurd_case := simpl in |- *; intros; discriminate.
-Ltac trivial_case := unfold not in |- *; intros; discriminate.
-
-(* \subsubsection{Entiers naturels} *)
-
-Fixpoint eq_nat (t1 t2 : nat) {struct t2} : bool :=
- match t1 with
- | O => match t2 with
- | O => true
- | _ => false
- end
- | S n1 => match t2 with
- | O => false
- | S n2 => eq_nat n1 n2
- end
- end.
-
-Theorem eq_nat_true : forall t1 t2 : nat, eq_nat t1 t2 = true -> t1 = t2.
-
-simple induction t1;
- [ intro t2; case t2; [ trivial | absurd_case ]
- | intros n H t2; case t2;
- [ absurd_case
- | simpl in |- *; intros; rewrite (H n0); [ trivial | assumption ] ] ].
-
-Qed.
-
-Theorem eq_nat_false : forall t1 t2 : nat, eq_nat t1 t2 = false -> t1 <> t2.
-
-simple induction t1;
- [ intro t2; case t2; [ simpl in |- *; intros; discriminate | trivial_case ]
- | intros n H t2; case t2; simpl in |- *; unfold not in |- *; intros;
- [ discriminate | elim (H n0 H0); simplify_eq H1; trivial ] ].
-
-Qed.
-
-
-(* \subsubsection{Entiers positifs} *)
+(* \subsubsection{Reified terms} *)
-Fixpoint eq_pos (p1 p2 : positive) {struct p2} : bool :=
- match p1 with
- | xI n1 => match p2 with
- | xI n2 => eq_pos n1 n2
- | _ => false
- end
- | xO n1 => match p2 with
- | xO n2 => eq_pos n1 n2
- | _ => false
- end
- | xH => match p2 with
- | xH => true
- | _ => false
- end
- end.
+Open Scope romega_scope.
-Theorem eq_pos_true : forall t1 t2 : positive, eq_pos t1 t2 = true -> t1 = t2.
-
-simple induction t1;
- [ intros p H t2; case t2;
- [ simpl in |- *; intros; rewrite (H p0 H0); trivial
- | absurd_case
- | absurd_case ]
- | intros p H t2; case t2;
- [ absurd_case
- | simpl in |- *; intros; rewrite (H p0 H0); trivial
- | absurd_case ]
- | intro t2; case t2; [ absurd_case | absurd_case | auto ] ].
-
-Qed.
-
-Theorem eq_pos_false :
- forall t1 t2 : positive, eq_pos t1 t2 = false -> t1 <> t2.
-
-simple induction t1;
- [ intros p H t2; case t2;
- [ simpl in |- *; unfold not in |- *; intros; elim (H p0 H0);
- simplify_eq H1; auto
- | trivial_case
- | trivial_case ]
- | intros p H t2; case t2;
- [ trivial_case
- | simpl in |- *; unfold not in |- *; intros; elim (H p0 H0);
- simplify_eq H1; auto
- | trivial_case ]
- | intros t2; case t2; [ trivial_case | trivial_case | absurd_case ] ].
-Qed.
-
-(* \subsubsection{Entiers relatifs} *)
-
-Definition eq_Z (z1 z2 : Z) : bool :=
- match z1 with
- | Z0 => match z2 with
- | Z0 => true
- | _ => false
- end
- | Zpos p1 => match z2 with
- | Zpos p2 => eq_pos p1 p2
- | _ => false
- end
- | Zneg p1 => match z2 with
- | Zneg p2 => eq_pos p1 p2
- | _ => false
- end
+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.
-Theorem eq_Z_true : forall t1 t2 : Z, eq_Z t1 t2 = true -> t1 = t2.
-
-simple induction t1;
- [ intros t2; case t2; [ auto | absurd_case | absurd_case ]
- | intros p t2; case t2;
- [ absurd_case
- | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial
- | absurd_case ]
- | intros p t2; case t2;
- [ absurd_case
- | absurd_case
- | simpl in |- *; intros; rewrite (eq_pos_true p p0 H); trivial ] ].
-
-Qed.
-
-Theorem eq_Z_false : forall t1 t2 : Z, eq_Z t1 t2 = false -> t1 <> t2.
-
-simple induction t1;
- [ intros t2; case t2; [ absurd_case | trivial_case | trivial_case ]
- | intros p t2; case t2;
- [ absurd_case
- | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H);
- simplify_eq H0; auto
- | trivial_case ]
- | intros p t2; case t2;
- [ absurd_case
- | trivial_case
- | simpl in |- *; unfold not in |- *; intros; elim (eq_pos_false p p0 H);
- simplify_eq H0; auto ] ].
-Qed.
-
-(* \subsubsection{Termes réifiés} *)
-
-Fixpoint eq_term (t1 t2 : term) {struct t2} : bool :=
- match t1 with
- | Tint st1 => match t2 with
- | Tint st2 => eq_Z st1 st2
- | _ => false
- end
- | (st11 + st12)%term =>
- match t2 with
- | (st21 + st22)%term => eq_term st11 st21 && eq_term st12 st22
- | _ => false
- end
- | (st11 * st12)%term =>
- match t2 with
- | (st21 * st22)%term => eq_term st11 st21 && eq_term st12 st22
- | _ => false
- end
- | (st11 - st12)%term =>
- match t2 with
- | (st21 - st22)%term => eq_term st11 st21 && eq_term st12 st22
- | _ => false
- end
- | (- st1)%term =>
- match t2 with
- | (- st2)%term => eq_term st1 st2
- | _ => false
- end
- | [st1]%term =>
- match t2 with
- | [st2]%term => eq_nat st1 st2
- | _ => false
- end
- end.
+Close Scope romega_scope.
Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2.
-
-
-simple induction t1; intros until t2; case t2; try absurd_case; simpl in |- *;
- [ intros; elim eq_Z_true with (1 := H); trivial
+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
@@ -417,16 +1074,17 @@ simple induction t1; intros until t2; case t2; try absurd_case; simpl in |- *;
elim H with (1 := H4); elim H0 with (1 := H5);
trivial
| intros t21 H3; elim H with (1 := H3); trivial
- | intros; elim eq_nat_true with (1 := H); 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.
-
-simple induction t1;
+Proof.
+ simple induction t1;
[ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *;
- intros; elim eq_Z_false with (1 := H); simplify_eq H0;
+ 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;
@@ -447,9 +1105,8 @@ simple induction t1;
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 eq_nat_false with (1 := H); simplify_eq H0;
+ intros; elim beq_nat_false with (1 := H); simplify_eq H0;
auto ].
-
Qed.
(* \subsubsection{Tactiques pour éliminer ces tests}
@@ -463,54 +1120,29 @@ Qed.
tel test préserve bien l'information voulue mais calculatoirement de
telles fonctions sont trop lentes. *)
-(* Le théorème suivant permet de garder dans les hypothèses la valeur
- du booléen lors de l'élimination. *)
-
-Theorem bool_ind2 :
- forall (P : bool -> Prop) (b : bool),
- (b = true -> P true) -> (b = false -> P false) -> P b.
-
-simple induction b; auto.
-Qed.
-
(* 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_ind2; intro Aux;
+ 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_eq_Z t1 t2 :=
- pattern (eq_Z t1 t2) in |- *; apply bool_ind2; intro Aux;
- [ generalize (eq_Z_true t1 t2 Aux); clear Aux
- | generalize (eq_Z_false t1 t2 Aux); clear Aux ].
-
-Ltac elim_eq_pos t1 t2 :=
- pattern (eq_pos t1 t2) in |- *; apply bool_ind2; intro Aux;
- [ generalize (eq_pos_true t1 t2 Aux); clear Aux
- | generalize (eq_pos_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 ].
-(* \subsubsection{Comparaison sur Z} *)
-
-(* Sujet très lié au précédent : on introduit la tactique d'élimination
- avec son théorème *)
-
-Theorem relation_ind2 :
- forall (P : comparison -> Prop) (b : comparison),
- (b = Eq -> P Eq) ->
- (b = Lt -> P Lt) ->
- (b = Gt -> P Gt) -> P b.
-
-simple induction b; auto.
-Qed.
+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 ].
-Ltac elim_Zcompare t1 t2 := pattern (t1 ?= t2) in |- *; apply relation_ind2.
(* \subsection{Interprétations}
\subsubsection{Interprétation des termes dans Z} *)
-Fixpoint interp_term (env : list Z) (t : term) {struct t} : 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
@@ -521,7 +1153,8 @@ Fixpoint interp_term (env : list Z) (t : term) {struct t} : Z :=
end.
(* \subsubsection{Interprétation des prédicats} *)
-Fixpoint interp_proposition (envp : PropList) (env : list Z)
+
+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
@@ -532,14 +1165,14 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z)
| 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 => Zne (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 => nthProp n envp True
+ | Tprop n => nth n envp True
end.
(* \subsubsection{Inteprétation des listes d'hypothèses}
@@ -547,7 +1180,7 @@ Fixpoint interp_proposition (envp : PropList) (env : list Z)
Interprétation sous forme d'une conjonction d'hypothèses plus faciles
à manipuler individuellement *)
-Fixpoint interp_hyps (envp : PropList) (env : list Z)
+Fixpoint interp_hyps (envp : list Prop) (env : list int)
(l : hyps) {struct l} : Prop :=
match l with
| nil => True
@@ -559,8 +1192,8 @@ Fixpoint interp_hyps (envp : PropList) (env : list Z)
[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 : PropList)
- (env : list Z) (l : hyps) {struct l} : Prop :=
+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' =>
@@ -573,19 +1206,19 @@ Notation interp_goal := (interp_goal_concl FalseTerm).
interprétations. *)
Theorem goal_to_hyps :
- forall (envp : PropList) (env : list Z) (l : hyps),
+ forall (envp : list Prop) (env : list int) (l : hyps),
(interp_hyps envp env l -> False) -> interp_goal envp env l.
-
-simple induction 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 : PropList) (env : list Z) (l : hyps),
+ forall (envp : list Prop) (env : list int) (l : hyps),
interp_goal envp env l -> interp_hyps envp env l -> False.
-
-simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
+Proof.
+ simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ].
Qed.
(* \subsection{Manipulations sur les hypothèses} *)
@@ -593,7 +1226,7 @@ Qed.
(* \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 Z) (t : term), interp_term e t = interp_term e (f t).
+ 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
@@ -602,11 +1235,11 @@ Definition term_stable (f : term -> term) :=
en argument (cela suffit pour omega). *)
Definition valid1 (f : proposition -> proposition) :=
- forall (ep : PropList) (e : list Z) (p1 : 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 : PropList) (e : list Z) (p1 p2 : 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).
@@ -615,31 +1248,31 @@ Definition valid2 (f : proposition -> proposition -> proposition) :=
On reste contravariant *)
Definition valid_hyps (f : hyps -> hyps) :=
- forall (ep : PropList) (e : list Z) (lp : 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 : PropList) (env : list Z) (l : hyps) (a : hyps -> hyps),
+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.
-
-intros; simpl in |- *; apply goal_to_hyps; intro H1;
+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 : PropList) (env : list Z)
+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 : PropList) (env : list Z)
+Fixpoint interp_list_goal (envp : list Prop) (env : list int)
(l : lhyps) {struct l} : Prop :=
match l with
| nil => True
@@ -647,10 +1280,10 @@ Fixpoint interp_list_goal (envp : PropList) (env : list Z)
end.
Theorem list_goal_to_hyps :
- forall (envp : PropList) (env : list Z) (l : lhyps),
+ forall (envp : list Prop) (env : list int) (l : lhyps),
(interp_list_hyps envp env l -> False) -> interp_list_goal envp env l.
-
-simple induction l; simpl in |- *;
+Proof.
+ simple induction l; simpl in |- *;
[ auto
| intros h1 l1 H H1; split;
[ apply goal_to_hyps; intro H2; apply H1; auto
@@ -658,37 +1291,37 @@ simple induction l; simpl in |- *;
Qed.
Theorem list_hyps_to_goal :
- forall (envp : PropList) (env : list Z) (l : lhyps),
+ forall (envp : list Prop) (env : list int) (l : lhyps),
interp_list_goal envp env l -> interp_list_hyps envp env l -> False.
-
-simple induction l; simpl in |- *;
+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 : PropList) (e : list Z) (lp : hyps),
+ 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 : PropList) (e : list Z) (lp : hyps),
+ 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.
-
-unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps;
+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 : PropList) (e : list Z) (l1 l2 : lhyps),
+ 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).
-
-intros ep e; simple induction l1;
+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
@@ -703,10 +1336,10 @@ Qed.
Definition nth_hyps (n : nat) (l : hyps) := nth n l TrueTerm.
Theorem nth_valid :
- forall (ep : PropList) (e : list Z) (i : nat) (l : hyps),
+ forall (ep : list Prop) (e : list int) (i : nat) (l : hyps),
interp_hyps ep e l -> interp_proposition ep e (nth_hyps i l).
-
-unfold nth_hyps in |- *; simple induction i;
+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
@@ -722,8 +1355,8 @@ Definition apply_oper_2 (i j : nat)
Theorem apply_oper_2_valid :
forall (i j : nat) (f : proposition -> proposition -> proposition),
valid2 f -> valid_hyps (apply_oper_2 i j f).
-
-intros i j f Hf; unfold apply_oper_2, valid_hyps in |- *; simpl in |- *;
+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.
@@ -743,8 +1376,8 @@ Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition)
Theorem apply_oper_1_valid :
forall (i : nat) (f : proposition -> proposition),
valid1 f -> valid_hyps (apply_oper_1 i f).
-
-unfold valid_hyps in |- *; intros i f Hf ep e; elim i;
+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;
@@ -753,7 +1386,6 @@ unfold valid_hyps in |- *; intros i f Hf ep e; elim i;
[ simpl in |- *; auto
| simpl in |- *; intros p l' (H1, H2); split;
[ assumption | apply Hrec; assumption ] ] ].
-
Qed.
(* \subsubsection{Manipulations de termes} *)
@@ -789,31 +1421,31 @@ Definition apply_both (f g : term -> term) (t : term) :=
Theorem apply_left_stable :
forall f : term -> term, term_stable f -> term_stable (apply_left f).
-
-unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+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).
-
-unfold term_stable in |- *; intros f H e t; case t; auto; simpl in |- *;
+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).
-
-unfold term_stable in |- *; intros f g H1 H2 e t; case t; auto; simpl in |- *;
+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)).
-
-unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg.
+Proof.
+ unfold term_stable in |- *; intros f g Hf Hg e t; elim Hf; apply Hg.
Qed.
(* \subsection{Les règles de réécriture} *)
@@ -879,21 +1511,7 @@ Ltac loop t :=
| Tand x x0 => _
| Timp x x0 => _
| Tprop x => _
- end =>
- case X1;
- [ intro; intro
- | intro; intro
- | idtac
- | idtac
- | intro
- | intro; intro
- | intro; intro
- | intro; intro
- | intro; intro
- | intro; intro
- | intro; intro
- | intro; intro
- | intro ]; auto; Simplify
+ end => destruct X1; auto; Simplify
| match ?X1 with
| Tint x => _
| (x + x0)%term => _
@@ -901,38 +1519,27 @@ Ltac loop t :=
| (x - x0)%term => _
| (- x)%term => _
| [x]%term => _
- end =>
- case X1;
- [ intro | intro; intro | intro; intro | intro; intro | intro | intro ];
- auto; Simplify
- | match ?X1 ?= ?X2 with
- | Eq => _
- | Lt => _
- | Gt => _
- end =>
- elim_Zcompare X1 X2; intro; auto; Simplify
- | match ?X1 with
- | Z0 => _
- | Zpos x => _
- | Zneg x => _
- end =>
- case X1; [ idtac | intro | intro ]; auto; Simplify
- | (if eq_Z ?X1 ?X2 then _ else _) =>
- elim_eq_Z X1 X2; intro H; [ rewrite H; clear H | clear H ];
+ 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 _) =>
- elim_eq_term X1 X2; intro H; [ rewrite H; clear H | clear H ];
- simpl in |- *; auto; Simplify
- | (if eq_pos ?X1 ?X2 then _ else _) =>
- elim_eq_pos X1 X2; intro H; [ rewrite H; clear H | clear H ];
+ 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.
+with Simplify := match goal with
+ | |- ?X1 => try loop X1
+ | _ => idtac
+ end.
Ltac prove_stable x th :=
match constr:x with
@@ -949,8 +1556,8 @@ Definition Tplus_assoc_l (t : term) :=
end.
Theorem Tplus_assoc_l_stable : term_stable Tplus_assoc_l.
-
-prove_stable Tplus_assoc_l Zplus_assoc.
+Proof.
+ prove_stable Tplus_assoc_l (ring.(Radd_assoc)).
Qed.
Definition Tplus_assoc_r (t : term) :=
@@ -960,8 +1567,8 @@ Definition Tplus_assoc_r (t : term) :=
end.
Theorem Tplus_assoc_r_stable : term_stable Tplus_assoc_r.
-
-prove_stable Tplus_assoc_r Zplus_assoc_reverse.
+Proof.
+ prove_stable Tplus_assoc_r plus_assoc_reverse.
Qed.
Definition Tmult_assoc_r (t : term) :=
@@ -971,8 +1578,8 @@ Definition Tmult_assoc_r (t : term) :=
end.
Theorem Tmult_assoc_r_stable : term_stable Tmult_assoc_r.
-
-prove_stable Tmult_assoc_r Zmult_assoc_reverse.
+Proof.
+ prove_stable Tmult_assoc_r mult_assoc_reverse.
Qed.
Definition Tplus_permute (t : term) :=
@@ -982,46 +1589,44 @@ Definition Tplus_permute (t : term) :=
end.
Theorem Tplus_permute_stable : term_stable Tplus_permute.
-
-prove_stable Tplus_permute Zplus_permute.
+Proof.
+ prove_stable Tplus_permute plus_permute.
Qed.
-Definition Tplus_sym (t : term) :=
+Definition Tplus_comm (t : term) :=
match t with
| (x + y)%term => (y + x)%term
| _ => t
end.
-Theorem Tplus_sym_stable : term_stable Tplus_sym.
-
-prove_stable Tplus_sym Zplus_comm.
+Theorem Tplus_comm_stable : term_stable Tplus_comm.
+Proof.
+ prove_stable Tplus_comm plus_comm.
Qed.
-Definition Tmult_sym (t : term) :=
+Definition Tmult_comm (t : term) :=
match t with
| (x * y)%term => (y * x)%term
| _ => t
end.
-Theorem Tmult_sym_stable : term_stable Tmult_sym.
-
-prove_stable Tmult_sym Zmult_comm.
+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 =>
- match eq_term v v' with
- | true =>
- (v * Tint (c1 * k1 + c2 * k2) + (l1 * Tint k1 + l2 * Tint k2))%term
- | false => t
- end
+ 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.
-
-prove_stable T_OMEGA10 OMEGA10.
+Proof.
+ prove_stable T_OMEGA10 OMEGA10.
Qed.
Definition T_OMEGA11 (t : term) :=
@@ -1032,8 +1637,8 @@ Definition T_OMEGA11 (t : term) :=
end.
Theorem T_OMEGA11_stable : term_stable T_OMEGA11.
-
-prove_stable T_OMEGA11 OMEGA11.
+Proof.
+ prove_stable T_OMEGA11 OMEGA11.
Qed.
Definition T_OMEGA12 (t : term) :=
@@ -1044,52 +1649,37 @@ Definition T_OMEGA12 (t : term) :=
end.
Theorem T_OMEGA12_stable : term_stable T_OMEGA12.
-
-prove_stable T_OMEGA12 OMEGA12.
+Proof.
+ prove_stable T_OMEGA12 OMEGA12.
Qed.
Definition T_OMEGA13 (t : term) :=
match t with
- | (v * Tint (Zpos x) + l1 + (v' * Tint (Zneg x') + l2))%term =>
- match eq_term v v' with
- | true =>
- match eq_pos x x' with
- | true => (l1 + l2)%term
- | false => t
- end
- | false => t
- end
- | (v * Tint (Zneg x) + l1 + (v' * Tint (Zpos x') + l2))%term =>
- match eq_term v v' with
- | true =>
- match eq_pos x x' with
- | true => (l1 + l2)%term
- | false => t
- end
- | false => t
- end
+ | (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.
-
-unfold term_stable, T_OMEGA13 in |- *; intros; Simplify; simpl in |- *;
- [ apply OMEGA13 | apply OMEGA14 ].
+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 =>
- match eq_term v v' with
- | true => (v * Tint (c1 + c2 * k2) + (l1 + l2 * Tint k2))%term
- | false => t
- end
+ 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.
-
-prove_stable T_OMEGA15 OMEGA15.
+Proof.
+ prove_stable T_OMEGA15 OMEGA15.
Qed.
Definition T_OMEGA16 (t : term) :=
@@ -1100,20 +1690,19 @@ Definition T_OMEGA16 (t : term) :=
Theorem T_OMEGA16_stable : term_stable T_OMEGA16.
-
-prove_stable T_OMEGA16 OMEGA16.
+Proof.
+ prove_stable T_OMEGA16 OMEGA16.
Qed.
Definition Tred_factor5 (t : term) :=
match t with
- | (x * Tint Z0 + y)%term => y
+ | (x * Tint c + y)%term => if beq c 0 then y else t
| _ => t
end.
Theorem Tred_factor5_stable : term_stable Tred_factor5.
-
-
-prove_stable Tred_factor5 Zred_factor5.
+Proof.
+ prove_stable Tred_factor5 red_factor5.
Qed.
Definition Topp_plus (t : term) :=
@@ -1123,8 +1712,8 @@ Definition Topp_plus (t : term) :=
end.
Theorem Topp_plus_stable : term_stable Topp_plus.
-
-prove_stable Topp_plus Zopp_plus_distr.
+Proof.
+ prove_stable Topp_plus opp_plus_distr.
Qed.
@@ -1135,8 +1724,8 @@ Definition Topp_opp (t : term) :=
end.
Theorem Topp_opp_stable : term_stable Topp_opp.
-
-prove_stable Topp_opp Zopp_involutive.
+Proof.
+ prove_stable Topp_opp opp_involutive.
Qed.
Definition Topp_mult_r (t : term) :=
@@ -1146,19 +1735,19 @@ Definition Topp_mult_r (t : term) :=
end.
Theorem Topp_mult_r_stable : term_stable Topp_mult_r.
-
-prove_stable Topp_mult_r Zopp_mult_distr_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
+ | (- x)%term => (x * Tint (-(1)))%term
| _ => t
end.
Theorem Topp_one_stable : term_stable Topp_one.
-
-prove_stable Topp_one Zopp_eq_mult_neg_1.
+Proof.
+ prove_stable Topp_one opp_eq_mult_neg_1.
Qed.
Definition Tmult_plus_distr (t : term) :=
@@ -1168,8 +1757,8 @@ Definition Tmult_plus_distr (t : term) :=
end.
Theorem Tmult_plus_distr_stable : term_stable Tmult_plus_distr.
-
-prove_stable Tmult_plus_distr Zmult_plus_distr_l.
+Proof.
+ prove_stable Tmult_plus_distr mult_plus_distr_r.
Qed.
Definition Tmult_opp_left (t : term) :=
@@ -1179,8 +1768,8 @@ Definition Tmult_opp_left (t : term) :=
end.
Theorem Tmult_opp_left_stable : term_stable Tmult_opp_left.
-
-prove_stable Tmult_opp_left Zmult_opp_comm.
+Proof.
+ prove_stable Tmult_opp_left mult_opp_comm.
Qed.
Definition Tmult_assoc_reduced (t : term) :=
@@ -1190,91 +1779,81 @@ Definition Tmult_assoc_reduced (t : term) :=
end.
Theorem Tmult_assoc_reduced_stable : term_stable Tmult_assoc_reduced.
-
-prove_stable Tmult_assoc_reduced Zmult_assoc_reverse.
+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.
-
-prove_stable Tred_factor0 Zred_factor0.
+Proof.
+ prove_stable Tred_factor0 red_factor0.
Qed.
Definition Tred_factor1 (t : term) :=
match t with
| (x + y)%term =>
- match eq_term x y with
- | true => (x * Tint 2)%term
- | false => t
- end
+ if eq_term x y
+ then (x * Tint 2)%term
+ else t
| _ => t
end.
Theorem Tred_factor1_stable : term_stable Tred_factor1.
-
-prove_stable Tred_factor1 Zred_factor1.
+Proof.
+ prove_stable Tred_factor1 red_factor1.
Qed.
Definition Tred_factor2 (t : term) :=
match t with
| (x + y * Tint k)%term =>
- match eq_term x y with
- | true => (x * Tint (1 + k))%term
- | false => t
- end
+ if eq_term x y
+ then (x * Tint (1 + k))%term
+ else t
| _ => t
end.
-(* Attention : il faut rendre opaque [Zplus] pour éviter que la tactique
- de simplification n'aille trop loin et défasse [Zplus 1 k] *)
-
-Opaque Zplus.
-
Theorem Tred_factor2_stable : term_stable Tred_factor2.
-prove_stable Tred_factor2 Zred_factor2.
+Proof.
+ prove_stable Tred_factor2 red_factor2.
Qed.
Definition Tred_factor3 (t : term) :=
match t with
| (x * Tint k + y)%term =>
- match eq_term x y with
- | true => (x * Tint (1 + k))%term
- | false => t
- end
+ if eq_term x y
+ then (x * Tint (1 + k))%term
+ else t
| _ => t
end.
Theorem Tred_factor3_stable : term_stable Tred_factor3.
-
-prove_stable Tred_factor3 Zred_factor3.
+Proof.
+ prove_stable Tred_factor3 red_factor3.
Qed.
Definition Tred_factor4 (t : term) :=
match t with
| (x * Tint k1 + y * Tint k2)%term =>
- match eq_term x y with
- | true => (x * Tint (k1 + k2))%term
- | false => t
- end
+ if eq_term x y
+ then (x * Tint (k1 + k2))%term
+ else t
| _ => t
end.
Theorem Tred_factor4_stable : term_stable Tred_factor4.
-
-prove_stable Tred_factor4 Zred_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.
-
-prove_stable Tred_factor6 Zred_factor6.
+Proof.
+ prove_stable Tred_factor6 red_factor6.
Qed.
-Transparent Zplus.
-
Definition Tminus_def (t : term) :=
match t with
| (x - y)%term => (x + - y)%term
@@ -1282,9 +1861,8 @@ Definition Tminus_def (t : term) :=
end.
Theorem Tminus_def_stable : term_stable Tminus_def.
-
-(* Le théorème ne sert à rien. Le but est prouvé avant. *)
-prove_stable Tminus_def False.
+Proof.
+ prove_stable Tminus_def minus_def.
Qed.
(* \subsection{Fonctions de réécriture complexes} *)
@@ -1332,8 +1910,8 @@ Fixpoint reduce (t : term) : term :=
end.
Theorem reduce_stable : term_stable reduce.
-
-unfold term_stable in |- *; intros e t; elim t; auto;
+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);
@@ -1366,8 +1944,8 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term :=
end.
Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t).
-
-simple induction t; simpl in |- *;
+Proof.
+ simple induction t; simpl in |- *;
[ exact reduce_stable
| intros stp l H; case stp;
[ apply compose_term_stable;
@@ -1378,7 +1956,6 @@ simple induction t; simpl in |- *;
[ 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} *)
@@ -1405,8 +1982,8 @@ Fixpoint fusion_cancel (trace : nat) (t : term) {struct trace} : term :=
end.
Theorem fusion_cancel_stable : forall t : nat, term_stable (fusion_cancel t).
-
-unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace;
+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.
@@ -1422,8 +1999,8 @@ Fixpoint scalar_norm_add (trace : nat) (t : term) {struct trace} : term :=
Theorem scalar_norm_add_stable :
forall t : nat, term_stable (scalar_norm_add t).
-
-unfold term_stable, scalar_norm_add in |- *; intros trace; elim trace;
+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 ] ].
@@ -1437,8 +2014,8 @@ Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term :=
end.
Theorem scalar_norm_stable : forall t : nat, term_stable (scalar_norm t).
-
-unfold term_stable, scalar_norm in |- *; intros trace; elim trace;
+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 ] ].
@@ -1452,8 +2029,8 @@ Fixpoint add_norm (trace : nat) (t : term) {struct trace} : term :=
end.
Theorem add_norm_stable : forall t : nat, term_stable (add_norm t).
-
-unfold term_stable, add_norm in |- *; intros trace; elim trace;
+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 ] ].
@@ -1480,7 +2057,7 @@ Fixpoint rewrite (s : step) : term -> term :=
| C_PLUS_ASSOC_R => Tplus_assoc_r
| C_PLUS_ASSOC_L => Tplus_assoc_l
| C_PLUS_PERMUTE => Tplus_permute
- | C_PLUS_COMM => Tplus_sym
+ | C_PLUS_COMM => Tplus_comm
| C_RED0 => Tred_factor0
| C_RED1 => Tred_factor1
| C_RED2 => Tred_factor2
@@ -1490,12 +2067,12 @@ Fixpoint rewrite (s : step) : term -> term :=
| C_RED6 => Tred_factor6
| C_MULT_ASSOC_REDUCED => Tmult_assoc_reduced
| C_MINUS => Tminus_def
- | C_MULT_COMM => Tmult_sym
+ | C_MULT_COMM => Tmult_comm
end.
Theorem rewrite_stable : forall s : step, term_stable (rewrite s).
-
-simple induction s; simpl in |- *;
+Proof.
+ simple induction s; simpl in |- *;
[ intros; apply apply_both_stable; auto
| intros; apply apply_left_stable; auto
| intros; apply apply_right_stable; auto
@@ -1512,7 +2089,7 @@ simple induction s; simpl in |- *;
| exact Tplus_assoc_r_stable
| exact Tplus_assoc_l_stable
| exact Tplus_permute_stable
- | exact Tplus_sym_stable
+ | exact Tplus_comm_stable
| exact Tred_factor0_stable
| exact Tred_factor1_stable
| exact Tred_factor2_stable
@@ -1522,7 +2099,7 @@ simple induction s; simpl in |- *;
| exact Tred_factor6_stable
| exact Tmult_assoc_reduced_stable
| exact Tminus_def_stable
- | exact Tmult_sym_stable ].
+ | exact Tmult_comm_stable ].
Qed.
(* \subsection{tactiques de résolution d'un but omega normalisé}
@@ -1532,20 +2109,18 @@ Qed.
Definition constant_not_nul (i : nat) (h : hyps) :=
match nth_hyps i h with
- | EqTerm (Tint Z0) (Tint n) =>
- match eq_Z n 0 with
- | true => h
- | false => absurd
- end
+ | 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).
-
-unfold valid_hyps, constant_not_nul in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
- elim_eq_Z ipattern:z0 0; auto; simpl in |- *; intros H1 H2;
+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.
@@ -1553,66 +2128,55 @@ Qed.
Definition constant_neg (i : nat) (h : hyps) :=
match nth_hyps i h with
- | LeqTerm (Tint Z0) (Tint (Zneg n)) => absurd
+ | 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).
-
-unfold valid_hyps, constant_neg in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
- unfold Zle in |- *; simpl in |- *; intros H1; elim H1;
- [ assumption | trivial ].
-Qed.
+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 : Z) (body : term)
+Definition not_exact_divide (k1 k2 : int) (body : term)
(t i : nat) (l : hyps) :=
match nth_hyps i l with
- | EqTerm (Tint Z0) b =>
- match
- eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b
- with
- | true =>
- match k2 ?= 0 with
- | Gt =>
- match k1 ?= k2 with
- | Gt => absurd
- | _ => l
- end
- | _ => l
- end
- | false => l
- end
+ | 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 : Z) (body : term) (t i : nat),
+ forall (k1 k2 : int) (body : term) (t i : nat),
valid_hyps (not_exact_divide k1 k2 body t i).
-
-unfold valid_hyps, not_exact_divide in |- *; intros;
- generalize (nth_valid ep e i lp); Simplify;
- elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1;
- auto; Simplify; intro H2; elim H2; simpl in |- *;
- elim (scalar_norm_add_stable t e); simpl in |- *;
- intro H4; absurd (interp_term e body * k1 + k2 = 0);
- [ apply OMEGA4; assumption | symmetry in |- *; auto ].
-
+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 Z0) b1 =>
+ | LeqTerm (Tint Nul) b1 =>
match nth_hyps j l with
- | LeqTerm (Tint Z0) b2 =>
+ | LeqTerm (Tint Nul') b2 =>
match fusion_cancel t (b1 + b2)%term with
- | Tint k => match 0 ?= k with
- | Gt => absurd
- | _ => l
- end
+ | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k
+ then absurd
+ else l
| _ => l
end
| _ => l
@@ -1622,43 +2186,40 @@ Definition contradiction (t i j : nat) (l : hyps) :=
Theorem contradiction_valid :
forall t i j : nat, valid_hyps (contradiction t i j).
-
-unfold valid_hyps, contradiction in |- *; intros t i j ep e l H;
+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; intros z; case z; auto; case (nth_hyps j l);
- auto; intros t3 t4; case t3; auto; intros z'; case z';
- auto; simpl in |- *; intros H1 H2;
+ 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 |- *;
- intro E; generalize (OMEGA2 _ _ H2 H1); rewrite E;
- case k; auto; unfold Zle in |- *; simpl in |- *; intros p H3;
- elim H3; auto.
-
+ 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 Z0) b1 =>
+ | EqTerm (Tint Nul) b1 =>
match nth_hyps i2 h with
- | NeqTerm (Tint Z0) b2 =>
- match eq_term b1 b2 with
- | true => absurd
- | false => h
- end
+ | NeqTerm (Tint Nul') b2 =>
+ if beq Nul 0 && beq Nul' 0 && eq_term b1 b2
+ then absurd
+ else h
| _ => h
end
- | NeqTerm (Tint Z0) b1 =>
+ | NeqTerm (Tint Nul) b1 =>
match nth_hyps i2 h with
- | EqTerm (Tint Z0) b2 =>
- match eq_term b1 b2 with
- | true => absurd
- | false => h
- end
+ | EqTerm (Tint Nul') b2 =>
+ if beq Nul 0 && beq Nul' 0 && eq_term b1 b2
+ then absurd
+ else h
| _ => h
end
| _ => h
@@ -1666,22 +2227,22 @@ Definition negate_contradict (i1 i2 : nat) (h : hyps) :=
Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
match nth_hyps i1 h with
- | EqTerm (Tint Z0) b1 =>
+ | EqTerm (Tint Nul) b1 =>
match nth_hyps i2 h with
- | NeqTerm (Tint Z0) b2 =>
- match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with
- | true => absurd
- | false => h
- end
+ | 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 Z0) b1 =>
+ | NeqTerm (Tint Nul) b1 =>
match nth_hyps i2 h with
- | EqTerm (Tint Z0) b2 =>
- match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with
- | true => absurd
- | false => h
- end
+ | 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
@@ -1689,45 +2250,33 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) :=
Theorem negate_contradict_valid :
forall i j : nat, valid_hyps (negate_contradict i j).
-
-unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H;
+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; case z; auto; case (nth_hyps j l);
- auto; intros t3 t4; case t3; auto; intros z'; case z';
- auto; simpl in |- *; intros H1 H2;
- [ elim_eq_term t2 t4; intro H3;
- [ elim H1; elim H3; assumption | assumption ]
- | elim_eq_term t2 t4; intro H3;
- [ elim H2; rewrite H3; assumption | assumption ] ].
-
+ 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).
-
-
-unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H;
+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; case z; auto; case (nth_hyps j l);
- auto; intros t3 t4; case t3; auto; intros z'; case z';
- auto; simpl in |- *; intros H1 H2;
- (pattern (eq_term t2 (scalar_norm t (t4 * Tint (-1))%term)) in |- *;
- apply bool_ind2; intro Aux;
- [ generalize (eq_term_true t2 (scalar_norm t (t4 * Tint (-1))%term) Aux);
- clear Aux
- | generalize (eq_term_false t2 (scalar_norm t (t4 * Tint (-1))%term) Aux);
- clear Aux ]);
- [ intro H3; elim H1; generalize H2; rewrite H3;
- rewrite <- (scalar_norm_stable t e); simpl in |- *;
- elim (interp_term e t4); simpl in |- *; auto; intros p H4;
- discriminate H4
- | auto
- | intro H3; elim H2; rewrite H3; elim (scalar_norm_stable t e);
- simpl in |- *; elim H1; simpl in |- *; trivial
- | auto ].
-
+ 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} *)
@@ -1737,150 +2286,93 @@ Qed.
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 : Z) (trace : list t_fusion)
+Definition sum (k1 k2 : int) (trace : list t_fusion)
(prop1 prop2 : proposition) :=
match prop1 with
- | EqTerm (Tint Z0) b1 =>
+ | EqTerm (Tint Null) b1 =>
match prop2 with
- | EqTerm (Tint Z0) b2 =>
- EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
- | LeqTerm (Tint Z0) b2 =>
- match k2 ?= 0 with
- | Gt =>
- LeqTerm (Tint 0)
+ | 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)
- | _ => TrueTerm
- end
+ else TrueTerm
| _ => TrueTerm
end
- | LeqTerm (Tint Z0) b1 =>
- match k1 ?= 0 with
- | Gt =>
- match prop2 with
- | EqTerm (Tint Z0) b2 =>
+ | 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)
- | LeqTerm (Tint Z0) b2 =>
- match k2 ?= 0 with
- | Gt =>
- LeqTerm (Tint 0)
+ 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)
- | _ => TrueTerm
- end
+ else TrueTerm
| _ => TrueTerm
end
- | _ => TrueTerm
- end
- | NeqTerm (Tint Z0) b1 =>
+ else TrueTerm
+ | NeqTerm (Tint Null) b1 =>
match prop2 with
- | EqTerm (Tint Z0) b2 =>
- match eq_Z k1 0 with
- | true => TrueTerm
- | false =>
- NeqTerm (Tint 0)
- (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term)
- end
+ | 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 sum1 : forall a b c d : Z, 0 = a -> 0 = b -> 0 = a * c + b * d.
-
-intros; elim H; elim H0; simpl in |- *; auto.
-Qed.
-
-Theorem sum2 :
- forall a b c d : Z, 0 <= d -> 0 = a -> 0 <= b -> 0 <= a * c + b * d.
-
-intros; elim H0; simpl in |- *; generalize H H1; case b; case d;
- unfold Zle in |- *; simpl in |- *; auto.
-Qed.
-
-Theorem sum3 :
- forall a b c d : Z,
- 0 <= c -> 0 <= d -> 0 <= a -> 0 <= b -> 0 <= a * c + b * d.
-
-intros a b c d; case a; case b; case c; case d; unfold Zle in |- *;
- simpl in |- *; auto.
-Qed.
-
-Theorem sum4 : forall k : Z, (k ?= 0) = Gt -> 0 <= k.
-
-intro; case k; unfold Zle in |- *; simpl in |- *; auto; intros; discriminate.
-Qed.
-
-Theorem sum5 :
- forall a b c d : Z, c <> 0 -> 0 <> a -> 0 = b -> 0 <> a * c + b * d.
-
-intros a b c d H1 H2 H3; elim H3; simpl in |- *; rewrite Zplus_comm;
- simpl in |- *; generalize H1 H2; case a; case c; simpl in |- *;
- intros; try discriminate; assumption.
-Qed.
-
Theorem sum_valid :
- forall (k1 k2 : Z) (t : list t_fusion), valid2 (sum k1 k2 t).
-
-unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *;
+ 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 Zplus_comm; apply sum2; try assumption; apply sum4; assumption
+ | rewrite plus_comm; apply sum2; try assumption; apply sum4; assumption
| apply sum3; try assumption; apply sum4; assumption
- | elim_eq_Z k1 0; simpl in |- *; auto; elim (fusion_stable t); simpl in |- *;
- intros; unfold Zne in |- *; apply sum5; 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 : Z) (body : term) (t : nat)
+Definition exact_divide (k : int) (body : term) (t : nat)
(prop : proposition) :=
match prop with
- | EqTerm (Tint Z0) b =>
- match eq_term (scalar_norm t (body * Tint k)%term) b with
- | true =>
- match eq_Z k 0 with
- | true => TrueTerm
- | false => EqTerm (Tint 0) body
- end
- | false => TrueTerm
- end
- | NeqTerm (Tint Z0) b =>
- match eq_term (scalar_norm t (body * Tint k)%term) b with
- | true =>
- match eq_Z k 0 with
- | true => FalseTerm
- | false => NeqTerm (Tint 0) body
- end
- | false => TrueTerm
- end
+ | 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 : Z) (t : term) (n : nat), valid1 (exact_divide k t n).
-
-
-unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; Simplify;
- simpl in |- *; auto; elim_eq_term (scalar_norm t (k2 * Tint k1)%term) t1;
- simpl in |- *; auto; elim_eq_Z k1 0; simpl in |- *;
- auto; intros H1 H2; elim H2; elim scalar_norm_stable;
- simpl in |- *;
- [
- generalize H1; case (interp_term e k2);
- try trivial;
- (case k1; simpl in |- *;
- [ intros; absurd (0 = 0); assumption
- | intros p2 p3 H3 H4; discriminate H4
- | intros p2 p3 H3 H4; discriminate H4 ])
- |
- subst k1; rewrite Zmult_comm; simpl in *; intros; absurd (0=0); trivial
- |
- generalize H1; case (interp_term e k2);
- try trivial; intros p2 p3 H3 H4; discriminate H4
+ 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.
@@ -1889,61 +2381,51 @@ Qed.
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 : Z) (body : term)
+Definition divide_and_approx (k1 k2 : int) (body : term)
(t : nat) (prop : proposition) :=
match prop with
- | LeqTerm (Tint Z0) b =>
- match
- eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b
- with
- | true =>
- match k1 ?= 0 with
- | Gt =>
- match k1 ?= k2 with
- | Gt => LeqTerm (Tint 0) body
- | _ => prop
- end
- | _ => prop
- end
- | false => prop
- end
+ | 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 : Z) (body : term) (t : nat),
+ forall (k1 k2 : int) (body : term) (t : nat),
valid1 (divide_and_approx k1 k2 body t).
-
-unfold valid1, divide_and_approx in |- *; intros k1 k2 body t ep e p1;
- Simplify;
- elim_eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) t1;
- Simplify; auto; intro E; elim E; simpl in |- *;
- elim (scalar_norm_add_stable t e); simpl in |- *;
- intro H1; apply Zmult_le_approx with (3 := H1); assumption.
+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 Z0) b1 =>
+ | LeqTerm (Tint Null) b1 =>
match prop2 with
- | LeqTerm (Tint Z0) b2 =>
- match eq_term b1 (scalar_norm t (b2 * Tint (-1))%term) with
- | true => EqTerm (Tint 0) b1
- | false => TrueTerm
- end
+ | 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).
-
-unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *;
+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 Zopp_eq_mult_neg_1; trivial ].
+ [ assumption | elim opp_eq_mult_neg_1; trivial ].
Qed.
@@ -1952,36 +2434,39 @@ Qed.
Definition constant_nul (i : nat) (h : hyps) :=
match nth_hyps i h with
- | NeqTerm (Tint Z0) (Tint Z0) => absurd
+ | 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).
-
-unfold valid_hyps, constant_nul in |- *; intros;
+Proof.
+ unfold valid_hyps, constant_nul in |- *; intros;
generalize (nth_valid ep e i lp); Simplify; simpl in |- *;
- unfold Zne in |- *; intro H1; absurd (0 = 0); auto.
+ intro H1; absurd (0 = 0); intuition.
Qed.
(* \paragraph{[O_STATE]} *)
-Definition state (m : Z) (s : step) (prop1 prop2 : proposition) :=
+Definition state (m : int) (s : step) (prop1 prop2 : proposition) :=
match prop1 with
- | EqTerm (Tint Z0) b1 =>
+ | EqTerm (Tint Null) b1 =>
match prop2 with
| EqTerm b2 b3 =>
- EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term)
+ 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 : Z) (s : step), valid2 (state m s).
-
-unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify;
+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.
- rewrite H2; rewrite Zplus_opp_l; simpl; reflexivity.
+ now rewrite H2, plus_opp_l, plus_0_l, mult_0_l.
Qed.
(* \subsubsection{Tactiques générant plusieurs but}
@@ -1991,11 +2476,13 @@ Qed.
Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps)
(l : hyps) :=
match nth_hyps i l with
- | NeqTerm (Tint Z0) b1 =>
- f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-1))%term) :: l) ++
+ | 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)
+ (scalar_norm_add t (b1 * Tint (-(1)) + Tint (-(1)))%term) :: l)
+ else l :: nil
| _ => l :: nil
end.
@@ -2003,17 +2490,18 @@ 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).
-
-unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H;
+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; case z; simpl in |- *; auto; intro H3;
+ 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 Zne, not in |- *; intros E1 E2; apply E1;
+ | generalize H3; unfold not in |- *; intros E1 E2; apply E1;
symmetry in |- *; trivial ].
Qed.
@@ -2046,8 +2534,8 @@ Fixpoint execute_omega (t : t_omega) (l : hyps) {struct t} : lhyps :=
end.
Theorem omega_valid : forall t : t_omega, valid_list_hyps (execute_omega t).
-
-simple induction t; simpl in |- *;
+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;
@@ -2058,7 +2546,7 @@ simple induction t; simpl in |- *;
(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 z z0 t0 n n0 ep e lp H)
+ 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
@@ -2101,36 +2589,30 @@ Definition move_right (s : step) (p : proposition) :=
| 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)
+ | 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 Zne_left_2 : forall x y : Z, Zne x y -> Zne 0 (x + - y).
-unfold Zne, not in |- *; intros x y H1 H2; apply H1;
- apply (Zplus_reg_l (- y)); rewrite Zplus_comm; elim H2;
- rewrite Zplus_opp_l; trivial.
-Qed.
-
Theorem move_right_valid : forall s : step, valid1 (move_right s).
-
-unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *;
+Proof.
+ unfold valid1, move_right in |- *; intros s ep e p; Simplify; simpl in |- *;
elim (rewrite_stable s e); simpl in |- *;
- [ symmetry in |- *; apply Zegal_left; assumption
- | intro; apply Zle_left; assumption
- | intro; apply Zge_left; assumption
- | intro; apply Zgt_left; assumption
- | intro; apply Zlt_left; assumption
- | intro; apply Zne_left_2; assumption ].
+ [ 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).
-
-intros; unfold do_normalize in |- *; apply apply_oper_1_valid;
+Proof.
+ intros; unfold do_normalize in |- *; apply apply_oper_1_valid;
apply move_right_valid.
Qed.
@@ -2143,43 +2625,40 @@ Fixpoint do_normalize_list (l : list step) (i : nat)
Theorem do_normalize_list_valid :
forall (l : list step) (i : nat), valid_hyps (do_normalize_list l i).
-
-simple induction l; simpl in |- *; unfold valid_hyps in |- *;
+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 : PropList) (env : list Z) (l : hyps),
+ 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.
-
-intros; apply valid_goal with (2 := H); apply do_normalize_list_valid.
+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 : PropList) (env : list Z) (l : hyps),
+ 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.
-
-intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H).
+Proof.
+ intros; apply (goal_valid (execute_omega t) (omega_valid t) ep env l H).
Qed.
Theorem append_goal :
- forall (ep : PropList) (e : list Z) (l1 l2 : lhyps),
+ 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).
-
-intros ep e; simple induction l1;
+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.
-Require Import Decidable.
-
(* 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
@@ -2203,30 +2682,29 @@ Fixpoint decidability (p : proposition) : bool :=
end.
Theorem decidable_correct :
- forall (ep : PropList) (e : list Z) (p : proposition),
+ forall (ep : list Prop) (e : list int) (p : proposition),
decidability p = true -> decidable (interp_proposition ep e p).
-
-simple induction p; simpl in |- *; intros;
+Proof.
+ simple induction p; simpl in |- *; intros;
[ apply dec_eq
- | apply dec_Zle
+ | apply dec_le
| left; auto
| right; unfold not in |- *; auto
| apply dec_not; auto
- | apply dec_Zge
- | apply dec_Zgt
- | apply dec_Zlt
- | apply dec_Zne
+ | 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 : PropList) (env : list Z)
+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
@@ -2234,7 +2712,7 @@ Fixpoint interp_full_goal (envp : PropList) (env : list Z)
interp_proposition envp env p' -> interp_full_goal envp env c l'
end.
-Definition interp_full (ep : PropList) (e : list Z)
+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
@@ -2244,12 +2722,11 @@ Definition interp_full (ep : PropList) (e : list Z)
of its hypothesis and conclusion *)
Theorem interp_full_false :
- forall (ep : PropList) (e : list Z) (l : hyps) (c : proposition),
+ 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).
-
-simple induction l; unfold interp_full in |- *; simpl in |- *;
+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
@@ -2265,11 +2742,11 @@ Definition to_contradict (lc : hyps * proposition) :=
hypothesis implies the original goal *)
Theorem to_contradict_valid :
- forall (ep : PropList) (e : list Z) (lc : hyps * proposition),
+ forall (ep : list Prop) (e : list int) (lc : hyps * proposition),
interp_goal ep e (to_contradict lc) -> interp_full ep e lc.
-
-intros ep e lc; case lc; intros l c; simpl in |- *;
- pattern (decidability c) in |- *; apply bool_ind2;
+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
@@ -2333,19 +2810,19 @@ Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps :=
end.
Theorem map_cons_val :
- forall (ep : PropList) (e : list Z) (p : proposition) (l : lhyps),
+ 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).
-
-simple induction l; simpl in |- *; [ auto | intros; elim H1; intro H2; auto ].
+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).
-
-simple induction 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
@@ -2358,7 +2835,7 @@ simple induction n;
(simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0;
auto);
[ simpl in |- *; intros p1 (H1, H2);
- pattern (decidability p1) in |- *; apply bool_ind2;
+ pattern (decidability p1) in |- *; apply bool_eq_ind;
intro H3;
[ apply H; simpl in |- *; split;
[ apply not_not; auto | assumption ]
@@ -2366,7 +2843,7 @@ simple induction n;
| 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_ind2;
+ 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
@@ -2378,18 +2855,17 @@ simple induction n;
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_ind2;
+ 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 : PropList) (e : list Z) (p : 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)
@@ -2405,8 +2881,8 @@ Definition p_apply_left (f : proposition -> proposition)
Theorem p_apply_left_stable :
forall f : proposition -> proposition,
prop_stable f -> prop_stable (p_apply_left f).
-
-unfold prop_stable in |- *; intros f H ep e p; split;
+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.
@@ -2423,8 +2899,8 @@ Definition p_apply_right (f : proposition -> proposition)
Theorem p_apply_right_stable :
forall f : proposition -> proposition,
prop_stable f -> prop_stable (p_apply_right f).
-
-unfold prop_stable in |- *; intros f H ep e p; split;
+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
@@ -2447,67 +2923,55 @@ Definition p_invert (f : proposition -> proposition)
Theorem p_invert_stable :
forall f : proposition -> proposition,
prop_stable f -> prop_stable (p_invert f).
-
-unfold prop_stable in |- *; intros f H ep e p; split;
+Proof.
+ unfold prop_stable in |- *; intros f H ep e p; split;
(case p; simpl in |- *; auto;
[ intros t1 t2; elim (H ep e (NeqTerm t1 t2)); simpl in |- *;
- unfold Zne 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 |- *;
- unfold Zgt in |- *;
- generalize (dec_Zgt (interp_term e t1) (interp_term e t2));
- unfold decidable, Zgt, Zle in |- *; tauto
+ generalize (dec_gt (interp_term e t1) (interp_term e t2));
+ unfold decidable in |- *; rewrite le_lt_iff, <- gt_lt_iff; tauto
| intros t1 t2; elim (H ep e (LtTerm t1 t2)); simpl in |- *;
- unfold Zlt in |- *;
- generalize (dec_Zlt (interp_term e t1) (interp_term e t2));
- unfold decidable, Zge in |- *; tauto
+ 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_Zgt (interp_term e t1) (interp_term e t2));
- unfold Zle, Zgt in |- *; unfold decidable in |- *;
- tauto
+ 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_Zlt (interp_term e t1) (interp_term e t2));
- unfold Zge, Zlt in |- *; unfold decidable in |- *;
- tauto
+ 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, Zne in |- *; tauto ]).
-Qed.
-
-Theorem Zlt_left_inv : forall x y : Z, 0 <= y + -1 + - x -> x < y.
-
-intros; apply Zsucc_lt_reg; apply Zle_lt_succ;
- apply (fun a b : Z => Zplus_le_reg_r a b (-1 + - x));
- rewrite Zplus_assoc; unfold Zsucc in |- *; rewrite (Zplus_assoc_reverse x);
- rewrite (Zplus_assoc y); simpl in |- *; rewrite Zplus_0_r;
- rewrite Zplus_opp_r; assumption.
+ unfold decidable; tauto ]).
Qed.
Theorem move_right_stable : forall s : step, prop_stable (move_right s).
-
-unfold move_right, prop_stable in |- *; intros s ep e p; split;
+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 Zegal_left; assumption
- | intro; apply Zle_left; assumption
- | intro; apply Zge_left; assumption
- | intro; apply Zgt_left; assumption
- | intro; apply Zlt_left; assumption
- | intro; apply Zne_left_2; assumption ]
+ [ 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 (Zplus_0_r_reverse (interp_term e t0)); rewrite H1;
- rewrite Zplus_permute; rewrite Zplus_opp_r;
- rewrite Zplus_0_r; trivial
- | apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t));
- rewrite Zplus_opp_r; assumption
- | apply Zle_ge;
- apply (fun a b : Z => Zplus_le_reg_r a b (- interp_term e t0));
- rewrite Zplus_opp_r; assumption
- | apply Zlt_gt; apply Zlt_left_inv; assumption
- | apply Zlt_left_inv; assumption
- | unfold Zne, not in |- *; unfold Zne in H1; intro H2; apply H1;
- rewrite H2; rewrite Zplus_opp_r; trivial ] ].
+ [ 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.
@@ -2521,9 +2985,8 @@ Fixpoint p_rewrite (s : p_step) : proposition -> proposition :=
end.
Theorem p_rewrite_stable : forall s : p_step, prop_stable (p_rewrite s).
-
-
-simple induction s; simpl in |- *;
+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
@@ -2539,8 +3002,8 @@ Fixpoint normalize_hyps (l : list h_step) (lh : hyps) {struct l} : hyps :=
Theorem normalize_hyps_valid :
forall l : list h_step, valid_hyps (normalize_hyps l).
-
-simple induction l; unfold valid_hyps in |- *; simpl in |- *;
+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;
@@ -2550,10 +3013,10 @@ simple induction l; unfold valid_hyps in |- *; simpl in |- *;
Qed.
Theorem normalize_hyps_goal :
- forall (s : list h_step) (ep : PropList) (env : list Z) (l : hyps),
+ 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.
-
-intros; apply valid_goal with (2 := H); apply normalize_hyps_valid.
+Proof.
+ intros; apply valid_goal with (2 := H); apply normalize_hyps_valid.
Qed.
Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} :
@@ -2604,18 +3067,18 @@ Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} :
end.
Definition co_valid1 (f : proposition -> proposition) :=
- forall (ep : PropList) (e : list Z) (p1 : 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).
-
-unfold valid1, co_valid1 in |- *; simple induction 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_ind2;
+ pattern (decidability p) in |- *; apply bool_eq_ind;
[ intro H; generalize (decidable_correct ep e p H);
unfold decidable in |- *; tauto
| simpl in |- *; auto ] ]
@@ -2623,12 +3086,11 @@ unfold valid1, co_valid1 in |- *; simple induction s;
case p; auto; simpl in |- *; intros;
(apply H1; tauto) ||
(apply H2; tauto) ||
- (pattern (decidability p0) in |- *; apply bool_ind2;
+ (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 :=
@@ -2655,13 +3117,13 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps :=
Theorem decompose_solve_valid :
forall s : e_step, valid_list_goal (decompose_solve s).
-
-intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim 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_ind2;
+ 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
@@ -2671,7 +3133,7 @@ intro s; apply goal_valid; unfold valid_list_hyps in |- *; elim s;
[ 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_ind2;
+ 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
@@ -2687,7 +3149,7 @@ Qed.
(* \subsection{La dernière étape qui élimine tous les séquents inutiles} *)
Definition valid_lhyps (f : lhyps -> lhyps) :=
- forall (ep : PropList) (e : list Z) (lp : 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 :=
@@ -2698,8 +3160,8 @@ Fixpoint reduce_lhyps (lp : lhyps) : lhyps :=
end.
Theorem reduce_lhyps_valid : valid_lhyps reduce_lhyps.
-
-unfold valid_lhyps in |- *; intros ep e lp; elim lp;
+Proof.
+ unfold valid_lhyps in |- *; intros ep e lp; elim lp;
[ simpl in |- *; auto
| intros a l HR; elim a;
[ simpl in |- *; tauto
@@ -2707,10 +3169,10 @@ unfold valid_lhyps in |- *; intros ep e lp; elim lp;
Qed.
Theorem do_reduce_lhyps :
- forall (envp : PropList) (env : list Z) (l : lhyps),
+ forall (envp : list Prop) (env : list int) (l : lhyps),
interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l.
-
-intros envp env l H; apply list_goal_to_hyps; intro H1;
+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.
@@ -2719,13 +3181,13 @@ Definition concl_to_hyp (p : proposition) :=
if decidability p then Tnot p else TrueTerm.
Definition do_concl_to_hyp :
- forall (envp : PropList) (env : list Z) (c : proposition) (l : hyps),
+ 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.
-
-simpl in |- *; intros envp env c l; induction l as [| a l Hrecl];
+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_ind2;
+ 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 ]
@@ -2737,12 +3199,19 @@ Definition omega_tactic (t1 : e_step) (t2 : list h_step)
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 : PropList)
- (env : list Z) (c : proposition) (l : hyps),
+ 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.
-
-unfold omega_tactic in |- *; intros; apply do_concl_to_hyp;
+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/contrib/romega/const_omega.ml b/contrib/romega/const_omega.ml
index 69b4b2de..bdec6bf4 100644
--- a/contrib/romega/const_omega.ml
+++ b/contrib/romega/const_omega.ml
@@ -48,64 +48,16 @@ let dest_const_apply t =
| _ -> raise Destruct
in Nametab.id_of_global ref, args
-let recognize_number 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 logic_dir = ["Coq";"Logic";"Decidable"]
let coq_modules =
Coqlib.init_modules @ [logic_dir] @ Coqlib.arith_modules @ Coqlib.zarith_base_modules
- @ [["Coq"; "omega"; "OmegaLemmas"]]
@ [["Coq"; "Lists"; "List"]]
@ [module_refl_path]
-
+ @ [module_refl_path@["ZOmega"]]
let constant = Coqlib.gen_constant_in_modules "Omega" coq_modules
-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_Lt = lazy (constant "Lt")
-let coq_Eq = lazy (constant "Eq")
-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")
-
-(* Peano *)
-let coq_le = lazy(constant "le")
-let coq_gt = lazy(constant "gt")
-
-(* Integers *)
-let coq_nat = lazy(constant "nat")
-let coq_S = lazy(constant "S")
-let coq_O = lazy(constant "O")
-let coq_minus = lazy(constant "minus")
-
(* Logic *)
let coq_eq = lazy(constant "eq")
let coq_refl_equal = lazy(constant "refl_equal")
@@ -114,15 +66,9 @@ let coq_not = lazy(constant "not")
let coq_or = lazy(constant "or")
let coq_True = lazy(constant "True")
let coq_False = lazy(constant "False")
-let coq_ex = lazy(constant "ex")
let coq_I = lazy(constant "I")
-(* Lists *)
-let coq_cons = lazy (constant "cons")
-let coq_nil = lazy (constant "nil")
-
-let coq_pcons = lazy (constant "Pcons")
-let coq_pnil = lazy (constant "Pnil")
+(* ReflOmegaCore/ZOmega *)
let coq_h_step = lazy (constant "h_step")
let coq_pair_step = lazy (constant "pair_step")
@@ -130,8 +76,6 @@ 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_p_nop = lazy (constant "P_NOP")
-
let coq_t_int = lazy (constant "Tint")
let coq_t_plus = lazy (constant "Tplus")
@@ -140,6 +84,7 @@ 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")
@@ -154,14 +99,6 @@ let coq_p_and = lazy (constant "Tand")
let coq_p_imp = lazy (constant "Timp")
let coq_p_prop = lazy (constant "Tprop")
-let coq_proposition = lazy (constant "proposition")
-let coq_interp_sequent = lazy (constant "interp_goal_concl")
-let coq_normalize_sequent = lazy (constant "normalize_goal")
-let coq_execute_sequent = lazy (constant "execute_goal")
-let coq_do_concl_to_hyp = lazy (constant "do_concl_to_hyp")
-let coq_sequent_to_hyps = lazy (constant "goal_to_hyps")
-let coq_normalize_hyps_goal = lazy (constant "normalize_hyps_goal")
-
(* Constructors for shuffle tactic *)
let coq_t_fusion = lazy (constant "t_fusion")
let coq_f_equal = lazy (constant "F_equal")
@@ -170,7 +107,6 @@ let coq_f_left = lazy (constant "F_left")
let coq_f_right = lazy (constant "F_right")
(* Constructors for reordering tactics *)
-let coq_step = lazy (constant "step")
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")
@@ -196,8 +132,7 @@ 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_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")
@@ -225,30 +160,11 @@ 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_decompose_solve_valid =
- lazy (constant "decompose_solve_valid")
-let coq_do_reduce_lhyps = lazy (constant "do_reduce_lhyps")
+let coq_interp_sequent = lazy (constant "interp_goal_concl")
let coq_do_omega = lazy (constant "do_omega")
(* \subsection{Construction d'expressions} *)
-
-let mk_var v = Term.mkVar (Names.id_of_string v)
-let mk_plus t1 t2 = Term.mkApp (Lazy.force coq_Zplus,[| t1; t2 |])
-let mk_times t1 t2 = Term.mkApp (Lazy.force coq_Zmult, [| t1; t2 |])
-let mk_minus t1 t2 = Term.mkApp (Lazy.force coq_Zminus, [| t1;t2 |])
-let mk_eq t1 t2 = Term.mkApp (Lazy.force coq_eq, [| Lazy.force coq_Z; t1; t2 |])
-let mk_le t1 t2 = Term.mkApp (Lazy.force coq_Zle, [|t1; t2 |])
-let mk_gt t1 t2 = Term.mkApp (Lazy.force coq_Zgt, [|t1; t2 |])
-let mk_inv t = Term.mkApp (Lazy.force coq_Zopp, [|t |])
-let mk_and t1 t2 = Term.mkApp (Lazy.force coq_and, [|t1; t2 |])
-let mk_or t1 t2 = Term.mkApp (Lazy.force coq_or, [|t1; t2 |])
-let mk_not t = Term.mkApp (Lazy.force coq_not, [|t |])
-let mk_eq_rel t1 t2 = Term.mkApp (Lazy.force coq_eq, [|
- Lazy.force coq_comparison; t1; t2 |])
-let mk_inj t = Term.mkApp (Lazy.force coq_Z_of_nat, [|t |])
-
-
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 |] )
@@ -272,27 +188,20 @@ let rec do_list = function
| [x] -> x
| (x::l) -> do_seq x (do_list l)
-let mk_integer n =
- let rec loop 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),
- [| loop q |]) in
-
- if n = Bigint.zero then Lazy.force coq_Z0
- else
- if Bigint.is_strictly_pos n then
- Term.mkApp (Lazy.force coq_Zpos, [| loop n |])
- else
- Term.mkApp (Lazy.force coq_Zneg, [| loop (Bigint.neg n) |])
+(* Nat *)
-let mk_Z = mk_integer
+let coq_S = lazy(constant "S")
+let coq_O = lazy(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
| [] ->
@@ -301,14 +210,141 @@ let mk_list typ l =
Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in
loop l
-let mk_plist l =
- let rec loop = function
- | [] ->
- (Lazy.force coq_pnil)
- | (step :: l) ->
- Term.mkApp (Lazy.force coq_pcons, [| 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/contrib/romega/const_omega.mli b/contrib/romega/const_omega.mli
new file mode 100644
index 00000000..0f00e918
--- /dev/null
+++ b/contrib/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/contrib/romega/g_romega.ml4 b/contrib/romega/g_romega.ml4
index 7cfc50f8..39b6c210 100644
--- a/contrib/romega/g_romega.ml4
+++ b/contrib/romega/g_romega.ml4
@@ -9,7 +9,34 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
open Refl_omega
+open Refiner
-TACTIC EXTEND romelga
- [ "romega" ] -> [ total_reflexive_omega_tactic ]
+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/contrib/romega/refl_omega.ml b/contrib/romega/refl_omega.ml
index e7e7b3c5..fc4f7a8f 100644
--- a/contrib/romega/refl_omega.ml
+++ b/contrib/romega/refl_omega.ml
@@ -6,10 +6,7 @@
*************************************************************************)
-(* The addition on int, since it while be hidden soon by the one on BigInt *)
-
-let (+.) = (+)
-
+open Util
open Const_omega
module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
open OmegaSolver
@@ -26,65 +23,6 @@ let pp i = print_int i; print_newline (); flush stdout
(* More readable than the prefix notation *)
let (>>) = Tacticals.tclTHEN
-(* [list_index t l = i] \eqv $nth l i = t \wedge \forall j < i nth l j != t$ *)
-
-let list_index t =
- let rec loop i = function
- | (u::l) -> if u = t then i else loop (succ i) l
- | [] -> raise Not_found in
- loop 0
-
-(* [list_uniq l = filter_i (x i -> nth l (i-1) != x) l] *)
-let list_uniq l =
- let rec uniq = function
- x :: ((y :: _) as l) when x = y -> uniq l
- | x :: l -> x :: uniq l
- | [] -> [] in
- uniq (List.sort compare l)
-
-(* $\forall x. mem x (list\_union l1 l2) \eqv x \in \{l1\} \cup \{l2\}$ *)
-let list_union l1 l2 =
- let rec loop buf = function
- x :: r -> if List.mem x l2 then loop buf r else loop (x :: buf) r
- | [] -> buf in
- loop l2 l1
-
-(* $\forall x.
- mem \;\; x \;\; (list\_intersect\;\; l1\;\;l2) \eqv x \in \{l1\}
- \cap \{l2\}$ *)
-let list_intersect l1 l2 =
- let rec loop buf = function
- x :: r -> if List.mem x l2 then loop (x::buf) r else loop buf r
- | [] -> buf in
- loop [] l1
-
-(* cartesian product. Elements are lists and are concatenated.
- $cartesian [x_1 ... x_n] [y_1 ... y_p] = [x_1 @ y_1, x_2 @ y_1 ... x_n @ y_1 , x_1 @ y_2 ... x_n @ y_p]$ *)
-
-let rec cartesien l1 l2 =
- let rec loop = function
- (x2 :: r2) -> List.map (fun x1 -> x1 @ x2) l1 @ loop r2
- | [] -> [] in
- loop l2
-
-(* remove element e from list l *)
-let list_remove e l =
- let rec loop = function
- x :: l -> if x = e then loop l else x :: loop l
- | [] -> [] in
- loop l
-
-(* equivalent of the map function but no element is added when the function
- raises an exception (and the computation silently continues) *)
-let map_exc f =
- let rec loop = function
- (x::l) ->
- begin match try Some (f x) with exc -> None with
- Some v -> v :: loop l | None -> loop l
- end
- | [] -> [] in
- loop
-
let mkApp = Term.mkApp
(* \section{Types}
@@ -174,6 +112,7 @@ type environment = {
(* \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;
@@ -280,7 +219,7 @@ let unintern_omega env id =
calcul des variables utiles. *)
let add_reified_atom t env =
- try list_index t env.terms
+ try list_index0 t env.terms
with Not_found ->
let i = List.length env.terms in
env.terms <- env.terms @ [t]; i
@@ -291,7 +230,7 @@ let get_reified_atom env =
(* \subsection{Gestion de l'environnement de proposition pour Omega} *)
(* ajout d'une proposition *)
let add_prop env t =
- try list_index t env.props
+ try list_index0 t env.props
with Not_found ->
let i = List.length env.props in env.props <- env.props @ [t]; i
@@ -362,13 +301,6 @@ let omega_of_oformula env kind =
(* \subsection{Omega vers Oformula} *)
-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 oformula_of_omega env af =
let rec loop = function
| ({v=v; c=n}::r) ->
@@ -382,20 +314,27 @@ let app f v = mkApp(Lazy.force f,v)
let rec coq_of_formula env t =
let rec loop = function
- | Oplus (t1,t2) -> app coq_Zplus [| loop t1; loop t2 |]
- | Oopp t -> app coq_Zopp [| loop t |]
- | Omult(t1,t2) -> app coq_Zmult [| loop t1; loop t2 |]
- | Oint v -> mk_Z v
+ | 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 coq_Zminus [| loop t1; loop t2 |] in
+ | 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 |]
@@ -403,7 +342,7 @@ let rec reified_of_formula env = function
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 [| mk_Z v |]
+ | 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) ->
@@ -448,12 +387,12 @@ let reified_of_proposition env f =
let reified_of_omega env body constant =
let coeff_constant =
- app coq_t_int [| mk_Z constant |] in
+ 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 [| mk_Z c |] |] in
+ app coq_t_int [| Z.mk c |] |] in
app coq_t_plus [|coef; t |] in
List.fold_right mk_coeff body coeff_constant
@@ -469,22 +408,34 @@ 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 *)
+(* 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)
+ | 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 vars_of_equations l =
- let rec loop = function
- e :: l -> vars_of_formula e.e_left @ vars_of_formula e.e_right @ loop l
- | [] -> [] in
- list_uniq (List.sort compare (loop l))
+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} *)
@@ -715,36 +666,23 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) =
(* \section{Compilation des hypothèses} *)
-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"),[t]) -> aux t
- | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize_number t in true
- | _ -> false in
- try aux t with _ -> false
-
let rec oformula_of_constr env t =
- try match destructurate t with
- | Kapp("Zplus",[t1;t2]) -> binop env (fun x y -> Oplus(x,y)) t1 t2
- | Kapp("Zminus",[t1;t2]) -> binop env (fun x y -> Ominus(x,y)) t1 t2
- | Kapp("Zmult",[t1;t2]) when is_scalar t1 or is_scalar t2 ->
- binop env (fun x y -> Omult(x,y)) t1 t2
- | Kapp("Zopp",[t]) -> Oopp(oformula_of_constr env t)
- | Kapp("Zsucc",[t]) -> Oplus(oformula_of_constr env t, Oint one)
- | Kapp(("Zpos"|"Zneg"|"Z0"),_) ->
- begin try Oint(recognize_number t)
- with _ -> Oatom (add_reified_atom t env) end
- | _ ->
- Oatom (add_reified_atom t env)
- with e when Logic.catchable_exception e ->
- 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)
+ 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
@@ -767,40 +705,32 @@ and mk_equation env ctxt c connector t1 t2 =
Pequa (c,omega)
and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c =
- try match destructurate c with
- | Kapp("eq",[typ;t1;t2])
- when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) ->
- mk_equation env ctxt c Eq t1 t2
- | Kapp("Zne",[t1;t2]) ->
- mk_equation env ctxt c Neq t1 t2
- | Kapp("Zle",[t1;t2]) ->
- mk_equation env ctxt c Leq t1 t2
- | Kapp("Zlt",[t1;t2]) ->
- mk_equation env ctxt c Lt t1 t2
- | Kapp("Zge",[t1;t2]) ->
- mk_equation env ctxt c Geq t1 t2
- | Kapp("Zgt",[t1;t2]) ->
- mk_equation env ctxt c Gt t1 t2
- | Kapp("True",[]) -> Ptrue
- | Kapp("False",[]) -> Pfalse
- | Kapp("not",[t]) ->
- let t' =
- oproposition_of_constr
- env (not negated, depends, origin,(O_mono::path)) gl t in
- Pnot t'
- | Kapp("or",[t1;t2]) ->
+ 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
- | Kapp("and",[t1;t2]) ->
+ | Rand (t1,t2) ->
binprop env ctxt negated negated gl
(fun i x y -> Pand(i,x,y)) t1 t2
- | Kimp(t1,t2) ->
+ | Rimp (t1,t2) ->
binprop env ctxt (not negated) (not negated) gl
(fun i x y -> Pimp(i,x,y)) t1 t2
- | Kapp("iff",[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
- with e when Logic.catchable_exception e -> Pprop c
(* Destructuration des hypothèses et de la conclusion *)
@@ -881,7 +811,7 @@ let destructurate_hyps syst =
(i,t) :: l ->
let l_syst1 = destructurate_pos_hyp i [] [] t in
let l_syst2 = loop l in
- cartesien l_syst1 l_syst2
+ list_cartesian (@) l_syst1 l_syst2
| [] -> [[]] in
loop syst
@@ -924,9 +854,9 @@ let display_systems syst_list =
let rec hyps_used_in_trace = function
| act :: l ->
begin match act with
- | HYP e -> e.id :: hyps_used_in_trace l
+ | 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 act1 @@ hyps_used_in_trace act2
| _ -> hyps_used_in_trace l
end
| [] -> []
@@ -950,14 +880,15 @@ let rec variable_stated_in_trace = function
;;
let add_stated_equations env tree =
- let rec loop = function
- Tree(_,t1,t2) ->
- list_union (loop t1) (loop t2)
- | Leaf s -> variable_stated_in_trace s.s_trace in
(* Il faut trier les variables par ordre d'introduction pour ne pas risquer
de définir dans le mauvais ordre *)
let stated_equations =
- List.sort (fun x y -> Pervasives.(-) x.st_var y.st_var) (loop tree) in
+ 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
@@ -966,7 +897,7 @@ let add_stated_equations env tree =
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 coq_Z; coq_v|] in
+ 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
@@ -978,10 +909,15 @@ let add_stated_equations env tree =
(* 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 l (get_eclatement env r)
+ list_union (List.rev l) (get_eclatement env r)
| [] -> []
let select_smaller l =
@@ -992,14 +928,13 @@ 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 raise Exit
+ else if List.mem (barre x) required then failwith "Exit"
else x :: select l
| [] -> [] in
- map_exc (function (sol,splits) -> (sol,select splits)) systems
+ map_succeed (function (sol,splits) -> (sol,select splits)) systems
let rec equas_of_solution_tree = function
- Tree(_,t1,t2) ->
- list_union (equas_of_solution_tree t1) (equas_of_solution_tree t2)
+ 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 *)
@@ -1041,14 +976,6 @@ let really_useful_prop l_equa c =
None -> Pprop (real_of c)
| Some t -> t
-let rec vars_of_prop = function
- | Pequa(_,e) -> vars_of_equations [e]
- | Pnot p -> vars_of_prop p
- | Por(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2)
- | Pand(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2)
- | Pimp(_,p1,p2) -> list_union (vars_of_prop p1) (vars_of_prop p2)
- | _ -> []
-
let rec display_solution_tree ch = function
Leaf t ->
output_string ch
@@ -1103,7 +1030,7 @@ let mk_direction_list l =
(* \section{Rejouer l'historique} *)
let get_hyp env_hyp i =
- try list_index (CCEqua i) env_hyp
+ try list_index0 (CCEqua i) env_hyp
with Not_found -> failwith (Printf.sprintf "get_hyp %d" i)
let replay_history env env_hyp =
@@ -1116,7 +1043,7 @@ let replay_history env env_hyp =
mk_nat (get_hyp env_hyp e2.id) |])
| DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
mkApp (Lazy.force coq_s_div_approx,
- [| mk_Z k; mk_Z d;
+ [| 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) |])
@@ -1125,7 +1052,7 @@ let replay_history env env_hyp =
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,
- [|mk_Z k; mk_Z d;
+ [|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)|])
@@ -1134,7 +1061,7 @@ let replay_history env env_hyp =
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,
- [|mk_Z k;
+ [|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)|])
@@ -1149,7 +1076,7 @@ let replay_history env env_hyp =
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,
- [| mk_Z k1; mk_nat n1; mk_Z k2;
+ [| 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,
@@ -1169,7 +1096,7 @@ let replay_history env env_hyp =
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,
- [| mk_Z m; trace; mk_nat n1; mk_nat n2;
+ [| 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 ->
@@ -1267,17 +1194,17 @@ let resolution env full_reified_goal systems_list =
print_newline()
end;
(* calcule la liste de toutes les hypothèses utilisées dans l'arbre de solution *)
- let useful_equa_id = list_uniq (equas_of_solution_tree solution_tree) in
+ 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_uniq (List.map (fun e -> e.e_origin.o_hyp) equations) 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
- list_uniq (List.sort compare (really_useful_vars @ concl_vars))
+ really_useful_vars @@ concl_vars
in
(* variables a introduire *)
let to_introduce = add_stated_equations env solution_tree in
@@ -1295,7 +1222,7 @@ let resolution env full_reified_goal systems_list =
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 coq_Z) basic_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),_) ->
@@ -1325,10 +1252,10 @@ let resolution env full_reified_goal systems_list =
| ((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_index e.e_origin.o_hyp l_hyps in
+ 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 i +. List.length to_introduce
+ 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 =
diff --git a/contrib/rtauto/Bintree.v b/contrib/rtauto/Bintree.v
index f4b24d4b..e90fea84 100644
--- a/contrib/rtauto/Bintree.v
+++ b/contrib/rtauto/Bintree.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: Bintree.v 8881 2006-05-31 18:16:34Z jforest $ *)
+(* $Id: Bintree.v 10681 2008-03-16 13:40:45Z msozeau $ *)
Require Export List.
Require Export BinPos.
@@ -20,15 +20,6 @@ Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t.
Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop.
-Lemma Prect : forall P : positive -> Type,
- P 1 ->
- (forall n : positive, P n -> P (Psucc n)) -> forall p : positive, P p.
-intros P H1 Hsucc n; induction n.
-rewrite <- plus_iter_xI; apply Hsucc; apply iterate_add; assumption.
-rewrite <- plus_iter_xO; apply iterate_add; assumption.
-assumption.
-Qed.
-
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));
@@ -116,7 +107,7 @@ intro ne;right;congruence.
left;reflexivity.
Defined.
-Theorem pos_eq_dec_refl : forall m, pos_eq_dec m m = left (m<>m) (refl_equal m) .
+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.
@@ -125,7 +116,7 @@ Qed.
Theorem pos_eq_dec_ex : forall m n,
pos_eq m n =true -> exists h:m=n,
- pos_eq_dec m n = left (m<>n) h.
+ 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).
diff --git a/contrib/rtauto/refl_tauto.ml b/contrib/rtauto/refl_tauto.ml
index a1f5e5aa..81256f4a 100644
--- a/contrib/rtauto/refl_tauto.ml
+++ b/contrib/rtauto/refl_tauto.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: refl_tauto.ml 9154 2006-09-20 17:18:18Z corbinea $ *)
+(* $Id: refl_tauto.ml 10478 2008-01-29 10:31:39Z notin $ *)
module Search = Explore.Make(Proof_search)
@@ -292,7 +292,7 @@ let rtauto_tac gls=
let prf =
try project (search_fun (init_state [] formula))
with Not_found ->
- errorlabstrm "rtauto" (Pp.str "rtauto could'nt find any proof") in
+ errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in
let search_end_time = System.get_time () in
let _ = if !verbose then
begin
diff --git a/contrib/setoid_ring/ArithRing.v b/contrib/setoid_ring/ArithRing.v
index 074f6ef7..601cabe0 100644
--- a/contrib/setoid_ring/ArithRing.v
+++ b/contrib/setoid_ring/ArithRing.v
@@ -32,7 +32,7 @@ Qed.
Ltac natcst t :=
match isnatcst t with
true => constr:(N_of_nat t)
- | _ => InitialRing.NotConstant
+ | _ => constr:InitialRing.NotConstant
end.
Ltac Ss_to_add f acc :=
diff --git a/contrib/setoid_ring/Field_tac.v b/contrib/setoid_ring/Field_tac.v
index aad3a580..cccee604 100644
--- a/contrib/setoid_ring/Field_tac.v
+++ b/contrib/setoid_ring/Field_tac.v
@@ -67,12 +67,12 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv :=
end
in TFV t fv.
-Ltac ParseFieldComponents lemma :=
+Ltac ParseFieldComponents lemma req :=
match type of lemma with
| context [
(* PCond _ _ _ _ _ _ _ _ _ _ _ -> *)
- (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
- ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) ] =>
+ req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv
+ ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] =>
(fun f => f radd rmul rsub ropp rdiv rinv rpow C)
| _ => fail 1 "field anomaly: bad correctness lemma (parse)"
end.
@@ -119,18 +119,18 @@ Ltac Field_norm_gen f Cst_tac Pow_tac lemma Cond_lemma req n lH rl :=
let prh := proofHyp_tac lH in
pose (vlpe := lpe);
match type of lemma with
- | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?ceqb _] =>
+ | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _] =>
compute_assertion vlmp_eq vlmp
- (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe);
+ (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe);
(assert (rr_lemma := lemma n vlpe fv prh vlmp vlmp_eq)
- || fail "type error when build the rewriting lemma");
+ || fail 1 "type error when build the rewriting lemma");
RW_tac rr_lemma;
try clear rr_lemma vlmp_eq vlmp vlpe
| _ => fail 1 "field_simplify anomaly: bad correctness lemma"
end in
ReflexiveRewriteTactic mkFFV mkFE simpl_field lemma_tac fv rl;
try (apply Cond_lemma; simpl_PCond req) in
- ParseFieldComponents lemma Main.
+ ParseFieldComponents lemma req Main.
Ltac Field_simplify_gen f :=
fun req cst_tac pow_tac _ _ field_simplify_ok _ cond_ok pre post lH rl =>
@@ -141,33 +141,35 @@ Ltac Field_simplify_gen f :=
Ltac Field_simplify := Field_simplify_gen ltac:(fun H => rewrite H).
-Tactic Notation (at level 0)
- "field_simplify" constr_list(rl) :=
- match goal with [|- ?G] => field_lookup Field_simplify [] rl [G] end.
+Tactic Notation (at level 0) "field_simplify" constr_list(rl) :=
+ let G := Get_goal in
+ field_lookup Field_simplify [] rl G.
Tactic Notation (at level 0)
"field_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
- match goal with [|- ?G] => field_lookup Field_simplify [lH] rl [G] end.
+ let G := Get_goal in
+ field_lookup Field_simplify [lH] rl G.
Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):=
- let G := getGoal in
- let t := type of H in
- let g := fresh "goal" in
- set (g:= G);
- generalize H;clear H;
- field_lookup 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 := getGoal in
- let t := type of H in
- let g := fresh "goal" in
- set (g:= G);
- generalize H;clear H;
- field_lookup Field_simplify [lH] rl [t];
- intro H;
- unfold g;clear g.
+ let G := Get_goal in
+ let t := type of H in
+ let g := fresh "goal" in
+ set (g:= G);
+ generalize H;clear H;
+ field_lookup 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);
+ generalize H;clear H;
+ field_lookup Field_simplify [lH] rl t;
+ intro H;
+ unfold g;clear g.
(*
Ltac Field_simplify_in hyp:=
@@ -176,12 +178,12 @@ Ltac Field_simplify_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].
+ 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].
+ field_lookup (Field_simplify_in h) [lH] rl t.
*)
(** Generic tactic for solving equations *)
@@ -224,7 +226,7 @@ Ltac Field_Scheme Simpl_tac Cst_tac Pow_tac lemma Cond_lemma req n lH :=
[ Simpl_tac | apply Cond_lemma; simpl_PCond req]);
clear vlpe nlemma in
OnEquation req Main_eq in
- ParseFieldComponents lemma Main.
+ ParseFieldComponents lemma req Main.
(* solve completely a field equation, leaving non-zero conditions to be
proved (field) *)
@@ -239,14 +241,15 @@ Ltac FIELD :=
post().
Tactic Notation (at level 0) "field" :=
- let G := getGoal in field_lookup FIELD [] [G].
+ let G := Get_goal in
+ field_lookup FIELD [] G.
Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" :=
- let G := getGoal in field_lookup FIELD [lH] [G].
+ let G := Get_goal in
+ field_lookup 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 :=
let Simpl := (protect_fv "field") in
fun req cst_tac pow_tac _ field_simplify_eq_ok _ _ cond_ok pre post lH rl =>
@@ -256,17 +259,19 @@ Ltac FIELD_SIMPL :=
post().
Tactic Notation (at level 0) "field_simplify_eq" :=
- let G := getGoal in field_lookup FIELD_SIMPL [] [G].
+ let G := Get_goal in
+ field_lookup FIELD_SIMPL [] G.
Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" :=
- let G := getGoal in field_lookup FIELD_SIMPL [lH] [G].
+ let G := Get_goal in
+ field_lookup FIELD_SIMPL [lH] G.
(* Same as FIELD_SIMPL but in hypothesis *)
Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH :=
let Main radd rmul rsub ropp rdiv rinv rpow C :=
let hyp := fresh "hyp" in
- intro hyp;
+ intro hyp;
match type of hyp with
| req ?t1 ?t2 =>
let mkFV := FV Cst_tac Pow_tac radd rmul rsub ropp rpow in
@@ -306,7 +311,7 @@ Ltac Field_simplify_eq Cst_tac Pow_tac lemma Cond_lemma req n lH :=
clear hyp
end)
end in
- ParseFieldComponents lemma Main.
+ ParseFieldComponents lemma req Main.
Ltac FIELD_SIMPL_EQ :=
fun req cst_tac pow_tac _ _ _ lemma cond_ok pre post lH rl =>
@@ -318,7 +323,7 @@ Ltac FIELD_SIMPL_EQ :=
Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) :=
let t := type of H in
generalize H;
- field_lookup FIELD_SIMPL_EQ [] [t];
+ field_lookup FIELD_SIMPL_EQ [] t;
[ try exact I
| clear H;intro H].
@@ -327,7 +332,7 @@ Tactic Notation (at level 0)
"field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) :=
let t := type of H in
generalize H;
- field_lookup FIELD_SIMPL_EQ [lH] [t];
+ field_lookup FIELD_SIMPL_EQ [lH] t;
[ try exact I
|clear H;intro H].
@@ -347,59 +352,55 @@ Ltac coerce_to_almost_field set ext f :=
| semi_field_theory _ _ _ _ _ _ _ => constr:(SF2AF set f)
end.
-Ltac field_elements set ext fspec pspec sspec rk :=
+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 rk
- ltac:(fun arth ext_r morph p_spec s_spec f => f afth ext_r morph p_spec s_spec).
-
-Ltac field_lemmas set ext inv_m fspec pspec sspec rk :=
- let simpl_eq_lemma :=
- match pspec with
- | None => constr:(Field_simplify_eq_correct)
- | Some _ => constr:(Field_simplify_eq_pow_correct)
- end in
- let simpl_eq_in_lemma :=
- match pspec with
- | None => constr:(Field_simplify_eq_in_correct)
- | Some _ => constr:(Field_simplify_eq_pow_in_correct)
- end in
- let rw_lemma :=
- match pspec with
- | None => constr:(Field_rw_correct)
- | Some _ => constr:(Field_rw_pow_correct)
- end in
- field_elements set ext fspec pspec sspec rk
- ltac:(fun afth ext_r morph p_spec s_spec =>
- match p_spec with
- | mkhypo ?pp_spec => match s_spec with
- | mkhypo ?ss_spec =>
- let field_simpl_eq_ok :=
- constr:(simpl_eq_lemma _ _ _ _ _ _ _ _ _ _
+ 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) in
- let field_simpl_ok :=
- constr:(rw_lemma _ _ _ _ _ _ _ _ _ _
- set ext_r inv_m afth
- _ _ _ _ _ _ _ _ _ morph
- _ _ _ pp_spec _ ss_spec) in
- let field_simpl_eq_in :=
- constr:(simpl_eq_in_lemma _ _ _ _ _ _ _ _ _ _
- set ext_r inv_m afth
- _ _ _ _ _ _ _ _ _ morph
- _ _ _ pp_spec _ ss_spec) in
- let field_ok :=
- constr:(Field_correct set ext_r inv_m afth morph pp_spec ss_spec) in
- let cond1_ok :=
- constr:(Pcond_simpl_gen set ext_r afth morph pp_spec) in
- let cond2_ok :=
- constr:(Pcond_simpl_complete set ext_r afth morph pp_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 2 "bad sign specification"
- end
- | _ => fail 1 "bad power specification"
+ _ _ _ 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/contrib/setoid_ring/Field_theory.v b/contrib/setoid_ring/Field_theory.v
index ea8421cf..65a397ac 100644
--- a/contrib/setoid_ring/Field_theory.v
+++ b/contrib/setoid_ring/Field_theory.v
@@ -74,7 +74,7 @@ Qed.
Notation "[ x ]" := (phi x) (at level 0).
- (* Usefull tactics *)
+ (* 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.
@@ -102,10 +102,13 @@ Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth)
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 ropp req phi get_sign.
+ 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).
+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).
@@ -300,7 +303,30 @@ transitivity (r2 * (r1 / r2) * (r4 * (r3 / r4))); [ ring | idtac ].
repeat rewrite rdiv_simpl in |- *; trivial.
Qed.
- Theorem rdiv7:
+ 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 ->
@@ -313,6 +339,29 @@ 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.
@@ -331,8 +380,7 @@ transitivity (r1 / r2 * (r4 / r4)).
rewrite H1 in |- *.
rewrite (ARmul_comm ARth r2 r4) in |- *.
rewrite <- rdiv4 in |- *; trivial.
- rewrite rdiv_r_r in |- *.
- trivial.
+ rewrite rdiv_r_r in |- * by trivial.
apply (ARmul_1_r Rsth ARth).
Qed.
@@ -395,7 +443,7 @@ Add Morphism (pow_pos rmul) : 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) : pow_N_morph.
+Add Morphism (pow_N rI rmul) with signature req ==> (@eq N) ==> req as pow_N_morph.
intros x y H [|p];simpl;auto. apply pow_morph;trivial.
Qed.
(*
@@ -451,7 +499,7 @@ 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)].
+ try (ring [(morph0 CRmorph)]).
apply (morph_add CRmorph).
Qed.
@@ -613,6 +661,8 @@ Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R :=
| FEpow x n => rpow (FEeval l x) (Cp_phi n)
end.
+Strategy expand [FEeval].
+
(* The result of the normalisation *)
Record linear : Type := mk_linear {
@@ -732,7 +782,7 @@ Proof.
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;[trivial | ring [ (morph1 CRmorph)]].
+ 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.
@@ -813,7 +863,7 @@ destruct n.
(Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z.
change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z).
rewrite <- Zplus_assoc. rewrite (Zplus_assoc (- Zpos p4)).
- simpl. rewrite Pcompare_refl. reflexivity.
+ 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).
@@ -961,8 +1011,10 @@ Fixpoint Fnorm (e : FExpr) : linear :=
| FEmul e1 e2 =>
let x := Fnorm e1 in
let y := Fnorm e2 in
- mk_linear (NPEmul (num x) (num y))
- (NPEmul (denum x) (denum y))
+ 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
@@ -973,8 +1025,10 @@ Fixpoint Fnorm (e : FExpr) : linear :=
| FEdiv e1 e2 =>
let x := Fnorm e1 in
let y := Fnorm e2 in
- mk_linear (NPEmul (num x) (denum y))
- (NPEmul (denum x) (num y))
+ 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
@@ -996,10 +1050,11 @@ 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). rewrite H1. rewrite Hp;ring. ring.
- reflexivity.
+ 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).
- rewrite Hp;ring. reflexivity. trivial.
+ reflexivity. rewrite Hp;ring. trivial.
Qed.
Theorem Pcond_Fnorm:
@@ -1040,10 +1095,14 @@ intros l e; elim e.
rewrite NPEmul_correct in |- *.
simpl in |- *.
apply field_is_integral_domain.
- apply Hrec1.
+ intros HH; apply Hrec1.
apply PCond_app_inv_l with (1 := Hcond).
- apply Hrec2.
+ 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 |- *.
@@ -1058,10 +1117,14 @@ intros l e; elim e.
rewrite NPEmul_correct in |- *.
simpl in |- *.
apply field_is_integral_domain.
- apply Hrec1.
+ intros HH; apply Hrec1.
specialize PCond_cons_inv_r with (1:=Hcond); intro Hcond1.
apply PCond_app_inv_l with (1 := Hcond1).
- apply PCond_cons_inv_l with (1:=Hcond).
+ 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).
@@ -1124,7 +1187,16 @@ assert (HH2: PCond l (condition (Fnorm e2))).
apply PCond_app_inv_r with ( 1 := HH ).
rewrite (He1 HH1); rewrite (He2 HH2).
repeat rewrite NPEmul_correct; simpl.
-apply rdiv4; auto.
+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.
@@ -1144,8 +1216,18 @@ apply PCond_app_inv_r with (condition (Fnorm e1)).
apply PCond_cons_inv_r with ( 1 := HH ).
rewrite (He1 HH1); rewrite (He2 HH2).
repeat rewrite NPEmul_correct;simpl.
-apply rdiv7; auto.
+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).
@@ -1155,13 +1237,15 @@ 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).
-intro Hp;apply (pow_pos_not_0 Hdiff p).
+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).
- apply pow_pos_not_0;trivial. ring [Hp]. reflexivity.
-apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
-rewrite IHp;reflexivity.
-rewrite <- rdiv4;trivial. apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial.
+ 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.
@@ -1174,9 +1258,9 @@ Theorem Fnorm_crossproduct:
PCond l (condition nfe1 ++ condition nfe2) ->
FEeval l fe1 == FEeval l fe2.
intros l fe1 fe2 nfe1 nfe2 Hcrossprod Hcond; subst nfe1 nfe2.
-rewrite Fnorm_FEeval_PEeval in |- *.
+rewrite Fnorm_FEeval_PEeval in |- * by
apply PCond_app_inv_l with (1 := Hcond).
- rewrite Fnorm_FEeval_PEeval in |- *.
+ rewrite Fnorm_FEeval_PEeval in |- * by
apply PCond_app_inv_r with (1 := Hcond).
apply cross_product_eq; trivial.
apply Pcond_Fnorm.
@@ -1187,7 +1271,7 @@ 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).
+Notation Nmk_monpol_list := (mk_monpol_list cO cI cadd cmul csub copp ceqb cdiv).
Theorem Fnorm_correct:
forall n l lpe fe,
@@ -1198,7 +1282,7 @@ 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 n l lpe);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.
@@ -1270,9 +1354,9 @@ 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 get_sign_spec
+ 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 get_sign_spec
+ 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.
@@ -1303,14 +1387,14 @@ 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 get_sign_spec n lpe l
+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 get_sign_spec n lpe l
+ 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.
@@ -1343,14 +1427,14 @@ 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 get_sign_spec n lpe l
+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 get_sign_spec n lpe l
+ 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.
@@ -1394,18 +1478,18 @@ Proof.
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. trivial.
+ 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. trivial.
+ 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_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ H7).
+ 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 :
@@ -1444,18 +1528,18 @@ Proof.
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. trivial.
+ 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. trivial.
+ 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_l _ _ _ H7). apply (PCond_app_inv_r _ _ _ H7).
+ apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7).
Qed.
@@ -1524,7 +1608,7 @@ Theorem PFcons0_fcons_inv:
intros l a l1; elim l1; simpl Fcons0; auto.
simpl; auto.
intros a0 l0.
-generalize (ring_correct Rsth Reqe ARth CRmorph pow_th O l nil a a0). simpl.
+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.
diff --git a/contrib/setoid_ring/InitialRing.v b/contrib/setoid_ring/InitialRing.v
index f5f845c2..c1fa963f 100644
--- a/contrib/setoid_ring/InitialRing.v
+++ b/contrib/setoid_ring/InitialRing.v
@@ -13,13 +13,13 @@ 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.
@@ -101,19 +101,19 @@ Section ZMORPHISM.
| _ => None
end.
- Lemma get_signZ_th : sign_theory ropp req gen_phiZ get_signZ.
+ 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;rrefl.
+ 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 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+ 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.
@@ -161,7 +161,7 @@ Section ZMORPHISM.
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 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+ Ltac norm := gen_srewrite Rsth Reqe ARth.
Ltac add_push := gen_add_push radd Rsth Reqe ARth.
(*morphisms are extensionaly equal*)
@@ -243,7 +243,7 @@ Section ZMORPHISM.
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 Zsth Zth SRmorph gen_phiZ_ext).
+ apply (Smorph_morph Rsth Reqe Rth Zth SRmorph gen_phiZ_ext).
Qed.
End ZMORPHISM.
@@ -317,8 +317,8 @@ Section NMORPHISM.
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 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
-
+ Ltac norm := gen_srewrite Rsth Reqe ARth.
+
Definition gen_phiN1 x :=
match x with
| N0 => 0
@@ -433,7 +433,7 @@ Section NWORDMORPHISM.
Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req.
Add Morphism rsub : rsub_ext7. exact (ARsub_ext Rsth Reqe ARth). Qed.
- Ltac norm := gen_srewrite 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+ Ltac norm := gen_srewrite Rsth Reqe ARth.
Ltac add_push := gen_add_push radd Rsth Reqe ARth.
Fixpoint gen_phiNword (w : Nword) : R :=
@@ -515,12 +515,12 @@ induction x; intros.
simpl Nwadd in |- *.
repeat rewrite gen_phiNword_cons in |- *.
- rewrite (fun sreq => gen_phiN_add Rsth sreq (ARth_SRth ARth)) in |- *.
- destruct Reqe; constructor; trivial.
+ 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.
+ rewrite IHx in |- *.
+ norm.
+ add_push (- gen_phiNword x); reflexivity.
Qed.
Lemma Nwopp_ok : forall x, gen_phiNword (Nwopp x) == - gen_phiNword x.
@@ -537,8 +537,8 @@ induction x; intros.
simpl Nwscal in |- *.
repeat rewrite gen_phiNword_cons in |- *.
- rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- *.
- destruct Reqe; constructor; trivial.
+ rewrite (fun sreq => gen_phiN_mult Rsth sreq (ARth_SRth ARth)) in |- *
+ by (destruct Reqe; constructor; trivial).
rewrite IHx in |- *.
norm.
@@ -592,7 +592,70 @@ 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 *)
@@ -604,17 +667,17 @@ End NWORDMORPHISM.
| (add rI (add rI rI)) => constr:3%positive
| (mul (add rI rI) ?p) => (* 2p *)
match inv_cst p with
- NotConstant => NotConstant
- | 1%positive => NotConstant (* 2*1 is not convertible to 2 *)
+ 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 => NotConstant
- | 1%positive => NotConstant
+ NotConstant => constr:NotConstant
+ | 1%positive => constr:NotConstant
| ?p => constr:(xI p)
end
- | _ => NotConstant
+ | _ => constr:NotConstant
end in
inv_cst t.
@@ -624,7 +687,7 @@ End NWORDMORPHISM.
rO => constr:NwO
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => NotConstant
+ NotConstant => constr:NotConstant
| ?p => constr:(Npos p::nil)
end
end.
@@ -636,7 +699,7 @@ End NWORDMORPHISM.
rO => constr:0%N
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => NotConstant
+ NotConstant => constr:NotConstant
| ?p => constr:(Npos p)
end
end.
@@ -647,12 +710,12 @@ End NWORDMORPHISM.
rO => constr:0%Z
| (opp ?p) =>
match inv_gen_phi_pos rI add mul p with
- NotConstant => NotConstant
+ NotConstant => constr:NotConstant
| ?p => constr:(Zneg p)
end
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => NotConstant
+ NotConstant => constr:NotConstant
| ?p => constr:(Zpos p)
end
end.
@@ -668,7 +731,7 @@ Ltac inv_gen_phi rO rI cO cI t :=
end.
(* A simple tactic recognizing no constant *)
- Ltac inv_morph_nothing t := constr:(NotConstant).
+ Ltac inv_morph_nothing t := constr:NotConstant.
Ltac coerce_to_almost_ring set ext rspec :=
match type of rspec with
@@ -710,31 +773,42 @@ Ltac gen_ring_pow set arth pspec :=
| Some ?t => constr:(t)
end.
-Ltac default_sign_spec morph :=
+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 (@get_sign_None_th R ropp req C phi))
+ constr:(mkhypo (triv_div_th set reqe arth morph))
| _ => fail 1 "ring anomaly : default_sign_spec"
end.
-Ltac gen_ring_sign set rspec morph sspec rk :=
- match sspec with
- | None =>
- match rk with
- | Abstract =>
- match type of rspec with
- | @ring_theory ?R ?rO ?rI ?radd ?rmul ?rsub ?ropp ?req =>
- constr:(mkhypo (@get_signZ_th R rO rI radd rmul ropp req set))
- | _ => default_sign_spec morph
- end
- | _ => default_sign_spec morph
- 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 rk :=
+
+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 :=
@@ -756,42 +830,54 @@ Ltac ring_elements set ext rspec pspec sspec rk :=
| _ => fail 1 "ill-formed ring kind"
end in
let p_spec := gen_ring_pow set arth pspec in
- let s_spec := gen_ring_sign set rspec morph sspec rk in
- fun f => f arth ext_r morph p_spec s_spec.
+ 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 rk :=
+
+ 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 rk
- ltac:(fun arth ext_r morph p_spec s_spec =>
- match p_spec with
- | mkhypo ?pp_spec =>
- match s_spec with
- | mkhypo ?ps_spec =>
- let lemma1 :=
- constr:(ring_correct set ext_r arth morph pp_spec) in
- let lemma2 :=
- constr:(gen_lemma2 _ _ _ _ _ _ _ _ set ext_r arth
- _ _ _ _ _ _ _ _ _ morph
- _ _ _ pp_spec
- _ ps_spec) in
- fun f => f arth ext_r morph lemma1 lemma2
- | _ => fail 2 "bad sign specification"
- end
- | _ => fail 1 "bad power specification"
+ 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 => true
+ O => constr:true
| S ?p => isnatcst p
- | _ => false
+ | _ => constr:false
end.
Ltac isPcst t :=
@@ -801,7 +887,7 @@ Ltac isPcst t :=
| xH => constr:true
(* nat -> positive *)
| P_of_succ_nat ?n => isnatcst n
- | _ => false
+ | _ => constr:false
end.
Ltac isNcst t :=
@@ -813,7 +899,7 @@ Ltac isNcst t :=
Ltac isZcst t :=
match t with
- Z0 => true
+ Z0 => constr:true
| Zpos ?p => isPcst p
| Zneg ?p => isPcst p
(* injection nat -> Z *)
@@ -821,7 +907,7 @@ Ltac isZcst t :=
(* injection N -> Z *)
| Z_of_N ?n => isNcst n
(* *)
- | _ => false
+ | _ => constr:false
end.
diff --git a/contrib/setoid_ring/NArithRing.v b/contrib/setoid_ring/NArithRing.v
index ae067a8a..0ba519fd 100644
--- a/contrib/setoid_ring/NArithRing.v
+++ b/contrib/setoid_ring/NArithRing.v
@@ -15,7 +15,7 @@ Set Implicit Arguments.
Ltac Ncst t :=
match isNcst t with
true => t
- | _ => NotConstant
+ | _ => constr:NotConstant
end.
Add Ring Nr : Nth (decidable Neq_bool_ok, constants [Ncst]).
diff --git a/contrib/setoid_ring/RealField.v b/contrib/setoid_ring/RealField.v
index d0512dff..60641bcf 100644
--- a/contrib/setoid_ring/RealField.v
+++ b/contrib/setoid_ring/RealField.v
@@ -130,4 +130,5 @@ Add Field RField : Rfield
(completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]).
+
diff --git a/contrib/setoid_ring/Ring.v b/contrib/setoid_ring/Ring.v
index 1a4e1cc7..d01b1625 100644
--- a/contrib/setoid_ring/Ring.v
+++ b/contrib/setoid_ring/Ring.v
@@ -38,7 +38,7 @@ Ltac bool_cst t :=
match t with
true => constr:true
| false => constr:false
- | _ => NotConstant
+ | _ => constr:NotConstant
end.
Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/contrib/setoid_ring/Ring_polynom.v b/contrib/setoid_ring/Ring_polynom.v
index b79f2fe2..d8847036 100644
--- a/contrib/setoid_ring/Ring_polynom.v
+++ b/contrib/setoid_ring/Ring_polynom.v
@@ -43,6 +43,10 @@ Section MakeRingPol.
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.
@@ -55,14 +59,14 @@ Section MakeRingPol.
Notation "x -! y " := (csub x y). Notation "-! x" := (copp x).
Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x).
- (* Usefull tactics *)
+ (* 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 0 1 radd rmul rsub ropp req Rsth Reqe ARth.
+ 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.
@@ -411,63 +415,79 @@ Section MakeRingPol.
| vmon i' m => vmon (i+i') m
end.
- Fixpoint MFactor (P: Pol) (M: Mon) {struct P}: Pol * Pol :=
+ 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 => (Pc cO, P)
+ _, 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 M1 in
+ Eq => let (R,S) := MFactor P1 c M1 in
(mkPinj j1 R, mkPinj j1 S)
- | Lt => let (R,S) := MFactor P1 (zmon (j2 - j1) M1) in
+ | 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 M in
- let (R2, S2) := MFactor Q1 M2 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 (mkZmon xH M1) in
+ Eq => let (R1,S1) := MFactor P1 c (mkZmon xH M1) in
(mkPX R1 i Q1, S1)
- | Lt => let (R1,S1) := MFactor P1 (vmon (j - i) M1) in
+ | Lt => let (R1,S1) := MFactor P1 c (vmon (j - i) M1) in
(mkPX R1 i Q1, S1)
- | Gt => let (R1,S1) := MFactor P1 (mkZmon xH M1) in
+ | 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) (M1: Mon) (P2: Pol): option Pol :=
- let (Q1,R1) := MFactor P1 M1 in
+ 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) (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
+ 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) (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
+ 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 (Mon * Pol)) (n: nat) {struct LM1}:
+ 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 (Mon * Pol)) (n: nat) {struct LM1}: option Pol :=
+ 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
@@ -477,7 +497,7 @@ Section MakeRingPol.
| _ => None
end.
- Fixpoint PNSubstL (P1: Pol) (LM1: list (Mon * Pol)) (m n: nat) {struct m}: Pol :=
+ Fixpoint PNSubstL (P1: Pol) (LM1: list ((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
@@ -579,16 +599,22 @@ Section MakeRingPol.
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)
+ | |- 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.
@@ -876,38 +902,82 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
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).
+ 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 M l; case M; simpl; auto; try intro p; try intro m;
- try rewrite (morph0 CRmorph); rsimpl.
+ 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.
- intros i P Hrec M l; case M; simpl; clear M.
- rewrite (morph0 CRmorph); rsimpl.
+ 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 M (jump j l)); case (MFactor P M);
+ generalize (Hrec (c, M) (jump j l)); case (MFactor P c 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.
+ 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 M l; case M; simpl; auto.
- 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 (zmon j M1) l);
- case (MFactor P2 (zmon j M1)).
+ generalize (Hrec1 (c,zmon j M1) l);
+ case (MFactor P2 c (zmon j M1)).
intros R1 S1 H1.
- generalize (Hrec2 (zmon_pred j M1) (List.tail l));
- case (MFactor Q2 (zmon_pred j M1)); simpl.
+ 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.
@@ -919,7 +989,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
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));
+ 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)).
@@ -929,9 +999,11 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
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 (vmon (j - i) M1) l);
- case (MFactor P2 (vmon (j - i) M1));
+ 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.
@@ -943,10 +1015,13 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
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 (mkZmon 1 M1) l);
- case (MFactor P2 (mkZmon 1 M1));
+ 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.
@@ -963,6 +1038,9 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
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.
@@ -970,10 +1048,10 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
(* 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.
+ POneSubst P1 M1 P2 = Some P3 -> phi (fst M1) * Mphi l (snd 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 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);
@@ -986,7 +1064,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l.
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. intros;apply Pmul_ok. rewrite H1; 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.
@@ -1017,7 +1095,7 @@ Proof.
Qed.
*)
Lemma PNSubst1_ok: forall n P1 M1 P2 l,
- Mphi l M1 == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@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.
@@ -1031,19 +1109,19 @@ Proof.
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.
+ PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd 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 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 (Mon * Pol)) (l: list R) {struct LM1} : Prop :=
+ Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop :=
match LM1 with
- cons (M1,P2) LM2 => (Mphi l M1 == P2@l) /\ (MPcond LM2 l)
+ cons (M1,P2) LM2 => ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l)
| _ => True
end.
@@ -1108,6 +1186,8 @@ Proof.
| 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.
@@ -1180,7 +1260,7 @@ Section POWER.
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. Qed.
+ Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl. Qed.
End POWER.
@@ -1188,7 +1268,7 @@ Section POWER.
Section NORM_SUBST_REC.
Variable n : nat.
- Variable lmp:list (Mon*Pol).
+ 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.
@@ -1256,7 +1336,7 @@ Section POWER.
rewrite IHpe1;rewrite IHpe2;rrefl.
rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl.
rewrite IHpe;rrefl.
- rewrite Ppow_N_ok. intros;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.
@@ -1282,24 +1362,24 @@ Section POWER.
end
end.
- Fixpoint mon_of_pol (P:Pol) : option Mon :=
+ Fixpoint mon_of_pol (P:Pol) : option (C * Mon) :=
match P with
- | Pc c => if (c ?=! cI) then Some mon0 else None
+ | Pc c => if (c ?=! cO) then None else Some (c, mon0)
| Pinj j P =>
match mon_of_pol P with
| None => None
- | Some m => Some (mkZmon j m)
+ | 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 m => Some (mkVmon i m)
+ | Some (c,m) => Some (c, mkVmon i m)
end
else None
end.
- Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (Mon*Pol) :=
+ Fixpoint mk_monpol_list (lpe:list (PExpr * PExpr)) : list (C*Mon*Pol) :=
match lpe with
| nil => nil
| (me,pe)::lpe =>
@@ -1310,16 +1390,18 @@ Section POWER.
end.
Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m ->
- forall l, Mphi l m == P@l.
+ forall l, [fst m] * Mphi l (snd m) == P@l.
Proof.
induction P;simpl;intros;Esimpl.
- assert (H1 := (morph_eq CRmorph) c cI).
- destruct (c ?=! cI).
- inversion H;rewrite H1;trivial;Esimpl.
+ assert (H1 := (morph_eq CRmorph) c cO).
+ destruct (c ?=! cO).
discriminate.
- generalize H;clear H;case_eq (mon_of_pol P);intros;try discriminate.
- inversion H0.
- rewrite mkZmon_ok;simpl;auto.
+ 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
@@ -1327,10 +1409,13 @@ Section POWER.
end with (P3 ?== P0).
assert (H := Peq_ok P3 P0).
destruct (P3 ?== P0).
- case_eq (mon_of_pol P2);intros.
+ case_eq (mon_of_pol P2);try intros (cc, pp); intros.
inversion H1.
+ simpl.
rewrite mkVmon_ok;simpl.
- rewrite H;trivial;Esimpl. rewrite IHP1;trivial;Esimpl. discriminate.
+ rewrite H;trivial;Esimpl.
+ generalize (IHP1 _ H0); simpl; intros HH; rewrite HH; rsimpl.
+ discriminate.
intros;discriminate.
Qed.
@@ -1342,7 +1427,7 @@ Section POWER.
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. exact I.
+ 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.
@@ -1371,7 +1456,7 @@ Section POWER.
(** Generic evaluation of polynomial towards R avoiding parenthesis *)
Variable get_sign : C -> option C.
- Variable get_sign_spec : sign_theory ropp req phi get_sign.
+ Variable get_sign_spec : sign_theory copp ceqb get_sign.
Section EVALUATION.
@@ -1509,7 +1594,7 @@ Section POWER.
case_eq (get_sign c);intros.
assert (H1 := (morph_eq CRmorph) c0 cI).
destruct (c0 ?=! cI).
- rewrite (get_sign_spec.(sign_spec) _ H). rewrite H1;trivial.
+ 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.
@@ -1520,7 +1605,7 @@ Qed.
Proof.
intros;unfold mkadd_mult.
case_eq (get_sign c);intros.
- rewrite (get_sign_spec.(sign_spec) _ H).
+ rewrite (CRmorph.(morph_eq) _ _ (get_sign_spec.(sign_spec) _ H));Esimpl.
rewrite mkmult_c_pos_ok;Esimpl.
rewrite mkmult_c_pos_ok;Esimpl.
Qed.
diff --git a/contrib/setoid_ring/Ring_tac.v b/contrib/setoid_ring/Ring_tac.v
index d8bb9eae..46d106d3 100644
--- a/contrib/setoid_ring/Ring_tac.v
+++ b/contrib/setoid_ring/Ring_tac.v
@@ -16,11 +16,6 @@ Ltac compute_assertion id id' t :=
[vm_cast_no_check (refl_equal id')|idtac].
(* [exact_no_check (refl_equal id'<: t = id')|idtac]). *)
-Ltac getGoal :=
- match goal with
- | |- ?G => G
- end.
-
(********************************************************************)
(* Tacticals to build reflexive tactics *)
@@ -47,10 +42,10 @@ Ltac ApplyLemmaThen lemma expr tac :=
forall x, ?nf_spec = x -> _ => nf_spec
| _ => fail 1 "ApplyLemmaThen: cannot find norm expression"
end in
- (compute_assertion H nexpr nf_spec;
- (assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma");
- clear H;
- OnMainSubgoal Heq ltac:(type of Heq) ltac:(tac Heq; clear Heq nexpr)).
+ compute_assertion H nexpr nf_spec;
+ assert (Heq:=lemma _ _ H) || fail "anomaly: failed to apply lemma";
+ clear H;
+ OnMainSubgoal Heq ltac:(type of Heq) ltac:(tac Heq; clear Heq nexpr).
Ltac ApplyLemmaThenAndCont lemma expr tac CONT_tac cont_arg :=
let npe := fresh "expr_nf" in
@@ -143,13 +138,11 @@ Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv :=
Ltac ParseRingComponents lemma :=
match type of lemma with
- | context
- [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
+ | context [@PEeval ?R ?rO ?add ?mul ?sub ?opp ?C ?phi ?Cpow ?powphi ?pow _ _] =>
(fun f => f R add mul sub opp pow C)
| _ => fail 1 "ring anomaly: bad correctness lemma (parse)"
end.
-
(* ring tactics *)
Ltac relation_carrier req :=
@@ -175,7 +168,7 @@ Ltac mkHyp_tac C req mkPE lH :=
let pe1 := mkPE r1 in
let pe2 := mkPE r2 in
constr:(cons (pe1,pe2) res)
- | _ => fail "hypothesis is not a ring equality"
+ | _ => fail 1 "hypothesis is not a ring equality"
end in
list_fold_right mkHyp (@nil (PExpr C * PExpr C)) lH.
@@ -226,12 +219,6 @@ Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl :=
let mkPol := mkPolexpr C Cst_tac CstPow_tac add mul sub opp pow in
let fv := FV_hypo_tac mkFV req lH in
let simpl_ring H := (protect_fv "ring" in H; f H) in
- let Coeffs :=
- match type of lemma2 with
- | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?ceqb _] =>
- (fun f => f cO cI cadd cmul csub copp ceqb)
- | _ => fail 1 "ring_simplify anomaly: bad correctness lemma"
- end in
let lemma_tac fv RW_tac :=
let rr_lemma := fresh "r_rw_lemma" in
let lpe := mkHyp_tac C req ltac:(fun t => mkPol t fv) lH in
@@ -240,25 +227,34 @@ Ltac Ring_norm_gen f Cst_tac CstPow_tac lemma2 req n lH rl :=
let vlmp_eq := fresh "list_hyp_norm_eq" in
let prh := proofHyp_tac lH in
pose (vlpe := lpe);
- Coeffs ltac:(fun cO cI cadd cmul csub copp ceqb =>
+ match type of lemma2 with
+ | context [mk_monpol_list ?cO ?cI ?cadd ?cmul ?csub ?copp ?cdiv ?ceqb _]
+ =>
compute_assertion vlmp_eq vlmp
- (mk_monpol_list cO cI cadd cmul csub copp ceqb vlpe);
- assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq)
- || fail "type error when build the rewriting lemma";
- RW_tac rr_lemma;
- try clear rr_lemma vlmp_eq vlmp vlpe) in
+ (mk_monpol_list cO cI cadd cmul csub copp cdiv ceqb vlpe);
+ (assert (rr_lemma := lemma2 n vlpe fv prh vlmp vlmp_eq)
+ || fail 1 "type error when build the rewriting lemma");
+ RW_tac rr_lemma;
+ try clear rr_lemma vlmp_eq vlmp vlpe
+ | _ => fail 1 "ring_simplify anomaly: bad correctness lemma"
+ end in
ReflexiveRewriteTactic mkFV mkPol simpl_ring lemma_tac fv rl in
ParseRingComponents lemma2 Main.
+
Ltac Ring_gen
req sth ext morph arth cst_tac pow_tac lemma1 lemma2 pre post lH rl :=
pre();Ring cst_tac pow_tac lemma1 req ring_subst_niter lH.
+Ltac Get_goal := match goal with [|- ?G] => G end.
+
Tactic Notation (at level 0) "ring" :=
- let G := getGoal in ring_lookup Ring_gen [] [G].
+ let G := Get_goal in
+ ring_lookup Ring_gen [] G.
Tactic Notation (at level 0) "ring" "[" constr_list(lH) "]" :=
- let G := getGoal in ring_lookup Ring_gen [lH] [G].
+ let G := Get_goal in
+ ring_lookup Ring_gen [lH] G.
(* Simplification *)
@@ -269,67 +265,89 @@ Ltac Ring_simplify_gen f :=
generalize (refl_equal l);
unfold l at 2;
pre();
- match goal with
- | [|- l = ?RL -> _ ] =>
+ let Tac RL :=
let Heq := fresh "Heq" in
intros Heq;clear Heq l;
Ring_norm_gen f cst_tac pow_tac lemma2 req ring_subst_niter lH RL;
- post()
- | _ => fail 1 "ring_simplify anomaly: bad goal after pre"
- end.
+ post() in
+ let Main :=
+ match goal with
+ | [|- l = ?RL -> _ ] => (fun f => f RL)
+ | _ => fail 1 "ring_simplify anomaly: bad goal after pre"
+ end in
+ Main Tac.
Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H).
-Ltac Ring_nf Cst_tac lemma2 req rl f :=
- let on_rhs H :=
- match type of H with
- | req _ ?rhs => clear H; f rhs
- end in
- Ring_norm_gen on_rhs Cst_tac lemma2 req rl.
-
+Tactic Notation (at level 0) "ring_simplify" constr_list(rl) :=
+ let G := Get_goal in
+ ring_lookup Ring_simplify [] rl G.
Tactic Notation (at level 0)
"ring_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
- let G := getGoal in ring_lookup Ring_simplify [lH] rl [G].
-
-Tactic Notation (at level 0)
- "ring_simplify" constr_list(rl) :=
- let G := getGoal in ring_lookup Ring_simplify [] rl [G].
+ let G := Get_goal in
+ ring_lookup Ring_simplify [lH] rl G.
+(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *)
Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):=
- let G := getGoal in
- let t := type of H in
- let g := fresh "goal" in
- set (g:= G);
- generalize H;clear H;
- ring_lookup 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 := getGoal in
- let t := type of H in
- let g := fresh "goal" in
- set (g:= G);
- generalize H;clear H;
- ring_lookup Ring_simplify [lH] rl [t];
- intro H;
- unfold g;clear g.
+ 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 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 Ring_simplify [lH] rl t;
+ intro H;
+ unfold g;clear g.
+
+
+
+(* LE RESTE MARCHE PAS DOMMAGE ..... *)
+
+
+
+
+
+
+
+
+
+
+
+
+
(*
+
+
+
+
+
+
+
Ltac Ring_simplify_in hyp:= Ring_simplify_gen ltac:(fun H => rewrite H in hyp).
Tactic Notation (at level 0)
"ring_simplify" "[" constr_list(lH) "]" constr_list(rl) :=
- match goal with [|- ?G] => ring_lookup Ring_simplify [lH] rl [G] end.
+ match goal with [|- ?G] => ring_lookup Ring_simplify [lH] rl G end.
Tactic Notation (at level 0)
"ring_simplify" constr_list(rl) :=
- match goal with [|- ?G] => ring_lookup Ring_simplify [] rl [G] end.
+ match goal with [|- ?G] => ring_lookup Ring_simplify [] rl G end.
Tactic Notation (at level 0)
"ring_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h):=
@@ -339,7 +357,7 @@ Tactic Notation (at level 0)
pre();
Ring_norm_gen ltac:(fun EQ => rewrite EQ in h) cst_tac pow_tac lemma2 req ring_subst_niter lH rl;
post())
- [lH] rl [t].
+ [lH] rl t.
(* ring_lookup ltac:(Ring_simplify_in h) [lH] rl [t]. NE MARCHE PAS ??? *)
Ltac Ring_simpl_in hyp := Ring_norm_gen ltac:(fun H => rewrite H in hyp).
@@ -352,7 +370,7 @@ Tactic Notation (at level 0)
pre();
Ring_simpl_in h cst_tac pow_tac lemma2 req ring_subst_niter lH rl;
post())
- [] rl [t].
+ [] rl t.
Ltac rw_in H Heq := rewrite Heq in H.
@@ -363,7 +381,7 @@ Ltac simpl_in H :=
pre();
Ring_norm_gen ltac:(fun Heq => rewrite Heq in H) cst_tac pow_tac lemma2 req ring_subst_niter lH rl;
post())
- [] [t].
+ [] t.
*)
diff --git a/contrib/setoid_ring/Ring_theory.v b/contrib/setoid_ring/Ring_theory.v
index 5498911d..29feab5c 100644
--- a/contrib/setoid_ring/Ring_theory.v
+++ b/contrib/setoid_ring/Ring_theory.v
@@ -19,7 +19,7 @@ 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 1, no 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).
@@ -59,8 +59,7 @@ Section Power.
induction j;simpl.
rewrite IHj.
rewrite (mul_comm x (pow_pos x j *pow_pos x j)).
- set (w:= x*pow_pos x j);unfold w at 2.
- rewrite (mul_comm x (pow_pos x j));unfold w.
+ 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).
@@ -198,7 +197,7 @@ Section DEFINITIONS.
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']
+ sign_spec : forall c c', get_sign c = Some c' -> c ?=! -! c' = true
}.
End SIGN.
@@ -207,6 +206,13 @@ Section DEFINITIONS.
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 *)
@@ -235,6 +241,7 @@ Section DEFINITIONS.
Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth).
+
End DEFINITIONS.
@@ -250,7 +257,7 @@ Section ALMOST_RING.
(** Leibniz equality leads to a setoid theory and is extensional*)
Lemma Eqsth : Setoid_Theory R (@eq R).
- Proof. constructor;intros;subst;trivial. Qed.
+ Proof. constructor;red;intros;subst;trivial. Qed.
Lemma Eq_s_ext : sring_eq_ext radd rmul (@eq R).
Proof. constructor;intros;subst;trivial. Qed.
@@ -442,7 +449,7 @@ Section ALMOST_RING.
End RING.
- (** Usefull lemmas on almost 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.
@@ -564,7 +571,7 @@ End AddRing.
(** Some simplification tactics*)
Ltac gen_reflexivity Rsth := apply (Seq_refl _ _ Rsth).
-Ltac gen_srewrite O I add mul sub opp eq Rsth Reqe ARth :=
+Ltac gen_srewrite Rsth Reqe ARth :=
repeat first
[ gen_reflexivity Rsth
| progress rewrite (ARopp_zero Rsth Reqe ARth)
diff --git a/contrib/setoid_ring/ZArithRing.v b/contrib/setoid_ring/ZArithRing.v
index 8de7021e..4a5b623b 100644
--- a/contrib/setoid_ring/ZArithRing.v
+++ b/contrib/setoid_ring/ZArithRing.v
@@ -17,14 +17,14 @@ Set Implicit Arguments.
Ltac Zcst t :=
match isZcst t with
true => t
- | _ => NotConstant
+ | _ => constr:NotConstant
end.
Ltac isZpow_coef t :=
match t with
| Zpos ?p => isPcst p
- | Z0 => true
- | _ => false
+ | Z0 => constr:true
+ | _ => constr:false
end.
Definition N_of_Z x :=
@@ -36,7 +36,7 @@ Definition N_of_Z x :=
Ltac Zpow_tac t :=
match isZpow_coef t with
| true => constr:(N_of_Z t)
- | _ => constr:(NotConstant)
+ | _ => constr:NotConstant
end.
Ltac Zpower_neg :=
@@ -49,8 +49,12 @@ Ltac Zpower_neg :=
end
end.
-
Add Ring Zr : Zth
(decidable Zeqb_ok, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
- power_tac Zpower_theory [Zpow_tac]).
+ 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/contrib/setoid_ring/newring.ml4 b/contrib/setoid_ring/newring.ml4
index 134ba1a8..dd79801d 100644
--- a/contrib/setoid_ring/newring.ml4
+++ b/contrib/setoid_ring/newring.ml4
@@ -8,7 +8,7 @@
(*i camlp4deps: "parsing/grammar.cma" i*)
-(*i $Id: newring.ml4 10047 2007-07-24 17:55:18Z barras $ i*)
+(*i $Id: newring.ml4 11094 2008-06-10 19:35:23Z herbelin $ i*)
open Pp
open Util
@@ -104,7 +104,8 @@ let protect_tac map =
Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
let protect_tac_in map id =
- Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(([],id),InHyp));;
+ Tactics.reduct_option (protect_red map,DEFAULTcast)
+ (Some((all_occurrences_expr,id),InHyp));;
TACTIC EXTEND protect_fv
@@ -176,13 +177,9 @@ let ltac_lcall tac args =
let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c)
-let dummy_goal env =
- {Evd.it=
- {Evd.evar_concl=mkProp;
- Evd.evar_hyps=named_context_val env;
- Evd.evar_body=Evd.Evar_empty;
- Evd.evar_extra=None};
- Evd.sigma=Evd.empty}
+let 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
@@ -205,7 +202,8 @@ let constr_of = function
let stdlib_modules =
[["Coq";"Setoids";"Setoid"];
["Coq";"Lists";"List"];
- ["Coq";"Init";"Datatypes"]
+ ["Coq";"Init";"Datatypes"];
+ ["Coq";"Init";"Logic"];
]
let coq_constant c =
@@ -216,6 +214,7 @@ 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)
@@ -452,10 +451,12 @@ let (theory_to_obj, obj_to_theory) =
export_function = export_th }
-let setoid_of_relation r =
+let setoid_of_relation env a r =
lapp coq_mk_Setoid
- [|r.rel_a; r.rel_aeq;
- out_some r.rel_refl; out_some r.rel_sym; out_some r.rel_trans |]
+ [|a ; r ;
+ Class_tactics.reflexive_proof env a r ;
+ Class_tactics.symmetric_proof env a r ;
+ Class_tactics.transitive_proof env a r |]
let op_morph r add mul opp req m1 m2 m3 =
lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |]
@@ -463,63 +464,110 @@ let op_morph 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
+(* 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)
- | 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
+ (setoid,op_morph)
+ | _ ->
+ let setoid = setoid_of_relation (Global.env ()) r req in
+ let signature = [Some (r,req);Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in
+ let add_m, add_m_lem =
+ try Class_tactics.default_morphism signature add
with Not_found ->
error "ring addition should be declared as a morphism" in
- let mul_m =
- try default_morphism ~filter:is_endomorphism mul
+ let mul_m, mul_m_lem =
+ try Class_tactics.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 =
- 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)
+ (let opp_m,opp_m_lem =
+ try Class_tactics.default_morphism ([Some(r,req)],Some(Lazy.lazy_from_val (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 ->
- (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)
-
+ (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 -> default_ring_equality (r,add,mul,opp,req)
+ | 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
@@ -569,7 +617,8 @@ type cst_tac_spec =
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 Nametab.global lc)
+ | Some (Closed lc) ->
+ closed_term_ast (List.map Syntax_def.global_with_alias lc)
| None ->
(match rk, opp, kind with
Abstract, None, _ ->
@@ -612,7 +661,8 @@ let interp_power env pow =
let tac =
match tac with
| CstTac t -> Tacinterp.glob_tactic t
- | Closed lc -> closed_term_ast (List.map Nametab.global lc) in
+ | Closed lc ->
+ closed_term_ast (List.map Syntax_def.global_with_alias lc) in
let spec = make_hyp env (ic spec) in
(tac, lapp coq_Some [|carrier; spec|])
@@ -625,7 +675,16 @@ let interp_sign env sign =
lapp coq_Some [|carrier;spec|]
(* Same remark on ill-typed terms ... *)
-let add_theory name rth eqth morphth cst_tac (pre,post) power sign =
+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
@@ -633,10 +692,11 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign =
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;rk]) in
+ (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
@@ -678,6 +738,7 @@ type ring_mod =
| 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
@@ -694,6 +755,7 @@ VERNAC ARGUMENT EXTEND ring_mod
[ 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 =
@@ -707,6 +769,7 @@ let process_ring_mods l =
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
@@ -714,14 +777,15 @@ let process_ring_mods l =
| 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) l;
+ | 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)
+ (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) = process_ring_mods l in
- add_theory id (ic t) set k cst (pre,post) power sign ]
+ [ 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
(*****************************************************************************)
@@ -759,15 +823,14 @@ let ring_lookup (f:glob_tactic_expr) lH rl t gl =
let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
Tacinterp.eval_tactic
(TacLetIn
- ([(dummy_loc,id_of_string"f"),None,Tacexp f],
+ (false,[(dummy_loc,id_of_string"f"),Tacexp f],
ltac_lcall "f"
[req;sth;ext;morph;th;cst_tac;pow_tac;
lemma1;lemma2;pretac;posttac;lH;rl])) gl
TACTIC EXTEND ring_lookup
-| [ "ring_lookup" tactic(f) "[" constr_list(lH) "]" constr_list(lr)
- "[" constr(t) "]" ] ->
- [ring_lookup (fst f) lH lr t]
+| [ "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
@@ -968,26 +1031,20 @@ let (ftheory_to_obj, obj_to_ftheory) =
classify_function = (fun (_,x) -> Substitute x);
export_function = export_th }
-let default_field_equality r inv req =
- let is_setoid = function
- {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _} -> true
- | _ -> false in
- match default_relation_for_carrier ~filter:is_setoid r with
- Leibniz _ ->
+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|])
- | Relation rel ->
- let is_endomorphism = function
- { args=args } -> List.for_all
- (function (var,Relation rel) ->
- var=None && eq_constr req rel
- | _ -> false) args in
- let inv_m =
- try default_morphism ~filter:is_endomorphism inv
+ | _ ->
+ let _setoid = setoid_of_relation (Global.env ()) r req in
+ let signature = [Some (r,req)],Some(Lazy.lazy_from_val (r,req)) in
+ let inv_m, inv_m_lem =
+ try Class_tactics.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 =
+ 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
@@ -995,14 +1052,15 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign =
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 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 inv_m = default_field_equality r inv req 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;rk]) in
+ (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
@@ -1059,6 +1117,7 @@ let process_field_mods l =
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) ->
@@ -1068,14 +1127,15 @@ let process_field_mods l =
| 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)
+ (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) = process_field_mods l in
- add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign]
+ [ 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 field_lookup (f:glob_tactic_expr) lH rl t gl =
@@ -1097,13 +1157,12 @@ let field_lookup (f:glob_tactic_expr) lH rl t gl =
let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
Tacinterp.eval_tactic
(TacLetIn
- ([(dummy_loc,id_of_string"f"),None,Tacexp f],
+ (false,[(dummy_loc,id_of_string"f"),Tacexp f],
ltac_lcall "f"
[req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
field_simpl_eq_in_ok;cond_ok;pretac;posttac;lH;rl])) gl
TACTIC EXTEND field_lookup
-| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" constr_list(l)
- "[" constr(t) "]" ] ->
- [ field_lookup (fst f) lH l t ]
+| [ "field_lookup" tactic0(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/contrib/subtac/FixSub.v b/contrib/subtac/FixSub.v
deleted file mode 100644
index f047b729..00000000
--- a/contrib/subtac/FixSub.v
+++ /dev/null
@@ -1,147 +0,0 @@
-Require Import Wf.
-Require Import Coq.subtac.Utils.
-
-(** Reformulation of the Wellfounded module using subsets where possible. *)
-
-Section Well_founded.
- Variable A : Type.
- Variable R : A -> A -> Prop.
- Hypothesis Rwf : well_founded R.
-
- Section Acc.
-
- Variable P : A -> Type.
-
- Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
-
- Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x :=
- F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y)
- (Acc_inv r (proj1_sig y) (proj2_sig y))).
-
- Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x).
- End Acc.
-
- Section FixPoint.
- Variable P : A -> Type.
-
- Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x.
-
- Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *)
-
- Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x).
-
- Hypothesis
- F_ext :
- forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)),
- (forall y:{ y:A | R y x}, f y = g y) -> F_sub x f = F_sub x g.
-
- Lemma Fix_F_eq :
- forall (x:A) (r:Acc R x),
- F_sub x (fun (y:{y:A|R y x}) => Fix_F (`y) (Acc_inv r (proj1_sig y) (proj2_sig y))) = Fix_F x r.
- Proof.
- destruct r using Acc_inv_dep; auto.
- Qed.
-
- Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F x r = Fix_F x s.
- Proof.
- intro x; induction (Rwf x); intros.
- rewrite <- (Fix_F_eq x r); rewrite <- (Fix_F_eq x s); intros.
- apply F_ext; auto.
- intros.
- rewrite (proof_irrelevance (Acc R x) r s) ; auto.
- Qed.
-
- Lemma Fix_eq : forall x:A, Fix x = F_sub x (fun (y:{y:A|R y x}) => Fix (proj1_sig y)).
- Proof.
- intro x; unfold Fix in |- *.
- rewrite <- (Fix_F_eq ).
- apply F_ext; intros.
- apply Fix_F_inv.
- Qed.
-
- Lemma fix_sub_eq :
- forall x : A,
- Fix_sub P F_sub x =
- let f_sub := F_sub in
- f_sub x (fun {y : A | R y x}=> Fix (`y)).
- exact Fix_eq.
- Qed.
-
- End FixPoint.
-
-End Well_founded.
-
-Extraction Inline Fix_F_sub Fix_sub.
-
-Require Import Wf_nat.
-Require Import Lt.
-
-Section Well_founded_measure.
- Variable A : Type.
- Variable m : A -> nat.
-
- Section Acc.
-
- Variable P : A -> Type.
-
- Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x.
-
- Fixpoint Fix_measure_F_sub (x : A) (r : Acc lt (m x)) {struct r} : P x :=
- F_sub x (fun y: { y : A | m y < m x} => Fix_measure_F_sub (proj1_sig y)
- (Acc_inv r (m (proj1_sig y)) (proj2_sig y))).
-
- Definition Fix_measure_sub (x : A) := Fix_measure_F_sub x (lt_wf (m x)).
-
- End Acc.
-
- Section FixPoint.
- Variable P : A -> Type.
-
- Variable F_sub : forall x:A, (forall y: { y : A | m y < m x }, P (proj1_sig y)) -> P x.
-
- Notation Fix_F := (Fix_measure_F_sub P F_sub) (only parsing). (* alias *)
-
- Definition Fix_measure (x:A) := Fix_measure_F_sub P F_sub x (lt_wf (m x)).
-
- Hypothesis
- F_ext :
- forall (x:A) (f g:forall y:{y:A | m y < m x}, P (`y)),
- (forall y:{ y:A | m y < m x}, f y = g y) -> F_sub x f = F_sub x g.
-
- Lemma Fix_measure_F_eq :
- forall (x:A) (r:Acc lt (m x)),
- F_sub x (fun (y:{y:A|m y < m x}) => Fix_F (`y) (Acc_inv r (m (proj1_sig y)) (proj2_sig y))) = Fix_F x r.
- Proof.
- intros x.
- set (y := m x).
- unfold Fix_measure_F_sub.
- intros r ; case r ; auto.
- Qed.
-
- Lemma Fix_measure_F_inv : forall (x:A) (r s:Acc lt (m x)), Fix_F x r = Fix_F x s.
- Proof.
- intros x r s.
- rewrite (proof_irrelevance (Acc lt (m x)) r s) ; auto.
- Qed.
-
- Lemma Fix_measure_eq : forall x:A, Fix_measure x = F_sub x (fun (y:{y:A| m y < m x}) => Fix_measure (proj1_sig y)).
- Proof.
- intro x; unfold Fix_measure in |- *.
- rewrite <- (Fix_measure_F_eq ).
- apply F_ext; intros.
- apply Fix_measure_F_inv.
- Qed.
-
- Lemma fix_measure_sub_eq :
- forall x : A,
- Fix_measure_sub P F_sub x =
- let f_sub := F_sub in
- f_sub x (fun {y : A | m y < m x}=> Fix_measure (`y)).
- exact Fix_measure_eq.
- Qed.
-
- End FixPoint.
-
-End Well_founded_measure.
-
-Extraction Inline Fix_measure_F_sub Fix_measure_sub.
diff --git a/contrib/subtac/FunctionalExtensionality.v b/contrib/subtac/FunctionalExtensionality.v
deleted file mode 100644
index 4610f346..00000000
--- a/contrib/subtac/FunctionalExtensionality.v
+++ /dev/null
@@ -1,47 +0,0 @@
-Lemma equal_f : forall A B : Type, forall (f g : A -> B),
- f = g -> forall x, f x = g x.
-Proof.
- intros.
- rewrite H.
- auto.
-Qed.
-
-Axiom fun_extensionality : forall A B (f g : A -> B),
- (forall x, f x = g x) -> f = g.
-
-Axiom fun_extensionality_dep : forall A, forall B : (A -> Type), forall (f g : forall x : A, B x),
- (forall x, f x = g x) -> f = g.
-
-Hint Resolve fun_extensionality fun_extensionality_dep : subtac.
-
-Require Import Coq.subtac.Utils.
-Require Import Coq.subtac.FixSub.
-
-Lemma fix_sub_eq_ext :
- forall (A : Set) (R : A -> A -> Prop) (Rwf : well_founded R)
- (P : A -> Set)
- (F_sub : forall x : A, (forall {y : A | R y x}, P (`y)) -> P x),
- forall x : A,
- Fix_sub A R Rwf P F_sub x =
- F_sub x (fun {y : A | R y x}=> Fix A R Rwf P F_sub (`y)).
-Proof.
- intros ; apply Fix_eq ; auto.
- intros.
- assert(f = g).
- apply (fun_extensionality_dep _ _ _ _ H).
- rewrite H0 ; auto.
-Qed.
-
-Lemma fix_sub_measure_eq_ext :
- forall (A : Type) (f : A -> nat) (P : A -> Type)
- (F_sub : forall x : A, (forall {y : A | f y < f x}, P (`y)) -> P x),
- forall x : A,
- Fix_measure_sub A f P F_sub x =
- F_sub x (fun {y : A | f y < f x}=> Fix_measure_sub A f P F_sub (`y)).
-Proof.
- intros ; apply Fix_measure_eq ; auto.
- intros.
- assert(f0 = g).
- apply (fun_extensionality_dep _ _ _ _ H).
- rewrite H0 ; auto.
-Qed.
diff --git a/contrib/subtac/Heq.v b/contrib/subtac/Heq.v
deleted file mode 100644
index f2b216d9..00000000
--- a/contrib/subtac/Heq.v
+++ /dev/null
@@ -1,34 +0,0 @@
-Require Export JMeq.
-
-(** Notation for heterogenous equality. *)
-
-Notation " [ x : X ] = [ y : Y ] " := (@JMeq X x Y y) (at level 0, X at next level, Y at next level).
-
-(** Do something on an heterogeneous equality appearing in the context. *)
-
-Ltac on_JMeq tac :=
- match goal with
- | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H
- end.
-
-(** Try to apply [JMeq_eq] to get back a regular equality when the two types are equal. *)
-
-Ltac simpl_one_JMeq :=
- on_JMeq
- ltac:(fun H => let H' := fresh "H" in
- assert (H' := JMeq_eq H) ; clear H ; rename H' into H).
-
-(** Repeat it for every possible hypothesis. *)
-
-Ltac simpl_JMeq := repeat simpl_one_JMeq.
-
-(** Just simplify an h.eq. without clearing it. *)
-
-Ltac simpl_one_dep_JMeq :=
- on_JMeq
- ltac:(fun H => let H' := fresh "H" in
- assert (H' := JMeq_eq H)).
-
-
-
-
diff --git a/contrib/subtac/Subtac.v b/contrib/subtac/Subtac.v
deleted file mode 100644
index 9912cd24..00000000
--- a/contrib/subtac/Subtac.v
+++ /dev/null
@@ -1,2 +0,0 @@
-Require Export Coq.subtac.Utils.
-Require Export Coq.subtac.FixSub. \ No newline at end of file
diff --git a/contrib/subtac/SubtacTactics.v b/contrib/subtac/SubtacTactics.v
deleted file mode 100644
index a00234dd..00000000
--- a/contrib/subtac/SubtacTactics.v
+++ /dev/null
@@ -1,158 +0,0 @@
-Ltac induction_with_subterm c H :=
- let x := fresh "x" in
- let y := fresh "y" in
- (remember c as x ; rewrite <- y in H ; induction H ; subst).
-
-Ltac induction_on_subterm c :=
- let x := fresh "x" in
- let y := fresh "y" in
- (set(x := c) ; assert(y:x = c) by reflexivity ; clearbody x ; induction x ; inversion y ; try subst ;
- clear y).
-
-Ltac induction_with_subterms c c' H :=
- let x := fresh "x" in
- let y := fresh "y" in
- let z := fresh "z" in
- let w := fresh "w" in
- (set(x := c) ; assert(y:x = c) by reflexivity ;
- set(z := c') ; assert(w:z = c') by reflexivity ;
- rewrite <- y in H ; rewrite <- w in H ;
- induction H ; subst).
-
-
-Ltac destruct_one_pair :=
- match goal with
- | [H : (_ /\ _) |- _] => destruct H
- | [H : prod _ _ |- _] => destruct H
- end.
-
-Ltac destruct_pairs := repeat (destruct_one_pair).
-
-Ltac destruct_one_ex :=
- let tac H := let ph := fresh "H" in destruct H as [H ph] in
- match goal with
- | [H : (ex _) |- _] => tac H
- | [H : (sig ?P) |- _ ] => tac H
- | [H : (ex2 _) |- _] => tac H
- end.
-
-Ltac destruct_exists := repeat (destruct_one_ex).
-
-Tactic Notation "destruct" "exist" ident(t) ident(Ht) := destruct t as [t Ht].
-
-Tactic Notation "destruct" "or" ident(H) := destruct H as [H|H].
-
-Tactic Notation "contradiction" "by" constr(t) :=
- let H := fresh in assert t as H by auto with * ; contradiction.
-
-Ltac discriminates :=
- match goal with
- | [ H : ?x <> ?x |- _ ] => elim H ; reflexivity
- | _ => discriminate
- end.
-
-Ltac destruct_conjs := repeat (destruct_one_pair || destruct_one_ex).
-
-Ltac on_last_hyp tac :=
- match goal with
- [ H : _ |- _ ] => tac H
- end.
-
-Tactic Notation "on_last_hyp" tactic(t) := on_last_hyp t.
-
-Ltac revert_last :=
- match goal with
- [ H : _ |- _ ] => revert H
- end.
-
-Ltac reverse := repeat revert_last.
-
-Ltac on_call f tac :=
- match goal with
- | H : ?T |- _ =>
- match T with
- | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u)
- | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v)
- | context [f ?x ?y ?z ?w] => tac (f x y z w)
- | context [f ?x ?y ?z] => tac (f x y z)
- | context [f ?x ?y] => tac (f x y)
- | context [f ?x] => tac (f x)
- end
- | |- ?T =>
- match T with
- | context [f ?x ?y ?z ?w ?v ?u] => tac (f x y z w v u)
- | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v)
- | context [f ?x ?y ?z ?w] => tac (f x y z w)
- | context [f ?x ?y ?z] => tac (f x y z)
- | context [f ?x ?y] => tac (f x y)
- | context [f ?x] => tac (f x)
- end
- end.
-
-(* Destructs calls to f in hypothesis or conclusion, useful if f creates a subset object *)
-Ltac destruct_call f :=
- let tac t := destruct t in on_call f tac.
-
-Ltac destruct_call_as f l :=
- let tac t := destruct t as l in on_call f tac.
-
-Tactic Notation "destruct_call" constr(f) := destruct_call f.
-Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := destruct_call_as f l.
-
-Ltac myinjection :=
- let tac H := inversion H ; subst ; clear H in
- match goal with
- | [ H : ?f ?a = ?f' ?a' |- _ ] => tac H
- | [ H : ?f ?a ?b = ?f' ?a' ?b' |- _ ] => tac H
- | [ H : ?f ?a ?b ?c = ?f' ?a' ?b' ?c' |- _ ] => tac H
- | [ H : ?f ?a ?b ?c ?d= ?f' ?a' ?b' ?c' ?d' |- _ ] => tac H
- | [ H : ?f ?a ?b ?c ?d ?e= ?f' ?a' ?b' ?c' ?d' ?e' |- _ ] => tac H
- | [ H : ?f ?a ?b ?c ?d ?e ?g= ?f' ?a' ?b' ?c' ?d' ?e' ?g' |- _ ] => tac H
- | [ H : ?f ?a ?b ?c ?d ?e ?g ?h= ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' |- _ ] => tac H
- | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' |- _ ] => tac H
- | [ H : ?f ?a ?b ?c ?d ?e ?g ?h ?i ?j = ?f' ?a' ?b' ?c' ?d' ?e'?g' ?h' ?i' ?j' |- _ ] => tac H
- | _ => idtac
- end.
-
-Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0.
-
-Ltac bang :=
- match goal with
- | |- ?x =>
- match x with
- | context [False_rect _ ?p] => elim p
- end
- end.
-
-Require Import Eqdep.
-
-Ltac elim_eq_rect :=
- match goal with
- | [ |- ?t ] =>
- match t with
- | context [ @eq_rect _ _ _ _ _ ?p ] =>
- let P := fresh "P" in
- set (P := p); simpl in P ;
- try ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
- | context [ @eq_rect _ _ _ _ _ ?p _ ] =>
- let P := fresh "P" in
- set (P := p); simpl in P ;
- try ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
- end
- end.
-
-Ltac real_elim_eq_rect :=
- match goal with
- | [ |- ?t ] =>
- match t with
- | context [ @eq_rect _ _ _ _ _ ?p ] =>
- let P := fresh "P" in
- set (P := p); simpl in P ;
- ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
- | context [ @eq_rect _ _ _ _ _ ?p _ ] =>
- let P := fresh "P" in
- set (P := p); simpl in P ;
- ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P))
- end
- end.
- \ No newline at end of file
diff --git a/contrib/subtac/Utils.v b/contrib/subtac/Utils.v
deleted file mode 100644
index 76f49dd3..00000000
--- a/contrib/subtac/Utils.v
+++ /dev/null
@@ -1,65 +0,0 @@
-Require Export Coq.subtac.SubtacTactics.
-
-Set Implicit Arguments.
-
-(** Wrap a proposition inside a subset. *)
-
-Notation " {{ x }} " := (tt : { y : unit | x }).
-
-(** A simpler notation for subsets defined on a cartesian product. *)
-
-Notation "{ ( x , y ) : A | P }" :=
- (sig (fun anonymous : A => let (x,y) := anonymous in P))
- (x ident, y ident) : type_scope.
-
-(** Generates an obligation to prove False. *)
-
-Notation " ! " := (False_rect _ _).
-
-(** Abbreviation for first projection and hiding of proofs of subset objects. *)
-
-Notation " ` t " := (proj1_sig t) (at level 10) : core_scope.
-Notation "( x & ? )" := (@exist _ _ x _) : core_scope.
-
-(** Coerces objects to their support before comparing them. *)
-
-Notation " x '`=' y " := ((x :>) = (y :>)) (at level 70).
-
-(** Quantifying over subsets. *)
-
-Notation "'fun' { x : A | P } => Q" :=
- (fun x:{x:A|P} => Q)
- (at level 200, x ident, right associativity).
-
-Notation "'forall' { x : A | P } , Q" :=
- (forall x:{x:A|P}, Q)
- (at level 200, x ident, right associativity).
-
-Require Import Coq.Bool.Sumbool.
-
-(** Construct a dependent disjunction from a boolean. *)
-
-Notation "'dec'" := (sumbool_of_bool) (at level 0).
-
-(** The notations [in_right] and [in_left] construct objects of a dependent disjunction. *)
-
-Notation in_right := (@right _ _ _).
-Notation in_left := (@left _ _ _).
-
-(** Default simplification tactic. *)
-
-Ltac subtac_simpl := simpl ; intros ; destruct_conjs ; simpl in * ; try subst ;
- try (solve [ red ; intros ; discriminate ]) ; auto with *.
-
-(** Extraction directives *)
-Extraction Inline proj1_sig.
-Extract Inductive unit => "unit" [ "()" ].
-Extract Inductive bool => "bool" [ "true" "false" ].
-Extract Inductive sumbool => "bool" [ "true" "false" ].
-(* Extract Inductive prod "'a" "'b" => " 'a * 'b " [ "(,)" ]. *)
-(* Extract Inductive sigT => "prod" [ "" ]. *)
-
-Require Export ProofIrrelevance.
-Require Export Coq.subtac.Heq.
-
-Delimit Scope program_scope with program.
diff --git a/contrib/subtac/eterm.ml b/contrib/subtac/eterm.ml
index 2a84fdd0..9bfb33ea 100644
--- a/contrib/subtac/eterm.ml
+++ b/contrib/subtac/eterm.ml
@@ -14,17 +14,21 @@ open Util
open Subtac_utils
let trace s =
- if !Options.debug then (msgnl s; msgerr s)
+ if !Flags.debug then (msgnl s; msgerr s)
else ()
+let succfix (depth, fixrels) =
+ (succ depth, List.map succ fixrels)
+
(** Substitute evar references in t using De Bruijn indices,
where n binders were passed through. *)
let subst_evar_constr evs n 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 c = match kind_of_term c with
+ let rec substrec (depth, fixrels) c = match kind_of_term c with
| Evar (k, args) ->
- let (id, idstr), hyps, chop, _, _ =
+ let (id, idstr), hyps, chop, _, _, _ =
try evar_info k
with Not_found ->
anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found")
@@ -42,7 +46,7 @@ let subst_evar_constr evs n t =
let rec aux hyps args acc =
match hyps, args with
((_, None, _) :: tlh), (c :: tla) ->
- aux tlh tla ((map_constr_with_binders succ substrec depth c) :: acc)
+ aux tlh tla ((map_constr_with_binders succfix substrec (depth, fixrels) c) :: acc)
| ((_, Some _, _) :: tlh), (_ :: tla) ->
aux tlh tla acc
| [], [] -> acc
@@ -53,11 +57,15 @@ let subst_evar_constr evs n t =
int (List.length hyps) ++ str " hypotheses" ++ spc () ++
pp_list (fun x -> my_print_constr (Global.env ()) x) args);
with _ -> ());
+ 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 (mkVar idstr, Array.of_list args)
- | _ -> map_constr_with_binders succ substrec depth c
+ | 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
+ let t' = substrec (0, []) t in
+ t', !seen, !transparent
(** Substitute variable references in t using De Bruijn indices,
@@ -74,26 +82,29 @@ let subst_vars acc n t =
to a product : forall H1 : t1, ..., forall Hn : tn, concl.
Changes evars and hypothesis references to variable references.
A little optimization: don't include unnecessary let-ins and their dependencies.
-*)
+*)
let etype_of_evar evs hyps concl =
let rec aux acc n = function
(id, copt, t) :: tl ->
- let t', s = subst_evar_constr evs n t in
+ let t', s, trans = subst_evar_constr evs n t in
let t'' = subst_vars acc 0 t' in
- let rest, s' = aux (id :: acc) (succ n) tl 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 ->
- if noccurn 1 rest then lift (-1) rest, s'
+ if noccurn 1 rest then lift (-1) rest, s', trans'
else
- let c', s'' = subst_evar_constr evs n c in
+ let c', s'', trans'' = subst_evar_constr evs n c in
let c' = subst_vars acc 0 c' in
- mkNamedProd_or_LetIn (id, Some c', t'') rest, Intset.union s'' s'
+ 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')
+ mkNamedProd_or_LetIn (id, None, t'') rest, s', trans')
| [] ->
- let t', s = subst_evar_constr evs n concl in
- subst_vars acc 0 t', s
+ let t', s, trans = subst_evar_constr evs n concl in
+ subst_vars acc 0 t', s, trans
in aux [] 0 (rev hyps)
@@ -110,12 +121,14 @@ let rec chop_product n t =
| Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None
| _ -> None
-let eterm_obligations name nclen isevars evm fs t tycon =
+let eterm_obligations env name isevars evm fs t ty =
(* 'Serialize' the evars, we assume that the types of the existentials
refer to previous existentials in the list only *)
trace (str " In eterm: isevars: " ++ my_print_evardefs isevars);
trace (str "Term given to eterm" ++ spc () ++
Termops.print_constr_env (Global.env ()) t);
+ 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 evn =
let i = ref (-1) in
@@ -128,9 +141,9 @@ let eterm_obligations name nclen isevars evm fs t tycon =
(* Remove existential variables in types and build the corresponding products *)
fold_right
(fun (id, (n, nstr), ev) l ->
- let hyps = Environ.named_context_of_val ev.evar_hyps in
- let hyps = trunc_named_context nclen hyps in
- let evtyp, deps = etype_of_evar l hyps ev.evar_concl in
+ 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 ->
@@ -145,26 +158,28 @@ let eterm_obligations name nclen isevars evm fs t tycon =
let loc, k = evar_source id isevars in
let opacity = match k with QuestionMark o -> o | _ -> true in
let opaque = if not opacity || chop <> fs then None else Some chop in
- let y' = (id, ((n, nstr), hyps, opaque, evtyp, deps)) in
+ let y' = (id, ((n, nstr), hyps, opaque, loc, evtyp, deps)) in
y' :: l)
evn []
in
- let t', _ = (* Substitute evar refs in the term by variables *)
+ let t', _, transparent = (* Substitute evar refs in the term by variables *)
subst_evar_constr evts 0 t
in
+ let ty, _, _ = subst_evar_constr evts 0 ty in
let evars =
- List.map (fun (_, ((_, name), _, opaque, typ, deps)) -> name, typ, not (opaque = None), deps) evts
+ List.map (fun (_, ((_, name), _, opaque, loc, typ, deps)) ->
+ name, typ, loc, not (opaque = None) && not (Idset.mem name transparent), deps) evts
in
(try
trace (str "Term constructed in eterm" ++ spc () ++
Termops.print_constr_env (Global.env ()) t');
ignore(iter
- (fun (name, typ, _, deps) ->
+ (fun (name, typ, _, _, deps) ->
trace (str "Evar :" ++ spc () ++ str (string_of_id name) ++
Termops.print_constr_env (Global.env ()) typ))
evars);
with _ -> ());
- Array.of_list (List.rev evars), t'
+ Array.of_list (List.rev evars), t', ty
let mkMetas n = list_tabulate (fun _ -> Evarutil.mk_new_meta ()) n
diff --git a/contrib/subtac/eterm.mli b/contrib/subtac/eterm.mli
index 76994c06..007e327c 100644
--- a/contrib/subtac/eterm.mli
+++ b/contrib/subtac/eterm.mli
@@ -6,8 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: eterm.mli 9976 2007-07-12 11:58:30Z msozeau $ i*)
-
+(*i $Id: eterm.mli 10889 2008-05-06 14:05:20Z msozeau $ i*)
+open Environ
open Tacmach
open Term
open Evd
@@ -18,10 +18,11 @@ val mkMetas : int -> constr list
(* val eterm_term : evar_map -> constr -> types option -> constr * types option * (identifier * types) list *)
-(* id, named context length, evars, number of
- function prototypes to try to clear from evars contexts, object and optional type *)
-val eterm_obligations : identifier -> int -> evar_defs -> evar_map -> int -> constr -> types option ->
- (identifier * types * bool * Intset.t) array * constr
- (* Obl. name, type as product, opacity (true = opaque) and dependencies as indexes into the array *)
+(* env, id, evars, number of
+ function prototypes to try to clear from evars contexts, object and type *)
+val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> constr -> types ->
+ (identifier * types * loc * bool * Intset.t) array * constr * types
+ (* Obl. name, type as product, location of the original evar,
+ opacity (true = opaque) and dependencies as indexes into the array *)
val etermtac : open_constr -> tactic
diff --git a/contrib/subtac/g_subtac.ml4 b/contrib/subtac/g_subtac.ml4
index 43a3bec4..88243b60 100644
--- a/contrib/subtac/g_subtac.ml4
+++ b/contrib/subtac/g_subtac.ml4
@@ -6,15 +6,18 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(*i camlp4deps: "parsing/grammar.cma" i*)
+(*i camlp4use: "pa_extend.cmo" i*)
+
+
(*
Syntax for the subtac terms and types.
Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *)
-(* $Id: g_subtac.ml4 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: g_subtac.ml4 10919 2008-05-11 22:04:26Z msozeau $ *)
-(*i camlp4deps: "parsing/grammar.cma" i*)
-open Options
+open Flags
open Util
open Names
open Nameops
@@ -41,17 +44,20 @@ struct
let subtac_nameopt : identifier option Gram.Entry.e = gec "subtac_nameopt"
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 Constr.binder_let Constr.binder subtac_nameopt;
+ GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_nameopt;
subtac_gallina_loc:
- [ [ g = Vernac.gallina -> loc, g ] ]
+ [ [ g = Vernac.gallina -> loc, g
+ | g = Vernac.gallina_ext -> loc, g ] ]
;
subtac_nameopt:
@@ -60,31 +66,31 @@ GEXTEND Gram
;
Constr.binder_let:
- [ [ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" ->
- let typ = mkAppC (sigref, [mkLambdaC ([id], t, c)]) in
- LocalRawAssum ([id], typ)
+ [[ "("; 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],mkAppC (sigref, [mkLambdaC ([id], c, p)]))
+ ([id],default_binder_kind, mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, c, p)]))
| "("; id=Prim.name; ":"; c=Constr.lconstr; ")" ->
- ([id],c)
+ ([id],default_binder_kind, c)
| "("; id=Prim.name; lid=LIST1 Prim.name; ":"; c=Constr.lconstr; ")" ->
- (id::lid,c)
+ (id::lid,default_binder_kind, c)
] ];
END
-type ('a,'b) gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a, 'b) Genarg.abstract_argument_type
+type 'a gallina_loc_argtype = (Vernacexpr.vernac_expr located, 'a) Genarg.abstract_argument_type
-let (wit_subtac_gallina_loc : (Genarg.tlevel, Proof_type.tactic) gallina_loc_argtype),
- (globwit_subtac_gallina_loc : (Genarg.glevel, Tacexpr.glob_tactic_expr ) gallina_loc_argtype),
- (rawwit_subtac_gallina_loc : (Genarg.rlevel, Tacexpr.raw_tactic_expr) gallina_loc_argtype) =
+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 nameopt_argtype = (identifier option, 'a, 'a) Genarg.abstract_argument_type
+type 'a nameopt_argtype = (identifier option, 'a) Genarg.abstract_argument_type
let (wit_subtac_nameopt : Genarg.tlevel nameopt_argtype),
(globwit_subtac_nameopt : Genarg.glevel nameopt_argtype),
@@ -133,10 +139,18 @@ VERNAC COMMAND EXTEND Subtac_Admit_Obligations
END
VERNAC COMMAND EXTEND Subtac_Set_Solver
-| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.glob_tactic t) ]
+| [ "Obligations" "Tactic" ":=" tactic(t) ] -> [
+ Coqlib.check_required_library ["Coq";"Program";"Tactics"];
+ Tacinterp.add_tacdef false
+ [(Qualid (dummy_loc, qualid_of_string "Coq.Program.Tactics.obligations_tactic"), true, t)] ]
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/contrib/subtac/subtac.ml b/contrib/subtac/subtac.ml
index 8bc310d5..a59ad6f5 100644
--- a/contrib/subtac/subtac.ml
+++ b/contrib/subtac/subtac.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: subtac.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: subtac.ml 11150 2008-06-19 11:38:27Z msozeau $ *)
open Global
open Pp
@@ -49,24 +49,41 @@ 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 c typ in
+ (** Make all obligations transparent so that real dependencies can be sorted out by the user *)
+ let obls = Array.map (fun (id, t, l, op, d) -> (id, t, l, false, d)) obls in
+ match Subtac_obligations.add_definition stmt_id 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 id ->
+ | 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
- errorlabstrm "start_proof" (pr_id id ++ str " already exists");
+ user_err_loc (loc,"start_proof",pr_id id ++ str " already exists");
id
| None ->
next_global_ident_away false (id_of_string "Unnamed_thm")
(Pfedit.get_all_proof_names ())
in
- let evm, c, typ =
+ let evm, c, typ, _imps =
Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None
in
- let _ = Typeops.infer_type env c in
- Command.start_proof id kind c hook
+ let c = solve_tccs_in_type env id isevars evm c typ in
+ Command.start_proof id kind c hook
-let print_subgoals () = Options.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) ()
+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;
@@ -75,122 +92,157 @@ let start_proof_and_print env isevars idopt k t hook =
let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n)))
let assumption_message id =
- Options.if_verbose message ((string_of_id id) ^ " is assumed")
+ Flags.if_verbose message ((string_of_id id) ^ " is assumed")
-let declare_assumption env isevars idl is_coe k bl c =
- if not (Pfedit.refining ()) then
- let evm, c, typ =
- Subtac_pretyping.subtac_process env isevars (snd (List.hd idl)) [] (Command.generalize_constr_expr c bl) None
+let declare_assumption 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 [] (Command.generalize_constr_expr c bl) None
in
- List.iter (Command.declare_one_assumption is_coe k c) idl
+ let c = solve_tccs_in_type env id isevars evm c typ in
+ List.iter (Command.declare_one_assumption is_coe k c imps false false nl) idl
else
errorlabstrm "Command.Assumption"
(str "Cannot declare an assumption while in proof editing mode.")
-let vernac_assumption env isevars kind l =
- List.iter (fun (is_coe,(idl,c)) -> declare_assumption env isevars idl is_coe kind [] c) l
+let dump_definition (loc, id) s =
+ Flags.dump_string (Printf.sprintf "%s %d %s\n" s (fst (unloc loc)) (string_of_id id))
+
+let dump_constraint ty ((loc, n), _, _) =
+ match n with
+ | Name id -> dump_definition (loc, id) 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 !Flags.dump then
+ List.iter (fun lid ->
+ if global then dump_definition lid "ax"
+ else dump_variable lid) idl;
+ declare_assumption 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"];
-(* check_required_library ["Coq";"Logic";"JMeq"]; *)
- require_library "Coq.subtac.FixSub";
- require_library "Coq.subtac.Utils";
- require_library "Coq.Logic.JMeq";
+ check_required_library ["Coq";"Program";"Tactics"];
let env = Global.env () in
let isevars = ref (create_evar_defs Evd.empty) in
try
match command with
- VernacDefinition (defkind, (locid, id), expr, hook) ->
- (match expr with
- ProveBody (bl, c) -> Subtac_pretyping.subtac_proof env isevars id bl c None
- | DefineBody (bl, _, c, tycon) ->
- Subtac_pretyping.subtac_proof env isevars id bl c tycon)
- | VernacFixpoint (l, b) ->
- let _ = trace (str "Building fixpoint") in
- ignore(Subtac_command.build_recursive l b)
-
- | VernacStartTheoremProof (thkind, (locid, id), (bl, t), lettop, hook) ->
- if not(Pfedit.refining ()) then
- if lettop then
- errorlabstrm "Subtac_command.StartProof"
- (str "Let declarations can only be used in proof editing mode");
+ | VernacDefinition (defkind, (_, id as lid), expr, hook) ->
+ check_fresh lid;
+ dump_definition lid "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 id) (Global, Proof thkind) (bl,t) hook
-
-
- | VernacAssumption (stre,l) ->
- vernac_assumption env isevars stre l
-
- (*| 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
+ start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t)
+ (fun _ _ -> ())
+ | DefineBody (bl, _, c, tycon) ->
+ ignore(Subtac_pretyping.subtac_proof defkind env isevars id bl c tycon))
+ | VernacFixpoint (l, b) ->
+ List.iter (fun ((lid, _, _, _, _), _) ->
+ check_fresh lid;
+ dump_definition lid "fix") l;
+ let _ = trace (str "Building fixpoint") in
+ ignore(Subtac_command.build_recursive l b)
- | (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
-
-
+ | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) ->
+ if !Flags.dump then dump_definition id "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 (glob, sup, is, props, pri) ->
+ if !Flags.dump then dump_constraint "inst" is;
+ ignore(Subtac_classes.new_instance ~global:glob sup is props pri)
+
+ | VernacCoFixpoint (l, b) ->
+ List.iter (fun ((lid, _, _, _), _) -> dump_definition lid "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, 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/contrib/subtac/subtac_cases.ml b/contrib/subtac/subtac_cases.ml
index 04cad7c0..c7182bd2 100644
--- a/contrib/subtac/subtac_cases.ml
+++ b/contrib/subtac/subtac_cases.ml
@@ -1,3 +1,4 @@
+(* -*- 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 *)
@@ -6,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: cases.ml 9399 2006-11-22 16:11:53Z herbelin $ *)
+(* $Id: subtac_cases.ml 11154 2008-06-19 18:42:19Z msozeau $ *)
open Cases
open Util
@@ -100,8 +101,7 @@ type equation =
rhs : rhs;
alias_stack : name list;
eqn_loc : loc;
- used : bool ref;
- tag : pattern_source }
+ used : bool ref }
type matrix = equation list
@@ -242,6 +242,7 @@ type pattern_matching_problem =
history : pattern_continuation;
mat : matrix;
caseloc : loc;
+ casestyle: case_style;
typing_function: type_constraint -> env -> rawconstr -> unsafe_judgment }
(*--------------------------------------------------------------------------*
@@ -386,7 +387,7 @@ let mkDeclTomatch na = function
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)
+ | 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
@@ -423,25 +424,6 @@ let remove_current_pattern eqn =
let prepend_pattern tms eqn = {eqn with patterns = tms@eqn.patterns }
(**********************************************************************)
-(* Dealing with regular and default patterns *)
-let is_regular eqn = eqn.tag = RegularPat
-
-let lower_pattern_status = function
- | RegularPat -> DefaultPat 0
- | DefaultPat n -> DefaultPat (n+1)
-
-let pattern_status pats =
- if array_exists ((=) RegularPat) pats then RegularPat
- else
- let min =
- Array.fold_right
- (fun pat n -> match pat with
- | DefaultPat i when i<n -> i
- | _ -> n)
- pats 0 in
- DefaultPat min
-
-(**********************************************************************)
(* Well-formedness tests *)
(* Partial check on patterns *)
@@ -499,7 +481,7 @@ let extract_rhs pb =
| [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion())
| eqn::_ ->
set_used_pattern eqn;
- eqn.tag, eqn.rhs
+ eqn.rhs
(**********************************************************************)
(* Functions to deal with matrix factorization *)
@@ -676,26 +658,6 @@ let all_name sign = List.map (fun (n, b, t) -> let n = match n with Name _ -> n
let push_rels_eqn sign eqn =
let sign = all_name sign in
-(* trace (str "push_rels_eqn: " ++ my_print_rel_context eqn.rhs.rhs_env sign ++ str "end"); *)
-(* str " branch is " ++ my_print_constr (fst eqn.rhs.c_orig) (snd eqn.rhs.c_orig)); *)
-(* let rhs = eqn.rhs in *)
-(* let l, c, s, e = *)
-(* List.fold_right *)
-(* (fun (na, c, t) (itlift, it, sign, env) -> *)
-(* (try trace (str "Pushing decl: " ++ pr_rel_decl env (na, c, t) ++ *)
-(* str " lift is " ++ int itlift); *)
-(* with _ -> trace (str "error in push_rels_eqn")); *)
-(* let env' = push_rel (na, c, t) env in *)
-(* match sign with *)
-(* [] -> (itlift, lift 1 it, sign, env') *)
-(* | (na', c, t) :: sign' -> *)
-(* if na' = na then *)
-(* (pred itlift, it, sign', env') *)
-(* else ( *)
-(* trace (str "skipping it"); *)
-(* (itlift, liftn 1 itlift it, sign, env'))) *)
-(* sign (rhs.rhs_lift, rhs.c_it, eqn.rhs.rhs_sign, eqn.rhs.rhs_env) *)
-(* in *)
{eqn with rhs = {eqn.rhs with rhs_env = push_rels sign eqn.rhs.rhs_env; } }
let push_rels_eqn_with_names sign eqn =
@@ -1126,7 +1088,6 @@ let group_equations pb ind current cstrs mat =
for i=1 to Array.length cstrs do
let n = cstrs.(i-1).cs_nargs in
let args = make_anonymous_patvars n in
- let rest = {rest with tag = lower_pattern_status rest.tag } in
brs.(i-1) <- (args, rest) :: brs.(i-1)
done
| PatCstr (loc,((_,i)),args,_) ->
@@ -1148,22 +1109,22 @@ let rec generalize_problem pb = function
let tomatch = regeneralize_index_tomatch (i+1) tomatch in
{ pb with
tomatch = Abstract d :: tomatch;
- pred = option_map (generalize_predicate i d) pb'.pred }
+ pred = Option.map (generalize_predicate i d) pb'.pred }
(* No more patterns: typing the right-hand-side of equations *)
let build_leaf pb =
- let tag, rhs = extract_rhs pb in
+ 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
- tag, pb.typing_function tycon rhs.rhs_env rhs.it
+ 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;
+ 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 }
@@ -1228,7 +1189,7 @@ let build_branch current deps pb eqns const_info =
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
+ let pred' = Option.map (specialize_predicate (List.rev typs') dep_sign const_info) pb.pred in
sign,
{ pb with
env = env';
@@ -1279,33 +1240,30 @@ and match_current pb tomatch =
let brs = array_map2 (compile_branch current deps pb) eqns cstrs in
(* We build the (elementary) case analysis *)
- let tags = Array.map (fun (t,_,_) -> t) brs in
- let brvals = Array.map (fun (_,v,_) -> v) brs in
- let brtyps = Array.map (fun (_,_,t) -> t) brs in
+ 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 RegularStyle tags in
+ let ci = make_case_info pb.env mind pb.casestyle in
let case = mkCase (ci,nf_betaiota pred,current,brvals) in
let inst = List.map mkRel deps in
- pattern_status tags,
{ 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 tag, j = compile pb in
- (tag, it_mkLambda_or_LetIn j.uj_val sign, j.uj_type)
+ 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;
+ pred = Option.map ungeneralize_predicate pb.pred;
mat = List.map (push_rels_eqn [d]) pb.mat } in
- let patstat,j = compile pb in
- patstat,
+ let j = compile pb in
{ uj_val = mkLambda_or_LetIn d j.uj_val;
uj_type = mkProd_or_LetIn d j.uj_type }
@@ -1328,11 +1286,10 @@ and compile_alias pb (deppat,nondeppat,d,t) rest =
{pb with
env = newenv;
tomatch = tomatch;
- pred = option_map (lift_predicate n) pb.pred;
+ pred = Option.map (lift_predicate n) pb.pred;
history = history;
mat = mat } in
- let patstat,j = compile pb in
- patstat,
+ 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
@@ -1352,7 +1309,6 @@ let matx_of_eqns env eqns =
it = rhs;
} in
{ patterns = lpat;
- tag = RegularPat;
alias_stack = [];
eqn_loc = loc;
used = ref false;
@@ -1421,9 +1377,9 @@ let set_arity_signature dep n arsign tomatchl pred x =
let rec decomp_lam_force n avoid l p =
if n = 0 then (List.rev l,p,avoid) else
match p with
- | RLambda (_,(Name id as na),_,c) ->
+ | RLambda (_,(Name id as na),k,_,c) ->
decomp_lam_force (n-1) (id::avoid) (na::l) c
- | RLambda (_,(Anonymous as na),_,c) -> decomp_lam_force (n-1) avoid (na::l) c
+ | RLambda (_,(Anonymous as na),k,_,c) -> decomp_lam_force (n-1) avoid (na::l) c
| _ ->
let x = next_ident_away (id_of_string "x") avoid in
decomp_lam_force (n-1) (x::avoid) (Name x :: l)
@@ -1513,7 +1469,7 @@ let extract_arity_signature env0 tomatchl tmsign =
match tm with
| NotInd (bo,typ) ->
(match t with
- | None -> [na,option_map (lift n) bo,lift n typ]
+ | 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"))
@@ -1612,7 +1568,8 @@ let eq_id avoid id =
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 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 true)
@@ -1626,18 +1583,14 @@ let context_of_arsign l =
let constr_of_pat env isevars arsign pat avoid =
let rec typ env (ty, realargs) pat avoid =
- trace (str "Typing pattern " ++ Printer.pr_cases_pattern pat ++ str " in env " ++
- print_env env ++ str" should have type: " ++ my_print_constr env ty);
match pat with
| PatVar (l,name) ->
- trace (str "Treating pattern variable " ++ str (string_of_id (id_of_name 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
- trace (str "Treated pattern variable " ++ str (string_of_id (id_of_name name)));
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
@@ -1665,11 +1618,8 @@ let constr_of_pat env isevars arsign pat avoid =
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
- trace (str "Getting type of app: " ++ my_print_constr env app);
let apptype = Retyping.get_type_of env (Evd.evars_of !isevars) app in
- trace (str "Family and args of apptype: " ++ my_print_constr env apptype);
let IndType (indf, realargs) = find_rectype env (Evd.evars_of !isevars) apptype in
- trace (str "Got Family and args of apptype: " ++ my_print_constr env apptype);
match alias with
Anonymous ->
pat', sign, app, apptype, realargs, n, avoid
@@ -1680,8 +1630,6 @@ let constr_of_pat env isevars arsign pat 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;
- trace (str "convertible types for alias : " ++ my_print_constr env (lift (succ m) ty)
- ++ my_print_constr env (lift 1 apptype));
let eq_t = mk_eq (lift (succ m) ty)
(mkRel 1) (* alias *)
(lift 1 app) (* aliased term *)
@@ -1693,15 +1641,8 @@ let constr_of_pat env isevars arsign pat avoid =
(* Mark the equality as a hole *)
pat', sign, lift i app, lift i apptype, realargs, n + i, avoid
in
-(* let tycon, arity = mk_tycon_from_sign env isevars arsign arity in *)
let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in
- let c = it_mkProd_or_LetIn patc sign in
- trace (str "arity signature is : " ++ my_print_rel_context env arsign);
- trace (str "signature is : " ++ my_print_rel_context env sign);
- trace (str "patty, args are : " ++ my_print_constr env (applistc patty args));
- trace (str "Constr_of_pat gives: " ++ my_print_constr env c);
- trace (str "with args: " ++ pp_list (my_print_constr (push_rels sign env)) args);
- pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
+ pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid
(* shadows functional version *)
@@ -1729,7 +1670,7 @@ let vars_of_ctx ctx =
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", [])
+ ctx (id_of_string "vars_of_ctx_error", [])
in List.rev y
let rec is_included x y =
@@ -1740,14 +1681,17 @@ let rec is_included x y =
if i = i' then List.for_all2 is_included args args'
else false
-(* liftsign is the current pattern's signature length *)
+(* 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
- (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat)
+ 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
@@ -1757,21 +1701,16 @@ let build_ineqs prevpatterns pats liftsign =
let lens = List.length ppat_sign in
(* Accumulated length of previous pattern's signatures *)
let len' = lens + len in
- trace (str "Lifting " ++ my_print_constr Environ.empty_env curpat_c ++ str " by "
- ++ int len');
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 (lens + liftsign) ppat_ty ;
- liftn liftsign (succ lens) ppat_c ;
+ [| lift (len' + liftsign) curpat_ty;
+ liftn (len + liftsign) (succ lens) ppat_c ;
lift len' curpat_c |]) ::
- List.map
- (fun t ->
- liftn (List.length curpat_sign) (succ len') (* Jump over the curpat signature *)
- (lift lens t (* Jump over this prevpat signature *))) c)
+ List.map (lift lens (* Jump over this prevpat signature *)) c)
in Some acc
else None)
(Some ([], 0, 0, [])) eqnpats pats
@@ -1790,20 +1729,19 @@ 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))
+ (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,type_app (liftn n k) t)
- ::(liftrec (k-1) 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 tycon env isevars eqns tomatchs sign neqs eqs arity =
+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
@@ -1815,71 +1753,53 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs ari
(idents, pat' :: newpatterns, cpat :: pats))
([], [], []) eqn.patterns sign
in
- let newpatterns = List.rev newpatterns and pats = List.rev pats 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 *)
-(* trace (str "treating pattern:" ++ my_print_constr Environ.empty_env c); *)
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) pats in
+ ([], [], 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
+ ([], 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
-(* trace (str "Env with signature is: " ++ my_print_env _signenv); *)
- let ineqs = build_ineqs prevpatterns pats signlen in
- let eqs_rels =
- let eqs = (*List.concat (List.rev eqs)*) context_of_arsign eqs in
+ let arity =
let args, nargs =
List.fold_right (fun (sign, c, (_, args), _) (allargs,n) ->
-(* trace (str "treating arg:" ++ my_print_constr Environ.empty_env c); *)
(args @ c :: allargs, List.length args + succ n))
pats ([], 0)
in
let args = List.rev args in
-(* trace (str " equalities " ++ my_print_rel_context Environ.empty_env eqs); *)
-(* trace (str " args " ++ pp_list (my_print_constr _signenv) args); *)
- (* Make room for substitution of prime arguments by constr patterns *)
- let eqs' = lift_rel_contextn signlen nargs eqs in
- let eqs'' = subst_rel_context 0 eqs' args in
-(* trace (str " new equalities " ++ my_print_rel_context Environ.empty_env eqs'); *)
-(* trace (str " subtituted equalities " ++ my_print_rel_context _signenv eqs''); *)
- eqs''
+ substl args (liftn signlen (succ nargs) arity)
in
- let rhs_rels', lift_ineqs =
- match ineqs with
- None -> eqs_rels @ rhs_rels', 0
- | Some ineqs ->
- (* let _ = trace (str"Generated inequalities: " ++ my_print_constr env ineqs) in *)
- lift_rel_context 1 eqs_rels @ ((Anonymous, None, ineqs) :: rhs_rels'), 1
+ 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
-(* (try trace (str "branch env: " ++ print_env rhs_env) *)
-(* with _ -> trace (str "error in print branch env")); *)
- let tycon = lift_tycon (List.length eqs_rels + lift_ineqs + signlen) tycon in
-
- let j = typing_fun tycon rhs_env eqn.rhs.it in
-(* (try trace (str "in env: " ++ my_print_env rhs_env ++ str"," ++ *)
-(* str "Typed branch: " ++ Prettyp.print_judgment rhs_env j); *)
-(* with _ -> *)
-(* trace (str "Error in typed branch pretty printing")); *)
+ 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
- (* (try trace (str "Branch decl: " ++ pr_rel_decl env (Name branch_name, Some bbody, btype)) *)
- (* with _ -> trace (str "Error in branch decl pp")); *)
let branch =
let bref = RVar (dummy_loc, branch_name) in
match vars_of_ctx rhs_rels with
@@ -1890,22 +1810,13 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs ari
Some _ -> RApp (dummy_loc, branch, [ hole ])
| None -> branch
in
- (* let branch = *)
- (* List.fold_left (fun br (eqH, _, t) -> RLambda (dummy_loc, eqH, RHole (dummy_loc, Evd.InternalHole), br)) branch eqs_rels *)
- (* in *)
- (* (try trace (str "New branch: " ++ Printer.pr_rawconstr branch) *)
- (* with _ -> trace (str "Error in new branch pp")); *)
- incr i;
- let rhs = { eqn.rhs with it = branch } in
- (branch_decl :: branches,
- { eqn with patterns = newpatterns; rhs = rhs } :: eqns,
- pats :: prevpatterns))
+ 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
-
-
-(* liftn_rel_declaration *)
-
(* Builds the predicate. If the predicate is dependent, its context is
* made of 1+nrealargs assumptions for each matched term in an inductive
@@ -1920,11 +1831,6 @@ let constrs_of_pats typing_fun tycon env isevars eqns tomatchs sign neqs eqs ari
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
-(* (try List.iter *)
-(* (fun arsign -> *)
-(* trace (str "arity signature: " ++ my_print_rel_context env arsign)) *)
-(* arsign; *)
-(* with _ -> trace (str "error in arity signature printing")); *)
let env = List.fold_right push_rels arsign env in
let allnames = List.rev (List.map (List.map pi1) arsign) in
match rtntyp with
@@ -1984,15 +1890,10 @@ let build_dependent_signature env evars avoid tomatchs arsign =
(* 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 _ = trace (str "Working on dependent arg: " ++ my_print_rel_context *)
-(* (push_rel_context argsign env) [_appsign]) *)
-(* in *)
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) ->
-(* trace (str "Matching indexes: " ++ my_print_constr env arg ++ *)
-(* str " and " ++ my_print_rel_context env [(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
@@ -2001,7 +1902,7 @@ let build_dependent_signature env evars avoid tomatchs arsign =
(lift (nargeqs + nar) arg),
mk_eq_refl argt arg)
else
- (mk_JMeq (lift (nargeqs + slift) appt)
+ (mk_JMeq (lift (nargeqs + slift) t)
(mkRel (nargeqs + slift))
(lift (nargeqs + nar) argt)
(lift (nargeqs + nar) arg),
@@ -2022,10 +1923,6 @@ let build_dependent_signature env evars avoid tomatchs arsign =
(Name id, b, t) :: argsign'))
(env, 0, [], [], slift, []) args argsign
in
-(* trace (str "neqs: " ++ int neqs ++ spc () ++ *)
-(* str "nargeqs: " ++ int nargeqs ++spc () ++ *)
-(* str "slift: " ++ int slift ++spc () ++ *)
-(* str "nar: " ++ int nar); *)
let eq = mk_JMeq
(lift (nargeqs + slift) appt)
(mkRel (nargeqs + slift))
@@ -2045,15 +1942,10 @@ let build_dependent_signature env evars avoid tomatchs arsign =
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 _ = trace (str "Working on arg: " ++ my_print_rel_context *)
-(* env [arsign']) *)
-(* in *)
let tomatch_ty = type_of_tomatch ty in
let eq =
mk_eq (lift nar tomatch_ty)
(mkRel slift) (lift nar tm)
-(* mk_eq (lift (neqs + nar) tomatch_ty) *)
-(* (mkRel (neqs + slift)) (lift (neqs + nar) tm) *)
in
([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs,
(mk_eq_refl tomatch_ty tm) :: refl_args,
@@ -2062,28 +1954,7 @@ let build_dependent_signature env evars avoid tomatchs arsign =
in
let arsign'' = List.rev arsign' in
assert(slift = 0); (* we must have folded over all elements of the arity signature *)
-(* begin try *)
-(* List.iter *)
-(* (fun arsign -> *)
-(* trace (str "old arity signature: " ++ my_print_rel_context env arsign)) *)
-(* arsign; *)
- List.iter
- (fun c ->
- trace (str "new arity signature: " ++ my_print_rel_context env c))
- (arsign'');
-(* with _ -> trace (str "error in arity signature printing") *)
-(* end; *)
- let env' = push_rel_context (context_of_arsign arsign') env in
- let _eqsenv = push_rel_context (context_of_arsign eqs) env' in
- (try trace (str "Where env with eqs is: " ++ my_print_env _eqsenv);
- trace (str "args: " ++ List.fold_left (fun acc x -> acc ++ my_print_constr env x)
- (mt()) refls)
- with _ -> trace (str "error in equalities signature printing"));
- arsign'', allnames, nar, eqs, neqs, refls
-
-(* let len = List.length eqs in *)
-(* it_mkProd_wo_LetIn (lift (nar + len) pred) eqs, pred, len *)
-
+ arsign'', allnames, nar, eqs, neqs, refls
(**************************************************************************)
(* Main entry of the matching compilation *)
@@ -2091,8 +1962,7 @@ let build_dependent_signature env evars avoid tomatchs arsign =
let liftn_rel_context n k sign =
let rec liftrec k = function
| (na,c,t)::sign ->
- (na,option_map (liftn n k) c,type_app (liftn n k) t)
- ::(liftrec (k-1) sign)
+ (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign)
| [] -> []
in
liftrec (k + rel_context_length sign) sign
@@ -2101,73 +1971,109 @@ let nf_evars_env evar_defs (env : env) : env =
let nf t = nf_isevar evar_defs 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'
+ 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')
+ 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 compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns) =
+(* 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 _ when not (dependent tm c)
+ && signlen > 1 (* The term is of a dependent type but does not appear in
+ the tycon, maybe some variable in its type does. *) ->
+ (match tmtype with
+ NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *)
+ | IsInd (_, IndType(indf,realargs)) ->
+ 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
+
+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
-(* isevars := nf_evar_defs !isevars; *)
-(* let env = nf_evars_env !isevars (env : env) in *)
-(* trace (str "Evars : " ++ my_print_evardefs !isevars); *)
-(* trace (str "Env : " ++ my_print_env env); *)
-
- let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in
- let tomatchs_len = List.length tomatchs_lets in
- let tycon = lift_tycon tomatchs_len tycon in
- let env = push_rel_context tomatchs_lets env in
let _isdep = List.exists (fun (x, y) -> is_dependent_ind y) tomatchs in
if predopt = None then
+ let tomatchs, tomatchs_lets = abstract_tomatch env tomatchs in
+ let tomatchs_len = List.length tomatchs_lets 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. *)
- trace (str "Arity signatures : " ++ my_print_rel_context env (context_of_arsign arsign));
let avoid = [] in
build_dependent_signature env (Evd.evars_of !isevars) avoid tomatchs arsign
in
- let tycon_constr =
+ let tycon, arity =
match valcon_of_tycon tycon with
- | None -> mkExistential env isevars
- | Some t -> t
+ | None -> let ev = mkExistential env isevars in ev, ev
+ | Some t ->
+ t, prepare_predicate_from_arsign_tycon loc env (Evd.evars_of !isevars)
+ tomatchs sign (lift tomatchs_len t)
+ in
+ let arity =
+ it_mkProd_or_LetIn (lift neqs arity) (context_of_arsign eqs)
in
let lets, matx =
(* Type the rhs under the assumption of equations *)
- constrs_of_pats typing_fun tycon env isevars matx tomatchs sign neqs
- (eqs : rel_context list) (lift (signlen + neqs) tycon_constr) in
-
+ 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 sign = List.map (lift_rel_context len) sign in
- let pred = it_mkProd_wo_LetIn (lift (signlen + neqs) tycon_constr)
- (context_of_arsign eqs) in
+ let pred = liftn len (succ signlen) arity in
+ let pred = build_initial_predicate true allnames pred in
- let pred = liftn len (succ signlen) pred in
-(* it_mkProd_wo_LetIn (lift (len + signlen + neqs) tycon_constr) (liftn_rel_context len signlen eqs) in*)
- (* We build the elimination predicate if any and check its consistency *)
- (* with the type of arguments to match *)
- let _signenv = List.fold_right push_rels sign env in
-(* trace (str "Using predicate: " ++ my_print_constr signenv pred ++ str " in env: " ++ my_print_env signenv ++ str " len is " ++ int len); *)
-
- let pred =
- (* prepare_predicate_from_tycon loc typing_fun isevars env tomatchs eqs allnames signlen sign tycon in *)
- 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) *)
+ (* 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 =
@@ -2178,17 +2084,17 @@ let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) e
history = start_history (List.length initial_pushed);
mat = matx;
caseloc = loc;
+ casestyle= style;
typing_function = typing_fun } in
- let _, j = compile pb 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 = lift (-tomatchs_len) (nf_isevar !isevars tycon_constr); }
+ uj_type = nf_isevar !isevars tycon; }
in j
-(* inh_conv_coerce_to_tycon loc env isevars j tycon0 *)
else
(* We build the elimination predicate if any and check its consistency *)
(* with the type of arguments to match *)
@@ -2207,12 +2113,12 @@ let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) e
history = start_history (List.length initial_pushed);
mat = matx;
caseloc = loc;
+ casestyle= style;
typing_function = typing_fun } in
- let _, j = compile pb in
+ let j = compile pb in
(* We check for unused patterns *)
List.iter (check_unused_pattern env) matx;
- let j = { j with uj_val = it_mkLambda_or_LetIn j.uj_val tomatchs_lets } in
inh_conv_coerce_to_tycon loc env isevars j tycon
end
diff --git a/contrib/subtac/subtac_cases.mli b/contrib/subtac/subtac_cases.mli
index 02fe016d..6b8a0981 100644
--- a/contrib/subtac/subtac_cases.mli
+++ b/contrib/subtac/subtac_cases.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: cases.mli 8741 2006-04-26 22:30:32Z herbelin $ i*)
+(*i $Id: subtac_cases.mli 10739 2008-04-01 14:45:20Z herbelin $ i*)
(*i*)
open Util
diff --git a/contrib/subtac/subtac_classes.ml b/contrib/subtac/subtac_classes.ml
new file mode 100644
index 00000000..15addb44
--- /dev/null
+++ b/contrib/subtac/subtac_classes.ml
@@ -0,0 +1,210 @@
+(************************************************************************)
+(* 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: subtac_classes.ml 11047 2008-06-03 23:08:00Z msozeau $ 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_binder_evars evdref env na t =
+ let t = Constrintern.intern_gen true (Evd.evars_of !evdref) env t in
+ SPretyping.understand_tcc_evars evdref env IsType t
+
+let interp_binders_evars isevars env avoid l =
+ List.fold_left
+ (fun (env, ids, params) ((loc, i), t) ->
+ let n = Name i in
+ let t' = interp_binder_evars isevars env n t in
+ let d = (i,None,t') in
+ (push_named d env, i :: ids, d::params))
+ (env, avoid, []) l
+
+let interp_typeclass_context_evars isevars env avoid l =
+ List.fold_left
+ (fun (env, ids, params) (iid, bk, cl) ->
+ let t' = interp_binder_evars isevars env (snd iid) cl in
+ let i = match snd iid with
+ | Anonymous -> Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids
+ | Name id -> id
+ in
+ let d = (i,None,t') in
+ (push_named d env, i :: ids, d::params))
+ (env, avoid, []) l
+
+let interp_constrs_evars isevars env avoid l =
+ List.fold_left
+ (fun (env, ids, params) t ->
+ let t' = interp_binder_evars isevars env Anonymous t in
+ let id = Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids in
+ let d = (id,None,t') in
+ (push_named d env, id :: ids, d::params))
+ (env, avoid, []) l
+
+let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c =
+ SPretyping.understand_tcc_evars evdref env kind
+ (intern_gen (kind=IsType) ~impls (Evd.evars_of !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 type_ctx_instance isevars env ctx inst subst =
+ List.fold_left2
+ (fun (subst, instctx) (na, _, t) ce ->
+ let t' = replace_vars subst t in
+ let c = interp_casted_constr_evars isevars env ce t' in
+ let d = na, Some c, t' in
+ (na, c) :: subst, d :: instctx)
+ (subst, []) (List.rev ctx) inst
+
+(*let superclass_ce = CRef (Ident (dummy_loc, id_of_string ".superclass"))*)
+
+let type_class_instance_params isevars env id n ctx inst subst =
+ List.fold_left2
+ (fun (subst, instctx) (na, _, t) ce ->
+ let t' = replace_vars subst t in
+ let c =
+(* if ce = superclass_ce then *)
+ (* (\* Control over the evars which are direct superclasses to avoid partial instanciations *)
+ (* in instance search. *\) *)
+ (* Evarutil.e_new_evar isevars env ~src:(dummy_loc, ImplicitArg (VarRef id, (n, Some na))) t' *)
+ (* else *)
+ interp_casted_constr_evars isevars env ce t'
+ in
+ let d = na, Some c, t' in
+ (na, c) :: subst, d :: instctx)
+ (subst, []) (List.rev ctx) inst
+
+let substitution_of_constrs ctx cstrs =
+ List.fold_right2 (fun c (na, _, _) acc -> (na, c) :: acc) cstrs ctx []
+
+let new_instance ?(global=false) ctx (instid, bk, cl) props ?(on_free_vars=Classes.default_on_free_vars) pri =
+ let env = Global.env() in
+ let isevars = ref (Evd.create_evar_defs Evd.empty) in
+ let bound = Implicit_quantifiers.ids_of_list (Termops.ids_of_context env) in
+ let bound, fvs = Implicit_quantifiers.free_vars_of_binders ~bound [] ctx in
+ let tclass =
+ match bk with
+ | Implicit ->
+ let loc, id, par = Implicit_quantifiers.destClassAppExpl cl in
+ let k = class_info (Nametab.global id) in
+ let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in
+ let needlen = List.fold_left (fun acc (x, y) -> if x = None then succ acc else acc) 0 k.cl_context in
+ if needlen <> applen then
+ Classes.mismatched_params env (List.map fst par) (List.map snd k.cl_context);
+ let pars, _ = Implicit_quantifiers.combine_params Idset.empty (* need no avoid *)
+ (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) (* (Evd.ImplicitArg (IndRef k.cl_impl, (1, None)))) *)
+ else CHole (Util.dummy_loc, None)
+ in t, avoid
+ | None -> failwith ("new instance: under-applied typeclass"))
+ par (List.rev k.cl_context)
+ in Topconstr.CAppExpl (loc, (None, id), pars)
+
+ | Explicit -> cl
+ in
+ let ctx_bound = Idset.union bound (Implicit_quantifiers.ids_of_list fvs) in
+ let gen_ids = Implicit_quantifiers.free_vars_of_constr_expr ~bound:ctx_bound tclass [] in
+ let bound = Idset.union (Implicit_quantifiers.ids_of_list gen_ids) ctx_bound in
+ on_free_vars (List.rev (gen_ids @ fvs));
+ let gen_ctx = Implicit_quantifiers.binder_list_of_ids gen_ids in
+ let ctx, avoid = Classes.name_typeclass_binders bound ctx in
+ let ctx = List.append ctx (List.rev gen_ctx) in
+ let k, ctx', imps, subst =
+ let c = Command.generalize_constr_expr tclass ctx in
+ let c', imps = interp_type_evars_impls ~evdref:isevars env c in
+ let ctx, c = Classes.decompose_named_assum c' in
+ let cl, args = Typeclasses.dest_class_app c in
+ cl, ctx, imps, substitution_of_constrs (List.map snd cl.cl_context) (List.rev (Array.to_list 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
+ Termops.next_global_ident_away false i (Termops.ids_of_context env)
+ in
+ let env' = Classes.push_named_context ctx' env in
+ isevars := Evarutil.nf_evar_defs !isevars;
+ isevars := resolve_typeclasses ~onlyargs:false ~fail:true env' !isevars;
+ let sigma = Evd.evars_of !isevars in
+ let substctx = Typeclasses.nf_substitution sigma subst in
+ let subst, _propsctx =
+ let props =
+ List.map (fun (x, l, d) ->
+ x, Topconstr.abstract_constr_expr d (Classes.binders_of_lidents l))
+ props
+ in
+ if List.length props > List.length k.cl_props then
+ Classes.mismatched_props env' (List.map snd props) k.cl_props;
+ let props, rest =
+ List.fold_left
+ (fun (props, rest) (id,_,_) ->
+ try
+ let ((loc, mid), c) = List.find (fun ((_,id'), c) -> id' = id) rest in
+ let rest' = List.filter (fun ((_,id'), c) -> id' <> id) rest in
+ Constrintern.add_glob loc (ConstRef (List.assoc mid k.cl_projs));
+ c :: props, rest'
+ with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest)
+ ([], props) k.cl_props
+ in
+ if rest <> [] then
+ unbound_method env' k.cl_impl (fst (List.hd rest))
+ else
+ type_ctx_instance isevars env' k.cl_props props substctx
+ in
+ let inst_constr, ty_constr = instance_constructor k (List.rev_map snd subst) in
+ isevars := Evarutil.nf_evar_defs !isevars;
+ let term = Evarutil.nf_isevar !isevars (it_mkNamedLambda_or_LetIn inst_constr ctx')
+ and termtype = Evarutil.nf_isevar !isevars (it_mkNamedProd_or_LetIn ty_constr ctx')
+ in
+ isevars := undefined_evars !isevars;
+ Evarutil.check_evars env Evd.empty !isevars termtype;
+(* let imps = *)
+(* Util.list_map_i *)
+(* (fun i binder -> *)
+(* match binder with *)
+(* ExplByPos (i, Some na), (true, true)) *)
+(* 1 ctx *)
+(* in *)
+ let hook gr =
+ let cst = match gr with ConstRef kn -> kn | _ -> assert false in
+ let inst = Typeclasses.new_instance k pri global cst in
+ Impargs.declare_manual_implicits false gr false imps;
+ Typeclasses.add_instance inst
+ in
+ let evm = Subtac_utils.evars_of_term (Evd.evars_of !isevars) Evd.empty term in
+ let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in
+ ignore(Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls);
+ id
diff --git a/contrib/subtac/subtac_classes.mli b/contrib/subtac/subtac_classes.mli
new file mode 100644
index 00000000..43f00107
--- /dev/null
+++ b/contrib/subtac/subtac_classes.mli
@@ -0,0 +1,42 @@
+(************************************************************************)
+(* 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: subtac_classes.mli 10797 2008-04-15 13:19:33Z msozeau $ 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_defs ref ->
+ Environ.env ->
+ (Names.identifier * 'a * Term.constr) list ->
+ Topconstr.constr_expr list ->
+ (Names.identifier * Term.constr) list ->
+ (Names.identifier * Term.constr) list *
+ (Names.identifier * Term.constr option * Term.constr) list
+
+val new_instance :
+ ?global:bool ->
+ Topconstr.local_binder list ->
+ typeclass_constraint ->
+ binder_def_list ->
+ ?on_free_vars:(identifier list -> unit) ->
+ int option ->
+ identifier
diff --git a/contrib/subtac/subtac_coercion.ml b/contrib/subtac/subtac_coercion.ml
index c764443f..b45e23d0 100644
--- a/contrib/subtac/subtac_coercion.ml
+++ b/contrib/subtac/subtac_coercion.ml
@@ -1,3 +1,4 @@
+(* -*- 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 *)
@@ -5,7 +6,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: subtac_coercion.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: subtac_coercion.ml 11143 2008-06-18 15:52:42Z msozeau $ *)
open Util
open Names
@@ -129,34 +130,45 @@ module Coercion = struct
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 rec coerce_application typ c c' l l' =
+ let rec coerce_application typ typ' c c' l l' =
let len = Array.length l in
- let rec aux tele typ i co =
+ let rec aux tele typ typ' i co =
+(* (try trace (str "coerce_application.aux from " ++ (my_print_constr env x) ++ *)
+(* str " to "++ my_print_constr env y *)
+(* ++ str "in env:" ++ my_print_env env); *)
+(* with _ -> ()); *)
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) = destProd typ in
- aux (hdx :: tele) (subst1 hdy restT) (succ i) co
+ let (n', eqT', restT') = destProd typ' in
+ aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co
with Reduction.NotConvertible ->
let (n, eqT, restT) = destProd typ in
+ let (n', eqT', restT') = destProd 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 jmeq = mkApp (Lazy.force jmeq_ind, [| eqT; hdx; eqT; hdy |]) in *)
- let evar = make_existential dummy_loc env isevars eq 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
- trace (str"Inserting coercion at application");
- aux (hdy :: tele) (subst1 hdy restT) (succ i) (fun x -> eq_app (co x))
- else co
- in aux [] typ 0 (fun x -> x)
+ aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x))
+ else Some co
+ in aux [] typ typ' 0 (fun x -> x)
in
-(* (try debug 1 (str "coerce' from " ++ (my_print_constr env x) ++ *)
-(* str " to "++ my_print_constr env y); *)
-(* with _ -> ()); *)
+(* (try trace (str "coerce' from " ++ (my_print_constr env x) ++ *)
+(* str " to "++ my_print_constr env y *)
+(* ++ str "in env:" ++ my_print_env env); *)
+(* with _ -> ()); *)
match (kind_of_term x, kind_of_term y) with
| Sort s, Sort s' ->
(match s, s' with
@@ -167,24 +179,35 @@ module Coercion = struct
| Prod (name, a, b), Prod (name', a', b') ->
let name' = Name (Nameops.next_ident_away (id_of_string "x") (Termops.ids_of_context env)) in
let env' = push_rel (name', None, a') env in
+
+(* let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in *)
+(* let name'' = Name (Nameops.next_ident_away (id_of_string "x'") (Termops.ids_of_context env)) in *)
+(* let env'' = push_rel (name'', Some (app_opt c1 (mkRel 1)), lift 1 a) env' in *)
+(* let c2 = coerce_unify env'' (liftn 1 1 b) (lift 1 b') in *)
+(* mkLetIn (name'', app_opt c1 (mkRel 1), (lift 1 a), *)
+
let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in
- let c2 = coerce_unify env' b b' 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 -> failwith "subtac.coerce': Should have detected equivalence earlier"
| _, _ ->
Some
(fun f ->
- mkLambda (name', a',
- app_opt c2
- (mkApp (Term.lift 1 f,
- [| app_opt c1 (mkRel 1) |])))))
+ 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' -> (* Sigma types *)
+ 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
@@ -248,21 +271,22 @@ module Coercion = struct
else
if i = i' && len = Array.length l' then
let evm = evars_of !isevars in
- let typ = Typing.type_of env evm c in
(try subco ()
- with NoSubtacCoercion ->
-
-(* if not (is_arity env evm typ) then *)
- Some (coerce_application typ c c' l l'))
-(* else 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 = evars_of !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 ( *)
- Some (coerce_application lam_type c c' l l')
+ coerce_application lam_type lam_type' c c' l l'
(* ) else subco () *)
else subco ()
| _ -> subco ())
@@ -284,7 +308,7 @@ module Coercion = struct
Some
(fun x ->
let cx = app_opt c x in
- let evar = make_existential dummy_loc env isevars (mkApp (p, [| cx |]))
+ let evar = make_existential loc env isevars (mkApp (p, [| cx |]))
in
(mkApp
((Lazy.force sig_).intro,
@@ -298,7 +322,7 @@ module Coercion = struct
let coerce_itf loc env isevars v t c1 =
let evars = ref isevars in
let coercion = coerce loc env evars t c1 in
- !evars, option_map (app_opt coercion) v, t
+ !evars, Option.map (app_opt coercion) v
(* Taken from pretyping/coercion.ml *)
@@ -360,7 +384,7 @@ module Coercion = struct
match kind_of_term t with
| Prod (_,_,_) -> (isevars,j)
| Evar ev when not (is_defined_evar isevars ev) ->
- let (isevars',t) = define_evar_as_arrow isevars ev in
+ let (isevars',t) = define_evar_as_product isevars ev in
(isevars',{ uj_val = j.uj_val; uj_type = t })
| _ ->
(try
@@ -400,11 +424,15 @@ module Coercion = struct
uj_type = typ' }
- let inh_coerce_to_fail env isevars c1 v t =
+ 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 t1,i1 = class_of1 env (evars_of isevars) c1 in
- let t2,i2 = class_of1 env (evars_of isevars) t in
+ let t1,i1 = class_of1 env (evars_of evd) c1 in
+ let t2,i2 = class_of1 env (evars_of evd) t in
let p = lookup_path_between (i2,i1) in
match v with
Some v ->
@@ -413,132 +441,88 @@ module Coercion = struct
| None -> None, t
with Not_found -> raise NoCoercion
in
- try (the_conv_x_leq env t' c1 isevars, v', t')
+ try (the_conv_x_leq env t' c1 evd, v')
with Reduction.NotConvertible -> raise NoCoercion
- let rec inh_conv_coerce_to_fail loc env isevars v t c1 =
-(* (try *)
-(* debug 1 (str "inh_conv_coerce_to_fail called for " ++ *)
-(* Termops.print_constr_env env t ++ str " and "++ spc () ++ *)
-(* Termops.print_constr_env env c1 ++ str " with evars: " ++ spc () ++ *)
-(* Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *)
-(* Termops.print_env env); *)
-(* with _ -> ()); *)
- try (the_conv_x_leq env t c1 isevars, v, t)
+
+ 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 isevars c1 v t
- with NoCoercion ->
- (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
- kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with
- | Prod (_,t1,t2), Prod (name,u1,u2) ->
- let v' = option_map (whd_betadeltaiota env (evars_of isevars)) v in
- let (evd',b) =
- match v' with
- Some v' ->
- (match kind_of_term v' with
- | Lambda (x,v1,v2) ->
- (try the_conv_x env v1 u1 isevars, Some (x, v1, v2) (* leq v1 u1? *)
- with Reduction.NotConvertible -> (isevars, None))
- | _ -> (isevars, None))
- | None -> (isevars, None)
- in
- (match b with
- Some (x, v1, v2) ->
- let env1 = push_rel (x,None,v1) env in
- let (evd'', v2', t2') = inh_conv_coerce_to_fail loc env1 evd'
- (Some v2) t2 u2 in
- (evd'', option_map (fun v2' -> mkLambda (x, v1, v2')) v2',
- mkProd (x, v1, t2'))
- | None ->
- (* Mismatch on t1 and u1 or not a lambda: we eta-expand *)
- (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *)
- (* has type (name: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', t1') =
- inh_conv_coerce_to_fail loc env1 isevars
- (Some (mkRel 1)) (lift 1 u1) (lift 1 t1)
- in
- let (evd'', v2', t2') =
- let v2 =
- match v with
- Some v -> option_map (fun v1' -> mkApp (lift 1 v, [|v1'|])) v1'
- | None -> None
- and evd', t2 =
- match v1' with
- Some v1' -> evd', subst1 v1' t2
- | None ->
- let evd', ev = new_evar evd' env ~src:(loc, InternalHole) t1' in
- evd', subst1 ev t2
- in
- inh_conv_coerce_to_fail loc env1 evd' v2 t2 u2
- in
- (evd'', option_map (fun v2' -> mkLambda (name, u1, v2')) v2',
- mkProd (name, u1, t2')))
- | _ -> raise NoCoercion))
+ try inh_coerce_to_fail env evd rigidonly v t c1
+ with NoCoercion ->
+ match
+ kind_of_term (whd_betadeltaiota env (evars_of evd) t),
+ kind_of_term (whd_betadeltaiota env (evars_of 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 loc env isevars cj ((n, t) as _tycon) =
-(* (try *)
-(* trace (str "Subtac_coercion.inh_conv_coerce_to called for " ++ *)
-(* Termops.print_constr_env env cj.uj_type ++ str " and "++ spc () ++ *)
-(* Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *)
-(* Subtac_utils.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *)
-(* Termops.print_env env); *)
-(* with _ -> ()); *)
+ let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) =
+ let evd = nf_evar_defs evd in
match n with
None ->
- let (evd', val', type') =
+ let (evd', val') =
try
- inh_conv_coerce_to_fail loc env isevars (Some cj.uj_val) cj.uj_type t
+ inh_conv_coerce_to_fail loc env evd rigidonly
+ (Some (nf_isevar evd cj.uj_val))
+ (nf_isevar evd cj.uj_type) (nf_isevar evd t)
with NoCoercion ->
- let sigma = evars_of isevars in
+ let sigma = evars_of evd in
try
- coerce_itf loc env isevars (Some cj.uj_val) cj.uj_type t
+ 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) ->
- (isevars, cj)
+ (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) =
-(* (try *)
-(* trace (str "Subtac_coercion.inh_conv_coerces_to called for " ++ *)
-(* Termops.print_constr_env env t ++ str " and "++ spc () ++ *)
-(* Evarutil.pr_tycon_type env tycon ++ str " with evars: " ++ spc () ++ *)
-(* Evd.pr_evar_defs isevars ++ str " in env: " ++ spc () ++ *)
-(* Termops.print_env env); *)
-(* with _ -> ()); *)
- let nabsinit, nabs =
+ let nabsinit, nabs =
match abs with
None -> 0, 0
| Some (init, cur) -> init, cur
in
- (* a little more effort to get products is needed *)
+ (* a little more effort to get products is needed *)
try let rels, rng = decompose_prod_n 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 0 (succ nabsinit) rng then (
(* trace (str "No occur between 0 and " ++ int (succ nabsinit)); *)
- let env', t, t' =
+ let env', t, t' =
let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in
env', rng, lift nabs t'
in
- try
- pi1 (try inh_conv_coerce_to_fail loc env' isevars None t t'
+ 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')
+ coerce_itf loc env' isevars None t t')
with NoSubtacCoercion ->
let sigma = evars_of isevars in
error_cannot_coerce env' sigma (t, t'))
- else isevars
+ else isevars
with _ -> isevars
- (* trace (str "decompose_prod_n failed"); *)
- (* raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") *)
+(* trace (str "decompose_prod_n failed"); *)
+(* raise (Invalid_argument "Subtac_coercion.inh_conv_coerces_to") *)
end
diff --git a/contrib/subtac/subtac_command.ml b/contrib/subtac/subtac_command.ml
index 86139039..5bff6ad1 100644
--- a/contrib/subtac/subtac_command.ml
+++ b/contrib/subtac/subtac_command.ml
@@ -39,6 +39,8 @@ open Tacticals
open Tacinterp
open Vernacexpr
open Notation
+open Evd
+open Evarutil
module SPretyping = Subtac_pretyping.Pretyping
open Subtac_utils
@@ -53,22 +55,24 @@ let evar_nf isevars c =
Evarutil.nf_isevar !isevars c
let interp_gen kind isevars env
- ?(impls=([],[])) ?(allow_soapp=false) ?(ltacvars=([],[]))
+ ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[]))
c =
- let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_soapp ~ltacvars (Evd.evars_of !isevars) env c in
-(* (try trace (str "Pretyping " ++ my_print_constr_expr c) with _ -> ()); *)
+ let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars (Evd.evars_of !isevars) env c in
let c' = SPretyping.pretype_gen 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 isevars env ?(impls=([],[])) 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 (Evd.evars_of !isevars) env c in
@@ -92,26 +96,31 @@ let locate_if_isevar loc na = function
let interp_binder sigma env na t =
let t = Constrintern.intern_gen true (Evd.evars_of !sigma) env t in
- SPretyping.understand_type (Evd.evars_of !sigma) env (locate_if_isevar (loc_of_rawconstr t) na t)
-
-
-let interp_context sigma env params =
- List.fold_left
- (fun (env,params) d -> match d with
- | LocalRawAssum ([_,na],(CHole _ as t)) ->
- let t = interp_binder sigma env na t in
- let d = (na,None,t) in
- (push_rel d env, d::params)
- | LocalRawAssum (nal,t) ->
- let t = interp_type sigma env t in
- let ctx = list_map_i (fun i (_,na) -> (na,None,lift i t)) 0 nal in
- let ctx = List.rev ctx in
- (push_rel_context ctx env, ctx@params)
- | LocalRawDef ((_,na),c) ->
- let c = interp_constr_judgment sigma env c in
- let d = (na, Some c.uj_val, c.uj_type) in
- (push_rel d env,d::params))
- (env,[]) params
+ SPretyping.pretype_gen sigma env ([], []) IsType (locate_if_isevar (loc_of_rawconstr t) na t)
+
+let interp_context_evars evdref env params =
+ let bl = Constrintern.intern_context (Evd.evars_of !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)) :: 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 *)
@@ -126,7 +135,7 @@ let collect_non_rec env =
let i =
list_try_find_i
(fun i f ->
- if List.for_all (fun (_, _, def) -> not (occur_var env f def)) ldefrec
+ if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec
then i else failwith "try_find_i")
0 lnamerec
in
@@ -152,14 +161,14 @@ let collect_non_rec env =
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, c) :: 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
+ | (id, t, c) :: tl -> (id, Option.map (liftn k n) t, liftn k n c) :: aux (pred n) tl
| [] -> []
in aux n l
@@ -172,11 +181,10 @@ let split_args n rel = match list_chop ((List.length rel) - n) rel with
| _ -> assert(false)
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 nc = named_context env in
- let nc_len = named_context_length nc 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
@@ -188,8 +196,10 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
(* Ppconstr.pr_constr_expr body) *)
(* with _ -> () *)
(* in *)
- let env', binders_rel = interp_context isevars env bl in
- let after, ((argname, _, argtyp) as arg), before = split_args (succ n) binders_rel in
+ let (env', binders_rel), impls = interp_context_evars isevars env bl in
+ let after, ((argname, _, argtyp) as arg), before =
+ let idx = list_index (Name (snd n)) (List.rev_map (fun (na, _, _) -> na) binders_rel) in
+ split_args idx binders_rel in
let before_length, after_length = List.length before, List.length after in
let argid = match argname with Name n -> n | _ -> assert(false) in
let liftafter = lift_binders 1 after_length after in
@@ -226,11 +236,10 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
(wf_rel_fun (succ len) (mkRel 1) (mkRel (len + 1))))
in
let top_bl = after @ (arg :: before) in
- let intern_bl = liftafter @ (wfarg 1 :: arg :: before) in
- (try trace (str "Intern bl: " ++ prr intern_bl) with _ -> ());
let top_env = push_rel_context top_bl env in
+ let top_arity = interp_type_evars isevars top_env arityc in
+ let intern_bl = wfarg 1 :: arg :: before in
let _intern_env = push_rel_context intern_bl env in
- let top_arity = interp_type isevars top_env arityc in
let proj = (Lazy.force sig_).Coqlib.proj1 in
let projection =
mkApp (proj, [| argtyp ;
@@ -240,29 +249,21 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
|])
in
let intern_arity = it_mkProd_or_LetIn top_arity after in
- (try trace (str "After length: " ++ int after_length ++ str "Top env: " ++ prr top_bl ++ spc () ++ str "Top arity: " ++ my_print_constr top_env top_arity);
- trace (str "Before lifting arity: " ++ my_print_constr env top_arity) with _ -> ());
- (* Top arity is in top_env = after :: arg :: before *)
-(* let intern_arity' = liftn 1 (succ after_length) top_arity in (\* arity in after :: wfarg :: arg :: before *\) *)
-(* (try trace (str "projection: " "After lifting arity: " ++ my_print_constr env intern_arity' ++ spc ()); *)
-(* trace (str "Intern env: " ++ prr intern_bl ++ str "intern_arity': " ++ my_print_constr _intern_env intern_arity') with _ -> ()); *)
- let intern_arity = substl [projection] intern_arity in (* substitute the projection of wfarg for arg *)
- (try trace (str "Top arity after subst: " ++ my_print_constr (Global.env ()) intern_arity) with _ -> ());
-(* let intern_arity = liftn 1 (succ after_length) intern_arity in (\* back in after :: wfarg :: arg :: before (ie, jump over arg) *\) *)
-(* (try trace (str "Top arity after subst and lift: " ++ my_print_constr (Global.env ()) intern_arity) with _ -> ()); *)
+ (* Intern arity is in top_env = arg :: before *)
+ let intern_arity = liftn 2 2 intern_arity in
+(* trace (str "After lifting arity: " ++ *)
+(* my_print_constr (push_rel (Name argid', None, lift 2 argtyp) intern_env) *)
+(* intern_arity); *)
+ (* arity is now in something :: wfarg :: arg :: before
+ where what refered to arg now refers to something *)
+ let intern_arity = substl [projection] intern_arity in
+ (* substitute the projection of wfarg for something *)
let intern_before_env = push_rel_context before env in
-(* let intern_fun_bl = liftafter @ [wfarg 1] in (\* FixMe dependencies *\) *)
-(* (try debug 2 (str "Intern fun bl: " ++ prr intern_fun_bl) with _ -> ()); *)
- (try trace (str "Intern arity: " ++
- my_print_constr _intern_env intern_arity) with _ -> ());
let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in
- (try trace (str "Intern fun arity product: " ++
- my_print_constr (push_rel_context [arg] intern_before_env) intern_fun_arity_prod) with _ -> ());
let intern_fun_binder = (Name recname, None, intern_fun_arity_prod) in
let fun_bl = liftafter @ (intern_fun_binder :: [arg]) in
-(* (try debug 2 (str "Fun bl: " ++ pr_rel intern_before_env fun_bl ++ spc ()) with _ -> ()); *)
let fun_env = push_rel_context fun_bl intern_before_env in
- let fun_arity = interp_type isevars fun_env arityc in
+ let fun_arity = interp_type_evars isevars fun_env arityc in
let intern_body = interp_casted_constr isevars fun_env body fun_arity in
let intern_body_lam = it_mkLambda_or_LetIn intern_body fun_bl in
let _ =
@@ -274,161 +275,177 @@ let build_wellfounded (recname, n, bl,arityc,body) r measure notation boxed =
(* str "Intern body " ++ pr intern_body_lam) *)
with _ -> ()
in
- let _impl =
- if Impargs.is_implicit_args()
- then Impargs.compute_implicits top_env top_arity
- else []
- in
let prop = mkLambda (Name argid, argtyp, it_mkProd_or_LetIn top_arity after) in
+ (* Lift to get to constant arguments *)
+ let lift_cst = List.length after + 1 in
let fix_def =
match measure_fn with
None ->
- mkApp (constr_of_reference (Lazy.force fix_sub_ref),
+ mkApp (constr_of_global (Lazy.force fix_sub_ref),
[| argtyp ;
wf_rel ;
- make_existential dummy_loc ~opaque:false intern_before_env isevars wf_proof ;
- prop ;
- intern_body_lam |])
+ make_existential dummy_loc ~opaque:false env isevars wf_proof ;
+ lift lift_cst prop ;
+ lift lift_cst intern_body_lam |])
| Some f ->
- lift (succ after_length)
- (mkApp (constr_of_reference (Lazy.force fix_measure_sub_ref),
- [| argtyp ;
- f ;
- prop ;
- intern_body_lam |]))
+ mkApp (constr_of_global (Lazy.force fix_measure_sub_ref),
+ [| lift lift_cst argtyp ;
+ lift lift_cst f ;
+ lift lift_cst prop ;
+ lift lift_cst intern_body_lam |])
in
let def_appl = applist (fix_def, gen_rels (after_length + 1)) in
let def = it_mkLambda_or_LetIn def_appl binders_rel in
let typ = it_mkProd_or_LetIn top_arity binders_rel in
let fullcoqc = Evarutil.nf_isevar !isevars def in
let fullctyp = Evarutil.nf_isevar !isevars typ in
-(* let _ = try trace (str "After evar normalization: " ++ spc () ++ *)
-(* str "Coq term: " ++ my_print_constr env fullcoqc ++ spc () *)
-(* ++ str "Coq type: " ++ my_print_constr env fullctyp) *)
-(* with _ -> () *)
-(* in *)
let evm = evars_of_term (Evd.evars_of !isevars) Evd.empty fullctyp in
let evm = evars_of_term (Evd.evars_of !isevars) evm fullcoqc in
let evm = non_instanciated_map env isevars evm in
-
- (* let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in *)
- let evars, evars_def = Eterm.eterm_obligations recname nc_len !isevars evm 0 fullcoqc (Some fullctyp) in
- (* (try trace (str "Generated obligations : "); *)
-(* Array.iter *)
- (* (fun (n, t, _) -> trace (str "Evar " ++ str (string_of_id n) ++ spc () ++ my_print_constr env t)) *)
- (* evars; *)
- (* with _ -> ()); *)
- Subtac_obligations.add_definition recname evars_def fullctyp evars
+ let evars, evars_def, evars_typ = Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp in
+ Subtac_obligations.add_definition recname evars_def evars_typ ~implicits:impls evars
let nf_evar_context isevars ctx =
List.map (fun (n, b, t) ->
- (n, option_map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx
+ (n, Option.map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx
-let build_mutrec l boxed =
- let sigma = Evd.empty and env = Global.env () in
- let nc = named_context env in
- let nc_len = named_context_length nc in
- let lnameargsardef =
- (*List.map (fun (f, d) -> Subtac_interp_fixpoint.rewrite_fixpoint env protos (f, d))*)
- l
- in
- let lrecnames = List.map (fun ((f,_,_,_,_),_) -> f) lnameargsardef
- and nv = List.map (fun ((_,n,_,_,_),_) -> n) lnameargsardef
+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 = interp_casted_constr_evars evdref env ~impls fix.Command.fix_body ccl in
+ it_mkLambda_or_LetIn body ctx
+
+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 interp_recursive fixkind l boxed =
+ let env = Global.env() in
+ let fixl, ntnl = List.split l in
+ let fixnames = List.map (fun fix -> fix.Command.fix_name) fixl in
+
+ (* Interp arities allowing for unresolved types *)
+ let evdref = ref (Evd.create_evar_defs 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 -> (id,None,t) :: env)
+ [] fixnames fixtypes
in
- (* Build the recursive context and notations for the recursive types *)
- let (rec_sign,rec_env,rec_impls,arityl) =
- List.fold_left
- (fun (sign,env,impls,arl) ((recname, n, bl,arityc,body),_) ->
- let isevars = ref (Evd.create_evar_defs sigma) in
- let arityc = Command.generalize_constr_expr arityc bl in
- let arity = interp_type isevars env arityc in
- let impl =
- if Impargs.is_implicit_args()
- then Impargs.compute_implicits env arity
- else [] in
- let impls' =(recname,([],impl,compute_arguments_scope arity))::impls in
- ((recname,None,arity) :: sign, Environ.push_named (recname,None,arity) env, impls', (isevars, None, arity)::arl))
- ([],env,[],[]) lnameargsardef in
- let arityl = List.rev arityl in
- let notations =
- List.fold_right (fun (_,ntnopt) l -> option_cons ntnopt l)
- lnameargsardef [] in
-
- let recdef =
-
- (* Declare local notations *)
- let fs = States.freeze() in
+ let env_rec = push_named_context rec_sign env in
+
+ (* Get interpretation metadatas *)
+ let impls = Command.compute_interning_datas env [] fixnames fixtypes fiximps in
+ let notations = List.fold_right Option.List.cons ntnl [] in
+
+ (* Interp bodies with rollback because temp use of notations/implicit *)
+ let fixdefs =
+ States.with_heavy_rollback (fun () ->
+ List.iter (Command.declare_interning_data impls) notations;
+ list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls)
+ () in
+
+ (* Instantiate evars and check all are resolved *)
+ let evd,_ = Evarconv.consider_remaining_unif_problems env_rec !evdref in
+ let fixdefs = List.map (nf_evar (evars_of evd)) fixdefs in
+ let fixtypes = List.map (nf_evar (evars_of evd)) fixtypes in
+ let rec_sign = nf_named_context_evar (evars_of 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; *)
+(* 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
+ trace (str "got undefined evars" ++ Evd.pr_evar_defs isevars);
+ let evm = Evd.evars_of isevars in
+ trace (str "got the evm, recdefs is " ++ int recdefs);
+ (* Solve remaining evars *)
+ let rec collect_evars id def typ imps =
+ let _ = try trace (str "In collect evars, isevars is: " ++ Evd.pr_evar_defs isevars) with _ -> () in
+ (* Generalize by the recursive prototypes *)
let def =
- try
- List.iter (fun (df,c,scope) -> (* No scope for tmp notation *)
- Metasyntax.add_notation_interpretation df rec_impls c None) notations;
- List.map2
- (fun ((_,_,bl,_,def),_) (isevars, info, arity) ->
- match info with
- None ->
- let def = abstract_constr_expr def bl in
- isevars, info, interp_casted_constr isevars rec_env ~impls:([],rec_impls)
- def arity
- | Some (n, artyp, wfrel, fun_bl, intern_bl, intern_arity) ->
- let rec_env = push_rel_context fun_bl rec_env in
- let cstr = interp_casted_constr isevars rec_env ~impls:([],rec_impls)
- def intern_arity
- in isevars, info, it_mkLambda_or_LetIn cstr fun_bl)
- lnameargsardef arityl
- with e ->
- States.unfreeze fs; raise e in
- States.unfreeze fs; def
- in
- let (lnonrec,(namerec,defrec,arrec,nvrec)) =
- collect_non_rec env lrecnames recdef arityl nv in
- let recdefs = Array.length defrec in
- (* Solve remaining evars *)
- let rec collect_evars i acc =
- if i < recdefs then
- let (isevars, info, def) = defrec.(i) in
- (* let _ = try trace (str "In solve evars, isevars is: " ++ Evd.pr_evar_defs !isevars) with _ -> () in *)
- let def = evar_nf isevars def in
- let x, y, typ = arrec.(i) in
- let typ = evar_nf isevars typ in
- arrec.(i) <- (x, y, typ);
- let rec_sign = nf_evar_context !isevars rec_sign in
- let isevars = Evd.undefined_evars !isevars in
- (* let _ = try trace (str "In solve evars, undefined is: " ++ Evd.pr_evar_defs isevars) with _ -> () in *)
- let evm = Evd.evars_of isevars in
- let id = namerec.(i) in
- (* 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 evars, def = Eterm.eterm_obligations id nc_len isevars evm recdefs def (Some typ) in
- collect_evars (succ i) ((id, def, typ, evars) :: acc)
- else acc
+ 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 = collect_evars 0 [] in
- Subtac_obligations.add_mutual_definitions (List.rev defs) nvrec
-
+ let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in
+ (match fixkind with
+ | Command.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
+ | Command.IsCoFixpoint -> ());
+ Subtac_obligations.add_mutual_definitions defs notations fixkind
+
let out_n = function
Some n -> n
- | None -> 0
-
-let build_recursive (lnameargsardef:(fixpoint_expr * decl_notation) list) boxed =
- match lnameargsardef with
- | ((id, (n, CWfRec r), bl, typ, body), no) :: [] ->
- build_wellfounded (id, out_n n, bl, typ, body) r false no boxed
- | ((id, (n, CMeasureRec r), bl, typ, body), no) :: [] ->
- build_wellfounded (id, out_n n, bl, typ, body) r true no boxed
- | l ->
- let lnameargsardef =
- List.map (fun ((id, (n, ro), bl, typ, body), no) ->
- match ro with
- CStructRec -> (id, out_n n, bl, typ, body), no
- | CWfRec _ | CMeasureRec _ ->
- errorlabstrm "Subtac_command.build_recursive"
- (str "Well-founded fixpoints not allowed in mutually recursive blocks"))
- lnameargsardef
- in build_mutrec lnameargsardef boxed
-
-
-
+ | 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, out_n n, bl, typ, def) r false ntn false)
+
+ | [(n, CMeasureRec r)], [(((_,id),_,bl,typ,def),ntn)] ->
+ ignore(build_wellfounded (id, out_n n, bl, typ, def) r true 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 (Command.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 Command.IsCoFixpoint fixl b
diff --git a/contrib/subtac/subtac_command.mli b/contrib/subtac/subtac_command.mli
index 846e06cf..27520867 100644
--- a/contrib/subtac/subtac_command.mli
+++ b/contrib/subtac/subtac_command.mli
@@ -14,18 +14,18 @@ val interp_gen :
evar_defs ref ->
env ->
?impls:full_implicits_env ->
- ?allow_soapp:bool ->
+ ?allow_patvar:bool ->
?ltacvars:ltac_sign ->
constr_expr -> constr
val interp_constr :
evar_defs ref ->
env -> constr_expr -> constr
-val interp_type :
+val interp_type_evars :
evar_defs ref ->
env ->
?impls:full_implicits_env ->
constr_expr -> constr
-val interp_casted_constr :
+val interp_casted_constr_evars :
evar_defs ref ->
env ->
?impls:full_implicits_env ->
@@ -38,5 +38,12 @@ val interp_constr_judgment :
constr_expr -> unsafe_judgment
val list_chop_hd : int -> 'a list -> 'a list * 'a * 'a list
+val interp_binder : Evd.evar_defs ref ->
+ Environ.env -> Names.name -> Topconstr.constr_expr -> Term.constr
+
+
val build_recursive :
(fixpoint_expr * decl_notation) list -> bool -> unit
+
+val build_corecursive :
+ (cofixpoint_expr * decl_notation) list -> bool -> unit
diff --git a/contrib/subtac/subtac_obligations.ml b/contrib/subtac/subtac_obligations.ml
index d182f7cd..55cdc7c4 100644
--- a/contrib/subtac/subtac_obligations.ml
+++ b/contrib/subtac/subtac_obligations.ml
@@ -1,7 +1,7 @@
-(* -*- default-directory: "~/research/coq/trunk/" -*- *)
open Printf
open Pp
open Subtac_utils
+open Command
open Term
open Names
@@ -12,8 +12,11 @@ open Entries
open Decl_kinds
open Util
open Evd
+open Declare
-let pperror cmd = Util.errorlabstrm "Subtac" cmd
+type definition_hook = global_reference -> unit
+
+let pperror cmd = Util.errorlabstrm "Program" cmd
let error s = pperror (str s)
exception NoObligations of identifier option
@@ -22,11 +25,12 @@ 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 * bool * Intset.t) array
+type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array
type obligation =
{ obl_name : identifier;
obl_type : types;
+ obl_location : loc;
obl_body : constr option;
obl_opaque : bool;
obl_deps : Intset.t;
@@ -34,27 +38,46 @@ type obligation =
type obligations = (obligation array * int)
+type notations = (string * 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_nvrec : int array;
+ prg_fixkind : Command.fixpoint_kind option ;
+ prg_implicits : (Topconstr.explicitation * (bool * bool)) list;
+ prg_notations : notations ;
+ prg_kind : definition_kind;
+ prg_hook : definition_hook;
}
let assumption_message id =
- Options.if_verbose message ((string_of_id id) ^ " is assumed")
+ 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 (Obj.magic ())
let set_default_tactic t = default_tactic_expr := t; default_tactic := Tacinterp.eval_tactic t
-let evar_of_obligation o = { evar_hyps = Global.named_context_val () ;
- evar_concl = o.obl_type ;
- evar_body = Evar_empty ;
- evar_extra = None }
+(* 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 = (SecondaryTable ("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 subst_deps obls deps t =
Intset.fold
@@ -62,7 +85,7 @@ let subst_deps obls deps t =
let xobl = obls.(x) in
debug 3 (str "Trying to get body of obligation " ++ int x);
let oblb =
- try out_some xobl.obl_body
+ try Option.get xobl.obl_body
with _ ->
debug 3 (str "Couldn't get body of obligation " ++ int x);
assert(false)
@@ -96,7 +119,7 @@ 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 (Subtac_utils.utils_call "subtac_simpl" [])
+ from_prg := ProgMap.empty; set_default_tactic (Subtac_utils.tactics_call "obligations_tactic" [])
let _ =
Summary.declare_summary "program-tcc-table"
@@ -110,7 +133,7 @@ let progmap_union = ProgMap.fold ProgMap.add
let cache (_, (infos, tac)) =
from_prg := infos;
- default_tactic_expr := tac
+ set_default_tactic tac
let (input,output) =
declare_object
@@ -129,69 +152,112 @@ let rec intset_to = function
let subst_body prg =
let obls, _ = prg.prg_obligations in
- subst_deps obls (intset_to (pred (Array.length obls))) prg.prg_body
-
+ let ints = intset_to (pred (Array.length obls)) in
+ subst_deps obls ints prg.prg_body,
+ subst_deps obls ints (Termops.refresh_universes prg.prg_type)
+
let declare_definition prg =
- let body = subst_body prg in
+ let body, typ = subst_body 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 prg.prg_type;
+ const_entry_type = Some typ;
const_entry_opaque = false;
- const_entry_boxed = false}
+ const_entry_boxed = boxed}
in
- let _constant = Declare.declare_constant
- prg.prg_name (DefinitionEntry ce,IsDefinition Definition)
- in
- Subtac_utils.definition_message prg.prg_name
+ (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");
+ 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 (Impargs.is_implicit_args ()) prg.prg_implicits;
+ print_message (Subtac_utils.definition_message prg.prg_name);
+ prg.prg_hook 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 (Sign.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 namerec = Array.of_list (List.map (fun x -> x.prg_name) l) in
- let arrec =
- Array.of_list (List.map (fun x -> snd (decompose_prod_n len x.prg_type)) l)
- in
- let recvec =
- Array.of_list
+ let fixdefs, fixtypes, fiximps =
+ list_split3
(List.map (fun x ->
- let subs = (subst_body x) in
- snd (decompose_lam_n len subs)) l)
+ let subs, typ = (subst_body x) in
+ snd (decompose_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) l)
in
- let nvrec = (List.hd l).prg_nvrec in
- let recdecls = (Array.map (fun id -> Name id) namerec, arrec, recvec) in
- let rec declare i fi =
- (try trace (str "Declaring: " ++ pr_id fi ++ spc () ++
- my_print_constr (Global.env()) (recvec.(i)));
- with _ -> ());
- let ce =
- { const_entry_body = mkFix ((nvrec,i),recdecls);
- const_entry_type = Some arrec.(i);
- const_entry_opaque = false;
- const_entry_boxed = true} in
- let kn = Declare.declare_constant fi (DefinitionEntry ce,IsDefinition Fixpoint)
- in
- ConstRef kn
- in
- let lrefrec = Array.mapi declare namerec in
- Options.if_verbose ppnl (recursive_message lrefrec)
-
+ let fixkind = Option.get (List.hd l).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 boxed = true (* TODO *) in
+ let fixnames = (List.hd l).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 (Command.declare_interning_data ([],[])) (List.hd l).prg_notations;
+ Flags.if_verbose ppnl (Command.recursive_message kind indexes fixnames);
+ (match List.hd kns with ConstRef kn -> kn | _ -> assert false)
+
let declare_obligation obl body =
let ce =
{ const_entry_body = body;
const_entry_type = Some obl.obl_type;
- const_entry_opaque = obl.obl_opaque;
+ const_entry_opaque = if get_proofs_transparency () then false else obl.obl_opaque;
const_entry_boxed = false}
in
let constant = Declare.declare_constant obl.obl_name
(DefinitionEntry ce,IsProof Property)
in
- Subtac_utils.definition_message obl.obl_name;
+ print_message (Subtac_utils.definition_message obl.obl_name);
{ obl with obl_body = Some (mkConst constant) }
let try_tactics obls =
@@ -209,18 +275,19 @@ let try_tactics obls =
let red = Reductionops.nf_betaiota
-let init_prog_info n b t deps nvrec obls =
+let init_prog_info n b t deps fixkind notations obls impls kind hook =
let obls' =
Array.mapi
- (fun i (n, t, o, d) ->
+ (fun i (n, t, l, o, d) ->
debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d));
{ obl_name = n ; obl_body = None;
- obl_type = red t; obl_opaque = o;
+ obl_location = l; obl_type = red t; obl_opaque = o;
obl_deps = d })
obls
in
{ prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls');
- prg_deps = deps; prg_nvrec = nvrec; }
+ 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
@@ -244,44 +311,63 @@ let update_state s =
(* msgnl (str "Updating obligations info"); *)
Lib.add_anonymous_leaf (input s)
-let obligations_message rem =
+type progress =
+ | Remain of int
+ | Dependent
+ | Defined of global_reference
+
+let obligations_message rem =
if rem > 0 then
if rem = 1 then
- Options.if_verbose msgnl (int rem ++ str " obligation remaining")
+ Flags.if_verbose msgnl (int rem ++ str " obligation remaining")
else
- Options.if_verbose msgnl (int rem ++ str " obligations remaining")
+ Flags.if_verbose msgnl (int rem ++ str " obligations remaining")
else
- Options.if_verbose msgnl (str "No more obligations remaining")
-
+ 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 ()
- else (
- match prg'.prg_deps with
- [] ->
- declare_definition prg';
- from_prg := ProgMap.remove prg.prg_name !from_prg
- | 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
- (declare_mutual_definition progs;
- from_prg := List.fold_left
- (fun acc x ->
- ProgMap.remove x.prg_name acc) !from_prg progs));
- update_state (!from_prg, !default_tactic_expr);
- rem
+ let res =
+ if rem > 0 then Remain rem
+ else (
+ match prg'.prg_deps with
+ [] ->
+ let kn = declare_definition prg' in
+ from_prg := ProgMap.remove prg.prg_name !from_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
+ from_prg := List.fold_left
+ (fun acc x ->
+ ProgMap.remove x.prg_name acc) !from_prg progs;
+ Defined (ConstRef kn))
+ else Dependent);
+ in
+ update_state (!from_prg, !default_tactic_expr);
+ res
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 []
-
+ 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 =
if o then Subtac_utils.goal_proof_kind
else Subtac_utils.goal_kind
@@ -293,6 +379,7 @@ let obligations_of_evars evars =
(fun (n, t) ->
{ obl_name = n;
obl_type = t;
+ obl_location = dummy_loc;
obl_body = None;
obl_opaque = false;
obl_deps = Intset.empty;
@@ -315,11 +402,15 @@ let rec solve_obligation prg num =
let obl = { obl with obl_body = Some (Libnames.constr_of_global gr) } in
let obls = Array.copy obls in
let _ = obls.(num) <- obl in
- if update_obls prg obls (pred rem) <> 0 then
- auto_solve_obligations (Some prg.prg_name));
+ match update_obls prg obls (pred rem) with
+ | Remain n when n > 0 ->
+ if has_dependencies obls num then
+ ignore(auto_solve_obligations (Some prg.prg_name))
+ | _ -> ());
trace (str "Started obligation " ++ int user_num ++ str " proof: " ++
Subtac_utils.my_print_constr (Global.env ()) obl.obl_type);
- Pfedit.by !default_tactic
+ Pfedit.by !default_tactic;
+ 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))
@@ -341,7 +432,7 @@ and solve_obligation_by_tac prg obls i tac =
Some _ -> false
| None ->
(try
- if deps_remaining obls obl.obl_deps = [] then
+ if deps_remaining obls obl.obl_deps = [] then
let obl = subst_deps_obl obls obl in
let t = Subtac_utils.solve_by_tac (evar_of_obligation obl) tac in
if obl.obl_opaque then
@@ -349,8 +440,12 @@ and solve_obligation_by_tac prg obls i tac =
else
obls.(i) <- { obl with obl_body = Some t };
true
- else false
- with _ -> false)
+ else false
+ with
+ | Stdpp.Exc_located(_, Refiner.FailError (_, s))
+ | Refiner.FailError (_, s) ->
+ user_err_loc (obl.obl_location, "solve_obligation", s)
+ | e -> false)
and solve_prg_obligations prg tac =
let obls, rem = prg.prg_obligations in
@@ -381,35 +476,66 @@ and try_solve_obligation n prg tac =
and try_solve_obligations n tac =
try ignore (solve_obligations n tac) with NoObligations _ -> ()
-and auto_solve_obligations n : unit =
- Options.if_verbose msgnl (str "Solving obligations automatically...");
- try_solve_obligations n !default_tactic
+and auto_solve_obligations n : progress =
+ Flags.if_verbose msgnl (str "Solving obligations automatically...");
+ try solve_obligations n !default_tactic with NoObligations _ -> Dependent
-let add_definition n b t obls =
- Options.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
- let prg = init_prog_info n b t [] (Array.make 0 0) obls in
+open Pp
+let show_obligations ?(msg=true) n =
+ let prg = get_prog_err n in
+ let n = prg.prg_name in
+ let obls, rem = prg.prg_obligations in
+ if msg then msgnl (int rem ++ str " obligation(s) remaining: ");
+ Array.iteri (fun i x ->
+ match x.obl_body with
+ None -> msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++
+ my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ())
+ | Some _ -> ())
+ obls
+
+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 b t ?(implicits=[]) ?(kind=Global,false,Definition) ?(hook=fun x -> ()) obls =
+ Flags.if_verbose pp (str (string_of_id n) ++ str " has type-checked");
+ let prg = init_prog_info n b t [] None [] obls implicits kind hook in
let obls,_ = prg.prg_obligations in
if Array.length obls = 0 then (
- Options.if_verbose ppnl (str ".");
- declare_definition prg;
- from_prg := ProgMap.remove prg.prg_name !from_prg)
+ Flags.if_verbose ppnl (str ".");
+ let cst = declare_definition prg in
+ from_prg := ProgMap.remove prg.prg_name !from_prg;
+ Defined cst)
else (
let len = Array.length obls in
- let _ = Options.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
+ let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in
from_prg := ProgMap.add n prg !from_prg;
- auto_solve_obligations (Some n))
+ let res = auto_solve_obligations (Some n) in
+ match res with
+ | Remain rem when rem < 5 -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res
+ | _ -> res)
-let add_mutual_definitions l nvrec =
- let deps = List.map (fun (n, b, t, obls) -> n) l in
+let add_mutual_definitions l ?(kind=Global,false,Definition) 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, obls) ->
- let prg = init_prog_info n b t deps nvrec obls in
- ProgMap.add n prg acc)
+ (fun acc (n, b, t, imps, obls) ->
+ let prg = init_prog_info n b t deps (Some fixkind) notations obls imps kind (fun x -> ()) in
+ ProgMap.add n prg acc)
!from_prg l
in
from_prg := upd;
- List.iter (fun x -> auto_solve_obligations (Some x)) deps
-
+ let _defined =
+ List.fold_left (fun finished x ->
+ if finished then finished
+ else
+ match auto_solve_obligations (Some x) 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
@@ -417,7 +543,7 @@ let admit_obligations n =
match x.obl_body with
None ->
let x = subst_deps_obl obls x in
- let kn = Declare.declare_constant x.obl_name (ParameterEntry x.obl_type, IsAssumption Conjectural) 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 _ -> ())
@@ -438,18 +564,5 @@ let next_obligation n =
array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = [])
obls
in solve_obligation prg i
-
-open Pp
-let show_obligations n =
- let prg = get_prog_err n in
- let n = prg.prg_name in
- let obls, rem = prg.prg_obligations in
- msgnl (int rem ++ str " obligation(s) remaining: ");
- Array.iteri (fun i x ->
- match x.obl_body with
- None -> msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++
- my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ())
- | Some _ -> ())
- obls
-
+
let default_tactic () = !default_tactic
diff --git a/contrib/subtac/subtac_obligations.mli b/contrib/subtac/subtac_obligations.mli
index f015b80b..6d13e3bd 100644
--- a/contrib/subtac/subtac_obligations.mli
+++ b/contrib/subtac/subtac_obligations.mli
@@ -1,22 +1,42 @@
+open Names
open Util
+open Libnames
-type obligation_info = (Names.identifier * Term.types * bool * Intset.t) array
- (* ident, type, opaque or transparent, dependencies *)
+type obligation_info = (Names.identifier * Term.types * loc * bool * Intset.t) array
+ (* ident, type, location, opaque or transparent, dependencies *)
+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 : Tacexpr.glob_tactic_expr -> unit
val default_tactic : unit -> Proof_type.tactic
+val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *)
+val get_proofs_transparency : unit -> bool
+
+type definition_hook = global_reference -> unit
+
val add_definition : Names.identifier -> Term.constr -> Term.types ->
- obligation_info -> unit
+ ?implicits:(Topconstr.explicitation * (bool * bool)) list ->
+ ?kind:Decl_kinds.definition_kind ->
+ ?hook:definition_hook -> obligation_info -> progress
+
+type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list
val add_mutual_definitions :
- (Names.identifier * Term.constr * Term.types * obligation_info) list -> int array -> unit
+ (Names.identifier * Term.constr * Term.types *
+ (Topconstr.explicitation * (bool * bool)) list * obligation_info) list ->
+ ?kind:Decl_kinds.definition_kind ->
+ notations ->
+ Command.fixpoint_kind -> unit
val subtac_obligation : int * Names.identifier option * Topconstr.constr_expr option -> unit
val next_obligation : Names.identifier option -> unit
-val solve_obligations : Names.identifier option -> Proof_type.tactic -> int
+val solve_obligations : Names.identifier option -> Proof_type.tactic -> progress
(* Number of remaining obligations to be solved for this program *)
val solve_all_obligations : Proof_type.tactic -> unit
@@ -25,7 +45,9 @@ val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic -
val try_solve_obligations : Names.identifier option -> Proof_type.tactic -> unit
-val show_obligations : Names.identifier 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
diff --git a/contrib/subtac/subtac_pretyping.ml b/contrib/subtac/subtac_pretyping.ml
index cce9a358..0e987cf2 100644
--- a/contrib/subtac/subtac_pretyping.ml
+++ b/contrib/subtac/subtac_pretyping.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: subtac_pretyping.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: subtac_pretyping.ml 11047 2008-06-03 23:08:00Z msozeau $ *)
open Global
open Pp
@@ -70,7 +70,12 @@ let merge_evms x y =
let interp env isevars c tycon =
let j = pretype tycon env isevars ([],[]) c in
- let evm = evars_of !isevars in
+ let _ = isevars := Evarutil.nf_evar_defs !isevars in
+ let evd,_ = consider_remaining_unif_problems env !isevars in
+(* let unevd = undefined_evars evd in *)
+ let unevd' = Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env evd in
+ let evm = evars_of unevd' in
+ isevars := unevd';
nf_evar evm j.uj_val, nf_evar evm j.uj_type
let find_with_index x l =
@@ -98,7 +103,7 @@ let env_with_binders env isevars l =
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, typ) :: 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 =
@@ -111,46 +116,28 @@ let env_with_binders env isevars l =
| [] -> acc
in aux (env, []) l
-let subtac_process env isevars id l c tycon =
- let c = Command.abstract_constr_expr c l in
-(* let env_binders, binders_rel = env_with_binders env isevars l in *)
+let subtac_process env isevars id bl c tycon =
+(* let bl = Implicit_quantifiers.ctx_of_class_binders (vars_of_env env) cbl @ l in *)
+ let c = Command.abstract_constr_expr c bl in
let tycon =
match tycon with
None -> empty_tycon
| Some t ->
- let t = Command.generalize_constr_expr t l in
+ let t = Command.generalize_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 _ = try trace (str "Interpreted term: " ++ my_print_constr env coqc ++ spc () ++ *)
-(* str "Coq type: " ++ my_print_constr env ctyp) *)
-(* with _ -> () *)
-(* in *)
-(* let _ = try trace (str "Original evar map: " ++ Evd.pr_evar_map (evars_of !isevars)) with _ -> () in *)
-
-(* let fullcoqc = it_mkLambda_or_LetIn coqc binders_rel *)
-(* and fullctyp = it_mkProd_or_LetIn ctyp binders_rel *)
-(* in *)
- let fullcoqc = Evarutil.nf_evar (evars_of !isevars) coqc in
- let fullctyp = Evarutil.nf_evar (evars_of !isevars) ctyp in
-(* let evm = evars_of_term (evars_of !isevars) Evd.empty fullctyp in *)
-(* let evm = evars_of_term (evars_of !isevars) evm fullcoqc in *)
-(* let _ = try trace (str "After evar normalization remain: " ++ spc () ++ *)
-(* Evd.pr_evar_map evm) *)
-(* with _ -> () *)
-(* in *)
let evm = non_instanciated_map env isevars (evars_of !isevars) in
-(* let _ = try trace (str "Non instanciated evars map: " ++ Evd.pr_evar_map evm) with _ -> () in *)
- evm, fullcoqc, fullctyp
+ evm, coqc, (match tycon with Some (None, c) -> c | _ -> ctyp), imps
open Subtac_obligations
-let subtac_proof env isevars id l c tycon =
- let nc = named_context env in
- let nc_len = named_context_length nc in
- let evm, coqc, coqt = subtac_process env isevars id l c tycon in
- let evars, def = Eterm.eterm_obligations id nc_len !isevars evm 0 coqc (Some coqt) in
- add_definition id def coqt evars
+let subtac_proof kind 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 evars, def, ty = Eterm.eterm_obligations env id !isevars evm 0 coqc coqt in
+ add_definition id def ty ~implicits:imps ~kind:kind evars
diff --git a/contrib/subtac/subtac_pretyping.mli b/contrib/subtac/subtac_pretyping.mli
index b62a8766..1d8eb250 100644
--- a/contrib/subtac/subtac_pretyping.mli
+++ b/contrib/subtac/subtac_pretyping.mli
@@ -5,11 +5,19 @@ open Sign
open Evd
open Global
open Topconstr
+open Implicit_quantifiers
+open Impargs
module Pretyping : Pretyping.S
+val interp :
+ Environ.env ->
+ Evd.evar_defs ref ->
+ Rawterm.rawconstr ->
+ Evarutil.type_constraint -> Term.constr * Term.constr
+
val subtac_process : env -> evar_defs ref -> identifier -> local_binder list ->
- constr_expr -> constr_expr option -> evar_map * constr * types
+ constr_expr -> constr_expr option -> evar_map * constr * types * manual_explicitation list
-val subtac_proof : env -> evar_defs ref -> identifier -> local_binder list ->
- constr_expr -> constr_expr option -> unit
+val subtac_proof : Decl_kinds.definition_kind -> env -> evar_defs ref -> identifier -> local_binder list ->
+ constr_expr -> constr_expr option -> Subtac_obligations.progress
diff --git a/contrib/subtac/subtac_pretyping_F.ml b/contrib/subtac/subtac_pretyping_F.ml
index 53eec0b6..afa5817f 100644
--- a/contrib/subtac/subtac_pretyping_F.ml
+++ b/contrib/subtac/subtac_pretyping_F.ml
@@ -1,3 +1,4 @@
+(* -*- 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 *)
@@ -6,7 +7,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: subtac_pretyping_F.ml 9976 2007-07-12 11:58:30Z msozeau $ *)
+(* $Id: subtac_pretyping_F.ml 11143 2008-06-18 15:52:42Z msozeau $ *)
open Pp
open Util
@@ -67,8 +68,6 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let mt_evd = Evd.empty
- let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
-
(* 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 *)
@@ -113,7 +112,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
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 = type_app (lift n) typ }
+ { uj_val = mkRel n; uj_type = lift n typ }
with Not_found ->
try
List.assoc id lvar
@@ -202,11 +201,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
| RRec (loc,fixkind,names,bl,lar,vdef) ->
let rec type_bl env ctxt = function
[] -> ctxt
- | (na,None,ty)::bl ->
+ | (na,k,None,ty)::bl ->
let ty' = pretype_type empty_valcon env isevars lvar ty in
let dcl = (na,None,ty'.utj_val) in
type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
- | (na,Some bd,ty)::bl ->
+ | (na,k,Some bd,ty)::bl ->
let ty' = pretype_type empty_valcon env isevars lvar ty in
let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in
let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
@@ -223,43 +222,47 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let names = Array.map (fun id -> Name id) names in
(* Note: bodies are not used by push_rec_types, so [||] is safe *)
let newenv = push_rec_types (names,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 ->
- (* 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 ftys.(i)) in
- let nenv = push_rel_context ctxt newenv in
- let j = pretype (mk_tycon ty) nenv isevars lvar def in
- { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
- uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
+ let fty =
+ let ty = ftys.(i) in
+ if i = fixi then (
+ Option.iter (fun tycon ->
+ isevars := Coercion.inh_conv_coerces_to loc env !isevars ftys.(i) tycon)
+ tycon;
+ nf_isevar !isevars 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 isevars 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 isevars names ftys vdefj;
let fixj = match fixkind with
| RFix (vn,i) ->
- let guard_indexes = Array.mapi
+ (* 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 ->
- (* Recursive argument was not given by the user : We
- check that there is only one inductive argument *)
- let ctx = ctxtv.(i) in
- let isIndApp t =
- isInd (fst (decompose_app (strip_head_cast t))) in
- (* This could be more precise (e.g. do some delta) *)
- let lb = List.rev_map (fun (_,_,t) -> isIndApp t) ctx in
- try (list_unique_index true lb) - 1
- with Not_found ->
- Util.user_err_loc
- (loc,"pretype",
- Pp.str "cannot guess decreasing argument of fix"))
- vn
- in
- let fix = ((guard_indexes, i),(names,ftys,Array.map j_val vdefj)) in
- (try check_fix env fix with e -> Stdpp.raise_with_loc loc e);
- make_judge (mkFix fix) ftys.(i)
+ | Some n -> [n]
+ | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i))
+ vn)
+ in
+ let fixdecls = (names,ftys,Array.map j_val vdefj) 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,Array.map j_val vdefj)) in
(try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
@@ -292,7 +295,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
let typ' = nf_isevar !isevars typ in
let tycon =
- option_map
+ Option.map
(fun (abs, ty) ->
match abs with
None ->
@@ -308,7 +311,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
apply_rec env (n+1)
{ uj_val = nf_isevar !isevars value;
uj_type = nf_isevar !isevars typ' }
- (option_map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest
+ (Option.map (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest
| _ ->
let hj = pretype empty_tycon env isevars lvar c in
@@ -316,7 +319,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
(join_loc floc argloc) env (evars_of !isevars)
resj [hj]
in
- let ftycon = option_map (lift_abstr_tycon_type (-1)) ftycon in
+ let ftycon = Option.map (lift_abstr_tycon_type (-1)) ftycon in
let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in
let resj =
match kind_of_term resj.uj_val with
@@ -328,7 +331,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
| _ -> resj in
inh_conv_coerce_to_tycon loc env isevars resj tycon
- | RLambda(loc,name,c1,c2) ->
+ | RLambda(loc,name,k,c1,c2) ->
let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in
let dom_valcon = valcon_of_tycon dom in
let j = pretype_type dom_valcon env isevars lvar c1 in
@@ -336,7 +339,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let j' = pretype rng (push_rel var env) isevars lvar c2 in
judge_of_abstraction env name j j'
- | RProd(loc,name,c1,c2) ->
+ | RProd(loc,name,k,c1,c2) ->
let j = pretype_type empty_valcon env isevars lvar c1 in
let var = (name,j.utj_val) in
let env' = push_rel_assum var env in
@@ -397,7 +400,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let f = it_mkLambda_or_LetIn fj.uj_val fsign in
let v =
let mis,_ = dest_ind_family indf in
- let ci = make_default_case_info env LetStyle mis 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 }
@@ -415,7 +418,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
let v =
let mis,_ = dest_ind_family indf in
- let ci = make_default_case_info env LetStyle mis in
+ let ci = make_case_info env mis LetStyle in
mkCase (ci, p, cj.uj_val,[|f|] )
in
{ uj_val = v; uj_type = ccl })
@@ -485,14 +488,14 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let b2 = f cstrs.(1) b2 in
let v =
let mis,_ = dest_ind_family indf in
- let ci = make_default_case_info env IfStyle mis 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,po,tml,eqns) ->
- Cases.compile_cases loc
- ((fun vtyc env -> pretype vtyc env isevars lvar),isevars)
+ | RCases (loc,sty,po,tml,eqns) ->
+ Cases.compile_cases loc sty
+ ((fun vtyc env isevars -> pretype vtyc env isevars lvar),isevars)
tycon env (* loc *) (po,tml,eqns)
| RCast(loc,c,k) ->
@@ -552,15 +555,22 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
error_unexpected_type_loc
(loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v
- let pretype_gen isevars env lvar kind c =
+ let pretype_gen_aux isevars 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 isevars lvar c).uj_val
| IsType ->
(pretype_type empty_valcon env isevars lvar c).utj_val in
+ let evd,_ = consider_remaining_unif_problems env !isevars in
+ isevars:=evd;
nf_evar (evars_of !isevars) c'
+ let pretype_gen isevars env lvar kind c =
+ let c = pretype_gen_aux isevars env lvar kind c in
+ isevars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:false env !isevars;
+ nf_evar (evars_of !isevars) 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...
@@ -587,11 +597,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
let ise_pretype_gen fail_evar sigma env lvar kind c =
let isevars = ref (Evd.create_evar_defs sigma) in
let c = pretype_gen isevars env lvar kind c in
- let isevars,_ = consider_remaining_unif_problems env !isevars in
- let c = nf_evar (evars_of isevars) c in
- if fail_evar then check_evars env sigma isevars c;
- isevars, c
-
+ let evd = !isevars in
+ if fail_evar then check_evars env Evd.empty evd c;
+ evd, c
+
(** Entry points of the high-level type synthesis algorithm *)
let understand_gen kind sigma env c =
@@ -601,16 +610,23 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct
snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c)
let understand_type sigma env c =
- snd (ise_pretype_gen true sigma env ([],[]) IsType c)
+ snd (ise_pretype_gen false sigma env ([],[]) IsType c)
let understand_ltac sigma env lvar kind c =
ise_pretype_gen false sigma env lvar kind c
- let understand_tcc_evars isevars env kind c =
- pretype_gen isevars env ([],[]) kind c
-
- let understand_tcc sigma env ?expected_type:exptyp c =
- let ev, t = ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c in
+ let understand_tcc_evars evdref env kind c =
+ pretype_gen evdref env ([],[]) kind c
+
+ let understand_tcc ?(resolve_classes=true) sigma env ?expected_type:exptyp c =
+ let ev, t =
+ if resolve_classes then
+ ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c
+ else
+ let isevars = ref (Evd.create_evar_defs sigma) in
+ let c = pretype_gen_aux isevars env ([],[]) (OfType exptyp) c in
+ !isevars, c
+ in
Evd.evars_of ev, t
end
diff --git a/contrib/subtac/subtac_utils.ml b/contrib/subtac/subtac_utils.ml
index 28fe6352..bae2731a 100644
--- a/contrib/subtac/subtac_utils.ml
+++ b/contrib/subtac/subtac_utils.ml
@@ -10,10 +10,10 @@ let ($) f x = f x
(****************************************************************************)
(* Library linking *)
-let contrib_name = "subtac"
+let contrib_name = "Program"
let subtac_dir = [contrib_name]
-let fix_sub_module = "FixSub"
+let fix_sub_module = "Wf"
let utils_module = "Utils"
let fixsub_module = subtac_dir @ [fix_sub_module]
let utils_module = subtac_dir @ [utils_module]
@@ -28,8 +28,8 @@ 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 ["subtac";"FixSub"] "Fix_sub"
-let fix_measure_sub_ref = make_ref ["subtac";"FixSub"] "Fix_measure_sub"
+let fix_sub_ref = make_ref fixsub_module "Fix_sub"
+let fix_measure_sub_ref = make_ref fixsub_module "Fix_measure_sub"
let lt_ref = make_ref ["Init";"Peano"] "lt"
let lt_wf_ref = make_ref ["Wf_nat"] "lt_wf"
let refl_ref = make_ref ["Init";"Logic"] "refl_equal"
@@ -64,9 +64,15 @@ 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 (init_constant ["Logic";"JMeq"] "JMeq")
-let jmeq_rec = lazy (init_constant ["Logic";"JMeq"] "JMeq_rec")
-let jmeq_refl = lazy (init_constant ["Logic";"JMeq"] "JMeq_refl")
+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")
@@ -113,20 +119,20 @@ let debug_on = true
let debug n s =
if debug_on then
- if !Options.debug && n >= debug_level then
+ if !Flags.debug && n >= debug_level then
msgnl s
else ()
else ()
let debug_msg n s =
if debug_on then
- if !Options.debug && n >= debug_level then s
+ if !Flags.debug && n >= debug_level then s
else mt ()
else mt ()
let trace s =
if debug_on then
- if !Options.debug && debug_level > 0 then msgnl s
+ if !Flags.debug && debug_level > 0 then msgnl s
else ()
else ()
@@ -163,7 +169,7 @@ let make_existential loc ?(opaque = true) env isevars c =
let make_existential_expr loc env c =
let key = Evarutil.new_untyped_evar () in
- let evar = Topconstr.CEvar (loc, key) in
+ let evar = Topconstr.CEvar (loc, key, None) in
debug 2 (str "Constructed evar " ++ int key);
evar
@@ -174,6 +180,8 @@ let string_of_hole_kind = function
| CasesType -> "CasesType"
| InternalHole -> "InternalHole"
| TomatchTypeParameter _ -> "TomatchTypeParameter"
+ | GoalEvar -> "GoalEvar"
+ | ImpossibleCase -> "ImpossibleCase"
let evars_of_term evc init c =
let rec evrec acc c =
@@ -194,7 +202,7 @@ let non_instanciated_map env evd evm =
QuestionMark _ -> Evd.add evm key evi
| _ ->
debug 2 (str " and is an implicit");
- Pretype_errors.error_unsolvable_implicit loc env evm k)
+ 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
@@ -231,8 +239,8 @@ let build_dependent_sum l =
(tclTHENS tac
([intros;
(tclTHENSEQ
- [constructor_tac (Some 1) 1
- (Rawterm.ImplicitBindings [mkVar n]);
+ [constructor_tac false (Some 1) 1
+ (Rawterm.ImplicitBindings [inj_open (mkVar n)]);
cont]);
])))
in
@@ -342,29 +350,44 @@ let id_of_name = function
| Anonymous -> raise (Invalid_argument "id_of_name")
let definition_message id =
- Options.if_verbose message ((string_of_id id) ^ " is defined")
-
+ Nameops.pr_id id ++ str " is defined"
+
let recursive_message v =
match Array.length v with
| 0 -> error "no recursive definition"
- | 1 -> (Printer.pr_global v.(0) ++ str " is recursively defined")
- | _ -> hov 0 (prvect_with_sep pr_coma Printer.pr_global v ++
+ | 1 -> (Printer.pr_constant (Global.env ()) v.(0) ++ str " is recursively defined")
+ | _ -> hov 0 (prvect_with_sep pr_coma (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 =
- debug 2 (str "Solving goal using tactics: " ++ Evd.pr_evar_info evi);
let id = id_of_string "H" in
- try
+ try
Pfedit.start_proof id goal_kind evi.evar_hyps evi.evar_concl
(fun _ _ -> ());
- debug 2 (str "Started proof");
Pfedit.by (tclCOMPLETE t);
- let _,(const,_,_) = Pfedit.cook_proof () in
+ let _,(const,_,_) = Pfedit.cook_proof ignore in
Pfedit.delete_current_proof (); const.Entries.const_entry_body
- with e ->
+ with e ->
Pfedit.delete_current_proof();
- raise Exit
+ 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
[] -> ""
@@ -395,7 +418,7 @@ let pr_meta_map evd =
| (mv,Clval(na,b,_)) ->
hov 0
(pr_meta mv ++ pr_name na ++ str " := " ++
- print_constr b.rebus ++ fnl ())
+ print_constr (fst b).rebus ++ fnl ())
in
prlist pr_meta_binding ml
@@ -440,11 +463,11 @@ let pr_evar_defs evd =
str"METAS:"++brk(0,1)++pr_meta_map evd in
v 0 (pp_evm ++ pp_met)
-let subtac_utils_path =
- make_dirpath (List.map id_of_string ["Utils";contrib_name;"Coq"])
-let utils_tac s =
- lazy(make_kn (MPfile subtac_utils_path) (make_dirpath []) (mk_label s))
+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 utils_call tac args =
- TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (utils_tac tac)),args))
+let tactics_call tac args =
+ TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, Lazy.force (tactics_tac tac)),args))
diff --git a/contrib/subtac/subtac_utils.mli b/contrib/subtac/subtac_utils.mli
index 5a5dd427..49335211 100644
--- a/contrib/subtac/subtac_utils.mli
+++ b/contrib/subtac/subtac_utils.mli
@@ -89,11 +89,11 @@ 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_defs ref -> evar_map -> evar_map
val global_kind : logical_kind
-val goal_kind : locality_flag * goal_object_kind
+val goal_kind : locality * goal_object_kind
val global_proof_kind : logical_kind
-val goal_proof_kind : locality_flag * goal_object_kind
+val goal_proof_kind : locality * goal_object_kind
val global_fix_kind : logical_kind
-val goal_fix_kind : locality_flag * goal_object_kind
+val goal_fix_kind : locality * goal_object_kind
val mkSubset : name -> constr -> constr -> constr
val mkProj1 : constr -> constr -> constr -> constr
@@ -115,8 +115,10 @@ val destruct_ex : constr -> constr -> constr list
val id_of_name : name -> identifier
-val definition_message : identifier -> unit
-val recursive_message : global_reference array -> std_ppcmds
+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
@@ -125,6 +127,6 @@ val string_of_intset : Intset.t -> string
val pr_evar_defs : evar_defs -> Pp.std_ppcmds
-val utils_call : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr
+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/contrib/subtac/test/ListDep.v b/contrib/subtac/test/ListDep.v
index 97cef9a5..da612c43 100644
--- a/contrib/subtac/test/ListDep.v
+++ b/contrib/subtac/test/ListDep.v
@@ -1,6 +1,6 @@
(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
Require Import List.
-Require Import Coq.subtac.Utils.
+Require Import Coq.Program.Program.
Set Implicit Arguments.
@@ -23,13 +23,13 @@ Section Map_DependentRecursor.
Variable f : { x : U | In x l } -> V.
Obligations Tactic := unfold sub_list in * ;
- subtac_simpl ; intuition.
+ 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
+ | nil => nil
+ | cons x tl => let tl' := map_rec tl in
f x :: tl'
end.
diff --git a/contrib/subtac/test/Mutind.v b/contrib/subtac/test/Mutind.v
index 0b40ef82..ac49ca96 100644
--- a/contrib/subtac/test/Mutind.v
+++ b/contrib/subtac/test/Mutind.v
@@ -1,13 +1,20 @@
-Program Fixpoint f (a : nat) : nat :=
+Require Import List.
+
+Program Fixpoint f a : { x : nat | x > 0 } :=
match a with
- | 0 => 0
+ | 0 => 1
| S a' => g a a'
end
-with g (a b : nat) { struct b } : nat :=
+with g a b : { x : nat | x > 0 } :=
match b with
- | 0 => 0
+ | 0 => 1
| S b' => f b'
end.
Check f.
-Check g. \ No newline at end of file
+Check g.
+
+
+
+
+
diff --git a/contrib/subtac/test/euclid.v b/contrib/subtac/test/euclid.v
index a5a8b85f..501aa798 100644
--- a/contrib/subtac/test/euclid.v
+++ b/contrib/subtac/test/euclid.v
@@ -1,20 +1,17 @@
-Require Import Coq.subtac.Utils.
+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).
-Require Import Omega.
-
-Obligations.
-Solve Obligations using subtac_simpl ; omega.
-
Next Obligation.
- assert(x0 * S q' = x0 * q' + x0) by auto with arith ; omega.
+ 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).
diff --git a/contrib/subtac/test/measure.v b/contrib/subtac/test/measure.v
index 4764037d..4f938f4f 100644
--- a/contrib/subtac/test/measure.v
+++ b/contrib/subtac/test/measure.v
@@ -2,7 +2,7 @@ Notation "( x & y )" := (@existS _ _ x y) : core_scope.
Unset Printing All.
Require Import Coq.Arith.Compare_dec.
-Require Import Coq.subtac.Utils.
+Require Import Coq.Program.Program.
Fixpoint size (a : nat) : nat :=
match a with
@@ -10,15 +10,11 @@ Fixpoint size (a : nat) : nat :=
| S n => S (size n)
end.
-Program Fixpoint test_measure (a : nat) {measure a size} : nat :=
+Program Fixpoint test_measure (a : nat) {measure size a} : nat :=
match a with
| S (S n) => S (test_measure n)
- | x => x
+ | 0 | S 0 => a
end.
-subst.
-unfold n0.
-auto with arith.
-Qed.
Check test_measure.
Print test_measure. \ No newline at end of file
diff --git a/contrib/subtac/test/take.v b/contrib/subtac/test/take.v
new file mode 100644
index 00000000..87ab47d6
--- /dev/null
+++ b/contrib/subtac/test/take.v
@@ -0,0 +1,38 @@
+(* -*- coq-prog-args: ("-emacs-U" "-debug") -*- *)
+Require Import JMeq.
+Require Import List.
+Require Import Coq.subtac.Utils.
+
+Set Implicit Arguments.
+
+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.
+
+Next Obligation.
+ intros.
+ simpl in l0.
+ apply le_S_n ; exact l0.
+Defined.
+
+Next Obligation.
+ intros.
+ destruct_call take ; subtac_simpl.
+Defined.
+
+Next Obligation.
+ intros.
+ inversion l0.
+Defined.
+
+
+
+
diff --git a/contrib/xml/cic2acic.ml b/contrib/xml/cic2acic.ml
index 8a5967a2..1a6cb9c8 100644
--- a/contrib/xml/cic2acic.ml
+++ b/contrib/xml/cic2acic.ml
@@ -55,18 +55,8 @@ let remove_module_dirpath_from_dirpath ~basedir dir =
let get_uri_of_var v pvars =
- let module D = Declare in
+ let module D = Decls in
let module N = Names in
- let rec search_in_pvars names =
- function
- [] -> None
- | ((name,l)::tl) ->
- let names' = name::names in
- if List.mem v l then
- Some names'
- else
- search_in_pvars names' tl
- in
let rec search_in_open_sections =
function
[] -> Util.error ("Variable "^v^" not found")
@@ -78,9 +68,10 @@ let get_uri_of_var v pvars =
search_in_open_sections tl
in
let path =
- match search_in_pvars [] pvars with
- None -> search_in_open_sections (N.repr_dirpath (Lib.cwd ()))
- | Some path -> path
+ if List.mem v pvars then
+ []
+ else
+ search_in_open_sections (N.repr_dirpath (Lib.cwd ()))
in
"cic:" ^
List.fold_left
@@ -241,16 +232,15 @@ let typeur sigma metamap =
| T.Var id ->
(try
let (_,_,ty) = Environ.lookup_named id env in
- T.body_of_type ty
+ 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 -> T.body_of_type (Inductiveops.type_of_inductive env ind)
- | T.Construct cstr ->
- T.body_of_type (Inductiveops.type_of_constructor env cstr)
+ | 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)
@@ -273,7 +263,7 @@ let typeur sigma metamap =
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.prop_univ (* ERROR HERE *)
+ | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *)
| CProp -> T.mkConst DoubleTypeInference.cprop
and sort_of env t =
diff --git a/contrib/xml/doubleTypeInference.ml b/contrib/xml/doubleTypeInference.ml
index cce78891..de8c540c 100644
--- a/contrib/xml/doubleTypeInference.ml
+++ b/contrib/xml/doubleTypeInference.ml
@@ -51,7 +51,7 @@ let type_judgment env sigma j =
;;
let type_judgment_cprop env sigma j =
- match Term.kind_of_term(whd_betadeltaiotacprop env sigma (Term.body_of_type j.Environ.uj_type)) with
+ 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 *)
;;
diff --git a/contrib/xml/dumptree.ml4 b/contrib/xml/dumptree.ml4
new file mode 100644
index 00000000..407f86b3
--- /dev/null
+++ b/contrib/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_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/contrib/xml/xmlcommand.ml b/contrib/xml/xmlcommand.ml
index 01271323..3c4b01f5 100644
--- a/contrib/xml/xmlcommand.ml
+++ b/contrib/xml/xmlcommand.ml
@@ -73,11 +73,7 @@ let could_have_namesakes o sp = (* namesake = omonimo in italian *)
let tag = Libobject.object_tag o in
print_if_verbose ("Object tag: " ^ tag ^ "\n") ;
match tag with
- "CONSTANT" ->
- (match D.constant_strength sp with
- | DK.Local -> false (* a local definition *)
- | DK.Global -> true (* a non-local one *)
- )
+ "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*)
@@ -89,8 +85,7 @@ let could_have_namesakes o sp = (* namesake = omonimo in italian *)
(* OF VARIABLES DECLARED IN THE i-th SUPER-SECTION OF THE CURRENT *)
(* SECTION, WHOSE PATH IS namei *)
-let pvars =
- ref ([Names.id_of_string "",[]] : (Names.identifier * string list) list);;
+let pvars = ref ([] : string list);;
let cumenv = ref Environ.empty_env;;
(* filter_params pvars hyps *)
@@ -138,9 +133,7 @@ let add_to_pvars x =
E.push_named (Names.id_of_string v, None, typ) !cumenv ;
v
in
- match !pvars with
- [] -> assert false
- | ((name,l)::tl) -> pvars := (name,v::l)::tl
+ pvars := v::!pvars
;;
(* The computation is very inefficient, but we can't do anything *)
@@ -157,7 +150,7 @@ let search_variables () =
| 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 (Declare.last_section_hyps dirpath) in
+ let t = List.map N.string_of_id (Decls.last_section_hyps dirpath) in
[he,t]
in
one_section_variables @ aux tl
@@ -329,14 +322,13 @@ let mk_variable_obj id body typ =
let variables = search_variables () in
let params = filter_params variables hyps'' in
Acic.Variable
- (Names.string_of_id id, unsharedbody,
- (Unshare.unshare (Term.body_of_type typ)), params)
+ (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 (Term.body_of_type ty) in
+ let unshared_ty = Unshare.unshare ty in
let metasenv =
List.map
(function
@@ -384,7 +376,7 @@ let mk_current_proof_obj is_a_variable id bo ty evar_map env =
let mk_constant_obj id bo ty variables hyps =
let hyps = string_list_of_named_context_list hyps in
- let ty = Unshare.unshare (Term.body_of_type ty) in
+ let ty = Unshare.unshare ty in
let params = filter_params variables hyps in
match bo with
None ->
@@ -413,7 +405,7 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite =
let cons =
(Array.fold_right (fun (name,lc) i -> (name,lc)::i)
(Array.mapi
- (fun j x ->(x,Unshare.unshare (Term.body_of_type lc.(j)))) consnames)
+ (fun j x ->(x,Unshare.unshare lc.(j))) consnames)
[]
)
in
@@ -447,7 +439,7 @@ let kind_of_inductive isrecord kn =
let kind_of_variable id =
let module DK = Decl_kinds in
- match Declare.variable_kind id with
+ match Decls.variable_kind id with
| DK.IsAssumption DK.Definitional -> "VARIABLE","Assumption"
| DK.IsAssumption DK.Logical -> "VARIABLE","Hypothesis"
| DK.IsAssumption DK.Conjectural -> "VARIABLE","Conjecture"
@@ -458,7 +450,7 @@ let kind_of_variable id =
let kind_of_constant kn =
let module DK = Decl_kinds in
- match Declare.constant_kind (Nametab.sp_of_global(Libnames.ConstRef kn)) with
+ match Decls.constant_kind kn with
| DK.IsAssumption DK.Definitional -> "AXIOM","Declaration"
| DK.IsAssumption DK.Logical -> "AXIOM","Axiom"
| DK.IsAssumption DK.Conjectural ->
@@ -492,6 +484,12 @@ let kind_of_constant kn =
| 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 _ ->
@@ -541,11 +539,10 @@ let print internal glob_ref kind xml_library_root =
let tag,obj =
match glob_ref with
Ln.VarRef id ->
- let sp = Declare.find_section_variable id in
(* 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 (Ln.basename sp))
+ 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
@@ -692,11 +689,11 @@ let _ =
Buffer.output_buffer ch theory_buffer ;
close_out ch
end ;
- Util.option_iter
+ Option.iter
(fun fn ->
let coqdoc = Coq_config.bindir^"/coqdoc" in
let options = " --html -s --body-only --no-index --latin1 --raw-comments" in
- let dir = Util.out_some xml_library_root in
+ let dir = Option.get xml_library_root in
let command cmd =
if Sys.command cmd <> 0 then
Util.anomaly ("Error executing \"" ^ cmd ^ "\"")