summaryrefslogtreecommitdiff
path: root/plugins
diff options
context:
space:
mode:
Diffstat (limited to 'plugins')
-rw-r--r--plugins/btauto/btauto_plugin.mlpack (renamed from plugins/btauto/btauto_plugin.mllib)1
-rw-r--r--plugins/btauto/refl_btauto.ml15
-rw-r--r--plugins/cc/cc_plugin.mlpack (renamed from plugins/cc/cc_plugin.mllib)1
-rw-r--r--plugins/cc/ccalgo.ml39
-rw-r--r--plugins/cc/ccalgo.mli2
-rw-r--r--plugins/cc/ccproof.ml14
-rw-r--r--plugins/cc/cctac.ml206
-rw-r--r--plugins/cc/g_congruence.ml42
-rw-r--r--plugins/decl_mode/decl_expr.mli2
-rw-r--r--plugins/decl_mode/decl_interp.ml12
-rw-r--r--plugins/decl_mode/decl_mode.ml4
-rw-r--r--plugins/decl_mode/decl_mode_plugin.mlpack (renamed from plugins/decl_mode/decl_mode_plugin.mllib)1
-rw-r--r--plugins/decl_mode/decl_proof_instr.ml99
-rw-r--r--plugins/decl_mode/g_decl_mode.ml434
-rw-r--r--plugins/decl_mode/ppdecl_proof.ml2
-rw-r--r--plugins/derive/derive.ml9
-rw-r--r--plugins/derive/derive_plugin.mlpack (renamed from plugins/derive/derive_plugin.mllib)0
-rw-r--r--plugins/derive/g_derive.ml44
-rw-r--r--plugins/extraction/ExtrOcamlZBigInt.v2
-rw-r--r--plugins/extraction/common.ml54
-rw-r--r--plugins/extraction/extract_env.ml11
-rw-r--r--plugins/extraction/extraction.ml119
-rw-r--r--plugins/extraction/extraction_plugin.mlpack (renamed from plugins/extraction/extraction_plugin.mllib)1
-rw-r--r--plugins/extraction/g_extraction.ml410
-rw-r--r--plugins/extraction/haskell.ml6
-rw-r--r--plugins/extraction/json.ml8
-rw-r--r--plugins/extraction/modutil.ml12
-rw-r--r--plugins/extraction/ocaml.ml4
-rw-r--r--plugins/extraction/scheme.ml2
-rw-r--r--plugins/extraction/table.ml146
-rw-r--r--plugins/extraction/table.mli5
-rw-r--r--plugins/firstorder/formula.ml21
-rw-r--r--plugins/firstorder/formula.mli5
-rw-r--r--plugins/firstorder/g_ground.ml439
-rw-r--r--plugins/firstorder/ground.ml6
-rw-r--r--plugins/firstorder/ground_plugin.mlpack (renamed from plugins/firstorder/ground_plugin.mllib)1
-rw-r--r--plugins/firstorder/instances.ml25
-rw-r--r--plugins/firstorder/rules.ml26
-rw-r--r--plugins/firstorder/sequent.ml2
-rw-r--r--plugins/fourier/fourierR.ml25
-rw-r--r--plugins/fourier/fourier_plugin.mlpack (renamed from plugins/fourier/fourier_plugin.mllib)1
-rw-r--r--plugins/funind/functional_principles_proofs.ml136
-rw-r--r--plugins/funind/functional_principles_types.ml68
-rw-r--r--plugins/funind/g_indfun.ml457
-rw-r--r--plugins/funind/glob_term_to_relation.ml68
-rw-r--r--plugins/funind/glob_termops.ml2
-rw-r--r--plugins/funind/indfun.ml83
-rw-r--r--plugins/funind/indfun.mli4
-rw-r--r--plugins/funind/indfun_common.ml20
-rw-r--r--plugins/funind/indfun_common.mli2
-rw-r--r--plugins/funind/invfun.ml111
-rw-r--r--plugins/funind/merge.ml65
-rw-r--r--plugins/funind/recdef.ml124
-rw-r--r--plugins/funind/recdef_plugin.mlpack (renamed from plugins/funind/recdef_plugin.mllib)1
-rw-r--r--plugins/micromega/Env.v6
-rw-r--r--plugins/micromega/EnvRing.v2
-rw-r--r--plugins/micromega/Lia.v34
-rw-r--r--plugins/micromega/Lqa.v51
-rw-r--r--plugins/micromega/Lra.v52
-rw-r--r--plugins/micromega/MExtraction.v2
-rw-r--r--plugins/micromega/Psatz.v71
-rw-r--r--plugins/micromega/QMicromega.v2
-rw-r--r--plugins/micromega/RMicromega.v2
-rw-r--r--plugins/micromega/RingMicromega.v2
-rw-r--r--plugins/micromega/VarMap.v29
-rw-r--r--plugins/micromega/ZMicromega.v2
-rw-r--r--plugins/micromega/certificate.ml1565
-rw-r--r--plugins/micromega/coq_micromega.ml887
-rw-r--r--plugins/micromega/g_micromega.ml453
-rw-r--r--plugins/micromega/mfourier.ml26
-rw-r--r--plugins/micromega/micromega.ml2827
-rw-r--r--plugins/micromega/micromega.mli950
-rw-r--r--plugins/micromega/micromega_plugin.mlpack (renamed from plugins/micromega/micromega_plugin.mllib)1
-rw-r--r--plugins/micromega/mutils.ml21
-rw-r--r--plugins/micromega/persistent_cache.ml10
-rw-r--r--plugins/micromega/vo.itarget4
-rw-r--r--plugins/nsatz/Nsatz.v5
-rw-r--r--plugins/nsatz/g_nsatz.ml417
-rw-r--r--plugins/nsatz/ideal.ml143
-rw-r--r--plugins/nsatz/ideal.mli47
-rw-r--r--plugins/nsatz/nsatz.ml (renamed from plugins/nsatz/nsatz.ml4)61
-rw-r--r--plugins/nsatz/nsatz.mli9
-rw-r--r--plugins/nsatz/nsatz_plugin.mlpack (renamed from plugins/nsatz/nsatz_plugin.mllib)2
-rw-r--r--plugins/nsatz/utile.ml6
-rw-r--r--plugins/omega/coq_omega.ml208
-rw-r--r--plugins/omega/g_omega.ml418
-rw-r--r--plugins/omega/omega_plugin.mlpack (renamed from plugins/omega/omega_plugin.mllib)1
-rw-r--r--plugins/plugins.itarget3
-rw-r--r--plugins/pluginsbyte.itarget21
-rw-r--r--plugins/pluginsdyn.itarget24
-rw-r--r--plugins/pluginsopt.itarget21
-rw-r--r--plugins/pluginsvo.itarget12
-rw-r--r--plugins/quote/g_quote.ml414
-rw-r--r--plugins/quote/quote.ml13
-rw-r--r--plugins/quote/quote_plugin.mllib3
-rw-r--r--plugins/quote/quote_plugin.mlpack2
-rw-r--r--plugins/romega/ReflOmegaCore.v39
-rw-r--r--plugins/romega/const_omega.ml6
-rw-r--r--plugins/romega/g_romega.ml418
-rw-r--r--plugins/romega/refl_omega.ml22
-rw-r--r--plugins/romega/romega_plugin.mlpack (renamed from plugins/romega/romega_plugin.mllib)1
-rw-r--r--plugins/rtauto/Bintree.v2
-rw-r--r--plugins/rtauto/proof_search.ml4
-rw-r--r--plugins/rtauto/refl_tauto.ml29
-rw-r--r--plugins/rtauto/refl_tauto.mli2
-rw-r--r--plugins/rtauto/rtauto_plugin.mlpack (renamed from plugins/rtauto/rtauto_plugin.mllib)1
-rw-r--r--plugins/setoid_ring/ArithRing.v4
-rw-r--r--plugins/setoid_ring/InitialRing.v50
-rw-r--r--plugins/setoid_ring/NArithRing.v2
-rw-r--r--plugins/setoid_ring/Ncring_initial.v4
-rw-r--r--plugins/setoid_ring/Ring.v6
-rw-r--r--plugins/setoid_ring/Ring_polynom.v2
-rw-r--r--plugins/setoid_ring/Ring_tac.v2
-rw-r--r--plugins/setoid_ring/Ring_theory.v5
-rw-r--r--plugins/setoid_ring/ZArithRing.v8
-rw-r--r--plugins/setoid_ring/g_newring.ml4133
-rw-r--r--plugins/setoid_ring/newring.ml (renamed from plugins/setoid_ring/newring.ml4)319
-rw-r--r--plugins/setoid_ring/newring.mli78
-rw-r--r--plugins/setoid_ring/newring_ast.mli63
-rw-r--r--plugins/setoid_ring/newring_plugin.mllib2
-rw-r--r--plugins/setoid_ring/newring_plugin.mlpack2
-rw-r--r--plugins/ssrmatching/ssrmatching.ml41447
-rw-r--r--plugins/ssrmatching/ssrmatching.mli241
-rw-r--r--plugins/ssrmatching/ssrmatching.v26
-rw-r--r--plugins/ssrmatching/ssrmatching_plugin.mlpack1
-rw-r--r--plugins/ssrmatching/vo.itarget1
-rw-r--r--plugins/syntax/ascii_syntax.ml6
-rw-r--r--plugins/syntax/ascii_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/ascii_syntax_plugin.mlpack1
-rw-r--r--plugins/syntax/nat_syntax.ml20
-rw-r--r--plugins/syntax/nat_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/nat_syntax_plugin.mlpack1
-rw-r--r--plugins/syntax/numbers_syntax.ml10
-rw-r--r--plugins/syntax/numbers_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/numbers_syntax_plugin.mlpack1
-rw-r--r--plugins/syntax/r_syntax.ml4
-rw-r--r--plugins/syntax/r_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/r_syntax_plugin.mlpack1
-rw-r--r--plugins/syntax/string_syntax.ml6
-rw-r--r--plugins/syntax/string_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/string_syntax_plugin.mlpack1
-rw-r--r--plugins/syntax/z_syntax.ml6
-rw-r--r--plugins/syntax/z_syntax_plugin.mllib2
-rw-r--r--plugins/syntax/z_syntax_plugin.mlpack1
144 files changed, 5575 insertions, 5963 deletions
diff --git a/plugins/btauto/btauto_plugin.mllib b/plugins/btauto/btauto_plugin.mlpack
index 319a9c30..2410f906 100644
--- a/plugins/btauto/btauto_plugin.mllib
+++ b/plugins/btauto/btauto_plugin.mlpack
@@ -1,3 +1,2 @@
Refl_btauto
G_btauto
-Btauto_plugin_mod
diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml
index 57268a9c..6e8b2eb0 100644
--- a/plugins/btauto/refl_btauto.ml
+++ b/plugins/btauto/refl_btauto.ml
@@ -1,3 +1,4 @@
+open Proofview.Notations
let contrib_name = "btauto"
@@ -11,7 +12,7 @@ let get_constant dir s = lazy (Coqlib.gen_constant contrib_name dir s)
let get_inductive dir s =
let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in
- Lazy.lazy_from_fun (fun () -> Globnames.destIndRef (glob_ref ()))
+ Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ()))
let decomp_term (c : Term.constr) =
Term.kind_of_term (Term.strip_outer_cast c)
@@ -211,12 +212,12 @@ module Btauto = struct
let assign = List.map map_msg assign in
let l = str "[" ++ (concat (str ";" ++ spc ()) assign) ++ str "]" in
str "Not a tautology:" ++ spc () ++ l
- with e when Errors.noncritical e -> (str "Not a tautology")
+ with e when CErrors.noncritical e -> (str "Not a tautology")
in
Tacticals.tclFAIL 0 msg gl
let try_unification env =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let eq = Lazy.force eq in
let t = decomp_term concl in
@@ -228,10 +229,10 @@ module Btauto = struct
| _ ->
let msg = str "Btauto: Internal error" in
Tacticals.New.tclFAIL 0 msg
- end
+ end }
let tac =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let eq = Lazy.force eq in
let bool = Lazy.force Bool.typ in
@@ -249,12 +250,12 @@ module Btauto = struct
Tacticals.New.tclTHENLIST [
Tactics.change_concl changed_gl;
Tactics.apply (Lazy.force soundness);
- Proofview.V82.tactic (Tactics.normalise_vm_in_concl);
+ Tactics.normalise_vm_in_concl;
try_unification env
]
| _ ->
let msg = str "Cannot recognize a boolean equality" in
Tacticals.New.tclFAIL 0 msg
- end
+ end }
end
diff --git a/plugins/cc/cc_plugin.mllib b/plugins/cc/cc_plugin.mlpack
index 1bcfc537..27e903fd 100644
--- a/plugins/cc/cc_plugin.mllib
+++ b/plugins/cc/cc_plugin.mlpack
@@ -2,4 +2,3 @@ Ccalgo
Ccproof
Cctac
G_congruence
-Cc_plugin_mod
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
index bc3d9ed5..bc53b113 100644
--- a/plugins/cc/ccalgo.ml
+++ b/plugins/cc/ccalgo.ml
@@ -10,7 +10,7 @@
(* Downey,Sethi and Tarjan. *)
(* Plus some e-matching and constructor handling by P. Corbineau *)
-open Errors
+open CErrors
open Util
open Pp
open Goptions
@@ -25,7 +25,7 @@ let init_size=5
let cc_verbose=ref false
let debug x =
- if !cc_verbose then msg_debug x
+ if !cc_verbose then Feedback.msg_debug (x ())
let _=
let gdopt=
@@ -154,11 +154,6 @@ let rec term_equal t1 t2 =
open Hashset.Combine
-let hash_sorts_family = function
-| InProp -> 0
-| InSet -> 1
-| InType -> 2
-
let rec hash_term = function
| Symb c -> combine 1 (hash_constr c)
| Product (s1, s2) -> combine3 2 (Sorts.hash s1) (Sorts.hash s2)
@@ -489,7 +484,7 @@ let build_subst uf subst =
Array.map
(fun i ->
try term uf i
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
anomaly (Pp.str "incomplete matching"))
subst
@@ -603,7 +598,7 @@ let add_inst state (inst,int_subst) =
Control.check_for_interrupt ();
if state.rew_depth > 0 then
if is_redundant state inst.qe_hyp_id int_subst then
- debug (str "discarding redundant (dis)equality")
+ debug (fun () -> str "discarding redundant (dis)equality")
else
begin
Identhash.add state.q_history inst.qe_hyp_id int_subst;
@@ -618,7 +613,7 @@ let add_inst state (inst,int_subst) =
state.rew_depth<-pred state.rew_depth;
if inst.qe_pol then
begin
- debug (
+ debug (fun () ->
(str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++
(str " [" ++ Termops.print_constr prf ++ str " : " ++
pr_term s ++ str " == " ++ pr_term t ++ str "]"));
@@ -626,7 +621,7 @@ let add_inst state (inst,int_subst) =
end
else
begin
- debug (
+ debug (fun () ->
(str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++
(str " [" ++ Termops.print_constr prf ++ str " : " ++
pr_term s ++ str " <> " ++ pr_term t ++ str "]"));
@@ -657,7 +652,7 @@ let join_path uf i j=
min_path (down_path uf i [],down_path uf j [])
let union state i1 i2 eq=
- debug (str "Linking " ++ pr_idx_term state.uf i1 ++
+ debug (fun () -> str "Linking " ++ pr_idx_term state.uf i1 ++
str " and " ++ pr_idx_term state.uf i2 ++ str ".");
let r1= get_representative state.uf i1
and r2= get_representative state.uf i2 in
@@ -698,7 +693,7 @@ let union state i1 i2 eq=
let merge eq state = (* merge and no-merge *)
debug
- (str "Merging " ++ pr_idx_term state.uf eq.lhs ++
+ (fun () -> str "Merging " ++ pr_idx_term state.uf eq.lhs ++
str " and " ++ pr_idx_term state.uf eq.rhs ++ str ".");
let uf=state.uf in
let i=find uf eq.lhs
@@ -711,7 +706,7 @@ let merge eq state = (* merge and no-merge *)
let update t state = (* update 1 and 2 *)
debug
- (str "Updating term " ++ pr_idx_term state.uf t ++ str ".");
+ (fun () -> str "Updating term " ++ pr_idx_term state.uf 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
@@ -773,7 +768,7 @@ let process_constructor_mark t i rep pac state =
let process_mark t m state =
debug
- (str "Processing mark for term " ++ pr_idx_term state.uf t ++ str ".");
+ (fun () -> str "Processing mark for term " ++ pr_idx_term state.uf t ++ str ".");
let i=find state.uf t in
let rep=get_representative state.uf i in
match m with
@@ -794,7 +789,7 @@ let check_disequalities state =
else (str "No", check_aux q)
in
let _ = debug
- (str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++
+ (fun () -> str "Checking if " ++ pr_idx_term state.uf dis.lhs ++ str " = " ++
pr_idx_term state.uf dis.rhs ++ str " ... " ++ info) in
ans
| [] -> None
@@ -824,7 +819,7 @@ let __eps__ = Id.of_string "_eps_"
let new_state_var typ state =
let id = pf_get_new_id __eps__ state.gls in
let {it=gl ; sigma=sigma} = state.gls in
- let gls = Goal.V82.new_goal_with sigma gl [id,None,typ] in
+ let gls = Goal.V82.new_goal_with sigma gl [Context.Named.Declaration.LocalAssum (id,typ)] in
state.gls<- gls;
id
@@ -979,7 +974,7 @@ let find_instances state =
let pb_stack= init_pb_stack state in
let res =ref [] in
let _ =
- debug (str "Running E-matching algorithm ... ");
+ debug (fun () -> str "Running E-matching algorithm ... ");
try
while true do
Control.check_for_interrupt ();
@@ -990,7 +985,7 @@ let find_instances state =
!res
let rec execute first_run state =
- debug (str "Executing ... ");
+ debug (fun () -> str "Executing ... ");
try
while
Control.check_for_interrupt ();
@@ -1000,7 +995,7 @@ let rec execute first_run state =
None ->
if not(Int.Set.is_empty state.pa_classes) then
begin
- debug (str "First run was incomplete, completing ... ");
+ debug (fun () -> str "First run was incomplete, completing ... ");
complete state;
execute false state
end
@@ -1015,12 +1010,12 @@ let rec execute first_run state =
end
else
begin
- debug (str "Out of instances ... ");
+ debug (fun () -> str "Out of instances ... ");
None
end
else
begin
- debug (str "Out of depth ... ");
+ debug (fun () -> str "Out of depth ... ");
None
end
| Some dis -> Some
diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli
index b73c8eef..c7fa2f56 100644
--- a/plugins/cc/ccalgo.mli
+++ b/plugins/cc/ccalgo.mli
@@ -120,7 +120,7 @@ val term_equal : term -> term -> bool
val constr_of_term : term -> constr
-val debug : Pp.std_ppcmds -> unit
+val debug : (unit -> Pp.std_ppcmds) -> unit
val forest : state -> forest
diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml
index c188bf3b..f58847ca 100644
--- a/plugins/cc/ccproof.ml
+++ b/plugins/cc/ccproof.ml
@@ -9,7 +9,7 @@
(* This file uses the (non-compressed) union-find structure to generate *)
(* proof-trees that will be transformed into proof-terms in cctac.ml4 *)
-open Errors
+open CErrors
open Term
open Ccalgo
open Pp
@@ -93,13 +93,13 @@ let pinject p c n a =
p_rule=Inject(p,c,n,a)}
let rec equal_proof uf i j=
- debug (str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+ debug (fun () -> str "equal_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
if i=j then prefl (term uf i) else
let (li,lj)=join_path uf i j in
ptrans (path_proof uf i li) (psym (path_proof uf j lj))
and edge_proof uf ((i,j),eq)=
- debug (str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+ debug (fun () -> str "edge_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
let pi=equal_proof uf i eq.lhs in
let pj=psym (equal_proof uf j eq.rhs) in
let pij=
@@ -115,7 +115,7 @@ and edge_proof uf ((i,j),eq)=
ptrans (ptrans pi pij) pj
and constr_proof uf i ipac=
- debug (str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20));
+ debug (fun () -> str "constr_proof " ++ pr_idx_term uf i ++ brk (1,20));
let t=find_oldest_pac uf i ipac in
let eq_it=equal_proof uf i t in
if ipac.args=[] then
@@ -128,20 +128,20 @@ and constr_proof uf i ipac=
ptrans eq_it (pcongr p (prefl targ))
and path_proof uf i l=
- debug (str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++
+ debug (fun () -> str "path_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ str "{" ++
(prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}");
match l with
| [] -> prefl (term uf i)
| x::q->ptrans (path_proof uf (snd (fst x)) q) (edge_proof uf x)
and congr_proof uf i j=
- debug (str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+ debug (fun () -> str "congr_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
let (i1,i2) = subterms uf i
and (j1,j2) = subterms uf j in
pcongr (equal_proof uf i1 j1) (equal_proof uf i2 j2)
and ind_proof uf i ipac j jpac=
- debug (str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
+ debug (fun () -> str "ind_proof " ++ pr_idx_term uf i ++ brk (1,20) ++ pr_idx_term uf j);
let p=equal_proof uf i j
and p1=constr_proof uf i ipac
and p2=constr_proof uf j jpac in
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml
index 0baa5337..fd46d806 100644
--- a/plugins/cc/cctac.ml
+++ b/plugins/cc/cctac.ml
@@ -20,8 +20,10 @@ open Typing
open Ccalgo
open Ccproof
open Pp
-open Errors
+open CErrors
open Util
+open Proofview.Notations
+open Context.Rel.Declaration
let reference dir s = lazy (Coqlib.gen_reference "CC" dir s)
@@ -36,17 +38,17 @@ let _True = reference ["Init";"Logic"] "True"
let _I = reference ["Init";"Logic"] "I"
let whd env=
- let infos=Closure.create_clos_infos Closure.betaiotazeta env in
- (fun t -> Closure.whd_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos CClosure.betaiotazeta env in
+ (fun t -> CClosure.whd_val infos (CClosure.inject t))
let whd_delta env=
- let infos=Closure.create_clos_infos Closure.betadeltaiota env in
- (fun t -> Closure.whd_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos CClosure.all env in
+ (fun t -> CClosure.whd_val infos (CClosure.inject t))
(* decompose member of equality in an applicative format *)
(** FIXME: evar leak *)
-let sf_of env sigma c = sort_of env (ref sigma) c
+let sf_of env sigma c = e_sort_of env (ref sigma) c
let rec decompose_term env sigma t=
match kind_of_term (whd env t) with
@@ -80,8 +82,10 @@ let rec decompose_term env sigma t=
| Proj (p, c) ->
let canon_const kn = constant_of_kn (canonical_con kn) in
let p' = Projection.map canon_const p in
- (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c))
- | _ ->if closed0 t then (Symb t) else raise Not_found
+ (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c))
+ | _ ->
+ let t = strip_outer_cast t in
+ if closed0 t then Symb t else raise Not_found
(* decompose equality in members and type *)
open Globnames
@@ -151,7 +155,7 @@ let rec quantified_atom_of_constr env sigma nrels term =
let patts=patterns_of_constr env sigma nrels atom in
`Nrule patts
else
- quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma (succ nrels) ff
+ quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma (succ nrels) ff
| _ ->
let patts=patterns_of_constr env sigma nrels term in
`Rule patts
@@ -166,7 +170,7 @@ let litteral_of_constr env sigma term=
else
begin
try
- quantified_atom_of_constr (Environ.push_rel (id,None,atom) env) sigma 1 ff
+ quantified_atom_of_constr (Environ.push_rel (LocalAssum (id,atom)) env) sigma 1 ff
with Not_found ->
`Other (decompose_term env sigma term)
end
@@ -187,7 +191,8 @@ let make_prb gls depth additionnal_terms =
let t = decompose_term env sigma c in
ignore (add_term state t)) additionnal_terms;
List.iter
- (fun (id,_,e) ->
+ (fun decl ->
+ let (id,_,e) = Context.Named.Declaration.to_tuple decl in
begin
let cid=mkVar id in
match litteral_of_constr env sigma e with
@@ -220,24 +225,9 @@ let make_prb gls depth additionnal_terms =
(* indhyps builds the array of arrays of constructor hyps for (ind largs) *)
-let build_projection intype outtype (cstr:pconstructor) special default gls=
- let env=pf_env gls in
- let (h,argv) = try destApp intype with DestKO -> (intype,[||]) in
- let ind,u=destInd h in
- let types=Inductiveops.arities_of_constructors env (ind,u) in
- let lp=Array.length types in
- let ci=pred (snd(fst cstr)) in
- let branch i=
- let ti= prod_appvect types.(i) argv in
- let rc=fst (decompose_prod_assum ti) in
- let head=
- if Int.equal i ci then special else default in
- it_mkLambda_or_LetIn head rc in
- let branches=Array.init lp branch in
- let casee=mkRel 1 in
- let pred=mkLambda(Anonymous,intype,outtype) in
- let case_info=make_case_info (pf_env gls) ind RegularStyle in
- let body= mkCase(case_info, pred, casee, branches) in
+let build_projection intype (cstr:pconstructor) special default gls=
+ let ci= (snd(fst cstr)) in
+ let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in
let id=pf_get_new_id (Id.of_string "t") gls in
mkLambda(Name id,intype,body)
@@ -245,22 +235,34 @@ let build_projection intype outtype (cstr:pconstructor) special default gls=
let _M =mkMeta
-let app_global f args k =
+let app_global f args k =
Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args)))
-let new_app_global f args k =
+let new_app_global f args k =
Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args)))
let new_refine c = Proofview.V82.tactic (refine c)
let assert_before n c =
- Proofview.Goal.enter begin fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let evm, _ = Tacmach.New.pf_apply type_of gl c in
Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c)
- end
-
+ end }
+
+let refresh_type env evm ty =
+ Evarsolve.refresh_universes ~status:Evd.univ_flexible ~refreshset:true
+ (Some false) env evm ty
+
+let refresh_universes ty k =
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let env = Proofview.Goal.env gl in
+ let evm = Tacmach.New.project gl in
+ let evm, ty = refresh_type env evm ty in
+ Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k ty)
+ end }
+
let rec proof_tac p : unit Proofview.tactic =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let type_of t = Tacmach.New.pf_unsafe_type_of gl t in
try (* type_of can raise exceptions *)
match p.p_rule with
@@ -268,35 +270,31 @@ let rec proof_tac p : unit Proofview.tactic =
| SymAx c ->
let l=constr_of_term p.p_lhs and
r=constr_of_term p.p_rhs in
- let typ = (* Termops.refresh_universes *) type_of l in
- new_app_global _sym_eq [|typ;r;l;c|] exact_check
+ refresh_universes (type_of l) (fun typ ->
+ new_app_global _sym_eq [|typ;r;l;c|] exact_check)
| Refl t ->
let lr = constr_of_term t in
- let typ = (* Termops.refresh_universes *) type_of lr in
- new_app_global _refl_equal [|typ;constr_of_term t|] exact_check
+ refresh_universes (type_of lr) (fun typ ->
+ new_app_global _refl_equal [|typ;constr_of_term t|] exact_check)
| 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 = (* Termops.refresh_universes *) (type_of t2) in
+ refresh_universes (type_of t2) (fun typ ->
let prf = new_app_global _trans_eq [|typ;t1;t2;t3;_M 1;_M 2|] in
- Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)]
+ Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)])
| Congr (p1,p2)->
let tf1=constr_of_term p1.p_lhs
and tx1=constr_of_term p2.p_lhs
and tf2=constr_of_term p1.p_rhs
and tx2=constr_of_term p2.p_rhs in
- let typf = (* Termops.refresh_universes *)(type_of tf1) in
- let typx = (* Termops.refresh_universes *) (type_of tx1) in
- let typfx = (* Termops.refresh_universes *) (type_of (mkApp (tf1,[|tx1|]))) in
+ refresh_universes (type_of tf1) (fun typf ->
+ refresh_universes (type_of tx1) (fun typx ->
+ refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx ->
let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl in
let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in
- let lemma1 =
- app_global _f_equal
- [|typf;typfx;appx1;tf1;tf2;_M 1|] in
- let lemma2=
- app_global _f_equal
- [|typx;typfx;tf2;tx1;tx2;_M 1|] in
+ let lemma1 = app_global _f_equal [|typf;typfx;appx1;tf1;tf2;_M 1|] in
+ let lemma2 = app_global _f_equal [|typx;typfx;tf2;tx1;tx2;_M 1|] in
let prf =
app_global _trans_eq
[|typfx;
@@ -310,96 +308,89 @@ let rec proof_tac p : unit Proofview.tactic =
reflexivity;
Tacticals.New.tclZEROMSG
(Pp.str
- "I don't know how to handle dependent equality")]]
+ "I don't know how to handle dependent equality")]])))
| Inject (prf,cstr,nargs,argind) ->
let ti=constr_of_term prf.p_lhs in
let tj=constr_of_term prf.p_rhs in
let default=constr_of_term p.p_lhs in
- let intype = (* Termops.refresh_universes *) (type_of ti) in
- let outtype = (* Termops.refresh_universes *) (type_of default) in
let special=mkRel (1+nargs-argind) in
+ refresh_universes (type_of ti) (fun intype ->
+ refresh_universes (type_of default) (fun outtype ->
let proj =
- Tacmach.New.of_old (build_projection intype outtype cstr special default) gl
+ Tacmach.New.of_old (build_projection intype cstr special default) gl
in
let injt=
app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in
- Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf)
+ Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf)))
with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
+ end }
let refute_tac c t1 t2 p =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
- let intype =
- Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt1)) gl
- in
- let neweq= new_app_global _eq [|intype;tt1;tt2|] in
let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in
let false_t=mkApp (c,[|mkVar hid|]) in
+ let k intype =
+ let neweq= new_app_global _eq [|intype;tt1;tt2|] in
Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
[proof_tac p; simplest_elim false_t]
- end
+ in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k
+ end }
let refine_exact_check c gl =
let evm, _ = pf_apply type_of gl c in
Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl
let convert_to_goal_tac c t1 t2 p =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let tt1=constr_of_term t1 and tt2=constr_of_term t2 in
- let sort =
- Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt2)) gl
- in
- let neweq= new_app_global _eq [|sort;tt1;tt2|] in
- let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in
- let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in
- let identity=mkLambda (Name x,sort,mkRel 1) in
- let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in
+ let k sort =
+ let neweq= new_app_global _eq [|sort;tt1;tt2|] in
+ let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in
+ let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in
+ let identity=mkLambda (Name x,sort,mkRel 1) in
+ let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in
Tacticals.New.tclTHENS (neweq (assert_before (Name e)))
- [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]
- end
+ [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]
+ in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k
+ end }
let convert_to_hyp_tac c1 t1 c2 t2 p =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let tt2=constr_of_term t2 in
let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in
let false_t=mkApp (c2,[|mkVar h|]) in
Tacticals.New.tclTHENS (assert_before (Name h) tt2)
[convert_to_goal_tac c1 t1 t2 p;
simplest_elim false_t]
- end
+ end }
let discriminate_tac (cstr,u as cstru) p =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in
- let intype =
- Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls t1)) gl
- in
+ let env = Proofview.Goal.env gl in
let concl = Proofview.Goal.concl gl in
- (* let evm,outsort = Evd.new_sort_variable Evd.univ_rigid (project gls) in *)
- (* let outsort = mkSort outsort in *)
let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in
- (* let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in *)
- (* let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in *)
let identity = Universes.constr_of_global (Lazy.force _I) in
- (* let trivial=pf_unsafe_type_of gls identity in *)
let trivial = Universes.constr_of_global (Lazy.force _True) in
- let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in
+ let evm = Tacmach.New.project gl in
+ let evm, intype = refresh_type env evm (Tacmach.New.pf_unsafe_type_of gl t1) in
+ let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in
let outtype = mkSort outtype in
- let pred=mkLambda(Name xid,outtype,mkRel 1) in
+ let pred = mkLambda(Name xid,outtype,mkRel 1) in
let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in
- let proj = Tacmach.New.of_old (build_projection intype outtype cstru trivial concl) gl in
+ let proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in
let injt=app_global _f_equal
- [|intype;outtype;proj;t1;t2;mkVar hid|] in
+ [|intype;outtype;proj;t1;t2;mkVar hid|] in
let endt k =
injt (fun injt ->
- app_global _eq_rect
- [|outtype;trivial;pred;identity;concl;injt|] k) in
+ app_global _eq_rect
+ [|outtype;trivial;pred;identity;concl;injt|] k) in
let neweq=new_app_global _eq [|intype;t1;t2|] in
Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm)
- (Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
- [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)])
- end
+ (Tacticals.New.tclTHENS (neweq (assert_before (Name hid)))
+ [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)])
+ end }
(* wrap everything *)
@@ -411,18 +402,18 @@ let build_term_to_complete uf meta pac =
applistc (mkConstructU cinfo.ci_constr) all_args
let cc_tactic depth additionnal_terms =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
Coqlib.check_required_library Coqlib.logic_module_name;
- let _ = debug (Pp.str "Reading subgoal ...") in
+ let _ = debug (fun () -> Pp.str "Reading subgoal ...") in
let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in
- let _ = debug (Pp.str "Problem built, solving ...") in
+ let _ = debug (fun () -> Pp.str "Problem built, solving ...") in
let sol = execute true state in
- let _ = debug (Pp.str "Computation completed.") in
+ let _ = debug (fun () -> Pp.str "Computation completed.") in
let uf=forest state in
match sol with
None -> Tacticals.New.tclFAIL 0 (str "congruence failed")
| Some reason ->
- debug (Pp.str "Goal solved, generating proof ...");
+ debug (fun () -> Pp.str "Goal solved, generating proof ...");
match reason with
Discrimination (i,ipac,j,jpac) ->
let p=build_proof uf (`Discr (i,ipac,j,jpac)) in
@@ -436,10 +427,10 @@ let cc_tactic depth additionnal_terms =
List.map
(build_term_to_complete uf newmeta)
(epsilons uf) in
- Pp.msg_info
+ Feedback.msg_info
(Pp.str "Goal is solvable by congruence but \
some arguments are missing.");
- Pp.msg_info
+ Feedback.msg_info
(Pp.str " Try " ++
hov 8
begin
@@ -462,7 +453,7 @@ let cc_tactic depth additionnal_terms =
convert_to_goal_tac id ta tb p
| HeqnH (ida,idb) ->
convert_to_hyp_tac ida ta idb tb p
- end
+ end }
let cc_fail gls =
errorlabstrm "Congruence" (Pp.str "congruence failed.")
@@ -482,11 +473,10 @@ let congruence_tac depth l =
This isn't particularly related with congruence, apart from
the fact that congruence is called internally.
*)
-
+
let mk_eq f c1 c2 k =
Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc ->
- Proofview.Goal.enter begin
- fun gl ->
+ Proofview.Goal.enter { enter = begin fun gl ->
let open Tacmach.New in
let evm, ty = pf_apply type_of gl c1 in
let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in
@@ -494,10 +484,10 @@ let mk_eq f c1 c2 k =
let evm, _ = type_of (pf_env gl) evm term in
Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm))
(k term)
- end)
-
+ end })
+
let f_equal =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let cut_eq c1 c2 =
try (* type_of can raise an exception *)
@@ -523,4 +513,4 @@ let f_equal =
| Type_errors.TypeError _ -> Proofview.tclUNIT ()
| e -> Proofview.tclZERO ~info e
end
- end
+ end }
diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4
index 5dbc340c..52a13511 100644
--- a/plugins/cc/g_congruence.ml4
+++ b/plugins/cc/g_congruence.ml4
@@ -9,6 +9,8 @@
(*i camlp4deps: "grammar/grammar.cma" i*)
open Cctac
+open Stdarg
+open Constrarg
DECLARE PLUGIN "cc_plugin"
diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli
index 79ef3d18..29ecb94c 100644
--- a/plugins/decl_mode/decl_expr.mli
+++ b/plugins/decl_mode/decl_expr.mli
@@ -99,4 +99,4 @@ type proof_instr =
(Term.constr statement,
Term.constr,
proof_pattern,
- Tacexpr.glob_tactic_expr) gen_proof_instr
+ Geninterp.Val.t) gen_proof_instr
diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml
index 2a44dca2..a862423e 100644
--- a/plugins/decl_mode/decl_interp.ml
+++ b/plugins/decl_mode/decl_interp.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Constrexpr
@@ -96,7 +96,7 @@ let rec add_vars_of_simple_pattern globs = function
add_vars_of_simple_pattern globs p
| CPatCstr (_,_,pl1,pl2) ->
List.fold_left add_vars_of_simple_pattern
- (List.fold_left add_vars_of_simple_pattern globs pl1) pl2
+ (Option.fold_left (List.fold_left add_vars_of_simple_pattern) globs pl1) pl2
| CPatNotation(_,_,(pl,pll),pl') ->
List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pl'::pll))
| CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs
@@ -153,8 +153,8 @@ let interp_constr check_sort env sigma c =
fst (understand env sigma (fst c))
let special_whd env =
- let infos=Closure.create_clos_infos Closure.betadeltaiota env in
- (fun t -> Closure.whd_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos CClosure.all env in
+ (fun t -> CClosure.whd_val infos (CClosure.inject t))
let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq))
@@ -384,7 +384,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps =
let interp_cut interp_it env sigma cut=
let nenv,nstat = interp_it env sigma cut.cut_stat in
- {cut with
+ { cut_using=Option.map (Tacinterp.Value.of_closure (Tacinterp.default_ist ())) cut.cut_using;
cut_stat=nstat;
cut_by=interp_justification_items nenv sigma cut.cut_by}
@@ -403,7 +403,7 @@ let interp_suffices_clause env sigma (hyps,cot)=
match hyp with
(Hprop st | Hvar st) ->
match st.st_label with
- Name id -> Environ.push_named (id,None,st.st_it) env0
+ Name id -> Environ.push_named (Context.Named.Declaration.LocalAssum (id,st.st_it)) env0
| _ -> env in
let nenv = List.fold_right push_one locvars env in
nenv,res
diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml
index acee3d6c..92d40890 100644
--- a/plugins/decl_mode/decl_mode.ml
+++ b/plugins/decl_mode/decl_mode.ml
@@ -9,7 +9,7 @@
open Names
open Term
open Evd
-open Errors
+open CErrors
open Util
let daimon_flag = ref false
@@ -116,7 +116,7 @@ let get_top_stack pts =
let get_stack pts = Proof.get_at_focus proof_focus pts
let get_last env = match Environ.named_context env with
- | (id,_,_)::_ -> id
+ | decl :: _ -> Context.Named.Declaration.get_id decl
| [] -> error "no previous statement to use"
diff --git a/plugins/decl_mode/decl_mode_plugin.mllib b/plugins/decl_mode/decl_mode_plugin.mlpack
index 39342dbd..1b84a079 100644
--- a/plugins/decl_mode/decl_mode_plugin.mllib
+++ b/plugins/decl_mode/decl_mode_plugin.mlpack
@@ -3,4 +3,3 @@ Decl_interp
Decl_proof_instr
Ppdecl_proof
G_decl_mode
-Decl_mode_plugin_mod
diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml
index ba9fb728..d30fcf60 100644
--- a/plugins/decl_mode/decl_proof_instr.ml
+++ b/plugins/decl_mode/decl_proof_instr.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Pp
open Evd
@@ -29,9 +29,27 @@ open Termops
open Namegen
open Goptions
open Misctypes
+open Sigma.Notations
+open Context.Named.Declaration
(* Strictness option *)
+let clear ids { it = goal; sigma } =
+ let ids = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty ids in
+ let env = Goal.V82.env sigma goal in
+ let sign = Goal.V82.hyps sigma goal in
+ let cl = Goal.V82.concl sigma goal in
+ let evdref = ref (Evd.clear_metas sigma) in
+ let (hyps, concl) =
+ try Evarutil.clear_hyps_in_evi env evdref sign cl ids
+ with Evarutil.ClearDependencyError (id, _) ->
+ errorlabstrm "" (str "Cannot clear " ++ pr_id id)
+ in
+ let sigma = !evdref in
+ let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in
+ let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
+ { it = [gl]; sigma }
+
let get_its_info gls = get_info gls.sigma gls.it
let get_strictness,set_strictness =
@@ -42,7 +60,7 @@ let _ =
declare_bool_option
{ optsync = true;
optdepr = false;
- optname = "strict mode";
+ optname = "strict proofs";
optkey = ["Strict";"Proofs"];
optread = get_strictness;
optwrite = set_strictness }
@@ -66,12 +84,12 @@ let tcl_erase_info gls =
tcl_change_info_gen info_gen gls
let special_whd gl=
- let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
- (fun t -> Closure.whd_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in
+ (fun t -> CClosure.whd_val infos (CClosure.inject t))
let special_nf gl=
- let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
- (fun t -> Closure.norm_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in
+ (fun t -> CClosure.norm_val infos (CClosure.inject t))
let is_good_inductive env ind =
let mib,oib = Inductive.lookup_mind_specif env ind in
@@ -86,7 +104,7 @@ Please \"suppose\" something or \"end\" it now."
| _ -> ()
let mk_evd metalist gls =
- let evd0= create_goal_evar_defs (sig_sig gls) in
+ let evd0= clear_metas (sig_sig gls) in
let add_one (meta,typ) evd =
meta_declare meta typ evd in
List.fold_right add_one metalist evd0
@@ -151,7 +169,7 @@ let do_daimon () =
daimon_instr env p
end
in
- if not status then Pp.feedback Feedback.AddedAxiom else ()
+ if not status then Feedback.feedback Feedback.AddedAxiom else ()
(* post-instruction focus management *)
@@ -228,7 +246,8 @@ let close_previous_case pts =
(* automation *)
let filter_hyps f gls =
- let filter_aux (id,_,_) =
+ let filter_aux id =
+ let id = get_id id in
if f id then
tclIDTAC
else
@@ -258,12 +277,16 @@ let prepare_goal items gls =
filter_hyps (let keep = !tokeep in fun id -> Id.Set.mem id keep)] gls
let my_automation_tac = ref
- (Proofview.tclZERO (Errors.make_anomaly (Pp.str"No automation registered")))
+ (Proofview.tclZERO (CErrors.make_anomaly (Pp.str"No automation registered")))
let register_automation_tac tac = my_automation_tac:= tac
let automation_tac = Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> !my_automation_tac)
+let warn_insufficient_justification =
+ CWarnings.create ~name:"declmode-insufficient-justification" ~category:"declmode"
+ (fun () -> strbrk "Insufficient justification.")
+
let justification tac gls=
tclORELSE
(tclSOLVE [tclTHEN tac (Proofview.V82.of_tactic assumption)])
@@ -272,7 +295,7 @@ let justification tac gls=
error "Insufficient justification."
else
begin
- msg_warning (str "Insufficient justification.");
+ warn_insufficient_justification ();
daimon_tac gls
end) gls
@@ -330,11 +353,12 @@ let enstack_subsubgoals env se stack gls=
let rc,_ = Reduction.dest_prod env apptype in
let rec meta_aux last lenv = function
[] -> (last,lenv,[])
- | (nam,_,typ)::q ->
+ | decl::q ->
let nlast=succ last in
let (llast,holes,metas) =
meta_aux nlast (mkMeta nlast :: lenv) q in
- (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in
+ let open Context.Rel.Declaration in
+ (llast,holes,(nlast,special_nf gls (substl lenv (get_type decl)))::metas) in
let (nlast,holes,nmetas) =
meta_aux se.se_last_meta [] (List.rev rc) in
let refiner = applist (appterm,List.rev holes) in
@@ -391,7 +415,7 @@ let find_subsubgoal c ctyp skip submetas gls =
se.se_meta submetas se.se_meta_list}
else
dfs (pred n)
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
begin
enstack_subsubgoals env se stack gls;
dfs n
@@ -403,15 +427,15 @@ let concl_refiner metas body gls =
let concl = pf_concl gls in
let evd = sig_sig gls in
let env = pf_env gls in
- let sort = family_of_sort (Typing.sort_of env (ref evd) concl) in
+ let sort = family_of_sort (Typing.e_sort_of env (ref evd) concl) in
let rec aux env avoid subst = function
[] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen")
| (n,typ)::rest ->
let _A = subst_meta subst typ in
let x = id_of_name_using_hdchar env _A Anonymous in
let _x = fresh_id avoid x gls in
- let nenv = Environ.push_named (_x,None,_A) env in
- let asort = family_of_sort (Typing.sort_of nenv (ref evd) _A) in
+ let nenv = Environ.push_named (LocalAssum (_x,_A)) env in
+ let asort = family_of_sort (Typing.e_sort_of nenv (ref evd) _A) in
let nsubst = (n,mkVar _x)::subst in
if List.is_empty rest then
asort,_A,mkNamedLambda _x _A (subst_meta nsubst body)
@@ -465,7 +489,7 @@ let thus_tac c ctyp submetas gls =
Proofview.V82.of_tactic (exact_check proof) gls
else
let refiner = concl_refiner list proof gls in
- Tactics.refine refiner gls
+ Tacmach.refine refiner gls
(* general forward step *)
@@ -492,7 +516,7 @@ let just_tac _then cut info gls0 =
None ->
Proofview.V82.of_tactic automation_tac gls
| Some tac ->
- Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in
+ Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in
justification (tclTHEN items_tac method_tac) gls0
let instr_cut mkstat _thus _then cut gls0 =
@@ -542,7 +566,7 @@ let instr_rew _thus rew_side cut gls0 =
None ->
Proofview.V82.of_tactic automation_tac gls
| Some tac ->
- Proofview.V82.of_tactic (Tacinterp.eval_tactic tac) gls in
+ Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in
let just_tac gls =
justification (tclTHEN items_tac method_tac) gls in
let (c_id,_) = match cut.cut_stat.st_label with
@@ -605,7 +629,7 @@ let assume_tac hyps gls =
tclTHEN
(push_intro_tac
(fun id ->
- Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label))
+ Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label))
hyps tclIDTAC gls
let assume_hyps_or_theses hyps gls =
@@ -615,7 +639,7 @@ let assume_hyps_or_theses hyps gls =
tclTHEN
(push_intro_tac
(fun id ->
- Proofview.V82.of_tactic (convert_hyp (id,None,c))) nam)
+ Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,c)))) nam)
| Hprop {st_label=nam;st_it=Thesis (tk)} ->
tclTHEN
(push_intro_tac
@@ -627,7 +651,7 @@ let assume_st hyps gls =
(fun st ->
tclTHEN
(push_intro_tac
- (fun id -> Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it))) st.st_label))
+ (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label))
hyps tclIDTAC gls
let assume_st_letin hyps gls =
@@ -636,7 +660,7 @@ let assume_st_letin hyps gls =
tclTHEN
(push_intro_tac
(fun id ->
- Proofview.V82.of_tactic (convert_hyp (id,Some (fst st.st_it),snd st.st_it))) st.st_label))
+ Proofview.V82.of_tactic (convert_hyp (LocalDef (id, fst st.st_it, snd st.st_it)))) st.st_label))
hyps tclIDTAC gls
(* suffices *)
@@ -730,7 +754,7 @@ let rec consider_match may_intro introduced available expected gls =
error "Not enough sub-hypotheses to match statements."
(* should tell which ones *)
| id::rest_ids,(Hvar st | Hprop st)::rest ->
- tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (id,None,st.st_it)))
+ tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it))))
begin
match st.st_label with
Anonymous ->
@@ -798,8 +822,8 @@ let define_tac id args body gls =
let cast_tac id_or_thesis typ gls =
match id_or_thesis with
This id ->
- let (_,body,_) = pf_get_hyp gls id in
- Proofview.V82.of_tactic (convert_hyp (id,body,typ)) gls
+ let body = pf_get_hyp gls id |> get_value in
+ Proofview.V82.of_tactic (convert_hyp (of_tuple (id,body,typ))) gls
| Thesis (For _ ) ->
error "\"thesis for ...\" is not applicable here."
| Thesis Plain ->
@@ -1199,6 +1223,9 @@ let hrec_for fix_id per_info gls obj_id =
let hd2 = applist (mkVar fix_id,args@[obj]) in
compose_lam rc (Reductionops.whd_beta gls.sigma hd2)
+let warn_missing_case =
+ CWarnings.create ~name:"declmode-missing-case" ~category:"declmode"
+ (fun () -> strbrk "missing case")
let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
match tree, objs with
@@ -1269,12 +1296,12 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls =
(fun id ->
hrec_for (out_name fix_name) per_info gls1 id)
recs in
- generalize hrecs gls1
+ Proofview.V82.of_tactic (generalize hrecs) gls1
end;
match bro with
None ->
- msg_warning (str "missing case");
- tacnext (mkMeta 1)
+ warn_missing_case ();
+ tacnext (mkMeta 1)
| Some (sub_ids,tree) ->
let br_args =
List.filter
@@ -1305,7 +1332,11 @@ let understand_my_constr env sigma c concl =
Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc)
let my_refine c gls =
- let oc sigma = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in
+ let oc = { run = begin fun sigma ->
+ let sigma = Sigma.to_evar_map sigma in
+ let (sigma, c) = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in
+ Sigma.Unsafe.of_pair (c, sigma)
+ end } in
Proofview.V82.of_tactic (Tactics.New.refine oc) gls
(* end focus/claim *)
@@ -1341,7 +1372,7 @@ let end_tac et2 gls =
(default_justification (List.map mkVar clauses))
| ET_Induction,EK_nodep ->
tclTHENLIST
- [generalize (pi.per_args@[pi.per_casee]);
+ [Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee]));
Proofview.V82.of_tactic (simple_induct (AnonHyp (succ (List.length pi.per_args))));
default_justification (List.map mkVar clauses)]
| ET_Case_analysis,EK_dep tree ->
@@ -1353,7 +1384,7 @@ let end_tac et2 gls =
(initial_instance_stack clauses) [pi.per_casee] 0 tree
| ET_Induction,EK_dep tree ->
let nargs = (List.length pi.per_args) in
- tclTHEN (generalize (pi.per_args@[pi.per_casee]))
+ tclTHEN (Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee])))
begin
fun gls0 ->
let fix_id =
@@ -1361,7 +1392,7 @@ let end_tac et2 gls =
let c_id =
pf_get_new_id (Id.of_string "_main_arg") gls0 in
tclTHENLIST
- [fix (Some fix_id) (succ nargs);
+ [Proofview.V82.of_tactic (fix (Some fix_id) (succ nargs));
tclDO nargs (Proofview.V82.of_tactic introf);
Proofview.V82.of_tactic (intro_mustbe_force c_id);
execute_cases (Name fix_id) pi
diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4
index b62cfd6a..6c17dcc4 100644
--- a/plugins/decl_mode/g_decl_mode.ml4
+++ b/plugins/decl_mode/g_decl_mode.ml4
@@ -8,7 +8,8 @@
(*i camlp4deps: "grammar/grammar.cma" i*)
-open Util
+DECLARE PLUGIN "decl_mode_plugin"
+
open Compat
open Pp
open Decl_expr
@@ -24,17 +25,14 @@ open Ppdecl_proof
let pr_goal gs =
let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in
let env = Goal.V82.env sigma g in
- let preamb,thesis,penv,pc =
- (str " *** Declarative Mode ***" ++ fnl ()++fnl ()),
- (str "thesis := " ++ fnl ()),
- Printer.pr_context_of env sigma,
- Printer.pr_goal_concl_style_env env sigma (Goal.V82.concl sigma g)
- in
- preamb ++
- str" " ++ hv 0 (penv ++ fnl () ++
- str (Printer.emacs_str "") ++
- str "============================" ++ fnl () ++
- thesis ++ str " " ++ pc) ++ fnl ()
+ let concl = Goal.V82.concl sigma g in
+ let goal =
+ Printer.pr_context_of env sigma ++ cut () ++
+ str "============================" ++ cut () ++
+ str "thesis :=" ++ cut () ++
+ Printer.pr_goal_concl_style_env env sigma concl in
+ str " *** Declarative Mode ***" ++ fnl () ++ fnl () ++
+ str " " ++ v 0 goal
let pr_subgoals ?(pr_first=true) _ sigma _ _ _ gll =
match gll with
@@ -60,7 +58,7 @@ let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }=
let vernac_decl_proof () =
let pf = Proof_global.give_me_the_proof () in
if Proof.is_done pf then
- Errors.error "Nothing left to prove here."
+ CErrors.error "Nothing left to prove here."
else
begin
Decl_proof_instr.go_to_proof_mode () ;
@@ -87,7 +85,7 @@ let vernac_proof_instr instr =
(* Only declared at raw level, because only used in vernac commands. *)
let wit_proof_instr : (raw_proof_instr, glob_proof_instr, proof_instr) Genarg.genarg_type =
- Genarg.make0 None "proof_instr"
+ Genarg.make0 "proof_instr"
(* We create a new parser entry [proof_mode]. The Declarative proof mode
will replace the normal parser entry for tactics with this one. *)
@@ -95,14 +93,14 @@ let proof_mode : vernac_expr Gram.entry =
Gram.entry_create "vernac:proof_command"
(* Auxiliary grammar entry. *)
let proof_instr : raw_proof_instr Gram.entry =
- Pcoq.create_generic_entry "proof_instr" (Genarg.rawwit wit_proof_instr)
+ Pcoq.create_generic_entry Pcoq.utactic "proof_instr" (Genarg.rawwit wit_proof_instr)
let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr
pr_raw_proof_instr pr_glob_proof_instr pr_proof_instr
let classify_proof_instr = function
| { instr = Pescape |Pend B_proof } -> VtProofMode "Classic", VtNow
- | _ -> VtProofStep false, VtLater
+ | _ -> Vernac_classifier.classify_as_proofstep
(* We use the VERNAC EXTEND facility with a custom non-terminal
to populate [proof_mode] with a new toplevel interpreter.
@@ -135,7 +133,7 @@ let _ =
set = begin fun () ->
(* We set the command non terminal to
[proof_mode] (which we just defined). *)
- G_vernac.set_command_entry proof_mode ;
+ Pcoq.set_command_entry proof_mode ;
(* We substitute the goal printer, by the one we built
for the proof mode. *)
Printer.set_printer_pr { Printer.default_printer_pr with
@@ -147,7 +145,7 @@ let _ =
reset = begin fun () ->
(* We restore the command non terminal to
[noedit_mode]. *)
- G_vernac.set_command_entry G_vernac.noedit_mode ;
+ Pcoq.set_command_entry Pcoq.Vernac_.noedit_mode ;
(* We restore the goal printer to default *)
Printer.set_printer_pr Printer.default_printer_pr
end
diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml
index 4c71f041..59a0bb5a 100644
--- a/plugins/decl_mode/ppdecl_proof.ml
+++ b/plugins/decl_mode/ppdecl_proof.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Pp
open Decl_expr
open Names
diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml
index ce93c5a3..e39d17b5 100644
--- a/plugins/derive/derive.ml
+++ b/plugins/derive/derive.ml
@@ -6,6 +6,8 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+open Context.Named.Declaration
+
let map_const_entry_body (f:Term.constr->Term.constr) (x:Safe_typing.private_constants Entries.const_entry_body)
: Safe_typing.private_constants Entries.const_entry_body =
Future.chain ~pure:true x begin fun ((b,ctx),fx) ->
@@ -32,7 +34,7 @@ let start_deriving f suchthat lemma =
let open Proofview in
TCons ( env , sigma , f_type_type , (fun sigma f_type ->
TCons ( env , sigma , f_type , (fun sigma ef ->
- let env' = Environ.push_named (f , (Some ef) , f_type) env in
+ let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in
let evdref = ref sigma in
let suchthat = Constrintern.interp_type_evars env' evdref suchthat in
TCons ( env' , !evdref , suchthat , (fun sigma _ ->
@@ -49,9 +51,9 @@ let start_deriving f suchthat lemma =
[suchthat], respectively. *)
let (opaque,f_def,lemma_def) =
match com with
- | Admitted _ -> Errors.error"Admitted isn't supported in Derive."
+ | Admitted _ -> CErrors.error"Admitted isn't supported in Derive."
| Proved (_,Some _,_) ->
- Errors.error"Cannot save a proof of Derive with an explicit name."
+ CErrors.error"Cannot save a proof of Derive with an explicit name."
| Proved (opaque, None, obj) ->
match Proof_global.(obj.entries) with
| [_;f_def;lemma_def] ->
@@ -93,6 +95,7 @@ let start_deriving f suchthat lemma =
ignore (Declare.declare_constant lemma lemma_def)
in
+ let terminator = Proof_global.make_terminator terminator in
let () = Proof_global.start_dependent_proof lemma kind goals terminator in
let _ = Proof_global.with_current_proof begin fun _ p ->
Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p
diff --git a/plugins/derive/derive_plugin.mllib b/plugins/derive/derive_plugin.mlpack
index 5ee0fc6d..5ee0fc6d 100644
--- a/plugins/derive/derive_plugin.mllib
+++ b/plugins/derive/derive_plugin.mlpack
diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4
index 18570a68..d4dc7e0e 100644
--- a/plugins/derive/g_derive.ml4
+++ b/plugins/derive/g_derive.ml4
@@ -6,8 +6,12 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+open Constrarg
+
(*i camlp4deps: "grammar/grammar.cma" i*)
+DECLARE PLUGIN "derive_plugin"
+
let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater)
VERNAC COMMAND EXTEND Derive CLASSIFIED BY classify_derive_command
diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v
index 9a1a4aa0..c9e8eac0 100644
--- a/plugins/extraction/ExtrOcamlZBigInt.v
+++ b/plugins/extraction/ExtrOcamlZBigInt.v
@@ -46,7 +46,7 @@ Extract Constant Pos.max => "Big.max".
Extract Constant Pos.compare =>
"fun x y -> Big.compare_case Eq Lt Gt x y".
Extract Constant Pos.compare_cont =>
- "fun x y c -> Big.compare_case c Lt Gt x y".
+ "fun c x y -> Big.compare_case c Lt Gt x y".
Extract Constant N.add => "Big.add".
Extract Constant N.succ => "Big.succ".
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index bb9e8e5f..3c5f6cb7 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -17,8 +17,8 @@ open Table
open Miniml
open Mlutil
-let string_of_id id =
- let s = Names.Id.to_string id in
+let ascii_of_id id =
+ let s = Id.to_string id in
for i = 0 to String.length s - 2 do
if s.[i] == '_' && s.[i+1] == '_' then warning_id s
done;
@@ -73,18 +73,19 @@ let fnl2 () = fnl () ++ fnl ()
let space_if = function true -> str " " | false -> mt ()
-let is_digit = function
- | '0'..'9' -> true
- | _ -> false
+let begins_with s prefix =
+ let len = String.length prefix in
+ String.length s >= len && String.equal (String.sub s 0 len) prefix
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
+ match s.[!i] with
+ | '_' -> i:=n (*Stop*)
+ | '0'..'9' -> incr i
+ | _ -> raise Not_found
done; true
with Not_found -> false
@@ -109,9 +110,9 @@ let pseudo_qualify = qualify "__"
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 lowercase_id id = Id.of_string (String.uncapitalize (ascii_of_id id))
let uppercase_id id =
- let s = string_of_id id in
+ let s = ascii_of_id id in
assert (not (String.is_empty s));
if s.[0] == '_' then Id.of_string ("Coq_"^s)
else Id.of_string (String.capitalize s)
@@ -331,13 +332,10 @@ let reset_renaming_tables flag =
existing. *)
let modular_rename k id =
- let s = string_of_id id in
- let prefix,is_ok =
- if upperkind k then "Coq_",is_upper else "coq_",is_lower
+ let s = ascii_of_id id in
+ let prefix,is_ok = if upperkind k then "Coq_",is_upper else "coq_",is_lower
in
- if not (is_ok s) ||
- (Id.Set.mem id (get_keywords ())) ||
- (String.length s >= 4 && String.equal (String.sub s 0 4) prefix)
+ if not (is_ok s) || Id.Set.mem id (get_keywords ()) || begins_with s prefix
then prefix ^ s
else s
@@ -345,21 +343,20 @@ let modular_rename k id =
with unique numbers *)
let modfstlev_rename =
- let add_prefixes,get_prefixes,_ = mktable_id true in
+ let add_index,get_index,_ = mktable_id true in
fun l ->
- let coqid = Id.of_string "Coq" in
let id = Label.to_id l in
try
- let coqset = get_prefixes id in
- let nextcoq = next_ident_away coqid coqset in
- add_prefixes id (nextcoq::coqset);
- (string_of_id nextcoq)^"_"^(string_of_id id)
+ let n = get_index id in
+ add_index id (n+1);
+ let s = if n == 0 then "" else string_of_int (n-1) in
+ "Coq"^s^"_"^(ascii_of_id id)
with Not_found ->
- let s = string_of_id id in
+ let s = ascii_of_id id in
if is_lower s || begins_with_CoqXX s then
- (add_prefixes id [coqid]; "Coq_"^s)
+ (add_index id 1; "Coq_"^s)
else
- (add_prefixes id []; s)
+ (add_index id 0; s)
(*s Creating renaming for a [module_path] : first, the real function ... *)
@@ -404,7 +401,7 @@ let ref_renaming_fun (k,r) =
| [""] -> (* this happens only at toplevel of the monolithic case *)
let globs = Id.Set.elements (get_global_ids ()) in
let id = next_ident_away (kindcase_id k idg) globs in
- string_of_id id
+ Id.to_string id
| _ -> modular_rename k idg
in
add_global_ids (Id.of_string s);
@@ -562,7 +559,7 @@ let pp_ocaml_extern k base rls = match rls with
(* Standard situation : object in an opened file *)
dottify rls'
-(* [pp_ocaml_gen] : choosing between [pp_ocaml_extern] or [pp_ocaml_extern] *)
+(* [pp_ocaml_gen] : choosing between [pp_ocaml_local] or [pp_ocaml_extern] *)
let pp_ocaml_gen k mp rls olab =
match common_prefix_from_list mp (get_visible_mps ()) with
@@ -579,8 +576,7 @@ let pp_haskell_gen k mp rls = match rls with
| s::rls' ->
let str = pseudo_qualify rls' in
let str = if is_upper str && not (upperkind k) then ("_"^str) else str in
- let prf = if not (ModPath.equal (base_mp mp) (top_visible_mp ())) then s ^ "." else "" in
- prf ^ str
+ if ModPath.equal (base_mp mp) (top_visible_mp ()) then str else s^"."^str
(* Main name printing function for a reference *)
diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml
index 41a068ff..52f22ee6 100644
--- a/plugins/extraction/extract_env.ml
+++ b/plugins/extraction/extract_env.ml
@@ -13,13 +13,12 @@ open Names
open Libnames
open Globnames
open Pp
-open Errors
+open CErrors
open Util
open Table
open Extraction
open Modutil
open Common
-open Mod_subst
(***************************************)
(*S Part I: computing Coq environment. *)
@@ -542,7 +541,7 @@ let print_structure_to_file (fn,si,mo) dry struc =
(if dry then None else si);
(* Print the buffer content via Coq standard formatter (ok with coqide). *)
if not (Int.equal (Buffer.length buf) 0) then begin
- Pp.msg_notice (str (Buffer.contents buf));
+ Feedback.msg_notice (str (Buffer.contents buf));
Buffer.reset buf
end
@@ -584,8 +583,8 @@ let rec locate_ref = function
| None, Some r -> let refs,mps = locate_ref l in r::refs,mps
| Some mp, None -> let refs,mps = locate_ref l in refs,mp::mps
| Some mp, Some r ->
- warning_both_mod_and_cst q mp r;
- let refs,mps = locate_ref l in refs,mp::mps
+ warning_ambiguous_name (q,mp,r);
+ let refs,mps = locate_ref l in refs,mp::mps
(*s Recursive extraction in the Coq toplevel. The vernacular command is
\verb!Recursive Extraction! [qualid1] ... [qualidn]. Also used when
@@ -636,7 +635,7 @@ let simple_extraction r =
in
let ans = flag ++ print_one_decl struc (modpath_of_r r) d in
reset ();
- Pp.msg_notice ans
+ Feedback.msg_notice ans
| _ -> assert false
diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml
index 10644da2..a980a43f 100644
--- a/plugins/extraction/extraction.ml
+++ b/plugins/extraction/extraction.ml
@@ -11,7 +11,6 @@ open Util
open Names
open Term
open Vars
-open Context
open Declarations
open Declareops
open Environ
@@ -26,6 +25,7 @@ open Globnames
open Miniml
open Table
open Mlutil
+open Context.Rel.Declaration
(*i*)
exception I of inductive_kind
@@ -35,17 +35,18 @@ let current_fixpoints = ref ([] : constant list)
let none = Evd.empty
+(* NB: In OCaml, [type_of] and [get_of] might raise
+ [SingletonInductiveBecomeProp]. This exception will be caught
+ in late wrappers around the exported functions of this file,
+ in order to display the location of the issue. *)
+
let type_of env c =
- try
- let polyprop = (lang() == Haskell) in
- Retyping.get_type_of ~polyprop env none (strip_outer_cast c)
- with SingletonInductiveBecomesProp id -> error_singleton_become_prop id
+ let polyprop = (lang() == Haskell) in
+ Retyping.get_type_of ~polyprop env none (strip_outer_cast c)
let sort_of env c =
- try
- let polyprop = (lang() == Haskell) in
- Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c)
- with SingletonInductiveBecomesProp id -> error_singleton_become_prop id
+ let polyprop = (lang() == Haskell) in
+ Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c)
(*S Generation of flags and signatures. *)
@@ -73,9 +74,9 @@ type flag = info * scheme
Really important function. *)
let rec flag_of_type env t : flag =
- let t = whd_betadeltaiota env none t in
+ let t = whd_all env none t in
match kind_of_term t with
- | Prod (x,t,c) -> flag_of_type (push_rel (x,None,t) env) c
+ | Prod (x,t,c) -> flag_of_type (push_rel (LocalAssum (x,t)) env) c
| Sort s when Sorts.is_prop s -> (Logic,TypeScheme)
| Sort _ -> (Info,TypeScheme)
| _ -> if (sort_of env t) == InProp then (Logic,Default) else (Info,Default)
@@ -101,14 +102,14 @@ let is_info_scheme env t = match flag_of_type env t with
(*s [type_sign] gernerates a signature aimed at treating a type application. *)
let rec type_sign env c =
- match kind_of_term (whd_betadeltaiota env none c) with
+ match kind_of_term (whd_all env none c) with
| Prod (n,t,d) ->
(if is_info_scheme env t then Keep else Kill Kprop)
:: (type_sign (push_rel_assum (n,t) env) d)
| _ -> []
let rec type_scheme_nb_args env c =
- match kind_of_term (whd_betadeltaiota env none c) with
+ match kind_of_term (whd_all env none c) with
| Prod (n,t,d) ->
let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in
if is_info_scheme env t then n+1 else n
@@ -134,7 +135,7 @@ let make_typvar n vl =
next_ident_away id' vl
let rec type_sign_vl env c =
- match kind_of_term (whd_betadeltaiota env none c) with
+ match kind_of_term (whd_all env none c) with
| Prod (n,t,d) ->
let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in
if not (is_info_scheme env t) then Kill Kprop::s, vl
@@ -142,7 +143,7 @@ let rec type_sign_vl env c =
| _ -> [],[]
let rec nb_default_params env c =
- match kind_of_term (whd_betadeltaiota env none c) with
+ match kind_of_term (whd_all env none c) with
| Prod (n,t,d) ->
let n = nb_default_params (push_rel_assum (n,t) env) d in
if is_default env t then n+1 else n
@@ -248,7 +249,7 @@ let rec extract_type env db j c args =
| _ when sort_of env (applist (c, args)) == InProp -> Tdummy Kprop
| Rel n ->
(match lookup_rel n env with
- | (_,Some t,_) -> extract_type env db j (lift n t) args
+ | LocalDef (_,t,_) -> extract_type env db j (lift n t) args
| _ ->
(* Asks [db] a translation for [n]. *)
if n > List.length db then Tunknown
@@ -285,7 +286,7 @@ let rec extract_type env db j c args =
| Ind ((kn,i),u) ->
let s = (extract_ind env kn).ind_packets.(i).ip_sign in
extract_type_app env db (IndRef (kn,i),s) args
- | Case _ | Fix _ | CoFix _ -> Tunknown
+ | Case _ | Fix _ | CoFix _ | Proj _ -> Tunknown
| _ -> assert false
(*s Auxiliary function dealing with type application.
@@ -328,11 +329,22 @@ and extract_type_scheme env db c p =
(*S Extraction of an inductive type. *)
+(* First, a version with cache *)
+
and extract_ind env kn = (* kn is supposed to be in long form *)
let mib = Environ.lookup_mind kn env in
match lookup_ind kn mib with
| Some ml_ind -> ml_ind
| None ->
+ try
+ extract_really_ind env kn mib
+ with SingletonInductiveBecomesProp id ->
+ (* TODO : which inductive is concerned in the block ? *)
+ error_singleton_become_prop id (Some (IndRef (kn,0)))
+
+(* Then the real function *)
+
+and extract_really_ind env kn mib =
(* First, if this inductive is aliased via a Module,
we process the original inductive if possible.
When at toplevel of the monolithic case, we cannot do much
@@ -359,8 +371,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
let packets =
Array.mapi
(fun i mip ->
- let (ind,u), ctx =
- Universes.fresh_inductive_instance env (kn,i) in
+ let (_,u),_ = Universes.fresh_inductive_instance env (kn,i) in
let ar = Inductive.type_of_inductive env ((mib,mip),u) in
let info = (fst (flag_of_type env ar) = Info) in
let s,v = if info then type_sign_vl env ar else [],[] in
@@ -477,7 +488,7 @@ and extract_ind env kn = (* kn is supposed to be in long form *)
*)
and extract_type_cons env db dbmap c i =
- match kind_of_term (whd_betadeltaiota env none c) with
+ match kind_of_term (whd_all env none c) with
| Prod (n,t,d) ->
let env' = push_rel_assum (n,t) env in
let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in
@@ -561,7 +572,7 @@ let rec extract_term env mle mlt c args =
put_magic_if magic (MLlam (id, d')))
| LetIn (n, c1, t1, c2) ->
let id = id_of_name n in
- let env' = push_rel (Name id, Some c1, t1) env in
+ let env' = push_rel (LocalDef (Name id, c1, t1)) env in
(* We directly push the args inside the [LetIn].
TODO: the opt_let_app flag is supposed to prevent that *)
let args' = List.map (lift 1) args in
@@ -579,10 +590,10 @@ let rec extract_term env mle mlt c args =
with NotDefault d ->
let mle' = Mlenv.push_std_type mle (Tdummy d) in
ast_pop (extract_term env' mle' mlt c2 args'))
- | Const (kn,u) ->
- extract_cst_app env mle mlt kn u args
- | Construct (cp,u) ->
- extract_cons_app env mle mlt cp u args
+ | Const (kn,_) ->
+ extract_cst_app env mle mlt kn args
+ | Construct (cp,_) ->
+ extract_cons_app env mle mlt cp args
| Proj (p, c) ->
let term = Retyping.expand_projection env (Evd.from_env env) p c [] in
extract_term env mle mlt term args
@@ -633,7 +644,7 @@ and make_mlargs env e s args typs =
(*s Extraction of a constant applied to arguments. *)
-and extract_cst_app env mle mlt kn u args =
+and extract_cst_app env mle mlt kn args =
(* First, the [ml_schema] of the constant, in expanded version. *)
let nb,t = record_constant_type env kn None in
let schema = nb, expand env t in
@@ -672,7 +683,7 @@ and extract_cst_app env mle mlt kn u args =
let l,l' = List.chop (projection_arity (ConstRef kn)) mla in
if not (List.is_empty l') then (List.map (fun _ -> MLexn "Proj Args") l) @ l'
else mla
- with e when Errors.noncritical e -> mla
+ with e when CErrors.noncritical e -> mla
in
(* For strict languages, purely logical signatures lead to a dummy lam
(except when [Kill Ktype] everywhere). So a [MLdummy] is left
@@ -706,7 +717,7 @@ and extract_cst_app env mle mlt kn u args =
they are fixed, and thus are not used for the computation.
\end{itemize} *)
-and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) u args =
+and extract_cons_app env mle mlt (((kn,i) as ip,j) as cp) args =
(* First, we build the type of the constructor, stored in small pieces. *)
let mi = extract_ind env kn in
let params_nb = mi.ind_nparams in
@@ -836,7 +847,7 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt =
let decomp_lams_eta_n n m env c t =
let rels = fst (splay_prod_n env none n t) in
- let rels = List.map (fun (id,_,c) -> (id,c)) rels in
+ let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,c)) rels in
let rels',c = decompose_lam c in
let d = n - m in
(* we'd better keep rels' as long as possible. *)
@@ -934,11 +945,13 @@ let extract_fixpoint env vkn (fi,ti,ci) =
(* for replacing recursive calls [Rel ..] by the corresponding [Const]: *)
let sub = List.rev_map mkConst kns in
for i = 0 to n-1 do
- if sort_of env ti.(i) != InProp then begin
- let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
- terms.(i) <- e;
- types.(i) <- t;
- end
+ if sort_of env ti.(i) != InProp then
+ try
+ let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in
+ terms.(i) <- e;
+ types.(i) <- t;
+ with SingletonInductiveBecomesProp id ->
+ error_singleton_become_prop id (Some (ConstRef vkn.(i)))
done;
current_fixpoints := [];
Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types)
@@ -968,13 +981,17 @@ let extract_constant env kn cb =
let e,t = extract_std_constant env kn c typ in
Dterm (r,e,t)
in
- match flag_of_type env typ with
+ try
+ match flag_of_type env typ with
| (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype)
| (Logic,Default) -> warn_log (); Dterm (r, MLdummy Kprop, Tdummy Kprop)
| (Info,TypeScheme) ->
(match cb.const_body with
| Undef _ -> warn_info (); mk_typ_ax ()
- | Def c -> mk_typ (Mod_subst.force_constr c)
+ | Def c ->
+ (match cb.const_proj with
+ | None -> mk_typ (Mod_subst.force_constr c)
+ | Some pb -> mk_typ pb.proj_body)
| OpaqueDef c ->
add_opaque r;
if access_opaque () then
@@ -983,17 +1000,23 @@ let extract_constant env kn cb =
| (Info,Default) ->
(match cb.const_body with
| Undef _ -> warn_info (); mk_ax ()
- | Def c -> mk_def (Mod_subst.force_constr c)
+ | Def c ->
+ (match cb.const_proj with
+ | None -> mk_def (Mod_subst.force_constr c)
+ | Some pb -> mk_def pb.proj_body)
| OpaqueDef c ->
add_opaque r;
if access_opaque () then
mk_def (Opaqueproof.force_proof (Environ.opaque_tables env) c)
else mk_ax ())
+ with SingletonInductiveBecomesProp id ->
+ error_singleton_become_prop id (Some (ConstRef kn))
let extract_constant_spec env kn cb =
let r = ConstRef kn in
let typ = Typeops.type_of_constant_type env cb.const_type in
- match flag_of_type env typ with
+ try
+ match flag_of_type env typ with
| (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype))
| (Logic, Default) -> Sval (r, Tdummy Kprop)
| (Info, TypeScheme) ->
@@ -1008,26 +1031,34 @@ let extract_constant_spec env kn cb =
| (Info, Default) ->
let t = snd (record_constant_type env kn (Some typ)) in
Sval (r, type_expunge env t)
+ with SingletonInductiveBecomesProp id ->
+ error_singleton_become_prop id (Some (ConstRef kn))
let extract_with_type env c =
- let typ = type_of env c in
- match flag_of_type env typ with
+ try
+ let typ = type_of env c in
+ match flag_of_type env typ with
| (Info, TypeScheme) ->
let s,vl = type_sign_vl env typ in
let db = db_from_sign s in
let t = extract_type_scheme env db c (List.length s) in
Some (vl, t)
| _ -> None
+ with SingletonInductiveBecomesProp id ->
+ error_singleton_become_prop id None
let extract_constr env c =
reset_meta_count ();
- let typ = type_of env c in
- match flag_of_type env typ with
+ try
+ let typ = type_of env c in
+ match flag_of_type env typ with
| (_,TypeScheme) -> MLdummy Ktype, Tdummy Ktype
| (Logic,_) -> MLdummy Kprop, Tdummy Kprop
| (Info,Default) ->
- let mlt = extract_type env [] 1 typ [] in
- extract_term env Mlenv.empty mlt c [], mlt
+ let mlt = extract_type env [] 1 typ [] in
+ extract_term env Mlenv.empty mlt c [], mlt
+ with SingletonInductiveBecomesProp id ->
+ error_singleton_become_prop id None
let extract_inductive env kn =
let ind = extract_ind env kn in
diff --git a/plugins/extraction/extraction_plugin.mllib b/plugins/extraction/extraction_plugin.mlpack
index ad321243..9184f650 100644
--- a/plugins/extraction/extraction_plugin.mllib
+++ b/plugins/extraction/extraction_plugin.mlpack
@@ -9,4 +9,3 @@ Scheme
Json
Extract_env
G_extraction
-Extraction_plugin_mod
diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4
index aec95868..19fda4ae 100644
--- a/plugins/extraction/g_extraction.ml4
+++ b/plugins/extraction/g_extraction.ml4
@@ -8,9 +8,14 @@
(*i camlp4deps: "grammar/grammar.cma" i*)
+DECLARE PLUGIN "extraction_plugin"
+
(* ML names *)
open Genarg
+open Stdarg
+open Constrarg
+open Pcoq.Prim
open Pp
open Names
open Nameops
@@ -31,7 +36,6 @@ let pr_int_or_id _ _ _ = function
| ArgId id -> pr_id id
ARGUMENT EXTEND int_or_id
- TYPED AS int_or_id
PRINTED BY pr_int_or_id
| [ preident(id) ] -> [ ArgId (Id.of_string id) ]
| [ integer(i) ] -> [ ArgInt i ]
@@ -99,7 +103,7 @@ END
VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY
| [ "Print" "Extraction" "Inline" ]
- -> [ msg_info (print_extraction_inline ()) ]
+ -> [Feedback. msg_info (print_extraction_inline ()) ]
END
VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF
@@ -121,7 +125,7 @@ END
VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY
| [ "Print" "Extraction" "Blacklist" ]
- -> [ msg_info (print_extraction_blacklist ()) ]
+ -> [ Feedback.msg_info (print_extraction_blacklist ()) ]
END
VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF
diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml
index 22519e34..0692c88c 100644
--- a/plugins/extraction/haskell.ml
+++ b/plugins/extraction/haskell.ml
@@ -9,7 +9,7 @@
(*s Production of Haskell syntax. *)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Nameops
@@ -346,7 +346,7 @@ let pp_decl = function
in
if void then mt ()
else
- names.(i) ++ str " :: " ++ pp_type false [] typs.(i) ++ fnl () ++
+ hov 2 (names.(i) ++ str " :: " ++ pp_type false [] typs.(i)) ++ fnl () ++
(if is_custom r then
(names.(i) ++ str " = " ++ str (find_custom r))
else
@@ -357,7 +357,7 @@ let pp_decl = function
if is_inline_custom r then mt ()
else
let e = pp_global Term r in
- e ++ str " :: " ++ pp_type false [] t ++ fnl () ++
+ hov 2 (e ++ str " :: " ++ pp_type false [] t) ++ fnl () ++
if is_custom r then
hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ())
else
diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml
index df79c585..e43c47d0 100644
--- a/plugins/extraction/json.ml
+++ b/plugins/extraction/json.ml
@@ -1,8 +1,6 @@
open Pp
-open Errors
open Util
open Names
-open Nameops
open Globnames
open Table
open Miniml
@@ -18,9 +16,6 @@ let json_int i =
let json_bool b =
if b then str "true" else str "false"
-let json_null =
- str "null"
-
let json_global typ ref =
json_str (Common.pp_global typ ref)
@@ -147,7 +142,8 @@ let rec json_expr env = function
("what", json_str "fix:item");
("name", json_id fi);
("body", json_function env' ti)
- ]) (Array.map2 (fun a b -> a,b) ids' defs)))
+ ]) (Array.map2 (fun a b -> a,b) ids' defs)));
+ ("for", json_int i);
]
| MLexn s -> json_dict [
("what", json_str "expr:exception");
diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml
index b5e8b480..60fe8e76 100644
--- a/plugins/extraction/modutil.ml
+++ b/plugins/extraction/modutil.ml
@@ -8,7 +8,7 @@
open Names
open Globnames
-open Errors
+open CErrors
open Util
open Miniml
open Table
@@ -310,7 +310,7 @@ let base_r = function
let reset_needed, add_needed, add_needed_mp, found_needed, is_needed =
let needed = ref Refset'.empty
and needed_mps = ref MPset.empty in
- ((fun l -> needed := Refset'.empty; needed_mps := MPset.empty),
+ ((fun () -> needed := Refset'.empty; needed_mps := MPset.empty),
(fun r -> needed := Refset'.add (base_r r) !needed),
(fun mp -> needed_mps := MPset.add mp !needed_mps),
(fun r -> needed := Refset'.remove (base_r r) !needed),
@@ -380,14 +380,6 @@ let rec depcheck_struct = function
let lse' = depcheck_se lse in
if List.is_empty lse' then struc' else (mp,lse')::struc'
-let is_prefix pre s =
- let len = String.length pre in
- let rec is_prefix_aux i =
- if Int.equal i len then true
- else pre.[i] == s.[i] && is_prefix_aux (succ i)
- in
- is_prefix_aux 0
-
exception RemainingImplicit of kill_reason
let check_for_remaining_implicits struc =
diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml
index 3cb3810c..1c29a9bc 100644
--- a/plugins/extraction/ocaml.ml
+++ b/plugins/extraction/ocaml.ml
@@ -9,7 +9,7 @@
(*s Production of Ocaml syntax. *)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Nameops
@@ -203,7 +203,7 @@ let rec pp_expr par env args =
let args = List.skipn (projection_arity r) args in
let record = List.hd args in
pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args)
- with e when Errors.noncritical e -> apply (pp_global Term r))
+ with e when CErrors.noncritical e -> apply (pp_global Term r))
| MLfix (i,ids,defs) ->
let ids',env' = push_vars (List.rev (Array.to_list ids)) env in
pp_fix par env' i (Array.of_list (List.rev ids'),defs) args
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index 7b0f14df..a6309e61 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -9,7 +9,7 @@
(*s Production of Scheme syntax. *)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Miniml
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index d7842e12..ff66d915 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -15,7 +15,7 @@ open Libobject
open Goptions
open Libnames
open Globnames
-open Errors
+open CErrors
open Util
open Pp
open Miniml
@@ -295,81 +295,94 @@ let pr_long_global ref = pr_path (Nametab.path_of_global ref)
let err s = errorlabstrm "Extraction" s
+let warn_extraction_axiom_to_realize =
+ CWarnings.create ~name:"extraction-axiom-to-realize" ~category:"extraction"
+ (fun axioms ->
+ let s = if Int.equal (List.length axioms) 1 then "axiom" else "axioms" in
+ strbrk ("The following "^s^" must be realized in the extracted code:")
+ ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global axioms)
+ ++ str "." ++ fnl ())
+
+let warn_extraction_logical_axiom =
+ CWarnings.create ~name:"extraction-logical-axiom" ~category:"extraction"
+ (fun axioms ->
+ let s =
+ if Int.equal (List.length axioms) 1 then "axiom was" else "axioms were"
+ in
+ (strbrk ("The following logical "^s^" encountered:") ++
+ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global axioms ++ str ".\n")
+ ++ strbrk "Having invalid logical axiom in the environment when extracting"
+ ++ spc () ++ strbrk "may lead to incorrect or non-terminating ML terms." ++
+ fnl ()))
+
let warning_axioms () =
let info_axioms = Refset'.elements !info_axioms in
- if List.is_empty info_axioms then ()
- else begin
- let s = if Int.equal (List.length info_axioms) 1 then "axiom" else "axioms" in
- msg_warning
- (str ("The following "^s^" must be realized in the extracted code:")
- ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms)
- ++ str "." ++ fnl ())
- end;
+ if not (List.is_empty info_axioms) then
+ warn_extraction_axiom_to_realize info_axioms;
let log_axioms = Refset'.elements !log_axioms in
- if List.is_empty log_axioms then ()
- else begin
- let s = if Int.equal (List.length log_axioms) 1 then "axiom was" else "axioms were"
- in
- msg_warning
- (str ("The following logical "^s^" encountered:") ++
- hov 1
- (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n")
- ++
- str "Having invalid logical axiom in the environment when extracting" ++
- spc () ++ str "may lead to incorrect or non-terminating ML terms." ++
- fnl ())
- end
+ if not (List.is_empty log_axioms) then
+ warn_extraction_logical_axiom log_axioms
+
+let warn_extraction_opaque_accessed =
+ CWarnings.create ~name:"extraction-opaque-accessed" ~category:"extraction"
+ (fun lst -> strbrk "The extraction is currently set to bypass opacity, " ++
+ strbrk "the following opaque constant bodies have been accessed :" ++
+ lst ++ str "." ++ fnl ())
+
+let warn_extraction_opaque_as_axiom =
+ CWarnings.create ~name:"extraction-opaque-as-axiom" ~category:"extraction"
+ (fun lst -> strbrk "The extraction now honors the opacity constraints by default, " ++
+ strbrk "the following opaque constants have been extracted as axioms :" ++
+ lst ++ str "." ++ fnl () ++
+ strbrk "If necessary, use \"Set Extraction AccessOpaque\" to change this."
+ ++ fnl ())
let warning_opaques accessed =
let opaques = Refset'.elements !opaques in
- if List.is_empty opaques then ()
- else
+ if not (List.is_empty opaques) then
let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in
- if accessed then
- msg_warning
- (str "The extraction is currently set to bypass opacity,\n" ++
- str "the following opaque constant bodies have been accessed :" ++
- lst ++ str "." ++ fnl ())
- else
- msg_warning
- (str "The extraction now honors the opacity constraints by default,\n" ++
- str "the following opaque constants have been extracted as axioms :" ++
- lst ++ str "." ++ fnl () ++
- str "If necessary, use \"Set Extraction AccessOpaque\" to change this."
- ++ fnl ())
-
-let warning_both_mod_and_cst q mp r =
- msg_warning
- (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++
- str "do you mean module " ++
- pr_long_mp mp ++
- str " or object " ++
- pr_long_global r ++ str " ?" ++ fnl () ++
- str "First choice is assumed, for the second one please use " ++
- str "fully qualified name." ++ fnl ())
+ if accessed then warn_extraction_opaque_accessed lst
+ else warn_extraction_opaque_as_axiom lst
+
+let warning_ambiguous_name =
+ CWarnings.create ~name:"extraction-ambiguous-name" ~category:"extraction"
+ (fun (q,mp,r) -> strbrk "The name " ++ pr_qualid q ++ strbrk " is ambiguous, " ++
+ strbrk "do you mean module " ++
+ pr_long_mp mp ++
+ strbrk " or object " ++
+ pr_long_global r ++ str " ?" ++ fnl () ++
+ strbrk "First choice is assumed, for the second one please use " ++
+ strbrk "fully qualified name." ++ fnl ())
let error_axiom_scheme r i =
err (str "The type scheme axiom " ++ spc () ++
safe_pr_global r ++ spc () ++ str "needs " ++ int i ++
str " type variable(s).")
+let warn_extraction_inside_module =
+ CWarnings.create ~name:"extraction-inside-module" ~category:"extraction"
+ (fun () -> strbrk "Extraction inside an opened module is experimental." ++
+ strbrk "In case of problem, close it first.")
+
+
let check_inside_module () =
if Lib.is_modtype () then
err (str "You can't do that within a Module Type." ++ fnl () ++
str "Close it and try again.")
else if Lib.is_module () then
- msg_warning
- (str "Extraction inside an opened module is experimental.\n" ++
- str "In case of problem, close it first.\n")
+ warn_extraction_inside_module ()
let check_inside_section () =
if Lib.sections_are_opened () then
err (str "You can't do that within a section." ++ fnl () ++
str "Close it and try again.")
-let warning_id s =
- msg_warning (str ("The identifier "^s^
- " contains __ which is reserved for the extraction"))
+let warn_extraction_reserved_identifier =
+ CWarnings.create ~name:"extraction-reserved-identifier" ~category:"extraction"
+ (fun s -> strbrk ("The identifier "^s^
+ " contains __ which is reserved for the extraction"))
+
+let warning_id s = warn_extraction_reserved_identifier s
let error_constant r =
err (safe_pr_global r ++ str " is not a constant.")
@@ -391,9 +404,15 @@ let error_no_module_expr mp =
++ str "some Declare Module outside any Module Type.\n"
++ str "This situation is currently unsupported by the extraction.")
-let error_singleton_become_prop id =
+let error_singleton_become_prop id og =
+ let loc =
+ match og with
+ | Some g -> fnl () ++ str "in " ++ safe_pr_global g ++
+ str " (or in its mutual block)"
+ | None -> mt ()
+ in
err (str "The informative inductive type " ++ pr_id id ++
- str " has a Prop instance.\n" ++
+ str " has a Prop instance" ++ loc ++ str "." ++ fnl () ++
str "This happens when a sort-polymorphic singleton inductive type\n" ++
str "has logical parameters, such as (I,I) : (True * True) : Prop.\n" ++
str "The Ocaml extraction cannot handle this situation yet.\n" ++
@@ -422,7 +441,7 @@ let error_MPfile_as_mod mp b =
let argnames_of_global r =
let typ = Global.type_of_global_unsafe r in
let rels,_ =
- decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in
+ decompose_prod (Reduction.whd_all (Global.env ()) typ) in
List.rev_map fst rels
let msg_of_implicit = function
@@ -441,25 +460,28 @@ let error_remaining_implicit k =
str "You might also try Unset Extraction SafeImplicits to force" ++
fnl() ++ str "the extraction of unsafe code and review it manually.")
+let warn_extraction_remaining_implicit =
+ CWarnings.create ~name:"extraction-remaining-implicit" ~category:"extraction"
+ (fun s -> strbrk ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++
+ strbrk "Extraction SafeImplicits is unset, extracting nonetheless,"
+ ++ strbrk "but this code is potentially unsafe, please review it manually.")
+
let warning_remaining_implicit k =
let s = msg_of_implicit k in
- msg_warning
- (str ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++
- str "Extraction SafeImplicits is unset, extracting nonetheless," ++ fnl ()
- ++ str "but this code is potentially unsafe, please review it manually.")
+ warn_extraction_remaining_implicit s
let check_loaded_modfile mp = match base_mp mp with
| MPfile dp ->
if not (Library.library_is_loaded dp) then begin
match base_mp (Lib.current_mp ()) with
| MPfile dp' when not (DirPath.equal dp dp') ->
- err (str ("Please load library "^(DirPath.to_string dp^" first.")))
+ err (str "Please load library " ++ pr_dirpath dp ++ str " first.")
| _ -> ()
end
| _ -> ()
let info_file f =
- Flags.if_verbose msg_info
+ Flags.if_verbose Feedback.msg_info
(str ("The file "^f^" has been created by extraction."))
@@ -858,7 +880,7 @@ let extract_constant_inline inline r ids s =
| ConstRef kn ->
let env = Global.env () in
let typ = Global.type_of_global_unsafe (ConstRef kn) in
- let typ = Reduction.whd_betadeltaiota env typ in
+ let typ = Reduction.whd_all env typ in
if Reduction.is_arity env typ
then begin
let nargs = Hook.get use_type_scheme_nb_args env typ in
diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli
index 2b163610..15a08756 100644
--- a/plugins/extraction/table.mli
+++ b/plugins/extraction/table.mli
@@ -21,8 +21,7 @@ val safe_basename_of_global : global_reference -> Id.t
val warning_axioms : unit -> unit
val warning_opaques : bool -> unit
-val warning_both_mod_and_cst :
- qualid -> module_path -> global_reference -> unit
+val warning_ambiguous_name : ?loc:Loc.t -> qualid * module_path * global_reference -> unit
val warning_id : string -> unit
val error_axiom_scheme : global_reference -> int -> 'a
val error_constant : global_reference -> 'a
@@ -30,7 +29,7 @@ val error_inductive : global_reference -> 'a
val error_nb_cons : unit -> 'a
val error_module_clash : module_path -> module_path -> 'a
val error_no_module_expr : module_path -> 'a
-val error_singleton_become_prop : Id.t -> 'a
+val error_singleton_become_prop : Id.t -> global_reference option -> 'a
val error_unknown_module : qualid -> 'a
val error_scheme : unit -> 'a
val error_not_visible : global_reference -> 'a
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
index ae2d059f..58744b57 100644
--- a/plugins/firstorder/formula.ml
+++ b/plugins/firstorder/formula.ml
@@ -15,10 +15,11 @@ open Tacmach
open Util
open Declarations
open Globnames
+open Context.Rel.Declaration
let qflag=ref true
-let red_flags=ref Closure.betaiotazeta
+let red_flags=ref CClosure.betaiotazeta
let (=?) f g i1 i2 j1 j2=
let c=f i1 i2 in
@@ -58,12 +59,12 @@ let ind_hyps nevar ind largs gls=
Array.map myhyps types
let special_nf gl=
- let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
- (fun t -> Closure.norm_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in
+ (fun t -> CClosure.norm_val infos (CClosure.inject t))
let special_whd gl=
- let infos=Closure.create_clos_infos !red_flags (pf_env gl) in
- (fun t -> Closure.whd_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in
+ (fun t -> CClosure.whd_val infos (CClosure.inject t))
type kind_of_formula=
Arrow of constr*constr
@@ -139,8 +140,8 @@ let build_atoms gl metagen side cciterm =
negative:= unsigned :: !negative
end;
let v = ind_hyps 0 i l gl in
- let g i _ (_,_,t) =
- build_rec env polarity (lift i t) in
+ let g i _ decl =
+ build_rec env polarity (lift i (get_type decl)) in
let f l =
List.fold_left_i g (1-(List.length l)) () l in
if polarity && (* we have a constant constructor *)
@@ -150,8 +151,8 @@ let build_atoms gl metagen side cciterm =
| Exists(i,l)->
let var=mkMeta (metagen true) in
let v =(ind_hyps 1 i l gl).(0) in
- let g i _ (_,_,t) =
- build_rec (var::env) polarity (lift i t) in
+ let g i _ decl =
+ build_rec (var::env) polarity (lift i (get_type decl)) in
List.fold_left_i g (2-(List.length l)) () v
| Forall(_,b)->
let var=mkMeta (metagen true) in
@@ -224,7 +225,7 @@ let build_formula side nam typ gl metagen=
| And(_,_,_) -> Rand
| Or(_,_,_) -> Ror
| Exists (i,l) ->
- let (_,_,d)=List.last (ind_hyps 0 i l gl).(0) in
+ let d = get_type (List.last (ind_hyps 0 i l gl).(0)) in
Rexists(m,d,trivial)
| Forall (_,a) -> Rforall
| Arrow (a,b) -> Rarrow in
diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli
index 39d99d2e..5db8ff59 100644
--- a/plugins/firstorder/formula.mli
+++ b/plugins/firstorder/formula.mli
@@ -7,12 +7,11 @@
(************************************************************************)
open Term
-open Context
open Globnames
val qflag : bool ref
-val red_flags: Closure.RedFlags.reds ref
+val red_flags: CClosure.RedFlags.reds ref
val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) ->
'a -> 'a -> 'b -> 'b -> int
@@ -27,7 +26,7 @@ type counter = bool -> metavariable
val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array
val ind_hyps : int -> pinductive -> constr list ->
- Proof_type.goal Tacmach.sigma -> rel_context array
+ Proof_type.goal Tacmach.sigma -> Context.Rel.t array
type atoms = {positive:constr list;negative:constr list}
diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4
index 04152688..43fac8ad 100644
--- a/plugins/firstorder/g_ground.ml4
+++ b/plugins/firstorder/g_ground.ml4
@@ -15,6 +15,9 @@ open Goptions
open Tacticals
open Tacinterp
open Libnames
+open Constrarg
+open Stdarg
+open Pcoq.Prim
DECLARE PLUGIN "ground_plugin"
@@ -52,8 +55,15 @@ let _=
in
declare_int_option gdopt
+let default_intuition_tac =
+ let tac _ _ = Auto.h_auto None [] None in
+ let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in
+ let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in
+ Tacenv.register_ml_tactic name [| tac |];
+ Tacexpr.TacML (Loc.ghost, entry, [])
+
let (set_default_solver, default_solver, print_default_solver) =
- Tactic_option.declare_tactic_option ~default:(<:tactic<auto with *>>) "Firstorder default solver"
+ Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver"
VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF
| [ "Set" "Firstorder" "Solver" tactic(t) ] -> [
@@ -64,7 +74,7 @@ END
VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY
| [ "Print" "Firstorder" "Solver" ] -> [
- Pp.msg_info
+ Feedback.msg_info
(Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ]
END
@@ -106,11 +116,17 @@ open Pp
open Genarg
open Ppconstr
open Printer
-let pr_firstorder_using_raw _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_reference l
-let pr_firstorder_using_glob _ _ _ l = str "using " ++ prlist_with_sep pr_comma (pr_or_var (fun x -> (pr_global (snd x)))) l
-let pr_firstorder_using_typed _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_global l
+let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_reference
+let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (pr_or_var (fun x -> pr_global (snd x)))
+let pr_firstorder_using_typed _ _ _ = Pptactic.pr_auto_using pr_global
+
+let warn_deprecated_syntax =
+ CWarnings.create ~name:"firstorder-deprecated-syntax" ~category:"deprecated"
+ (fun () -> Pp.strbrk "Deprecated syntax; use \",\" as separator")
+
ARGUMENT EXTEND firstorder_using
+ TYPED AS reference_list
PRINTED BY pr_firstorder_using_typed
RAW_TYPED AS reference_list
RAW_PRINTED BY pr_firstorder_using_raw
@@ -119,8 +135,7 @@ ARGUMENT EXTEND firstorder_using
| [ "using" reference(a) ] -> [ [a] ]
| [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ]
| [ "using" reference(a) reference(b) reference_list(l) ] -> [
- Flags.if_verbose
- Pp.msg_warning (Pp.str "Deprecated syntax; use \",\" as separator");
+ warn_deprecated_syntax ();
a::b::l
]
| [ ] -> [ [] ]
@@ -128,20 +143,22 @@ END
TACTIC EXTEND firstorder
[ "firstorder" tactic_opt(t) firstorder_using(l) ] ->
- [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l []) ]
+ [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l []) ]
| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] ->
- [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) [] l) ]
+ [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l) ]
| [ "firstorder" tactic_opt(t) firstorder_using(l)
"with" ne_preident_list(l') ] ->
- [ Proofview.V82.tactic (gen_ground_tac true (Option.map eval_tactic t) l l') ]
+ [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l l') ]
END
TACTIC EXTEND gintuition
[ "gintuition" tactic_opt(t) ] ->
- [ Proofview.V82.tactic (gen_ground_tac false (Option.map eval_tactic t) [] []) ]
+ [ Proofview.V82.tactic (gen_ground_tac false (Option.map (tactic_of_value ist) t) [] []) ]
END
open Proofview.Notations
+open Cc_plugin
+open Decl_mode_plugin
let default_declarative_automation =
Proofview.tclUNIT () >>= fun () -> (* delay for [congruence_depth] *)
diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml
index 3b9f67f6..628af4e7 100644
--- a/plugins/firstorder/ground.ml
+++ b/plugins/firstorder/ground.ml
@@ -24,15 +24,15 @@ let update_flags ()=
in
List.iter f (Classops.coercions ());
red_flags:=
- Closure.RedFlags.red_add_transparent
- Closure.betaiotazeta
+ CClosure.RedFlags.red_add_transparent
+ CClosure.betaiotazeta
(Names.Id.Pred.full,Names.Cpred.complement !predref)
let ground_tac solver startseq gl=
update_flags ();
let rec toptac skipped seq gl=
if Tacinterp.get_debug()=Tactic_debug.DebugOn 0
- then Pp.msg_debug (Printer.pr_goal gl);
+ then Feedback.msg_debug (Printer.pr_goal gl);
tclORELSE (axiom_tac seq.gl seq)
begin
try
diff --git a/plugins/firstorder/ground_plugin.mllib b/plugins/firstorder/ground_plugin.mlpack
index 447a1fb5..65fb2e9a 100644
--- a/plugins/firstorder/ground_plugin.mllib
+++ b/plugins/firstorder/ground_plugin.mlpack
@@ -5,4 +5,3 @@ Rules
Instances
Ground
G_ground
-Ground_plugin_mod
diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml
index a717cc91..eebd974e 100644
--- a/plugins/firstorder/instances.ml
+++ b/plugins/firstorder/instances.ml
@@ -8,11 +8,10 @@
open Unify
open Rules
-open Errors
+open CErrors
open Util
open Term
open Vars
-open Glob_term
open Tacmach
open Tactics
open Tacticals
@@ -22,6 +21,8 @@ open Formula
open Sequent
open Names
open Misctypes
+open Sigma.Notations
+open Context.Rel.Declaration
let compare_instance inst1 inst2=
match inst1,inst2 with
@@ -96,8 +97,6 @@ let rec collect_quantified seq=
(* open instances processor *)
-let dummy_constr=mkMeta (-1)
-
let dummy_bvid=Id.of_string "x"
let mk_open_instance id idc gl m t=
@@ -108,7 +107,7 @@ let mk_open_instance id idc gl m t=
let typ=pf_unsafe_type_of gl idc in
(* since we know we will get a product,
reduction is not too expensive *)
- let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in
+ let (nam,_,_)=destProd (whd_all env evmap typ) in
match nam with
Name id -> id
| Anonymous -> dummy_bvid in
@@ -116,8 +115,10 @@ let mk_open_instance id idc gl m t=
let rec aux n avoid env evmap decls =
if Int.equal n 0 then evmap, decls else
let nid=(fresh_id avoid var_id gl) in
- let evmap, (c, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in
- let decl = (Name nid,None,c) in
+ let evmap = Sigma.Unsafe.of_evar_map evmap in
+ let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in
+ let evmap = Sigma.to_evar_map evmap in
+ let decl = LocalAssum (Name nid, c) in
aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in
let evmap, decls = aux m [] env evmap [] in
evmap, decls, revt
@@ -134,9 +135,9 @@ let left_instance_tac (inst,id) continue seq=
[tclTHENLIST
[Proofview.V82.of_tactic introf;
pf_constr_of_global id (fun idc ->
- (fun gls->generalize
+ (fun gls-> Proofview.V82.of_tactic (generalize
[mkApp(idc,
- [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls));
+ [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])]) gls));
Proofview.V82.of_tactic introf;
tclSOLVE [wrap 1 false continue
(deepen (record (id,None) seq))]];
@@ -155,12 +156,12 @@ let left_instance_tac (inst,id) continue seq=
(mkApp(idc,[|ot|])) rc in
let evmap, _ =
try Typing.type_of (pf_env gl) evmap gt
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
error "Untypable instance, maybe higher-order non-prenex quantification" in
- tclTHEN (Refiner.tclEVARS evmap) (generalize [gt]) gl)
+ tclTHEN (Refiner.tclEVARS evmap) (Proofview.V82.of_tactic (generalize [gt])) gl)
else
pf_constr_of_global id (fun idc ->
- generalize [mkApp(idc,[|t|])])
+ Proofview.V82.of_tactic (generalize [mkApp(idc,[|t|])]))
in
tclTHENLIST
[special_generalize;
diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml
index e676a8a9..ffb63af0 100644
--- a/plugins/firstorder/rules.ml
+++ b/plugins/firstorder/rules.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -19,6 +19,7 @@ open Formula
open Sequent
open Globnames
open Locus
+open Context.Named.Declaration
type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic
@@ -34,12 +35,13 @@ let wrap n b continue seq gls=
if i<=0 then seq else
match nc with
[]->anomaly (Pp.str "Not the expected number of hyps")
- | ((id,_,typ) as nd)::q->
+ | nd::q->
+ let id = get_id nd in
if occur_var env id (pf_concl gls) ||
List.exists (occur_var_in_decl env id) ctx then
(aux (i-1) q (nd::ctx))
else
- add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in
+ add_formula Hyp (VarRef id) (get_type nd) (aux (i-1) q (nd::ctx)) gls in
let seq1=aux n nc [] in
let seq2=if b then
add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in
@@ -50,13 +52,13 @@ let basename_of_global=function
| _->assert false
let clear_global=function
- VarRef id->clear [id]
+ VarRef id-> Proofview.V82.of_tactic (clear [id])
| _->tclIDTAC
(* connection rules *)
let axiom_tac t seq=
- try pf_constr_of_global (find_left t seq) exact_no_check
+ try pf_constr_of_global (find_left t seq) (fun c -> Proofview.V82.of_tactic (exact_no_check c))
with Not_found->tclFAIL 0 (Pp.str "No axiom link")
let ll_atom_tac a backtrack id continue seq=
@@ -65,7 +67,7 @@ let ll_atom_tac a backtrack id continue seq=
tclTHENLIST
[pf_constr_of_global (find_left a seq) (fun left ->
pf_constr_of_global id (fun id ->
- generalize [mkApp(id, [|left|])]));
+ Proofview.V82.of_tactic (generalize [mkApp(id, [|left|])])));
clear_global id;
Proofview.V82.of_tactic intro]
with Not_found->tclFAIL 0 (Pp.str "No link"))
@@ -133,7 +135,7 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl=
let newhyps idc =List.init lp (myterm idc) in
tclIFTHENELSE
(tclTHENLIST
- [pf_constr_of_global id (fun idc -> generalize (newhyps idc));
+ [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize (newhyps idc)));
clear_global id;
tclDO lp (Proofview.V82.of_tactic intro)])
(wrap lp false continue seq) backtrack gl
@@ -149,9 +151,9 @@ let ll_arrow_tac a b c backtrack id continue seq=
clear_global id;
wrap 1 false continue seq];
tclTHENS (Proofview.V82.of_tactic (cut cc))
- [pf_constr_of_global id exact_no_check;
+ [pf_constr_of_global id (fun c -> Proofview.V82.of_tactic (exact_no_check c));
tclTHENLIST
- [pf_constr_of_global id (fun idc -> generalize [d idc]);
+ [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize [d idc]));
clear_global id;
Proofview.V82.of_tactic introf;
Proofview.V82.of_tactic introf;
@@ -190,7 +192,7 @@ let ll_forall_tac prod backtrack id continue seq=
(fun gls->
let id0=pf_nth_hyp_id gls 1 in
let term=mkApp(idc,[|mkVar(id0)|]) in
- tclTHEN (generalize [term]) (clear [id0]) gls));
+ tclTHEN (Proofview.V82.of_tactic (generalize [term])) (Proofview.V82.of_tactic (clear [id0])) gls));
clear_global id;
Proofview.V82.of_tactic intro;
tclCOMPLETE (wrap 1 false continue (deepen seq))];
@@ -210,6 +212,6 @@ let defined_connectives=lazy
let normalize_evaluables=
onAllHypsAndConcl
(function
- None->unfold_in_concl (Lazy.force defined_connectives)
+ None-> Proofview.V82.of_tactic (unfold_in_concl (Lazy.force defined_connectives))
| Some id ->
- unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly))
+ Proofview.V82.of_tactic (unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)))
diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml
index 3e8033da..1248b60a 100644
--- a/plugins/firstorder/sequent.ml
+++ b/plugins/firstorder/sequent.ml
@@ -7,7 +7,7 @@
(************************************************************************)
open Term
-open Errors
+open CErrors
open Util
open Formula
open Unify
diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml
index 72e9371b..51bd3009 100644
--- a/plugins/fourier/fourierR.ml
+++ b/plugins/fourier/fourierR.ml
@@ -16,9 +16,9 @@ open Term
open Tactics
open Names
open Globnames
-open Tacmach
open Fourier
open Contradiction
+open Proofview.Notations
(******************************************************************************
Opérations sur les combinaisons linéaires affines.
@@ -412,13 +412,6 @@ let tac_zero_infeq_false gl (n,d) =
(tac_zero_inf_pos gl (-n,d)))
;;
-let create_meta () = mkMeta(Evarutil.new_meta());;
-
-let my_cut c gl=
- let concl = pf_concl gl in
- apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl
-;;
-
let exact = exact_check;;
let tac_use h =
@@ -451,7 +444,11 @@ let is_ineq (h,t) =
;;
*)
-let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;;
+let list_of_sign s =
+ let open Context.Named.Declaration in
+ List.map (function LocalAssum (name, typ) -> name, typ
+ | LocalDef (name, _, typ) -> name, typ)
+ s;;
let mkAppL a =
let l = Array.to_list a in
@@ -462,7 +459,7 @@ exception GoalDone
(* Résolution d'inéquations linéaires dans R *)
let rec fourier () =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
Coqlib.check_required_library ["Coq";"fourier";"Fourier"];
let goal = strip_outer_cast concl in
@@ -504,11 +501,11 @@ let rec fourier () =
with NoIneq -> ())
hyps;
(* lineq = les inéquations découlant des hypothèses *)
- if !lineq=[] then Errors.error "No inequalities";
+ if !lineq=[] then CErrors.error "No inequalities";
let res=fourier_lineq (!lineq) in
let tac=ref (Proofview.tclUNIT ()) in
if res=[]
- then Errors.error "fourier failed"
+ then CErrors.error "fourier failed"
(* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *)
else (match res with
[(cres,sres,lc)]->
@@ -586,7 +583,7 @@ let rec fourier () =
then tac_zero_inf_false gl (rational_to_fraction cres)
else tac_zero_infeq_false gl (rational_to_fraction cres)
in
- tac:=(Tacticals.New.tclTHENS (Proofview.V82.tactic (my_cut ineq))
+ tac:=(Tacticals.New.tclTHENS (cut ineq)
[Tacticals.New.tclTHEN (change_concl
(mkAppL [| get coq_not; ineq|]
))
@@ -622,7 +619,7 @@ let rec fourier () =
(* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *)
!tac
(* ((tclABSTRACT None !tac) gl) *)
- end
+ end }
;;
(*
diff --git a/plugins/fourier/fourier_plugin.mllib b/plugins/fourier/fourier_plugin.mlpack
index 0383b1a8..b6262f8a 100644
--- a/plugins/fourier/fourier_plugin.mllib
+++ b/plugins/fourier/fourier_plugin.mlpack
@@ -1,4 +1,3 @@
Fourier
FourierR
G_fourier
-Fourier_plugin_mod
diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml
index 169a7060..b0ffc775 100644
--- a/plugins/funind/functional_principles_proofs.ml
+++ b/plugins/funind/functional_principles_proofs.ml
@@ -1,20 +1,20 @@
open Printer
-open Errors
+open CErrors
open Util
open Term
open Vars
-open Context
open Namegen
open Names
-open Declarations
open Pp
open Tacmach
+open Termops
open Proof_type
open Tacticals
open Tactics
open Indfun_common
open Libnames
open Globnames
+open Context.Rel.Declaration
(* let msgnl = Pp.msgnl *)
@@ -27,7 +27,7 @@ let observe strm =
let do_observe_tac s tac g =
try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v
with e ->
- let e = Cerrors.process_vernac_interp_error e in
+ let e = ExplainErr.process_vernac_interp_error e in
let goal = begin try (Printer.pr_goal g) with _ -> assert false end in
msg_debug (str "observation "++ s++str " raised exception " ++
Errors.print e ++ str " on goal " ++ goal );
@@ -52,17 +52,17 @@ let rec print_debug_queue e =
let _ =
match e with
| Some e ->
- Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+ Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal))
| None ->
begin
- Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
+ Feedback.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal);
end in
print_debug_queue None ;
end
let observe strm =
if do_observe ()
- then Pp.msg_debug strm
+ then Feedback.msg_debug strm
else ()
let do_observe_tac s tac g =
@@ -74,9 +74,9 @@ let do_observe_tac s tac g =
ignore(Stack.pop debug_queue);
v
with reraise ->
- let reraise = Errors.push reraise in
+ let reraise = CErrors.push reraise in
if not (Stack.is_empty debug_queue)
- then print_debug_queue (Some (fst (Cerrors.process_vernac_interp_error reraise)));
+ then print_debug_queue (Some (fst (ExplainErr.process_vernac_interp_error reraise)));
iraise reraise
let observe_tac_stream s tac g =
@@ -127,8 +127,7 @@ let finish_proof dynamic_infos g =
let refine c =
Tacmach.refine c
-let thin l =
- Tacmach.thin_no_check l
+let thin l = Proofview.V82.of_tactic (Tactics.clear l)
let eq_constr u v = eq_constr_nounivs u v
@@ -142,7 +141,7 @@ let is_trivial_eq t =
eq_constr t1 t2 && eq_constr a1 a2
| _ -> false
end
- with e when Errors.noncritical e -> false
+ with e when CErrors.noncritical e -> false
in
(* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *)
res
@@ -168,7 +167,7 @@ let is_incompatible_eq t =
(eq_constr u1 u2 &&
incompatible_constructor_terms t1 t2)
| _ -> false
- with e when Errors.noncritical e -> false
+ with e when CErrors.noncritical e -> false
in
if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t);
res
@@ -224,12 +223,12 @@ let isAppConstruct ?(env=Global.env ()) t =
let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *)
let clos_norm_flags flgs env sigma t =
- Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
- clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty
+ CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in
+ clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty
-let change_eq env sigma hyp_id (context:rel_context) x t end_of_type =
+let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type =
let nochange ?t' msg =
begin
observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t );
@@ -255,7 +254,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type =
then
(jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0))
else nochange "not an equality"
- with e when Errors.noncritical e -> nochange "not an equality"
+ with e when CErrors.noncritical e -> nochange "not an equality"
in
if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs";
let rec compute_substitution sub t1 t2 =
@@ -282,7 +281,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type =
List.fold_left2 compute_substitution sub args1 args2
end
else
- if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2) "cannot solve (diff)"
+ if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_all env t1) t2) "cannot solve (diff)"
in
let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in
let sub = compute_substitution sub (fst t1) (fst t2) in
@@ -304,11 +303,11 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type =
in
let new_type_of_hyp,ctxt_size,witness_fun =
List.fold_left_i
- (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) ->
+ (fun i (end_of_type,ctxt_size,witness_fun) decl ->
try
let witness = Int.Map.find i sub in
- if not (Option.is_empty b') then anomaly (Pp.str "can not redefine a rel!");
- (Termops.pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun))
+ if is_local_def decl then anomaly (Pp.str "can not redefine a rel!");
+ (Termops.pop end_of_type,ctxt_size,mkLetIn (get_name decl, witness, get_type decl, witness_fun))
with Not_found ->
(mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun)
)
@@ -371,12 +370,12 @@ let isLetIn t =
| _ -> false
-let h_reduce_with_zeta =
- reduce
+let h_reduce_with_zeta cl =
+ Proofview.V82.of_tactic (reduce
(Genredexpr.Cbv
{Redops.all_flags
with Genredexpr.rDelta = false;
- })
+ }) cl)
@@ -536,7 +535,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma =
(scan_type new_context new_t')
with Failure "NoChange" ->
(* Last thing todo : push the rel in the context and continue *)
- scan_type ((x,None,t_x)::context) t'
+ scan_type (LocalAssum (x,t_x) :: context) t'
end
end
else
@@ -626,8 +625,8 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos =
let my_orelse tac1 tac2 g =
try
tac1 g
- with e when Errors.noncritical e ->
-(* observe (str "using snd tac since : " ++ Errors.print e); *)
+ with e when CErrors.noncritical e ->
+(* observe (str "using snd tac since : " ++ CErrors.print e); *)
tac2 g
let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id =
@@ -705,9 +704,9 @@ let build_proof
in
tclTHENSEQ
[
- Simple.generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps));
+ Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)));
thin dyn_infos.rec_hyps;
- pattern_option [Locus.AllOccurrencesBut [1],t] None;
+ Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None);
(fun g -> observe_tac "toto" (
tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t);
(fun g' ->
@@ -736,7 +735,8 @@ let build_proof
tclTHEN
(Proofview.V82.of_tactic intro)
(fun g' ->
- let (id,_,_) = pf_last_hyp g' in
+ let open Context.Named.Declaration in
+ let id = pf_last_hyp g' |> get_id in
let new_term =
pf_nf_betaiota g'
(mkApp(dyn_infos.info,[|mkVar id|]))
@@ -921,7 +921,9 @@ let generalize_non_dep hyp g =
let env = Global.env () in
let hyp_typ = pf_unsafe_type_of g (mkVar hyp) in
let to_revert,_ =
- Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) ->
+ let open Context.Named.Declaration in
+ Environ.fold_named_context_reverse (fun (clear,keep) decl ->
+ let hyp = get_id decl in
if Id.List.mem hyp hyps
|| List.exists (Termops.occur_var_in_decl env hyp) keep
|| Termops.occur_var env hyp hyp_typ
@@ -932,15 +934,15 @@ let generalize_non_dep hyp g =
in
(* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *)
tclTHEN
- ((* observe_tac "h_generalize" *) (Simple.generalize (List.map mkVar to_revert) ))
+ ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map mkVar to_revert) )))
((* observe_tac "thin" *) (thin to_revert))
g
-let id_of_decl (na,_,_) = (Nameops.out_name na)
+let id_of_decl decl = Nameops.out_name (get_name decl)
let var_of_decl decl = mkVar (id_of_decl decl)
let revert idl =
tclTHEN
- (generalize (List.map mkVar idl))
+ (Proofview.V82.of_tactic (generalize (List.map mkVar idl)))
(thin idl)
let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num =
@@ -1023,7 +1025,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a
{finfos with
equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with
ConstRef c -> c
- | _ -> Errors.anomaly (Pp.str "Not a constant")
+ | _ -> CErrors.anomaly (Pp.str "Not a constant")
)
}
| _ -> ()
@@ -1044,7 +1046,8 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a
(
fun g' ->
let just_introduced = nLastDecls nb_intro_to_do g' in
- let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in
+ let open Context.Named.Declaration in
+ let just_introduced_id = List.map get_id just_introduced in
tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma))
(revert just_introduced_id) g'
)
@@ -1069,11 +1072,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
(Name new_id)
)
in
- let fresh_decl =
- (fun (na,b,t) ->
- (fresh_id na,b,t)
- )
- in
+ let fresh_decl = map_name fresh_id in
let princ_info : elim_scheme =
{ princ_info with
params = List.map fresh_decl princ_info.params;
@@ -1086,7 +1085,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
match Global.body_of_constant const with
| Some body ->
Tacred.cbv_norm_flags
- (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+ (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
(Global.env ())
(Evd.empty)
body
@@ -1120,11 +1119,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
)
in
observe (str "full_params := " ++
- prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na))
+ prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl)))
full_params
);
observe (str "princ_params := " ++
- prlist_with_sep spc (fun (na,_,_) -> Ppconstr.pr_id (Nameops.out_name na))
+ prlist_with_sep spc (fun decl -> Ppconstr.pr_id (Nameops.out_name (get_name decl)))
princ_params
);
observe (str "fbody_with_full_params := " ++
@@ -1165,7 +1164,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
in
let pte_to_fix,rev_info =
List.fold_left_i
- (fun i (acc_map,acc_info) (pte,_,_) ->
+ (fun i (acc_map,acc_info) decl ->
+ let pte = get_name decl in
let infos = info_array.(i) in
let type_args,_ = decompose_prod infos.types in
let nargs = List.length type_args in
@@ -1227,10 +1227,10 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
if this_fix_info.idx + 1 = 0
then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *)
else
- observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (fix (Some this_fix_info.name) (this_fix_info.idx +1))
+ observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix (Some this_fix_info.name) (this_fix_info.idx +1)))
else
- Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1)
- other_fix_infos 0
+ Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1)
+ other_fix_infos 0)
| _ -> anomaly (Pp.str "Not a valid information")
in
let first_tac : tactic = (* every operations until fix creations *)
@@ -1259,7 +1259,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
let args = nLastDecls nb_args g in
let fix_body = fix_info.body_with_param in
(* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *)
- let args_id = List.map (fun (id,_,_) -> id) args in
+ let open Context.Named.Declaration in
+ let args_id = List.map get_id args in
let dyn_infos =
{
nb_rec_hyps = -100;
@@ -1276,7 +1277,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
(do_replace evd
full_params
(fix_info.idx + List.length princ_params)
- (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params))
+ (args_id@(List.map (fun decl -> Nameops.out_name (get_name decl)) princ_params))
(all_funs.(fix_info.num_in_block))
fix_info.num_in_block
all_funs
@@ -1317,8 +1318,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
[
tclDO nb_args (Proofview.V82.of_tactic intro);
(fun g -> (* replacement of the function by its body *)
- let args = nLastDecls nb_args g in
- let args_id = List.map (fun (id,_,_) -> id) args in
+ let args = nLastDecls nb_args g in
+ let open Context.Named.Declaration in
+ let args_id = List.map get_id args in
let dyn_infos =
{
nb_rec_hyps = -100;
@@ -1334,7 +1336,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam
in
let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in
tclTHENSEQ
- [unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))];
+ [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]);
let do_prove =
build_proof
interactive_proof
@@ -1403,7 +1405,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic =
(* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *)
(* rewrite *)
(* ) *)
- Eauto.gen_eauto (false,5) [] (Some [])
+ Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some []))
]
gls
@@ -1460,7 +1462,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
(fun g ->
if is_mes
then
- unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g
+ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) g
else tclIDTAC g
);
observe_tac "rew_and_finish"
@@ -1472,7 +1474,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic =
tclCOMPLETE(
Eauto.eauto_with_bases
(true,5)
- [Evd.empty,Lazy.force refl_equal]
+ [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}]
[Hints.Hint_db.empty empty_transparent_state false]
)
)
@@ -1520,7 +1522,7 @@ let prove_principle_for_gen
avoid := new_id :: !avoid;
Name new_id
in
- let fresh_decl (na,b,t) = (fresh_id na,b,t) in
+ let fresh_decl = map_name fresh_id in
let princ_info : elim_scheme =
{ princ_info with
params = List.map fresh_decl princ_info.params;
@@ -1550,11 +1552,11 @@ let prove_principle_for_gen
in
let rec_arg_id =
match List.rev post_rec_arg with
- | (Name id,_,_)::_ -> id
+ | (LocalAssum (Name id,_) | LocalDef (Name id,_,_)) :: _ -> id
| _ -> assert false
in
(* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *)
- let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in
+ let subst_constrs = List.map (fun decl -> mkVar (Nameops.out_name (get_name decl))) (pre_rec_arg@princ_info.params) in
let relation = substl subst_constrs relation in
let input_type = substl subst_constrs rec_arg_type in
let wf_thm_id = Nameops.out_name (fresh_id (Name (Id.of_string "wf_R"))) in
@@ -1562,7 +1564,7 @@ let prove_principle_for_gen
Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id)))))
in
let revert l =
- tclTHEN (Tactics.Simple.generalize (List.map mkVar l)) (clear l)
+ tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l))
in
let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in
let prove_rec_arg_acc g =
@@ -1582,7 +1584,7 @@ let prove_principle_for_gen
)
g
in
- let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in
+ let args_ids = List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.args in
let lemma =
match !tcc_lemma_ref with
| None -> error "No tcc proof !!"
@@ -1608,7 +1610,7 @@ let prove_principle_for_gen
in
tclTHENSEQ
[
- generalize [lemma];
+ Proofview.V82.of_tactic (generalize [lemma]);
Proofview.V82.of_tactic (Simple.intro hid);
Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid));
(fun g ->
@@ -1629,7 +1631,7 @@ let prove_principle_for_gen
[
observe_tac "start_tac" start_tac;
h_intros
- (List.rev_map (fun (na,_,_) -> Nameops.out_name na)
+ (List.rev_map (fun decl -> Nameops.out_name (get_name decl))
(princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params)
);
(* observe_tac "" *) Proofview.V82.of_tactic (assert_by
@@ -1640,7 +1642,7 @@ let prove_principle_for_gen
(* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids)));
(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *)
(* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *)
- (* observe_tac "h_fix " *) (fix (Some fix_id) (List.length args_ids + 1));
+ (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix (Some fix_id) (List.length args_ids + 1)));
(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *)
h_intros (List.rev (acc_rec_arg_id::args_ids));
Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref));
@@ -1667,7 +1669,7 @@ let prove_principle_for_gen
in
let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in
let predicates_names =
- List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates
+ List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.predicates
in
let pte_info =
{ proving_tac =
@@ -1683,7 +1685,7 @@ let prove_principle_for_gen
is_mes acc_inv fix_id
(!tcc_list@(List.map
- (fun (na,_,_) -> (Nameops.out_name na))
+ (fun decl -> (Nameops.out_name (get_name decl)))
(princ_info.args@princ_info.params)
)@ ([acc_rec_arg_id])) eqs
)
@@ -1712,7 +1714,7 @@ let prove_principle_for_gen
(* observe_tac "instanciate_hyps_with_args" *)
(instanciate_hyps_with_args
make_proof
- (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches)
+ (List.map (fun decl -> Nameops.out_name (get_name decl)) princ_info.branches)
(List.rev args_ids)
)
gl'
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index c47602bd..5e72b867 100644
--- a/plugins/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -1,24 +1,25 @@
open Printer
-open Errors
+open CErrors
open Util
open Term
open Vars
-open Context
open Namegen
open Names
open Pp
open Entries
open Tactics
+open Context.Rel.Declaration
open Indfun_common
open Functional_principles_proofs
open Misctypes
+open Sigma.Notations
exception Toberemoved_with_rel of int*constr
exception Toberemoved
let observe s =
if do_observe ()
- then Pp.msg_debug s
+ then Feedback.msg_debug s
(*
Transform an inductive induction principle into
@@ -29,14 +30,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
let env = Global.env () in
let env_with_params = Environ.push_rel_context princ_type_info.params env in
let tbl = Hashtbl.create 792 in
- let rec change_predicates_names (avoid:Id.t list) (predicates:rel_context) : rel_context =
+ let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t) : Context.Rel.t =
match predicates with
| [] -> []
- |(Name x,v,t)::predicates ->
- let id = Namegen.next_ident_away x avoid in
- Hashtbl.add tbl id x;
- (Name id,v,t)::(change_predicates_names (id::avoid) predicates)
- | (Anonymous,_,_)::_ -> anomaly (Pp.str "Anonymous property binder ")
+ | decl :: predicates ->
+ (match Context.Rel.Declaration.get_name decl with
+ | Name x ->
+ let id = Namegen.next_ident_away x avoid in
+ Hashtbl.add tbl id x;
+ set_name (Name id) decl :: change_predicates_names (id::avoid) predicates
+ | Anonymous -> anomaly (Pp.str "Anonymous property binder "))
in
let avoid = (Termops.ids_of_context env_with_params ) in
let princ_type_info =
@@ -46,15 +49,16 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
in
(* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *)
(* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *)
- let change_predicate_sort i (x,_,t) =
+ let change_predicate_sort i decl =
let new_sort = sorts.(i) in
- let args,_ = decompose_prod t in
+ let args,_ = decompose_prod (get_type decl) in
let real_args =
if princ_type_info.indarg_in_concl
then List.tl args
else args
in
- Nameops.out_name x,None,compose_prod real_args (mkSort new_sort)
+ Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl),
+ compose_prod real_args (mkSort new_sort))
in
let new_predicates =
List.map_i
@@ -69,7 +73,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
| _ -> error "Not a valid predicate"
)
in
- let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in
+ let ptes_vars = List.map Context.Named.Declaration.get_id new_predicates in
let is_pte =
let set = List.fold_right Id.Set.add ptes_vars Id.Set.empty in
fun t ->
@@ -114,7 +118,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
| Rel n ->
begin
try match Environ.lookup_rel n env with
- | _,_,t when is_dom t -> raise Toberemoved
+ | LocalAssum (_,t) | LocalDef (_,_,t) when is_dom t -> raise Toberemoved
| _ -> pre_princ,[]
with Not_found -> assert false
end
@@ -159,7 +163,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
try
let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
let new_x : Name.t = get_name (Termops.ids_of_context env) x in
- let new_env = Environ.push_rel (x,None,t) env in
+ let new_env = Environ.push_rel (LocalAssum (x,t)) env in
let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b
@@ -188,7 +192,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
let new_t,binders_to_remove_from_t = compute_new_princ_type remove env t in
let new_v,binders_to_remove_from_v = compute_new_princ_type remove env v in
let new_x : Name.t = get_name (Termops.ids_of_context env) x in
- let new_env = Environ.push_rel (x,Some v,t) env in
+ let new_env = Environ.push_rel (LocalDef (x,v,t)) env in
let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in
if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b
then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b
@@ -227,7 +231,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
in
it_mkProd_or_LetIn
(it_mkProd_or_LetIn
- pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b)
+ pre_res (List.map (function Context.Named.Declaration.LocalAssum (id,b) -> LocalAssum (Name (Hashtbl.find tbl id), b)
+ | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b))
new_predicates)
)
princ_type_info.params
@@ -235,10 +240,12 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type =
let change_property_sort evd toSort princ princName =
+ let open Context.Rel.Declaration in
let princ_info = compute_elim_sig princ in
- let change_sort_in_predicate (x,v,t) =
- (x,None,
- let args,ty = decompose_prod t in
+ let change_sort_in_predicate decl =
+ LocalAssum
+ (get_name decl,
+ let args,ty = decompose_prod (get_type decl) in
let s = destSort ty in
Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty);
compose_prod args (mkSort toSort)
@@ -291,7 +298,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin
(* let dur1 = System.time_difference tim1 tim2 in *)
(* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *)
(* end; *)
- get_proof_clean true, Ephemeron.create hook
+ get_proof_clean true, CEphemeron.create hook
end
@@ -351,7 +358,7 @@ let generate_functional_principle (evd: Evd.evar_map ref)
Don't forget to close the goal if an error is raised !!!!
*)
save false new_princ_name entry g_kind hook
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
begin
begin
try
@@ -363,7 +370,7 @@ let generate_functional_principle (evd: Evd.evar_map ref)
then Pfedit.delete_current_proof ()
else ()
else ()
- with e when Errors.noncritical e -> ()
+ with e when CErrors.noncritical e -> ()
end;
raise (Defining_principle e)
end
@@ -393,7 +400,7 @@ let get_funs_constant mp dp =
match Global.body_of_constant const with
| Some body ->
let body = Tacred.cbv_norm_flags
- (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+ (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
(Global.env ())
(Evd.from_env (Global.env ()))
body
@@ -503,7 +510,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con
0
(prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs)))
(fun _ _ _ -> ())
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
begin
begin
try
@@ -515,7 +522,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con
then Pfedit.delete_current_proof ()
else ()
else ()
- with e when Errors.noncritical e -> ()
+ with e when CErrors.noncritical e -> ()
end;
raise (Defining_principle e)
end
@@ -648,12 +655,15 @@ let build_case_scheme fa =
let this_block_funs_indexes = Array.to_list this_block_funs_indexes in
List.assoc_f Constant.equal (fst (destConst funs)) this_block_funs_indexes
in
- let ind_fun =
+ let (ind, sf) =
let ind = first_fun_kn,funs_indexes in
(ind,Univ.Instance.empty)(*FIXME*),prop_sort
in
- let sigma, scheme =
- (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun in
+ let sigma = Sigma.Unsafe.of_evar_map sigma in
+ let Sigma (scheme, sigma, _) =
+ Indrec.build_case_analysis_scheme_default env sigma ind sf
+ in
+ let sigma = Sigma.to_evar_map sigma in
let scheme_type = (Typing.unsafe_type_of env sigma ) scheme in
let sorts =
(fun (_,_,x) ->
diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4
index a15e46bf..42e49031 100644
--- a/plugins/funind/g_indfun.ml4
+++ b/plugins/funind/g_indfun.ml4
@@ -9,15 +9,16 @@
open Compat
open Util
open Term
-open Vars
-open Names
open Pp
open Constrexpr
open Indfun_common
open Indfun
open Genarg
-open Tacticals
+open Constrarg
open Misctypes
+open Pcoq.Prim
+open Pcoq.Constr
+open Pcoq.Tactic
DECLARE PLUGIN "recdef_plugin"
@@ -55,10 +56,13 @@ let pr_with_bindings_typed prc prlc (c,bl) =
let pr_fun_ind_using_typed prc prlc _ opt_c =
match opt_c with
| None -> mt ()
- | Some b -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b.Evd.it)
+ | Some b ->
+ let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in
+ spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b)
ARGUMENT EXTEND fun_ind_using
+ TYPED AS constr_with_bindings option
PRINTED BY pr_fun_ind_using_typed
RAW_TYPED AS constr_with_bindings_opt
RAW_PRINTED BY pr_fun_ind_using
@@ -86,9 +90,9 @@ let pr_intro_as_pat _prc _ _ pat =
let out_disjunctive = function
| loc, IntroAction (IntroOrAndPattern l) -> (loc,l)
- | _ -> Errors.error "Disjunctive or conjunctive intro pattern expected."
+ | _ -> CErrors.error "Disjunctive or conjunctive intro pattern expected."
-ARGUMENT EXTEND with_names TYPED AS simple_intropattern_opt PRINTED BY pr_intro_as_pat
+ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat
| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ]
| [] ->[ None ]
END
@@ -119,12 +123,12 @@ TACTIC EXTEND snewfunind
END
-let pr_constr_coma_sequence prc _ _ = prlist_with_sep pr_comma prc
+let pr_constr_comma_sequence prc _ _ = prlist_with_sep pr_comma prc
-ARGUMENT EXTEND constr_coma_sequence'
+ARGUMENT EXTEND constr_comma_sequence'
TYPED AS constr_list
- PRINTED BY pr_constr_coma_sequence
-| [ constr(c) "," constr_coma_sequence'(l) ] -> [ c::l ]
+ PRINTED BY pr_constr_comma_sequence
+| [ constr(c) "," constr_comma_sequence'(l) ] -> [ c::l ]
| [ constr(c) ] -> [ [c] ]
END
@@ -133,7 +137,7 @@ let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc
ARGUMENT EXTEND auto_using'
TYPED AS constr_list
PRINTED BY pr_auto_using
-| [ "using" constr_coma_sequence'(l) ] -> [ l ]
+| [ "using" constr_comma_sequence'(l) ] -> [ l ]
| [ ] -> [ [] ]
END
@@ -144,10 +148,10 @@ module Tactic = Pcoq.Tactic
type function_rec_definition_loc_argtype = (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) Loc.located
let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genarg.uniform_genarg_type) =
- Genarg.create_arg None "function_rec_definition_loc"
+ Genarg.create_arg "function_rec_definition_loc"
let function_rec_definition_loc =
- Pcoq.create_generic_entry "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc)
+ Pcoq.create_generic_entry Pcoq.utactic "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc)
GEXTEND Gram
GLOBAL: function_rec_definition_loc ;
@@ -158,6 +162,11 @@ GEXTEND Gram
END
+let () =
+ let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in
+ let printer _ _ _ _ = str "<Unavailable printer for rec_definition>" in
+ Pptactic.declare_extra_genarg_pprule wit_function_rec_definition_loc raw_printer printer printer
+
(* TASSI: n'importe quoi ! *)
VERNAC COMMAND EXTEND Function
["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")]
@@ -186,18 +195,16 @@ END
let warning_error names e =
- let (e, _) = Cerrors.process_vernac_interp_error (e, Exninfo.null) in
+ let (e, _) = ExplainErr.process_vernac_interp_error (e, Exninfo.null) in
match e with
| Building_graph e ->
- Pp.msg_warning
- (str "Cannot define graph(s) for " ++
- h 1 (pr_enum Libnames.pr_reference names) ++
- if do_observe () then (spc () ++ Errors.print e) else mt ())
+ let names = pr_enum Libnames.pr_reference names in
+ let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in
+ warn_cannot_define_graph (names,error)
| Defining_principle e ->
- Pp.msg_warning
- (str "Cannot define principle(s) for "++
- h 1 (pr_enum Libnames.pr_reference names) ++
- if do_observe () then Errors.print e else mt ())
+ let names = pr_enum Libnames.pr_reference names in
+ let error = if do_observe () then CErrors.print e else mt () in
+ warn_cannot_define_principle (names,error)
| _ -> raise e
@@ -220,15 +227,15 @@ VERNAC COMMAND EXTEND NewFunctionalScheme
;
try Functional_principles_types.build_scheme fas
with Functional_principles_types.No_graph_found ->
- Errors.error ("Cannot generate induction principle(s)")
- | e when Errors.noncritical e ->
+ CErrors.error ("Cannot generate induction principle(s)")
+ | e when CErrors.noncritical e ->
let names = List.map (fun (_,na,_) -> na) fas in
warning_error names e
end
| _ -> assert false (* we can only have non empty list *)
end
- | e when Errors.noncritical e ->
+ | e when CErrors.noncritical e ->
let names = List.map (fun (_,na,_) -> na) fas in
warning_error names e
end
diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml
index 5d92fca5..52179ae5 100644
--- a/plugins/funind/glob_term_to_relation.ml
+++ b/plugins/funind/glob_term_to_relation.ml
@@ -7,14 +7,14 @@ open Glob_term
open Glob_ops
open Globnames
open Indfun_common
-open Errors
+open CErrors
open Util
open Glob_termops
open Misctypes
let observe strm =
if do_observe ()
- then Pp.msg_debug strm
+ then Feedback.msg_debug strm
else ()
(*let observennl strm =
if do_observe ()
@@ -335,15 +335,17 @@ let raw_push_named (na,raw_value,raw_typ) env =
| Name id ->
let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in
let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in
- Environ.push_named (id,value,typ) env
+ let open Context.Named.Declaration in
+ Environ.push_named (of_tuple (id,value,typ)) env
let add_pat_variables pat typ env : Environ.env =
let rec add_pat_variables env pat typ : Environ.env =
+ let open Context.Rel.Declaration in
observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env));
match pat with
- | PatVar(_,na) -> Environ.push_rel (na,None,typ) env
+ | PatVar(_,na) -> Environ.push_rel (LocalAssum (na,typ)) env
| PatCstr(_,c,patl,na) ->
let Inductiveops.IndType(indf,indargs) =
try Inductiveops.find_rectype env (Evd.from_env env) typ
@@ -351,15 +353,16 @@ let add_pat_variables pat typ env : Environ.env =
in
let constructors = Inductiveops.get_constructors env indf in
let constructor : Inductiveops.constructor_summary = List.find (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in
- let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
+ let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in
List.fold_left2 add_pat_variables env patl (List.rev cs_args_types)
in
let new_env = add_pat_variables env pat typ in
let res =
fst (
- Context.fold_rel_context
- (fun (na,v,t) (env,ctxt) ->
- match na with
+ Context.Rel.fold_outside
+ (fun decl (env,ctxt) ->
+ let _,v,t = Context.Rel.Declaration.to_tuple decl in
+ match Context.Rel.Declaration.get_name decl with
| Anonymous -> assert false
| Name id ->
let new_t = substl ctxt t in
@@ -370,7 +373,8 @@ let add_pat_variables pat typ env : Environ.env =
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)
+ let open Context.Named.Declaration in
+ (Environ.push_named (of_tuple (id,new_v,new_t)) env,mkVar id::ctxt)
)
(Environ.rel_context new_env)
~init:(env,[])
@@ -398,7 +402,8 @@ let rec pattern_to_term_and_type env typ = function
in
let constructors = Inductiveops.get_constructors env indf in
let constructor = List.find (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in
- let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in
+ let open Context.Rel.Declaration in
+ let cs_args_types :types list = List.map get_type constructor.Inductiveops.cs_args in
let _,cstl = Inductiveops.dest_ind_family indf in
let csta = Array.of_list cstl in
let implicit_args =
@@ -597,9 +602,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return =
let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in
let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in
let new_env =
+ let open Context.Named.Declaration in
match n with
Anonymous -> env
- | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env
+ | Name id -> Environ.push_named (of_tuple (id,Some v_as_constr,v_type)) env
in
let b_res = build_entry_lc new_env funnames avoid b in
combine_results (combine_letin n) v_res b_res
@@ -875,7 +881,7 @@ exception Continue
*)
let rec rebuild_cons env nb_args relname args crossed_types depth rt =
observe (str "rebuilding : " ++ pr_glob_constr rt);
-
+ let open Context.Rel.Declaration in
match rt with
| GProd(_,n,k,t,b) ->
let not_free_in_t id = not (is_free_in id t) in
@@ -895,7 +901,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt])
in
let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in
- let new_env = Environ.push_rel (n,None,t') env in
+ let new_env = Environ.push_rel (LocalAssum (n,t')) env in
let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
@@ -915,7 +921,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
observe (str "computing new type for eq : " ++ pr_glob_constr rt);
let t' =
try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*)
- with e when Errors.noncritical e -> raise Continue
+ with e when CErrors.noncritical e -> raise Continue
in
let is_in_b = is_free_in id b in
let _keep_eq =
@@ -926,7 +932,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
let subst_b =
if is_in_b then b else replace_var_by_term id rt b
in
- let new_env = Environ.push_rel (n,None,t') env in
+ let new_env = Environ.push_rel (LocalAssum (n,t')) env in
let new_b,id_to_exclude =
rebuild_cons
new_env
@@ -970,9 +976,8 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
(fun acc var_as_constr arg ->
if isRel var_as_constr
then
- let (na,_,_) =
- Environ.lookup_rel (destRel var_as_constr) env
- in
+ let open Context.Rel.Declaration in
+ let na = get_name (Environ.lookup_rel (destRel var_as_constr) env) in
match na with
| Anonymous -> acc
| Name id' ->
@@ -1010,7 +1015,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
in
let new_env =
let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in
- Environ.push_rel (n,None,t') env
+ Environ.push_rel (LocalAssum (n,t')) env
in
let new_b,id_to_exclude =
rebuild_cons
@@ -1048,7 +1053,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
with Continue ->
observe (str "computing new type for prod : " ++ pr_glob_constr rt);
let t',ctx = Pretyping.understand env (Evd.from_env env) t in
- let new_env = Environ.push_rel (n,None,t') env in
+ let new_env = Environ.push_rel (LocalAssum (n,t')) env in
let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
@@ -1064,7 +1069,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
| _ ->
observe (str "computing new type for prod : " ++ pr_glob_constr rt);
let t',ctx = Pretyping.understand env (Evd.from_env env) t in
- let new_env = Environ.push_rel (n,None,t') env in
+ let new_env = Environ.push_rel (LocalAssum (n,t')) env in
let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
@@ -1085,7 +1090,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
let t',ctx = Pretyping.understand env (Evd.from_env env) t in
match n with
| Name id ->
- let new_env = Environ.push_rel (n,None,t') env in
+ let new_env = Environ.push_rel (LocalAssum (n,t')) env in
let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
@@ -1108,7 +1113,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
let t',ctx = Pretyping.understand env evd t in
let evd = Evd.from_ctx ctx in
let type_t' = Typing.unsafe_type_of env evd t' in
- let new_env = Environ.push_rel (n,Some t',type_t') env in
+ let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in
let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
@@ -1132,7 +1137,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt =
depth t
in
let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in
- let new_env = Environ.push_rel (na,None,t') env in
+ let new_env = Environ.push_rel (LocalAssum (na,t')) env in
let new_b,id_to_exclude =
rebuild_cons new_env
nb_args relname
@@ -1212,13 +1217,13 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool)
if Array.for_all
(fun l ->
let (n',nt',is_defined') = List.nth l i in
- Name.equal n n' && Notation_ops.eq_glob_constr nt nt' && (is_defined : bool) == is_defined')
+ Name.equal n n' && glob_constr_eq nt nt' && (is_defined : bool) == is_defined')
rels_params
then
l := param::!l
)
rels_params.(0)
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
()
in
List.rev !l
@@ -1254,12 +1259,13 @@ let do_build_inductive
let relnames = Array.map mk_rel_id funnames in
let relnames_as_set = Array.fold_right Id.Set.add relnames Id.Set.empty in
(* Construction of the pseudo constructors *)
+ let open Context.Named.Declaration in
let evd,env =
Array.fold_right2
(fun id c (evd,env) ->
let evd,t = Typing.type_of env evd (mkConstU c) in
evd,
- Environ.push_named (id,None,t)
+ Environ.push_named (LocalAssum (id,t))
(* try *)
(* Typing.e_type_of env evd (mkConstU c) *)
(* with Not_found -> *)
@@ -1298,8 +1304,8 @@ let do_build_inductive
*)
let rel_arities = Array.mapi rel_arity funsargs in
Util.Array.fold_left2 (fun env rel_name rel_ar ->
- Environ.push_named (rel_name,None,
- fst (with_full_print (Constrintern.interp_constr env evd) rel_ar)) env) env relnames rel_arities
+ Environ.push_named (LocalAssum (rel_name,
+ fst (with_full_print (Constrintern.interp_constr env evd) rel_ar))) env) env relnames rel_arities
in
(* and of the real constructors*)
let constr i res =
@@ -1454,7 +1460,7 @@ let do_build_inductive
str "while trying to define"++ spc () ++
Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds))
++ fnl () ++
- Errors.print reraise
+ CErrors.print reraise
in
observe msg;
raise reraise
@@ -1470,7 +1476,7 @@ let build_inductive evd funconstants funsargs returned_types rtl =
do_build_inductive evd funconstants funsargs returned_types rtl;
Detyping.print_universes := pu;
Constrextern.print_universes := cu
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
Detyping.print_universes := pu;
Constrextern.print_universes := cu;
raise (Building_graph e)
diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml
index 291f835e..01e5ef7f 100644
--- a/plugins/funind/glob_termops.ml
+++ b/plugins/funind/glob_termops.ml
@@ -1,6 +1,6 @@
open Pp
open Glob_term
-open Errors
+open CErrors
open Util
open Names
open Decl_kinds
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index 3dbd4380..18817f50 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -1,4 +1,5 @@
-open Errors
+open Context.Rel.Declaration
+open CErrors
open Util
open Names
open Term
@@ -10,12 +11,13 @@ open Glob_term
open Declarations
open Misctypes
open Decl_kinds
+open Sigma.Notations
let is_rec_info scheme_info =
- let test_branche min acc (_,_,br) =
+ let test_branche min acc decl =
acc || (
let new_branche =
- it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in
+ it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (get_type decl))) in
let free_rels_in_br = Termops.free_rels new_branche in
let max = min + scheme_info.Tactics.npredicates in
Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br
@@ -85,7 +87,7 @@ let functional_induction with_clean c princl pat =
in
let encoded_pat_as_patlist =
List.make (List.length args + List.length c_list - 1) None @ [pat] in
- List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr (fun env sigma -> sigma,(c,NoBindings))),(None,pat),None))
+ List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None))
(args@c_list) encoded_pat_as_patlist
in
let princ' = Some (princ,bindings) in
@@ -112,7 +114,7 @@ let functional_induction with_clean c princl pat =
in
Tacticals.tclTHEN
(Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl )
- (Tactics.reduce flag Locusops.allHypsAndConcl)
+ (Proofview.V82.of_tactic (Tactics.reduce flag Locusops.allHypsAndConcl))
g
else Tacticals.tclIDTAC g
in
@@ -130,6 +132,7 @@ let rec abstract_glob_constr c = function
| Constrexpr.LocalRawAssum (idl,k,t)::bl ->
List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl
(abstract_glob_constr c bl)
+ | Constrexpr.LocalPattern _::bl -> assert false
let interp_casted_constr_with_implicits env sigma impls c =
Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls
@@ -152,7 +155,8 @@ let build_newrecursive
let evdref = ref (Evd.from_env env0) in
let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in
let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in
- (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls))
+ let open Context.Named.Declaration in
+ (Environ.push_named (LocalAssum (recname,arity)) env, Id.Map.add recname impl impls))
(env0,Constrintern.empty_internalization_env) lnameargsardef in
let recdef =
(* Declare local notations *)
@@ -212,6 +216,7 @@ let rec local_binders_length = function
| [] -> 0
| Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl
| Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl
+ | Constrexpr.LocalPattern _::bl -> assert false
let prepare_body ((name,_,args,types,_),_) rt =
let n = local_binders_length args in
@@ -220,7 +225,12 @@ let prepare_body ((name,_,args,types,_),_) rt =
(fun_args,rt')
let process_vernac_interp_error e =
- fst (Cerrors.process_vernac_interp_error (e, Exninfo.null))
+ fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))
+
+let warn_funind_cannot_build_inversion =
+ CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind"
+ (fun e' -> strbrk "Cannot build inversion information" ++
+ if do_observe () then (fnl() ++ CErrors.print e') else mt ())
let derive_inversion fix_names =
try
@@ -262,16 +272,22 @@ let derive_inversion fix_names =
functional_induction
fix_names_as_constant
lind;
- with e when Errors.noncritical e ->
- let e' = process_vernac_interp_error e in
- msg_warning
- (str "Cannot build inversion information" ++
- if do_observe () then (fnl() ++ Errors.print e') else mt ())
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
let e' = process_vernac_interp_error e in
- msg_warning
- (str "Cannot build inversion information (early)" ++
- if do_observe () then (fnl() ++ Errors.print e') else mt ())
+ warn_funind_cannot_build_inversion e'
+ with e when CErrors.noncritical e ->
+ let e' = process_vernac_interp_error e in
+ warn_funind_cannot_build_inversion e'
+
+let warn_cannot_define_graph =
+ CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind"
+ (fun (names,error) -> strbrk "Cannot define graph(s) for " ++
+ h 1 names ++ error)
+
+let warn_cannot_define_principle =
+ CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind"
+ (fun (names,error) -> strbrk "Cannot define induction principle(s) for "++
+ h 1 names ++ error)
let warning_error names e =
let e = process_vernac_interp_error e in
@@ -279,33 +295,29 @@ let warning_error names e =
match e with
| ToShow e ->
let e = process_vernac_interp_error e in
- spc () ++ Errors.print e
+ spc () ++ CErrors.print e
| _ ->
if do_observe ()
then
let e = process_vernac_interp_error e in
- (spc () ++ Errors.print e)
+ (spc () ++ CErrors.print e)
else mt ()
in
match e with
| Building_graph e ->
- Pp.msg_warning
- (str "Cannot define graph(s) for " ++
- h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
- e_explain e)
+ let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in
+ warn_cannot_define_graph (names,e_explain e)
| Defining_principle e ->
- Pp.msg_warning
- (str "Cannot define principle(s) for "++
- h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++
- e_explain e)
+ let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in
+ warn_cannot_define_principle (names,e_explain e)
| _ -> raise e
let error_error names e =
let e = process_vernac_interp_error e in
let e_explain e =
match e with
- | ToShow e -> spc () ++ Errors.print e
- | _ -> if do_observe () then (spc () ++ Errors.print e) else mt ()
+ | ToShow e -> spc () ++ CErrors.print e
+ | _ -> if do_observe () then (spc () ++ CErrors.print e) else mt ()
in
match e with
| Building_graph e ->
@@ -373,7 +385,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error
Array.iter (add_Function is_general) funs_kn;
()
end
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
on_error names e
let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) =
@@ -463,7 +475,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas
functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation
);
derive_inversion [fname]
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
(* No proof done *)
()
in
@@ -727,9 +739,9 @@ let rec add_args id new_args b =
List.map (fun (e,o) -> add_args id new_args e,o) bl)
| CCases(loc,sty,b_option,cel,cal) ->
CCases(loc,sty,Option.map (add_args id new_args) b_option,
- List.map (fun (b,(na,b_option)) ->
+ List.map (fun (b,na,b_option) ->
add_args id new_args b,
- (na, b_option)) cel,
+ na, 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) ->
@@ -751,10 +763,8 @@ let rec add_args id new_args b =
| CCast(loc,b1,b2) ->
CCast(loc,add_args id new_args b1,
Miscops.map_cast_type (add_args id new_args) b2)
- | CRecord (loc, w, pars) ->
- CRecord (loc,
- (match w with Some w -> Some (add_args id new_args w) | _ -> None),
- List.map (fun (e,o) -> e, add_args id new_args o) pars)
+ | CRecord (loc, pars) ->
+ CRecord (loc, List.map (fun (e,o) -> e, add_args id new_args o) pars)
| CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation")
| CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization")
| CPrim _ -> b
@@ -860,6 +870,7 @@ let make_graph (f_ref:global_reference) =
(fun (loc,n) ->
CRef(Libnames.Ident(loc, Nameops.out_name n),None))
nal
+ | Constrexpr.LocalPattern _ -> assert false
)
nal_tas
)
diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli
index e7206914..1c27bdfa 100644
--- a/plugins/funind/indfun.mli
+++ b/plugins/funind/indfun.mli
@@ -1,5 +1,9 @@
open Misctypes
+val warn_cannot_define_graph : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit
+
+val warn_cannot_define_principle : ?loc:Loc.t -> Pp.std_ppcmds * Pp.std_ppcmds -> unit
+
val do_generate_principle :
bool ->
(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list ->
diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml
index aa47e261..f56e9241 100644
--- a/plugins/funind/indfun_common.ml
+++ b/plugins/funind/indfun_common.ml
@@ -49,7 +49,7 @@ let locate_constant ref =
let locate_with_msg msg f x =
try f x
- with Not_found -> raise (Errors.UserError("", msg))
+ with Not_found -> raise (CErrors.UserError("", msg))
let filter_map filter f =
@@ -73,7 +73,7 @@ let chop_rlambda_n =
| Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b
| Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b
| _ ->
- raise (Errors.UserError("chop_rlambda_n",
+ raise (CErrors.UserError("chop_rlambda_n",
str "chop_rlambda_n: Not enough Lambdas"))
in
chop_lambda_n []
@@ -85,7 +85,7 @@ let chop_rprod_n =
else
match rt with
| Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b
- | _ -> raise (Errors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
+ | _ -> raise (CErrors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products"))
in
chop_prod_n []
@@ -110,7 +110,7 @@ let const_of_id id =
in
try Constrintern.locate_reference princ_ref
with Not_found ->
- Errors.errorlabstrm "IndFun.const_of_id"
+ CErrors.errorlabstrm "IndFun.const_of_id"
(str "cannot find " ++ Nameops.pr_id id)
let def_of_const t =
@@ -163,7 +163,7 @@ let save with_clean id const (locality,_,kind) hook =
(locality, ConstRef kn)
in
if with_clean then Pfedit.delete_current_proof ();
- Ephemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r);
+ CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r);
definition_message id
@@ -344,7 +344,7 @@ let pr_info f_info =
(try
Printer.pr_lconstr
(Global.type_of_global_unsafe (ConstRef f_info.function_constant))
- with e when Errors.noncritical e -> mt ()) ++ fnl () ++
+ with e when CErrors.noncritical e -> mt ()) ++ fnl () ++
str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++
str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++
str "correctness_lemma := " ++ pr_ocst f_info.correctness_lemma ++ fnl () ++
@@ -371,7 +371,7 @@ let in_Function : function_info -> Libobject.obj =
let find_or_none id =
try Some
- (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Errors.anomaly (Pp.str "Not a constant")
+ (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant")
)
with Not_found -> None
@@ -399,7 +399,7 @@ let add_Function is_general f =
and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind")
and graph_ind =
match Nametab.locate (qualid_of_ident (mk_rel_id f_id))
- with | IndRef ind -> ind | _ -> Errors.anomaly (Pp.str "Not an inductive")
+ with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive")
in
let finfos =
{ function_constant = f;
@@ -476,13 +476,13 @@ let jmeq () =
try
Coqlib.check_required_library Coqlib.jmeq_module_name;
Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq"
- with e when Errors.noncritical e -> raise (ToShow e)
+ with e when CErrors.noncritical e -> raise (ToShow e)
let jmeq_refl () =
try
Coqlib.check_required_library Coqlib.jmeq_module_name;
Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl"
- with e when Errors.noncritical e -> raise (ToShow e)
+ with e when CErrors.noncritical e -> raise (ToShow e)
let h_intros l =
tclMAP (fun x -> Proofview.V82.of_tactic (Tactics.Simple.intro x)) l
diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli
index 23f1da1b..e5c756f5 100644
--- a/plugins/funind/indfun_common.mli
+++ b/plugins/funind/indfun_common.mli
@@ -47,7 +47,7 @@ val jmeq : unit -> Term.constr
val jmeq_refl : unit -> Term.constr
val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind ->
- unit Lemmas.declaration_hook Ephemeron.key -> unit
+ unit Lemmas.declaration_hook CEphemeron.key -> unit
(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and
abort the proof
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index a800c186..26fc88a6 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -5,9 +5,10 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+
open Tacexpr
open Declarations
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -19,6 +20,8 @@ open Tactics
open Indfun_common
open Tacmach
open Misctypes
+open Termops
+open Context.Rel.Declaration
(* Some pretty printing function for debugging purpose *)
@@ -50,7 +53,7 @@ let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds =
let observe strm =
if do_observe ()
- then Pp.msg_debug strm
+ then Feedback.msg_debug strm
else ()
(*let observennl strm =
@@ -62,16 +65,16 @@ let observe strm =
let do_observe_tac s tac g =
let goal =
try Printer.pr_goal g
- with e when Errors.noncritical e -> assert false
+ with e when CErrors.noncritical e -> assert false
in
try
let v = tac g in
msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v
with reraise ->
- let reraise = Errors.push reraise in
- let e = Cerrors.process_vernac_interp_error reraise in
- observe (str "observation "++ s++str " raised exception " ++
- Errors.iprint e ++ str " on goal " ++ goal );
+ let reraise = CErrors.push reraise in
+ let e = ExplainErr.process_vernac_interp_error reraise in
+ observe (hov 0 (str "observation "++ s++str " raised exception " ++
+ CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal ));
iraise reraise;;
@@ -87,10 +90,11 @@ let observe_tac s tac g =
(* [nf_zeta] $\zeta$-normalization of a term *)
let nf_zeta =
- Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+ Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
Environ.empty_env
Evd.empty
+let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl
(* (\* [id_to_constr id] finds the term associated to [id] in the global environment *\) *)
(* let id_to_constr id = *)
@@ -133,18 +137,21 @@ let generate_type evd g_to_f f graph i =
let fun_ctxt,res_type =
match ctxt with
| [] | [_] -> anomaly (Pp.str "Not a valid context")
- | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type
+ | decl :: fun_ctxt -> fun_ctxt, get_type decl
in
let rec args_from_decl i accu = function
| [] -> accu
- | (_, Some _, _) :: l ->
+ | LocalDef _ :: l ->
args_from_decl (succ i) accu l
| _ :: l ->
let t = mkRel i in
args_from_decl (succ i) (t :: accu) l
in
(*i We need to name the vars [res] and [fv] i*)
- let filter = function (Name id,_,_) -> Some id | (Anonymous,_,_) -> None in
+ let filter = fun decl -> match get_name decl with
+ | Name id -> Some id
+ | Anonymous -> None
+ in
let named_ctxt = List.map_filter filter fun_ctxt in
let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in
let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (res_id :: named_ctxt) in
@@ -170,12 +177,12 @@ let generate_type evd g_to_f f graph i =
\[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \]
i*)
let pre_ctxt =
- (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(f,args_as_rels)),res_type)::fun_ctxt
+ LocalAssum (Name res_id, lift 1 res_type) :: LocalDef (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt
in
(*i and we can return the solution depending on which lemma type we are defining i*)
if g_to_f
- then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph
- else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph
+ then LocalAssum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph
+ else LocalAssum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph
(*
@@ -259,10 +266,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
(* and built the intro pattern for each of them *)
let intro_pats =
List.map
- (fun (_,_,br_type) ->
+ (fun decl ->
List.map
(fun id -> Loc.ghost, IntroNaming (IntroIdentifier id))
- (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum br_type))))
+ (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (get_type decl)))))
)
branches
in
@@ -358,18 +365,18 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
observe_tac("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in
match l with
| [] -> tclIDTAC
- | _ -> Proofview.V82.of_tactic (intro_patterns l));
+ | _ -> Proofview.V82.of_tactic (intro_patterns false l));
(* unfolding of all the defined variables introduced by this branch *)
(* observe_tac "unfolding" pre_tac; *)
(* $zeta$ normalizing of the conclusion *)
- reduce
+ Proofview.V82.of_tactic (reduce
(Genredexpr.Cbv
{ Redops.all_flags with
Genredexpr.rDelta = false ;
Genredexpr.rConst = []
}
)
- Locusops.onConcl;
+ Locusops.onConcl);
observe_tac ("toto ") tclIDTAC;
(* introducing the the result of the graph and the equality hypothesis *)
@@ -389,10 +396,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
(fun ((_,(ctxt,concl))) ->
match ctxt with
| [] | [_] | [_;_] -> anomaly (Pp.str "bad context")
- | hres::res::(x,_,t)::ctxt ->
+ | hres::res::decl::ctxt ->
let res = Termops.it_mkLambda_or_LetIn
(Termops.it_mkProd_or_LetIn concl [hres;res])
- ((x,None,t)::ctxt)
+ (LocalAssum (get_name decl, get_type decl) :: ctxt)
in
res
)
@@ -407,8 +414,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
let bindings =
let params_bindings,avoid =
List.fold_left2
- (fun (bindings,avoid) (x,_,_) p ->
- let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+ (fun (bindings,avoid) decl p ->
+ let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in
p::bindings,id::avoid
)
([],pf_ids_of_hyps g)
@@ -417,8 +424,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
in
let lemmas_bindings =
List.rev (fst (List.fold_left2
- (fun (bindings,avoid) (x,_,_) p ->
- let id = Namegen.next_ident_away (Nameops.out_name x) avoid in
+ (fun (bindings,avoid) decl p ->
+ let id = Namegen.next_ident_away (Nameops.out_name (get_name decl)) avoid in
(nf_zeta p)::bindings,id::avoid)
([],avoid)
princ_infos.predicates
@@ -454,10 +461,11 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes
generalize every hypothesis which depends of [x] but [hyp]
*)
let generalize_dependent_of x hyp g =
+ let open Context.Named.Declaration in
tclMAP
(function
- | (id,None,t) when not (Id.equal id hyp) &&
- (Termops.occur_var (pf_env g) x t) -> tclTHEN (Tactics.Simple.generalize [mkVar id]) (thin [id])
+ | LocalAssum (id,t) when not (Id.equal id hyp) &&
+ (Termops.occur_var (pf_env g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id])
| _ -> tclIDTAC
)
(pf_hyps g)
@@ -467,6 +475,15 @@ let generalize_dependent_of x hyp g =
(* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis
(unfolding, substituting, destructing cases \ldots)
*)
+let tauto =
+ let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in
+ let mp = ModPath.MPfile (DirPath.make dp) in
+ let kn = KerName.make2 mp (Label.make "tauto") in
+ Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () ->
+ let body = Tacenv.interp_ltac kn in
+ Tacinterp.eval_tactic body
+ end
+
let rec intros_with_rewrite g =
observe_tac "intros_with_rewrite" intros_with_rewrite_aux g
and intros_with_rewrite_aux : tactic =
@@ -483,15 +500,15 @@ and intros_with_rewrite_aux : tactic =
tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g
else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g))
then tclTHENSEQ[
- unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))];
- tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) ))
+ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]);
+ tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) )))
(pf_ids_of_hyps g);
intros_with_rewrite
] g
else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g))
then tclTHENSEQ[
- unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))];
- tclMAP (fun id -> tclTRY(unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) ))
+ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]);
+ tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) )))
(pf_ids_of_hyps g);
intros_with_rewrite
] g
@@ -523,7 +540,7 @@ and intros_with_rewrite_aux : tactic =
] g
end
| Ind _ when eq_constr t (Coqlib.build_coq_False ()) ->
- Proofview.V82.of_tactic Tauto.tauto g
+ Proofview.V82.of_tactic tauto g
| Case(_,_,v,_) ->
tclTHENSEQ[
Proofview.V82.of_tactic (simplest_case v);
@@ -531,12 +548,12 @@ and intros_with_rewrite_aux : tactic =
] g
| LetIn _ ->
tclTHENSEQ[
- reduce
+ Proofview.V82.of_tactic (reduce
(Genredexpr.Cbv
{Redops.all_flags
with Genredexpr.rDelta = false;
})
- Locusops.onConcl
+ Locusops.onConcl)
;
intros_with_rewrite
] g
@@ -546,12 +563,12 @@ and intros_with_rewrite_aux : tactic =
end
| LetIn _ ->
tclTHENSEQ[
- reduce
+ Proofview.V82.of_tactic (reduce
(Genredexpr.Cbv
{Redops.all_flags
with Genredexpr.rDelta = false;
})
- Locusops.onConcl
+ Locusops.onConcl)
;
intros_with_rewrite
] g
@@ -568,7 +585,7 @@ let rec reflexivity_with_destruct_cases g =
observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases
]
| _ -> Proofview.V82.of_tactic reflexivity
- with e when Errors.noncritical e -> Proofview.V82.of_tactic reflexivity
+ with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity
in
let eq_ind = make_eq () in
let discr_inject =
@@ -662,10 +679,10 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
let branches = List.rev princ_infos.branches in
let intro_pats =
List.map
- (fun (_,_,br_type) ->
+ (fun decl ->
List.map
(fun id -> id)
- (generate_fresh_id (Id.of_string "y") ids (nb_prod br_type))
+ (generate_fresh_id (Id.of_string "y") ids (nb_prod (get_type decl)))
)
branches
in
@@ -691,18 +708,18 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma));
(* Don't forget to $\zeta$ normlize the term since the principles
have been $\zeta$-normalized *)
- reduce
+ Proofview.V82.of_tactic (reduce
(Genredexpr.Cbv
{Redops.all_flags
with Genredexpr.rDelta = false;
})
- Locusops.onConcl
+ Locusops.onConcl)
;
- Simple.generalize (List.map mkVar ids);
+ Proofview.V82.of_tactic (generalize (List.map mkVar ids));
thin ids
]
else
- unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]
+ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))])
in
(* The proof of each branche itself *)
let ind_number = ref 0 in
@@ -737,7 +754,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic =
tclTHENSEQ
[ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]);
observe_tac "h_generalize"
- (Simple.generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]);
+ (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]));
Proofview.V82.of_tactic (Simple.intro graph_principle_id);
observe_tac "" (tclTHEN_i
(observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings)))))
@@ -920,7 +937,7 @@ let revert_graph kn post_tac hid g =
let f_args,res = Array.chop (Array.length args - 1) args in
tclTHENSEQ
[
- Simple.generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])];
+ Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]);
thin [hid];
Proofview.V82.of_tactic (Simple.intro hid);
post_tac hid
@@ -964,7 +981,7 @@ let functional_inversion kn hid fconst f_correct : tactic =
in
tclTHENSEQ[
pre_tac hid;
- Simple.generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])];
+ Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]);
thin [hid];
Proofview.V82.of_tactic (Simple.intro hid);
Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid));
@@ -981,7 +998,7 @@ let invfun qhyp f =
let f =
match f with
| ConstRef f -> f
- | _ -> raise (Errors.UserError("",str "Not a function"))
+ | _ -> raise (CErrors.UserError("",str "Not a function"))
in
try
let finfos = find_Function_infos f in
diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml
index 87d7ca76..de4210af 100644
--- a/plugins/funind/merge.ml
+++ b/plugins/funind/merge.ml
@@ -11,7 +11,7 @@
open Globnames
open Tactics
open Indfun_common
-open Errors
+open CErrors
open Util
open Constrexpr
open Vernacexpr
@@ -19,12 +19,12 @@ open Pp
open Names
open Term
open Vars
-open Context
open Termops
open Declarations
open Glob_term
open Glob_termops
open Decl_kinds
+open Context.Rel.Declaration
(** {1 Utilities} *)
@@ -73,7 +73,7 @@ let ident_global_exist id =
let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in
let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in
true
- with e when Errors.noncritical e -> false
+ with e when CErrors.noncritical e -> false
(** [next_ident_fresh id] returns a fresh identifier (ie not linked in
global env) with base [id]. *)
@@ -135,9 +135,9 @@ let showind (id:Id.t) =
let cstrid = Constrintern.global_reference id in
let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in
let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in
- List.iter (fun (nm, optcstr, tp) ->
- print_string (string_of_name nm^":");
- prconstr tp; print_string "\n")
+ List.iter (fun decl ->
+ print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":");
+ prconstr (get_type decl); print_string "\n")
ib1.mind_arity_ctxt;
Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1);
Array.iteri
@@ -258,27 +258,27 @@ type merge_infos =
lnk2: int merged_arg array;
(** rec params which remain rec param (ie not linked) *)
- recprms1: rel_declaration list;
- recprms2: rel_declaration list;
+ recprms1: Context.Rel.Declaration.t list;
+ recprms2: Context.Rel.Declaration.t list;
nrecprms1: int;
nrecprms2: int;
(** rec parms which became non parm (either linked to something
or because after a rec parm that became non parm) *)
- otherprms1: rel_declaration list;
- otherprms2: rel_declaration list;
+ otherprms1: Context.Rel.Declaration.t list;
+ otherprms2: Context.Rel.Declaration.t list;
notherprms1:int;
notherprms2:int;
(** args which remain args in merge *)
- args1:rel_declaration list;
- args2:rel_declaration list;
+ args1:Context.Rel.Declaration.t list;
+ args2:Context.Rel.Declaration.t list;
nargs1:int;
nargs2:int;
(** functional result args *)
- funresprms1: rel_declaration list;
- funresprms2: rel_declaration list;
+ funresprms1: Context.Rel.Declaration.t list;
+ funresprms2: Context.Rel.Declaration.t list;
nfunresprms1:int;
nfunresprms2:int;
}
@@ -460,11 +460,12 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array
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")
+ List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : ");
+ prconstr (get_type decl); prstr "\n")
otherprms1 in
let _ = prstr "\notherprms2:\n" in
let _ =
- List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n")
+ List.iter (fun decl -> prstr (string_of_name (get_name decl) ^ " : "); prconstr (get_type decl); prstr "\n")
otherprms2 in
{
ident=id;
@@ -503,19 +504,19 @@ 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
| GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 ->
- let _ = prstr "\nICI1!\n";Pp.flush_all() in
+ let _ = prstr "\nICI1!\n" in
let args = filter_shift_stable lnk (arr1 @ arr2) in
GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args)
| GApp(_,f1, arr1), GApp(_,f2,arr2) -> raise NoMerge
| GLetIn(_,nme,bdy,trm) , _ ->
- let _ = prstr "\nICI2!\n";Pp.flush_all() in
+ let _ = prstr "\nICI2!\n" in
let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in
GLetIn(Loc.ghost,nme,bdy,newtrm)
| _, GLetIn(_,nme,bdy,trm) ->
- let _ = prstr "\nICI3!\n";Pp.flush_all() in
+ let _ = prstr "\nICI3!\n" in
let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in
GLetIn(Loc.ghost,nme,bdy,newtrm)
- | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in
+ | _ -> let _ = prstr "\nICI4!\n" in
raise NoMerge
let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
@@ -526,14 +527,14 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable =
GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args)
(* FIXME: what if the function appears in the body of the let? *)
| GLetIn(_,nme,bdy,trm) , _ ->
- let _ = prstr "\nICI2 '!\n";Pp.flush_all() in
+ let _ = prstr "\nICI2 '!\n" in
let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in
GLetIn(Loc.ghost,nme,bdy,newtrm)
| _, GLetIn(_,nme,bdy,trm) ->
- let _ = prstr "\nICI3 '!\n";Pp.flush_all() in
+ let _ = prstr "\nICI3 '!\n" in
let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in
GLetIn(Loc.ghost,nme,bdy,newtrm)
- | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge
+ | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge
@@ -784,10 +785,10 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body)
let params1 =
try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1))
- with e when Errors.noncritical e -> [] in
+ with e when CErrors.noncritical e -> [] in
let params2 =
try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2))
- with e when Errors.noncritical e -> [] in
+ with e when CErrors.noncritical e -> [] in
let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in
let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in
@@ -824,9 +825,11 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) =
let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in
let arity,_ =
List.fold_left
- (fun (acc,env) (nm,_,c) ->
+ (fun (acc,env) decl ->
+ let nm = Context.Rel.Declaration.get_name decl in
+ let c = get_type decl in
let typ = Constrextern.extern_constr false env Evd.empty c in
- let newenv = Environ.push_rel (nm,None,c) env in
+ let newenv = Environ.push_rel (LocalAssum (nm,c)) env in
CProdN (Loc.ghost, [[(Loc.ghost,nm)],Constrexpr_ops.default_binder_kind,typ] , acc) , newenv)
(concl,Global.env())
(shift.funresprms2 @ shift.funresprms1
@@ -851,12 +854,12 @@ let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift
lident , bindlist , Some cstr_expr , lcstor_expr
-let mkProd_reldecl (rdecl:rel_declaration) (t2:glob_constr) =
+let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) =
match rdecl with
- | (nme,None,t) ->
+ | LocalAssum (nme,t) ->
let traw = Detyping.detype false [] (Global.env()) Evd.empty t in
GProd (Loc.ghost,nme,Explicit,traw,t2)
- | (_,Some _,_) -> assert false
+ | LocalDef _ -> assert false
(** [merge_inductive ind1 ind2 lnk] merges two graphs, linking
@@ -970,7 +973,7 @@ let funify_branches relinfo nfuns branch =
| Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches)
| _ -> false in
(* FIXME: *)
- (Anonymous,Some mkProp,mkProp)
+ LocalDef (Anonymous,mkProp,mkProp)
let relprinctype_to_funprinctype relprinctype nfuns =
diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml
index 065d0fe5..fa84e4dd 100644
--- a/plugins/funind/recdef.ml
+++ b/plugins/funind/recdef.ml
@@ -16,7 +16,7 @@ open Names
open Libnames
open Globnames
open Nameops
-open Errors
+open CErrors
open Util
open Tacticals
open Tacmach
@@ -29,6 +29,7 @@ open Proof_type
open Pfedit
open Glob_term
open Pretyping
+open Termops
open Constrintern
open Misctypes
open Genredexpr
@@ -38,7 +39,8 @@ open Auto
open Eauto
open Indfun_common
-
+open Sigma.Notations
+open Context.Rel.Declaration
(* Ugly things which should not be here *)
@@ -90,15 +92,15 @@ let const_of_ref = function
let nf_zeta env =
- Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA])
+ Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA])
env
Evd.empty
let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *)
let clos_norm_flags flgs env sigma t =
- Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in
- clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty
+ CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in
+ clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty
@@ -159,7 +161,7 @@ let rec n_x_id ids n =
let simpl_iter clause =
reduce
(Lazy
- {rBeta=true;rIota=true;rZeta= true; rDelta=false;
+ {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=true;rDelta=false;
rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]})
clause
@@ -179,7 +181,7 @@ let (value_f:constr list -> global_reference -> constr) =
)
in
let context = List.map
- (fun (x, c) -> Name x, None, c) (List.combine rev_x_id_l (List.rev al))
+ (fun (x, c) -> LocalAssum (Name x, c)) (List.combine rev_x_id_l (List.rev al))
in
let env = Environ.push_rel_context context (Global.env ()) in
let glob_body =
@@ -206,23 +208,23 @@ let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> glob
(* Debugging mechanism *)
let debug_queue = Stack.create ()
-let rec print_debug_queue b e =
+let print_debug_queue b e =
if not (Stack.is_empty debug_queue)
then
begin
let lmsg,goal = Stack.pop debug_queue in
if b then
- Pp.msg_debug (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal " ++ goal)
+ Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal))
else
begin
- Pp.msg_debug (str " from " ++ lmsg ++ str " on goal " ++ goal);
+ Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal));
end;
(* print_debug_queue false e; *)
end
let observe strm =
if do_observe ()
- then Pp.msg_debug strm
+ then Feedback.msg_debug strm
else ()
@@ -236,9 +238,9 @@ let do_observe_tac s tac g =
ignore(Stack.pop debug_queue);
v
with reraise ->
- let reraise = Errors.push reraise in
+ let reraise = CErrors.push reraise in
if not (Stack.is_empty debug_queue)
- then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise));
+ then print_debug_queue true (fst (ExplainErr.process_vernac_interp_error reraise));
iraise reraise
let observe_tac s tac g =
@@ -265,8 +267,8 @@ let observe_tclTHENLIST s tacl =
let tclUSER tac is_mes l g =
let clear_tac =
match l with
- | None -> clear []
- | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l)
+ | None -> tclIDTAC
+ | Some l -> tclMAP (fun id -> tclTRY (Proofview.V82.of_tactic (clear [id]))) (List.rev l)
in
observe_tclTHENLIST (str "tclUSER1")
[
@@ -274,8 +276,8 @@ let tclUSER tac is_mes l g =
if is_mes
then observe_tclTHENLIST (str "tclUSER2")
[
- unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference
- (delayed_force Indfun_common.ltof_ref))];
+ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference
+ (delayed_force Indfun_common.ltof_ref))]);
tac
]
else tac
@@ -397,7 +399,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic =
Proofview.V82.of_tactic (intro_using teq_id);
onLastHypId (fun heq ->
observe_tclTHENLIST (str "treat_case2")[
- thin to_intros;
+ Proofview.V82.of_tactic (clear to_intros);
h_intros to_intros;
(fun g' ->
let ty_teq = pf_unsafe_type_of g' (mkVar heq) in
@@ -439,7 +441,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) =
try
check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
jinfo.otherS () expr_info continuation_tac expr_info
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id)
end
| Lambda(n,t,b) ->
@@ -447,7 +449,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) =
try
check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info;
jinfo.otherS () expr_info continuation_tac expr_info
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id)
end
| Case(ci,t,a,l) ->
@@ -558,12 +560,12 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g =
Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|])));
Proofview.V82.of_tactic default_full_auto];
observe_tclTHENLIST (str "destruct_bounds_aux2")[
- observe_tac (str "clearing k ") (clear [id]);
+ observe_tac (str "clearing k ") (Proofview.V82.of_tactic (clear [id]));
h_intros [k;h';def];
- observe_tac (str "simple_iter") (simpl_iter Locusops.onConcl);
+ observe_tac (str "simple_iter") (Proofview.V82.of_tactic (simpl_iter Locusops.onConcl));
observe_tac (str "unfold functional")
- (unfold_in_concl[(Locus.OnlyOccurrences [1],
- evaluable_of_global_reference infos.func)]);
+ (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1],
+ evaluable_of_global_reference infos.func)]));
(
observe_tclTHENLIST (str "test")[
list_rewrite true
@@ -587,7 +589,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g =
| (_,v_bound)::l ->
observe_tclTHENLIST (str "destruct_bounds_aux3")[
Proofview.V82.of_tactic (simplest_elim (mkVar v_bound));
- clear [v_bound];
+ Proofview.V82.of_tactic (clear [v_bound]);
tclDO 2 (Proofview.V82.of_tactic intro);
onNthHypId 1
(fun p_hyp ->
@@ -643,7 +645,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info =
try
check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b;
true
- with e when Errors.noncritical e -> false
+ with e when CErrors.noncritical e -> false
in
if forbid
then
@@ -676,8 +678,10 @@ let mkDestructEq :
let hyps = pf_hyps g in
let to_revert =
Util.List.map_filter
- (fun (id, _, t) ->
- if Id.List.mem id not_on_hyp || not (Termops.occur_term expr t)
+ (fun decl ->
+ let open Context.Named.Declaration in
+ let id = get_id decl in
+ if Id.List.mem id not_on_hyp || not (Termops.occur_term expr (get_type decl))
then None else Some id) hyps in
let to_revert_constr = List.rev_map mkVar to_revert in
let type_of_expr = pf_unsafe_type_of g expr in
@@ -685,11 +689,13 @@ let mkDestructEq :
to_revert_constr in
pf_typel new_hyps (fun _ ->
observe_tclTHENLIST (str "mkDestructEq")
- [Simple.generalize new_hyps;
+ [Proofview.V82.of_tactic (generalize new_hyps);
(fun g2 ->
- Proofview.V82.of_tactic (change_in_concl None
- (fun patvars sigma ->
- pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2))) g2);
+ let changefun patvars = { run = fun sigma ->
+ let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in
+ redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2)
+ } in
+ Proofview.V82.of_tactic (change_in_concl None changefun) g2);
Proofview.V82.of_tactic (simplest_case expr)]), to_revert
@@ -698,7 +704,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g =
try
check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a;
false
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
true
in
let a' = infos.info in
@@ -897,10 +903,10 @@ let make_rewrite expr_info l hp max =
[observe_tac(str "make_rewrite finalize") (
(* tclORELSE( h_reflexivity) *)
(observe_tclTHENLIST (str "make_rewrite")[
- simpl_iter Locusops.onConcl;
+ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl);
observe_tac (str "unfold functional")
- (unfold_in_concl[(Locus.OnlyOccurrences [1],
- evaluable_of_global_reference expr_info.func)]);
+ (Proofview.V82.of_tactic (unfold_in_concl[(Locus.OnlyOccurrences [1],
+ evaluable_of_global_reference expr_info.func)]));
(list_rewrite true
(List.map (fun e -> mkVar e,true) expr_info.eqs));
@@ -942,7 +948,7 @@ let rec destruct_hex expr_info acc l =
| (v,hex)::l ->
observe_tclTHENLIST (str "destruct_hex")[
Proofview.V82.of_tactic (simplest_case (mkVar hex));
- clear [hex];
+ Proofview.V82.of_tactic (clear [hex]);
tclDO 2 (Proofview.V82.of_tactic intro);
onNthHypId 1 (fun hp ->
onNthHypId 2 (fun p ->
@@ -1110,10 +1116,10 @@ let termination_proof_header is_mes input_type ids args_id relation
[observe_tac (str "generalize")
(onNLastHypsId (nargs+1)
(tclMAP (fun id ->
- tclTHEN (Tactics.Simple.generalize [mkVar id]) (clear [id]))
+ tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id])))
))
;
- observe_tac (str "fix") (fix (Some hrec) (nargs+1));
+ observe_tac (str "fix") (Proofview.V82.of_tactic (fix (Some hrec) (nargs+1)));
h_intros args_id;
Proofview.V82.of_tactic (Simple.intro wf_rec_arg);
observe_tac (str "tac") (tac wf_rec_arg hrec wf_rec_arg acc_inv)
@@ -1248,7 +1254,7 @@ let clear_goals =
then Termops.pop b'
else if b' == b then t
else mkProd(na,t',b')
- | _ -> map_constr clear_goal t
+ | _ -> Term.map_constr clear_goal t
in
List.map clear_goal
@@ -1275,12 +1281,12 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
| Some s -> s
| None ->
try add_suffix current_proof_name "_subproof"
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
anomaly (Pp.str "open_new_goal with an unamed theorem")
in
let na = next_global_ident_away name [] in
if Termops.occur_existential gls_type then
- Errors.error "\"abstract\" cannot handle existentials";
+ CErrors.error "\"abstract\" cannot handle existentials";
let hook _ _ =
let opacity =
let na_ref = Libnames.Ident (Loc.ghost,na) in
@@ -1300,7 +1306,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in
observe_tclTHENLIST (str "")
[
- Simple.generalize [lemma];
+ Proofview.V82.of_tactic (generalize [lemma]);
Proofview.V82.of_tactic (Simple.intro hid);
(fun g ->
let ids = pf_ids_of_hyps g in
@@ -1327,10 +1333,10 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp
tclFIRST[
tclTHEN
(Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)))
- e_assumption;
+ (Proofview.V82.of_tactic e_assumption);
Eauto.eauto_with_bases
(true,5)
- [Evd.empty,Lazy.force refl_equal]
+ [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}]
[Hints.Hint_db.empty empty_transparent_state false]
]
)
@@ -1420,7 +1426,7 @@ let start_equation (f:global_reference) (term_f:global_reference)
let x = n_x_id ids nargs in
observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [
h_intros x;
- unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)];
+ Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]);
observe_tac (str "simplest_case")
(Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr,
Array.of_list (List.map mkVar x)))));
@@ -1484,7 +1490,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
let env = Global.env() in
let evd = ref (Evd.from_env env) in
let function_type = interp_type_evars env evd type_of_f in
- let env = push_named (function_name,None,function_type) env in
+ let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in
(* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *)
let ty = interp_type_evars env evd ~impls:rec_impls eq in
let evm, nf = Evarutil.nf_evars_and_universes !evd in
@@ -1492,7 +1498,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
let function_type = nf function_type in
(* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *)
let res_vars,eq' = decompose_prod equation_lemma_type in
- let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in
+ let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in
let eq' = nf_zeta env_eq' eq' in
let res =
(* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *)
@@ -1510,29 +1516,31 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num
let functional_id = add_suffix function_name "_F" in
let term_id = add_suffix function_name "_terminate" in
let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(snd (Evd.universe_context evm)) res in
- let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in
- let relation =
- fst (*FIXME*)(interp_constr
- env_with_pre_rec_args
- (Evd.from_env env_with_pre_rec_args)
- r)
+ (* Refresh the global universes, now including those of _F *)
+ let evm = Evd.from_env (Global.env ()) in
+ let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> LocalAssum (x,t)) pre_rec_args) env in
+ let relation, evuctx =
+ interp_constr env_with_pre_rec_args evm r
in
+ let evm = Evd.from_ctx evuctx in
let tcc_lemma_name = add_suffix function_name "_tcc" in
let tcc_lemma_constr = ref None in
(* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *)
let hook _ _ =
let term_ref = Nametab.locate (qualid_of_ident term_id) in
let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in
- let _ = Table.extraction_inline true [Ident (Loc.ghost,term_id)] in
+ let _ = Extraction_plugin.Table.extraction_inline true [Ident (Loc.ghost,term_id)] in
(* message "start second proof"; *)
let stop =
try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type);
false
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
begin
if do_observe ()
- then msg_debug (str "Cannot create equation Lemma " ++ Errors.print e)
- else anomaly (Pp.str "Cannot create equation Lemma")
+ then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e)
+ else CErrors.errorlabstrm "Cannot create equation Lemma"
+ (str "Cannot create equation lemma." ++ spc () ++
+ str "This may be because the function is nested-recursive.")
;
true
end
diff --git a/plugins/funind/recdef_plugin.mllib b/plugins/funind/recdef_plugin.mlpack
index ec1f5436..2b443f2a 100644
--- a/plugins/funind/recdef_plugin.mllib
+++ b/plugins/funind/recdef_plugin.mlpack
@@ -8,4 +8,3 @@ Invfun
Indfun
Merge
G_indfun
-Recdef_plugin_mod
diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v
index a19e9df9..7e3ef892 100644
--- a/plugins/micromega/Env.v
+++ b/plugins/micromega/Env.v
@@ -93,7 +93,7 @@ End S.
Ltac jump_simpl :=
repeat
match goal with
- | |- appcontext [jump xH] => rewrite (jump_simpl xH)
- | |- appcontext [jump (xO ?p)] => rewrite (jump_simpl (xO p))
- | |- appcontext [jump (xI ?p)] => rewrite (jump_simpl (xI p))
+ | |- context [jump xH] => rewrite (jump_simpl xH)
+ | |- context [jump (xO ?p)] => rewrite (jump_simpl (xO p))
+ | |- context [jump (xI ?p)] => rewrite (jump_simpl (xI p))
end.
diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v
index fd4bb248..904ee4da 100644
--- a/plugins/micromega/EnvRing.v
+++ b/plugins/micromega/EnvRing.v
@@ -914,7 +914,7 @@ Qed.
revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros.
- discriminate.
- assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst.
- * injection H; intros <-. rewrite <- PSubstL1_ok; intuition.
+ * injection H as <-. rewrite <- PSubstL1_ok; intuition.
* now apply IH.
Qed.
diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v
index 3e58e81a..47b6f7c7 100644
--- a/plugins/micromega/Lia.v
+++ b/plugins/micromega/Lia.v
@@ -8,7 +8,7 @@
(* *)
(* Micromega: A reflexive tactic using the Positivstellensatz *)
(* *)
-(* Frédéric Besson (Irisa/Inria) 2013 *)
+(* Frédéric Besson (Irisa/Inria) 2013-2016 *)
(* *)
(************************************************************************)
@@ -16,27 +16,27 @@ Require Import ZMicromega.
Require Import ZArith.
Require Import RingMicromega.
Require Import VarMap.
-Require Tauto.
+Require Coq.micromega.Tauto.
Declare ML Module "micromega_plugin".
+
Ltac preprocess :=
zify ; unfold Z.succ in * ; unfold Z.pred in *.
-Ltac lia :=
- preprocess;
- xlia ;
- abstract (
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
- apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
-
-Ltac nia :=
- preprocess;
- xnlia ;
- abstract (
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
- apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+Ltac zchange :=
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
+ apply (ZTautoChecker_sound __ff __wit).
+
+Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity.
+
+Ltac zchecker_abstract := zchange ; vm_cast_no_check (eq_refl true).
+
+Ltac zchecker := zchecker_no_abstract.
+
+Ltac lia := preprocess; xlia zchecker.
+
+Ltac nia := preprocess; xnlia zchecker.
(* Local Variables: *)
diff --git a/plugins/micromega/Lqa.v b/plugins/micromega/Lqa.v
new file mode 100644
index 00000000..acd2751a
--- /dev/null
+++ b/plugins/micromega/Lqa.v
@@ -0,0 +1,51 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \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) 2016 *)
+(* *)
+(************************************************************************)
+
+Require Import QMicromega.
+Require Import QArith.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Coq.micromega.Tauto.
+Declare ML Module "micromega_plugin".
+
+Ltac rchange :=
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
+ apply (QTautoChecker_sound __ff __wit).
+
+Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity.
+Ltac rchecker_abstract := rchange ; vm_cast_no_check (eq_refl true).
+
+Ltac rchecker := rchecker_no_abstract.
+
+(** Here, lra stands for linear rational arithmetic *)
+Ltac lra := lra_Q rchecker.
+
+(** Here, nra stands for non-linear rational arithmetic *)
+Ltac nra := xnqa rchecker.
+
+Ltac xpsatz dom d :=
+ let tac := lazymatch dom with
+ | Q =>
+ ((sos_Q rchecker) || (psatz_Q d rchecker))
+ | _ => fail "Unsupported domain"
+ end in tac.
+
+Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
+Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1).
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/Lra.v b/plugins/micromega/Lra.v
new file mode 100644
index 00000000..5b97d8ed
--- /dev/null
+++ b/plugins/micromega/Lra.v
@@ -0,0 +1,52 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \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) 2016 *)
+(* *)
+(************************************************************************)
+
+Require Import RMicromega.
+Require Import QMicromega.
+Require Import Rdefinitions.
+Require Import RingMicromega.
+Require Import VarMap.
+Require Coq.micromega.Tauto.
+Declare ML Module "micromega_plugin".
+
+Ltac rchange :=
+ intros __wit __varmap __ff ;
+ change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
+ apply (RTautoChecker_sound __ff __wit).
+
+Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity.
+Ltac rchecker_abstract := rchange ; vm_cast_no_check (eq_refl true).
+
+Ltac rchecker := rchecker_no_abstract.
+
+(** Here, lra stands for linear real arithmetic *)
+Ltac lra := unfold Rdiv in * ; lra_R rchecker.
+
+(** Here, nra stands for non-linear real arithmetic *)
+Ltac nra := unfold Rdiv in * ; xnra rchecker.
+
+Ltac xpsatz dom d :=
+ let tac := lazymatch dom with
+ | R =>
+ (sos_R rchecker) || (psatz_R d rchecker)
+ | _ => fail "Unsupported domain"
+ end in tac.
+
+Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
+Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1).
+
+
+(* Local Variables: *)
+(* coding: utf-8 *)
+(* End: *)
diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v
index 0a41af45..d28bb828 100644
--- a/plugins/micromega/MExtraction.v
+++ b/plugins/micromega/MExtraction.v
@@ -50,7 +50,7 @@ Extract Constant Rinv => "fun x -> 1 / x".
Extraction "micromega.ml"
List.map simpl_cone (*map_cone indexes*)
- denorm Qpower
+ denorm Qpower vm_add
n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.
diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v
index a461b26a..8acf0ff8 100644
--- a/plugins/micromega/Psatz.v
+++ b/plugins/micromega/Psatz.v
@@ -8,7 +8,7 @@
(* *)
(* Micromega: A reflexive tactic using the Positivstellensatz *)
(* *)
-(* Frédéric Besson (Irisa/Inria) 2006-2008 *)
+(* Frédéric Besson (Irisa/Inria) 2006-2016 *)
(* *)
(************************************************************************)
@@ -20,75 +20,36 @@ Require Import ZArith.
Require Import Rdefinitions.
Require Import RingMicromega.
Require Import VarMap.
-Require Tauto.
-Declare ML Module "micromega_plugin".
+Require Coq.micromega.Tauto.
+Require Lia.
+Require Lra.
+Require Lqa.
-Ltac preprocess :=
- zify ; unfold Z.succ in * ; unfold Z.pred in *.
+Declare ML Module "micromega_plugin".
-Ltac lia :=
- preprocess;
- xlia ;
- abstract (
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
- apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+Ltac lia := Lia.lia.
-Ltac nia :=
- preprocess;
- xnlia ;
- abstract (
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
- apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)).
+Ltac nia := Lia.nia.
Ltac xpsatz dom d :=
let tac := lazymatch dom with
| Z =>
- (sos_Z || psatz_Z d) ;
- abstract(
- intros __wit __varmap __ff ;
- change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ;
- apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))
+ (sos_Z Lia.zchecker) || (psatz_Z d Lia.zchecker)
| R =>
- (sos_R || psatz_R d) ;
- (* If csdp is not installed, the previous step might not produce any
- progress: the rest of the tactical will then fail. Hence the 'try'. *)
- try (abstract(intros __wit __varmap __ff ;
- change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
- apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
- | Q =>
- (sos_Q || psatz_Q d) ;
- (* If csdp is not installed, the previous step might not produce any
- progress: the rest of the tactical will then fail. Hence the 'try'. *)
- try (abstract(intros __wit __varmap __ff ;
- change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
- apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
+ (sos_R Lra.rchecker) || (psatz_R d Lra.rchecker)
+ | Q => (sos_Q Lqa.rchecker) || (psatz_Q d Lqa.rchecker)
| _ => fail "Unsupported domain"
end in tac.
Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n.
-Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:-1.
+Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1).
Ltac psatzl dom :=
let tac := lazymatch dom with
- | Z => lia
- | Q =>
- psatzl_Q ;
- (* If csdp is not installed, the previous step might not produce any
- progress: the rest of the tactical will then fail. Hence the 'try'. *)
- try (abstract(intros __wit __varmap __ff ;
- change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ;
- apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
- | R =>
- unfold Rdiv in * ;
- psatzl_R ;
- (* If csdp is not installed, the previous step might not produce any
- progress: the rest of the tactical will then fail. Hence the 'try'. *)
- try abstract((intros __wit __varmap __ff ;
- change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ;
- apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)))
+ | Z => Lia.lia
+ | Q => Lqa.lra
+ | R => Lra.lra
| _ => fail "Unsupported domain"
end in tac.
@@ -96,6 +57,8 @@ Ltac psatzl dom :=
Ltac lra :=
first [ psatzl R | psatzl Q ].
+Ltac nra :=
+ first [ Lra.nra | Lqa.nra ].
(* Local Variables: *)
diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v
index 43268363..b13285f5 100644
--- a/plugins/micromega/QMicromega.v
+++ b/plugins/micromega/QMicromega.v
@@ -168,7 +168,7 @@ Proof.
exact H.
Qed.
-Require Import Tauto.
+Require Import Coq.micromega.Tauto.
Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool.
diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v
index 72353a99..2352d78d 100644
--- a/plugins/micromega/RMicromega.v
+++ b/plugins/micromega/RMicromega.v
@@ -533,7 +533,7 @@ Proof.
exact H.
Qed.
-Require Import Tauto.
+Require Import Coq.micromega.Tauto.
Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool.
Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool.
diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v
index 751a81df..ed49c3df 100644
--- a/plugins/micromega/RingMicromega.v
+++ b/plugins/micromega/RingMicromega.v
@@ -794,7 +794,7 @@ Definition xnormalise (t:Formula C) : list (NFormula) :=
| OpLe => (psub lhs rhs ,Strict) :: nil
end.
-Require Import Tauto.
+Require Import Coq.micromega.Tauto.
Definition cnf_normalise (t:Formula C) : cnf (NFormula) :=
List.map (fun x => x::nil) (xnormalise t).
diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v
index 4981ddb3..2d2c0bc7 100644
--- a/plugins/micromega/VarMap.v
+++ b/plugins/micromega/VarMap.v
@@ -1,7 +1,7 @@
(* -*- coding: utf-8 -*- *)
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
@@ -26,6 +26,7 @@ Set Implicit Arguments.
*)
Section MakeVarMap.
+
Variable A : Type.
Variable default : A.
@@ -46,5 +47,29 @@ Section MakeVarMap.
end.
-End MakeVarMap.
+ Fixpoint singleton (x:positive) (v : A) : t :=
+ match x with
+ | xH => Leaf v
+ | xO p => Node (singleton p v) default Empty
+ | xI p => Node Empty default (singleton p v)
+ end.
+
+ Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t :=
+ match m with
+ | Empty => singleton x v
+ | Leaf vl =>
+ match x with
+ | xH => Leaf v
+ | xO p => Node (singleton p v) vl Empty
+ | xI p => Node Empty vl (singleton p v)
+ end
+ | Node l o r =>
+ match x with
+ | xH => Node l v r
+ | xI p => Node l o (vm_add p v r)
+ | xO p => Node (vm_add p v l) o r
+ end
+ end.
+
+End MakeVarMap.
diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v
index d7ddef2b..5aa8d03f 100644
--- a/plugins/micromega/ZMicromega.v
+++ b/plugins/micromega/ZMicromega.v
@@ -198,7 +198,7 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z) :=
| OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil
end.
-Require Import Tauto BinNums.
+Require Import Coq.micromega.Tauto BinNums.
Definition normalise (t:Formula Z) : cnf (NFormula Z) :=
List.map (fun x => x::nil) (xnormalise t).
diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml
index a5fceb56..459c72f9 100644
--- a/plugins/micromega/certificate.ml
+++ b/plugins/micromega/certificate.ml
@@ -63,82 +63,82 @@ 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 (C2Ml.positive 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 Int.equal 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
+ | Mc.PEc z -> Poly.constant (n_spec.number_to_num z)
+ | Mc.PEX v -> Poly.variable (C2Ml.positive v)
+ | Mc.PEmul(p1,p2) ->
+ let p1 = dev_form p1 in
+ let p2 = dev_form p2 in
+ Poly.product p1 p2
+ | 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 Int.equal 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 v = Ml2C.positive v in
- let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
- if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *)
- then mn
- else Mc.PEmul(mn,acc))
- mn
- (Mc.PEc (Mc.Zpos Mc.XH))
+ let v = Ml2C.positive v in
+ let mn = if Int.equal i 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in
+ if Pervasives.(=) acc (Mc.PEc (Mc.Zpos Mc.XH)) (** FIXME *)
+ 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 Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH))
- then var i
- else Mc.PEmul (c,var i) in
- let p' = if Pervasives.(=) 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
+ else let c = Mc.PEc (Ml2C.bigint (numerator c)) in
+ let mn =
+ if Pervasives.(=) c (Mc.PEc (Mc.Zpos Mc.XH))
+ then var i
+ else Mc.PEmul (c,var i) in
+ let p' = if Pervasives.(=) 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 Pervasives.(=) y' x then y'
- else fixpoint f y'
+ if Pervasives.(=) y' x then y'
+ else fixpoint f y'
let rec_simpl_cone n_spec e =
let simpl_cone =
Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in
let rec rec_simpl_cone = function
- | Mc.PsatzMulE(t1, t2) ->
- simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
- | Mc.PsatzAdd(t1,t2) ->
- simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2))
- | x -> simpl_cone x in
- rec_simpl_cone e
-
-
+ | Mc.PsatzMulE(t1, t2) ->
+ simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2))
+ | Mc.PsatzAdd(t1,t2) ->
+ simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2))
+ | x -> simpl_cone x in
+ rec_simpl_cone e
+
+
let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c
type cone_prod =
- Const of cone
- | Ideal of cone *cone
- | Mult of cone * cone
- | Other of cone
+ Const of cone
+| Ideal of cone *cone
+| Mult of cone * cone
+| Other of cone
and cone = Mc.zWitness
@@ -147,32 +147,32 @@ let factorise_linear_cone c =
let rec cone_list c l =
match c with
- | Mc.PsatzAdd (x,r) -> cone_list r (x::l)
- | _ -> c :: l in
-
+ | Mc.PsatzAdd (x,r) -> cone_list r (x::l)
+ | _ -> c :: l in
+
let factorise c1 c2 =
match c1 , c2 with
- | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') ->
- if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
- | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') ->
- if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
- | _ -> None in
-
+ | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') ->
+ if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None
+ | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') ->
+ if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None
+ | _ -> None in
+
let rec rebuild_cone l pending =
match l with
- | [] -> (match pending with
- | None -> Mc.PsatzZ
- | Some p -> p
- )
- | e::l ->
- (match pending with
- | None -> rebuild_cone l (Some e)
- | Some p -> (match factorise p e with
- | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e))
- | Some f -> rebuild_cone l (Some f) )
- ) in
+ | [] -> (match pending with
+ | None -> Mc.PsatzZ
+ | Some p -> p
+ )
+ | e::l ->
+ (match pending with
+ | None -> rebuild_cone l (Some e)
+ | Some p -> (match factorise p e with
+ | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e))
+ | Some f -> rebuild_cone l (Some f) )
+ ) in
- (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
+ (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None)
@@ -199,28 +199,28 @@ open Mfourier
let constrain_monomial mn l =
let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in
- if Pervasives.(=) 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 }
+ if Pervasives.(=) 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)
+ | [] -> []
+ | (_,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
+ xpositivity 0 l
let string_of_op = function
@@ -241,23 +241,23 @@ let build_linear_system l =
let monomials =
List.fold_left (fun acc p ->
- Poly.fold (fun m _ acc -> MonSet.add m acc) p acc)
- (MonSet.singleton Monomial.const) l'
+ Poly.fold (fun m _ acc -> MonSet.add m acc) p acc)
+ (MonSet.singleton Monomial.const) l'
in (* For each monomial, compute a constraint *)
let s0 =
MonSet.fold (fun mn res -> (constrain_monomial mn l')::res) monomials [] in
- (* I need at least something strictly positive *)
+ (* 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));
+ 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)
+ {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
@@ -266,32 +266,32 @@ let big_int_to_z = Ml2C.bigint
-- at a lower layer, certificates are using nums... *)
let make_certificate n_spec (cert,li) =
let bint_to_cst = n_spec.bigint_to_number in
- match cert with
- | [] -> failwith "empty_certificate"
- | e::cert' ->
-(* let cst = match compare_big_int e zero_big_int with
- | 0 -> Mc.PsatzZ
- | 1 -> Mc.PsatzC (bint_to_cst e)
- | _ -> failwith "positivity error"
- in *)
- let rec scalar_product cert l =
- match cert with
- | [] -> Mc.PsatzZ
- | c::cert ->
- match l with
- | [] -> failwith "make_certificate(1)"
- | i::l ->
- let r = scalar_product cert l in
- match compare_big_int c zero_big_int with
- | -1 -> Mc.PsatzAdd (
- Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
- r)
- | 0 -> r
- | _ -> Mc.PsatzAdd (
- Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
- r) in
- (factorise_linear_cone
- (simplify_cone n_spec (scalar_product cert' li)))
+ match cert with
+ | [] -> failwith "empty_certificate"
+ | e::cert' ->
+ (* let cst = match compare_big_int e zero_big_int with
+ | 0 -> Mc.PsatzZ
+ | 1 -> Mc.PsatzC (bint_to_cst e)
+ | _ -> failwith "positivity error"
+ in *)
+ let rec scalar_product cert l =
+ match cert with
+ | [] -> Mc.PsatzZ
+ | c::cert ->
+ match l with
+ | [] -> failwith "make_certificate(1)"
+ | i::l ->
+ let r = scalar_product cert l in
+ match compare_big_int c zero_big_int with
+ | -1 -> Mc.PsatzAdd (
+ Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
+ r)
+ | 0 -> r
+ | _ -> Mc.PsatzAdd (
+ Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)),
+ r) in
+ (factorise_linear_cone
+ (simplify_cone n_spec (scalar_product cert' li)))
exception Found of Monomial.t
@@ -301,92 +301,155 @@ exception Strict
module MonMap = Map.Make(Monomial)
let primal l =
- let vr = ref 0 in
-
- let vect_of_poly map p =
- Poly.fold (fun mn vl (map,vect) ->
- if Pervasives.(=) mn Monomial.const
- then (map,vect)
- else
- let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in
- (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in
-
- let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in
+ let vr = ref 0 in
+
+ let vect_of_poly map p =
+ Poly.fold (fun mn vl (map,vect) ->
+ if Pervasives.(=) mn Monomial.const
+ then (map,vect)
+ else
+ let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in
+ (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in
+
+ let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in
- let cmp x y = Int.compare (fst x) (fst y) in
+ let cmp x y = Int.compare (fst x) (fst y) in
- snd (List.fold_right (fun (p,op) (map,l) ->
- let (mp,vect) = vect_of_poly map p in
- let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in
+ snd (List.fold_right (fun (p,op) (map,l) ->
+ let (mp,vect) = vect_of_poly map p in
+ let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in
- (mp,cstr::l)) l (MonMap.empty,[]))
+ (mp,cstr::l)) l (MonMap.empty,[]))
let dual_raw_certificate (l: (Poly.t * Mc.op1) list) =
-(* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *)
-
+ (* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *)
+
let sys = build_linear_system l in
- try
- match Fourier.find_point sys with
- | Inr _ -> None
- | Inl cert -> Some (rats_to_ints (Vect.to_list cert))
- (* should not use rats_to_ints *)
- with x when Errors.noncritical x ->
- if debug
- then (Printf.printf "raw certificate %s" (Printexc.to_string x);
- flush stdout) ;
- None
+ try
+ match Fourier.find_point sys with
+ | Inr _ -> None
+ | Inl cert -> Some (rats_to_ints (Vect.to_list cert))
+ (* should not use rats_to_ints *)
+ with x when CErrors.noncritical x ->
+ if debug
+ then (Printf.printf "raw certificate %s" (Printexc.to_string x);
+ flush stdout) ;
+ None
let raw_certificate l =
- try
- let p = primal l in
- match Fourier.find_point p with
- | Inr prf ->
- if debug then Printf.printf "AProof : %a\n" pp_proof prf ;
- let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in
- if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ;
- Some (rats_to_ints (Vect.to_list cert))
- | Inl _ -> None
- with Strict ->
+ try
+ let p = primal l in
+ match Fourier.find_point p with
+ | Inr prf ->
+ if debug then Printf.printf "AProof : %a\n" pp_proof prf ;
+ let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in
+ if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ;
+ Some (rats_to_ints (Vect.to_list cert))
+ | Inl _ -> None
+ with Strict ->
(* Fourier elimination should handle > *)
- dual_raw_certificate l
+ dual_raw_certificate l
let simple_linear_prover l =
let (lc,li) = List.split l in
- match raw_certificate lc with
- | None -> None (* No certificate *)
- | Some cert -> Some (cert,li)
-
+ match raw_certificate lc with
+ | None -> None (* No certificate *)
+ | Some cert -> Some (cert,li)
+
let linear_prover n_spec l =
- let build_system n_spec l =
- let li = List.combine l (interval 0 (List.length l -1)) in
- let (l1,l') = List.partition
- (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in
- List.map
- (fun ((x,y),i) -> match y with
- Mc.NonEqual -> failwith "cannot happen"
- | y -> ((dev_form n_spec x, y),i)) l' in
- let l' = build_system n_spec l in
- simple_linear_prover (*n_spec*) l'
+ let build_system n_spec l =
+ let li = List.combine l (interval 0 (List.length l -1)) in
+ let (l1,l') = List.partition
+ (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in
+ List.map
+ (fun ((x,y),i) -> match y with
+ Mc.NonEqual -> failwith "cannot happen"
+ | y -> ((dev_form n_spec x, y),i)) l' in
+ let l' = build_system n_spec l in
+ simple_linear_prover (*n_spec*) l'
let linear_prover n_spec l =
try linear_prover n_spec l
- with x when Errors.noncritical x ->
- (print_string (Printexc.to_string x); None)
+ with x when CErrors.noncritical x ->
+ (print_string (Printexc.to_string x); None)
+
+let compute_max_nb_cstr l d =
+ let len = List.length l in
+ max len (max d (len * d))
+
+let linear_prover_with_cert prfdepth spec l =
+ max_nb_cstr := compute_max_nb_cstr l prfdepth ;
+ match linear_prover spec l with
+ | None -> None
+ | Some cert -> Some (make_certificate spec cert)
+
+let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) =
+ LinPoly.MonT.clear ();
+ max_nb_cstr := compute_max_nb_cstr sys prfdepth ;
+ (* Assign a proof to the initial hypotheses *)
+ let sys = mapi (fun c i -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in
+
+
+ (* Add all the product of hypotheses *)
+ let prod = all_pairs (fun ((c,o),p) ((c',o'),p') ->
+ ((Mc.PEmul(c,c') , Mc.opMult o o') , Mc.PsatzMulE(p,p'))) sys in
+
+ (* Only filter those have a meaning *)
+ let prod = List.fold_left (fun l ((c,o),p) ->
+ match o with
+ | None -> l
+ | Some o -> ((c,o),p) :: l) [] prod in
+
+ let sys = sys @ prod in
+
+ let square =
+ (* Collect the squares and state that they are positive *)
+ let pols = List.map (fun ((p,_),_) -> dev_form q_spec p) sys in
+ let square =
+ List.fold_left (fun acc p ->
+ Poly.fold
+ (fun m _ acc ->
+ match Monomial.sqrt m with
+ | None -> acc
+ | Some s -> MonMap.add s m acc) p acc) MonMap.empty pols in
-let linear_prover_with_cert spec l =
- match linear_prover spec l with
- | None -> None
- | Some cert -> Some (make_certificate spec cert)
+ let pol_of_mon m =
+ Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc q_spec.unit) in
+
+ let norm0 =
+ Mc.norm q_spec.zero q_spec.unit Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool in
+
+
+ MonMap.fold (fun s m acc -> ((pol_of_mon m , Mc.NonStrict), Mc.PsatzSquare(norm0 (pol_of_mon s)))::acc) square [] in
+
+ let sys = sys @ square in
+ (* Call the linear prover without the proofs *)
+ let sys_no_prf = List.map fst sys in
+
+ match linear_prover q_spec sys_no_prf with
+ | None -> None
+ | Some cert ->
+ let cert = make_certificate q_spec cert in
+ let rec map_psatz = function
+ | Mc.PsatzIn n -> snd (List.nth sys (C2Ml.nat n))
+ | Mc.PsatzSquare c -> Mc.PsatzSquare c
+ | Mc.PsatzMulC(c,p) -> Mc.PsatzMulC(c, map_psatz p)
+ | Mc.PsatzMulE(p1,p2) -> Mc.PsatzMulE(map_psatz p1,map_psatz p2)
+ | Mc.PsatzAdd(p1,p2) -> Mc.PsatzAdd(map_psatz p1,map_psatz p2)
+ | Mc.PsatzC c -> Mc.PsatzC c
+ | Mc.PsatzZ -> Mc.PsatzZ in
+ Some (map_psatz cert)
+
let make_linear_system l =
@@ -395,11 +458,11 @@ let make_linear_system l =
(Poly.constant (Int 0)) l' in
let monomials = Poly.fold
(fun mn _ l -> if Pervasives.(=) 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)
+ (List.map (fun (c,op) ->
+ {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ;
+ op = op ;
+ cst = minus_num ( (Poly.get Monomial.const c))}) l
+ ,monomials)
let pplus x y = Mc.PEadd(x,y)
@@ -413,7 +476,7 @@ let rec 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)
+ remove_assoc p x l else e::(remove_assoc p x l)
let eq x y = Int.equal (Vect.compare x y) 0
@@ -424,39 +487,39 @@ let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l
only searching for naive cutting planes *)
let develop_constraint z_spec (e,k) =
- match k with
- | Mc.NonStrict -> (dev_form z_spec e , Ge)
- | Mc.Equal -> (dev_form z_spec e , Eq)
- | _ -> assert false
+ match k with
+ | Mc.NonStrict -> (dev_form z_spec e , Ge)
+ | Mc.Equal -> (dev_form z_spec e , Eq)
+ | _ -> assert false
let op_of_op_compat = function
- | Ge -> Mc.NonStrict
- | Eq -> Mc.Equal
+ | Ge -> Mc.NonStrict
+ | Eq -> Mc.Equal
let integer_vector coeffs =
- let vars , coeffs = List.split coeffs in
- List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs))
+ let vars , coeffs = List.split coeffs in
+ List.combine vars (List.map (fun x -> Big_int x) (rats_to_ints coeffs))
let integer_cstr {coeffs = coeffs ; op = op ; cst = cst } =
- let vars , coeffs = List.split coeffs in
- match rats_to_ints (cst::coeffs) with
- | cst :: coeffs ->
- {
- coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ;
- op = op ; cst = Big_int cst}
- | _ -> assert false
-
+ let vars , coeffs = List.split coeffs in
+ match rats_to_ints (cst::coeffs) with
+ | cst :: coeffs ->
+ {
+ coeffs = List.combine vars (List.map (fun x -> Big_int x) coeffs) ;
+ op = op ; cst = Big_int cst}
+ | _ -> assert false
+
let pexpr_of_cstr_compat var cstr =
- let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in
- try
- let expr = list_to_polynomial var (Vect.to_list coeffs) in
- let d = Ml2C.bigint (denominator cst) in
- let n = Ml2C.bigint (numerator cst) in
- (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op)
- with Failure _ -> failwith "pexpr_of_cstr_compat"
+ let {coeffs = coeffs ; op = op ; cst = cst } = integer_cstr cstr in
+ try
+ let expr = list_to_polynomial var (Vect.to_list coeffs) in
+ let d = Ml2C.bigint (denominator cst) in
+ let n = Ml2C.bigint (numerator cst) in
+ (pplus (pmult (pconst d) expr) (popp (pconst n)), op_of_op_compat op)
+ with Failure _ -> failwith "pexpr_of_cstr_compat"
@@ -465,41 +528,41 @@ open Sos_types
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 Int.equal (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"
+ | 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 Int.equal (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'
+ s,t'
let get_index_of_ith_match f i l =
let rec get j res l =
match l with
- | [] -> failwith "bad index"
- | e::l -> if f e
- then
- (if Int.equal j i then res else get (j+1) (res+1) l )
- else get j (res+1) l in
- get 0 0 l
+ | [] -> failwith "bad index"
+ | e::l -> if f e
+ then
+ (if Int.equal j i then res else get (j+1) (res+1) l )
+ else get j (res+1) l in
+ get 0 0 l
let rec scale_certificate pos = match pos with
@@ -511,97 +574,97 @@ let rec scale_certificate pos = match pos with
| 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'
+ 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)
+ 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))
+ 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 s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in
+ mult_big_int s1 s2 , Product (y1,y2)
open Micromega
- let rec term_to_q_expr = function
- | Const n -> PEc (Ml2C.q n)
- | Zero -> PEc ( Ml2C.q (Int 0))
- | Var s -> PEX (Ml2C.index
- (int_of_string (String.sub s 1 (String.length s - 1))))
- | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2)
- | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2)
- | Opp p -> PEopp (term_to_q_expr p)
- | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n)
- | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2)
- | _ -> failwith "term_to_q_expr: not implemented"
-
- let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e)
-
-
- let rec product l =
- match l with
- | [] -> Mc.PsatzZ
- | [i] -> Mc.PsatzIn (Ml2C.nat i)
- | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l)
+let rec term_to_q_expr = function
+ | Const n -> PEc (Ml2C.q n)
+ | Zero -> PEc ( Ml2C.q (Int 0))
+ | Var s -> PEX (Ml2C.index
+ (int_of_string (String.sub s 1 (String.length s - 1))))
+ | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2)
+ | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2)
+ | Opp p -> PEopp (term_to_q_expr p)
+ | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n)
+ | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2)
+ | _ -> failwith "term_to_q_expr: not implemented"
+
+let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e)
+
+
+let rec product l =
+ match l with
+ | [] -> Mc.PsatzZ
+ | [i] -> Mc.PsatzIn (Ml2C.nat i)
+ | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l)
let q_cert_of_pos pos =
let rec _cert_of_pos = function
- Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
+ Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
| Axiom_le i -> Mc.PsatzIn (Ml2C.nat i)
| Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i)
| Monoid l -> product l
| Rational_eq n | Rational_le n | Rational_lt n ->
- if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
- Mc.PsatzC (Ml2C.q n)
+ if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
+ Mc.PsatzC (Ml2C.q n)
| Square t -> Mc.PsatzSquare (term_to_q_pol t)
| Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y)
| Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z)
| Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in
- simplify_cone q_spec (_cert_of_pos pos)
+ simplify_cone q_spec (_cert_of_pos pos)
- let rec term_to_z_expr = function
- | Const n -> PEc (Ml2C.bigint (big_int_of_num n))
- | Zero -> PEc ( Z0)
- | Var s -> PEX (Ml2C.index
- (int_of_string (String.sub s 1 (String.length s - 1))))
- | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2)
- | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2)
- | Opp p -> PEopp (term_to_z_expr p)
- | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n)
- | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2)
- | _ -> failwith "term_to_z_expr: not implemented"
+let rec term_to_z_expr = function
+ | Const n -> PEc (Ml2C.bigint (big_int_of_num n))
+ | Zero -> PEc ( Z0)
+ | Var s -> PEX (Ml2C.index
+ (int_of_string (String.sub s 1 (String.length s - 1))))
+ | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2)
+ | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2)
+ | Opp p -> PEopp (term_to_z_expr p)
+ | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n)
+ | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2)
+ | _ -> failwith "term_to_z_expr: not implemented"
- let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e)
+let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e)
let z_cert_of_pos pos =
let s,pos = (scale_certificate pos) in
let rec _cert_of_pos = function
- Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
+ Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i)
| Axiom_le i -> Mc.PsatzIn (Ml2C.nat i)
| Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i)
| Monoid l -> product l
| Rational_eq n | Rational_le n | Rational_lt n ->
- if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
- Mc.PsatzC (Ml2C.bigint (big_int_of_num n))
+ if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else
+ Mc.PsatzC (Ml2C.bigint (big_int_of_num n))
| Square t -> Mc.PsatzSquare (term_to_z_pol t)
| Eqmul (t, y) ->
- let is_unit =
- match t with
- | Const n -> n =/ Int 1
- | _ -> false in
- if is_unit
- then _cert_of_pos y
- else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y)
+ let is_unit =
+ match t with
+ | Const n -> n =/ Int 1
+ | _ -> false in
+ if is_unit
+ then _cert_of_pos y
+ else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y)
| Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z)
| Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in
- simplify_cone z_spec (_cert_of_pos pos)
+ simplify_cone z_spec (_cert_of_pos pos)
(** All constraints (initial or derived) have an index and have a justification i.e., proof.
Given a constraint, all the coefficients are always integers.
@@ -612,116 +675,109 @@ open Num
open Big_int
open Polynomial
-(*module Mc = Micromega*)
-(*module Ml2C = Mutils.CamlToCoq
-module C2Ml = Mutils.CoqToCaml
-*)
-let debug = false
-
-
module Env =
struct
- type t = int list
+ type t = int list
- let id_of_hyp hyp l =
- let rec xid_of_hyp i l =
- match l with
- | [] -> failwith "id_of_hyp"
- | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in
- xid_of_hyp 0 l
+ let id_of_hyp hyp l =
+ let rec xid_of_hyp i l =
+ match l with
+ | [] -> failwith "id_of_hyp"
+ | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in
+ xid_of_hyp 0 l
end
let coq_poly_of_linpol (p,c) =
- let pol_of_mon m =
- Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in
+ let pol_of_mon m =
+ Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in
- List.fold_left (fun acc (x,v) ->
- let mn = LinPoly.MonT.retrieve x in
- Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p
-
+ List.fold_left (fun acc (x,v) ->
+ let mn = LinPoly.MonT.retrieve x in
+ Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p
+
let rec cmpl_prf_rule env = function
- | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env))
- | Cst i -> Mc.PsatzC (Ml2C.bigint i)
- | Zero -> Mc.PsatzZ
- | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2)
- | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2)
- | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in
- Mc.PsatzMulC(lp,cmpl_prf_rule env p)
- | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp))
- | _ -> failwith "Cuts should already be compiled"
-
+ | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env))
+ | Cst i -> Mc.PsatzC (Ml2C.bigint i)
+ | Zero -> Mc.PsatzZ
+ | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2)
+ | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2)
+ | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in
+ Mc.PsatzMulC(lp,cmpl_prf_rule env p)
+ | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp))
+ | _ -> failwith "Cuts should already be compiled"
+
let rec cmpl_proof env = function
- | Done -> Mc.DoneProof
- | Step(i,p,prf) ->
- begin
- match p with
- | CutPrf p' ->
- Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf)
- | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf)
- end
- | Enum(i,p1,_,p2,l) ->
- Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l)
+ | Done -> Mc.DoneProof
+ | Step(i,p,prf) ->
+ begin
+ match p with
+ | CutPrf p' ->
+ Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf)
+ | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf)
+ end
+ | Enum(i,p1,_,p2,l) ->
+ Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l)
let compile_proof env prf =
- let id = 1 + proof_max_id prf in
- let _,prf = normalise_proof id prf in
- if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf;
- cmpl_proof env prf
+ let id = 1 + proof_max_id prf in
+ let _,prf = normalise_proof id prf in
+ if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf;
+ cmpl_proof env prf
type prf_sys = (cstr_compat * prf_rule) list
let xlinear_prover sys =
- match Fourier.find_point sys with
- | Inr prf ->
- if debug then Printf.printf "AProof : %a\n" pp_proof prf ;
- let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in
- if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ;
- Some (rats_to_ints (Vect.to_list cert))
- | Inl _ -> None
+ match Fourier.find_point sys with
+ | Inr prf ->
+ if debug then Printf.printf "AProof : %a\n" pp_proof prf ;
+ let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in
+ if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ;
+ Some (rats_to_ints (Vect.to_list cert))
+ | Inl _ -> None
let output_num o n = output_string o (string_of_num n)
let output_bigint o n = output_string o (string_of_big_int n)
let proof_of_farkas prf cert =
-(* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *)
- let rec mk_farkas acc prf cert =
- match prf, cert with
- | _ , [] -> acc
- | [] , _ -> failwith "proof_of_farkas : not enough hyps"
- | p::prf,c::cert ->
- mk_farkas (add_proof (mul_proof c p) acc) prf cert in
- let res = mk_farkas Zero prf cert in
+ (* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *)
+ let rec mk_farkas acc prf cert =
+ match prf, cert with
+ | _ , [] -> acc
+ | [] , _ -> failwith "proof_of_farkas : not enough hyps"
+ | p::prf,c::cert ->
+ mk_farkas (add_proof (mul_proof c p) acc) prf cert in
+ let res = mk_farkas Zero prf cert in
(*Printf.printf "==> %a" output_prf_rule res ; *)
- res
+ res
let linear_prover sys =
- let (sysi,prfi) = List.split sys in
- match xlinear_prover sysi with
- | None -> None
- | Some cert -> Some (proof_of_farkas prfi cert)
+ let (sysi,prfi) = List.split sys in
+ match xlinear_prover sysi with
+ | None -> None
+ | Some cert -> Some (proof_of_farkas prfi cert)
let linear_prover =
- if debug
- then
- fun sys ->
- Printf.printf "<linear_prover"; flush stdout ;
- let res = linear_prover sys in
- Printf.printf ">"; flush stdout ;
- res
- else linear_prover
+ if debug
+ then
+ fun sys ->
+ Printf.printf "<linear_prover"; flush stdout ;
+ let res = linear_prover sys in
+ Printf.printf ">"; flush stdout ;
+ res
+ else linear_prover
@@ -733,11 +789,11 @@ let linear_prover =
*)
type checksat =
- | Tauto (* Tautology *)
- | Unsat of prf_rule (* Unsatisfiable *)
- | Cut of cstr_compat * prf_rule (* Cutting plane *)
- | Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *)
-
+| Tauto (* Tautology *)
+| Unsat of prf_rule (* Unsatisfiable *)
+| Cut of cstr_compat * prf_rule (* Cutting plane *)
+| Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *)
+
(** [check_sat]
- detects constraints that are not satisfiable;
@@ -745,83 +801,83 @@ type checksat =
*)
let check_sat (cstr,prf) =
- let {coeffs=coeffs ; op=op ; cst=cst} = cstr in
- match coeffs with
- | [] ->
- if eval_op op (Int 0) cst then Tauto else Unsat prf
- | _ ->
- let gcdi = (gcd_list (List.map snd coeffs)) in
- let gcd = Big_int gcdi in
- if eq_num gcd (Int 1)
- then Normalise(cstr,prf)
- else
- if Int.equal (sign_num (mod_num cst gcd)) 0
- then (* We can really normalise *)
- begin
- assert (sign_num gcd >=1 ) ;
- let cstr = {
- coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
- op = op ; cst = cst // gcd
- } in
- Normalise(cstr,Gcd(gcdi,prf))
- (* Normalise(cstr,CutPrf prf)*)
- end
- else
- match op with
- | Eq -> Unsat (CutPrf prf)
- | Ge ->
- let cstr = {
- coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
- op = op ; cst = ceiling_num (cst // gcd)
- } in Cut(cstr,CutPrf prf)
+ let {coeffs=coeffs ; op=op ; cst=cst} = cstr in
+ match coeffs with
+ | [] ->
+ if eval_op op (Int 0) cst then Tauto else Unsat prf
+ | _ ->
+ let gcdi = (gcd_list (List.map snd coeffs)) in
+ let gcd = Big_int gcdi in
+ if eq_num gcd (Int 1)
+ then Normalise(cstr,prf)
+ else
+ if Int.equal (sign_num (mod_num cst gcd)) 0
+ then (* We can really normalise *)
+ begin
+ assert (sign_num gcd >=1 ) ;
+ let cstr = {
+ coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
+ op = op ; cst = cst // gcd
+ } in
+ Normalise(cstr,Gcd(gcdi,prf))
+ (* Normalise(cstr,CutPrf prf)*)
+ end
+ else
+ match op with
+ | Eq -> Unsat (CutPrf prf)
+ | Ge ->
+ let cstr = {
+ coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs;
+ op = op ; cst = ceiling_num (cst // gcd)
+ } in Cut(cstr,CutPrf prf)
(** Proof generating pivoting over variable v *)
let pivot v (c1,p1) (c2,p2) =
- let {coeffs = v1 ; op = op1 ; cst = n1} = c1
- and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
+ let {coeffs = v1 ; op = op1 ; cst = n1} = c1
+ and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in
(* Could factorise gcd... *)
- let xpivot cv1 cv2 =
- (
- {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ;
- op = Proof.add_op op1 op2 ;
- cst = n1 */ cv1 +/ n2 */ cv2 },
+ let xpivot cv1 cv2 =
+ (
+ {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ;
+ op = Proof.add_op op1 op2 ;
+ cst = n1 */ cv1 +/ n2 */ cv2 },
- AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in
+ AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in
+
+ match Vect.get v v1 , Vect.get v v2 with
+ | None , _ | _ , None -> None
+ | Some a , Some b ->
+ if Int.equal ((sign_num a) * (sign_num b)) (-1)
+ then
+ let cv1 = abs_num b
+ and cv2 = abs_num a in
+ Some (xpivot cv1 cv2)
+ else
+ if op1 == Eq
+ then
+ let cv1 = minus_num (b */ (Int (sign_num a)))
+ and cv2 = abs_num a in
+ Some (xpivot cv1 cv2)
+ else if op2 == Eq
+ then
+ let cv1 = abs_num b
+ and cv2 = minus_num (a */ (Int (sign_num b))) in
+ Some (xpivot cv1 cv2)
+ else None (* op2 could be Eq ... this might happen *)
- match Vect.get v v1 , Vect.get v v2 with
- | None , _ | _ , None -> None
- | Some a , Some b ->
- if Int.equal ((sign_num a) * (sign_num b)) (-1)
- then
- let cv1 = abs_num b
- and cv2 = abs_num a in
- Some (xpivot cv1 cv2)
- else
- if op1 == Eq
- then
- let cv1 = minus_num (b */ (Int (sign_num a)))
- and cv2 = abs_num a in
- Some (xpivot cv1 cv2)
- else if op2 == Eq
- then
- let cv1 = abs_num b
- and cv2 = minus_num (a */ (Int (sign_num b))) in
- Some (xpivot cv1 cv2)
- else None (* op2 could be Eq ... this might happen *)
-
exception FoundProof of prf_rule
let simpl_sys sys =
- List.fold_left (fun acc (c,p) ->
- match check_sat (c,p) with
- | Tauto -> acc
- | Unsat prf -> raise (FoundProof prf)
- | Cut(c,p) -> (c,p)::acc
- | Normalise (c,p) -> (c,p)::acc) [] sys
+ List.fold_left (fun acc (c,p) ->
+ match check_sat (c,p) with
+ | Tauto -> acc
+ | Unsat prf -> raise (FoundProof prf)
+ | Cut(c,p) -> (c,p)::acc
+ | Normalise (c,p) -> (c,p)::acc) [] sys
(** [ext_gcd a b] is the extended Euclid algorithm.
@@ -829,77 +885,77 @@ let simpl_sys sys =
Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
*)
let rec ext_gcd a b =
- if Int.equal (sign_big_int b) 0
- then (unit_big_int,zero_big_int)
- else
- let (q,r) = quomod_big_int a b in
- let (s,t) = ext_gcd b r in
- (t, sub_big_int s (mult_big_int q t))
+ if Int.equal (sign_big_int b) 0
+ then (unit_big_int,zero_big_int)
+ else
+ let (q,r) = quomod_big_int a b in
+ let (s,t) = ext_gcd b r in
+ (t, sub_big_int s (mult_big_int q t))
let pp_ext_gcd a b =
- let a' = big_int_of_int a in
- let b' = big_int_of_int b in
-
- let (x,y) = ext_gcd a' b' in
- Printf.fprintf stdout "%s * %s + %s * %s = %s\n"
- (string_of_big_int x) (string_of_big_int a')
- (string_of_big_int y) (string_of_big_int b')
- (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b')))
+ let a' = big_int_of_int a in
+ let b' = big_int_of_int b in
+
+ let (x,y) = ext_gcd a' b' in
+ Printf.fprintf stdout "%s * %s + %s * %s = %s\n"
+ (string_of_big_int x) (string_of_big_int a')
+ (string_of_big_int y) (string_of_big_int b')
+ (string_of_big_int (add_big_int (mult_big_int x a') (mult_big_int y b')))
exception Result of (int * (proof * cstr_compat))
let split_equations psys =
- List.partition (fun (c,p) -> c.op == Eq)
+ List.partition (fun (c,p) -> c.op == Eq)
let extract_coprime (c1,p1) (c2,p2) =
- let rec exist2 vect1 vect2 =
- match vect1 , vect2 with
- | _ , [] | [], _ -> None
- | (v1,n1)::vect1' , (v2, n2) :: vect2' ->
- if Pervasives.(=) v1 v2
- then
- if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0
- then Some (v1,n1,n2)
- else
- exist2 vect1' vect2'
- else
- if v1 < v2
- then exist2 vect1' vect2
- else exist2 vect1 vect2' in
-
- if c1.op == Eq && c2.op == Eq
- then exist2 c1.coeffs c2.coeffs
- else None
+ let rec exist2 vect1 vect2 =
+ match vect1 , vect2 with
+ | _ , [] | [], _ -> None
+ | (v1,n1)::vect1' , (v2, n2) :: vect2' ->
+ if Pervasives.(=) v1 v2
+ then
+ if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0
+ then Some (v1,n1,n2)
+ else
+ exist2 vect1' vect2'
+ else
+ if v1 < v2
+ then exist2 vect1' vect2
+ else exist2 vect1 vect2' in
+
+ if c1.op == Eq && c2.op == Eq
+ then exist2 c1.coeffs c2.coeffs
+ else None
let extract2 pred l =
- let rec xextract2 rl l =
- match l with
- | [] -> (None,rl) (* Did not find *)
- | e::l ->
- match extract (pred e) l with
- | None,_ -> xextract2 (e::rl) l
- | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in
-
- xextract2 [] l
+ let rec xextract2 rl l =
+ match l with
+ | [] -> (None,rl) (* Did not find *)
+ | e::l ->
+ match extract (pred e) l with
+ | None,_ -> xextract2 (e::rl) l
+ | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in
+
+ xextract2 [] l
let extract_coprime_equation psys =
- extract2 extract_coprime psys
+ extract2 extract_coprime psys
let apply_and_normalise f psys =
- List.fold_left (fun acc pc' ->
- match f pc' with
- | None -> pc'::acc
- | Some pc' ->
- match check_sat pc' with
- | Tauto -> acc
- | Unsat prf -> raise (FoundProof prf)
- | Cut(c,p) -> (c,p)::acc
- | Normalise (c,p) -> (c,p)::acc
- ) [] psys
+ List.fold_left (fun acc pc' ->
+ match f pc' with
+ | None -> pc'::acc
+ | Some pc' ->
+ match check_sat pc' with
+ | Tauto -> acc
+ | Unsat prf -> raise (FoundProof prf)
+ | Cut(c,p) -> (c,p)::acc
+ | Normalise (c,p) -> (c,p)::acc
+ ) [] psys
@@ -908,314 +964,317 @@ let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys
let reduce_coprime psys =
- let oeq,sys = extract_coprime_equation psys in
- match oeq with
- | None -> None (* Nothing to do *)
- | Some((v,n1,n2),(c1,p1),(c2,p2) ) ->
- let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in
- let l1' = Big_int l1 and l2' = Big_int l2 in
- let cstr =
- {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs);
- op = Eq ;
- cst = (l1' */ c1.cst) +/ (l2' */ c2.cst)
- } in
- let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in
-
- Some (pivot_sys v (cstr,prf) ((c1,p1)::sys))
+ let oeq,sys = extract_coprime_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some((v,n1,n2),(c1,p1),(c2,p2) ) ->
+ let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in
+ let l1' = Big_int l1 and l2' = Big_int l2 in
+ let cstr =
+ {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs);
+ op = Eq ;
+ cst = (l1' */ c1.cst) +/ (l2' */ c2.cst)
+ } in
+ let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in
+
+ Some (pivot_sys v (cstr,prf) ((c1,p1)::sys))
(** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *)
let reduce_unary psys =
- let is_unary_equation (cstr,prf) =
- if cstr.op == Eq
- then
- try
- Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
- with Not_found -> None
- else None in
-
- let (oeq,sys) = extract is_unary_equation psys in
- match oeq with
- | None -> None (* Nothing to do *)
- | Some(v,pc) ->
- Some(pivot_sys v pc sys)
+ let is_unary_equation (cstr,prf) =
+ if cstr.op == Eq
+ then
+ try
+ Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs))
+ with Not_found -> None
+ else None in
+
+ let (oeq,sys) = extract is_unary_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) ->
+ Some(pivot_sys v pc sys)
let reduce_non_lin_unary psys =
- let is_unary_equation (cstr,prf) =
- if cstr.op == Eq
- then
- try
- let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in
- let x' = LinPoly.MonT.retrieve x in
- if List.for_all (fun (y,_) -> Pervasives.(=) y x || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs
- then Some x
- else None
- with Not_found -> None
- else None in
-
-
- let (oeq,sys) = extract is_unary_equation psys in
- match oeq with
- | None -> None (* Nothing to do *)
- | Some(v,pc) ->
- Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys)
+ let is_unary_equation (cstr,prf) =
+ if cstr.op == Eq
+ then
+ try
+ let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in
+ let x' = LinPoly.MonT.retrieve x in
+ if List.for_all (fun (y,_) -> Pervasives.(=) y x || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs
+ then Some x
+ else None
+ with Not_found -> None
+ else None in
+
+
+ let (oeq,sys) = extract is_unary_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) ->
+ Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys)
let reduce_var_change psys =
- let rec rel_prime vect =
- match vect with
- | [] -> None
- | (x,v)::vect ->
- let v = numerator v in
- try
- let (x',v') = List.find (fun (_,v') ->
- let v' = numerator v' in
- eq_big_int (gcd_big_int v v') unit_big_int) vect in
- Some ((x,v),(x',numerator v'))
- with Not_found -> rel_prime vect in
-
- let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in
-
- let (oeq,sys) = extract rel_prime psys in
-
- match oeq with
- | None -> None
- | Some(((x,v),(x',v')),(c,p)) ->
- let (l1,l2) = ext_gcd v v' in
- let l1,l2 = Big_int l1 , Big_int l2 in
+ let rec rel_prime vect =
+ match vect with
+ | [] -> None
+ | (x,v)::vect ->
+ let v = numerator v in
+ try
+ let (x',v') = List.find (fun (_,v') ->
+ let v' = numerator v' in
+ eq_big_int (gcd_big_int v v') unit_big_int) vect in
+ Some ((x,v),(x',numerator v'))
+ with Not_found -> rel_prime vect in
+
+ let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in
- let get v vect =
- match Vect.get v vect with
- | None -> Int 0
- | Some n -> n in
+ let (oeq,sys) = extract rel_prime psys in
+
+ match oeq with
+ | None -> None
+ | Some(((x,v),(x',v')),(c,p)) ->
+ let (l1,l2) = ext_gcd v v' in
+ let l1,l2 = Big_int l1 , Big_int l2 in
- let pivot_eq (c',p') =
- let {coeffs = coeffs ; op = op ; cst = cst} = c' in
- let vx = get x coeffs in
- let vx' = get x' coeffs in
- let m = minus_num (vx */ l1 +/ vx' */ l2) in
- Some ({coeffs =
- Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} ,
- AddPrf(MulC(([], m),p),p')) in
+ let get v vect =
+ match Vect.get v vect with
+ | None -> Int 0
+ | Some n -> n in
- Some (apply_and_normalise pivot_eq sys)
+ let pivot_eq (c',p') =
+ let {coeffs = coeffs ; op = op ; cst = cst} = c' in
+ let vx = get x coeffs in
+ let vx' = get x' coeffs in
+ let m = minus_num (vx */ l1 +/ vx' */ l2) in
+ Some ({coeffs =
+ Vect.add (Vect.mul m c.coeffs) coeffs ; op = op ; cst = m */ c.cst +/ cst} ,
+ AddPrf(MulC(([], m),p),p')) in
+ Some (apply_and_normalise pivot_eq sys)
- let reduce_pivot psys =
- let is_equation (cstr,prf) =
- if cstr.op == Eq
- then
- try
- Some (fst (List.hd cstr.coeffs))
- with Not_found -> None
- else None in
- let (oeq,sys) = extract is_equation psys in
- match oeq with
- | None -> None (* Nothing to do *)
- | Some(v,pc) ->
- if debug then
- Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst);
- Some(pivot_sys v pc sys)
+let reduce_pivot psys =
+ let is_equation (cstr,prf) =
+ if cstr.op == Eq
+ then
+ try
+ Some (fst (List.hd cstr.coeffs))
+ with Not_found -> None
+ else None in
+ let (oeq,sys) = extract is_equation psys in
+ match oeq with
+ | None -> None (* Nothing to do *)
+ | Some(v,pc) ->
+ if debug then
+ Printf.printf "Bad news : loss of completeness %a=%s" Vect.pp_vect (fst pc).coeffs (string_of_num (fst pc).cst);
+ Some(pivot_sys v pc sys)
- let iterate_until_stable f x =
- let rec iter x =
- match f x with
- | None -> x
- | Some x' -> iter x' in
- iter x
- let rec app_funs l x =
- match l with
- | [] -> None
- | f::fl ->
- match f x with
- | None -> app_funs fl x
- | Some x' -> Some x'
+let iterate_until_stable f x =
+ let rec iter x =
+ match f x with
+ | None -> x
+ | Some x' -> iter x' in
+ iter x
- let reduction_equations psys =
- iterate_until_stable (app_funs
- [reduce_unary ; reduce_coprime ;
- reduce_var_change (*; reduce_pivot*)]) psys
+let rec app_funs l x =
+ match l with
+ | [] -> None
+ | f::fl ->
+ match f x with
+ | None -> app_funs fl x
+ | Some x' -> Some x'
- let reduction_non_lin_equations psys =
- iterate_until_stable (app_funs
- [reduce_non_lin_unary (*; reduce_coprime ;
- reduce_var_change ; reduce_pivot *)]) psys
+let reduction_equations psys =
+ iterate_until_stable (app_funs
+ [reduce_unary ; reduce_coprime ;
+ reduce_var_change (*; reduce_pivot*)]) psys
+
+let reduction_non_lin_equations psys =
+ iterate_until_stable (app_funs
+ [reduce_non_lin_unary (*; reduce_coprime ;
+ reduce_var_change ; reduce_pivot *)]) psys
(** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *)
- let get_bound sys =
- let is_small (v,i) =
- match Itv.range i with
- | None -> false
- | Some i -> i <=/ (Int 1) in
-
- let select_best (x1,i1) (x2,i2) =
- if Itv.smaller_itv i1 i2
- then (x1,i1) else (x2,i2) in
+let get_bound sys =
+ let is_small (v,i) =
+ match Itv.range i with
+ | None -> false
+ | Some i -> i <=/ (Int 1) in
+
+ let select_best (x1,i1) (x2,i2) =
+ if Itv.smaller_itv i1 i2
+ then (x1,i1) else (x2,i2) in
(* For lia, there are no equations => these precautions are not needed *)
(* For nlia, there are equations => do not enumerate over equations! *)
- let all_planes sys =
- let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in
- match eq with
- | [] -> List.rev_map (fun c -> c.coeffs) ineq
- | _ ->
- List.fold_left (fun acc c ->
- if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq
- then acc else c.coeffs ::acc) [] ineq in
-
- let smallest_interval =
- List.fold_left
- (fun acc vect ->
- if is_small acc
- then acc
- else
- match Fourier.optimise vect sys with
- | None -> acc
- | Some i ->
- if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ;
- select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in
- let smallest_interval =
- match smallest_interval
- with
- | (x,(Some i, Some j)) -> Some(i,x,j)
- | x -> None (* This should not be possible *)
- in
- match smallest_interval with
- | Some (lb,e,ub) ->
- let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in
- let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in
- (match
+ let all_planes sys =
+ let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in
+ match eq with
+ | [] -> List.rev_map (fun c -> c.coeffs) ineq
+ | _ ->
+ List.fold_left (fun acc c ->
+ if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq
+ then acc else c.coeffs ::acc) [] ineq in
+
+ let smallest_interval =
+ List.fold_left
+ (fun acc vect ->
+ if is_small acc
+ then acc
+ else
+ match Fourier.optimise vect sys with
+ | None -> acc
+ | Some i ->
+ if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ;
+ select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in
+ let smallest_interval =
+ match smallest_interval
+ with
+ | (x,(Some i, Some j)) -> Some(i,x,j)
+ | x -> None (* This should not be possible *)
+ in
+ match smallest_interval with
+ | Some (lb,e,ub) ->
+ let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in
+ let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in
+ (match
(* x <= ub -> x > ub *)
- xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys),
+ xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys),
(* lb <= x -> lb > x *)
- xlinear_prover
- ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys)
- with
- | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub)
- | _ -> failwith "Interval without proof"
- )
- | None -> None
-
-
- let check_sys sys =
- List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys
-
-
- let xlia reduction_equations sys =
-
- let rec enum_proof (id:int) (sys:prf_sys) : proof option =
- if debug then (Printf.printf "enum_proof\n" ; flush stdout) ;
- assert (check_sys sys) ;
-
- let nsys,prf = List.split sys in
- match get_bound nsys with
- | None -> None (* Is the systeme really unbounded ? *)
- | Some(prf1,(lb,e,ub),prf2) ->
- if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ;
- (match start_enum id e (ceiling_num lb) (floor_num ub) sys
- with
- | Some prfl ->
- Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl))
- | None -> None
- )
-
- and start_enum id e clb cub sys =
- if clb >/ cub
- then Some []
- else
- let eq = {coeffs = e ; op = Eq ; cst = clb} in
- match aux_lia (id+1) ((eq, Def id) :: sys) with
- | None -> None
- | Some prf ->
- match start_enum id e (clb +/ (Int 1)) cub sys with
- | None -> None
- | Some l -> Some (prf::l)
-
- and aux_lia (id:int) (sys:prf_sys) : proof option =
- assert (check_sys sys) ;
- if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ;
- try
- let sys = reduction_equations sys in
- if debug then
+ xlinear_prover
+ ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys)
+ with
+ | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub)
+ | _ -> failwith "Interval without proof"
+ )
+ | None -> None
+
+
+let check_sys sys =
+ List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys
+
+
+let xlia (can_enum:bool) reduction_equations sys =
+
+
+ let rec enum_proof (id:int) (sys:prf_sys) : proof option =
+ if debug then (Printf.printf "enum_proof\n" ; flush stdout) ;
+ assert (check_sys sys) ;
+
+ let nsys,prf = List.split sys in
+ match get_bound nsys with
+ | None -> None (* Is the systeme really unbounded ? *)
+ | Some(prf1,(lb,e,ub),prf2) ->
+ if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect e (string_of_num lb) (string_of_num ub) ;
+ (match start_enum id e (ceiling_num lb) (floor_num ub) sys
+ with
+ | Some prfl ->
+ Some(Enum(id,proof_of_farkas prf prf1,e, proof_of_farkas prf prf2,prfl))
+ | None -> None
+ )
+
+ and start_enum id e clb cub sys =
+ if clb >/ cub
+ then Some []
+ else
+ let eq = {coeffs = e ; op = Eq ; cst = clb} in
+ match aux_lia (id+1) ((eq, Def id) :: sys) with
+ | None -> None
+ | Some prf ->
+ match start_enum id e (clb +/ (Int 1)) cub sys with
+ | None -> None
+ | Some l -> Some (prf::l)
+
+ and aux_lia (id:int) (sys:prf_sys) : proof option =
+ assert (check_sys sys) ;
+ if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ;
+ try
+ let sys = reduction_equations sys in
+ if debug then
Printf.printf "after reduction: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ;
- match linear_prover sys with
- | Some prf -> Some (Step(id,prf,Done))
- | None -> enum_proof id sys
- with FoundProof prf ->
+ match linear_prover sys with
+ | Some prf -> Some (Step(id,prf,Done))
+ | None -> if can_enum then enum_proof id sys else None
+ with FoundProof prf ->
(* [reduction_equations] can find a proof *)
- Some(Step(id,prf,Done)) in
+ Some(Step(id,prf,Done)) in
(* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*)
- let id = List.length sys in
- let orpf =
- try
- let sys = simpl_sys sys in
- aux_lia id sys
- with FoundProof pr -> Some(Step(id,pr,Done)) in
- match orpf with
- | None -> None
- | Some prf ->
+ let id = List.length sys in
+ let orpf =
+ try
+ let sys = simpl_sys sys in
+ aux_lia id sys
+ with FoundProof pr -> Some(Step(id,pr,Done)) in
+ match orpf with
+ | None -> None
+ | Some prf ->
(*Printf.printf "direct proof %a\n" output_proof prf ; *)
- let env = mapi (fun _ i -> i) sys in
- let prf = compile_proof env prf in
+ let env = mapi (fun _ i -> i) sys in
+ let prf = compile_proof env prf in
(*try
if Mc.zChecker sys' prf then Some prf else
raise Certificate.BadCertificate
with Failure s -> (Printf.printf "%s" s ; Some prf)
*) Some prf
-
-
- let cstr_compat_of_poly (p,o) =
- let (v,c) = LinPoly.linpol_of_pol p in
- {coeffs = v ; op = o ; cst = minus_num c }
-
-
- let lia sys =
- LinPoly.MonT.clear ();
- let sys = List.map (develop_constraint z_spec) sys in
- let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in
- let sys = mapi (fun c i -> (c,Hyp i)) sys in
- xlia reduction_equations sys
-
-
- let nlia sys =
- LinPoly.MonT.clear ();
- let sys = List.map (develop_constraint z_spec) sys in
- let sys = mapi (fun c i -> (c,Hyp i)) sys in
-
- let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
-
- let collect_square =
- List.fold_left (fun acc ((p,_),_) -> Poly.fold
- (fun m _ acc ->
- match Monomial.sqrt m with
- | None -> acc
- | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in
- let sys = MonMap.fold (fun s m acc ->
- let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in
- let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in
- ((m, Ge), (Square s))::acc) collect_square sys in
-
-(* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*)
-
- let sys =
- if is_linear then sys
- else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') ->
- ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in
+
- let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in
- assert (check_sys sys) ;
- xlia (if is_linear then reduction_equations else reduction_non_lin_equations) sys
+let cstr_compat_of_poly (p,o) =
+ let (v,c) = LinPoly.linpol_of_pol p in
+ {coeffs = v ; op = o ; cst = minus_num c }
+
+
+let lia (can_enum:bool) (prfdepth:int) sys =
+ LinPoly.MonT.clear ();
+ max_nb_cstr := compute_max_nb_cstr sys prfdepth ;
+ let sys = List.map (develop_constraint z_spec) sys in
+ let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in
+ let sys = mapi (fun c i -> (c,Hyp i)) sys in
+ xlia can_enum reduction_equations sys
+
+
+let nlia enum prfdepth sys =
+ LinPoly.MonT.clear ();
+ max_nb_cstr := compute_max_nb_cstr sys prfdepth;
+ let sys = List.map (develop_constraint z_spec) sys in
+ let sys = mapi (fun c i -> (c,Hyp i)) sys in
+
+ let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in
+
+ let collect_square =
+ List.fold_left (fun acc ((p,_),_) -> Poly.fold
+ (fun m _ acc ->
+ match Monomial.sqrt m with
+ | None -> acc
+ | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in
+ let sys = MonMap.fold (fun s m acc ->
+ let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in
+ let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in
+ ((m, Ge), (Square s))::acc) collect_square sys in
+
+ (* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*)
+
+ let sys =
+ if is_linear then sys
+ else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') ->
+ ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in
+
+ let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in
+ assert (check_sys sys) ;
+ xlia enum (if is_linear then reduction_equations else reduction_non_lin_equations) sys
diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml
index cce0a728..e4b58a56 100644
--- a/plugins/micromega/coq_micromega.ml
+++ b/plugins/micromega/coq_micromega.ml
@@ -18,6 +18,7 @@
open Pp
open Mutils
+open Goptions
(**
* Debug flag
@@ -37,6 +38,53 @@ let time str f x =
flush stdout);
res
+
+(* Limit the proof search *)
+
+let max_depth = max_int
+
+(* Search limit for provers over Q R *)
+let lra_proof_depth = ref max_depth
+
+
+(* Search limit for provers over Z *)
+let lia_enum = ref true
+let lia_proof_depth = ref max_depth
+
+let get_lia_option () =
+ (!lia_enum,!lia_proof_depth)
+
+let get_lra_option () =
+ !lra_proof_depth
+
+
+
+let _ =
+
+ let int_opt l vref =
+ {
+ optsync = true;
+ optdepr = false;
+ optname = List.fold_right (^) l "";
+ optkey = l ;
+ optread = (fun () -> Some !vref);
+ optwrite = (fun x -> vref := (match x with None -> max_depth | Some v -> v))
+ } in
+
+ let lia_enum_opt =
+ {
+ optsync = true;
+ optdepr = false;
+ optname = "Lia Enum";
+ optkey = ["Lia";"Enum"];
+ optread = (fun () -> !lia_enum);
+ optwrite = (fun x -> lia_enum := x)
+ } in
+ let _ = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in
+ let _ = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in
+ let _ = declare_bool_option lia_enum_opt in
+ ()
+
(**
* Initialize a tag type to the Tag module declaration (see Mutils).
*)
@@ -99,6 +147,17 @@ let rec map_atoms fct f =
| N f -> N(map_atoms fct f)
| I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2)
+let rec map_prop fct f =
+ match f with
+ | TT -> TT
+ | FF -> FF
+ | X x -> X (fct x)
+ | A (at,tg,cstr) -> A(at,tg,cstr)
+ | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2)
+ | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2)
+ | N f -> N(map_prop fct f)
+ | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2)
+
(**
* Collect the identifiers of a (string of) implications. Implication labels
* are inherited from Coq/CoC's higher order dependent type constructor (Pi).
@@ -244,7 +303,8 @@ let rec add_term t0 = function
*)
module ISet = Set.Make(Int)
-
+module IMap = Map.Make(Int)
+
(**
* Given a set of integers s=\{i0,...,iN\} and a list m, return the list of
* elements of m that are at position i0,...,iN.
@@ -303,7 +363,8 @@ struct
let r_modules =
[["Coq";"Reals" ; "Rdefinitions"];
["Coq";"Reals" ; "Rpow_def"] ;
-]
+ ["Coq";"Reals" ; "Raxioms"] ;
+ ]
let z_modules = [["Coq";"ZArith";"BinInt"]]
@@ -322,6 +383,8 @@ struct
let coq_and = lazy (init_constant "and")
let coq_or = lazy (init_constant "or")
let coq_not = lazy (init_constant "not")
+ let coq_not_gl_ref = (Nametab.locate ( Libnames.qualid_of_string "Coq.Init.Logic.not"))
+
let coq_iff = lazy (init_constant "iff")
let coq_True = lazy (init_constant "True")
let coq_False = lazy (init_constant "False")
@@ -359,6 +422,7 @@ struct
let coq_Qmake = lazy (constant "Qmake")
let coq_Rcst = lazy (constant "Rcst")
+
let coq_C0 = lazy (m_constant "C0")
let coq_C1 = lazy (m_constant "C1")
let coq_CQ = lazy (m_constant "CQ")
@@ -415,8 +479,9 @@ struct
let coq_Rdiv = lazy (r_constant "Rdiv")
let coq_Rinv = lazy (r_constant "Rinv")
let coq_Rpower = lazy (r_constant "pow")
+ let coq_IZR = lazy (r_constant "IZR")
let coq_IQR = lazy (constant "IQR")
- let coq_IZR = lazy (constant "IZR")
+
let coq_PEX = lazy (constant "PEX" )
let coq_PEc = lazy (constant"PEc")
@@ -896,8 +961,20 @@ struct
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)
+ (env, CamlToCoq.positive n)
+
+ let get_rank env v =
+ let rec _get_rank env n =
+ match env with
+ | [] -> raise (Invalid_argument "get_rank")
+ | e::l ->
+ if eq_constr e v
+ then n
+ else _get_rank l (n+1) in
+ _get_rank env 1
+
+
let empty = []
let elements env = env
@@ -910,7 +987,7 @@ struct
let parse_expr parse_constant parse_exp ops_spec env term =
if debug
- then Pp.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term);
+ then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term);
(*
let constant_or_variable env term =
@@ -947,7 +1024,7 @@ struct
let (expr,env) = parse_expr env args.(0) in
let power = (parse_exp expr args.(1)) in
(power , env)
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
(* if the exponent is a variable *)
let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env)
end
@@ -994,7 +1071,7 @@ struct
coq_Rplus , (fun x y -> Mc.CPlus(x,y)) ;
coq_Rminus , (fun x y -> Mc.CMinus(x,y)) ;
coq_Rmult , (fun x y -> Mc.CMult(x,y)) ;
- coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;
+ (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*)
]
let rec rconstant term =
@@ -1016,10 +1093,14 @@ struct
with
ParseError ->
match op with
- | op when Constr.equal op (Lazy.force coq_Rinv) -> Mc.CInv(rconstant args.(0))
- | op when Constr.equal op (Lazy.force coq_IQR) -> Mc.CQ (parse_q args.(0))
-(* | op when op = Lazy.force coq_IZR -> Mc.CZ (parse_z args.(0))*)
- | _ -> raise ParseError
+ | op when Constr.equal op (Lazy.force coq_Rinv) ->
+ let arg = rconstant args.(0) in
+ if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH}
+ then raise ParseError (* This is a division by zero -- no semantics *)
+ else Mc.CInv(arg)
+ | op when Constr.equal op (Lazy.force coq_IQR) -> Mc.CQ (parse_q args.(0))
+ | op when Constr.equal op (Lazy.force coq_IZR) -> Mc.CZ (parse_z args.(0))
+ | _ -> raise ParseError
end
| _ -> raise ParseError
@@ -1027,7 +1108,7 @@ struct
let rconstant term =
if debug
- then Pp.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ());
+ then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ());
let res = rconstant term in
if debug then
(Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ;
@@ -1067,7 +1148,7 @@ struct
let parse_arith parse_op parse_expr env cstr gl =
if debug
- then Pp.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ());
+ then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ());
match kind_of_term cstr with
| App(op,args) ->
let (op,lhs,rhs) = parse_op gl (op,args) in
@@ -1094,10 +1175,6 @@ struct
| N (a) -> Mc.N(f2f a)
| I(a,_,b) -> Mc.I(f2f a,f2f b)
- let is_prop t =
- match t with
- | Names.Anonymous -> true (* Not quite right *)
- | Names.Name x -> false
let mkC f1 f2 = C(f1,f2)
let mkD f1 f2 = D(f1,f2)
@@ -1119,34 +1196,40 @@ struct
try
let (at,env) = parse_atom env t gl in
(A(at,tg,t), env,Tag.next tg)
- with e when Errors.noncritical e -> (X(t),env,tg) in
+ with e when CErrors.noncritical e -> (X(t),env,tg) in
+ let is_prop term =
+ let sort = Retyping.get_sort_of (Tacmach.pf_env gl) (Tacmach.project gl) term in
+ Term.is_prop_sort sort in
+
let rec xparse_formula env tg term =
- match kind_of_term term with
+ match kind_of_term term with
| App(l,rst) ->
- (match rst with
- | [|a;b|] when eq_constr l (Lazy.force coq_and) ->
- let f,env,tg = xparse_formula env tg a in
- let g,env, tg = xparse_formula env tg b in
- mkformula_binary mkC term f g,env,tg
- | [|a;b|] when eq_constr l (Lazy.force coq_or) ->
- let f,env,tg = xparse_formula env tg a in
- let g,env,tg = xparse_formula env tg b in
- mkformula_binary mkD term f g,env,tg
- | [|a|] when eq_constr l (Lazy.force coq_not) ->
- let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg)
- | [|a;b|] when eq_constr l (Lazy.force coq_iff) ->
- let f,env,tg = xparse_formula env tg a in
- let g,env,tg = xparse_formula env tg b in
- mkformula_binary mkIff term f g,env,tg
- | _ -> parse_atom env tg term)
- | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b) ->
+ (match rst with
+ | [|a;b|] when eq_constr l (Lazy.force coq_and) ->
+ let f,env,tg = xparse_formula env tg a in
+ let g,env, tg = xparse_formula env tg b in
+ mkformula_binary mkC term f g,env,tg
+ | [|a;b|] when eq_constr l (Lazy.force coq_or) ->
+ let f,env,tg = xparse_formula env tg a in
+ let g,env,tg = xparse_formula env tg b in
+ mkformula_binary mkD term f g,env,tg
+ | [|a|] when eq_constr l (Lazy.force coq_not) ->
+ let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg)
+ | [|a;b|] when eq_constr l (Lazy.force coq_iff) ->
let f,env,tg = xparse_formula env tg a in
let g,env,tg = xparse_formula env tg b in
- mkformula_binary mkI term f g,env,tg
+ mkformula_binary mkIff term f g,env,tg
+ | _ -> parse_atom env tg term)
+ | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b)->
+ let f,env,tg = xparse_formula env tg a in
+ let g,env,tg = xparse_formula env tg b in
+ mkformula_binary mkI term f g,env,tg
| _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg)
| _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg)
- | _ -> X(term),env,tg in
+ | _ when is_prop term -> X(term),env,tg
+ | _ -> raise ParseError
+ in
xparse_formula env tg ((*Reductionops.whd_zeta*) term)
let dump_formula typ dump_atom f =
@@ -1162,12 +1245,214 @@ struct
| X(t) -> mkApp(Lazy.force coq_X,[|typ ; t|]) in
xdump f
- (**
- * Given a conclusion and a list of affectations, rebuild a term prefixed by
- * the appropriate letins.
- * TODO: reverse the list of bindings!
- *)
+ let prop_env_of_formula form =
+ let rec doit env = function
+ | TT | FF | A(_,_,_) -> env
+ | X t -> fst (Env.compute_rank_add env t)
+ | C(f1,f2) | D(f1,f2) | I(f1,_,f2) ->
+ doit (doit env f1) f2
+ | N f -> doit env f in
+
+ doit [] form
+
+ let var_env_of_formula form =
+
+ let rec vars_of_expr = function
+ | Mc.PEX n -> ISet.singleton (CoqToCaml.positive n)
+ | Mc.PEc z -> ISet.empty
+ | Mc.PEadd(e1,e2) | Mc.PEmul(e1,e2) | Mc.PEsub(e1,e2) ->
+ ISet.union (vars_of_expr e1) (vars_of_expr e2)
+ | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e
+ in
+
+ let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} =
+ ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in
+
+ let rec doit = function
+ | TT | FF | X _ -> ISet.empty
+ | A (a,t,c) -> vars_of_atom a
+ | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2)
+ | N f -> doit f in
+
+ doit form
+
+
+
+
+ type 'cst dump_expr = (* 'cst is the type of the syntactic constants *)
+ {
+ interp_typ : constr;
+ dump_cst : 'cst -> constr;
+ dump_add : constr;
+ dump_sub : constr;
+ dump_opp : constr;
+ dump_mul : constr;
+ dump_pow : constr;
+ dump_pow_arg : Mc.n -> constr;
+ dump_op : (Mc.op2 * Term.constr) list
+ }
+
+let dump_zexpr = lazy
+ {
+ interp_typ = Lazy.force coq_Z;
+ dump_cst = dump_z;
+ dump_add = Lazy.force coq_Zplus;
+ dump_sub = Lazy.force coq_Zminus;
+ dump_opp = Lazy.force coq_Zopp;
+ dump_mul = Lazy.force coq_Zmult;
+ dump_pow = Lazy.force coq_Zpower;
+ dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n)));
+ dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table
+ }
+
+let dump_qexpr = lazy
+ {
+ interp_typ = Lazy.force coq_Q;
+ dump_cst = dump_q;
+ dump_add = Lazy.force coq_Qplus;
+ dump_sub = Lazy.force coq_Qminus;
+ dump_opp = Lazy.force coq_Qopp;
+ dump_mul = Lazy.force coq_Qmult;
+ dump_pow = Lazy.force coq_Qpower;
+ dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n)));
+ dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table
+ }
+
+ let dump_positive_as_R p =
+ let mult = Lazy.force coq_Rmult in
+ let add = Lazy.force coq_Rplus in
+
+ let one = Lazy.force coq_R1 in
+ let mk_add x y = mkApp(add,[|x;y|]) in
+ let mk_mult x y = mkApp(mult,[|x;y|]) in
+
+ let two = mk_add one one in
+
+ let rec dump_positive p =
+ match p with
+ | Mc.XH -> one
+ | Mc.XO p -> mk_mult two (dump_positive p)
+ | Mc.XI p -> mk_add one (mk_mult two (dump_positive p)) in
+
+ dump_positive p
+
+let dump_n_as_R n =
+ let z = CoqToCaml.n n in
+ if z = 0
+ then Lazy.force coq_R0
+ else dump_positive_as_R (CamlToCoq.positive z)
+
+
+let rec dump_Rcst_as_R cst =
+ match cst with
+ | Mc.C0 -> Lazy.force coq_R0
+ | Mc.C1 -> Lazy.force coq_R1
+ | Mc.CQ q -> Term.mkApp(Lazy.force coq_IQR, [| dump_q q |])
+ | Mc.CZ z -> Term.mkApp(Lazy.force coq_IZR, [| dump_z z |])
+ | Mc.CPlus(x,y) -> Term.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |])
+ | Mc.CMinus(x,y) -> Term.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |])
+ | Mc.CMult(x,y) -> Term.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |])
+ | Mc.CInv t -> Term.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |])
+ | Mc.COpp t -> Term.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |])
+
+
+let dump_rexpr = lazy
+ {
+ interp_typ = Lazy.force coq_R;
+ dump_cst = dump_Rcst_as_R;
+ dump_add = Lazy.force coq_Rplus;
+ dump_sub = Lazy.force coq_Rminus;
+ dump_opp = Lazy.force coq_Ropp;
+ dump_mul = Lazy.force coq_Rmult;
+ dump_pow = Lazy.force coq_Rpower;
+ dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n)));
+ dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table
+ }
+
+
+
+
+(** [make_goal_of_formula depxr vars props form] where
+ - vars is an environment for the arithmetic variables occuring in form
+ - props is an environment for the propositions occuring in form
+ @return a goal where all the variables and propositions of the formula are quantified
+
+*)
+
+let rec make_goal_of_formula dexpr form =
+
+ let vars_idx =
+ List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in
+
+ (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*)
+
+ let props = prop_env_of_formula form in
+
+ let vars_n = List.map (fun (_,i) -> (Names.id_of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in
+ let props_n = List.mapi (fun i _ -> (Names.id_of_string (Printf.sprintf "__p%i" (i+1))) , Term.mkProp) props in
+
+ let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in
+
+ let dump_expr i e =
+ let rec dump_expr = function
+ | Mc.PEX n -> mkRel (i+(List.assoc (CoqToCaml.positive n) vars_idx))
+ | Mc.PEc z -> dexpr.dump_cst z
+ | Mc.PEadd(e1,e2) -> mkApp(dexpr.dump_add,
+ [| dump_expr e1;dump_expr e2|])
+ | Mc.PEsub(e1,e2) -> mkApp(dexpr.dump_sub,
+ [| dump_expr e1;dump_expr e2|])
+ | Mc.PEopp e -> mkApp(dexpr.dump_opp,
+ [| dump_expr e|])
+ | Mc.PEmul(e1,e2) -> mkApp(dexpr.dump_mul,
+ [| dump_expr e1;dump_expr e2|])
+ | Mc.PEpow(e,n) -> mkApp(dexpr.dump_pow,
+ [| dump_expr e; dexpr.dump_pow_arg n|])
+ in dump_expr e in
+
+ let mkop op e1 e2 =
+ try
+ Term.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|])
+ with Not_found ->
+ Term.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in
+
+ let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } =
+ mkop fop (dump_expr i flhs) (dump_expr i frhs) in
+
+ let rec xdump pi xi f =
+ match f with
+ | TT -> Lazy.force coq_True
+ | FF -> Lazy.force coq_False
+ | C(x,y) -> mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|])
+ | D(x,y) -> mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|])
+ | I(x,_,y) -> mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y)
+ | N(x) -> mkArrow (xdump pi xi x) (Lazy.force coq_False)
+ | A(x,_,_) -> dump_cstr xi x
+ | X(t) -> let idx = Env.get_rank props t in
+ mkRel (pi+idx) in
+
+ let nb_vars = List.length vars_n in
+ let nb_props = List.length props_n in
+
+ (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*)
+
+ let subst_prop p =
+ let idx = Env.get_rank props p in
+ mkVar (Names.id_of_string (Printf.sprintf "__p%i" idx)) in
+
+ let form' = map_prop subst_prop form in
+
+ (Term.prodn nb_props (List.map (fun (x,y) -> Names.Name x,y) props_n)
+ (Term.prodn nb_vars (List.map (fun (x,y) -> Names.Name x,y) vars_n)
+ (xdump (List.length vars_n) 0 form)),
+ List.rev props_n, List.rev var_name_pos,form')
+
+ (**
+ * Given a conclusion and a list of affectations, rebuild a term prefixed by
+ * the appropriate letins.
+ * TODO: reverse the list of bindings!
+ *)
+
let set l concl =
let rec xset acc = function
| [] -> acc
@@ -1242,29 +1527,25 @@ 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 when Errors.noncritical 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 coq_VarMap = lazy
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t")
+
+
+let rec dump_varmap typ m =
+ match m with
+ | Mc.Empty -> Term.mkApp(Lazy.force coq_Empty,[| typ |])
+ | Mc.Leaf v -> Term.mkApp(Lazy.force coq_Leaf,[| typ; v|])
+ | Mc.Node(l,o,r) ->
+ Term.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |])
+
+
+let vm_of_list env =
+ match env with
+ | [] -> Mc.Empty
+ | (d,_)::_ ->
+ List.fold_left (fun vm (c,i) ->
+ Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env
let rec pp_varmap o vm =
@@ -1329,7 +1610,7 @@ let rec parse_hyps gl parse_arith env tg hyps =
try
let (c,env,tg) = parse_formula gl parse_arith env tg t in
((i,c)::lhyps, env,tg)
- with e when Errors.noncritical e -> (lhyps,env,tg)
+ with e when CErrors.noncritical e -> (lhyps,env,tg)
(*(if debug then Printf.printf "parse_arith : %s\n" x);*)
@@ -1377,50 +1658,81 @@ let rcst_domain_spec = lazy {
dump_proof = dump_psatz coq_Q dump_q
}
+open Proofview.Notations
+
+(** Naive topological sort of constr according to the subterm-ordering *)
+
+(* An element is minimal x is minimal w.r.t y if
+ x <= y or (x and y are incomparable) *)
+
+let is_min le x y =
+ if le x y then true
+ else if le y x then false else true
+
+let is_minimal le l c = List.for_all (is_min le c) l
+
+let find_rem p l =
+ let rec xfind_rem acc l =
+ match l with
+ | [] -> (None, acc)
+ | x :: l -> if p x then (Some x, acc @ l)
+ else xfind_rem (x::acc) l in
+ xfind_rem [] l
+
+let find_minimal le l = find_rem (is_minimal le l) l
+
+let rec mk_topo_order le l =
+ match find_minimal le l with
+ | (None , _) -> []
+ | (Some v,l') -> v :: (mk_topo_order le l')
+
+
+let topo_sort_constr l = mk_topo_order Termops.dependent l
+
+
(**
* Instanciate the current Coq goal with a Micromega formula, a varmap, and a
* witness.
*)
-
-
-let micromega_order_change spec cert cert_typ env ff : Tacmach.tactic =
- let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__z"^(string_of_int i)))) 0 env in
+let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) =
+ (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *)
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
- (* todo : directly generate the proof term - or generalize befor conversion? *)
- Tacticals.tclTHENSEQ [
- (fun gl ->
- Proofview.V82.of_tactic (Tactics.change_concl
- (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);
- Tactics.generalize env ;
- Tacticals.tclTHENSEQ (List.map (fun id -> Proofview.V82.of_tactic (Tactics.introduction id)) ids) ;
- ]
-
+ let vm = dump_varmap (spec.typ) (vm_of_list env) in
+ (* todo : directly generate the proof term - or generalize before conversion? *)
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let gl = Tacmach.New.of_old (fun x -> x) gl in
+ Tacticals.New.tclTHENLIST
+ [
+ Tactics.change_concl
+ (set
+ [
+ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
+ ("__varmap", vm, Term.mkApp(Lazy.force coq_VarMap, [|spec.typ|]));
+ ("__wit", cert, cert_typ)
+ ]
+ (Tacmach.pf_concl gl))
+ ]
+ end }
(**
* The datastructures that aggregate prover attributes.
*)
-type ('a,'prf) prover = {
+type ('option,'a,'prf) prover = {
name : string ; (* name of the prover *)
- prover : 'a list -> 'prf option ; (* the prover itself *)
+ get_option : unit ->'option ; (* find the options of the prover *)
+ prover : 'option * 'a list -> 'prf option ; (* the prover itself *)
hyps : 'prf -> ISet.t ; (* extract the indexes of the hypotheses really used in the proof *)
compact : 'prf -> (int -> int) -> 'prf ; (* remap the hyp indexes according to function *)
pp_prf : out_channel -> 'prf -> unit ;(* pretting printing of proof *)
pp_f : out_channel -> 'a -> unit (* pretty printing of the formulas (polynomials)*)
}
+
+
(**
* Given a list of provers and a disjunction of atoms, find a proof of any of
* the atoms. Returns an (optional) pair of a proof and a prover
@@ -1430,7 +1742,7 @@ type ('a,'prf) prover = {
let find_witness provers polys1 =
let provers = List.map (fun p ->
(fun l ->
- match p.prover l with
+ match p.prover (p.get_option (),l) with
| None -> None
| Some prf -> Some(prf,p)) , p.name) provers in
try_any provers (List.map fst polys1)
@@ -1482,10 +1794,10 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) =
(pp_ml_list prover.pp_f) (List.map fst new_cl) ;
flush stdout
end ; *)
- let res = try prover.compact prf remap with x when Errors.noncritical x ->
+ let res = try prover.compact prf remap with x when CErrors.noncritical x ->
if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ;
(* This should not happen -- this is the recovery plan... *)
- match prover.prover (List.map fst new_cl) with
+ match prover.prover (prover.get_option () ,List.map fst new_cl) with
| None -> failwith "proof compaction error"
| Some p -> p
in
@@ -1562,6 +1874,7 @@ let rec abstract_wrt_formula f1 f2 =
exception CsdpNotFound
+
(**
* This is the core of Micromega: apply the prover, analyze the result and
* prune unused fomulas, and finally modify the proof state.
@@ -1586,12 +1899,12 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2
if debug then
begin
- Pp.pp (Pp.str "Formula....\n") ;
+ Feedback.msg_notice (Pp.str "Formula....\n") ;
let formula_typ = (Term.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in
let ff = dump_formula formula_typ
(dump_cstr spec.typ spec.dump_coeff) ff in
- Pp.pp (Printer.prterm ff) ; Pp.pp_flush ();
- Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff
+ Feedback.msg_notice (Printer.prterm ff);
+ Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff
end;
match witness_list_tags prover cnf_ff with
@@ -1611,11 +1924,11 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2
if debug then
begin
- Pp.pp (Pp.str "\nAFormula\n") ;
+ Feedback.msg_notice (Pp.str "\nAFormula\n") ;
let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in
let ff' = dump_formula formula_typ
(dump_cstr spec.typ spec.dump_coeff) ff' in
- Pp.pp (Printer.prterm ff') ; Pp.pp_flush ();
+ Feedback.msg_notice (Printer.prterm ff');
Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff'
end;
@@ -1646,58 +1959,103 @@ let micromega_gen
(negate:'cst atom -> 'cst mc_cnf)
(normalise:'cst atom -> 'cst mc_cnf)
unsat deduce
- spec prover gl =
- let concl = Tacmach.pf_concl gl in
- let hyps = Tacmach.pf_hyps_types gl in
- try
- let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
- let env = Env.elements env in
- let spec = Lazy.force spec in
-
+ spec dumpexpr prover tac =
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let gl = Tacmach.New.of_old (fun x -> x) gl in
+ let concl = Tacmach.pf_concl gl in
+ let hyps = Tacmach.pf_hyps_types gl in
+ try
+ let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
+ let env = Env.elements env in
+ let spec = Lazy.force spec in
+ let dumpexpr = Lazy.force dumpexpr in
+
match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl with
- | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
- | Some (ids,ff',res') ->
- (Tacticals.tclTHENSEQ
- [
- Tactics.generalize (List.map Term.mkVar ids) ;
- micromega_order_change spec res'
- (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff'
- ]) gl
- with
- | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
- | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
- Tacticals.tclFAIL 0 (Pp.str
- (" Skipping what remains of this tactic: the complexity of the goal requires "
- ^ "the use of a specialized external tool called csdp. \n\n"
- ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
- ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl
-
-
-
-let micromega_order_changer cert env ff gl =
+ | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
+ | Some (ids,ff',res') ->
+ let (arith_goal,props,vars,ff_arith) = make_goal_of_formula dumpexpr ff' in
+ let intro (id,_) = Tactics.introduction id in
+
+ let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in
+ let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in
+ let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in
+ let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in
+ let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in
+
+ let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ;
+ micromega_order_change spec res'
+ (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in
+
+ let goal_props = List.rev (prop_env_of_formula ff') in
+
+ let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in
+
+ let arith_args = goal_props @ goal_vars in
+
+ let kill_arith =
+ Tacticals.New.tclTHEN
+ (Tactics.keep [])
+ ((*Tactics.tclABSTRACT None*)
+ (Tacticals.New.tclTHEN tac_arith tac)) in
+
+ Tacticals.New.tclTHENS
+ (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal)
+ [
+ kill_arith;
+ (Tacticals.New.tclTHENLIST
+ [(Tactics.generalize (List.map Term.mkVar ids));
+ Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args))
+ ] )
+ ]
+ with
+ | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment")
+ | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout")
+ | CsdpNotFound -> flush stdout ;
+ Tacticals.New.tclFAIL 0 (Pp.str
+ (" Skipping what remains of this tactic: the complexity of the goal requires "
+ ^ "the use of a specialized external tool called csdp. \n\n"
+ ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
+ ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp"))
+ end }
+
+let micromega_gen parse_arith
+ (negate:'cst atom -> 'cst mc_cnf)
+ (normalise:'cst atom -> 'cst mc_cnf)
+ unsat deduce
+ spec prover =
+ (micromega_gen parse_arith negate normalise unsat deduce spec prover)
+
+
+
+let micromega_order_changer cert env ff =
+ (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *)
let coeff = Lazy.force coq_Rcst in
let dump_coeff = dump_Rcst in
let typ = Lazy.force coq_R in
let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in
-
- let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in
- let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in
- let vm = dump_varmap (typ) env in
- Proofview.V82.of_tactic (Tactics.change_concl
- (set
+
+ let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in
+ let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in
+ let vm = dump_varmap (typ) (vm_of_list env) in
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let gl = Tacmach.New.of_old (fun x -> x) gl in
+ Tacticals.New.tclTHENLIST
[
- ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
- ("__varmap", vm, Term.mkApp
- (Coqlib.gen_constant_in_modules "VarMap"
- [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|]));
- ("__wit", cert, cert_typ)
+ (Tactics.change_concl
+ (set
+ [
+ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |]));
+ ("__varmap", vm, Term.mkApp
+ (Coqlib.gen_constant_in_modules "VarMap"
+ [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|]));
+ ("__wit", cert, cert_typ)
+ ]
+ (Tacmach.pf_concl gl)));
+ (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*)
]
- (Tacmach.pf_concl gl)
- ))
- gl
-
+ end }
-let micromega_genr prover gl =
+let micromega_genr prover tac =
let parse_arith = parse_rarith in
let negate = Mc.rnegate in
let normalise = Mc.rnormalise in
@@ -1710,41 +2068,77 @@ let micromega_genr prover gl =
proof_typ = Lazy.force coq_QWitness ;
dump_proof = dump_psatz coq_Q dump_q
} in
-
- let concl = Tacmach.pf_concl gl in
- let hyps = Tacmach.pf_hyps_types gl in
- try
- let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
- let env = Env.elements env in
- let spec = Lazy.force spec in
-
- let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in
- let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in
-
- match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with
- | None -> Tacticals.tclFAIL 0 (Pp.str " Cannot find witness") gl
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let gl = Tacmach.New.of_old (fun x -> x) gl in
+ let concl = Tacmach.pf_concl gl in
+ let hyps = Tacmach.pf_hyps_types gl in
+
+ try
+ let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in
+ let env = Env.elements env in
+ let spec = Lazy.force spec in
+
+ let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in
+ let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in
+
+ match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with
+ | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness")
| Some (ids,ff',res') ->
- let (ff,ids') = formula_hyps_concl
+ let (ff,ids) = formula_hyps_concl
(List.filter (fun (n,_) -> List.mem n ids) hyps) concl in
+ let ff' = abstract_wrt_formula ff' ff in
+
+ let (arith_goal,props,vars,ff_arith) = make_goal_of_formula (Lazy.force dump_rexpr) ff' in
+ let intro (id,_) = Tactics.introduction id in
+
+ let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in
+ let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in
+ let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in
+ let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in
+ let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in
+
+ let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ;
+ micromega_order_changer res' env' ff_arith ] in
+
+ let goal_props = List.rev (prop_env_of_formula ff') in
+
+ let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in
+
+ let arith_args = goal_props @ goal_vars in
+
+ let kill_arith =
+ Tacticals.New.tclTHEN
+ (Tactics.keep [])
+ ((*Tactics.tclABSTRACT None*)
+ (Tacticals.New.tclTHEN tac_arith tac)) in
- (Tacticals.tclTHENSEQ
- [
- Tactics.generalize (List.map Term.mkVar ids) ;
- micromega_order_changer res' env (abstract_wrt_formula ff' ff)
- ]) gl
- with
- | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl
- | CsdpNotFound -> flush stdout ; Pp.pp_flush () ;
- Tacticals.tclFAIL 0 (Pp.str
- (" Skipping what remains of this tactic: the complexity of the goal requires "
- ^ "the use of a specialized external tool called csdp. \n\n"
- ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
- ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) gl
+ Tacticals.New.tclTHENS
+ (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal)
+ [
+ kill_arith;
+ (Tacticals.New.tclTHENLIST
+ [(Tactics.generalize (List.map Term.mkVar ids));
+ Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args))
+ ] )
+ ]
+ with
+ | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment")
+ | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout")
+ | CsdpNotFound -> flush stdout ;
+ Tacticals.New.tclFAIL 0 (Pp.str
+ (" Skipping what remains of this tactic: the complexity of the goal requires "
+ ^ "the use of a specialized external tool called csdp. \n\n"
+ ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n"
+ ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp"))
+ end }
+let micromega_genr prover = (micromega_genr prover)
+
+
let lift_ratproof prover l =
match prover l with
| None -> None
@@ -1766,7 +2160,7 @@ module Cache = PHashtable(struct
let hash = Hashtbl.hash
end)
-let csdp_cache = "csdp.cache"
+let csdp_cache = ".csdp.cache"
(**
* Build the command to call csdpcert, and launch it. This in turn will call
@@ -1818,7 +2212,7 @@ let call_csdpcert_q provername poly =
let cert = Certificate.q_cert_of_pos cert in
if Mc.qWeakChecker poly cert
then Some cert
- else ((print_string "buggy certificate" ; flush stdout) ;None)
+ else ((print_string "buggy certificate") ;None)
let call_csdpcert_z provername poly =
let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in
@@ -1898,38 +2292,61 @@ let compact_pt pt f =
let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l)
-let linear_prover_Z = {
- name = "linear prover" ;
- prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ;
- hyps = hyps_of_pt ;
- compact = compact_pt ;
- pp_prf = pp_proof_term;
- pp_f = fun o x -> pp_pol pp_z o (fst x)
-}
+module CacheZ = PHashtable(struct
+ type prover_option = bool * int
+
+ type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list)
+ let equal = (=)
+ let hash = Hashtbl.hash
+end)
+module CacheQ = PHashtable(struct
+ type t = int * ((Mc.q Mc.pol * Mc.op1) list)
+ let equal = (=)
+ let hash = Hashtbl.hash
+end)
+
+let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s)
+let memo_nlia = CacheZ.memo ".nia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s)
+let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s)
+
+
+
let linear_prover_Q = {
- name = "linear prover";
- prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ;
- hyps = hyps_of_cone ;
- compact = compact_cone ;
- pp_prf = pp_psatz pp_q ;
- pp_f = fun o x -> pp_pol pp_q o (fst x)
+ name = "linear prover";
+ get_option = get_lra_option ;
+ prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ;
+ hyps = hyps_of_cone ;
+ compact = compact_cone ;
+ pp_prf = pp_psatz pp_q ;
+ pp_f = fun o x -> pp_pol pp_q o (fst x)
}
let linear_prover_R = {
name = "linear prover";
- prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ;
+ get_option = get_lra_option ;
+ prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ;
hyps = hyps_of_cone ;
compact = compact_cone ;
pp_prf = pp_psatz pp_q ;
pp_f = fun o x -> pp_pol pp_q o (fst x)
}
+let nlinear_prover_R = {
+ name = "nra";
+ get_option = get_lra_option;
+ prover = memo_nra ;
+ hyps = hyps_of_cone ;
+ compact = compact_cone ;
+ pp_prf = pp_psatz pp_q ;
+ pp_f = fun o x -> pp_pol pp_q o (fst x)
+}
let non_linear_prover_Q str o = {
name = "real nonlinear prover";
- prover = call_csdpcert_q (str, o);
+ get_option = (fun () -> (str,o));
+ prover = (fun (o,l) -> call_csdpcert_q o l);
hyps = hyps_of_cone;
compact = compact_cone ;
pp_prf = pp_psatz pp_q ;
@@ -1938,7 +2355,8 @@ let non_linear_prover_Q str o = {
let non_linear_prover_R str o = {
name = "real nonlinear prover";
- prover = call_csdpcert_q (str, o);
+ get_option = (fun () -> (str,o));
+ prover = (fun (o,l) -> call_csdpcert_q o l);
hyps = hyps_of_cone;
compact = compact_cone;
pp_prf = pp_psatz pp_q;
@@ -1947,30 +2365,18 @@ let non_linear_prover_R str o = {
let non_linear_prover_Z str o = {
name = "real nonlinear prover";
- prover = lift_ratproof (call_csdpcert_z (str, o));
+ get_option = (fun () -> (str,o));
+ prover = (fun (o,l) -> lift_ratproof (call_csdpcert_z o) l);
hyps = hyps_of_pt;
compact = compact_pt;
pp_prf = pp_proof_term;
pp_f = fun o x -> pp_pol pp_z o (fst x)
}
-module CacheZ = PHashtable(struct
- type t = (Mc.z Mc.pol * Mc.op1) list
- let equal = Pervasives.(=)
- let hash = Hashtbl.hash
-end)
-
-let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.lia)
-let memo_nlia = CacheZ.memo "nlia.cache" (lift_pexpr_prover Certificate.nlia)
-
-(*let memo_zlinear_prover = (lift_pexpr_prover Lia.lia)*)
-(*let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate.zlinear_prover)*)
-
-
-
let linear_Z = {
name = "lia";
- prover = memo_zlinear_prover ;
+ get_option = get_lia_option;
+ prover = memo_zlinear_prover ;
hyps = hyps_of_pt;
compact = compact_pt;
pp_prf = pp_proof_term;
@@ -1979,7 +2385,8 @@ let linear_Z = {
let nlinear_Z = {
name = "nlia";
- prover = memo_nlia ;
+ get_option = get_lia_option;
+ prover = memo_nlia ;
hyps = hyps_of_pt;
compact = compact_pt;
pp_prf = pp_proof_term;
@@ -2001,57 +2408,53 @@ let tauto_lia ff =
* solvers
*)
-let psatzl_Z gl =
- micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ linear_prover_Z ] gl
-
-let psatzl_Q gl =
- micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
- [ linear_prover_Q ] gl
-
-let psatz_Q i gl =
- micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
- [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl
+let lra_Q =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr
+ [ linear_prover_Q ]
+let psatz_Q i =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr
+ [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ]
-let psatzl_R gl =
- micromega_genr [ linear_prover_R ] gl
+let lra_R =
+ micromega_genr [ linear_prover_R ]
+let psatz_R i =
+ micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ]
-let psatz_R i gl =
- micromega_genr [ non_linear_prover_R "real_nonlinear_prover" (Some i) ] gl
+let psatz_Z i =
+ micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr
+ [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ]
-let psatz_Z i gl =
- micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl
+let sos_Z =
+ micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr
+ [ non_linear_prover_Z "pure_sos" None ]
-let sos_Z gl =
- micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ non_linear_prover_Z "pure_sos" None ] gl
+let sos_Q =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr
+ [ non_linear_prover_Q "pure_sos" None ]
-let sos_Q gl =
- micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec
- [ non_linear_prover_Q "pure_sos" None ] gl
+let sos_R =
+ micromega_genr [ non_linear_prover_R "pure_sos" None ]
-let sos_R gl =
- micromega_genr [ non_linear_prover_R "pure_sos" None ] gl
+let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr
+ [ linear_Z ]
-let xlia gl =
- try
- micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ linear_Z ] gl
- with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise
+let xnlia =
+ micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr
+ [ nlinear_Z ]
-let xnlia gl =
- try
- micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec
- [ nlinear_Z ] gl
- with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise
+let nra =
+ micromega_genr [ nlinear_prover_R ]
+let nqa =
+ micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr
+ [ nlinear_prover_R ]
+
(* Local Variables: *)
(* coding: utf-8 *)
diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4
index 75237aaa..027f690f 100644
--- a/plugins/micromega/g_micromega.ml4
+++ b/plugins/micromega/g_micromega.ml4
@@ -16,63 +16,68 @@
(*i camlp4deps: "grammar/grammar.cma" i*)
-open Errors
-open Misctypes
+open Constrarg
DECLARE PLUGIN "micromega_plugin"
-let out_arg = function
- | ArgVar _ -> anomaly (Pp.str "Unevaluated or_var variable")
- | ArgArg x -> x
+TACTIC EXTEND RED
+| [ "myred" ] -> [ Tactics.red_in_concl ]
+END
+
+
TACTIC EXTEND PsatzZ
-| [ "psatz_Z" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (out_arg i)) ]
-| [ "psatz_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Z (-1)) ]
+| [ "psatz_Z" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_Z i
+ (Tacinterp.tactic_of_value ist t))
+ ]
+| [ "psatz_Z" tactic(t)] -> [ (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) ]
END
TACTIC EXTEND Lia
-[ "xlia" ] -> [ Proofview.V82.tactic (Coq_micromega.xlia) ]
+[ "xlia" tactic(t) ] -> [ (Coq_micromega.xlia (Tacinterp.tactic_of_value ist t)) ]
END
TACTIC EXTEND Nia
-[ "xnlia" ] -> [ Proofview.V82.tactic (Coq_micromega.xnlia) ]
+[ "xnlia" tactic(t) ] -> [ (Coq_micromega.xnlia (Tacinterp.tactic_of_value ist t)) ]
+END
+
+TACTIC EXTEND NRA
+[ "xnra" tactic(t) ] -> [ (Coq_micromega.nra (Tacinterp.tactic_of_value ist t))]
END
+TACTIC EXTEND NQA
+[ "xnqa" tactic(t) ] -> [ (Coq_micromega.nqa (Tacinterp.tactic_of_value ist t))]
+END
+
TACTIC EXTEND Sos_Z
-| [ "sos_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_Z) ]
+| [ "sos_Z" tactic(t) ] -> [ (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) ]
END
TACTIC EXTEND Sos_Q
-| [ "sos_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_Q) ]
+| [ "sos_Q" tactic(t) ] -> [ (Coq_micromega.sos_Q (Tacinterp.tactic_of_value ist t)) ]
END
TACTIC EXTEND Sos_R
-| [ "sos_R" ] -> [ Proofview.V82.tactic (Coq_micromega.sos_R) ]
-END
-
-(*
-TACTIC EXTEND Omicron
-[ "psatzl_Z" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_Z) ]
+| [ "sos_R" tactic(t) ] -> [ (Coq_micromega.sos_R (Tacinterp.tactic_of_value ist t)) ]
END
-*)
TACTIC EXTEND LRA_Q
-[ "psatzl_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_Q) ]
+[ "lra_Q" tactic(t) ] -> [ (Coq_micromega.lra_Q (Tacinterp.tactic_of_value ist t)) ]
END
TACTIC EXTEND LRA_R
-[ "psatzl_R" ] -> [ Proofview.V82.tactic (Coq_micromega.psatzl_R) ]
+[ "lra_R" tactic(t) ] -> [ (Coq_micromega.lra_R (Tacinterp.tactic_of_value ist t)) ]
END
TACTIC EXTEND PsatzR
-| [ "psatz_R" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_R (out_arg i)) ]
-| [ "psatz_R" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_R (-1)) ]
+| [ "psatz_R" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) ]
+| [ "psatz_R" tactic(t) ] -> [ (Coq_micromega.psatz_R (-1) (Tacinterp.tactic_of_value ist t)) ]
END
TACTIC EXTEND PsatzQ
-| [ "psatz_Q" int_or_var(i) ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (out_arg i)) ]
-| [ "psatz_Q" ] -> [ Proofview.V82.tactic (Coq_micromega.psatz_Q (-1)) ]
+| [ "psatz_Q" int_or_var(i) tactic(t) ] -> [ (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) ]
+| [ "psatz_Q" tactic(t) ] -> [ (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) ]
END
diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml
index a36369d2..f4f9b3c2 100644
--- a/plugins/micromega/mfourier.ml
+++ b/plugins/micromega/mfourier.ml
@@ -98,12 +98,12 @@ module PSet = ISet
module System = Hashtbl.Make(Vect)
- type proof =
- | Hyp of int
- | Elim of var * proof * proof
- | And of proof * proof
-
+type proof =
+| Hyp of int
+| Elim of var * proof * proof
+| And of proof * proof
+let max_nb_cstr = ref max_int
type system = {
sys : cstr_info ref System.t ;
@@ -120,7 +120,7 @@ and cstr_info = {
(** A system of constraints has the form [\{sys = s ; vars = v\}].
[s] is a hashtable mapping a normalised vector to a [cstr_info] record where
- [bound] is an interval
- - [prf_idx] is the set of hypothese indexes (i.e. constraints in the initial system) used to obtain the current constraint.
+ - [prf_idx] is the set of hypothesis indexes (i.e. constraints in the initial system) used to obtain the current constraint.
In the initial system, each constraint is given an unique singleton proof_idx.
When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn]
- [pos] is the number of positive values of the vector
@@ -208,8 +208,7 @@ let merge_cstr_info i1 i2 =
*)
let xadd_cstr vect cstr_info sys =
- if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ;
- try
+ try
let info = System.find sys vect in
match merge_cstr_info cstr_info !info with
| None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf)))
@@ -217,6 +216,13 @@ let xadd_cstr vect cstr_info sys =
with
| Not_found -> System.replace sys vect (ref cstr_info)
+exception TimeOut
+
+let xadd_cstr vect cstr_info sys =
+ if debug && Int.equal (System.length sys mod 1000) 0 then (print_string "*" ; flush stdout) ;
+ if System.length sys < !max_nb_cstr
+ then xadd_cstr vect cstr_info sys
+ else raise TimeOut
type cstr_ext =
| Contradiction (** The constraint is contradictory.
@@ -728,7 +734,7 @@ struct
| Inl (s,_) ->
try
Some (bound_of_variable IMap.empty fresh s.sys)
- with x when Errors.noncritical x ->
+ with x when CErrors.noncritical x ->
Printf.printf "optimise Exception : %s" (Printexc.to_string x);
None
@@ -866,7 +872,7 @@ let mk_proof hyps prf =
| Elim(v,prf1,prf2) ->
let prfsl = mk_proof prf1
and prfsr = mk_proof prf2 in
- (* I take only the pairs for which the elimination is meaningfull *)
+ (* I take only the pairs for which the elimination is meaningful *)
forall_pairs (pivot v) prfsl prfsr
| And(prf1,prf2) ->
let prfsl1 = mk_proof prf1
diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml
index 0537cdbe..5cf1da8e 100644
--- a/plugins/micromega/micromega.ml
+++ b/plugins/micromega/micromega.ml
@@ -1,6 +1,3 @@
-type __ = Obj.t
-let __ = let rec f _ = Obj.repr f in Obj.repr f
-
(** val negb : bool -> bool **)
let negb = function
@@ -11,16 +8,6 @@ type nat =
| O
| S of nat
-(** val fst : ('a1 * 'a2) -> 'a1 **)
-
-let fst = function
-| x,y -> x
-
-(** val snd : ('a1 * 'a2) -> 'a2 **)
-
-let snd = function
-| x,y -> y
-
(** val app : 'a1 list -> 'a1 list -> 'a1 list **)
let rec app l m =
@@ -40,42 +27,15 @@ let compOpp = function
| Lt -> Gt
| Gt -> Lt
-type compareSpecT =
-| CompEqT
-| CompLtT
-| CompGtT
-
-(** val compareSpec2Type : comparison -> compareSpecT **)
-
-let compareSpec2Type = function
-| Eq -> CompEqT
-| Lt -> CompLtT
-| Gt -> CompGtT
-
-type 'a compSpecT = compareSpecT
-
-(** val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT **)
-
-let compSpec2Type x y c =
- compareSpec2Type c
-
-type 'a sig0 =
- 'a
- (* singleton inductive, whose constructor was exist *)
-
-(** val plus : nat -> nat -> nat **)
-
-let rec plus n0 m =
- match n0 with
- | O -> m
- | S p -> S (plus p m)
-
-(** val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
+module Coq__1 = struct
+ (** val add : nat -> nat -> nat **)
+ let rec add n0 m =
+ match n0 with
+ | O -> m
+ | S p -> S (add p m)
+end
+let add = Coq__1.add
-let rec nat_iter n0 f x =
- match n0 with
- | O -> x
- | S n' -> f (nat_iter n' f x)
type positive =
| XI of positive
@@ -91,592 +51,25 @@ type z =
| Zpos of positive
| Zneg of positive
-module type TotalOrder' =
- sig
- type t
- end
-
-module MakeOrderTac =
- functor (O:TotalOrder') ->
- struct
-
- end
-
-module MaxLogicalProperties =
- functor (O:TotalOrder') ->
- functor (M:sig
- val max : O.t -> O.t -> O.t
- end) ->
- struct
- module T = MakeOrderTac(O)
- end
-
-module Pos =
- struct
- type t = positive
-
- (** val succ : positive -> positive **)
-
- let rec succ = function
- | XI p -> XO (succ p)
- | XO p -> XI p
- | XH -> XO XH
-
- (** val add : positive -> positive -> positive **)
-
- let rec add x y =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> XO (add_carry p q0)
- | XO q0 -> XI (add p q0)
- | XH -> XO (succ p))
- | XO p ->
- (match y with
- | XI q0 -> XI (add p q0)
- | XO q0 -> XO (add p q0)
- | XH -> XI p)
- | XH ->
- (match y with
- | XI q0 -> XO (succ q0)
- | XO q0 -> XI q0
- | XH -> XO XH)
-
- (** val add_carry : positive -> positive -> positive **)
-
- and add_carry x y =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> XI (add_carry p q0)
- | XO q0 -> XO (add_carry p q0)
- | XH -> XI (succ p))
- | XO p ->
- (match y with
- | XI q0 -> XO (add_carry p q0)
- | XO q0 -> XI (add p q0)
- | XH -> XO (succ p))
- | XH ->
- (match y with
- | XI q0 -> XI (succ q0)
- | XO q0 -> XO (succ q0)
- | XH -> XI XH)
-
- (** val pred_double : positive -> positive **)
-
- let rec pred_double = function
- | XI p -> XI (XO p)
- | XO p -> XI (pred_double p)
- | XH -> XH
-
- (** val pred : positive -> positive **)
-
- let pred = function
- | XI p -> XO p
- | XO p -> pred_double p
- | XH -> XH
-
- (** val pred_N : positive -> n **)
-
- let pred_N = function
- | XI p -> Npos (XO p)
- | XO p -> Npos (pred_double p)
- | XH -> N0
-
+module Pos =
+ struct
type mask =
| IsNul
| IsPos of positive
| IsNeg
-
- (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
-
- let mask_rect f f0 f1 = function
- | IsNul -> f
- | IsPos x -> f0 x
- | IsNeg -> f1
-
- (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
-
- let mask_rec f f0 f1 = function
- | IsNul -> f
- | IsPos x -> f0 x
- | IsNeg -> f1
-
- (** val succ_double_mask : mask -> mask **)
-
- let succ_double_mask = function
- | IsNul -> IsPos XH
- | IsPos p -> IsPos (XI p)
- | IsNeg -> IsNeg
-
- (** val double_mask : mask -> mask **)
-
- let double_mask = function
- | IsPos p -> IsPos (XO p)
- | x0 -> x0
-
- (** val double_pred_mask : positive -> mask **)
-
- let double_pred_mask = function
- | XI p -> IsPos (XO (XO p))
- | XO p -> IsPos (XO (pred_double p))
- | XH -> IsNul
-
- (** val pred_mask : mask -> mask **)
-
- let pred_mask = function
- | IsPos q0 ->
- (match q0 with
- | XH -> IsNul
- | _ -> IsPos (pred q0))
- | _ -> IsNeg
-
- (** val sub_mask : positive -> positive -> mask **)
-
- let rec sub_mask x y =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> double_mask (sub_mask p q0)
- | XO q0 -> succ_double_mask (sub_mask p q0)
- | XH -> IsPos (XO p))
- | XO p ->
- (match y with
- | XI q0 -> succ_double_mask (sub_mask_carry p q0)
- | XO q0 -> double_mask (sub_mask p q0)
- | XH -> IsPos (pred_double p))
- | XH ->
- (match y with
- | XH -> IsNul
- | _ -> IsNeg)
-
- (** val sub_mask_carry : positive -> positive -> mask **)
-
- and sub_mask_carry x y =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> succ_double_mask (sub_mask_carry p q0)
- | XO q0 -> double_mask (sub_mask p q0)
- | XH -> IsPos (pred_double p))
- | XO p ->
- (match y with
- | XI q0 -> double_mask (sub_mask_carry p q0)
- | XO q0 -> succ_double_mask (sub_mask_carry p q0)
- | XH -> double_pred_mask p)
- | XH -> IsNeg
-
- (** val sub : positive -> positive -> positive **)
-
- let sub x y =
- match sub_mask x y with
- | IsPos z0 -> z0
- | _ -> XH
-
- (** val mul : positive -> positive -> positive **)
-
- let rec mul x y =
- match x with
- | XI p -> add y (XO (mul p y))
- | XO p -> XO (mul p y)
- | XH -> y
-
- (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
-
- let rec iter n0 f x =
- match n0 with
- | XI n' -> f (iter n' f (iter n' f x))
- | XO n' -> iter n' f (iter n' f x)
- | XH -> f x
-
- (** val pow : positive -> positive -> positive **)
-
- let pow x y =
- iter y (mul x) XH
-
- (** val div2 : positive -> positive **)
-
- let div2 = function
- | XI p2 -> p2
- | XO p2 -> p2
- | XH -> XH
-
- (** val div2_up : positive -> positive **)
-
- let div2_up = function
- | XI p2 -> succ p2
- | XO p2 -> p2
- | XH -> XH
-
- (** val size_nat : positive -> nat **)
-
- let rec size_nat = function
- | XI p2 -> S (size_nat p2)
- | XO p2 -> S (size_nat p2)
- | XH -> S O
-
- (** val size : positive -> positive **)
-
- let rec size = function
- | XI p2 -> succ (size p2)
- | XO p2 -> succ (size p2)
- | XH -> XH
-
- (** val compare_cont : positive -> positive -> comparison -> comparison **)
-
- let rec compare_cont x y r =
- match x with
- | XI p ->
- (match y with
- | XI q0 -> compare_cont p q0 r
- | XO q0 -> compare_cont p q0 Gt
- | XH -> Gt)
- | XO p ->
- (match y with
- | XI q0 -> compare_cont p q0 Lt
- | XO q0 -> compare_cont p q0 r
- | XH -> Gt)
- | XH ->
- (match y with
- | XH -> r
- | _ -> Lt)
-
- (** val compare : positive -> positive -> comparison **)
-
- let compare x y =
- compare_cont x y Eq
-
- (** val min : positive -> positive -> positive **)
-
- let min p p' =
- match compare p p' with
- | Gt -> p'
- | _ -> p
-
- (** val max : positive -> positive -> positive **)
-
- let max p p' =
- match compare p p' with
- | Gt -> p
- | _ -> p'
-
- (** val eqb : positive -> positive -> bool **)
-
- let rec eqb p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> eqb p2 q1
- | _ -> false)
- | XO p2 ->
- (match q0 with
- | XO q1 -> eqb p2 q1
- | _ -> false)
- | XH ->
- (match q0 with
- | XH -> true
- | _ -> false)
-
- (** val leb : positive -> positive -> bool **)
-
- let leb x y =
- match compare x y with
- | Gt -> false
- | _ -> true
-
- (** val ltb : positive -> positive -> bool **)
-
- let ltb x y =
- match compare x y with
- | Lt -> true
- | _ -> false
-
- (** val sqrtrem_step :
- (positive -> positive) -> (positive -> positive) -> (positive * mask)
- -> positive * mask **)
-
- let sqrtrem_step f g = function
- | s,y ->
- (match y with
- | IsPos r ->
- let s' = XI (XO s) in
- let r' = g (f r) in
- if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r')
- | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH))))
-
- (** val sqrtrem : positive -> positive * mask **)
-
- let rec sqrtrem = function
- | XI p2 ->
- (match p2 with
- | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3)
- | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3)
- | XH -> XH,(IsPos (XO XH)))
- | XO p2 ->
- (match p2 with
- | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3)
- | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3)
- | XH -> XH,(IsPos XH))
- | XH -> XH,IsNul
-
- (** val sqrt : positive -> positive **)
-
- let sqrt p =
- fst (sqrtrem p)
-
- (** val gcdn : nat -> positive -> positive -> positive **)
-
- let rec gcdn n0 a b =
- match n0 with
- | O -> XH
- | S n1 ->
- (match a with
- | XI a' ->
- (match b with
- | XI b' ->
- (match compare a' b' with
- | Eq -> a
- | Lt -> gcdn n1 (sub b' a') a
- | Gt -> gcdn n1 (sub a' b') b)
- | XO b0 -> gcdn n1 a b0
- | XH -> XH)
- | XO a0 ->
- (match b with
- | XI p -> gcdn n1 a0 b
- | XO b0 -> XO (gcdn n1 a0 b0)
- | XH -> XH)
- | XH -> XH)
-
- (** val gcd : positive -> positive -> positive **)
-
- let gcd a b =
- gcdn (plus (size_nat a) (size_nat b)) a b
-
- (** val ggcdn :
- nat -> positive -> positive -> positive * (positive * positive) **)
-
- let rec ggcdn n0 a b =
- match n0 with
- | O -> XH,(a,b)
- | S n1 ->
- (match a with
- | XI a' ->
- (match b with
- | XI b' ->
- (match compare a' b' with
- | Eq -> a,(XH,XH)
- | Lt ->
- let g,p = ggcdn n1 (sub b' a') a in
- let ba,aa = p in g,(aa,(add aa (XO ba)))
- | Gt ->
- let g,p = ggcdn n1 (sub a' b') b in
- let ab,bb = p in g,((add bb (XO ab)),bb))
- | XO b0 ->
- let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb))
- | XH -> XH,(a,XH))
- | XO a0 ->
- (match b with
- | XI p ->
- let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb)
- | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p
- | XH -> XH,(a,XH))
- | XH -> XH,(XH,b))
-
- (** val ggcd : positive -> positive -> positive * (positive * positive) **)
-
- let ggcd a b =
- ggcdn (plus (size_nat a) (size_nat b)) a b
-
- (** val coq_Nsucc_double : n -> n **)
-
- let coq_Nsucc_double = function
- | N0 -> Npos XH
- | Npos p -> Npos (XI p)
-
- (** val coq_Ndouble : n -> n **)
-
- let coq_Ndouble = function
- | N0 -> N0
- | Npos p -> Npos (XO p)
-
- (** val coq_lor : positive -> positive -> positive **)
-
- let rec coq_lor p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> XI (coq_lor p2 q1)
- | XO q1 -> XI (coq_lor p2 q1)
- | XH -> p)
- | XO p2 ->
- (match q0 with
- | XI q1 -> XI (coq_lor p2 q1)
- | XO q1 -> XO (coq_lor p2 q1)
- | XH -> XI p2)
- | XH ->
- (match q0 with
- | XO q1 -> XI q1
- | _ -> q0)
-
- (** val coq_land : positive -> positive -> n **)
-
- let rec coq_land p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> coq_Nsucc_double (coq_land p2 q1)
- | XO q1 -> coq_Ndouble (coq_land p2 q1)
- | XH -> Npos XH)
- | XO p2 ->
- (match q0 with
- | XI q1 -> coq_Ndouble (coq_land p2 q1)
- | XO q1 -> coq_Ndouble (coq_land p2 q1)
- | XH -> N0)
- | XH ->
- (match q0 with
- | XO q1 -> N0
- | _ -> Npos XH)
-
- (** val ldiff : positive -> positive -> n **)
-
- let rec ldiff p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> coq_Ndouble (ldiff p2 q1)
- | XO q1 -> coq_Nsucc_double (ldiff p2 q1)
- | XH -> Npos (XO p2))
- | XO p2 ->
- (match q0 with
- | XI q1 -> coq_Ndouble (ldiff p2 q1)
- | XO q1 -> coq_Ndouble (ldiff p2 q1)
- | XH -> Npos p)
- | XH ->
- (match q0 with
- | XO q1 -> Npos XH
- | _ -> N0)
-
- (** val coq_lxor : positive -> positive -> n **)
-
- let rec coq_lxor p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> coq_Ndouble (coq_lxor p2 q1)
- | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1)
- | XH -> Npos (XO p2))
- | XO p2 ->
- (match q0 with
- | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1)
- | XO q1 -> coq_Ndouble (coq_lxor p2 q1)
- | XH -> Npos (XI p2))
- | XH ->
- (match q0 with
- | XI q1 -> Npos (XO q1)
- | XO q1 -> Npos (XI q1)
- | XH -> N0)
-
- (** val shiftl_nat : positive -> nat -> positive **)
-
- let shiftl_nat p n0 =
- nat_iter n0 (fun x -> XO x) p
-
- (** val shiftr_nat : positive -> nat -> positive **)
-
- let shiftr_nat p n0 =
- nat_iter n0 div2 p
-
- (** val shiftl : positive -> n -> positive **)
-
- let shiftl p = function
- | N0 -> p
- | Npos n1 -> iter n1 (fun x -> XO x) p
-
- (** val shiftr : positive -> n -> positive **)
-
- let shiftr p = function
- | N0 -> p
- | Npos n1 -> iter n1 div2 p
-
- (** val testbit_nat : positive -> nat -> bool **)
-
- let rec testbit_nat p n0 =
- match p with
- | XI p2 ->
- (match n0 with
- | O -> true
- | S n' -> testbit_nat p2 n')
- | XO p2 ->
- (match n0 with
- | O -> false
- | S n' -> testbit_nat p2 n')
- | XH ->
- (match n0 with
- | O -> true
- | S n1 -> false)
-
- (** val testbit : positive -> n -> bool **)
-
- let rec testbit p n0 =
- match p with
- | XI p2 ->
- (match n0 with
- | N0 -> true
- | Npos n1 -> testbit p2 (pred_N n1))
- | XO p2 ->
- (match n0 with
- | N0 -> false
- | Npos n1 -> testbit p2 (pred_N n1))
- | XH ->
- (match n0 with
- | N0 -> true
- | Npos p2 -> false)
-
- (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **)
-
- let rec iter_op op p a =
- match p with
- | XI p2 -> op a (iter_op op p2 (op a a))
- | XO p2 -> iter_op op p2 (op a a)
- | XH -> a
-
- (** val to_nat : positive -> nat **)
-
- let to_nat x =
- iter_op plus x (S O)
-
- (** val of_nat : nat -> positive **)
-
- let rec of_nat = function
- | O -> XH
- | S x ->
- (match x with
- | O -> XH
- | S n1 -> succ (of_nat x))
-
- (** val of_succ_nat : nat -> positive **)
-
- let rec of_succ_nat = function
- | O -> XH
- | S x -> succ (of_succ_nat x)
end
-module Coq_Pos =
- struct
- module Coq__1 = struct
- type t = positive
- end
- type t = Coq__1.t
-
+module Coq_Pos =
+ struct
(** val succ : positive -> positive **)
-
+
let rec succ = function
| XI p -> XO (succ p)
| XO p -> XI p
| XH -> XO XH
-
+
(** val add : positive -> positive -> positive **)
-
+
let rec add x y =
match x with
| XI p ->
@@ -694,9 +87,9 @@ module Coq_Pos =
| XI q0 -> XO (succ q0)
| XO q0 -> XI q0
| XH -> XO XH)
-
+
(** val add_carry : positive -> positive -> positive **)
-
+
and add_carry x y =
match x with
| XI p ->
@@ -714,78 +107,41 @@ module Coq_Pos =
| XI q0 -> XI (succ q0)
| XO q0 -> XO (succ q0)
| XH -> XI XH)
-
+
(** val pred_double : positive -> positive **)
-
+
let rec pred_double = function
| XI p -> XI (XO p)
| XO p -> XI (pred_double p)
| XH -> XH
-
- (** val pred : positive -> positive **)
-
- let pred = function
- | XI p -> XO p
- | XO p -> pred_double p
- | XH -> XH
-
- (** val pred_N : positive -> n **)
-
- let pred_N = function
- | XI p -> Npos (XO p)
- | XO p -> Npos (pred_double p)
- | XH -> N0
-
+
type mask = Pos.mask =
| IsNul
| IsPos of positive
| IsNeg
-
- (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
-
- let mask_rect f f0 f1 = function
- | IsNul -> f
- | IsPos x -> f0 x
- | IsNeg -> f1
-
- (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **)
-
- let mask_rec f f0 f1 = function
- | IsNul -> f
- | IsPos x -> f0 x
- | IsNeg -> f1
-
+
(** val succ_double_mask : mask -> mask **)
-
+
let succ_double_mask = function
| IsNul -> IsPos XH
| IsPos p -> IsPos (XI p)
| IsNeg -> IsNeg
-
+
(** val double_mask : mask -> mask **)
-
+
let double_mask = function
| IsPos p -> IsPos (XO p)
| x0 -> x0
-
+
(** val double_pred_mask : positive -> mask **)
-
+
let double_pred_mask = function
| XI p -> IsPos (XO (XO p))
| XO p -> IsPos (XO (pred_double p))
| XH -> IsNul
-
- (** val pred_mask : mask -> mask **)
-
- let pred_mask = function
- | IsPos q0 ->
- (match q0 with
- | XH -> IsNul
- | _ -> IsPos (pred q0))
- | _ -> IsNeg
-
+
(** val sub_mask : positive -> positive -> mask **)
-
+
let rec sub_mask x y =
match x with
| XI p ->
@@ -802,9 +158,9 @@ module Coq_Pos =
(match y with
| XH -> IsNul
| _ -> IsNeg)
-
+
(** val sub_mask_carry : positive -> positive -> mask **)
-
+
and sub_mask_carry x y =
match x with
| XI p ->
@@ -818,167 +174,56 @@ module Coq_Pos =
| XO q0 -> succ_double_mask (sub_mask_carry p q0)
| XH -> double_pred_mask p)
| XH -> IsNeg
-
+
(** val sub : positive -> positive -> positive **)
-
+
let sub x y =
match sub_mask x y with
| IsPos z0 -> z0
| _ -> XH
-
+
(** val mul : positive -> positive -> positive **)
-
+
let rec mul x y =
match x with
| XI p -> add y (XO (mul p y))
| XO p -> XO (mul p y)
| XH -> y
-
- (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
-
- let rec iter n0 f x =
- match n0 with
- | XI n' -> f (iter n' f (iter n' f x))
- | XO n' -> iter n' f (iter n' f x)
- | XH -> f x
-
- (** val pow : positive -> positive -> positive **)
-
- let pow x y =
- iter y (mul x) XH
-
- (** val div2 : positive -> positive **)
-
- let div2 = function
- | XI p2 -> p2
- | XO p2 -> p2
- | XH -> XH
-
- (** val div2_up : positive -> positive **)
-
- let div2_up = function
- | XI p2 -> succ p2
- | XO p2 -> p2
- | XH -> XH
-
+
(** val size_nat : positive -> nat **)
-
+
let rec size_nat = function
| XI p2 -> S (size_nat p2)
| XO p2 -> S (size_nat p2)
| XH -> S O
-
- (** val size : positive -> positive **)
-
- let rec size = function
- | XI p2 -> succ (size p2)
- | XO p2 -> succ (size p2)
- | XH -> XH
-
- (** val compare_cont : positive -> positive -> comparison -> comparison **)
-
- let rec compare_cont x y r =
+
+ (** val compare_cont :
+ comparison -> positive -> positive -> comparison **)
+
+ let rec compare_cont r x y =
match x with
| XI p ->
(match y with
- | XI q0 -> compare_cont p q0 r
- | XO q0 -> compare_cont p q0 Gt
+ | XI q0 -> compare_cont r p q0
+ | XO q0 -> compare_cont Gt p q0
| XH -> Gt)
| XO p ->
(match y with
- | XI q0 -> compare_cont p q0 Lt
- | XO q0 -> compare_cont p q0 r
+ | XI q0 -> compare_cont Lt p q0
+ | XO q0 -> compare_cont r p q0
| XH -> Gt)
| XH ->
(match y with
| XH -> r
| _ -> Lt)
-
+
(** val compare : positive -> positive -> comparison **)
-
- let compare x y =
- compare_cont x y Eq
-
- (** val min : positive -> positive -> positive **)
-
- let min p p' =
- match compare p p' with
- | Gt -> p'
- | _ -> p
-
- (** val max : positive -> positive -> positive **)
-
- let max p p' =
- match compare p p' with
- | Gt -> p
- | _ -> p'
-
- (** val eqb : positive -> positive -> bool **)
-
- let rec eqb p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> eqb p2 q1
- | _ -> false)
- | XO p2 ->
- (match q0 with
- | XO q1 -> eqb p2 q1
- | _ -> false)
- | XH ->
- (match q0 with
- | XH -> true
- | _ -> false)
-
- (** val leb : positive -> positive -> bool **)
-
- let leb x y =
- match compare x y with
- | Gt -> false
- | _ -> true
-
- (** val ltb : positive -> positive -> bool **)
-
- let ltb x y =
- match compare x y with
- | Lt -> true
- | _ -> false
-
- (** val sqrtrem_step :
- (positive -> positive) -> (positive -> positive) -> (positive * mask)
- -> positive * mask **)
-
- let sqrtrem_step f g = function
- | s,y ->
- (match y with
- | IsPos r ->
- let s' = XI (XO s) in
- let r' = g (f r) in
- if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r')
- | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH))))
-
- (** val sqrtrem : positive -> positive * mask **)
-
- let rec sqrtrem = function
- | XI p2 ->
- (match p2 with
- | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3)
- | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3)
- | XH -> XH,(IsPos (XO XH)))
- | XO p2 ->
- (match p2 with
- | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3)
- | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3)
- | XH -> XH,(IsPos XH))
- | XH -> XH,IsNul
-
- (** val sqrt : positive -> positive **)
-
- let sqrt p =
- fst (sqrtrem p)
-
+
+ let compare =
+ compare_cont Eq
+
(** val gcdn : nat -> positive -> positive -> positive **)
-
+
let rec gcdn n0 a b =
match n0 with
| O -> XH
@@ -995,1001 +240,30 @@ module Coq_Pos =
| XH -> XH)
| XO a0 ->
(match b with
- | XI p -> gcdn n1 a0 b
+ | XI _ -> gcdn n1 a0 b
| XO b0 -> XO (gcdn n1 a0 b0)
| XH -> XH)
| XH -> XH)
-
+
(** val gcd : positive -> positive -> positive **)
-
+
let gcd a b =
- gcdn (plus (size_nat a) (size_nat b)) a b
-
- (** val ggcdn :
- nat -> positive -> positive -> positive * (positive * positive) **)
-
- let rec ggcdn n0 a b =
- match n0 with
- | O -> XH,(a,b)
- | S n1 ->
- (match a with
- | XI a' ->
- (match b with
- | XI b' ->
- (match compare a' b' with
- | Eq -> a,(XH,XH)
- | Lt ->
- let g,p = ggcdn n1 (sub b' a') a in
- let ba,aa = p in g,(aa,(add aa (XO ba)))
- | Gt ->
- let g,p = ggcdn n1 (sub a' b') b in
- let ab,bb = p in g,((add bb (XO ab)),bb))
- | XO b0 ->
- let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb))
- | XH -> XH,(a,XH))
- | XO a0 ->
- (match b with
- | XI p ->
- let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb)
- | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p
- | XH -> XH,(a,XH))
- | XH -> XH,(XH,b))
-
- (** val ggcd : positive -> positive -> positive * (positive * positive) **)
-
- let ggcd a b =
- ggcdn (plus (size_nat a) (size_nat b)) a b
-
- (** val coq_Nsucc_double : n -> n **)
-
- let coq_Nsucc_double = function
- | N0 -> Npos XH
- | Npos p -> Npos (XI p)
-
- (** val coq_Ndouble : n -> n **)
-
- let coq_Ndouble = function
- | N0 -> N0
- | Npos p -> Npos (XO p)
-
- (** val coq_lor : positive -> positive -> positive **)
-
- let rec coq_lor p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> XI (coq_lor p2 q1)
- | XO q1 -> XI (coq_lor p2 q1)
- | XH -> p)
- | XO p2 ->
- (match q0 with
- | XI q1 -> XI (coq_lor p2 q1)
- | XO q1 -> XO (coq_lor p2 q1)
- | XH -> XI p2)
- | XH ->
- (match q0 with
- | XO q1 -> XI q1
- | _ -> q0)
-
- (** val coq_land : positive -> positive -> n **)
-
- let rec coq_land p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> coq_Nsucc_double (coq_land p2 q1)
- | XO q1 -> coq_Ndouble (coq_land p2 q1)
- | XH -> Npos XH)
- | XO p2 ->
- (match q0 with
- | XI q1 -> coq_Ndouble (coq_land p2 q1)
- | XO q1 -> coq_Ndouble (coq_land p2 q1)
- | XH -> N0)
- | XH ->
- (match q0 with
- | XO q1 -> N0
- | _ -> Npos XH)
-
- (** val ldiff : positive -> positive -> n **)
-
- let rec ldiff p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> coq_Ndouble (ldiff p2 q1)
- | XO q1 -> coq_Nsucc_double (ldiff p2 q1)
- | XH -> Npos (XO p2))
- | XO p2 ->
- (match q0 with
- | XI q1 -> coq_Ndouble (ldiff p2 q1)
- | XO q1 -> coq_Ndouble (ldiff p2 q1)
- | XH -> Npos p)
- | XH ->
- (match q0 with
- | XO q1 -> Npos XH
- | _ -> N0)
-
- (** val coq_lxor : positive -> positive -> n **)
-
- let rec coq_lxor p q0 =
- match p with
- | XI p2 ->
- (match q0 with
- | XI q1 -> coq_Ndouble (coq_lxor p2 q1)
- | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1)
- | XH -> Npos (XO p2))
- | XO p2 ->
- (match q0 with
- | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1)
- | XO q1 -> coq_Ndouble (coq_lxor p2 q1)
- | XH -> Npos (XI p2))
- | XH ->
- (match q0 with
- | XI q1 -> Npos (XO q1)
- | XO q1 -> Npos (XI q1)
- | XH -> N0)
-
- (** val shiftl_nat : positive -> nat -> positive **)
-
- let shiftl_nat p n0 =
- nat_iter n0 (fun x -> XO x) p
-
- (** val shiftr_nat : positive -> nat -> positive **)
-
- let shiftr_nat p n0 =
- nat_iter n0 div2 p
-
- (** val shiftl : positive -> n -> positive **)
-
- let shiftl p = function
- | N0 -> p
- | Npos n1 -> iter n1 (fun x -> XO x) p
-
- (** val shiftr : positive -> n -> positive **)
-
- let shiftr p = function
- | N0 -> p
- | Npos n1 -> iter n1 div2 p
-
- (** val testbit_nat : positive -> nat -> bool **)
-
- let rec testbit_nat p n0 =
- match p with
- | XI p2 ->
- (match n0 with
- | O -> true
- | S n' -> testbit_nat p2 n')
- | XO p2 ->
- (match n0 with
- | O -> false
- | S n' -> testbit_nat p2 n')
- | XH ->
- (match n0 with
- | O -> true
- | S n1 -> false)
-
- (** val testbit : positive -> n -> bool **)
-
- let rec testbit p n0 =
- match p with
- | XI p2 ->
- (match n0 with
- | N0 -> true
- | Npos n1 -> testbit p2 (pred_N n1))
- | XO p2 ->
- (match n0 with
- | N0 -> false
- | Npos n1 -> testbit p2 (pred_N n1))
- | XH ->
- (match n0 with
- | N0 -> true
- | Npos p2 -> false)
-
- (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **)
-
- let rec iter_op op p a =
- match p with
- | XI p2 -> op a (iter_op op p2 (op a a))
- | XO p2 -> iter_op op p2 (op a a)
- | XH -> a
-
- (** val to_nat : positive -> nat **)
-
- let to_nat x =
- iter_op plus x (S O)
-
- (** val of_nat : nat -> positive **)
-
- let rec of_nat = function
- | O -> XH
- | S x ->
- (match x with
- | O -> XH
- | S n1 -> succ (of_nat x))
-
+ gcdn (Coq__1.add (size_nat a) (size_nat b)) a b
+
(** val of_succ_nat : nat -> positive **)
-
+
let rec of_succ_nat = function
| O -> XH
| S x -> succ (of_succ_nat x)
-
- (** val eq_dec : positive -> positive -> bool **)
-
- let rec eq_dec p y0 =
- match p with
- | XI p2 ->
- (match y0 with
- | XI p3 -> eq_dec p2 p3
- | _ -> false)
- | XO p2 ->
- (match y0 with
- | XO p3 -> eq_dec p2 p3
- | _ -> false)
- | XH ->
- (match y0 with
- | XH -> true
- | _ -> false)
-
- (** val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **)
-
- let rec peano_rect a f p =
- let f2 = peano_rect (f XH a) (fun p2 x -> f (succ (XO p2)) (f (XO p2) x))
- in
- (match p with
- | XI q0 -> f (XO q0) (f2 q0)
- | XO q0 -> f2 q0
- | XH -> a)
-
- (** val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **)
-
- let peano_rec =
- peano_rect
-
- type coq_PeanoView =
- | PeanoOne
- | PeanoSucc of positive * coq_PeanoView
-
- (** val coq_PeanoView_rect :
- 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
- coq_PeanoView -> 'a1 **)
-
- let rec coq_PeanoView_rect f f0 p = function
- | PeanoOne -> f
- | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rect f f0 p3 p4)
-
- (** val coq_PeanoView_rec :
- 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
- coq_PeanoView -> 'a1 **)
-
- let rec coq_PeanoView_rec f f0 p = function
- | PeanoOne -> f
- | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rec f f0 p3 p4)
-
- (** val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView **)
-
- let rec peanoView_xO p = function
- | PeanoOne -> PeanoSucc (XH, PeanoOne)
- | PeanoSucc (p2, q1) ->
- PeanoSucc ((succ (XO p2)), (PeanoSucc ((XO p2), (peanoView_xO p2 q1))))
-
- (** val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView **)
-
- let rec peanoView_xI p = function
- | PeanoOne -> PeanoSucc ((succ XH), (PeanoSucc (XH, PeanoOne)))
- | PeanoSucc (p2, q1) ->
- PeanoSucc ((succ (XI p2)), (PeanoSucc ((XI p2), (peanoView_xI p2 q1))))
-
- (** val peanoView : positive -> coq_PeanoView **)
-
- let rec peanoView = function
- | XI p2 -> peanoView_xI p2 (peanoView p2)
- | XO p2 -> peanoView_xO p2 (peanoView p2)
- | XH -> PeanoOne
-
- (** val coq_PeanoView_iter :
- 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **)
-
- let rec coq_PeanoView_iter a f p = function
- | PeanoOne -> a
- | PeanoSucc (p2, q1) -> f p2 (coq_PeanoView_iter a f p2 q1)
-
- (** val switch_Eq : comparison -> comparison -> comparison **)
-
- let switch_Eq c = function
- | Eq -> c
- | x -> x
-
- (** val mask2cmp : mask -> comparison **)
-
- let mask2cmp = function
- | IsNul -> Eq
- | IsPos p2 -> Gt
- | IsNeg -> Lt
-
- module T =
- struct
-
- end
-
- module ORev =
- struct
- type t = Coq__1.t
- end
-
- module MRev =
- struct
- (** val max : t -> t -> t **)
-
- let max x y =
- min y x
- end
-
- module MPRev = MaxLogicalProperties(ORev)(MRev)
-
- module P =
- struct
- (** val max_case_strong :
- t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
- -> 'a1 **)
-
- let max_case_strong n0 m compat hl hr =
- let c = compSpec2Type n0 m (compare n0 m) in
- (match c with
- | CompGtT -> compat n0 (max n0 m) __ (hl __)
- | _ -> compat m (max n0 m) __ (hr __))
-
- (** val max_case :
- t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-
- let max_case n0 m x x0 x1 =
- max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-
- (** val max_dec : t -> t -> bool **)
-
- let max_dec n0 m =
- max_case n0 m (fun x y _ h0 -> h0) true false
-
- (** val min_case_strong :
- t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
- -> 'a1 **)
-
- let min_case_strong n0 m compat hl hr =
- let c = compSpec2Type n0 m (compare n0 m) in
- (match c with
- | CompGtT -> compat m (min n0 m) __ (hr __)
- | _ -> compat n0 (min n0 m) __ (hl __))
-
- (** val min_case :
- t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-
- let min_case n0 m x x0 x1 =
- min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-
- (** val min_dec : t -> t -> bool **)
-
- let min_dec n0 m =
- min_case n0 m (fun x y _ h0 -> h0) true false
- end
-
- (** val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-
- let max_case_strong n0 m x x0 =
- P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-
- (** val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 **)
-
- let max_case n0 m x x0 =
- max_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-
- (** val max_dec : t -> t -> bool **)
-
- let max_dec =
- P.max_dec
-
- (** val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-
- let min_case_strong n0 m x x0 =
- P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-
- (** val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 **)
-
- let min_case n0 m x x0 =
- min_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-
- (** val min_dec : t -> t -> bool **)
-
- let min_dec =
- P.min_dec
end
-module N =
- struct
- type t = n
-
- (** val zero : n **)
-
- let zero =
- N0
-
- (** val one : n **)
-
- let one =
- Npos XH
-
- (** val two : n **)
-
- let two =
- Npos (XO XH)
-
- (** val succ_double : n -> n **)
-
- let succ_double = function
- | N0 -> Npos XH
- | Npos p -> Npos (XI p)
-
- (** val double : n -> n **)
-
- let double = function
- | N0 -> N0
- | Npos p -> Npos (XO p)
-
- (** val succ : n -> n **)
-
- let succ = function
- | N0 -> Npos XH
- | Npos p -> Npos (Coq_Pos.succ p)
-
- (** val pred : n -> n **)
-
- let pred = function
- | N0 -> N0
- | Npos p -> Coq_Pos.pred_N p
-
- (** val succ_pos : n -> positive **)
-
- let succ_pos = function
- | N0 -> XH
- | Npos p -> Coq_Pos.succ p
-
- (** val add : n -> n -> n **)
-
- let add n0 m =
- match n0 with
- | N0 -> m
- | Npos p ->
- (match m with
- | N0 -> n0
- | Npos q0 -> Npos (Coq_Pos.add p q0))
-
- (** val sub : n -> n -> n **)
-
- let sub n0 m =
- match n0 with
- | N0 -> N0
- | Npos n' ->
- (match m with
- | N0 -> n0
- | Npos m' ->
- (match Coq_Pos.sub_mask n' m' with
- | Coq_Pos.IsPos p -> Npos p
- | _ -> N0))
-
- (** val mul : n -> n -> n **)
-
- let mul n0 m =
- match n0 with
- | N0 -> N0
- | Npos p ->
- (match m with
- | N0 -> N0
- | Npos q0 -> Npos (Coq_Pos.mul p q0))
-
- (** val compare : n -> n -> comparison **)
-
- let compare n0 m =
- match n0 with
- | N0 ->
- (match m with
- | N0 -> Eq
- | Npos m' -> Lt)
- | Npos n' ->
- (match m with
- | N0 -> Gt
- | Npos m' -> Coq_Pos.compare n' m')
-
- (** val eqb : n -> n -> bool **)
-
- let eqb n0 m =
- match n0 with
- | N0 ->
- (match m with
- | N0 -> true
- | Npos p -> false)
- | Npos p ->
- (match m with
- | N0 -> false
- | Npos q0 -> Coq_Pos.eqb p q0)
-
- (** val leb : n -> n -> bool **)
-
- let leb x y =
- match compare x y with
- | Gt -> false
- | _ -> true
-
- (** val ltb : n -> n -> bool **)
-
- let ltb x y =
- match compare x y with
- | Lt -> true
- | _ -> false
-
- (** val min : n -> n -> n **)
-
- let min n0 n' =
- match compare n0 n' with
- | Gt -> n'
- | _ -> n0
-
- (** val max : n -> n -> n **)
-
- let max n0 n' =
- match compare n0 n' with
- | Gt -> n0
- | _ -> n'
-
- (** val div2 : n -> n **)
-
- let div2 = function
- | N0 -> N0
- | Npos p2 ->
- (match p2 with
- | XI p -> Npos p
- | XO p -> Npos p
- | XH -> N0)
-
- (** val even : n -> bool **)
-
- let even = function
- | N0 -> true
- | Npos p ->
- (match p with
- | XO p2 -> true
- | _ -> false)
-
- (** val odd : n -> bool **)
-
- let odd n0 =
- negb (even n0)
-
- (** val pow : n -> n -> n **)
-
- let pow n0 = function
- | N0 -> Npos XH
- | Npos p2 ->
- (match n0 with
- | N0 -> N0
- | Npos q0 -> Npos (Coq_Pos.pow q0 p2))
-
- (** val log2 : n -> n **)
-
- let log2 = function
- | N0 -> N0
- | Npos p2 ->
- (match p2 with
- | XI p -> Npos (Coq_Pos.size p)
- | XO p -> Npos (Coq_Pos.size p)
- | XH -> N0)
-
- (** val size : n -> n **)
-
- let size = function
- | N0 -> N0
- | Npos p -> Npos (Coq_Pos.size p)
-
- (** val size_nat : n -> nat **)
-
- let size_nat = function
- | N0 -> O
- | Npos p -> Coq_Pos.size_nat p
-
- (** val pos_div_eucl : positive -> n -> n * n **)
-
- let rec pos_div_eucl a b =
- match a with
- | XI a' ->
- let q0,r = pos_div_eucl a' b in
- let r' = succ_double r in
- if leb b r' then (succ_double q0),(sub r' b) else (double q0),r'
- | XO a' ->
- let q0,r = pos_div_eucl a' b in
- let r' = double r in
- if leb b r' then (succ_double q0),(sub r' b) else (double q0),r'
- | XH ->
- (match b with
- | N0 -> N0,(Npos XH)
- | Npos p ->
- (match p with
- | XH -> (Npos XH),N0
- | _ -> N0,(Npos XH)))
-
- (** val div_eucl : n -> n -> n * n **)
-
- let div_eucl a b =
- match a with
- | N0 -> N0,N0
- | Npos na ->
- (match b with
- | N0 -> N0,a
- | Npos p -> pos_div_eucl na b)
-
- (** val div : n -> n -> n **)
-
- let div a b =
- fst (div_eucl a b)
-
- (** val modulo : n -> n -> n **)
-
- let modulo a b =
- snd (div_eucl a b)
-
- (** val gcd : n -> n -> n **)
-
- let gcd a b =
- match a with
- | N0 -> b
- | Npos p ->
- (match b with
- | N0 -> a
- | Npos q0 -> Npos (Coq_Pos.gcd p q0))
-
- (** val ggcd : n -> n -> n * (n * n) **)
-
- let ggcd a b =
- match a with
- | N0 -> b,(N0,(Npos XH))
- | Npos p ->
- (match b with
- | N0 -> a,((Npos XH),N0)
- | Npos q0 ->
- let g,p2 = Coq_Pos.ggcd p q0 in
- let aa,bb = p2 in (Npos g),((Npos aa),(Npos bb)))
-
- (** val sqrtrem : n -> n * n **)
-
- let sqrtrem = function
- | N0 -> N0,N0
- | Npos p ->
- let s,m = Coq_Pos.sqrtrem p in
- (match m with
- | Coq_Pos.IsPos r -> (Npos s),(Npos r)
- | _ -> (Npos s),N0)
-
- (** val sqrt : n -> n **)
-
- let sqrt = function
- | N0 -> N0
- | Npos p -> Npos (Coq_Pos.sqrt p)
-
- (** val coq_lor : n -> n -> n **)
-
- let coq_lor n0 m =
- match n0 with
- | N0 -> m
- | Npos p ->
- (match m with
- | N0 -> n0
- | Npos q0 -> Npos (Coq_Pos.coq_lor p q0))
-
- (** val coq_land : n -> n -> n **)
-
- let coq_land n0 m =
- match n0 with
- | N0 -> N0
- | Npos p ->
- (match m with
- | N0 -> N0
- | Npos q0 -> Coq_Pos.coq_land p q0)
-
- (** val ldiff : n -> n -> n **)
-
- let ldiff n0 m =
- match n0 with
- | N0 -> N0
- | Npos p ->
- (match m with
- | N0 -> n0
- | Npos q0 -> Coq_Pos.ldiff p q0)
-
- (** val coq_lxor : n -> n -> n **)
-
- let coq_lxor n0 m =
- match n0 with
- | N0 -> m
- | Npos p ->
- (match m with
- | N0 -> n0
- | Npos q0 -> Coq_Pos.coq_lxor p q0)
-
- (** val shiftl_nat : n -> nat -> n **)
-
- let shiftl_nat a n0 =
- nat_iter n0 double a
-
- (** val shiftr_nat : n -> nat -> n **)
-
- let shiftr_nat a n0 =
- nat_iter n0 div2 a
-
- (** val shiftl : n -> n -> n **)
-
- let shiftl a n0 =
- match a with
- | N0 -> N0
- | Npos a0 -> Npos (Coq_Pos.shiftl a0 n0)
-
- (** val shiftr : n -> n -> n **)
-
- let shiftr a = function
- | N0 -> a
- | Npos p -> Coq_Pos.iter p div2 a
-
- (** val testbit_nat : n -> nat -> bool **)
-
- let testbit_nat = function
- | N0 -> (fun x -> false)
- | Npos p -> Coq_Pos.testbit_nat p
-
- (** val testbit : n -> n -> bool **)
-
- let testbit a n0 =
- match a with
- | N0 -> false
- | Npos p -> Coq_Pos.testbit p n0
-
- (** val to_nat : n -> nat **)
-
- let to_nat = function
- | N0 -> O
- | Npos p -> Coq_Pos.to_nat p
-
+module N =
+ struct
(** val of_nat : nat -> n **)
-
+
let of_nat = function
| O -> N0
| S n' -> Npos (Coq_Pos.of_succ_nat n')
-
- (** val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
-
- let iter n0 f x =
- match n0 with
- | N0 -> x
- | Npos p -> Coq_Pos.iter p f x
-
- (** val eq_dec : n -> n -> bool **)
-
- let eq_dec n0 m =
- match n0 with
- | N0 ->
- (match m with
- | N0 -> true
- | Npos p -> false)
- | Npos x ->
- (match m with
- | N0 -> false
- | Npos p2 -> Coq_Pos.eq_dec x p2)
-
- (** val discr : n -> positive option **)
-
- let discr = function
- | N0 -> None
- | Npos p -> Some p
-
- (** val binary_rect :
- 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-
- let binary_rect f0 f2 fS2 n0 =
- let f2' = fun p -> f2 (Npos p) in
- let fS2' = fun p -> fS2 (Npos p) in
- (match n0 with
- | N0 -> f0
- | Npos p ->
- let rec f = function
- | XI p3 -> fS2' p3 (f p3)
- | XO p3 -> f2' p3 (f p3)
- | XH -> fS2 N0 f0
- in f p)
-
- (** val binary_rec :
- 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-
- let binary_rec =
- binary_rect
-
- (** val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-
- let peano_rect f0 f n0 =
- let f' = fun p -> f (Npos p) in
- (match n0 with
- | N0 -> f0
- | Npos p -> Coq_Pos.peano_rect (f N0 f0) f' p)
-
- (** val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-
- let peano_rec =
- peano_rect
-
- module BootStrap =
- struct
-
- end
-
- (** val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **)
-
- let recursion x =
- peano_rect x
-
- module OrderElts =
- struct
- type t = n
- end
-
- module OrderTac = MakeOrderTac(OrderElts)
-
- module NZPowP =
- struct
-
- end
-
- module NZSqrtP =
- struct
-
- end
-
- (** val sqrt_up : n -> n **)
-
- let sqrt_up a =
- match compare N0 a with
- | Lt -> succ (sqrt (pred a))
- | _ -> N0
-
- (** val log2_up : n -> n **)
-
- let log2_up a =
- match compare (Npos XH) a with
- | Lt -> succ (log2 (pred a))
- | _ -> N0
-
- module NZDivP =
- struct
-
- end
-
- (** val lcm : n -> n -> n **)
-
- let lcm a b =
- mul a (div b (gcd a b))
-
- (** val b2n : bool -> n **)
-
- let b2n = function
- | true -> Npos XH
- | false -> N0
-
- (** val setbit : n -> n -> n **)
-
- let setbit a n0 =
- coq_lor a (shiftl (Npos XH) n0)
-
- (** val clearbit : n -> n -> n **)
-
- let clearbit a n0 =
- ldiff a (shiftl (Npos XH) n0)
-
- (** val ones : n -> n **)
-
- let ones n0 =
- pred (shiftl (Npos XH) n0)
-
- (** val lnot : n -> n -> n **)
-
- let lnot a n0 =
- coq_lxor a (ones n0)
-
- module T =
- struct
-
- end
-
- module ORev =
- struct
- type t = n
- end
-
- module MRev =
- struct
- (** val max : n -> n -> n **)
-
- let max x y =
- min y x
- end
-
- module MPRev = MaxLogicalProperties(ORev)(MRev)
-
- module P =
- struct
- (** val max_case_strong :
- n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
- -> 'a1 **)
-
- let max_case_strong n0 m compat hl hr =
- let c = compSpec2Type n0 m (compare n0 m) in
- (match c with
- | CompGtT -> compat n0 (max n0 m) __ (hl __)
- | _ -> compat m (max n0 m) __ (hr __))
-
- (** val max_case :
- n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-
- let max_case n0 m x x0 x1 =
- max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-
- (** val max_dec : n -> n -> bool **)
-
- let max_dec n0 m =
- max_case n0 m (fun x y _ h0 -> h0) true false
-
- (** val min_case_strong :
- n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
- -> 'a1 **)
-
- let min_case_strong n0 m compat hl hr =
- let c = compSpec2Type n0 m (compare n0 m) in
- (match c with
- | CompGtT -> compat m (min n0 m) __ (hr __)
- | _ -> compat n0 (min n0 m) __ (hl __))
-
- (** val min_case :
- n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-
- let min_case n0 m x x0 x1 =
- min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-
- (** val min_dec : n -> n -> bool **)
-
- let min_dec n0 m =
- min_case n0 m (fun x y _ h0 -> h0) true false
- end
-
- (** val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-
- let max_case_strong n0 m x x0 =
- P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-
- (** val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 **)
-
- let max_case n0 m x x0 =
- max_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-
- (** val max_dec : n -> n -> bool **)
-
- let max_dec =
- P.max_dec
-
- (** val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-
- let min_case_strong n0 m x x0 =
- P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-
- (** val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 **)
-
- let min_case n0 m x x0 =
- min_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-
- (** val min_dec : n -> n -> bool **)
-
- let min_dec =
- P.min_dec
end
(** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **)
@@ -2006,66 +280,49 @@ let rec nth n0 l default =
| O ->
(match l with
| [] -> default
- | x::l' -> x)
+ | x::_ -> x)
| S m ->
(match l with
| [] -> default
- | x::t1 -> nth m t1 default)
+ | _::t0 -> nth m t0 default)
(** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **)
let rec map f = function
| [] -> []
-| a::t1 -> (f a)::(map f t1)
+| a::t0 -> (f a)::(map f t0)
(** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **)
let rec fold_right f a0 = function
| [] -> a0
-| b::t1 -> f b (fold_right f a0 t1)
-
-module Z =
- struct
- type t = z
-
- (** val zero : z **)
-
- let zero =
- Z0
-
- (** val one : z **)
-
- let one =
- Zpos XH
-
- (** val two : z **)
-
- let two =
- Zpos (XO XH)
-
+| b::t0 -> f b (fold_right f a0 t0)
+
+module Z =
+ struct
(** val double : z -> z **)
-
+
let double = function
| Z0 -> Z0
| Zpos p -> Zpos (XO p)
| Zneg p -> Zneg (XO p)
-
+
(** val succ_double : z -> z **)
-
+
let succ_double = function
| Z0 -> Zpos XH
| Zpos p -> Zpos (XI p)
| Zneg p -> Zneg (Coq_Pos.pred_double p)
-
+
(** val pred_double : z -> z **)
-
+
let pred_double = function
| Z0 -> Zneg XH
| Zpos p -> Zpos (Coq_Pos.pred_double p)
| Zneg p -> Zneg (XI p)
-
+
(** val pos_sub : positive -> positive -> z **)
-
+
let rec pos_sub x y =
match x with
| XI p ->
@@ -2083,9 +340,9 @@ module Z =
| XI q0 -> Zneg (XO q0)
| XO q0 -> Zneg (Coq_Pos.pred_double q0)
| XH -> Z0)
-
+
(** val add : z -> z -> z **)
-
+
let add x y =
match x with
| Z0 -> y
@@ -2099,31 +356,21 @@ module Z =
| Z0 -> x
| Zpos y' -> pos_sub y' x'
| Zneg y' -> Zneg (Coq_Pos.add x' y'))
-
+
(** val opp : z -> z **)
-
+
let opp = function
| Z0 -> Z0
| Zpos x0 -> Zneg x0
| Zneg x0 -> Zpos x0
-
- (** val succ : z -> z **)
-
- let succ x =
- add x (Zpos XH)
-
- (** val pred : z -> z **)
-
- let pred x =
- add x (Zneg XH)
-
+
(** val sub : z -> z -> z **)
-
+
let sub m n0 =
add m (opp n0)
-
+
(** val mul : z -> z -> z **)
-
+
let mul x y =
match x with
| Z0 -> Z0
@@ -2137,28 +384,16 @@ module Z =
| Z0 -> Z0
| Zpos y' -> Zneg (Coq_Pos.mul x' y')
| Zneg y' -> Zpos (Coq_Pos.mul x' y'))
-
- (** val pow_pos : z -> positive -> z **)
-
- let pow_pos z0 n0 =
- Coq_Pos.iter n0 (mul z0) (Zpos XH)
-
- (** val pow : z -> z -> z **)
-
- let pow x = function
- | Z0 -> Zpos XH
- | Zpos p -> pow_pos x p
- | Zneg p -> Z0
-
+
(** val compare : z -> z -> comparison **)
-
+
let compare x y =
match x with
| Z0 ->
(match y with
| Z0 -> Eq
- | Zpos y' -> Lt
- | Zneg y' -> Gt)
+ | Zpos _ -> Lt
+ | Zneg _ -> Gt)
| Zpos x' ->
(match y with
| Zpos y' -> Coq_Pos.compare x' y'
@@ -2167,151 +402,74 @@ module Z =
(match y with
| Zneg y' -> compOpp (Coq_Pos.compare x' y')
| _ -> Lt)
-
- (** val sgn : z -> z **)
-
- let sgn = function
- | Z0 -> Z0
- | Zpos p -> Zpos XH
- | Zneg p -> Zneg XH
-
+
(** val leb : z -> z -> bool **)
-
+
let leb x y =
match compare x y with
| Gt -> false
| _ -> true
-
- (** val geb : z -> z -> bool **)
-
- let geb x y =
- match compare x y with
- | Lt -> false
- | _ -> true
-
+
(** val ltb : z -> z -> bool **)
-
+
let ltb x y =
match compare x y with
| Lt -> true
| _ -> false
-
+
(** val gtb : z -> z -> bool **)
-
+
let gtb x y =
match compare x y with
| Gt -> true
| _ -> false
-
- (** val eqb : z -> z -> bool **)
-
- let eqb x y =
- match x with
- | Z0 ->
- (match y with
- | Z0 -> true
- | _ -> false)
- | Zpos p ->
- (match y with
- | Zpos q0 -> Coq_Pos.eqb p q0
- | _ -> false)
- | Zneg p ->
- (match y with
- | Zneg q0 -> Coq_Pos.eqb p q0
- | _ -> false)
-
+
(** val max : z -> z -> z **)
-
+
let max n0 m =
match compare n0 m with
| Lt -> m
| _ -> n0
-
- (** val min : z -> z -> z **)
-
- let min n0 m =
- match compare n0 m with
- | Gt -> m
- | _ -> n0
-
+
(** val abs : z -> z **)
-
+
let abs = function
| Zneg p -> Zpos p
| x -> x
-
- (** val abs_nat : z -> nat **)
-
- let abs_nat = function
- | Z0 -> O
- | Zpos p -> Coq_Pos.to_nat p
- | Zneg p -> Coq_Pos.to_nat p
-
- (** val abs_N : z -> n **)
-
- let abs_N = function
- | Z0 -> N0
- | Zpos p -> Npos p
- | Zneg p -> Npos p
-
- (** val to_nat : z -> nat **)
-
- let to_nat = function
- | Zpos p -> Coq_Pos.to_nat p
- | _ -> O
-
+
(** val to_N : z -> n **)
-
+
let to_N = function
| Zpos p -> Npos p
| _ -> N0
-
- (** val of_nat : nat -> z **)
-
- let of_nat = function
- | O -> Z0
- | S n1 -> Zpos (Coq_Pos.of_succ_nat n1)
-
- (** val of_N : n -> z **)
-
- let of_N = function
- | N0 -> Z0
- | Npos p -> Zpos p
-
- (** val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 **)
-
- let iter n0 f x =
- match n0 with
- | Zpos p -> Coq_Pos.iter p f x
- | _ -> x
-
+
(** val pos_div_eucl : positive -> z -> z * z **)
-
+
let rec pos_div_eucl a b =
match a with
| XI a' ->
let q0,r = pos_div_eucl a' b in
let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in
- if gtb b r'
+ if ltb r' b
then (mul (Zpos (XO XH)) q0),r'
else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b)
| XO a' ->
let q0,r = pos_div_eucl a' b in
let r' = mul (Zpos (XO XH)) r in
- if gtb b r'
+ if ltb r' b
then (mul (Zpos (XO XH)) q0),r'
else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b)
- | XH -> if geb b (Zpos (XO XH)) then Z0,(Zpos XH) else (Zpos XH),Z0
-
+ | XH -> if leb (Zpos (XO XH)) b then Z0,(Zpos XH) else (Zpos XH),Z0
+
(** val div_eucl : z -> z -> z * z **)
-
+
let div_eucl a b =
match a with
| Z0 -> Z0,Z0
| Zpos a' ->
(match b with
| Z0 -> Z0,Z0
- | Zpos p -> pos_div_eucl a' b
+ | Zpos _ -> pos_div_eucl a' b
| Zneg b' ->
let q0,r = pos_div_eucl a' (Zpos b') in
(match r with
@@ -2320,131 +478,20 @@ module Z =
| Zneg a' ->
(match b with
| Z0 -> Z0,Z0
- | Zpos p ->
+ | Zpos _ ->
let q0,r = pos_div_eucl a' b in
(match r with
| Z0 -> (opp q0),Z0
| _ -> (opp (add q0 (Zpos XH))),(sub b r))
| Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r))
-
+
(** val div : z -> z -> z **)
-
+
let div a b =
- let q0,x = div_eucl a b in q0
-
- (** val modulo : z -> z -> z **)
-
- let modulo a b =
- let x,r = div_eucl a b in r
-
- (** val quotrem : z -> z -> z * z **)
-
- let quotrem a b =
- match a with
- | Z0 -> Z0,Z0
- | Zpos a0 ->
- (match b with
- | Z0 -> Z0,a
- | Zpos b0 ->
- let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(of_N r)
- | Zneg b0 ->
- let q0,r = N.pos_div_eucl a0 (Npos b0) in (opp (of_N q0)),(of_N r))
- | Zneg a0 ->
- (match b with
- | Z0 -> Z0,a
- | Zpos b0 ->
- let q0,r = N.pos_div_eucl a0 (Npos b0) in
- (opp (of_N q0)),(opp (of_N r))
- | Zneg b0 ->
- let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(opp (of_N r)))
-
- (** val quot : z -> z -> z **)
-
- let quot a b =
- fst (quotrem a b)
-
- (** val rem : z -> z -> z **)
-
- let rem a b =
- snd (quotrem a b)
-
- (** val even : z -> bool **)
-
- let even = function
- | Z0 -> true
- | Zpos p ->
- (match p with
- | XO p2 -> true
- | _ -> false)
- | Zneg p ->
- (match p with
- | XO p2 -> true
- | _ -> false)
-
- (** val odd : z -> bool **)
-
- let odd = function
- | Z0 -> false
- | Zpos p ->
- (match p with
- | XO p2 -> false
- | _ -> true)
- | Zneg p ->
- (match p with
- | XO p2 -> false
- | _ -> true)
-
- (** val div2 : z -> z **)
-
- let div2 = function
- | Z0 -> Z0
- | Zpos p ->
- (match p with
- | XH -> Z0
- | _ -> Zpos (Coq_Pos.div2 p))
- | Zneg p -> Zneg (Coq_Pos.div2_up p)
-
- (** val quot2 : z -> z **)
-
- let quot2 = function
- | Z0 -> Z0
- | Zpos p ->
- (match p with
- | XH -> Z0
- | _ -> Zpos (Coq_Pos.div2 p))
- | Zneg p ->
- (match p with
- | XH -> Z0
- | _ -> Zneg (Coq_Pos.div2 p))
-
- (** val log2 : z -> z **)
-
- let log2 = function
- | Zpos p2 ->
- (match p2 with
- | XI p -> Zpos (Coq_Pos.size p)
- | XO p -> Zpos (Coq_Pos.size p)
- | XH -> Z0)
- | _ -> Z0
-
- (** val sqrtrem : z -> z * z **)
-
- let sqrtrem = function
- | Zpos p ->
- let s,m = Coq_Pos.sqrtrem p in
- (match m with
- | Coq_Pos.IsPos r -> (Zpos s),(Zpos r)
- | _ -> (Zpos s),Z0)
- | _ -> Z0,Z0
-
- (** val sqrt : z -> z **)
-
- let sqrt = function
- | Zpos p -> Zpos (Coq_Pos.sqrt p)
- | _ -> Z0
-
+ let q0,_ = div_eucl a b in q0
+
(** val gcd : z -> z -> z **)
-
+
let gcd a b =
match a with
| Z0 -> abs b
@@ -2458,316 +505,6 @@ module Z =
| Z0 -> abs a
| Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0)
| Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0))
-
- (** val ggcd : z -> z -> z * (z * z) **)
-
- let ggcd a b =
- match a with
- | Z0 -> (abs b),(Z0,(sgn b))
- | Zpos a0 ->
- (match b with
- | Z0 -> (abs a),((sgn a),Z0)
- | Zpos b0 ->
- let g,p = Coq_Pos.ggcd a0 b0 in
- let aa,bb = p in (Zpos g),((Zpos aa),(Zpos bb))
- | Zneg b0 ->
- let g,p = Coq_Pos.ggcd a0 b0 in
- let aa,bb = p in (Zpos g),((Zpos aa),(Zneg bb)))
- | Zneg a0 ->
- (match b with
- | Z0 -> (abs a),((sgn a),Z0)
- | Zpos b0 ->
- let g,p = Coq_Pos.ggcd a0 b0 in
- let aa,bb = p in (Zpos g),((Zneg aa),(Zpos bb))
- | Zneg b0 ->
- let g,p = Coq_Pos.ggcd a0 b0 in
- let aa,bb = p in (Zpos g),((Zneg aa),(Zneg bb)))
-
- (** val testbit : z -> z -> bool **)
-
- let testbit a = function
- | Z0 -> odd a
- | Zpos p ->
- (match a with
- | Z0 -> false
- | Zpos a0 -> Coq_Pos.testbit a0 (Npos p)
- | Zneg a0 -> negb (N.testbit (Coq_Pos.pred_N a0) (Npos p)))
- | Zneg p -> false
-
- (** val shiftl : z -> z -> z **)
-
- let shiftl a = function
- | Z0 -> a
- | Zpos p -> Coq_Pos.iter p (mul (Zpos (XO XH))) a
- | Zneg p -> Coq_Pos.iter p div2 a
-
- (** val shiftr : z -> z -> z **)
-
- let shiftr a n0 =
- shiftl a (opp n0)
-
- (** val coq_lor : z -> z -> z **)
-
- let coq_lor a b =
- match a with
- | Z0 -> b
- | Zpos a0 ->
- (match b with
- | Z0 -> a
- | Zpos b0 -> Zpos (Coq_Pos.coq_lor a0 b0)
- | Zneg b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N b0) (Npos a0))))
- | Zneg a0 ->
- (match b with
- | Z0 -> a
- | Zpos b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N a0) (Npos b0)))
- | Zneg b0 ->
- Zneg
- (N.succ_pos (N.coq_land (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))))
-
- (** val coq_land : z -> z -> z **)
-
- let coq_land a b =
- match a with
- | Z0 -> Z0
- | Zpos a0 ->
- (match b with
- | Z0 -> Z0
- | Zpos b0 -> of_N (Coq_Pos.coq_land a0 b0)
- | Zneg b0 -> of_N (N.ldiff (Npos a0) (Coq_Pos.pred_N b0)))
- | Zneg a0 ->
- (match b with
- | Z0 -> Z0
- | Zpos b0 -> of_N (N.ldiff (Npos b0) (Coq_Pos.pred_N a0))
- | Zneg b0 ->
- Zneg
- (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))))
-
- (** val ldiff : z -> z -> z **)
-
- let ldiff a b =
- match a with
- | Z0 -> Z0
- | Zpos a0 ->
- (match b with
- | Z0 -> a
- | Zpos b0 -> of_N (Coq_Pos.ldiff a0 b0)
- | Zneg b0 -> of_N (N.coq_land (Npos a0) (Coq_Pos.pred_N b0)))
- | Zneg a0 ->
- (match b with
- | Z0 -> a
- | Zpos b0 ->
- Zneg (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Npos b0)))
- | Zneg b0 -> of_N (N.ldiff (Coq_Pos.pred_N b0) (Coq_Pos.pred_N a0)))
-
- (** val coq_lxor : z -> z -> z **)
-
- let coq_lxor a b =
- match a with
- | Z0 -> b
- | Zpos a0 ->
- (match b with
- | Z0 -> a
- | Zpos b0 -> of_N (Coq_Pos.coq_lxor a0 b0)
- | Zneg b0 ->
- Zneg (N.succ_pos (N.coq_lxor (Npos a0) (Coq_Pos.pred_N b0))))
- | Zneg a0 ->
- (match b with
- | Z0 -> a
- | Zpos b0 ->
- Zneg (N.succ_pos (N.coq_lxor (Coq_Pos.pred_N a0) (Npos b0)))
- | Zneg b0 -> of_N (N.coq_lxor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))
-
- (** val eq_dec : z -> z -> bool **)
-
- let eq_dec x y =
- match x with
- | Z0 ->
- (match y with
- | Z0 -> true
- | _ -> false)
- | Zpos x0 ->
- (match y with
- | Zpos p2 -> Coq_Pos.eq_dec x0 p2
- | _ -> false)
- | Zneg x0 ->
- (match y with
- | Zneg p2 -> Coq_Pos.eq_dec x0 p2
- | _ -> false)
-
- module BootStrap =
- struct
-
- end
-
- module OrderElts =
- struct
- type t = z
- end
-
- module OrderTac = MakeOrderTac(OrderElts)
-
- (** val sqrt_up : z -> z **)
-
- let sqrt_up a =
- match compare Z0 a with
- | Lt -> succ (sqrt (pred a))
- | _ -> Z0
-
- (** val log2_up : z -> z **)
-
- let log2_up a =
- match compare (Zpos XH) a with
- | Lt -> succ (log2 (pred a))
- | _ -> Z0
-
- module NZDivP =
- struct
-
- end
-
- module Quot2Div =
- struct
- (** val div : z -> z -> z **)
-
- let div =
- quot
-
- (** val modulo : z -> z -> z **)
-
- let modulo =
- rem
- end
-
- module NZQuot =
- struct
-
- end
-
- (** val lcm : z -> z -> z **)
-
- let lcm a b =
- abs (mul a (div b (gcd a b)))
-
- (** val b2z : bool -> z **)
-
- let b2z = function
- | true -> Zpos XH
- | false -> Z0
-
- (** val setbit : z -> z -> z **)
-
- let setbit a n0 =
- coq_lor a (shiftl (Zpos XH) n0)
-
- (** val clearbit : z -> z -> z **)
-
- let clearbit a n0 =
- ldiff a (shiftl (Zpos XH) n0)
-
- (** val lnot : z -> z **)
-
- let lnot a =
- pred (opp a)
-
- (** val ones : z -> z **)
-
- let ones n0 =
- pred (shiftl (Zpos XH) n0)
-
- module T =
- struct
-
- end
-
- module ORev =
- struct
- type t = z
- end
-
- module MRev =
- struct
- (** val max : z -> z -> z **)
-
- let max x y =
- min y x
- end
-
- module MPRev = MaxLogicalProperties(ORev)(MRev)
-
- module P =
- struct
- (** val max_case_strong :
- z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
- -> 'a1 **)
-
- let max_case_strong n0 m compat hl hr =
- let c = compSpec2Type n0 m (compare n0 m) in
- (match c with
- | CompGtT -> compat n0 (max n0 m) __ (hl __)
- | _ -> compat m (max n0 m) __ (hr __))
-
- (** val max_case :
- z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-
- let max_case n0 m x x0 x1 =
- max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-
- (** val max_dec : z -> z -> bool **)
-
- let max_dec n0 m =
- max_case n0 m (fun x y _ h0 -> h0) true false
-
- (** val min_case_strong :
- z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1)
- -> 'a1 **)
-
- let min_case_strong n0 m compat hl hr =
- let c = compSpec2Type n0 m (compare n0 m) in
- (match c with
- | CompGtT -> compat m (min n0 m) __ (hr __)
- | _ -> compat n0 (min n0 m) __ (hl __))
-
- (** val min_case :
- z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **)
-
- let min_case n0 m x x0 x1 =
- min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1)
-
- (** val min_dec : z -> z -> bool **)
-
- let min_dec n0 m =
- min_case n0 m (fun x y _ h0 -> h0) true false
- end
-
- (** val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-
- let max_case_strong n0 m x x0 =
- P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-
- (** val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 **)
-
- let max_case n0 m x x0 =
- max_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-
- (** val max_dec : z -> z -> bool **)
-
- let max_dec =
- P.max_dec
-
- (** val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **)
-
- let min_case_strong n0 m x x0 =
- P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0
-
- (** val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 **)
-
- let min_case n0 m x x0 =
- min_case_strong n0 m (fun _ -> x) (fun _ -> x0)
-
- (** val min_dec : z -> z -> bool **)
-
- let min_dec =
- P.min_dec
end
(** val zeq_bool : z -> z -> bool **)
@@ -2818,9 +555,9 @@ let rec peq ceqb p p' =
(** val mkPinj : positive -> 'a1 pol -> 'a1 pol **)
let mkPinj j p = match p with
-| Pc c -> p
+| Pc _ -> p
| Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0)
-| PX (p2, p3, p4) -> Pinj (j, p)
+| PX (_, _, _) -> Pinj (j, p)
(** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **)
@@ -2831,12 +568,13 @@ let mkPinj_pred j p =
| XH -> p
(** val mkPX :
- 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+ 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1
+ pol **)
let mkPX cO ceqb p i q0 =
match p with
| Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0)
- | Pinj (p2, p3) -> PX (p, i, q0)
+ | Pinj (_, _) -> PX (p, i, q0)
| PX (p', i', q') ->
if peq ceqb q' (p0 cO)
then PX (p', (Coq_Pos.add i' i), q0)
@@ -2893,8 +631,8 @@ let rec paddI cadd pop q0 j = function
| 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 **)
+ ('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 -> mkPinj j (paddC cadd (popp copp q0) c)
@@ -2911,11 +649,11 @@ let rec psubI cadd copp pop q0 j = function
| 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 **)
+ '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)
+| Pc _ -> PX (p', i', p)
| Pinj (j, q') ->
(match j with
| XI j0 -> PX (p', i', (Pinj ((XO j0), q')))
@@ -2928,15 +666,16 @@ let rec paddX cO ceqb pop p' i' p = match p with
| 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 **)
+ '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)
+| Pc _ -> PX ((popp copp p'), i', p)
| Pinj (j, q') ->
(match j with
| XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q')))
- | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q')))
+ | XO j0 ->
+ PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q')))
| XH -> PX ((popp copp p'), i', q'))
| PX (p2, i, q') ->
(match Z.pos_sub i i' with
@@ -2945,8 +684,8 @@ let rec psubX cO copp ceqb pop p' i' p = match p with
| 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 **)
+ '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'
@@ -2964,7 +703,8 @@ let rec padd cO cadd ceqb p = function
| PX (p2, i, q0) ->
(match Z.pos_sub i i' with
| Z0 ->
- mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q')
+ 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')
@@ -2973,8 +713,8 @@ let rec padd cO cadd ceqb p = function
(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 **)
+ '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'
@@ -2989,25 +729,27 @@ let rec psub cO cadd csub copp ceqb p = function
(psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q'))
| XO j0 ->
PX ((popp copp p'0), i',
- (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q0))
- q'))
- | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q')))
+ (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0),
+ q0)) q'))
+ | XH ->
+ PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q')))
| PX (p2, i, q0) ->
(match Z.pos_sub i i' with
| Z0 ->
mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i
(psub cO cadd csub copp ceqb q0 q')
| Zpos k ->
- mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0)
- i' (psub cO cadd csub copp ceqb q0 q')
+ mkPX cO ceqb
+ (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) i'
+ (psub cO cadd csub copp ceqb q0 q')
| Zneg k ->
mkPX cO ceqb
(psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i
(psub cO cadd csub copp ceqb q0 q')))
(** val pmulC_aux :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 ->
- 'a1 pol **)
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
+ -> 'a1 pol **)
let rec pmulC_aux cO cmul ceqb p c =
match p with
@@ -3018,8 +760,8 @@ let rec pmulC_aux cO cmul ceqb p c =
(pmulC_aux cO cmul ceqb q0 c)
(** val pmulC :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol ->
- 'a1 -> 'a1 pol **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol
+ -> 'a1 -> 'a1 pol **)
let pmulC cO cI cmul ceqb p c =
if ceqb c cO
@@ -3027,8 +769,8 @@ let pmulC cO cI cmul ceqb p c =
else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c
(** val pmulI :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol ->
- 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **)
+ '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 -> mkPinj j (pmulC cO cI cmul ceqb q0 c)
@@ -3049,12 +791,13 @@ let rec pmulI cO cI cmul ceqb pmul0 q0 j = function
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 **)
+ '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 (pmul cO cI cadd cmul ceqb) q' j' p
+| Pinj (j', q') ->
+ pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p
| PX (p', i', q') ->
(match p with
| Pc c -> pmulC cO cI cmul ceqb p'' c
@@ -3063,22 +806,24 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with
match j with
| XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q'
| XO j0 ->
- pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q'
+ pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0))
+ q'
| XH -> pmul cO cI cadd cmul ceqb q0 q'
in
mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ'
| PX (p2, i, q0) ->
let qQ' = pmul cO cI cadd cmul ceqb q0 q' in
- let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in
+ let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2
+ in
let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in
let pP' = pmul cO cI cadd cmul ceqb p2 p' in
padd cO cadd ceqb
- (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i'
- (p0 cO)) (mkPX cO ceqb pQ' i qQ'))
+ (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP')
+ i' (p0 cO)) (mkPX cO ceqb pQ' i qQ'))
(** val psquare :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> bool) -> 'a1 pol -> 'a1 pol **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> bool) -> 'a1 pol -> 'a1 pol **)
let rec psquare cO cI cadd cmul ceqb = function
| Pc c -> Pc (cmul c c)
@@ -3107,9 +852,9 @@ 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 **)
+ '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 ->
@@ -3123,16 +868,17 @@ let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function
| 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 **)
+ '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 **)
+ '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
@@ -3153,7 +899,8 @@ let rec norm_aux cO cI cadd cmul csub copp ceqb = function
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)
+ 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)
@@ -3185,9 +932,9 @@ let rec map_bformula fct = function
| N f0 -> N (map_bformula fct f0)
| I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2))
-type 'term' clause = 'term' list
+type 'x clause = 'x list
-type 'term' cnf = 'term' clause list
+type 'x cnf = 'x clause list
(** val tt : 'a1 cnf **)
@@ -3200,52 +947,52 @@ let ff =
[]::[]
(** val add_term :
- ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1
- clause option **)
+ ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause ->
+ 'a1 clause option **)
-let rec add_term unsat deduce t1 = function
+let rec add_term unsat deduce t0 = function
| [] ->
- (match deduce t1 t1 with
- | Some u -> if unsat u then None else Some (t1::[])
- | None -> Some (t1::[]))
+ (match deduce t0 t0 with
+ | Some u -> if unsat u then None else Some (t0::[])
+ | None -> Some (t0::[]))
| t'::cl0 ->
- (match deduce t1 t' with
+ (match deduce t0 t' with
| Some u ->
if unsat u
then None
- else (match add_term unsat deduce t1 cl0 with
+ else (match add_term unsat deduce t0 cl0 with
| Some cl' -> Some (t'::cl')
| None -> None)
| None ->
- (match add_term unsat deduce t1 cl0 with
+ (match add_term unsat deduce t0 cl0 with
| Some cl' -> Some (t'::cl')
| None -> None))
(** val or_clause :
- ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause
- -> 'a1 clause option **)
+ ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1
+ clause -> 'a1 clause option **)
let rec or_clause unsat deduce cl1 cl2 =
match cl1 with
| [] -> Some cl2
- | t1::cl ->
- (match add_term unsat deduce t1 cl2 with
+ | t0::cl ->
+ (match add_term unsat deduce t0 cl2 with
| Some cl' -> or_clause unsat deduce cl cl'
| None -> None)
(** val or_clause_cnf :
- ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf ->
- 'a1 cnf **)
+ ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf
+ -> 'a1 cnf **)
-let or_clause_cnf unsat deduce t1 f =
+let or_clause_cnf unsat deduce t0 f =
fold_right (fun e acc ->
- match or_clause unsat deduce t1 e with
+ match or_clause unsat deduce t0 e with
| Some cl -> cl::acc
| None -> acc) [] f
(** val or_cnf :
- ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1
- cnf **)
+ ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf ->
+ 'a1 cnf **)
let rec or_cnf unsat deduce f f' =
match f with
@@ -3259,8 +1006,8 @@ let and_cnf f1 f2 =
app f1 f2
(** val xcnf :
- ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
- -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
+ ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) ->
+ ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **)
let rec xcnf unsat deduce normalise0 negate0 pol0 = function
| TT -> if pol0 then tt else ff
@@ -3300,9 +1047,9 @@ let rec cnf_checker checker f l =
| c::l0 -> if checker e c then cnf_checker checker f0 l0 else false)
(** val tauto_checker :
- ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
- -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list ->
- bool **)
+ ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) ->
+ ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3
+ list -> bool **)
let tauto_checker unsat deduce normalise0 negate0 checker f w =
cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w
@@ -3335,18 +1082,18 @@ let opMult o o' =
| Equal -> Some Equal
| NonEqual ->
(match o' with
- | Strict -> None
- | NonStrict -> None
- | x -> Some x)
+ | Equal -> Some Equal
+ | NonEqual -> Some NonEqual
+ | _ -> None)
| Strict ->
(match o' with
| NonEqual -> None
| _ -> Some o')
| NonStrict ->
(match o' with
+ | Equal -> Some Equal
| NonEqual -> None
- | Strict -> Some NonStrict
- | x -> Some x)
+ | _ -> Some NonStrict)
(** val opAdd : op1 -> op1 -> op1 option **)
@@ -3394,8 +1141,8 @@ let map_option2 f o o' =
| None -> None
(** val pexpr_times_nformula :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option **)
let pexpr_times_nformula cO cI cplus ctimes ceqb e = function
| ef,o ->
@@ -3404,8 +1151,8 @@ let pexpr_times_nformula cO cI cplus ctimes ceqb e = function
| _ -> None)
(** val nformula_times_nformula :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option **)
let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 =
let e1,o1 = f1 in
@@ -3414,8 +1161,8 @@ let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 =
(opMult o1 o2)
(** val nformula_plus_nformula :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1
- nFormula -> 'a1 nFormula option **)
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula ->
+ 'a1 nFormula -> 'a1 nFormula option **)
let nformula_plus_nformula cO cplus ceqb f1 f2 =
let e1,o1 = f1 in
@@ -3423,9 +1170,9 @@ let nformula_plus_nformula cO cplus ceqb f1 f2 =
map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2)
(** val eval_Psatz :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1
- nFormula option **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz
+ -> 'a1 nFormula option **)
let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function
| PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal))
@@ -3460,9 +1207,9 @@ let check_inconsistent cO ceqb cleb = function
| _ -> false)
(** val check_normalised_formulas :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz ->
- bool **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz
+ -> bool **)
let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm =
match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with
@@ -3479,51 +1226,41 @@ type op2 =
type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr }
-(** val flhs : 'a1 formula -> 'a1 pExpr **)
-
-let flhs x = x.flhs
-
-(** val fop : 'a1 formula -> op2 **)
-
-let fop x = x.fop
-
-(** val frhs : 'a1 formula -> 'a1 pExpr **)
-
-let frhs x = x.frhs
-
(** val norm :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr ->
+ 'a1 pol **)
let norm cO cI cplus ctimes cminus copp ceqb =
norm_aux cO cI cplus ctimes cminus copp ceqb
(** val psub0 :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
- -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) ->
+ ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol **)
let psub0 cO cplus cminus copp ceqb =
psub cO cplus cminus copp ceqb
(** val padd0 :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
- -> 'a1 pol **)
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1
+ pol -> 'a1 pol **)
let padd0 cO cplus ceqb =
padd cO cplus ceqb
(** val xnormalise :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
- nFormula list **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula ->
+ 'a1 nFormula list **)
-let xnormalise cO cI cplus ctimes cminus copp ceqb t1 =
- let { flhs = lhs; fop = o; frhs = rhs } = t1 in
+let xnormalise cO cI cplus ctimes cminus copp ceqb t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in
let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in
(match o with
| OpEq ->
- ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus
+ ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO
+ cplus
cminus copp
ceqb rhs0
lhs0),Strict)::[])
@@ -3534,26 +1271,27 @@ let xnormalise cO cI cplus ctimes cminus copp ceqb t1 =
| OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[])
(** val cnf_normalise :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
- nFormula cnf **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula ->
+ 'a1 nFormula cnf **)
-let cnf_normalise cO cI cplus ctimes cminus copp ceqb t1 =
- map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t1)
+let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 =
+ map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t0)
(** val xnegate :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
- nFormula list **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula ->
+ 'a1 nFormula list **)
-let xnegate cO cI cplus ctimes cminus copp ceqb t1 =
- let { flhs = lhs; fop = o; frhs = rhs } = t1 in
+let xnegate cO cI cplus ctimes cminus copp ceqb t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in
let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in
(match o with
| OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[]
| OpNEq ->
- ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus
+ ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO
+ cplus
cminus copp
ceqb rhs0
lhs0),Strict)::[])
@@ -3563,12 +1301,12 @@ let xnegate cO cI cplus ctimes cminus copp ceqb t1 =
| OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[])
(** val cnf_negate :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
- -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
- nFormula cnf **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 ->
+ 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula ->
+ 'a1 nFormula cnf **)
-let cnf_negate cO cI cplus ctimes cminus copp ceqb t1 =
- map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t1)
+let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 =
+ map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0)
(** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **)
@@ -3602,14 +1340,14 @@ let map_Formula c_of_S f =
{ flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) }
(** val simpl_cone :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
- 'a1 psatz **)
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz
+ -> 'a1 psatz **)
let simpl_cone cO cI ctimes ceqb e = match e with
-| PsatzSquare t1 ->
- (match t1 with
+| PsatzSquare t0 ->
+ (match t0 with
| Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c)
- | _ -> PsatzSquare t1)
+ | _ -> PsatzSquare t0)
| PsatzMulE (t1, t2) ->
(match t1 with
| PsatzMulE (x, x0) ->
@@ -3641,7 +1379,8 @@ let simpl_cone cO cI ctimes ceqb e = match e with
| PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x)
| _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)))
| PsatzAdd (y, z0) ->
- PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0)))
+ PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c),
+ z0)))
| PsatzC c0 -> PsatzC (ctimes c c0)
| PsatzZ -> PsatzZ
| _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))
@@ -3683,7 +1422,8 @@ let qle_bool x y =
(** val qplus : q -> q -> q **)
let qplus x y =
- { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)));
+ { qnum =
+ (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden)));
qden = (Coq_Pos.mul x.qden y.qden) }
(** val qmult : q -> q -> q **)
@@ -3711,8 +1451,8 @@ let qinv x =
(** val qpower_positive : q -> positive -> q **)
-let qpower_positive q0 p =
- pow_pos qmult q0 p
+let qpower_positive =
+ pow_pos qmult
(** val qpower : q -> z -> q **)
@@ -3721,12 +1461,12 @@ let qpower q0 = function
| Zpos p -> qpower_positive q0 p
| Zneg p -> qinv (qpower_positive q0 p)
-type 'a t0 =
+type 'a t =
| Empty
| Leaf of 'a
-| Node of 'a t0 * 'a * 'a t0
+| Node of 'a t * 'a * 'a t
-(** val find : 'a1 -> 'a1 t0 -> positive -> 'a1 **)
+(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **)
let rec find default vm p =
match vm with
@@ -3738,6 +1478,29 @@ let rec find default vm p =
| XO p2 -> find default l p2
| XH -> e)
+(** val singleton : 'a1 -> positive -> 'a1 -> 'a1 t **)
+
+let rec singleton default x v =
+ match x with
+ | XI p -> Node (Empty, default, (singleton default p v))
+ | XO p -> Node ((singleton default p v), default, Empty)
+ | XH -> Leaf v
+
+(** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **)
+
+let rec vm_add default x v = function
+| Empty -> singleton default x v
+| Leaf vl ->
+ (match x with
+ | XI p -> Node (Empty, vl, (singleton default p v))
+ | XO p -> Node ((singleton default p v), vl, Empty)
+ | XH -> Leaf v)
+| Node (l, o, r) ->
+ (match x with
+ | XI p -> Node (l, o, (vm_add default p v r))
+ | XO p -> Node ((vm_add default p v l), o, r)
+ | XH -> Node (l, v, r))
+
type zWitness = z psatz
(** val zWeakChecker : z nFormula list -> z psatz -> bool **)
@@ -3762,8 +1525,8 @@ let norm0 =
(** val xnormalise0 : z formula -> z nFormula list **)
-let xnormalise0 t1 =
- let { flhs = lhs; fop = o; frhs = rhs } = t1 in
+let xnormalise0 t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
let lhs0 = norm0 lhs in
let rhs0 = norm0 rhs in
(match o with
@@ -3780,13 +1543,13 @@ let xnormalise0 t1 =
(** val normalise : z formula -> z nFormula cnf **)
-let normalise t1 =
- map (fun x -> x::[]) (xnormalise0 t1)
+let normalise t0 =
+ map (fun x -> x::[]) (xnormalise0 t0)
(** val xnegate0 : z formula -> z nFormula list **)
-let xnegate0 t1 =
- let { flhs = lhs; fop = o; frhs = rhs } = t1 in
+let xnegate0 t0 =
+ let { flhs = lhs; fop = o; frhs = rhs } = t0 in
let lhs0 = norm0 lhs in
let rhs0 = norm0 rhs in
(match o with
@@ -3803,8 +1566,8 @@ let xnegate0 t1 =
(** val negate : z formula -> z nFormula cnf **)
-let negate t1 =
- map (fun x -> x::[]) (xnegate0 t1)
+let negate t0 =
+ map (fun x -> x::[]) (xnegate0 t0)
(** val zunsat : z nFormula -> bool **)
@@ -3839,8 +1602,8 @@ let zgcdM x y =
let rec zgcd_pol = function
| Pc c -> Z0,c
-| Pinj (p2, p3) -> zgcd_pol p3
-| PX (p2, p3, q0) ->
+| Pinj (_, p2) -> zgcd_pol p2
+| PX (p2, _, q0) ->
let g1,c1 = zgcd_pol p2 in
let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2
@@ -3872,7 +1635,8 @@ let genCuttingPlane = function
then None
else Some ((makeCuttingPlane e),Equal)
| NonEqual -> Some ((e,Z0),op)
- | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict)
+ | Strict ->
+ Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict)
| NonStrict -> Some ((makeCuttingPlane e),NonStrict))
(** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **)
@@ -3966,8 +1730,8 @@ let qnormalise =
(** val qnegate : q formula -> q nFormula cnf **)
let qnegate =
- cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus
- qmult qminus qopp qeq_bool
+ cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH }
+ qplus qmult qminus qopp qeq_bool
(** val qunsat : q nFormula -> bool **)
@@ -4025,8 +1789,8 @@ let rnormalise =
(** val rnegate : q formula -> q nFormula cnf **)
let rnegate =
- cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus
- qmult qminus qopp qeq_bool
+ cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH }
+ qplus qmult qminus qopp qeq_bool
(** val runsat : q nFormula -> bool **)
@@ -4043,4 +1807,3 @@ let rdeduce =
let rTautoChecker f w =
tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker
(map_bformula (map_Formula q_of_Rcst) f) w
-
diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli
index bcd61f39..beb042f4 100644
--- a/plugins/micromega/micromega.mli
+++ b/plugins/micromega/micromega.mli
@@ -1,15 +1,9 @@
-type __ = Obj.t
-
val negb : bool -> bool
type nat =
| O
| S of nat
-val fst : ('a1 * 'a2) -> 'a1
-
-val snd : ('a1 * 'a2) -> 'a2
-
val app : 'a1 list -> 'a1 list -> 'a1 list
type comparison =
@@ -19,24 +13,7 @@ type comparison =
val compOpp : comparison -> comparison
-type compareSpecT =
-| CompEqT
-| CompLtT
-| CompGtT
-
-val compareSpec2Type : comparison -> compareSpecT
-
-type 'a compSpecT = compareSpecT
-
-val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT
-
-type 'a sig0 =
- 'a
- (* singleton inductive, whose constructor was exist *)
-
-val plus : nat -> nat -> nat
-
-val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1
+val add : nat -> nat -> nat
type positive =
| XI of positive
@@ -52,560 +29,59 @@ type z =
| Zpos of positive
| Zneg of positive
-module type TotalOrder' =
- sig
- type t
- end
-
-module MakeOrderTac :
- functor (O:TotalOrder') ->
- sig
-
- end
-
-module MaxLogicalProperties :
- functor (O:TotalOrder') ->
- functor (M:sig
- val max : O.t -> O.t -> O.t
- end) ->
- sig
- module T :
- sig
-
- end
- end
-
-module Pos :
- sig
- type t = positive
-
- val succ : positive -> positive
-
- val add : positive -> positive -> positive
-
- val add_carry : positive -> positive -> positive
-
- val pred_double : positive -> positive
-
- val pred : positive -> positive
-
- val pred_N : positive -> n
-
+module Pos :
+ sig
type mask =
| IsNul
| IsPos of positive
| IsNeg
-
- val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
-
- val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
-
- val succ_double_mask : mask -> mask
-
- val double_mask : mask -> mask
-
- val double_pred_mask : positive -> mask
-
- val pred_mask : mask -> mask
-
- val sub_mask : positive -> positive -> mask
-
- val sub_mask_carry : positive -> positive -> mask
-
- val sub : positive -> positive -> positive
-
- val mul : positive -> positive -> positive
-
- val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1
-
- val pow : positive -> positive -> positive
-
- val div2 : positive -> positive
-
- val div2_up : positive -> positive
-
- val size_nat : positive -> nat
-
- val size : positive -> positive
-
- val compare_cont : positive -> positive -> comparison -> comparison
-
- val compare : positive -> positive -> comparison
-
- val min : positive -> positive -> positive
-
- val max : positive -> positive -> positive
-
- val eqb : positive -> positive -> bool
-
- val leb : positive -> positive -> bool
-
- val ltb : positive -> positive -> bool
-
- val sqrtrem_step :
- (positive -> positive) -> (positive -> positive) -> (positive * mask) ->
- positive * mask
-
- val sqrtrem : positive -> positive * mask
-
- val sqrt : positive -> positive
-
- val gcdn : nat -> positive -> positive -> positive
-
- val gcd : positive -> positive -> positive
-
- val ggcdn : nat -> positive -> positive -> positive * (positive * positive)
-
- val ggcd : positive -> positive -> positive * (positive * positive)
-
- val coq_Nsucc_double : n -> n
-
- val coq_Ndouble : n -> n
-
- val coq_lor : positive -> positive -> positive
-
- val coq_land : positive -> positive -> n
-
- val ldiff : positive -> positive -> n
-
- val coq_lxor : positive -> positive -> n
-
- val shiftl_nat : positive -> nat -> positive
-
- val shiftr_nat : positive -> nat -> positive
-
- val shiftl : positive -> n -> positive
-
- val shiftr : positive -> n -> positive
-
- val testbit_nat : positive -> nat -> bool
-
- val testbit : positive -> n -> bool
-
- val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1
-
- val to_nat : positive -> nat
-
- val of_nat : nat -> positive
-
- val of_succ_nat : nat -> positive
end
-module Coq_Pos :
- sig
- module Coq__1 : sig
- type t = positive
- end
- type t = Coq__1.t
-
+module Coq_Pos :
+ sig
val succ : positive -> positive
-
+
val add : positive -> positive -> positive
-
+
val add_carry : positive -> positive -> positive
-
+
val pred_double : positive -> positive
-
- val pred : positive -> positive
-
- val pred_N : positive -> n
-
+
type mask = Pos.mask =
| IsNul
| IsPos of positive
| IsNeg
-
- val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
-
- val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1
-
+
val succ_double_mask : mask -> mask
-
+
val double_mask : mask -> mask
-
+
val double_pred_mask : positive -> mask
-
- val pred_mask : mask -> mask
-
+
val sub_mask : positive -> positive -> mask
-
+
val sub_mask_carry : positive -> positive -> mask
-
+
val sub : positive -> positive -> positive
-
+
val mul : positive -> positive -> positive
-
- val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1
-
- val pow : positive -> positive -> positive
-
- val div2 : positive -> positive
-
- val div2_up : positive -> positive
-
+
val size_nat : positive -> nat
-
- val size : positive -> positive
-
- val compare_cont : positive -> positive -> comparison -> comparison
-
+
+ val compare_cont : comparison -> positive -> positive -> comparison
+
val compare : positive -> positive -> comparison
-
- val min : positive -> positive -> positive
-
- val max : positive -> positive -> positive
-
- val eqb : positive -> positive -> bool
-
- val leb : positive -> positive -> bool
-
- val ltb : positive -> positive -> bool
-
- val sqrtrem_step :
- (positive -> positive) -> (positive -> positive) -> (positive * mask) ->
- positive * mask
-
- val sqrtrem : positive -> positive * mask
-
- val sqrt : positive -> positive
-
+
val gcdn : nat -> positive -> positive -> positive
-
+
val gcd : positive -> positive -> positive
-
- val ggcdn : nat -> positive -> positive -> positive * (positive * positive)
-
- val ggcd : positive -> positive -> positive * (positive * positive)
-
- val coq_Nsucc_double : n -> n
-
- val coq_Ndouble : n -> n
-
- val coq_lor : positive -> positive -> positive
-
- val coq_land : positive -> positive -> n
-
- val ldiff : positive -> positive -> n
-
- val coq_lxor : positive -> positive -> n
-
- val shiftl_nat : positive -> nat -> positive
-
- val shiftr_nat : positive -> nat -> positive
-
- val shiftl : positive -> n -> positive
-
- val shiftr : positive -> n -> positive
-
- val testbit_nat : positive -> nat -> bool
-
- val testbit : positive -> n -> bool
-
- val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1
-
- val to_nat : positive -> nat
-
- val of_nat : nat -> positive
-
+
val of_succ_nat : nat -> positive
-
- val eq_dec : positive -> positive -> bool
-
- val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1
-
- val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1
-
- type coq_PeanoView =
- | PeanoOne
- | PeanoSucc of positive * coq_PeanoView
-
- val coq_PeanoView_rect :
- 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
- coq_PeanoView -> 'a1
-
- val coq_PeanoView_rec :
- 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive ->
- coq_PeanoView -> 'a1
-
- val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView
-
- val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView
-
- val peanoView : positive -> coq_PeanoView
-
- val coq_PeanoView_iter :
- 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1
-
- val switch_Eq : comparison -> comparison -> comparison
-
- val mask2cmp : mask -> comparison
-
- module T :
- sig
-
- end
-
- module ORev :
- sig
- type t = Coq__1.t
- end
-
- module MRev :
- sig
- val max : t -> t -> t
- end
-
- module MPRev :
- sig
- module T :
- sig
-
- end
- end
-
- module P :
- sig
- val max_case_strong :
- t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
- 'a1
-
- val max_case :
- t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-
- val max_dec : t -> t -> bool
-
- val min_case_strong :
- t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
- 'a1
-
- val min_case :
- t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-
- val min_dec : t -> t -> bool
- end
-
- val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-
- val max_case : t -> t -> 'a1 -> 'a1 -> 'a1
-
- val max_dec : t -> t -> bool
-
- val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-
- val min_case : t -> t -> 'a1 -> 'a1 -> 'a1
-
- val min_dec : t -> t -> bool
end
-module N :
- sig
- type t = n
-
- val zero : n
-
- val one : n
-
- val two : n
-
- val succ_double : n -> n
-
- val double : n -> n
-
- val succ : n -> n
-
- val pred : n -> n
-
- val succ_pos : n -> positive
-
- val add : n -> n -> n
-
- val sub : n -> n -> n
-
- val mul : n -> n -> n
-
- val compare : n -> n -> comparison
-
- val eqb : n -> n -> bool
-
- val leb : n -> n -> bool
-
- val ltb : n -> n -> bool
-
- val min : n -> n -> n
-
- val max : n -> n -> n
-
- val div2 : n -> n
-
- val even : n -> bool
-
- val odd : n -> bool
-
- val pow : n -> n -> n
-
- val log2 : n -> n
-
- val size : n -> n
-
- val size_nat : n -> nat
-
- val pos_div_eucl : positive -> n -> n * n
-
- val div_eucl : n -> n -> n * n
-
- val div : n -> n -> n
-
- val modulo : n -> n -> n
-
- val gcd : n -> n -> n
-
- val ggcd : n -> n -> n * (n * n)
-
- val sqrtrem : n -> n * n
-
- val sqrt : n -> n
-
- val coq_lor : n -> n -> n
-
- val coq_land : n -> n -> n
-
- val ldiff : n -> n -> n
-
- val coq_lxor : n -> n -> n
-
- val shiftl_nat : n -> nat -> n
-
- val shiftr_nat : n -> nat -> n
-
- val shiftl : n -> n -> n
-
- val shiftr : n -> n -> n
-
- val testbit_nat : n -> nat -> bool
-
- val testbit : n -> n -> bool
-
- val to_nat : n -> nat
-
+module N :
+ sig
val of_nat : nat -> n
-
- val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1
-
- val eq_dec : n -> n -> bool
-
- val discr : n -> positive option
-
- val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1
-
- val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1
-
- val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1
-
- val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1
-
- module BootStrap :
- sig
-
- end
-
- val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1
-
- module OrderElts :
- sig
- type t = n
- end
-
- module OrderTac :
- sig
-
- end
-
- module NZPowP :
- sig
-
- end
-
- module NZSqrtP :
- sig
-
- end
-
- val sqrt_up : n -> n
-
- val log2_up : n -> n
-
- module NZDivP :
- sig
-
- end
-
- val lcm : n -> n -> n
-
- val b2n : bool -> n
-
- val setbit : n -> n -> n
-
- val clearbit : n -> n -> n
-
- val ones : n -> n
-
- val lnot : n -> n -> n
-
- module T :
- sig
-
- end
-
- module ORev :
- sig
- type t = n
- end
-
- module MRev :
- sig
- val max : n -> n -> n
- end
-
- module MPRev :
- sig
- module T :
- sig
-
- end
- end
-
- module P :
- sig
- val max_case_strong :
- n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
- 'a1
-
- val max_case :
- n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-
- val max_dec : n -> n -> bool
-
- val min_case_strong :
- n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
- 'a1
-
- val min_case :
- n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-
- val min_dec : n -> n -> bool
- end
-
- val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-
- val max_case : n -> n -> 'a1 -> 'a1 -> 'a1
-
- val max_dec : n -> n -> bool
-
- val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-
- val min_case : n -> n -> 'a1 -> 'a1 -> 'a1
-
- val min_dec : n -> n -> bool
end
val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1
@@ -616,225 +92,45 @@ val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list
val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1
-module Z :
- sig
- type t = z
-
- val zero : z
-
- val one : z
-
- val two : z
-
+module Z :
+ sig
val double : z -> z
-
+
val succ_double : z -> z
-
+
val pred_double : z -> z
-
+
val pos_sub : positive -> positive -> z
-
+
val add : z -> z -> z
-
+
val opp : z -> z
-
- val succ : z -> z
-
- val pred : z -> z
-
+
val sub : z -> z -> z
-
+
val mul : z -> z -> z
-
- val pow_pos : z -> positive -> z
-
- val pow : z -> z -> z
-
+
val compare : z -> z -> comparison
-
- val sgn : z -> z
-
+
val leb : z -> z -> bool
-
- val geb : z -> z -> bool
-
+
val ltb : z -> z -> bool
-
+
val gtb : z -> z -> bool
-
- val eqb : z -> z -> bool
-
+
val max : z -> z -> z
-
- val min : z -> z -> z
-
+
val abs : z -> z
-
- val abs_nat : z -> nat
-
- val abs_N : z -> n
-
- val to_nat : z -> nat
-
+
val to_N : z -> n
-
- val of_nat : nat -> z
-
- val of_N : n -> z
-
- val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1
-
+
val pos_div_eucl : positive -> z -> z * z
-
+
val div_eucl : z -> z -> z * z
-
+
val div : z -> z -> z
-
- val modulo : z -> z -> z
-
- val quotrem : z -> z -> z * z
-
- val quot : z -> z -> z
-
- val rem : z -> z -> z
-
- val even : z -> bool
-
- val odd : z -> bool
-
- val div2 : z -> z
-
- val quot2 : z -> z
-
- val log2 : z -> z
-
- val sqrtrem : z -> z * z
-
- val sqrt : z -> z
-
+
val gcd : z -> z -> z
-
- val ggcd : z -> z -> z * (z * z)
-
- val testbit : z -> z -> bool
-
- val shiftl : z -> z -> z
-
- val shiftr : z -> z -> z
-
- val coq_lor : z -> z -> z
-
- val coq_land : z -> z -> z
-
- val ldiff : z -> z -> z
-
- val coq_lxor : z -> z -> z
-
- val eq_dec : z -> z -> bool
-
- module BootStrap :
- sig
-
- end
-
- module OrderElts :
- sig
- type t = z
- end
-
- module OrderTac :
- sig
-
- end
-
- val sqrt_up : z -> z
-
- val log2_up : z -> z
-
- module NZDivP :
- sig
-
- end
-
- module Quot2Div :
- sig
- val div : z -> z -> z
-
- val modulo : z -> z -> z
- end
-
- module NZQuot :
- sig
-
- end
-
- val lcm : z -> z -> z
-
- val b2z : bool -> z
-
- val setbit : z -> z -> z
-
- val clearbit : z -> z -> z
-
- val lnot : z -> z
-
- val ones : z -> z
-
- module T :
- sig
-
- end
-
- module ORev :
- sig
- type t = z
- end
-
- module MRev :
- sig
- val max : z -> z -> z
- end
-
- module MPRev :
- sig
- module T :
- sig
-
- end
- end
-
- module P :
- sig
- val max_case_strong :
- z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
- 'a1
-
- val max_case :
- z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-
- val max_dec : z -> z -> bool
-
- val min_case_strong :
- z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) ->
- 'a1
-
- val min_case :
- z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1
-
- val min_dec : z -> z -> bool
- end
-
- val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-
- val max_case : z -> z -> 'a1 -> 'a1 -> 'a1
-
- val max_dec : z -> z -> bool
-
- val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1
-
- val min_case : z -> z -> 'a1 -> 'a1 -> 'a1
-
- val min_dec : z -> z -> bool
end
val zeq_bool : z -> z -> bool
@@ -872,44 +168,44 @@ val paddI :
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
+ ('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
+ '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
+ '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
+ '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
+ '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
+ '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
+ '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
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
val psquare :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- bool) -> 'a1 pol -> 'a1 pol
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> 'a1 pol -> 'a1 pol
type 'c pExpr =
| PEc of 'c
@@ -923,16 +219,17 @@ type 'c pExpr =
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
+ '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
+ '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
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
type 'a bFormula =
| TT
@@ -946,9 +243,9 @@ type 'a bFormula =
val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula
-type 'term' clause = 'term' list
+type 'x clause = 'x list
-type 'term' cnf = 'term' clause list
+type 'x cnf = 'x clause list
val tt : 'a1 cnf
@@ -959,12 +256,12 @@ val add_term :
clause option
val or_clause :
- ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause ->
- 'a1 clause option
+ ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause
+ -> 'a1 clause option
val or_clause_cnf :
- ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1
- cnf
+ ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf ->
+ 'a1 cnf
val or_cnf :
('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1
@@ -973,18 +270,20 @@ val or_cnf :
val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf
val xcnf :
- ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 ->
- 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf
+ ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
+ -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf
val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool
val tauto_checker :
- ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 ->
- 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool
+ ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1
+ -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list ->
+ bool
val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
-val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
+val cltb :
+ ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool
type 'c polC = 'c pol
@@ -1015,28 +314,30 @@ val map_option2 :
('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 option
val pexpr_times_nformula :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> 'a1 polC -> 'a1 nFormula -> 'a1 nFormula option
val nformula_times_nformula :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula option
val nformula_plus_nformula :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1
- nFormula -> 'a1 nFormula option
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula ->
+ 'a1 nFormula -> 'a1 nFormula option
val eval_Psatz :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1
- nFormula option
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz ->
+ 'a1 nFormula option
val check_inconsistent :
- 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool
+ 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula ->
+ bool
val check_normalised_formulas :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz ->
+ bool
type op2 =
| OpEq
@@ -1048,43 +349,37 @@ type op2 =
type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr }
-val flhs : 'a1 formula -> 'a1 pExpr
-
-val fop : 'a1 formula -> op2
-
-val frhs : 'a1 formula -> 'a1 pExpr
-
val norm :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol
val psub0 :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1
- -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) ->
+ ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> 'a1 pol
val padd0 :
- 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol ->
- 'a1 pol
+ 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol
+ -> 'a1 pol
val xnormalise :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
- list
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+ nFormula list
val cnf_normalise :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
- cnf
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+ nFormula cnf
val xnegate :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
- list
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+ nFormula list
val cnf_negate :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 ->
- 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula
- cnf
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1
+ -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1
+ nFormula cnf
val xdenorm : positive -> 'a1 pol -> 'a1 pExpr
@@ -1095,8 +390,8 @@ val map_PExpr : ('a2 -> 'a1) -> 'a2 pExpr -> 'a1 pExpr
val map_Formula : ('a2 -> 'a1) -> 'a2 formula -> 'a1 formula
val simpl_cone :
- 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz ->
- 'a1 psatz
+ 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz
+ -> 'a1 psatz
type q = { qnum : z; qden : positive }
@@ -1122,12 +417,16 @@ val qpower_positive : q -> positive -> q
val qpower : q -> z -> q
-type 'a t0 =
+type 'a t =
| Empty
| Leaf of 'a
-| Node of 'a t0 * 'a * 'a t0
+| Node of 'a t * 'a * 'a t
+
+val find : 'a1 -> 'a1 t -> positive -> 'a1
-val find : 'a1 -> 'a1 t0 -> positive -> 'a1
+val singleton : 'a1 -> positive -> 'a1 -> 'a1 t
+
+val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t
type zWitness = z psatz
@@ -1221,4 +520,3 @@ val runsat : q nFormula -> bool
val rdeduce : q nFormula -> q nFormula -> q nFormula option
val rTautoChecker : rcst formula bFormula -> rWitness list -> bool
-
diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mlpack
index f53a9e37..ed253da3 100644
--- a/plugins/micromega/micromega_plugin.mllib
+++ b/plugins/micromega/micromega_plugin.mlpack
@@ -7,4 +7,3 @@ Certificate
Persistent_cache
Coq_micromega
G_micromega
-Micromega_plugin_mod
diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml
index 2dd443f0..b4c6d032 100644
--- a/plugins/micromega/mutils.ml
+++ b/plugins/micromega/mutils.ml
@@ -66,6 +66,15 @@ let all_sym_pairs f l =
| e::l -> xpairs (pair_with acc e l) l in
xpairs [] l
+let all_pairs f l =
+ let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in
+
+ let rec xpairs acc l =
+ match l with
+ | [] -> acc
+ | e::lx -> xpairs (pair_with acc e l) lx in
+ xpairs [] l
+
let rec map3 f l1 l2 l3 =
@@ -285,18 +294,6 @@ struct
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 Int.equal n 1 then []
- else (Int.equal (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
diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml
index 6a03e2d6..0e6d346a 100644
--- a/plugins/micromega/persistent_cache.ml
+++ b/plugins/micromega/persistent_cache.ml
@@ -92,7 +92,7 @@ let read_key_elem inch =
Some (Marshal.from_channel inch)
with
| End_of_file -> None
- | e when Errors.noncritical e -> raise InvalidTableFormat
+ | e when CErrors.noncritical e -> raise InvalidTableFormat
(**
We used to only lock/unlock regions.
@@ -212,9 +212,11 @@ let find t k =
res
let memo cache f =
- let tbl = lazy (open_in cache) in
- fun x ->
- let tbl = Lazy.force tbl in
+ let tbl = lazy (try Some (open_in cache) with _ -> None) in
+ fun x ->
+ match Lazy.force tbl with
+ | None -> f x
+ | Some tbl ->
try
find tbl x
with
diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget
index bf6a1a7d..c9009ea4 100644
--- a/plugins/micromega/vo.itarget
+++ b/plugins/micromega/vo.itarget
@@ -10,4 +10,6 @@ Tauto.vo
VarMap.vo
ZCoeff.vo
ZMicromega.vo
-Lia.vo \ No newline at end of file
+Lia.vo
+Lqa.vo
+Lra.vo
diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v
index 3068b534..b11d15e5 100644
--- a/plugins/nsatz/Nsatz.v
+++ b/plugins/nsatz/Nsatz.v
@@ -298,7 +298,9 @@ Ltac nsatz_call_n info nparam p rr lp kont :=
match goal with
| |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
intros _;
+ let lci := fresh "lci" in
set (lci:=lci0);
+ let lq := fresh "lq" in
set (lq:=lq0);
kont c rr lq lci
end.
@@ -380,10 +382,13 @@ Ltac nsatz_generic radicalmax info lparam lvar :=
end in
SplitPolyList ltac:(fun p lp =>
+ let p21 := fresh "p21" in
+ let lp21 := fresh "lp21" in
set (p21:=p) ;
set (lp21:=lp);
(* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *)
nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci =>
+ let q := fresh "q" in
set (q := PEmul c (PEpow p21 r));
let Hg := fresh "Hg" in
assert (Hg:check lp21 q (lci,lq) = true);
diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4
new file mode 100644
index 00000000..5f906a8d
--- /dev/null
+++ b/plugins/nsatz/g_nsatz.ml4
@@ -0,0 +1,17 @@
+DECLARE PLUGIN "nsatz_plugin"
+
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+DECLARE PLUGIN "nsatz_plugin"
+
+TACTIC EXTEND nsatz_compute
+| [ "nsatz_compute" constr(lt) ] -> [ Nsatz.nsatz_compute lt ]
+END
diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml
index 482ce505..48bdad82 100644
--- a/plugins/nsatz/ideal.ml
+++ b/plugins/nsatz/ideal.ml
@@ -19,75 +19,6 @@ open Utile
exception NotInIdeal
-module type S = sig
-
-(* Monomials *)
-type mon = int array
-
-val mult_mon : mon -> mon -> mon
-val deg : mon -> int
-val compare_mon : mon -> mon -> int
-val div_mon : mon -> mon -> mon
-val div_mon_test : mon -> mon -> bool
-val ppcm_mon : mon -> mon -> mon
-
-(* Polynomials *)
-
-type deg = int
-type coef
-type poly
-type polynom
-
-val repr : poly -> (coef * mon) list
-val polconst : coef -> poly
-val zeroP : poly
-val gen : int -> poly
-
-val equal : poly -> poly -> bool
-val name_var : string list ref
-val getvar : string list -> int -> string
-val lstringP : poly list -> string
-val printP : poly -> unit
-val lprintP : poly list -> unit
-
-val div_pol_coef : poly -> coef -> poly
-val plusP : poly -> poly -> poly
-val mult_t_pol : coef -> mon -> poly -> poly
-val selectdiv : mon -> poly list -> poly
-val oppP : poly -> poly
-val emultP : coef -> poly -> poly
-val multP : poly -> poly -> poly
-val puisP : poly -> int -> poly
-val contentP : poly -> coef
-val contentPlist : poly list -> coef
-val pgcdpos : coef -> coef -> coef
-val div_pol : poly -> poly -> coef -> coef -> mon -> poly
-val reduce2 : poly -> poly list -> coef * poly
-
-val poldepcontent : coef list ref
-val coefpoldep_find : poly -> poly -> poly
-val coefpoldep_set : poly -> poly -> poly -> unit
-val initcoefpoldep : poly list -> unit
-val reduce2_trace : poly -> poly list -> poly list -> poly list * poly
-val spol : poly -> poly -> poly
-val etrangers : poly -> poly -> bool
-val div_ppcm : poly -> poly -> poly -> bool
-
-val genPcPf : poly -> poly list -> poly list -> poly list
-val genOCPf : poly list -> poly list
-
-val is_homogeneous : poly -> bool
-
-type certificate =
- { coef : coef; power : int;
- gb_comb : poly list list; last_comb : poly list }
-
-val test_dans_ideal : poly -> poly list -> poly list ->
- poly list * poly * certificate
-val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate
-
-end
-
(***********************************************************************
Global options
*)
@@ -127,11 +58,11 @@ type polynom =
num : int;
sugar : int}
-let nvar m = Array.length m - 1
+let nvar (m : mon) = Array.length m - 1
-let deg m = m.(0)
+let deg (m : mon) = m.(0)
-let mult_mon m m' =
+let mult_mon (m : mon) (m' : mon) =
let d = nvar m in
let m'' = Array.make (d+1) 0 in
for i=0 to d do
@@ -140,7 +71,7 @@ let mult_mon m m' =
m''
-let compare_mon m m' =
+let compare_mon (m : mon) (m' : mon) =
let d = nvar m in
if !lexico
then (
@@ -148,18 +79,18 @@ let compare_mon m m' =
let res=ref 0 in
let i=ref 1 in (* 1 si lexico pur 0 si degre*)
while (!res=0) && (!i<=d) do
- res:= (compare m.(!i) m'.(!i));
+ res:= (Int.compare m.(!i) m'.(!i));
i:=!i+1;
done;
!res)
else (
(* degre lexicographique inverse *)
- match compare m.(0) m'.(0) with
+ match Int.compare m.(0) m'.(0) with
| 0 -> (* meme degre total *)
let res=ref 0 in
let i=ref d in
while (!res=0) && (!i>=1) do
- res:= - (compare m.(!i) m'.(!i));
+ res:= - (Int.compare m.(!i) m'.(!i));
i:=!i-1;
done;
!res
@@ -402,29 +333,25 @@ let polconst d c =
[(c,m)]
let plusP p q =
- let rec plusP p q =
- match p with
- [] -> q
- |t::p' ->
- match q with
- [] -> p
- |t'::q' ->
- match compare_mon (snd t) (snd t') with
- 1 -> t::(plusP p' q)
- |(-1) -> t'::(plusP p q')
- |_ -> let c=P.plusP (fst t) (fst t') in
- match P.equal c coef0 with
- true -> (plusP p' q')
- |false -> (c,(snd t))::(plusP p' q')
- in plusP p q
+ let rec plusP p q accu = match p, q with
+ | [], [] -> List.rev accu
+ | [], _ -> List.rev_append accu q
+ | _, [] -> List.rev_append accu p
+ | t :: p', t' :: q' ->
+ let c = compare_mon (snd t) (snd t') in
+ if c > 0 then plusP p' q (t :: accu)
+ else if c < 0 then plusP p q' (t' :: accu)
+ else
+ let c = P.plusP (fst t) (fst t') in
+ if P.equal c coef0 then plusP p' q' accu
+ else plusP p' q' ((c, (snd t)) :: accu)
+ in
+ plusP p q []
(* multiplication by (a,monomial) *)
let mult_t_pol a m p =
- let rec mult_t_pol p =
- match p with
- [] -> []
- |(b,m')::p -> ((P.multP a b),(mult_mon m m'))::(mult_t_pol p)
- in mult_t_pol p
+ let map (b, m') = (P.multP a b, mult_mon m m') in
+ CList.map map p
let coef_of_int x = P.of_num (Num.Int x)
@@ -451,23 +378,27 @@ let emultP a p =
in emultP p
let multP p q =
- let rec aux p =
+ let rec aux p accu =
match p with
- [] -> []
- |(a,m)::p' -> plusP (mult_t_pol a m q) (aux p')
- in aux p
+ [] -> accu
+ |(a,m)::p' -> aux p' (plusP (mult_t_pol a m q) accu)
+ in aux p []
let puisP p n=
match p with
[] -> []
|_ ->
+ if n = 0 then
let d = nvar (snd (List.hd p)) in
- let rec puisP n =
- match n with
- 0 -> [coef1, Array.make (d+1) 0]
- | 1 -> p
- |_ -> multP p (puisP (n-1))
- in puisP n
+ [coef1, Array.make (d+1) 0]
+ else
+ let rec puisP p n =
+ if n = 1 then p
+ else
+ let q = puisP p (n / 2) in
+ let q = multP q q in
+ if n mod 2 = 0 then q else multP p q
+ in puisP p n
let rec contentP p =
match p with
diff --git a/plugins/nsatz/ideal.mli b/plugins/nsatz/ideal.mli
new file mode 100644
index 00000000..d1a2a0a7
--- /dev/null
+++ b/plugins/nsatz/ideal.mli
@@ -0,0 +1,47 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+module Make (P : Polynom.S) :
+sig
+(* Polynomials *)
+
+type deg = int
+type coef = P.t
+type poly
+
+val repr : poly -> (coef * int array) list
+val polconst : int -> coef -> poly
+val zeroP : poly
+val gen : int -> int -> poly
+
+val equal : poly -> poly -> bool
+val name_var : string list ref
+
+val plusP : poly -> poly -> poly
+val oppP : poly -> poly
+val multP : poly -> poly -> poly
+val puisP : poly -> int -> poly
+
+val poldepcontent : coef list ref
+
+type certificate =
+ { coef : coef; power : int;
+ gb_comb : poly list list; last_comb : poly list }
+
+val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate
+
+module Hashpol : Hashtbl.S with type key = poly
+
+val sugar_flag : bool ref
+val divide_rem_with_critical_pair : bool ref
+
+end
+
+exception NotInIdeal
+
+val lexico : bool ref
diff --git a/plugins/nsatz/nsatz.ml4 b/plugins/nsatz/nsatz.ml
index ced53d82..36bce780 100644
--- a/plugins/nsatz/nsatz.ml4
+++ b/plugins/nsatz/nsatz.ml
@@ -6,9 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
-open Errors
+open CErrors
open Util
open Term
open Tactics
@@ -17,8 +15,6 @@ open Coqlib
open Num
open Utile
-DECLARE PLUGIN "nsatz_plugin"
-
(***********************************************************************
Operations on coefficients
*)
@@ -472,6 +468,44 @@ let theoremedeszeros lpol p =
open Ideal
+(* Remove zero polynomials and duplicates from the list of polynomials lp
+ Return (clp, lb)
+ where clp is the reduced list and lb is a list of booleans
+ that has the same size than lp and where true indicates an
+ element that has been removed
+ *)
+let rec clean_pol lp =
+ let t = Hashpol.create 12 in
+ let find p = try Hashpol.find t p
+ with
+ Not_found -> Hashpol.add t p true; false in
+ let rec aux lp =
+ match lp with
+ | [] -> [], []
+ | p :: lp1 ->
+ let clp, lb = aux lp1 in
+ if equal p zeroP || find p then clp, true::lb
+ else
+ (p :: clp, false::lb) in
+ aux lp
+
+(* Expand the list of polynomials lp putting zeros where the list of
+ booleans lb indicates there is a missing element
+ Warning:
+ the expansion is relative to the end of the list in reversed order
+ lp cannot have less elements than lb
+*)
+let expand_pol lb lp =
+ let rec aux lb lp =
+ match lb with
+ | [] -> lp
+ | true :: lb1 -> zeroP :: aux lb1 lp
+ | false :: lb1 ->
+ match lp with
+ [] -> assert false
+ | p :: lp1 -> p :: aux lb1 lp1
+ in List.rev (aux lb (List.rev lp))
+
let theoremedeszeros_termes lp =
nvars:=0;(* mise a jour par term_pol_sparse *)
List.iter set_nvars_term lp;
@@ -522,20 +556,29 @@ let theoremedeszeros_termes lp =
| [] -> assert false
| p::lp1 ->
let lpol = List.rev lp1 in
+ (* preprocessing :
+ we remove zero polynomials and duplicate that are not handled by in_ideal
+ lb is kept in order to fix the certificate in the post-processing
+ *)
+ let lpol, lb = clean_pol lpol in
let (cert,lp0,p,_lct) = theoremedeszeros lpol p in
info "cert ok\n";
let lc = cert.last_comb::List.rev cert.gb_comb in
match remove_zeros (fun x -> equal x zeroP) lc with
| [] -> assert false
| (lq::lci) ->
+ (* post-processing : we apply the correction for the last line *)
+ let lq = expand_pol lb lq in
(* lci commence par les nouveaux polynomes *)
- let m= !nvars in
+ let m = !nvars in
let c = pol_sparse_to_term m (polconst m cert.coef) in
let r = Pow(Zero,cert.power) in
let lci = List.rev lci in
+ (* post-processing we apply the correction for the other lines *)
+ let lci = List.map (expand_pol lb) lci in
let lci = List.map (List.map (pol_sparse_to_term m)) lci in
let lq = List.map (pol_sparse_to_term m) lq in
- info ("number of parametres: "^string_of_int nparam^"\n");
+ info ("number of parameters: "^string_of_int nparam^"\n");
info "term computed\n";
(c,r,lci,lq)
)
@@ -591,8 +634,4 @@ let nsatz_compute t =
error "nsatz cannot solve this problem" in
return_term lpol
-TACTIC EXTEND nsatz_compute
-| [ "nsatz_compute" constr(lt) ] -> [ Proofview.V82.tactic (nsatz_compute lt) ]
-END
-
diff --git a/plugins/nsatz/nsatz.mli b/plugins/nsatz/nsatz.mli
new file mode 100644
index 00000000..e876ccfa
--- /dev/null
+++ b/plugins/nsatz/nsatz.mli
@@ -0,0 +1,9 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+val nsatz_compute : Constr.t -> unit Proofview.tactic
diff --git a/plugins/nsatz/nsatz_plugin.mllib b/plugins/nsatz/nsatz_plugin.mlpack
index a25e649d..b55adf43 100644
--- a/plugins/nsatz/nsatz_plugin.mllib
+++ b/plugins/nsatz/nsatz_plugin.mlpack
@@ -2,4 +2,4 @@ Utile
Polynom
Ideal
Nsatz
-Nsatz_plugin_mod
+G_nsatz
diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml
index 8e2fc07c..92243246 100644
--- a/plugins/nsatz/utile.ml
+++ b/plugins/nsatz/utile.ml
@@ -51,7 +51,7 @@ let facteurs_liste div constant lp =
if not (constant r)
then l1:=r::(!l1)
else p_dans_lmin:=true)
- with e when Errors.noncritical e -> ())
+ with e when CErrors.noncritical e -> ())
lmin;
if !p_dans_lmin
then factor lmin lp1
@@ -62,7 +62,7 @@ let facteurs_liste div constant lp =
List.iter (fun q -> try (let r = div q p in
if not (constant r)
then l1:=r::(!l1))
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
lmin1:=q::(!lmin1))
lmin;
factor (List.rev (p::(!lmin1))) !l1)
@@ -93,7 +93,7 @@ let factorise_tableau div zero c f l1 =
li:=j::(!li);
r:=rr;
done)
- with e when Errors.noncritical e -> ())
+ with e when CErrors.noncritical e -> ())
l1;
res.(i)<-(!r,!li))
f;
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
index 8a2a957c..d625e307 100644
--- a/plugins/omega/coq_omega.ml
+++ b/plugins/omega/coq_omega.ml
@@ -13,7 +13,7 @@
(* *)
(**************************************************************************)
-open Errors
+open CErrors
open Util
open Names
open Nameops
@@ -27,6 +27,8 @@ open Globnames
open Nametab
open Contradiction
open Misctypes
+open Proofview.Notations
+open Context.Named.Declaration
module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
open OmegaSolver
@@ -34,9 +36,9 @@ open OmegaSolver
(* Added by JCF, 09/03/98 *)
let elim_id id =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
simplest_elim (Tacmach.New.pf_global id gl)
- end
+ end }
let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl
let timing timer_name f arg = f arg
@@ -148,7 +150,7 @@ let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c])
let generalize_tac t = generalize t
let elim t = simplest_elim t
-let exact t = Tactics.refine t
+let exact t = Tacmach.refine t
let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s]
let rev_assoc k =
@@ -909,7 +911,7 @@ let rec transform p t =
try
let v,th,_ = find_constr t' in
[clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v
- with e when Errors.noncritical e ->
+ with e when CErrors.noncritical e ->
let v = new_identifier_var ()
and th = new_identifier () in
hide_constr t' v th isnat;
@@ -926,15 +928,15 @@ let rec transform p t =
transform p
(mkApp (Lazy.force coq_Zplus,
[| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in
- unfold sp_Zminus :: tac,t
+ Proofview.V82.of_tactic (unfold sp_Zminus) :: tac,t
| Kapp(Zsucc,[t1]) ->
let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
[| t1; mk_integer one |])) in
- unfold sp_Zsucc :: tac,t
+ Proofview.V82.of_tactic (unfold sp_Zsucc) :: tac,t
| Kapp(Zpred,[t1]) ->
let tac,t = transform p (mkApp (Lazy.force coq_Zplus,
[| t1; mk_integer negone |])) in
- unfold sp_Zpred :: tac,t
+ Proofview.V82.of_tactic (unfold sp_Zpred) :: tac,t
| Kapp(Zmult,[t1;t2]) ->
let tac1,t1' = transform (P_APP 1 :: p) t1
and tac2,t2' = transform (P_APP 2 :: p) t2 in
@@ -949,7 +951,7 @@ let rec transform p t =
end
| Kapp((Zpos|Zneg|Z0),_) ->
(try ([],Oz(recognize_number t))
- with e when Errors.noncritical e -> default false t)
+ with e when CErrors.noncritical e -> default false t)
| Kvar s -> [],Oatom s
| Kapp(Zopp,[t]) ->
let tac,t' = transform (P_APP 1 :: p) t in
@@ -1065,12 +1067,12 @@ let replay_history tactic_normalisation =
let p_initial = [P_APP 1;P_TYPE] in
let tac= shuffle_mult_right p_initial e1.body k e2.body in
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ generalize_tac
[mkApp (Lazy.force coq_OMEGA17, [|
val_of eq1;
val_of eq2;
mk_integer k;
- mkVar id1; mkVar id2 |])]);
+ mkVar id1; mkVar id2 |])];
Proofview.V82.tactic (mk_then tac);
(intros_using [aux]);
Proofview.V82.tactic (resolve_id aux);
@@ -1090,8 +1092,8 @@ let replay_history tactic_normalisation =
in
Tacticals.New.tclTHENS
(Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (unfold sp_Zle);
- Proofview.V82.tactic (simpl_in_concl);
+ unfold sp_Zle;
+ simpl_in_concl;
intro;
(absurd not_sup_sup) ])
[ assumption ; reflexivity ]
@@ -1102,7 +1104,7 @@ let replay_history tactic_normalisation =
mkVar (hyp_of_tag e1.id);
mkVar (hyp_of_tag e2.id) |])
in
- Proofview.tclTHEN (Proofview.V82.tactic (tclTHEN (generalize_tac [theorem]) (mk_then tac))) (solve_le)
+ Proofview.tclTHEN (Proofview.V82.tactic (tclTHEN (Proofview.V82.of_tactic (generalize_tac [theorem])) (mk_then tac))) (solve_le)
| DIVIDE_AND_APPROX (e1,e2,k,d) :: l ->
let id = hyp_of_tag e1.id in
let eq1 = val_of(decompile e1)
@@ -1117,27 +1119,27 @@ let replay_history tactic_normalisation =
[ Tacticals.New.tclTHENS
(Tacticals.New.tclTHENLIST [
(intros_using [aux]);
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_OMEGA1,
[| eq1; rhs; mkVar aux; mkVar id |])]);
- Proofview.V82.tactic (clear [aux;id]);
+ (clear [aux;id]);
(intros_using [id]);
(cut (mk_gt kk dd)) ])
[ Tacticals.New.tclTHENS
(cut (mk_gt kk izero))
[ Tacticals.New.tclTHENLIST [
(intros_using [aux1; aux2]);
- (Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_Zmult_le_approx,
- [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]));
- Proofview.V82.tactic (clear [aux1;aux2;id]);
+ [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]);
+ (clear [aux1;aux2;id]);
(intros_using [id]);
(loop l) ];
Tacticals.New.tclTHENLIST [
- (Proofview.V82.tactic (unfold sp_Zgt));
- (Proofview.V82.tactic simpl_in_concl);
+ (unfold sp_Zgt);
+ simpl_in_concl;
reflexivity ] ];
- Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (unfold sp_Zgt); Proofview.V82.tactic simpl_in_concl; reflexivity ]
+ Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ]
];
Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
@@ -1155,22 +1157,22 @@ let replay_history tactic_normalisation =
[ Tacticals.New.tclTHENS (cut (mk_gt kk dd))
[Tacticals.New.tclTHENLIST [
(intros_using [aux2;aux1]);
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_OMEGA4,
[| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]);
- Proofview.V82.tactic (clear [aux1;aux2]);
- Proofview.V82.tactic (unfold sp_not);
+ (clear [aux1;aux2]);
+ unfold sp_not;
(intros_using [aux]);
Proofview.V82.tactic (resolve_id aux);
Proofview.V82.tactic (mk_then tac);
assumption ] ;
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (unfold sp_Zgt);
- Proofview.V82.tactic simpl_in_concl;
+ unfold sp_Zgt;
+ simpl_in_concl;
reflexivity ] ];
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (unfold sp_Zgt);
- Proofview.V82.tactic simpl_in_concl;
+ unfold sp_Zgt;
+ simpl_in_concl;
reflexivity ] ]
| EXACT_DIVIDE (e1,k) :: l ->
let id = hyp_of_tag e1.id in
@@ -1185,10 +1187,10 @@ let replay_history tactic_normalisation =
(cut state_eq)
[Tacticals.New.tclTHENLIST [
(intros_using [aux1]);
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_OMEGA18,
[| eq1;eq2;kk;mkVar aux1; mkVar id |])]);
- Proofview.V82.tactic (clear [aux1;id]);
+ (clear [aux1;id]);
(intros_using [id]);
(loop l) ];
Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
@@ -1200,15 +1202,15 @@ let replay_history tactic_normalisation =
(cut (mk_gt kk izero))
[Tacticals.New.tclTHENLIST [
(intros_using [aux2;aux1]);
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_OMEGA3,
[| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]);
- Proofview.V82.tactic (clear [aux1;aux2;id]);
+ (clear [aux1;aux2;id]);
(intros_using [id]);
(loop l) ];
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (unfold sp_Zgt);
- Proofview.V82.tactic simpl_in_concl;
+ unfold sp_Zgt;
+ simpl_in_concl;
reflexivity ] ];
Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ]
| (MERGE_EQ(e3,e1,e2)) :: l ->
@@ -1227,9 +1229,9 @@ let replay_history tactic_normalisation =
(cut (mk_eq eq1 (mk_inv eq2)))
[Tacticals.New.tclTHENLIST [
(intros_using [aux]);
- Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
+ (generalize_tac [mkApp (Lazy.force coq_OMEGA8,
[| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]);
- Proofview.V82.tactic (clear [id1;id2;aux]);
+ (clear [id1;id2;aux]);
(intros_using [id]);
(loop l) ];
Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity]
@@ -1261,13 +1263,13 @@ let replay_history tactic_normalisation =
[Tacticals.New.tclTHENLIST [
(intros_using [aux]);
(elim_id aux);
- Proofview.V82.tactic (clear [aux]);
+ (clear [aux]);
(intros_using [vid; aux]);
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_OMEGA9,
[| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]);
Proofview.V82.tactic (mk_then tac);
- Proofview.V82.tactic (clear [aux]);
+ (clear [aux]);
(intros_using [id]);
(loop l) ];
Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ]
@@ -1302,7 +1304,7 @@ let replay_history tactic_normalisation =
if e1.kind == DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in
let tac = shuffle_mult_right p_initial e1.body k2 e2.body in
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]);
Proofview.V82.tactic (mk_then tac);
(intros_using [id]);
@@ -1318,33 +1320,33 @@ let replay_history tactic_normalisation =
(cut (mk_gt kk2 izero))
[Tacticals.New.tclTHENLIST [
(intros_using [aux2;aux1]);
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_OMEGA7, [|
eq1;eq2;kk1;kk2;
mkVar aux1;mkVar aux2;
mkVar id1;mkVar id2 |])]);
- Proofview.V82.tactic (clear [aux1;aux2]);
+ (clear [aux1;aux2]);
Proofview.V82.tactic (mk_then tac);
(intros_using [id]);
(loop l) ];
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (unfold sp_Zgt);
- Proofview.V82.tactic simpl_in_concl;
+ unfold sp_Zgt;
+ simpl_in_concl;
reflexivity ] ];
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (unfold sp_Zgt);
- Proofview.V82.tactic simpl_in_concl;
+ unfold sp_Zgt;
+ simpl_in_concl;
reflexivity ] ]
| CONSTANT_NOT_NUL(e,k) :: l ->
- Tacticals.New.tclTHEN (Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl
+ Tacticals.New.tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl
| CONSTANT_NUL(e) :: l ->
Tacticals.New.tclTHEN (Proofview.V82.tactic (resolve_id (hyp_of_tag e))) reflexivity
| CONSTANT_NEG(e,k) :: l ->
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac [mkVar (hyp_of_tag e)]);
- Proofview.V82.tactic (unfold sp_Zle);
- Proofview.V82.tactic simpl_in_concl;
- Proofview.V82.tactic (unfold sp_not);
+ (generalize_tac [mkVar (hyp_of_tag e)]);
+ unfold sp_Zle;
+ simpl_in_concl;
+ unfold sp_not;
(intros_using [aux]);
Proofview.V82.tactic (resolve_id aux);
reflexivity
@@ -1364,8 +1366,8 @@ let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) =
let (tac,t') = normalize p_initial t in
let shift_left =
tclTHEN
- (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])
- (tclTRY (clear [id]))
+ (Proofview.V82.of_tactic (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]))
+ (tclTRY (Proofview.V82.of_tactic (clear [id])))
in
if not (List.is_empty tac) then
let id' = new_identifier () in
@@ -1410,13 +1412,13 @@ let destructure_omega gl tac_def (id,c) =
let reintroduce id =
(* [id] cannot be cleared if dependent: protect it by a try *)
- Tacticals.New.tclTHEN (Proofview.V82.tactic (tclTRY (clear [id]))) (intro_using id)
+ Tacticals.New.tclTHEN (Tacticals.New.tclTRY (clear [id])) (intro_using id)
open Proofview.Notations
let coq_omega =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
clear_constr_tables ();
let hyps_types = Tacmach.New.pf_hyps_types gl in
let destructure_omega = Tacmach.New.of_old destructure_omega gl in
@@ -1433,7 +1435,7 @@ let coq_omega =
(simplest_elim (applist (Lazy.force coq_intro_Z, [t])));
(intros_using [v; id]);
(elim_id id);
- Proofview.V82.tactic (clear [id]);
+ (clear [id]);
(intros_using [th;id]);
tac ]),
{kind = INEQ;
@@ -1464,12 +1466,12 @@ let coq_omega =
Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path)
with NO_CONTRADICTION -> Tacticals.New.tclZEROMSG (Pp.str"Omega can't solve this system")
end
- end
+ end }
let coq_omega = coq_omega
let nat_inject =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in
let rec explore p t : unit Proofview.tactic =
try match destructurate_term t with
@@ -1544,7 +1546,7 @@ let nat_inject =
begin try match destructurate_prop t with
Kapp(Le,[t1;t2]) ->
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]);
(explore [P_APP 1; P_TYPE] t1);
(explore [P_APP 2; P_TYPE] t2);
@@ -1553,7 +1555,7 @@ let nat_inject =
]
| Kapp(Lt,[t1;t2]) ->
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]);
(explore [P_APP 1; P_TYPE] t1);
(explore [P_APP 2; P_TYPE] t2);
@@ -1562,7 +1564,7 @@ let nat_inject =
]
| Kapp(Ge,[t1;t2]) ->
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]);
(explore [P_APP 1; P_TYPE] t1);
(explore [P_APP 2; P_TYPE] t2);
@@ -1571,7 +1573,7 @@ let nat_inject =
]
| Kapp(Gt,[t1;t2]) ->
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]);
(explore [P_APP 1; P_TYPE] t1);
(explore [P_APP 2; P_TYPE] t2);
@@ -1580,7 +1582,7 @@ let nat_inject =
]
| Kapp(Neq,[t1;t2]) ->
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]);
(explore [P_APP 1; P_TYPE] t1);
(explore [P_APP 2; P_TYPE] t2);
@@ -1590,7 +1592,7 @@ let nat_inject =
| Kapp(Eq,[typ;t1;t2]) ->
if is_conv typ (Lazy.force coq_nat) then
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]);
(explore [P_APP 2; P_TYPE] t1);
(explore [P_APP 3; P_TYPE] t2);
@@ -1603,7 +1605,7 @@ let nat_inject =
in
let hyps_types = Tacmach.New.pf_hyps_types gl in
loop (List.rev hyps_types)
- end
+ end }
let dec_binop = function
| Zne -> coq_dec_Zne
@@ -1672,47 +1674,48 @@ let onClearedName id tac =
(* We cannot ensure that hyps can be cleared (because of dependencies), *)
(* so renaming may be necessary *)
Tacticals.New.tclTHEN
- (Proofview.V82.tactic (tclTRY (clear [id])))
- (Proofview.Goal.nf_enter begin fun gl ->
+ (Tacticals.New.tclTRY (clear [id]))
+ (Proofview.Goal.nf_enter { enter = begin fun gl ->
let id = Tacmach.New.of_old (fresh_id [] id) gl in
Tacticals.New.tclTHEN (introduction id) (tac id)
- end)
+ end })
let onClearedName2 id tac =
Tacticals.New.tclTHEN
- (Proofview.V82.tactic (tclTRY (clear [id])))
- (Proofview.Goal.nf_enter begin fun gl ->
+ (Tacticals.New.tclTRY (clear [id]))
+ (Proofview.Goal.nf_enter { enter = begin fun gl ->
let id1 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_left")) gl in
let id2 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_right")) gl in
Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ]
- end)
+ end })
let destructure_hyps =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let type_of = Tacmach.New.pf_unsafe_type_of gl in
let decidability = Tacmach.New.of_old decidability gl in
let pf_nf = Tacmach.New.of_old pf_nf gl in
let rec loop = function
| [] -> (Tacticals.New.tclTHEN nat_inject coq_omega)
- | (i,body,t)::lit ->
+ | decl::lit ->
+ let (i,_,t) = to_tuple decl in
begin try match destructurate_prop t with
| Kapp(False,[]) -> elim_id i
| Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit
| Kapp(Or,[t1;t2]) ->
(Tacticals.New.tclTHENS
(elim_id i)
- [ onClearedName i (fun i -> (loop ((i,None,t1)::lit)));
- onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ])
+ [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit)));
+ onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ])
| Kapp(And,[t1;t2]) ->
Tacticals.New.tclTHEN
(elim_id i)
(onClearedName2 i (fun i1 i2 ->
- loop ((i1,None,t1)::(i2,None,t2)::lit)))
+ loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit)))
| Kapp(Iff,[t1;t2]) ->
Tacticals.New.tclTHEN
(elim_id i)
(onClearedName2 i (fun i1 i2 ->
- loop ((i1,None,mkArrow t1 t2)::(i2,None,mkArrow t2 t1)::lit)))
+ loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,mkArrow t2 t1) :: lit)))
| Kimp(t1,t2) ->
(* t1 and t2 might be in Type rather than Prop.
For t1, the decidability check will ensure being Prop. *)
@@ -1720,10 +1723,10 @@ let destructure_hyps =
then
let d1 = decidability t1 in
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac [mkApp (Lazy.force coq_imp_simp,
+ (generalize_tac [mkApp (Lazy.force coq_imp_simp,
[| t1; t2; d1; mkVar i|])]);
(onClearedName i (fun i ->
- (loop ((i,None,mk_or (mk_not t1) t2)::lit))))
+ (loop (LocalAssum (i,mk_or (mk_not t1) t2) :: lit))))
]
else
loop lit
@@ -1731,55 +1734,54 @@ let destructure_hyps =
begin match destructurate_prop t with
Kapp(Or,[t1;t2]) ->
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]);
(onClearedName i (fun i ->
- (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit))))
+ (loop (LocalAssum (i,mk_and (mk_not t1) (mk_not t2)) :: lit))))
]
| Kapp(And,[t1;t2]) ->
let d1 = decidability t1 in
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_not_and,
[| t1; t2; d1; mkVar i |])]);
(onClearedName i (fun i ->
- (loop ((i,None,mk_or (mk_not t1) (mk_not t2))::lit))))
+ (loop (LocalAssum (i,mk_or (mk_not t1) (mk_not t2)) :: lit))))
]
| Kapp(Iff,[t1;t2]) ->
let d1 = decidability t1 in
let d2 = decidability t2 in
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_not_iff,
[| t1; t2; d1; d2; mkVar i |])]);
(onClearedName i (fun i ->
- (loop ((i,None,
- mk_or (mk_and t1 (mk_not t2))
- (mk_and (mk_not t1) t2))::lit))))
+ (loop (LocalAssum (i, mk_or (mk_and t1 (mk_not t2))
+ (mk_and (mk_not t1) t2)) :: lit))))
]
| Kimp(t1,t2) ->
(* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok.
For t1, being decidable implies being Prop. *)
let d1 = decidability t1 in
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_not_imp,
[| t1; t2; d1; mkVar i |])]);
(onClearedName i (fun i ->
- (loop ((i,None,mk_and t1 (mk_not t2)) :: lit))))
+ (loop (LocalAssum (i,mk_and t1 (mk_not t2)) :: lit))))
]
| Kapp(Not,[t]) ->
let d = decidability t in
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]);
- (onClearedName i (fun i -> (loop ((i,None,t)::lit))))
+ (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit))))
]
| Kapp(op,[t1;t2]) ->
(try
let thm = not_binop op in
Tacticals.New.tclTHENLIST [
- Proofview.V82.tactic (generalize_tac
+ (generalize_tac
[mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]);
(onClearedName i (fun _ -> loop lit))
]
@@ -1806,15 +1808,13 @@ let destructure_hyps =
match destructurate_type (pf_nf typ) with
| Kapp(Nat,_) ->
(Tacticals.New.tclTHEN
- (convert_hyp_no_check
- (i,body,
- (mkApp (Lazy.force coq_neq, [| t1;t2|]))))
+ (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_neq, [| t1;t2|]))
+ decl))
(loop lit))
| Kapp(Z,_) ->
(Tacticals.New.tclTHEN
- (convert_hyp_no_check
- (i,body,
- (mkApp (Lazy.force coq_Zne, [| t1;t2|]))))
+ (convert_hyp_no_check (set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|]))
+ decl))
(loop lit))
| _ -> loop lit
end
@@ -1828,17 +1828,17 @@ let destructure_hyps =
in
let hyps = Proofview.Goal.hyps gl in
loop hyps
- end
+ end }
let destructure_goal =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let concl = Proofview.Goal.concl gl in
let decidability = Tacmach.New.of_old decidability gl in
let rec loop t =
match destructurate_prop t with
| Kapp(Not,[t]) ->
(Tacticals.New.tclTHEN
- (Tacticals.New.tclTHEN (Proofview.V82.tactic (unfold sp_not)) intro)
+ (Tacticals.New.tclTHEN (unfold sp_not) intro)
destructure_hyps)
| Kimp(a,b) -> (Tacticals.New.tclTHEN intro (loop b))
| Kapp(False,[]) -> destructure_hyps
@@ -1847,7 +1847,7 @@ let destructure_goal =
try
let dec = decidability t in
Tacticals.New.tclTHEN
- (Proofview.V82.tactic (Tactics.refine
+ (Proofview.V82.tactic (Tacmach.refine
(mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))))
intro
with Undecidable -> Tactics.elim_type (build_coq_False ())
@@ -1855,7 +1855,7 @@ let destructure_goal =
Tacticals.New.tclTHEN goal_tac destructure_hyps
in
(loop concl)
- end
+ end }
let destructure_goal = destructure_goal
diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4
index c96b4a4f..5647fbf9 100644
--- a/plugins/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -17,16 +17,24 @@
DECLARE PLUGIN "omega_plugin"
+open Names
open Coq_omega
+open Constrarg
+
+let eval_tactic name =
+ let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in
+ let kn = KerName.make2 (MPfile dp) (Label.make name) in
+ let tac = Tacenv.interp_ltac kn in
+ Tacinterp.eval_tactic tac
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 -> Errors.error ("No Omega knowledge base for type "^s))
+ | "nat" -> eval_tactic "zify_nat"
+ | "positive" -> eval_tactic "zify_positive"
+ | "N" -> eval_tactic "zify_N"
+ | "Z" -> eval_tactic "zify_op"
+ | s -> CErrors.error ("No Omega knowledge base for type "^s))
(Util.List.sort_uniquize String.compare l)
in
Tacticals.New.tclTHEN
diff --git a/plugins/omega/omega_plugin.mllib b/plugins/omega/omega_plugin.mlpack
index 2b387fdc..df7f1047 100644
--- a/plugins/omega/omega_plugin.mllib
+++ b/plugins/omega/omega_plugin.mlpack
@@ -1,4 +1,3 @@
Omega
Coq_omega
G_omega
-Omega_plugin_mod
diff --git a/plugins/plugins.itarget b/plugins/plugins.itarget
deleted file mode 100644
index 56aa42b0..00000000
--- a/plugins/plugins.itarget
+++ /dev/null
@@ -1,3 +0,0 @@
-pluginsopt.otarget
-pluginsbyte.otarget
-pluginsvo.otarget \ No newline at end of file
diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget
deleted file mode 100644
index d8752f8b..00000000
--- a/plugins/pluginsbyte.itarget
+++ /dev/null
@@ -1,21 +0,0 @@
-btauto/btauto_plugin.cma
-setoid_ring/newring_plugin.cma
-extraction/extraction_plugin.cma
-decl_mode/decl_mode_plugin.cma
-firstorder/ground_plugin.cma
-rtauto/rtauto_plugin.cma
-fourier/fourier_plugin.cma
-romega/romega_plugin.cma
-omega/omega_plugin.cma
-micromega/micromega_plugin.cma
-cc/cc_plugin.cma
-nsatz/nsatz_plugin.cma
-funind/recdef_plugin.cma
-syntax/ascii_syntax_plugin.cma
-syntax/nat_syntax_plugin.cma
-syntax/numbers_syntax_plugin.cma
-syntax/r_syntax_plugin.cma
-syntax/string_syntax_plugin.cma
-syntax/z_syntax_plugin.cma
-quote/quote_plugin.cma
-derive/derive_plugin.cma \ No newline at end of file
diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget
deleted file mode 100644
index 220e5182..00000000
--- a/plugins/pluginsdyn.itarget
+++ /dev/null
@@ -1,24 +0,0 @@
-btauto/btauto_plugin.cmxs
-field/field_plugin.cmxs
-setoid_ring/newring_plugin.cmxs
-extraction/extraction_plugin.cmxs
-decl_mode/decl_mode_plugin.cmxs
-firstorder/ground_plugin.cmxs
-rtauto/rtauto_plugin.cmxs
-fourier/fourier_plugin.cmxs
-romega/romega_plugin.cmxs
-omega/omega_plugin.cmxs
-micromega/micromega_plugin.cmxs
-subtac/subtac_plugin.cmxs
-ring/ring_plugin.cmxs
-cc/cc_plugin.cmxs
-nsatz/nsatz_plugin.cmxs
-funind/recdef_plugin.cmxs
-syntax/ascii_syntax_plugin.cmxs
-syntax/nat_syntax_plugin.cmxs
-syntax/numbers_syntax_plugin.cmxs
-syntax/r_syntax_plugin.cmxs
-syntax/string_syntax_plugin.cmxs
-syntax/z_syntax_plugin.cmxs
-quote/quote_plugin.cmxs
-derive/derive_plugin.cmxs
diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget
deleted file mode 100644
index 04a1e711..00000000
--- a/plugins/pluginsopt.itarget
+++ /dev/null
@@ -1,21 +0,0 @@
-btauto/btauto_plugin.cmxa
-setoid_ring/newring_plugin.cmxa
-extraction/extraction_plugin.cmxa
-decl_mode/decl_mode_plugin.cmxa
-firstorder/ground_plugin.cmxa
-rtauto/rtauto_plugin.cmxa
-fourier/fourier_plugin.cmxa
-romega/romega_plugin.cmxa
-omega/omega_plugin.cmxa
-micromega/micromega_plugin.cmxa
-cc/cc_plugin.cmxa
-nsatz/nsatz_plugin.cmxa
-funind/recdef_plugin.cmxa
-syntax/ascii_syntax_plugin.cmxa
-syntax/nat_syntax_plugin.cmxa
-syntax/numbers_syntax_plugin.cmxa
-syntax/r_syntax_plugin.cmxa
-syntax/string_syntax_plugin.cmxa
-syntax/z_syntax_plugin.cmxa
-quote/quote_plugin.cmxa
-derive/derive_plugin.cmxa
diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget
deleted file mode 100644
index a59bf29c..00000000
--- a/plugins/pluginsvo.itarget
+++ /dev/null
@@ -1,12 +0,0 @@
-btauto/vo.otarget
-fourier/vo.otarget
-funind/vo.otarget
-nsatz/vo.otarget
-micromega/vo.otarget
-omega/vo.otarget
-quote/vo.otarget
-romega/vo.otarget
-rtauto/vo.otarget
-setoid_ring/vo.otarget
-extraction/vo.otarget
-derive/vo.otarget \ No newline at end of file
diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4
index fdc5c2bb..fd87d5b7 100644
--- a/plugins/quote/g_quote.ml4
+++ b/plugins/quote/g_quote.ml4
@@ -13,19 +13,19 @@ open Misctypes
open Tacexpr
open Geninterp
open Quote
+open Constrarg
DECLARE PLUGIN "quote_plugin"
let loc = Loc.ghost
-let cont = (loc, Id.of_string "cont")
-let x = (loc, Id.of_string "x")
+let cont = Id.of_string "cont"
+let x = Id.of_string "x"
-let make_cont (k : glob_tactic_expr) (c : Constr.t) =
+let make_cont (k : Val.t) (c : Constr.t) =
let c = Tacinterp.Value.of_constr c in
- let tac = TacCall (loc, ArgVar cont, [Reference (ArgVar x)]) in
- let tac = TacLetIn (false, [(cont, Tacexp k)], TacArg (loc, tac)) in
- let ist = { lfun = Id.Map.singleton (snd x) c; extra = TacStore.empty; } in
- Tacinterp.eval_tactic_ist ist tac
+ let tac = TacCall (loc, ArgVar (loc, cont), [Reference (ArgVar (loc, x))]) in
+ let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in
+ Tacinterp.eval_tactic_ist ist (TacArg (loc, tac))
TACTIC EXTEND quote
[ "quote" ident(f) ] -> [ quote f [] ]
diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml
index ff6acf13..b3ea4335 100644
--- a/plugins/quote/quote.ml
+++ b/plugins/quote/quote.ml
@@ -101,7 +101,7 @@
(*i*)
-open Errors
+open CErrors
open Util
open Names
open Term
@@ -109,6 +109,7 @@ open Pattern
open Patternops
open Constr_matching
open Tacmach
+open Proofview.Notations
(*i*)
(*s First, we need to access some Coq constants
@@ -227,7 +228,7 @@ let compute_ivs f cs gl =
let (args3, body3) = decompose_lam body2 in
let nargs3 = List.length args3 in
let env = Proofview.Goal.env gl in
- let sigma = Proofview.Goal.sigma gl in
+ let sigma = Tacmach.New.project gl in
let is_conv = Reductionops.is_conv env sigma in
begin match decomp_term body3 with
| Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *)
@@ -446,7 +447,7 @@ let quote_terms ivs lc =
yet. *)
let quote f lid =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let f = Tacmach.New.pf_global f gl in
let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
let ivs = compute_ivs f cl gl in
@@ -459,10 +460,10 @@ let quote f lid =
match ivs.variable_lhs with
| None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast
| Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast
- end
+ end }
let gen_quote cont c f lid =
- Proofview.Goal.nf_enter begin fun gl ->
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
let f = Tacmach.New.pf_global f gl in
let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in
let ivs = compute_ivs f cl gl in
@@ -474,7 +475,7 @@ let gen_quote cont c f lid =
match ivs.variable_lhs with
| None -> cont (mkApp (f, [| p |]))
| Some _ -> cont (mkApp (f, [| vm; p |]))
- end
+ end }
(*i
diff --git a/plugins/quote/quote_plugin.mllib b/plugins/quote/quote_plugin.mllib
deleted file mode 100644
index d1b3ccbe..00000000
--- a/plugins/quote/quote_plugin.mllib
+++ /dev/null
@@ -1,3 +0,0 @@
-Quote
-G_quote
-Quote_plugin_mod
diff --git a/plugins/quote/quote_plugin.mlpack b/plugins/quote/quote_plugin.mlpack
new file mode 100644
index 00000000..2e9be09d
--- /dev/null
+++ b/plugins/quote/quote_plugin.mlpack
@@ -0,0 +1,2 @@
+Quote
+G_quote
diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v
index b84cf254..187601fc 100644
--- a/plugins/romega/ReflOmegaCore.v
+++ b/plugins/romega/ReflOmegaCore.v
@@ -1074,16 +1074,19 @@ Qed.
avait utilisé le test précédent et fait une elimination dessus. *)
Ltac elim_eq_term t1 t2 :=
+ let Aux := fresh "Aux" in
pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux;
[ generalize (eq_term_true t1 t2 Aux); clear Aux
| generalize (eq_term_false t1 t2 Aux); clear Aux ].
Ltac elim_beq t1 t2 :=
+ let Aux := fresh "Aux" in
pattern (beq t1 t2); apply bool_eq_ind; intro Aux;
[ generalize (beq_true t1 t2 Aux); clear Aux
| generalize (beq_false t1 t2 Aux); clear Aux ].
Ltac elim_bgt t1 t2 :=
+ let Aux := fresh "Aux" in
pattern (bgt t1 t2); apply bool_eq_ind; intro Aux;
[ generalize (bgt_true t1 t2 Aux); clear Aux
| generalize (bgt_false t1 t2 Aux); clear Aux ].
@@ -1448,27 +1451,27 @@ Ltac loop t :=
| (Tint ?X1) => loop X1
(* Eliminations *)
| match ?X1 with
- | EqTerm x x0 => _
- | LeqTerm x x0 => _
+ | EqTerm _ _ => _
+ | LeqTerm _ _ => _
| TrueTerm => _
| FalseTerm => _
- | Tnot x => _
- | GeqTerm x x0 => _
- | GtTerm x x0 => _
- | LtTerm x x0 => _
- | NeqTerm x x0 => _
- | Tor x x0 => _
- | Tand x x0 => _
- | Timp x x0 => _
- | Tprop x => _
+ | Tnot _ => _
+ | GeqTerm _ _ => _
+ | GtTerm _ _ => _
+ | LtTerm _ _ => _
+ | NeqTerm _ _ => _
+ | Tor _ _ => _
+ | Tand _ _ => _
+ | Timp _ _ => _
+ | Tprop _ => _
end => destruct X1; auto; Simplify
| match ?X1 with
- | Tint x => _
- | (x + x0)%term => _
- | (x * x0)%term => _
- | (x - x0)%term => _
- | (- x)%term => _
- | [x]%term => _
+ | Tint _ => _
+ | (_ + _)%term => _
+ | (_ * _)%term => _
+ | (_ - _)%term => _
+ | (- _)%term => _
+ | [_]%term => _
end => destruct X1; auto; Simplify
| (if beq ?X1 ?X2 then _ else _) =>
let H := fresh "H" in
@@ -1492,7 +1495,7 @@ with Simplify := match goal with
end.
Ltac prove_stable x th :=
- match constr:x with
+ match constr:(x) with
| ?X1 =>
unfold term_stable, X1; intros; Simplify; simpl;
apply th
diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml
index 21b0f78b..4935fe4b 100644
--- a/plugins/romega/const_omega.ml
+++ b/plugins/romega/const_omega.ml
@@ -39,7 +39,7 @@ let destructurate t =
| Term.Var id,[] -> Kvar(Names.Id.to_string id)
| Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body)
| Term.Prod (Names.Name _,_,_),[] ->
- Errors.error "Omega: Not a quantifier-free goal"
+ CErrors.error "Omega: Not a quantifier-free goal"
| _ -> Kufo
exception Destruct
@@ -346,7 +346,7 @@ let parse_term t =
| Kapp("Z.succ",[t]) -> Tsucc t
| Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one))
| Kapp(("Zpos"|"Zneg"|"Z0"),_) ->
- (try Tnum (recognize t) with e when Errors.noncritical e -> Tother)
+ (try Tnum (recognize t) with e when CErrors.noncritical e -> Tother)
| _ -> Tother
with e when Logic.catchable_exception e -> Tother
@@ -368,6 +368,6 @@ let is_scalar t =
| Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t
| Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true
| _ -> false in
- try aux t with e when Errors.noncritical e -> false
+ try aux t with e when CErrors.noncritical e -> false
end
diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4
index 0a99a26b..830dc54d 100644
--- a/plugins/romega/g_romega.ml4
+++ b/plugins/romega/g_romega.ml4
@@ -10,16 +10,24 @@
DECLARE PLUGIN "romega_plugin"
+open Names
open Refl_omega
+open Constrarg
+
+let eval_tactic name =
+ let dp = DirPath.make (List.map Id.of_string ["PreOmega"; "omega"; "Coq"]) in
+ let kn = KerName.make2 (MPfile dp) (Label.make name) in
+ let tac = Tacenv.interp_ltac kn in
+ Tacinterp.eval_tactic tac
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 -> Errors.error ("No ROmega knowledge base for type "^s))
+ | "nat" -> eval_tactic "zify_nat"
+ | "positive" -> eval_tactic "zify_positive"
+ | "N" -> eval_tactic "zify_N"
+ | "Z" -> eval_tactic "zify_op"
+ | s -> CErrors.error ("No ROmega knowledge base for type "^s))
(Util.List.sort_uniquize String.compare l)
in
Tacticals.New.tclTHEN
diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml
index 560e6a89..ba882e39 100644
--- a/plugins/romega/refl_omega.ml
+++ b/plugins/romega/refl_omega.ml
@@ -9,7 +9,7 @@
open Pp
open Util
open Const_omega
-module OmegaSolver = Omega.MakeOmegaSolver (Bigint)
+module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint)
open OmegaSolver
(* \section{Useful functions and flags} *)
@@ -172,7 +172,7 @@ let print_env_reification env =
in
let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in
let term_info = str "ENVIRONMENT OF TERMS :" ++ fnl () ++ loop 'V' 0 env.terms in
- msg_debug (prop_info ++ fnl () ++ term_info)
+ Feedback.msg_debug (prop_info ++ fnl () ++ term_info)
(* \subsection{Gestion des environnements de variable pour Omega} *)
(* generation d'identifiant d'equation pour Omega *)
@@ -454,7 +454,7 @@ let rec scalar n = function
| Omult(t1,Oint x) ->
do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x))
| Omult(t1,t2) ->
- Errors.error "Omega: Can't solve a goal with non-linear products"
+ CErrors.error "Omega: Can't solve a goal with non-linear products"
| (Oatom _ as t) -> do_list [], Omult(t,Oint n)
| Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i)
| (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n))
@@ -473,7 +473,7 @@ let rec negate = function
| Omult(t1,Oint x) ->
do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x))
| Omult(t1,t2) ->
- Errors.error "Omega: Can't solve a goal with non-linear products"
+ CErrors.error "Omega: Can't solve a goal with non-linear products"
| (Oatom _ as t) ->
do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone))
| Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i)
@@ -545,7 +545,7 @@ let shrink_pair f1 f2 =
Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2))
| t1,t2 ->
oprint stdout t1; print_newline (); oprint stdout t2; print_newline ();
- flush Pervasives.stdout; Errors.error "shrink.1"
+ flush Pervasives.stdout; CErrors.error "shrink.1"
end
(* \subsection{Calcul d'une sous formule constante} *)
@@ -559,9 +559,9 @@ let reduce_factor = function
let rec compute = function
Oint n -> n
| Oplus(t1,t2) -> compute t1 + compute t2
- | _ -> Errors.error "condense.1" in
+ | _ -> CErrors.error "condense.1" in
[Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c))
- | t -> Errors.error "reduce_factor.1"
+ | t -> CErrors.error "reduce_factor.1"
(* \subsection{Réordonnancement} *)
@@ -1280,12 +1280,12 @@ let resolution env full_reified_goal systems_list =
CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in
let decompose_tactic = decompose_tree env context solution_tree in
- Tactics.generalize
- (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >>
+ Proofview.V82.of_tactic (Tactics.generalize
+ (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps))) >>
Proofview.V82.of_tactic (Tactics.change_concl reified) >>
Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >>
show_goal >>
- Tactics.normalise_vm_in_concl >>
+ Proofview.V82.of_tactic (Tactics.normalise_vm_in_concl) >>
(*i Alternatives to the previous line:
- Normalisation without VM:
Tactics.normalise_in_concl
@@ -1304,7 +1304,7 @@ let total_reflexive_omega_tactic gl =
let systems_list = destructurate_hyps full_reified_goal in
if !debug then display_systems systems_list;
resolution env full_reified_goal systems_list gl
- with NO_CONTRADICTION -> Errors.error "ROmega can't solve this system"
+ with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system"
(*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*)
diff --git a/plugins/romega/romega_plugin.mllib b/plugins/romega/romega_plugin.mlpack
index 1625009d..38d0e941 100644
--- a/plugins/romega/romega_plugin.mllib
+++ b/plugins/romega/romega_plugin.mlpack
@@ -1,4 +1,3 @@
Const_omega
Refl_omega
G_romega
-Romega_plugin_mod
diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v
index 7394cebd..36460187 100644
--- a/plugins/rtauto/Bintree.v
+++ b/plugins/rtauto/Bintree.v
@@ -266,7 +266,7 @@ Qed.
Lemma push_not_empty: forall a S, (push a S) <> empty.
intros a [ind cont];unfold push,empty.
-simpl;intro H;injection H; intros _ ; apply Pos.succ_not_1.
+intros [= H%Pos.succ_not_1]. assumption.
Qed.
Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop :=
diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml
index 3ba92b9f..8b926111 100644
--- a/plugins/rtauto/proof_search.ml
+++ b/plugins/rtauto/proof_search.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-open Errors
+open CErrors
open Util
open Goptions
@@ -547,7 +547,7 @@ let pp_info () =
int s_info.created_branches ++ str " created" ++ fnl () ++
str "Hypotheses : " ++
int s_info.created_hyps ++ str " created" ++ fnl () in
- msg_info
+ Feedback.msg_info
( str "Proof-search statistics :" ++ fnl () ++
count_info ++
str "Branch ends: " ++
diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml
index 9c22b5ad..4ed90795 100644
--- a/plugins/rtauto/refl_tauto.ml
+++ b/plugins/rtauto/refl_tauto.ml
@@ -8,11 +8,12 @@
module Search = Explore.Make(Proof_search)
-open Errors
+open CErrors
open Util
open Term
open Tacmach
open Proof_search
+open Context.Named.Declaration
let force count lazc = incr count;Lazy.force lazc
@@ -66,12 +67,12 @@ let l_D_Or = lazy (constant "D_Or")
let special_whd gl=
- let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in
- (fun t -> Closure.whd_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in
+ (fun t -> CClosure.whd_val infos (CClosure.inject t))
let special_nf gl=
- let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in
- (fun t -> Closure.norm_val infos (Closure.inject t))
+ let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in
+ (fun t -> CClosure.norm_val infos (CClosure.inject t))
type atom_env=
{mutable next:int;
@@ -128,9 +129,9 @@ let rec make_form atom_env gls term =
let rec make_hyps atom_env gls lenv = function
[] -> []
- | (_,Some body,typ)::rest ->
+ | LocalDef (_,body,typ)::rest ->
make_hyps atom_env gls (typ::body::lenv) rest
- | (id,None,typ)::rest ->
+ | LocalAssum (id,typ)::rest ->
let hrec=
make_hyps atom_env gls (typ::lenv) rest in
if List.exists (Termops.dependent (mkVar id)) lenv ||
@@ -275,7 +276,7 @@ let rtauto_tac gls=
begin
reset_info ();
if !verbose then
- msg_info (str "Starting proof-search ...");
+ Feedback.msg_info (str "Starting proof-search ...");
end in
let search_start_time = System.get_time () in
let prf =
@@ -285,10 +286,10 @@ let rtauto_tac gls=
let search_end_time = System.get_time () in
let _ = if !verbose then
begin
- msg_info (str "Proof tree found in " ++
+ Feedback.msg_info (str "Proof tree found in " ++
System.fmt_time_difference search_start_time search_end_time);
pp_info ();
- msg_info (str "Building proof term ... ")
+ Feedback.msg_info (str "Building proof term ... ")
end in
let build_start_time=System.get_time () in
let _ = step_count := 0; node_count := 0 in
@@ -301,7 +302,7 @@ let rtauto_tac gls=
let build_end_time=System.get_time () in
let _ = if !verbose then
begin
- msg_info (str "Proof term built in " ++
+ Feedback.msg_info (str "Proof term built in " ++
System.fmt_time_difference build_start_time build_end_time ++
fnl () ++
str "Proof size : " ++ int !step_count ++
@@ -315,12 +316,12 @@ let rtauto_tac gls=
if !check then
Proofview.V82.of_tactic (Tactics.exact_check term) gls
else
- Tactics.exact_no_check term gls in
+ Proofview.V82.of_tactic (Tactics.exact_no_check term) gls in
let tac_end_time = System.get_time () in
let _ =
- if !check then msg_info (str "Proof term type-checking is on");
+ if !check then Feedback.msg_info (str "Proof term type-checking is on");
if !verbose then
- msg_info (str "Internal tactic executed in " ++
+ Feedback.msg_info (str "Internal tactic executed in " ++
System.fmt_time_difference tac_start_time tac_end_time) in
result
diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli
index c9e591bb..9a14ac6c 100644
--- a/plugins/rtauto/refl_tauto.mli
+++ b/plugins/rtauto/refl_tauto.mli
@@ -18,7 +18,7 @@ val make_hyps :
atom_env ->
Proof_type.goal Tacmach.sigma ->
Term.types list ->
- (Names.Id.t * Term.types option * Term.types) list ->
+ Context.Named.t ->
(Names.Id.t * Proof_search.form) list
val rtauto_tac : Proof_type.tactic
diff --git a/plugins/rtauto/rtauto_plugin.mllib b/plugins/rtauto/rtauto_plugin.mlpack
index 0e346044..61c5e945 100644
--- a/plugins/rtauto/rtauto_plugin.mllib
+++ b/plugins/rtauto/rtauto_plugin.mlpack
@@ -1,4 +1,3 @@
Proof_search
Refl_tauto
G_rtauto
-Rtauto_plugin_mod
diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v
index 04decbce..5f5b9792 100644
--- a/plugins/setoid_ring/ArithRing.v
+++ b/plugins/setoid_ring/ArithRing.v
@@ -32,13 +32,13 @@ Qed.
Ltac natcst t :=
match isnatcst t with
true => constr:(N.of_nat t)
- | _ => constr:InitialRing.NotConstant
+ | _ => constr:(InitialRing.NotConstant)
end.
Ltac Ss_to_add f acc :=
match f with
| S ?f1 => Ss_to_add f1 (S acc)
- | _ => constr:(acc + f)%nat
+ | _ => constr:((acc + f)%nat)
end.
Ltac natprering :=
diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v
index 8362c8c2..9c690e2b 100644
--- a/plugins/setoid_ring/InitialRing.v
+++ b/plugins/setoid_ring/InitialRing.v
@@ -96,7 +96,7 @@ Section ZMORPHISM.
Proof.
constructor.
destruct c;intros;try discriminate.
- injection H;clear H;intros H1;subst c'.
+ injection H as <-.
simpl. unfold Zeq_bool. rewrite Z.compare_refl. trivial.
Qed.
@@ -612,32 +612,32 @@ End GEN_DIV.
Ltac inv_gen_phi_pos rI add mul t :=
let rec inv_cst t :=
match t with
- rI => constr:1%positive
- | (add rI rI) => constr:2%positive
- | (add rI (add rI rI)) => constr:3%positive
+ rI => constr:(1%positive)
+ | (add rI rI) => constr:(2%positive)
+ | (add rI (add rI rI)) => constr:(3%positive)
| (mul (add rI rI) ?p) => (* 2p *)
match inv_cst p with
- NotConstant => constr:NotConstant
- | 1%positive => constr:NotConstant (* 2*1 is not convertible to 2 *)
+ NotConstant => constr:(NotConstant)
+ | 1%positive => constr:(NotConstant) (* 2*1 is not convertible to 2 *)
| ?p => constr:(xO p)
end
| (add rI (mul (add rI rI) ?p)) => (* 1+2p *)
match inv_cst p with
- NotConstant => constr:NotConstant
- | 1%positive => constr:NotConstant
+ NotConstant => constr:(NotConstant)
+ | 1%positive => constr:(NotConstant)
| ?p => constr:(xI p)
end
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end in
inv_cst t.
(* The (partial) inverse of gen_phiNword *)
Ltac inv_gen_phiNword rO rI add mul opp t :=
match t with
- rO => constr:NwO
+ rO => constr:(NwO)
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Npos p::nil)
end
end.
@@ -646,10 +646,10 @@ End GEN_DIV.
(* The inverse of gen_phiN *)
Ltac inv_gen_phiN rO rI add mul t :=
match t with
- rO => constr:0%N
+ rO => constr:(0%N)
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Npos p)
end
end.
@@ -657,15 +657,15 @@ End GEN_DIV.
(* The inverse of gen_phiZ *)
Ltac inv_gen_phiZ rO rI add mul opp t :=
match t with
- rO => constr:0%Z
+ rO => constr:(0%Z)
| (opp ?p) =>
match inv_gen_phi_pos rI add mul p with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Zneg p)
end
| _ =>
match inv_gen_phi_pos rI add mul t with
- NotConstant => constr:NotConstant
+ NotConstant => constr:(NotConstant)
| ?p => constr:(Zpos p)
end
end.
@@ -681,7 +681,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
@@ -825,31 +825,31 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk :=
(* Tactic for constant *)
Ltac isnatcst t :=
match t with
- O => constr:true
+ O => constr:(true)
| S ?p => isnatcst p
- | _ => constr:false
+ | _ => constr:(false)
end.
Ltac isPcst t :=
match t with
| xI ?p => isPcst p
| xO ?p => isPcst p
- | xH => constr:true
+ | xH => constr:(true)
(* nat -> positive *)
| Pos.of_succ_nat ?n => isnatcst n
- | _ => constr:false
+ | _ => constr:(false)
end.
Ltac isNcst t :=
match t with
- N0 => constr:true
+ N0 => constr:(true)
| Npos ?p => isPcst p
- | _ => constr:false
+ | _ => constr:(false)
end.
Ltac isZcst t :=
match t with
- Z0 => constr:true
+ Z0 => constr:(true)
| Zpos ?p => isPcst p
| Zneg ?p => isPcst p
(* injection nat -> Z *)
@@ -857,7 +857,7 @@ Ltac isZcst t :=
(* injection N -> Z *)
| Z.of_N ?n => isNcst n
(* *)
- | _ => constr:false
+ | _ => constr:(false)
end.
diff --git a/plugins/setoid_ring/NArithRing.v b/plugins/setoid_ring/NArithRing.v
index 6c1a79e4..54e2789b 100644
--- a/plugins/setoid_ring/NArithRing.v
+++ b/plugins/setoid_ring/NArithRing.v
@@ -15,7 +15,7 @@ Set Implicit Arguments.
Ltac Ncst t :=
match isNcst t with
true => t
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end.
Add Ring Nr : Nth (decidable Neqb_ok, constants [Ncst]).
diff --git a/plugins/setoid_ring/Ncring_initial.v b/plugins/setoid_ring/Ncring_initial.v
index 96885d2f..20022c00 100644
--- a/plugins/setoid_ring/Ncring_initial.v
+++ b/plugins/setoid_ring/Ncring_initial.v
@@ -18,7 +18,6 @@ Require Import BinInt.
Require Import Setoid.
Require Export Ncring.
Require Export Ncring_polynom.
-Import List.
Set Implicit Arguments.
@@ -78,7 +77,8 @@ Context {R:Type}`{Ring R}.
| Z0 => 0
| Zneg p => -(gen_phiPOS p)
end.
- Notation "[ x ]" := (gen_phiZ x).
+ Local Notation "[ x ]" := (gen_phiZ x) : ZMORPHISM.
+ Local Open Scope ZMORPHISM.
Definition get_signZ z :=
match z with
diff --git a/plugins/setoid_ring/Ring.v b/plugins/setoid_ring/Ring.v
index a0844100..77576cb9 100644
--- a/plugins/setoid_ring/Ring.v
+++ b/plugins/setoid_ring/Ring.v
@@ -36,9 +36,9 @@ Qed.
Ltac bool_cst t :=
let t := eval hnf in t in
match t with
- true => constr:true
- | false => constr:false
- | _ => constr:NotConstant
+ true => constr:(true)
+ | false => constr:(false)
+ | _ => constr:(NotConstant)
end.
Add Ring bool_ring : BoolTheory (decidable bool_eq_ok, constants [bool_cst]).
diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v
index 760ad4da..b6919667 100644
--- a/plugins/setoid_ring/Ring_polynom.v
+++ b/plugins/setoid_ring/Ring_polynom.v
@@ -883,7 +883,7 @@ Section MakeRingPol.
revert P1. induction LM1 as [|(M2,P2') LM2 IH]; simpl; intros.
- discriminate.
- assert (H':=PNSubst_ok n P3 M2 P2'). destruct PNSubst.
- * injection H; intros <-. rewrite <- PSubstL1_ok; intuition.
+ * injection H as <-. rewrite <- PSubstL1_ok; intuition.
* now apply IH.
Qed.
diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v
index 77863edc..fc02cef1 100644
--- a/plugins/setoid_ring/Ring_tac.v
+++ b/plugins/setoid_ring/Ring_tac.v
@@ -422,8 +422,6 @@ Tactic Notation (at level 0)
let G := Get_goal in
ring_lookup (PackRing Ring_simplify) [lH] rl G.
-(* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *)
-
Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):=
let G := Get_goal in
let t := type of H in
diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v
index 7fcd6c08..f7757a18 100644
--- a/plugins/setoid_ring/Ring_theory.v
+++ b/plugins/setoid_ring/Ring_theory.v
@@ -238,7 +238,6 @@ Section ALMOST_RING.
Variable req : R -> R -> Prop.
Notation "0" := rO. Notation "1" := rI.
Infix "==" := req. Infix "+" := radd. Infix "* " := rmul.
- Infix "-" := rsub. Notation "- x" := (ropp x).
(** Leibniz equality leads to a setoid theory and is extensional*)
Lemma Eqsth : Equivalence (@eq R).
@@ -263,7 +262,7 @@ Section ALMOST_RING.
-x = x and x - y = x + y *)
Definition SRopp (x:R) := x. Notation "- x" := (SRopp x).
- Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y).
+ Definition SRsub x y := x + -y. Infix "-" := SRsub.
Lemma SRopp_ext : forall x y, x == y -> -x == -y.
Proof. intros x y H; exact H. Qed.
@@ -320,6 +319,8 @@ Section ALMOST_RING.
Qed.
End SEMI_RING.
+ Infix "-" := rsub.
+ Notation "- x" := (ropp x).
Variable Reqe : ring_eq_ext radd rmul ropp req.
Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed.
diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v
index 91484372..23784cf3 100644
--- a/plugins/setoid_ring/ZArithRing.v
+++ b/plugins/setoid_ring/ZArithRing.v
@@ -17,14 +17,14 @@ Set Implicit Arguments.
Ltac Zcst t :=
match isZcst t with
true => t
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end.
Ltac isZpow_coef t :=
match t with
| Zpos ?p => isPcst p
- | Z0 => constr:true
- | _ => constr:false
+ | Z0 => constr:(true)
+ | _ => constr:(false)
end.
Notation N_of_Z := Z.to_N (only parsing).
@@ -32,7 +32,7 @@ Notation N_of_Z := Z.to_N (only parsing).
Ltac Zpow_tac t :=
match isZpow_coef t with
| true => constr:(N_of_Z t)
- | _ => constr:NotConstant
+ | _ => constr:(NotConstant)
end.
Ltac Zpower_neg :=
diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4
new file mode 100644
index 00000000..216eb8b3
--- /dev/null
+++ b/plugins/setoid_ring/g_newring.ml4
@@ -0,0 +1,133 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Pp
+open Util
+open Libnames
+open Printer
+open Newring_ast
+open Newring
+open Stdarg
+open Constrarg
+open Pcoq.Constr
+open Pcoq.Tactic
+
+DECLARE PLUGIN "newring_plugin"
+
+TACTIC EXTEND protect_fv
+ [ "protect_fv" string(map) "in" ident(id) ] ->
+ [ protect_tac_in map id ]
+| [ "protect_fv" string(map) ] ->
+ [ protect_tac map ]
+END
+
+TACTIC EXTEND closed_term
+ [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
+ [ closed_term t l ]
+END
+
+open Pptactic
+open Ppconstr
+
+let pr_ring_mod = function
+ | Ring_kind (Computational eq_test) -> str "decidable" ++ pr_arg pr_constr_expr eq_test
+ | Ring_kind Abstract -> str "abstract"
+ | Ring_kind (Morphism morph) -> str "morphism" ++ pr_arg pr_constr_expr morph
+ | Const_tac (CstTac cst_tac) -> str "constants" ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]"
+ | Const_tac (Closed l) -> str "closed" ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]"
+ | Pre_tac t -> str "preprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]"
+ | Post_tac t -> str "postprocess" ++ spc () ++ str "[" ++ pr_raw_tactic t ++ str "]"
+ | Setoid(sth,ext) -> str "setoid" ++ pr_arg pr_constr_expr sth ++ pr_arg pr_constr_expr ext
+ | Pow_spec(Closed l,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ prlist_with_sep spc pr_reference l ++ str "]"
+ | Pow_spec(CstTac cst_tac,spec) -> str "power_tac" ++ pr_arg pr_constr_expr spec ++ spc () ++ str "[" ++ pr_raw_tactic cst_tac ++ str "]"
+ | Sign_spec t -> str "sign" ++ pr_arg pr_constr_expr t
+ | Div_spec t -> str "div" ++ pr_arg pr_constr_expr t
+
+VERNAC ARGUMENT EXTEND ring_mod
+ PRINTED BY pr_ring_mod
+ | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ]
+ | [ "abstract" ] -> [ Ring_kind Abstract ]
+ | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ]
+ | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
+ | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
+ | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
+ | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
+ | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
+ | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
+ | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
+ [ Pow_spec (Closed l, pow_spec) ]
+ | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
+ [ Pow_spec (CstTac cst_tac, pow_spec) ]
+ | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
+END
+
+let pr_ring_mods l = surround (prlist_with_sep pr_comma pr_ring_mod l)
+
+VERNAC ARGUMENT EXTEND ring_mods
+ PRINTED BY pr_ring_mods
+ | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> [ mods ]
+END
+
+VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
+ | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] ->
+ [ let l = match l with None -> [] | Some l -> l in
+ 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]
+ | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
+ Feedback.msg_notice (strbrk "The following ring structures have been declared:");
+ Spmap.iter (fun fn fi ->
+ Feedback.msg_notice (hov 2
+ (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+ str"with carrier "++ pr_constr fi.ring_carrier++spc()++
+ str"and equivalence relation "++ pr_constr fi.ring_req))
+ ) !from_name ]
+END
+
+TACTIC EXTEND ring_lookup
+| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
+ [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t]
+END
+
+let pr_field_mod = function
+ | Ring_mod m -> pr_ring_mod m
+ | Inject inj -> str "completeness" ++ pr_arg pr_constr_expr inj
+
+VERNAC ARGUMENT EXTEND field_mod
+ PRINTED BY pr_field_mod
+ | [ ring_mod(m) ] -> [ Ring_mod m ]
+ | [ "completeness" constr(inj) ] -> [ Inject inj ]
+END
+
+let pr_field_mods l = surround (prlist_with_sep pr_comma pr_field_mod l)
+
+VERNAC ARGUMENT EXTEND field_mods
+ PRINTED BY pr_field_mods
+ | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> [ mods ]
+END
+
+VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
+| [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] ->
+ [ let l = match l with None -> [] | Some l -> l in
+ 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]
+| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
+ Feedback.msg_notice (strbrk "The following field structures have been declared:");
+ Spmap.iter (fun fn fi ->
+ Feedback.msg_notice (hov 2
+ (Ppconstr.pr_id (Libnames.basename fn)++spc()++
+ str"with carrier "++ pr_constr fi.field_carrier++spc()++
+ str"and equivalence relation "++ pr_constr fi.field_req))
+ ) !field_from_name ]
+END
+
+TACTIC EXTEND field_lookup
+| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
+ [ let (t,l) = List.sep_last lt in field_lookup f lH l t ]
+END
diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml
index e704c466..90f5f8e6 100644
--- a/plugins/setoid_ring/newring.ml4
+++ b/plugins/setoid_ring/newring.ml
@@ -6,15 +6,13 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i camlp4deps: "grammar/grammar.cma" i*)
-
open Pp
-open Errors
+open CErrors
open Util
open Names
open Term
open Vars
-open Closure
+open CClosure
open Environ
open Libnames
open Globnames
@@ -30,21 +28,12 @@ open Declare
open Decl_kinds
open Entries
open Misctypes
-
-DECLARE PLUGIN "newring_plugin"
+open Newring_ast
+open Proofview.Notations
(****************************************************************************)
(* controlled reduction *)
-(** ppedrot: something dubious here, we're obviously using evars the wrong
- way. FIXME! *)
-
-let mark_arg i c = mkEvar(Evar.unsafe_of_int i,[|c|])
-let unmark_arg f c =
- match destEvar c with
- | (i,[|c|]) -> f (Evar.repr i) c
- | _ -> assert false
-
type protect_flag = Eval|Prot|Rec
let tag_arg tag_rec map subs i c =
@@ -77,12 +66,10 @@ and mk_clos_app_but f_map subs f args n =
let fargs, args' = Array.chop n args in
let f' = mkApp(f,fargs) in
match f_map (global_of_constr_nofail f') with
- Some map ->
- mk_clos_deep
- (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s'))
- subs
- (mkApp (mark_arg (-1) f', Array.mapi mark_arg args'))
- | None -> mk_clos_app_but f_map subs f args (n+1)
+ | Some map ->
+ let f i t = tag_arg (mk_clos_but f_map subs) map subs i t in
+ mk_red (FApp (f (-1) f', Array.mapi f args'))
+ | None -> mk_atom (mkApp (f, args))
let interp_map l t =
try Some(List.assoc_f eq_gr t l) with Not_found -> None
@@ -95,36 +82,23 @@ let lookup_map map =
errorlabstrm"lookup_map"(str"map "++qs map++str"not found")
let protect_red map env sigma c =
- kl (create_clos_infos betadeltaiota env)
+ kl (create_clos_infos all env)
(mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);;
let protect_tac map =
- Tactics.reduct_option (protect_red map,DEFAULTcast) None ;;
+ Tactics.reduct_option (protect_red map,DEFAULTcast) None
let protect_tac_in map id =
- Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp));;
-
+ Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp))
-TACTIC EXTEND protect_fv
- [ "protect_fv" string(map) "in" ident(id) ] ->
- [ Proofview.V82.tactic (protect_tac_in map id) ]
-| [ "protect_fv" string(map) ] ->
- [ Proofview.V82.tactic (protect_tac map) ]
-END;;
(****************************************************************************)
let closed_term t l =
+ let open Quote_plugin in
let l = List.map Universes.constr_of_global l in
let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in
- if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt())
-;;
-
-TACTIC EXTEND closed_term
- [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] ->
- [ Proofview.V82.tactic (closed_term t l) ]
-END
-;;
+ if Quote.closed_under cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt())
(* TACTIC EXTEND echo
| [ "echo" constr(t) ] ->
@@ -143,11 +117,15 @@ let closed_term_ast l =
mltac_plugin = "newring_plugin";
mltac_tactic = "closed_term";
} in
+ let tacname = {
+ mltac_name = tacname;
+ mltac_index = 0;
+ } in
let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in
TacFun([Some(Id.of_string"t")],
TacML(Loc.ghost,tacname,
- [Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None);
- Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l]))
+ [TacGeneric (Genarg.in_gen (Genarg.glbwit Constrarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None));
+ TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Constrarg.wit_ref)) l)]))
(*
let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term"
*)
@@ -164,11 +142,6 @@ let ic_unsafe c = (*FIXME remove *)
let sigma = Evd.from_env env in
fst (Constrintern.interp_constr env sigma c)
-let ty c =
- let env = Global.env() in
- let sigma = Evd.from_env env in
- Typing.unsafe_type_of env sigma c
-
let decl_constant na ctx c =
let vars = Universes.universes_of_constr c in
let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in
@@ -185,18 +158,16 @@ let ltac_call tac (args:glob_tactic_arg list) =
let ltac_lcall tac args =
TacArg(Loc.ghost,TacCall(Loc.ghost, ArgVar(Loc.ghost, Id.of_string tac),args))
-let ltac_letin (x, e1) e2 =
- TacLetIn(false,[(Loc.ghost,Id.of_string x),e1],e2)
-
-let ltac_apply (f:glob_tactic_expr) (args:glob_tactic_arg list) =
- Tacinterp.eval_tactic
- (ltac_letin ("F", Tacexp f) (ltac_lcall "F" args))
-
-let ltac_record flds =
- TacFun([Some(Id.of_string"proj")], ltac_lcall "proj" flds)
-
-
-let carg c = TacDynamic(Loc.ghost,Pretyping.constr_in c)
+let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) =
+ let fold arg (i, vars, lfun) =
+ let id = Id.of_string ("x" ^ string_of_int i) in
+ let x = Reference (ArgVar (Loc.ghost, id)) in
+ (succ i, x :: vars, Id.Map.add id arg lfun)
+ in
+ let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in
+ let lfun = Id.Map.add (Id.of_string "F") f lfun in
+ let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in
+ Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args)
let dummy_goal env sigma =
let (gl,_,sigma) =
@@ -207,20 +178,39 @@ let constr_of v = match Value.to_constr v with
| Some c -> c
| None -> failwith "Ring.exec_tactic: anomaly"
+let tactic_res = ref [||]
+
+let get_res =
+ let open Tacexpr in
+ let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in
+ let entry = { mltac_name = name; mltac_index = 0 } in
+ let tac args ist =
+ let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in
+ let init i = Id.Map.find (Id.of_string ("x" ^ string_of_int i)) ist.lfun in
+ tactic_res := Array.init n init;
+ Proofview.tclUNIT ()
+ in
+ Tacenv.register_ml_tactic name [| tac |];
+ entry
+
let exec_tactic env evd n f args =
+ let fold arg (i, vars, lfun) =
+ let id = Id.of_string ("x" ^ string_of_int i) in
+ let x = Reference (ArgVar (Loc.ghost, id)) in
+ (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun)
+ in
+ let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in
+ let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in
+ (** Build the getter *)
let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in
- let res = ref [||] in
- let get_res ist =
- let l = List.map (fun id -> Id.Map.find id ist.lfun) lid in
- res := Array.of_list l;
- TacId[] in
- let getter =
- Tacexp(TacFun(List.map(fun id -> Some id) lid,
- Tacintern.glob_tactic(tacticIn get_res))) in
+ let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in
+ let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in
+ let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in
+ (** Evaluate the whole result *)
let gl = dummy_goal env evd in
- let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in
+ let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in
let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in
- Array.map (fun x -> nf (constr_of x)) !res, snd (Evd.universe_context evd)
+ Array.map (fun x -> nf (constr_of x)) !tactic_res, snd (Evd.universe_context evd)
let stdlib_modules =
[["Coq";"Setoids";"Setoid"];
@@ -281,8 +271,6 @@ let my_reference c =
let new_ring_path =
DirPath.make (List.map Id.of_string ["Ring_tac";plugin_dir;"Coq"])
-let ltac s =
- lazy(make_kn (MPfile new_ring_path) DirPath.empty (Label.make s))
let znew_ring_path =
DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"])
let zltac s =
@@ -309,21 +297,12 @@ let coq_mk_reqe = my_constant "mk_reqe"
let coq_semi_ring_theory = my_constant "semi_ring_theory"
let coq_mk_seqe = my_constant "mk_seqe"
-let ltac_inv_morph_gen = zltac"inv_gen_phi"
-let ltac_inv_morphZ = zltac"inv_gen_phiZ"
-let ltac_inv_morphN = zltac"inv_gen_phiN"
-let ltac_inv_morphNword = zltac"inv_gen_phiNword"
let coq_abstract = my_constant"Abstract"
let coq_comp = my_constant"Computational"
let coq_morph = my_constant"Morphism"
-(* morphism *)
-let coq_ring_morph = my_constant "ring_morph"
-let coq_semi_morph = my_constant "semi_morph"
-
(* power function *)
let ltac_inv_morph_nothing = zltac"inv_morph_nothing"
-let coq_pow_N_pow_N = my_constant "pow_N_pow_N"
(* hypothesis *)
let coq_mkhypo = my_reference "mkhypo"
@@ -355,20 +334,6 @@ let _ = add_map "ring"
(****************************************************************************)
(* Ring database *)
-type ring_info =
- { ring_carrier : types;
- ring_req : constr;
- ring_setoid : constr;
- ring_ext : constr;
- ring_morph : constr;
- ring_th : constr;
- ring_cst_tac : glob_tactic_expr;
- ring_pow_tac : glob_tactic_expr;
- ring_lemma1 : constr;
- ring_lemma2 : constr;
- ring_pre_tac : glob_tactic_expr;
- ring_post_tac : glob_tactic_expr }
-
module Cmap = Map.Make(Constr)
let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table"
@@ -527,8 +492,8 @@ let ring_equality env evd (r,add,mul,opp,req) =
match opp with
Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|]
| None -> plapp evd coq_eq_smorph [|r;add;mul|] in
- let setoid = Typing.solve_evars env evd setoid in
- let op_morph = Typing.solve_evars env evd op_morph in
+ let setoid = Typing.e_solve_evars env evd setoid in
+ let op_morph = Typing.e_solve_evars env evd op_morph in
(setoid,op_morph)
| _ ->
let setoid = setoid_of_relation (Global.env ()) evd r req in
@@ -551,7 +516,7 @@ let ring_equality env evd (r,add,mul,opp,req) =
let op_morph =
op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in
Flags.if_verbose
- msg_info
+ Feedback.msg_info
(str"Using setoid \""++pr_constr req++str"\""++spc()++
str"and morphisms \""++pr_constr add_m_lem ++
str"\","++spc()++ str"\""++pr_constr mul_m_lem++
@@ -560,7 +525,7 @@ let ring_equality env evd (r,add,mul,opp,req) =
op_morph)
| None ->
(Flags.if_verbose
- msg_info
+ Feedback.msg_info
(str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++
str"and morphisms \""++pr_constr add_m_lem ++
str"\""++spc()++str"and \""++
@@ -588,25 +553,6 @@ let dest_ring env sigma th_spec =
| _ -> error "bad ring structure"
-let dest_morph env sigma m_spec =
- let m_typ = Retyping.get_type_of env sigma m_spec in
- match kind_of_term m_typ with
- App(f,[|r;zero;one;add;mul;sub;opp;req;
- c;czero;cone;cadd;cmul;csub;copp;ceqb;phi|])
- when eq_constr_nounivs f (Lazy.force coq_ring_morph) ->
- (c,czero,cone,cadd,cmul,Some csub,Some copp,ceqb,phi)
- | App(f,[|r;zero;one;add;mul;req;c;czero;cone;cadd;cmul;ceqb;phi|])
- when eq_constr_nounivs f (Lazy.force coq_semi_morph) ->
- (c,czero,cone,cadd,cmul,None,None,ceqb,phi)
- | _ -> error "bad morphism structure"
-
-
-type 'constr coeff_spec =
- Computational of 'constr (* equality test *)
- | Abstract (* coeffs = Z *)
- | Morphism of 'constr (* general morphism *)
-
-
let reflect_coeff rkind =
(* We build an ill-typed terms on purpose... *)
match rkind with
@@ -614,10 +560,6 @@ let reflect_coeff rkind =
| Computational c -> lapp coq_comp [|c|]
| Morphism m -> lapp coq_morph [|m|]
-type cst_tac_spec =
- CstTac of raw_tactic_expr
- | Closed of reference list
-
let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac =
match cst_tac with
Some (CstTac t) -> Tacintern.glob_tactic t
@@ -638,7 +580,7 @@ let make_hyp_list env evd lH =
(fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH
(plapp evd coq_nil [|carrier|])
in
- let l' = Typing.solve_evars env evd l in
+ let l' = Typing.e_solve_evars env evd l in
Evarutil.nf_evars_universes !evd l'
let interp_power env evd pow =
@@ -686,7 +628,7 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
let rk = reflect_coeff morphth in
let params,ctx =
exec_tactic env !evd 5 (zltac "ring_lemmas")
- (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in
+ [sth;ext;rth;pspec;sspec;dspec;rk] in
let lemma1 = params.(3) in
let lemma2 = params.(4) in
@@ -721,41 +663,12 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div =
ring_post_tac = posttac }) in
()
-type 'constr ring_mod =
- Ring_kind of 'constr coeff_spec
- | Const_tac of cst_tac_spec
- | Pre_tac of raw_tactic_expr
- | Post_tac of raw_tactic_expr
- | Setoid of Constrexpr.constr_expr * Constrexpr.constr_expr
- | Pow_spec of cst_tac_spec * Constrexpr.constr_expr
- (* Syntaxification tactic , correctness lemma *)
- | Sign_spec of Constrexpr.constr_expr
- | Div_spec of Constrexpr.constr_expr
-
-
let ic_coeff_spec = function
| Computational t -> Computational (ic_unsafe t)
| Morphism t -> Morphism (ic_unsafe t)
| Abstract -> Abstract
-VERNAC ARGUMENT EXTEND ring_mod
- | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ]
- | [ "abstract" ] -> [ Ring_kind Abstract ]
- | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ]
- | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ]
- | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ]
- | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ]
- | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ]
- | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ]
- | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ]
- | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] ->
- [ Pow_spec (Closed l, pow_spec) ]
- | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] ->
- [ Pow_spec (CstTac cst_tac, pow_spec) ]
- | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ]
-END
-
let set_once s r v =
if Option.is_empty !r then r := Some v else error (s^" cannot be set twice")
@@ -780,20 +693,6 @@ let process_ring_mods l =
let k = match !kind with Some k -> k | None -> Abstract in
(k, !set, !cst_tac, !pre, !post, !power, !sign, !div)
-VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF
- | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods(l) ] ->
- [ let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in
- add_theory id (ic t) set k cst (pre,post) power sign div]
- | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [
- msg_notice (strbrk "The following ring structures have been declared:");
- Spmap.iter (fun fn fi ->
- msg_notice (hov 2
- (Ppconstr.pr_id (Libnames.basename fn)++spc()++
- str"with carrier "++ pr_constr fi.ring_carrier++spc()++
- str"and equivalence relation "++ pr_constr fi.ring_req))
- ) !from_name ]
-END
-
(*****************************************************************************)
(* The tactics consist then only in a lookup in the ring database and
call the appropriate ltac. *)
@@ -807,7 +706,11 @@ let make_term_list env evd carrier rl =
let l = List.fold_right
(fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl
(plapp evd coq_nil [|carrier|])
- in Typing.solve_evars env evd l
+ in Typing.e_solve_evars env evd l
+
+let carg = Tacinterp.Value.of_constr
+let tacarg expr =
+ Tacinterp.Value.of_closure (Tacinterp.default_ist ()) expr
let ltac_ring_structure e =
let req = carg e.ring_req in
@@ -815,18 +718,18 @@ let ltac_ring_structure e =
let ext = carg e.ring_ext in
let morph = carg e.ring_morph in
let th = carg e.ring_th in
- let cst_tac = Tacexp e.ring_cst_tac in
- let pow_tac = Tacexp e.ring_pow_tac in
+ let cst_tac = tacarg e.ring_cst_tac in
+ let pow_tac = tacarg e.ring_pow_tac in
let lemma1 = carg e.ring_lemma1 in
let lemma2 = carg e.ring_lemma2 in
- let pretac = Tacexp(TacFun([None],e.ring_pre_tac)) in
- let posttac = Tacexp(TacFun([None],e.ring_post_tac)) in
+ let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in
+ let posttac = tacarg (TacFun([None],e.ring_post_tac)) in
[req;sth;ext;morph;th;cst_tac;pow_tac;
lemma1;lemma2;pretac;posttac]
-let ring_lookup (f:glob_tactic_expr) lH rl t =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+let ring_lookup (f : Value.t) lH rl t =
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
try (* find_ring_strucure can raise an exception *)
let evdref = ref sigma in
@@ -837,14 +740,7 @@ let ring_lookup (f:glob_tactic_expr) lH rl t =
let ring = ltac_ring_structure e in
Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl]))
with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
-
-TACTIC EXTEND ring_lookup
-| [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] ->
- [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t]
-END
-
-
+ end }
(***********************************************************************)
@@ -919,19 +815,6 @@ let dest_field env evd th_spec =
(Some true,r,zero,one,add,mul,None,None,div,inv,req,rth)
| _ -> error "bad field structure"
-type field_info =
- { field_carrier : types;
- field_req : constr;
- field_cst_tac : glob_tactic_expr;
- field_pow_tac : glob_tactic_expr;
- field_ok : constr;
- field_simpl_eq_ok : constr;
- field_simpl_ok : constr;
- field_simpl_eq_in_ok : constr;
- field_cond : constr;
- field_pre_tac : glob_tactic_expr;
- field_post_tac : glob_tactic_expr }
-
let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table"
let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table"
@@ -1034,7 +917,7 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power
let rk = reflect_coeff morphth in
let params,ctx =
exec_tactic env !evd 9 (field_ltac"field_lemmas")
- (List.map carg[sth;ext;inv_m;fth;pspec;sspec;dspec;rk]) in
+ [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in
let lemma1 = params.(3) in
let lemma2 = params.(4) in
let lemma3 = params.(5) in
@@ -1078,15 +961,6 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power
field_pre_tac = pretac;
field_post_tac = posttac }) in ()
-type 'constr field_mod =
- Ring_mod of 'constr ring_mod
- | Inject of Constrexpr.constr_expr
-
-VERNAC ARGUMENT EXTEND field_mod
- | [ ring_mod(m) ] -> [ Ring_mod m ]
- | [ "completeness" constr(inj) ] -> [ Inject inj ]
-END
-
let process_field_mods l =
let kind = ref None in
let set = ref None in
@@ -1111,38 +985,23 @@ let process_field_mods l =
let k = match !kind with Some k -> k | None -> Abstract in
(k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div)
-VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF
-| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] ->
- [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in
- add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div]
-| [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [
- msg_notice (strbrk "The following field structures have been declared:");
- Spmap.iter (fun fn fi ->
- msg_notice (hov 2
- (Ppconstr.pr_id (Libnames.basename fn)++spc()++
- str"with carrier "++ pr_constr fi.field_carrier++spc()++
- str"and equivalence relation "++ pr_constr fi.field_req))
- ) !field_from_name ]
-END
-
-
let ltac_field_structure e =
let req = carg e.field_req in
- let cst_tac = Tacexp e.field_cst_tac in
- let pow_tac = Tacexp e.field_pow_tac in
+ let cst_tac = tacarg e.field_cst_tac in
+ let pow_tac = tacarg e.field_pow_tac in
let field_ok = carg e.field_ok in
let field_simpl_ok = carg e.field_simpl_ok in
let field_simpl_eq_ok = carg e.field_simpl_eq_ok in
let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in
let cond_ok = carg e.field_cond in
- let pretac = Tacexp(TacFun([None],e.field_pre_tac)) in
- let posttac = Tacexp(TacFun([None],e.field_post_tac)) in
+ let pretac = tacarg (TacFun([None],e.field_pre_tac)) in
+ let posttac = tacarg (TacFun([None],e.field_post_tac)) in
[req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok;
field_simpl_eq_in_ok;cond_ok;pretac;posttac]
-let field_lookup (f:glob_tactic_expr) lH rl t =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
+let field_lookup (f : Value.t) lH rl t =
+ Proofview.Goal.enter { enter = begin fun gl ->
+ let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
try
let evdref = ref sigma in
@@ -1153,10 +1012,4 @@ let field_lookup (f:glob_tactic_expr) lH rl t =
let field = ltac_field_structure e in
Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl]))
with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
- end
-
-
-TACTIC EXTEND field_lookup
-| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] ->
- [ let (t,l) = List.sep_last lt in field_lookup f lH l t ]
-END
+ end }
diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli
new file mode 100644
index 00000000..f417c87c
--- /dev/null
+++ b/plugins/setoid_ring/newring.mli
@@ -0,0 +1,78 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Names
+open Constr
+open Libnames
+open Globnames
+open Constrexpr
+open Tacexpr
+open Proof_type
+open Newring_ast
+
+val protect_tac_in : string -> Id.t -> unit Proofview.tactic
+
+val protect_tac : string -> unit Proofview.tactic
+
+val closed_term : constr -> global_reference list -> unit Proofview.tactic
+
+val process_ring_mods :
+ constr_expr ring_mod list ->
+ constr coeff_spec * (constr * constr) option *
+ cst_tac_spec option * raw_tactic_expr option *
+ raw_tactic_expr option *
+ (cst_tac_spec * constr_expr) option *
+ constr_expr option * constr_expr option
+
+val add_theory :
+ Id.t ->
+ Evd.evar_map * constr ->
+ (constr * constr) option ->
+ constr coeff_spec ->
+ cst_tac_spec option ->
+ raw_tactic_expr option * raw_tactic_expr option ->
+ (cst_tac_spec * constr_expr) option ->
+ constr_expr option ->
+ constr_expr option -> unit
+
+val ic : constr_expr -> Evd.evar_map * constr
+
+val from_name : ring_info Spmap.t ref
+
+val ring_lookup :
+ Geninterp.Val.t ->
+ constr list ->
+ constr list -> constr -> unit Proofview.tactic
+
+val process_field_mods :
+ constr_expr field_mod list ->
+ constr coeff_spec *
+ (constr * constr) option * constr option *
+ cst_tac_spec option * raw_tactic_expr option *
+ raw_tactic_expr option *
+ (cst_tac_spec * constr_expr) option *
+ constr_expr option * constr_expr option
+
+val add_field_theory :
+ Id.t ->
+ Evd.evar_map * constr ->
+ (constr * constr) option ->
+ constr coeff_spec ->
+ cst_tac_spec option ->
+ constr option ->
+ raw_tactic_expr option * raw_tactic_expr option ->
+ (cst_tac_spec * constr_expr) option ->
+ constr_expr option ->
+ constr_expr option -> unit
+
+val field_from_name : field_info Spmap.t ref
+
+val field_lookup :
+ Geninterp.Val.t ->
+ constr list ->
+ constr list -> constr -> unit Proofview.tactic
diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli
new file mode 100644
index 00000000..c26fcc8d
--- /dev/null
+++ b/plugins/setoid_ring/newring_ast.mli
@@ -0,0 +1,63 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+open Constr
+open Libnames
+open Constrexpr
+open Tacexpr
+
+type 'constr coeff_spec =
+ Computational of 'constr (* equality test *)
+ | Abstract (* coeffs = Z *)
+ | Morphism of 'constr (* general morphism *)
+
+type cst_tac_spec =
+ CstTac of raw_tactic_expr
+ | Closed of reference list
+
+type 'constr ring_mod =
+ Ring_kind of 'constr coeff_spec
+ | Const_tac of cst_tac_spec
+ | Pre_tac of raw_tactic_expr
+ | Post_tac of raw_tactic_expr
+ | Setoid of constr_expr * constr_expr
+ | Pow_spec of cst_tac_spec * constr_expr
+ (* Syntaxification tactic , correctness lemma *)
+ | Sign_spec of constr_expr
+ | Div_spec of constr_expr
+
+type 'constr field_mod =
+ Ring_mod of 'constr ring_mod
+ | Inject of constr_expr
+
+type ring_info =
+ { ring_carrier : types;
+ ring_req : constr;
+ ring_setoid : constr;
+ ring_ext : constr;
+ ring_morph : constr;
+ ring_th : constr;
+ ring_cst_tac : glob_tactic_expr;
+ ring_pow_tac : glob_tactic_expr;
+ ring_lemma1 : constr;
+ ring_lemma2 : constr;
+ ring_pre_tac : glob_tactic_expr;
+ ring_post_tac : glob_tactic_expr }
+
+type field_info =
+ { field_carrier : types;
+ field_req : constr;
+ field_cst_tac : glob_tactic_expr;
+ field_pow_tac : glob_tactic_expr;
+ field_ok : constr;
+ field_simpl_eq_ok : constr;
+ field_simpl_ok : constr;
+ field_simpl_eq_in_ok : constr;
+ field_cond : constr;
+ field_pre_tac : glob_tactic_expr;
+ field_post_tac : glob_tactic_expr }
diff --git a/plugins/setoid_ring/newring_plugin.mllib b/plugins/setoid_ring/newring_plugin.mllib
deleted file mode 100644
index a98392f1..00000000
--- a/plugins/setoid_ring/newring_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Newring
-Newring_plugin_mod
diff --git a/plugins/setoid_ring/newring_plugin.mlpack b/plugins/setoid_ring/newring_plugin.mlpack
new file mode 100644
index 00000000..23663b40
--- /dev/null
+++ b/plugins/setoid_ring/newring_plugin.mlpack
@@ -0,0 +1,2 @@
+Newring
+G_newring
diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4
new file mode 100644
index 00000000..d21223d4
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching.ml4
@@ -0,0 +1,1447 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *)
+
+(* Defining grammar rules with "xx" in it automatically declares keywords too,
+ * we thus save the lexer to restore it at the end of the file *)
+let frozen_lexer = CLexer.freeze () ;;
+
+(*i camlp4use: "pa_extend.cmo" i*)
+(*i camlp4deps: "grammar/grammar.cma" i*)
+
+open Names
+open Pp
+open Pcoq
+open Genarg
+open Constrarg
+open Term
+open Vars
+open Topconstr
+open Libnames
+open Tactics
+open Tacticals
+open Termops
+open Namegen
+open Recordops
+open Tacmach
+open Coqlib
+open Glob_term
+open Util
+open Evd
+open Extend
+open Goptions
+open Tacexpr
+open Proofview.Notations
+open Tacinterp
+open Pretyping
+open Constr
+open Tactic
+open Extraargs
+open Ppconstr
+open Printer
+
+open Globnames
+open Misctypes
+open Decl_kinds
+open Evar_kinds
+open Constrexpr
+open Constrexpr_ops
+open Notation_term
+open Notation_ops
+open Locus
+open Locusops
+
+DECLARE PLUGIN "ssrmatching_plugin"
+
+type loc = Loc.t
+let dummy_loc = Loc.ghost
+let errorstrm = CErrors.errorlabstrm "ssrmatching"
+let loc_error loc msg = CErrors.user_err_loc (loc, msg, str msg)
+let ppnl = Feedback.msg_info
+
+(* 0 cost pp function. Active only if env variable SSRDEBUG is set *)
+(* or if SsrDebug is Set *)
+let pp_ref = ref (fun _ -> ())
+let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s)
+let _ =
+ try ignore(Sys.getenv "SSRMATCHINGDEBUG"); pp_ref := ssr_pp
+ with Not_found -> ()
+let debug b =
+ if b then pp_ref := ssr_pp else pp_ref := fun _ -> ()
+let _ =
+ Goptions.declare_bool_option
+ { Goptions.optsync = false;
+ Goptions.optname = "ssrmatching debugging";
+ Goptions.optkey = ["Debug";"SsrMatching"];
+ Goptions.optdepr = false;
+ Goptions.optread = (fun _ -> !pp_ref == ssr_pp);
+ Goptions.optwrite = debug }
+let pp s = !pp_ref s
+
+(** Utils {{{ *****************************************************************)
+let env_size env = List.length (Environ.named_context env)
+let safeDestApp c =
+ match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |]
+let get_index = function ArgArg i -> i | _ ->
+ CErrors.anomaly (str"Uninterpreted index")
+(* Toplevel constr must be globalized twice ! *)
+let glob_constr ist genv = function
+ | _, Some ce ->
+ let vars = Id.Map.fold (fun x _ accu -> Id.Set.add x accu) ist.lfun Id.Set.empty in
+ let ltacvars = { Constrintern.empty_ltac_sign with Constrintern.ltac_vars = vars } in
+ Constrintern.intern_gen WithoutTypeConstraint ~ltacvars:ltacvars genv ce
+ | rc, None -> rc
+
+(* Term printing utilities functions for deciding bracketing. *)
+let pr_paren prx x = hov 1 (str "(" ++ prx x ++ str ")")
+(* String lexing utilities *)
+let skip_wschars s =
+ let rec loop i = match s.[i] with '\n'..' ' -> loop (i + 1) | _ -> i in loop
+(* We also guard characters that might interfere with the ssreflect *)
+(* tactic syntax. *)
+let guard_term ch1 s i = match s.[i] with
+ | '(' -> false
+ | '{' | '/' | '=' -> true
+ | _ -> ch1 = '('
+(* The call 'guard s i' should return true if the contents of s *)
+(* starting at i need bracketing to avoid ambiguities. *)
+let pr_guarded guard prc c =
+ let s = Pp.string_of_ppcmds (prc c) ^ "$" in
+ if guard s (skip_wschars s 0) then pr_paren prc c else prc c
+(* More sensible names for constr printers *)
+let pr_constr = pr_constr
+let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c
+let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c
+let prl_constr_expr = pr_lconstr_expr
+let pr_constr_expr = pr_constr_expr
+let prl_glob_constr_and_expr = function
+ | _, Some c -> prl_constr_expr c
+ | c, None -> prl_glob_constr c
+let pr_glob_constr_and_expr = function
+ | _, Some c -> pr_constr_expr c
+ | c, None -> pr_glob_constr c
+let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c
+let prl_term (k, c) = pr_guarded (guard_term k) prl_glob_constr_and_expr c
+
+(** Adding a new uninterpreted generic argument type *)
+let add_genarg tag pr =
+ let wit = Genarg.make0 tag in
+ let tag = Geninterp.Val.create tag in
+ let glob ist x = (ist, x) in
+ let subst _ x = x in
+ let interp ist x = Ftactic.return (Geninterp.Val.Dyn (tag, x)) in
+ let gen_pr _ _ _ = pr in
+ let () = Genintern.register_intern0 wit glob in
+ let () = Genintern.register_subst0 wit subst in
+ let () = Geninterp.register_interp0 wit interp in
+ let () = Geninterp.register_val0 wit (Some (Geninterp.Val.Base tag)) in
+ Pptactic.declare_extra_genarg_pprule wit gen_pr gen_pr gen_pr;
+ wit
+
+(** Constructors for cast type *)
+let dC t = CastConv t
+(** Constructors for constr_expr *)
+let isCVar = function CRef (Ident _, _) -> true | _ -> false
+let destCVar = function CRef (Ident (_, id), _) -> id | _ ->
+ CErrors.anomaly (str"not a CRef")
+let mkCHole loc = CHole (loc, None, IntroAnonymous, None)
+let mkCLambda loc name ty t =
+ CLambdaN (loc, [[loc, name], Default Explicit, ty], t)
+let mkCLetIn loc name bo t =
+ CLetIn (loc, (loc, name), bo, t)
+let mkCCast loc t ty = CCast (loc,t, dC ty)
+(** Constructors for rawconstr *)
+let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None)
+let mkRApp f args = if args = [] then f else GApp (dummy_loc, f, args)
+let mkRCast rc rt = GCast (dummy_loc, rc, dC rt)
+let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t)
+
+(* ssrterm conbinators *)
+let combineCG t1 t2 f g = match t1, t2 with
+ | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None)
+ | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2))
+ | _, (_, (_, None)) -> CErrors.anomaly (str"have: mixed C-G constr")
+ | _ -> CErrors.anomaly (str"have: mixed G-C constr")
+let loc_ofCG = function
+ | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s
+ | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s
+
+let mk_term k c = k, (mkRHole, Some c)
+let mk_lterm = mk_term ' '
+
+let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty
+
+(* }}} *)
+
+(** Profiling {{{ *************************************************************)
+type profiler = {
+ profile : 'a 'b. ('a -> 'b) -> 'a -> 'b;
+ reset : unit -> unit;
+ print : unit -> unit }
+let profile_now = ref false
+let something_profiled = ref false
+let profilers = ref []
+let add_profiler f = profilers := f :: !profilers;;
+let profile b =
+ profile_now := b;
+ if b then List.iter (fun f -> f.reset ()) !profilers;
+ if not b then List.iter (fun f -> f.print ()) !profilers
+;;
+let _ =
+ Goptions.declare_bool_option
+ { Goptions.optsync = false;
+ Goptions.optname = "ssrmatching profiling";
+ Goptions.optkey = ["SsrMatchingProfiling"];
+ Goptions.optread = (fun _ -> !profile_now);
+ Goptions.optdepr = false;
+ Goptions.optwrite = profile }
+let () =
+ let prof_total =
+ let init = ref 0.0 in {
+ profile = (fun f x -> assert false);
+ reset = (fun () -> init := Unix.gettimeofday ());
+ print = (fun () -> if !something_profiled then
+ prerr_endline
+ (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f"
+ "total" 0 (Unix.gettimeofday() -. !init) 0.0 0.0)) } in
+ let prof_legenda = {
+ profile = (fun f x -> assert false);
+ reset = (fun () -> ());
+ print = (fun () -> if !something_profiled then begin
+ prerr_endline
+ (Printf.sprintf "!! %39s ---------- --------- --------- ---------"
+ (String.make 39 '-'));
+ prerr_endline
+ (Printf.sprintf "!! %-39s %10s %9s %9s %9s"
+ "function" "#calls" "total" "max" "average") end) } in
+ add_profiler prof_legenda;
+ add_profiler prof_total
+;;
+
+let mk_profiler s =
+ let total, calls, max = ref 0.0, ref 0, ref 0.0 in
+ let reset () = total := 0.0; calls := 0; max := 0.0 in
+ let profile f x =
+ if not !profile_now then f x else
+ let before = Unix.gettimeofday () in
+ try
+ incr calls;
+ let res = f x in
+ let after = Unix.gettimeofday () in
+ let delta = after -. before in
+ total := !total +. delta;
+ if delta > !max then max := delta;
+ res
+ with exc ->
+ let after = Unix.gettimeofday () in
+ let delta = after -. before in
+ total := !total +. delta;
+ if delta > !max then max := delta;
+ raise exc in
+ let print () =
+ if !calls <> 0 then begin
+ something_profiled := true;
+ prerr_endline
+ (Printf.sprintf "!! %-39s %10d %9.4f %9.4f %9.4f"
+ s !calls !total !max (!total /. (float_of_int !calls))) end in
+ let prof = { profile = profile; reset = reset; print = print } in
+ add_profiler prof;
+ prof
+;;
+(* }}} *)
+
+exception NoProgress
+
+(** Unification procedures. *)
+
+(* To enforce the rigidity of the rooted match we always split *)
+(* top applications, so the unification procedures operate on *)
+(* arrays of patterns and terms. *)
+(* We perform three kinds of unification: *)
+(* EQ: exact conversion check *)
+(* FO: first-order unification of evars, without conversion *)
+(* HO: higher-order unification with conversion *)
+(* The subterm unification strategy is to find the first FO *)
+(* match, if possible, and the first HO match otherwise, then *)
+(* compute all the occurrences that are EQ matches for the *)
+(* relevant subterm. *)
+(* Additional twists: *)
+(* - If FO/HO fails then we attempt to fill evars using *)
+(* typeclasses before raising an outright error. We also *)
+(* fill typeclasses even after a successful match, since *)
+(* beta-reduction and canonical instances may leave *)
+(* undefined evars. *)
+(* - We do postchecks to rule out matches that are not *)
+(* closed or that assign to a global evar; these can be *)
+(* disabled for rewrite or dependent family matches. *)
+(* - We do a full FO scan before turning to HO, as the FO *)
+(* comparison can be much faster than the HO one. *)
+
+let unif_EQ env sigma p c =
+ let evars = existential_opt_value sigma, Evd.universes sigma in
+ try let _ = Reduction.conv env p ~evars c in true with _ -> false
+
+let unif_EQ_args env sigma pa a =
+ let n = Array.length pa in
+ let rec loop i = (i = n) || unif_EQ env sigma pa.(i) a.(i) && loop (i + 1) in
+ loop 0
+
+let prof_unif_eq_args = mk_profiler "unif_EQ_args";;
+let unif_EQ_args env sigma pa a =
+ prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a
+;;
+
+let unif_HO env ise p c = Evarconv.the_conv_x env p c ise
+
+let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise
+
+let unif_HO_args env ise0 pa i ca =
+ let n = Array.length pa in
+ let rec loop ise j =
+ if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in
+ loop ise0 0
+
+(* FO unification should boil down to calling w_unify with no_delta, but *)
+(* alas things are not so simple: w_unify does partial type-checking, *)
+(* which breaks down when the no-delta flag is on (as the Coq type system *)
+(* requires full convertibility. The workaround here is to convert all *)
+(* evars into metas, since 8.2 does not TC metas. This means some lossage *)
+(* for HO evars, though hopefully Miller patterns can pick up some of *)
+(* those cases, and HO matching will mop up the rest. *)
+let flags_FO =
+ let flags =
+ { (Unification.default_no_delta_unify_flags ()).Unification.core_unify_flags
+ with
+ Unification.modulo_conv_on_closed_terms = None;
+ Unification.modulo_eta = true;
+ Unification.modulo_betaiota = true;
+ Unification.modulo_delta_types = full_transparent_state}
+ in
+ { Unification.core_unify_flags = flags;
+ Unification.merge_unify_flags = flags;
+ Unification.subterm_unify_flags = flags;
+ Unification.allow_K_in_toplevel_higher_order_unification = false;
+ Unification.resolve_evars =
+ (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars
+ }
+let unif_FO env ise p c =
+ Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c
+
+(* Perform evar substitution in main term and prune substitution. *)
+let nf_open_term sigma0 ise c =
+ let s = ise and s' = ref sigma0 in
+ let rec nf c' = match kind_of_term c' with
+ | Evar ex ->
+ begin try nf (existential_value s ex) with _ ->
+ let k, a = ex in let a' = Array.map nf a in
+ if not (Evd.mem !s' k) then
+ s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k));
+ mkEvar (k, a')
+ end
+ | _ -> map_constr nf c' in
+ let copy_def k evi () =
+ if evar_body evi != Evd.Evar_empty then () else
+ match Evd.evar_body (Evd.find s k) with
+ | Evar_defined c' -> s' := Evd.define k (nf c') !s'
+ | _ -> () in
+ let c' = nf c in let _ = Evd.fold copy_def sigma0 () in
+ !s', Evd.evar_universe_context s, c'
+
+let unif_end env sigma0 ise0 pt ok =
+ let ise = Evarconv.solve_unif_constraints_with_heuristics env ise0 in
+ let s, uc, t = nf_open_term sigma0 ise pt in
+ let ise1 = create_evar_defs s in
+ let ise1 = Evd.set_universe_context ise1 uc in
+ let ise2 = Typeclasses.resolve_typeclasses ~fail:true env ise1 in
+ if not (ok ise) then raise NoProgress else
+ if ise2 == ise1 then (s, uc, t)
+ else
+ let s, uc', t = nf_open_term sigma0 ise2 t in
+ s, Evd.union_evar_universe_context uc uc', t
+
+let pf_unif_HO gl sigma pt p c =
+ let env = pf_env gl in
+ let ise = unif_HO env (create_evar_defs sigma) p c in
+ unif_end env (project gl) ise pt (fun _ -> true)
+
+let unify_HO env sigma0 t1 t2 =
+ let sigma = unif_HO env sigma0 t1 t2 in
+ let sigma, uc, _ = unif_end env sigma0 sigma t2 (fun _ -> true) in
+ Evd.set_universe_context sigma uc
+
+let pf_unify_HO gl t1 t2 =
+ let env, sigma0, si = pf_env gl, project gl, sig_it gl in
+ let sigma = unify_HO env sigma0 t1 t2 in
+ re_sig si sigma
+
+(* This is what the definition of iter_constr should be... *)
+let iter_constr_LR f c = match kind_of_term c with
+ | Evar (k, a) -> Array.iter f a
+ | Cast (cc, _, t) -> f cc; f t
+ | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b
+ | LetIn (_, v, t, b) -> f v; f t; f b
+ | App (cf, a) -> f cf; Array.iter f a
+ | Case (_, p, v, b) -> f v; f p; Array.iter f b
+ | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) ->
+ for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done
+ | Proj(_,a) -> f a
+ | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> ()
+
+(* The comparison used to determine which subterms matches is KEYED *)
+(* CONVERSION. This looks for convertible terms that either have the same *)
+(* same head constant as pat if pat is an application (after beta-iota), *)
+(* or start with the same constr constructor (esp. for LetIn); this is *)
+(* disregarded if the head term is let x := ... in x, and casts are always *)
+(* ignored and removed). *)
+(* Record projections get special treatment: in addition to the projection *)
+(* constant itself, ssreflect also recognizes head constants of canonical *)
+(* projections. *)
+
+exception NoMatch
+type ssrdir = L2R | R2L
+let pr_dir_side = function L2R -> str "LHS" | R2L -> str "RHS"
+let inv_dir = function L2R -> R2L | R2L -> L2R
+
+
+type pattern_class =
+ | KpatFixed
+ | KpatConst
+ | KpatEvar of existential_key
+ | KpatLet
+ | KpatLam
+ | KpatRigid
+ | KpatFlex
+ | KpatProj of constant
+
+type tpattern = {
+ up_k : pattern_class;
+ up_FO : constr;
+ up_f : constr;
+ up_a : constr array;
+ up_t : constr; (* equation proof term or matched term *)
+ up_dir : ssrdir; (* direction of the rule *)
+ up_ok : constr -> evar_map -> bool; (* progess test for rewrite *)
+ }
+
+let all_ok _ _ = true
+
+let proj_nparams c =
+ try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0
+
+let isFixed c = match kind_of_term c with
+ | Var _ | Ind _ | Construct _ | Const _ | Proj _ -> true
+ | _ -> false
+
+let isRigid c = match kind_of_term c with
+ | Prod _ | Sort _ | Lambda _ | Case _ | Fix _ | CoFix _ -> true
+ | _ -> false
+
+exception UndefPat
+
+let hole_var = mkVar (id_of_string "_")
+let pr_constr_pat c0 =
+ let rec wipe_evar c =
+ if isEvar c then hole_var else map_constr wipe_evar c in
+ pr_constr (wipe_evar c0)
+
+(* Turn (new) evars into metas *)
+let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 =
+ let ise = ref ise0 in
+ let sigma = ref ise0 in
+ let nenv = env_size env + if hack then 1 else 0 in
+ let rec put c = match kind_of_term c with
+ | Evar (k, a as ex) ->
+ begin try put (existential_value !sigma ex)
+ with NotInstantiatedEvar ->
+ if Evd.mem sigma0 k then map_constr put c else
+ let evi = Evd.find !sigma k in
+ let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in
+ let abs_dc (d, c) = function
+ | Context.Named.Declaration.LocalDef (x, b, t) ->
+ d, mkNamedLetIn x (put b) (put t) c
+ | Context.Named.Declaration.LocalAssum (x, t) ->
+ mkVar x :: d, mkNamedProd x (put t) c in
+ let a, t =
+ Context.Named.fold_inside abs_dc ~init:([], (put evi.evar_concl)) dc in
+ let m = Evarutil.new_meta () in
+ ise := meta_declare m t !ise;
+ sigma := Evd.define k (applist (mkMeta m, a)) !sigma;
+ put (existential_value !sigma ex)
+ end
+ | _ -> map_constr put c in
+ let c1 = put c0 in !ise, c1
+
+(* Compile a match pattern from a term; t is the term to fill. *)
+(* p_origin can be passed to obtain a better error message *)
+let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p =
+ let k, f, a =
+ let f, a = Reductionops.whd_betaiota_stack ise p in
+ match kind_of_term f with
+ | Const (p,_) ->
+ let np = proj_nparams p in
+ if np = 0 || np > List.length a then KpatConst, f, a else
+ let a1, a2 = List.chop np a in KpatProj p, applist(f, a1), a2
+ | Proj (p,arg) -> KpatProj (Projection.constant p), f, a
+ | Var _ | Ind _ | Construct _ -> KpatFixed, f, a
+ | Evar (k, _) ->
+ if Evd.mem sigma0 k then KpatEvar k, f, a else
+ if a <> [] then KpatFlex, f, a else
+ (match p_origin with None -> CErrors.error "indeterminate pattern"
+ | Some (dir, rule) ->
+ errorstrm (str "indeterminate " ++ pr_dir_side dir
+ ++ str " in " ++ pr_constr_pat rule))
+ | LetIn (_, v, _, b) ->
+ if b <> mkRel 1 then KpatLet, f, a else KpatFlex, v, a
+ | Lambda _ -> KpatLam, f, a
+ | _ -> KpatRigid, f, a in
+ let aa = Array.of_list a in
+ let ise', p' = evars_for_FO ~hack env sigma0 ise (mkApp (f, aa)) in
+ ise',
+ { up_k = k; up_FO = p'; up_f = f;
+ up_a = aa; up_ok = ok; up_dir = dir; up_t = t}
+
+(* Specialize a pattern after a successful match: assign a precise head *)
+(* kind and arity for Proj and Flex patterns. *)
+let ungen_upat lhs (sigma, uc, t) u =
+ let f, a = safeDestApp lhs in
+ let k = match kind_of_term f with
+ | Var _ | Ind _ | Construct _ -> KpatFixed
+ | Const _ -> KpatConst
+ | Evar (k, _) -> if is_defined sigma k then raise NoMatch else KpatEvar k
+ | LetIn _ -> KpatLet
+ | Lambda _ -> KpatLam
+ | _ -> KpatRigid in
+ sigma, uc, {u with up_k = k; up_FO = lhs; up_f = f; up_a = a; up_t = t}
+
+let nb_cs_proj_args pc f u =
+ let na k =
+ List.length (snd (lookup_canonical_conversion (ConstRef pc, k))).o_TCOMPS in
+ try match kind_of_term f with
+ | Prod _ -> na Prod_cs
+ | Sort s -> na (Sort_cs (family_of_sort s))
+ | Const (c',_) when Constant.equal c' pc ->
+ begin match kind_of_term u.up_f with
+ | App(_,args) -> Array.length args
+ | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be
+ the number of arguments including the projected *)
+ | _ -> assert false
+ end
+ | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f))
+ | _ -> -1
+ with Not_found -> -1
+
+let isEvar_k k f =
+ match kind_of_term f with Evar (k', _) -> k = k' | _ -> false
+
+let nb_args c =
+ match kind_of_term c with App (_, a) -> Array.length a | _ -> 0
+
+let mkSubArg i a = if i = Array.length a then a else Array.sub a 0 i
+let mkSubApp f i a = if i = 0 then f else mkApp (f, mkSubArg i a)
+
+let splay_app ise =
+ let rec loop c a = match kind_of_term c with
+ | App (f, a') -> loop f (Array.append a' a)
+ | Cast (c', _, _) -> loop c' a
+ | Evar ex ->
+ (try loop (existential_value ise ex) a with _ -> c, a)
+ | _ -> c, a in
+ fun c -> match kind_of_term c with
+ | App (f, a) -> loop f a
+ | Cast _ | Evar _ -> loop c [| |]
+ | _ -> c, [| |]
+
+let filter_upat i0 f n u fpats =
+ let na = Array.length u.up_a in
+ if n < na then fpats else
+ let np = match u.up_k with
+ | KpatConst when Term.eq_constr u.up_f f -> na
+ | KpatFixed when Term.eq_constr u.up_f f -> na
+ | KpatEvar k when isEvar_k k f -> na
+ | KpatLet when isLetIn f -> na
+ | KpatLam when isLambda f -> na
+ | KpatRigid when isRigid f -> na
+ | KpatFlex -> na
+ | KpatProj pc ->
+ let np = na + nb_cs_proj_args pc f u in if n < np then -1 else np
+ | _ -> -1 in
+ if np < na then fpats else
+ let () = if !i0 < np then i0 := n in (u, np) :: fpats
+
+let eq_prim_proj c t = match kind_of_term t with
+ | Proj(p,_) -> Constant.equal (Projection.constant p) c
+ | _ -> false
+
+let filter_upat_FO i0 f n u fpats =
+ let np = nb_args u.up_FO in
+ if n < np then fpats else
+ let ok = match u.up_k with
+ | KpatConst -> Term.eq_constr u.up_f f
+ | KpatFixed -> Term.eq_constr u.up_f f
+ | KpatEvar k -> isEvar_k k f
+ | KpatLet -> isLetIn f
+ | KpatLam -> isLambda f
+ | KpatRigid -> isRigid f
+ | KpatProj pc -> Term.eq_constr f (mkConst pc) || eq_prim_proj pc f
+ | KpatFlex -> i0 := n; true in
+ if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats
+
+exception FoundUnif of (evar_map * evar_universe_context * tpattern)
+(* Note: we don't update env as we descend into the term, as the primitive *)
+(* unification procedure always rejects subterms with bound variables. *)
+
+let dont_impact_evars_in cl =
+ let evs_in_cl = Evd.evars_of_term cl in
+ fun sigma -> Evar.Set.for_all (fun k ->
+ try let _ = Evd.find_undefined sigma k in true
+ with Not_found -> false) evs_in_cl
+
+(* We are forced to duplicate code between the FO/HO matching because we *)
+(* have to work around several kludges in unify.ml: *)
+(* - w_unify drops into second-order unification when the pattern is an *)
+(* application whose head is a meta. *)
+(* - w_unify tries to unify types without subsumption when the pattern *)
+(* head is an evar or meta (e.g., it fails on ?1 = nat when ?1 : Type). *)
+(* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *)
+(* match a head let rigidly. *)
+let match_upats_FO upats env sigma0 ise orig_c =
+ let dont_impact_evars = dont_impact_evars_in orig_c in
+ let rec loop c =
+ let f, a = splay_app ise c in let i0 = ref (-1) in
+ let fpats =
+ List.fold_right (filter_upat_FO i0 f (Array.length a)) upats [] in
+ while !i0 >= 0 do
+ let i = !i0 in i0 := -1;
+ let c' = mkSubApp f i a in
+ let one_match (u, np) =
+ let skip =
+ if i <= np then i < np else
+ if u.up_k == KpatFlex then begin i0 := i - 1; false end else
+ begin if !i0 < np then i0 := np; true end in
+ if skip || not (closed0 c') then () else try
+ let _ = match u.up_k with
+ | KpatFlex ->
+ let kludge v = mkLambda (Anonymous, mkProp, v) in
+ unif_FO env ise (kludge u.up_FO) (kludge c')
+ | KpatLet ->
+ let kludge vla =
+ let vl, a = safeDestApp vla in
+ let x, v, t, b = destLetIn vl in
+ mkApp (mkLambda (x, t, b), Array.cons v a) in
+ unif_FO env ise (kludge u.up_FO) (kludge c')
+ | _ -> unif_FO env ise u.up_FO c' in
+ let ise' = (* Unify again using HO to assign evars *)
+ let p = mkApp (u.up_f, u.up_a) in
+ try unif_HO env ise p c' with _ -> raise NoMatch in
+ let lhs = mkSubApp f i a in
+ let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in
+ raise (FoundUnif (ungen_upat lhs pt' u))
+ with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u
+ | Not_found -> CErrors.anomaly (str"incomplete ise in match_upats_FO")
+ | _ -> () in
+ List.iter one_match fpats
+ done;
+ iter_constr_LR loop f; Array.iter loop a in
+ try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO")
+
+let prof_FO = mk_profiler "match_upats_FO";;
+let match_upats_FO upats env sigma0 ise c =
+ prof_FO.profile (match_upats_FO upats env sigma0) ise c
+;;
+
+
+let match_upats_HO ~on_instance upats env sigma0 ise c =
+ let dont_impact_evars = dont_impact_evars_in c in
+ let it_did_match = ref false in
+ let failed_because_of_TC = ref false in
+ let rec aux upats env sigma0 ise c =
+ let f, a = splay_app ise c in let i0 = ref (-1) in
+ let fpats = List.fold_right (filter_upat i0 f (Array.length a)) upats [] in
+ while !i0 >= 0 do
+ let i = !i0 in i0 := -1;
+ let one_match (u, np) =
+ let skip =
+ if i <= np then i < np else
+ if u.up_k == KpatFlex then begin i0 := i - 1; false end else
+ begin if !i0 < np then i0 := np; true end in
+ if skip then () else try
+ let ise' = match u.up_k with
+ | KpatFixed | KpatConst -> ise
+ | KpatEvar _ ->
+ let _, pka = destEvar u.up_f and _, ka = destEvar f in
+ unif_HO_args env ise pka 0 ka
+ | KpatLet ->
+ let x, v, t, b = destLetIn f in
+ let _, pv, _, pb = destLetIn u.up_f in
+ let ise' = unif_HO env ise pv v in
+ unif_HO
+ (Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env)
+ ise' pb b
+ | KpatFlex | KpatProj _ ->
+ unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a)
+ | _ -> unif_HO env ise u.up_f f in
+ let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in
+ let lhs = mkSubApp f i a in
+ let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in
+ on_instance (ungen_upat lhs pt' u)
+ with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u
+ | NoProgress -> it_did_match := true
+ | Pretype_errors.PretypeError
+ (_,_,Pretype_errors.UnsatisfiableConstraints _) ->
+ failed_because_of_TC:=true
+ | e when CErrors.noncritical e -> () in
+ List.iter one_match fpats
+ done;
+ iter_constr_LR (aux upats env sigma0 ise) f;
+ Array.iter (aux upats env sigma0 ise) a
+ in
+ aux upats env sigma0 ise c;
+ if !it_did_match then raise NoProgress;
+ !failed_because_of_TC
+
+let prof_HO = mk_profiler "match_upats_HO";;
+let match_upats_HO ~on_instance upats env sigma0 ise c =
+ prof_HO.profile (match_upats_HO ~on_instance upats env sigma0) ise c
+;;
+
+
+let fixed_upat = function
+| {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false
+| {up_t = t} -> not (occur_existential t)
+
+let do_once r f = match !r with Some _ -> () | None -> r := Some (f ())
+
+let assert_done r =
+ match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called")
+
+let assert_done_multires r =
+ match !r with
+ | None -> CErrors.anomaly (str"do_once never called")
+ | Some (n, xs) ->
+ r := Some (n+1,xs);
+ try List.nth xs n with Failure _ -> raise NoMatch
+
+type subst = Environ.env -> Term.constr -> Term.constr -> int -> Term.constr
+type find_P =
+ Environ.env -> Term.constr -> int ->
+ k:subst ->
+ Term.constr
+type conclude = unit ->
+ Term.constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * Term.constr)
+
+(* upats_origin makes a better error message only *)
+let mk_tpattern_matcher ?(all_instances=false)
+ ?(raise_NoMatch=false) ?upats_origin sigma0 occ (ise, upats)
+=
+ let nocc = ref 0 and skip_occ = ref false in
+ let use_occ, occ_list = match occ with
+ | Some (true, ol) -> ol = [], ol
+ | Some (false, ol) -> ol <> [], ol
+ | None -> false, [] in
+ let max_occ = List.fold_right max occ_list 0 in
+ let subst_occ =
+ let occ_set = Array.make max_occ (not use_occ) in
+ let _ = List.iter (fun i -> occ_set.(i - 1) <- use_occ) occ_list in
+ let _ = if max_occ = 0 then skip_occ := use_occ in
+ fun () -> incr nocc;
+ if !nocc = max_occ then skip_occ := use_occ;
+ if !nocc <= max_occ then occ_set.(!nocc - 1) else not use_occ in
+ let upat_that_matched = ref None in
+ let match_EQ env sigma u =
+ match u.up_k with
+ | KpatLet ->
+ let x, pv, t, pb = destLetIn u.up_f in
+ let env' =
+ Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env in
+ let match_let f = match kind_of_term f with
+ | LetIn (_, v, _, b) -> unif_EQ env sigma pv v && unif_EQ env' sigma pb b
+ | _ -> false in match_let
+ | KpatFixed -> Term.eq_constr u.up_f
+ | KpatConst -> Term.eq_constr u.up_f
+ | KpatLam -> fun c ->
+ (match kind_of_term c with
+ | Lambda _ -> unif_EQ env sigma u.up_f c
+ | _ -> false)
+ | _ -> unif_EQ env sigma u.up_f in
+let p2t p = mkApp(p.up_f,p.up_a) in
+let source () = match upats_origin, upats with
+ | None, [p] ->
+ (if fixed_upat p then str"term " else str"partial term ") ++
+ pr_constr_pat (p2t p) ++ spc()
+ | Some (dir,rule), [p] -> str"The " ++ pr_dir_side dir ++ str" of " ++
+ pr_constr_pat rule ++ fnl() ++ ws 4 ++ pr_constr_pat (p2t p) ++ fnl()
+ | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++
+ pr_constr_pat rule ++ spc()
+ | _, [] | None, _::_::_ ->
+ CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in
+let on_instance, instances =
+ let instances = ref [] in
+ (fun x ->
+ if all_instances then instances := !instances @ [x]
+ else raise (FoundUnif x)),
+ (fun () -> !instances) in
+let rec uniquize = function
+ | [] -> []
+ | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs ->
+ let t = Reductionops.nf_evar sigma t in
+ let f = Reductionops.nf_evar sigma f in
+ let a = Array.map (Reductionops.nf_evar sigma) a in
+ let neq (sigma1,_,{ up_f = f1; up_a = a1; up_t = t1 }) =
+ let t1 = Reductionops.nf_evar sigma1 t1 in
+ let f1 = Reductionops.nf_evar sigma1 f1 in
+ let a1 = Array.map (Reductionops.nf_evar sigma1) a1 in
+ not (Term.eq_constr t t1 &&
+ Term.eq_constr f f1 && CArray.for_all2 Term.eq_constr a a1) in
+ x :: uniquize (List.filter neq xs) in
+
+((fun env c h ~k ->
+ do_once upat_that_matched (fun () ->
+ let failed_because_of_TC = ref false in
+ try
+ if not all_instances then match_upats_FO upats env sigma0 ise c;
+ failed_because_of_TC:=match_upats_HO ~on_instance upats env sigma0 ise c;
+ raise NoMatch
+ with FoundUnif sigma_u -> 0,[sigma_u]
+ | (NoMatch|NoProgress) when all_instances && instances () <> [] ->
+ 0, uniquize (instances ())
+ | NoMatch when (not raise_NoMatch) ->
+ if !failed_because_of_TC then
+ errorstrm (source ()++strbrk"matches but type classes inference fails")
+ else
+ errorstrm (source () ++ str "does not match any subterm of the goal")
+ | NoProgress when (not raise_NoMatch) ->
+ let dir = match upats_origin with Some (d,_) -> d | _ ->
+ CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in
+ errorstrm (str"all matches of "++source()++
+ str"are equal to the " ++ pr_dir_side (inv_dir dir))
+ | NoProgress -> raise NoMatch);
+ let sigma, _, ({up_f = pf; up_a = pa} as u) =
+ if all_instances then assert_done_multires upat_that_matched
+ else List.hd (snd(assert_done upat_that_matched)) in
+(* pp(lazy(str"sigma@tmatch=" ++ pr_evar_map None sigma)); *)
+ if !skip_occ then ((*ignore(k env u.up_t 0);*) c) else
+ let match_EQ = match_EQ env sigma u in
+ let pn = Array.length pa in
+ let rec subst_loop (env,h as acc) c' =
+ if !skip_occ then c' else
+ let f, a = splay_app sigma c' in
+ if Array.length a >= pn && match_EQ f && unif_EQ_args env sigma pa a then
+ let a1, a2 = Array.chop (Array.length pa) a in
+ let fa1 = mkApp (f, a1) in
+ let f' = if subst_occ () then k env u.up_t fa1 h else fa1 in
+ mkApp (f', Array.map_left (subst_loop acc) a2)
+ else
+ (* TASSI: clear letin values to avoid unfolding *)
+ let inc_h rd (env,h') =
+ let ctx_item =
+ match rd with
+ | Context.Rel.Declaration.LocalAssum _ as x -> x
+ | Context.Rel.Declaration.LocalDef (x,_,y) ->
+ Context.Rel.Declaration.LocalAssum(x,y) in
+ Environ.push_rel ctx_item env, h' + 1 in
+ let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in
+ mkApp (f', Array.map_left (subst_loop acc) a) in
+ subst_loop (env,h) c) : find_P),
+((fun () ->
+ let sigma, uc, ({up_f = pf; up_a = pa} as u) =
+ match !upat_that_matched with
+ | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch
+ | None -> CErrors.anomaly (str"companion function never called") in
+ let p' = mkApp (pf, pa) in
+ if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t)
+ else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++
+ str(String.plural !nocc " occurence") ++ match upats_origin with
+ | None -> str" of" ++ spc() ++ pr_constr_pat p'
+ | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++
+ ws 4 ++ pr_constr_pat p' ++ fnl () ++
+ str"of " ++ pr_constr_pat rule)) : conclude)
+
+type ('ident, 'term) ssrpattern =
+ | T of 'term
+ | In_T of 'term
+ | X_In_T of 'ident * 'term
+ | In_X_In_T of 'ident * 'term
+ | E_In_X_In_T of 'term * 'ident * 'term
+ | E_As_X_In_T of 'term * 'ident * 'term
+
+let pr_pattern = function
+ | T t -> prl_term t
+ | In_T t -> str "in " ++ prl_term t
+ | X_In_T (x,t) -> prl_term x ++ str " in " ++ prl_term t
+ | In_X_In_T (x,t) -> str "in " ++ prl_term x ++ str " in " ++ prl_term t
+ | E_In_X_In_T (e,x,t) ->
+ prl_term e ++ str " in " ++ prl_term x ++ str " in " ++ prl_term t
+ | E_As_X_In_T (e,x,t) ->
+ prl_term e ++ str " as " ++ prl_term x ++ str " in " ++ prl_term t
+
+let pr_pattern_w_ids = function
+ | T t -> prl_term t
+ | In_T t -> str "in " ++ prl_term t
+ | X_In_T (x,t) -> pr_id x ++ str " in " ++ prl_term t
+ | In_X_In_T (x,t) -> str "in " ++ pr_id x ++ str " in " ++ prl_term t
+ | E_In_X_In_T (e,x,t) ->
+ prl_term e ++ str " in " ++ pr_id x ++ str " in " ++ prl_term t
+ | E_As_X_In_T (e,x,t) ->
+ prl_term e ++ str " as " ++ pr_id x ++ str " in " ++ prl_term t
+
+let pr_pattern_aux pr_constr = function
+ | T t -> pr_constr t
+ | In_T t -> str "in " ++ pr_constr t
+ | X_In_T (x,t) -> pr_constr x ++ str " in " ++ pr_constr t
+ | In_X_In_T (x,t) -> str "in " ++ pr_constr x ++ str " in " ++ pr_constr t
+ | E_In_X_In_T (e,x,t) ->
+ pr_constr e ++ str " in " ++ pr_constr x ++ str " in " ++ pr_constr t
+ | E_As_X_In_T (e,x,t) ->
+ pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t
+let pp_pattern (sigma, p) =
+ pr_pattern_aux (fun t -> pr_constr_pat (pi3 (nf_open_term sigma sigma t))) p
+let pr_cpattern = pr_term
+let pr_rpattern _ _ _ = pr_pattern
+
+let pr_option f = function None -> mt() | Some x -> f x
+let pr_ssrpattern _ _ _ = pr_option pr_pattern
+let pr_pattern_squarep = pr_option (fun r -> str "[" ++ pr_pattern r ++ str "]")
+let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep
+let pr_pattern_roundp = pr_option (fun r -> str "(" ++ pr_pattern r ++ str ")")
+let pr_ssrpattern_roundp _ _ _ = pr_pattern_roundp
+
+let wit_rpatternty = add_genarg "rpatternty" pr_pattern
+
+let glob_ssrterm gs = function
+ | k, (_, Some c) -> k,
+ let x = Tacintern.intern_constr gs c in
+ fst x, Some c
+ | ct -> ct
+
+(* This piece of code asserts the following notations are reserved *)
+(* Reserved Notation "( a 'in' b )" (at level 0). *)
+(* Reserved Notation "( a 'as' b )" (at level 0). *)
+(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *)
+(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *)
+let glob_cpattern gs p =
+ pp(lazy(str"globbing pattern: " ++ pr_term p));
+ let glob x = snd (glob_ssrterm gs (mk_lterm x)) in
+ let encode k s l =
+ let name = Name (id_of_string ("_ssrpat_" ^ s)) in
+ k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in
+ let bind_in t1 t2 =
+ let d = dummy_loc in let n = Name (destCVar t1) in
+ fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in
+ let check_var t2 = if not (isCVar t2) then
+ loc_error (constr_loc t2) "Only identifiers are allowed here" in
+ match p with
+ | _, (_, None) as x -> x
+ | k, (v, Some t) as orig ->
+ if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else
+ match t with
+ | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) ->
+ (try match glob t1, glob t2 with
+ | (r1, None), (r2, None) -> encode k "In" [r1;r2]
+ | (r1, Some _), (r2, Some _) when isCVar t1 ->
+ encode k "In" [r1; r2; bind_in t1 t2]
+ | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2]
+ | _ -> CErrors.anomaly (str"where are we?")
+ with _ when isCVar t1 -> encode k "In" [bind_in t1 t2])
+ | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) ->
+ check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3]
+ | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) ->
+ encode k "As" [fst (glob t1); fst (glob t2)]
+ | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) ->
+ check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3]
+ | _ -> glob_ssrterm gs orig
+;;
+
+let glob_rpattern s p =
+ match p with
+ | T t -> T (glob_cpattern s t)
+ | In_T t -> In_T (glob_ssrterm s t)
+ | X_In_T(x,t) -> X_In_T (x,glob_ssrterm s t)
+ | In_X_In_T(x,t) -> In_X_In_T (x,glob_ssrterm s t)
+ | E_In_X_In_T(e,x,t) -> E_In_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t)
+ | E_As_X_In_T(e,x,t) -> E_As_X_In_T (glob_ssrterm s e,x,glob_ssrterm s t)
+
+let subst_ssrterm s (k, c) = k, Tacsubst.subst_glob_constr_and_expr s c
+
+let subst_rpattern s = function
+ | T t -> T (subst_ssrterm s t)
+ | In_T t -> In_T (subst_ssrterm s t)
+ | X_In_T(x,t) -> X_In_T (x,subst_ssrterm s t)
+ | In_X_In_T(x,t) -> In_X_In_T (x,subst_ssrterm s t)
+ | E_In_X_In_T(e,x,t) -> E_In_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t)
+ | E_As_X_In_T(e,x,t) -> E_As_X_In_T (subst_ssrterm s e,x,subst_ssrterm s t)
+
+ARGUMENT EXTEND rpattern
+ TYPED AS rpatternty
+ PRINTED BY pr_rpattern
+ GLOBALIZED BY glob_rpattern
+ SUBSTITUTED BY subst_rpattern
+ | [ lconstr(c) ] -> [ T (mk_lterm c) ]
+ | [ "in" lconstr(c) ] -> [ In_T (mk_lterm c) ]
+ | [ lconstr(x) "in" lconstr(c) ] ->
+ [ X_In_T (mk_lterm x, mk_lterm c) ]
+ | [ "in" lconstr(x) "in" lconstr(c) ] ->
+ [ In_X_In_T (mk_lterm x, mk_lterm c) ]
+ | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] ->
+ [ E_In_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ]
+ | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] ->
+ [ E_As_X_In_T (mk_lterm e, mk_lterm x, mk_lterm c) ]
+END
+
+
+
+type cpattern = char * glob_constr_and_expr
+let tag_of_cpattern = fst
+let loc_of_cpattern = loc_ofCG
+let cpattern_of_term t = t
+type occ = (bool * int list) option
+
+type rpattern = (cpattern, cpattern) ssrpattern
+let pr_rpattern = pr_pattern
+
+type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern
+
+
+let id_of_cpattern = function
+ | _,(_,Some (CRef (Ident (_, x), _))) -> Some x
+ | _,(_,Some (CAppExpl (_, (_, Ident (_, x), _), []))) -> Some x
+ | _,(GRef (_, VarRef x, _) ,None) -> Some x
+ | _ -> None
+let id_of_Cterm t = match id_of_cpattern t with
+ | Some x -> x
+ | None -> loc_error (loc_of_cpattern t) "Only identifiers are allowed here"
+
+let of_ftactic ftac gl =
+ let r = ref None in
+ let tac = Ftactic.run ftac (fun ans -> r := Some ans; Proofview.tclUNIT ()) in
+ let tac = Proofview.V82.of_tactic tac in
+ let { sigma = sigma } = tac gl in
+ let ans = match !r with
+ | None -> assert false (** If the tactic failed we should not reach this point *)
+ | Some ans -> ans
+ in
+ (sigma, ans)
+
+let interp_wit wit ist gl x =
+ let globarg = in_gen (glbwit wit) x in
+ let arg = interp_genarg ist globarg in
+ let (sigma, arg) = of_ftactic arg gl in
+ sigma, Value.cast (topwit wit) arg
+let interp_constr = interp_wit wit_constr
+let interp_open_constr ist gl gc =
+ interp_wit wit_open_constr ist gl gc
+let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c
+let interp_term ist gl (_, c) = (interp_open_constr ist gl c)
+let pr_ssrterm _ _ _ = pr_term
+let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with
+ | Tok.KEYWORD "(" -> '('
+ | Tok.KEYWORD "@" -> '@'
+ | _ -> ' '
+let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind
+
+let interp_ssrterm _ gl t = Tacmach.project gl, t
+
+ARGUMENT EXTEND cpattern
+ PRINTED BY pr_ssrterm
+ INTERPRETED BY interp_ssrterm
+ GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm
+ RAW_PRINTED BY pr_ssrterm
+ GLOB_PRINTED BY pr_ssrterm
+| [ "Qed" constr(c) ] -> [ mk_lterm c ]
+END
+
+let (!@) = Compat.to_coqloc
+
+GEXTEND Gram
+ GLOBAL: cpattern;
+ cpattern: [[ k = ssrtermkind; c = constr ->
+ let pattern = mk_term k c in
+ if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]];
+END
+
+ARGUMENT EXTEND lcpattern
+ TYPED AS cpattern
+ PRINTED BY pr_ssrterm
+ INTERPRETED BY interp_ssrterm
+ GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm
+ RAW_PRINTED BY pr_ssrterm
+ GLOB_PRINTED BY pr_ssrterm
+| [ "Qed" lconstr(c) ] -> [ mk_lterm c ]
+END
+
+GEXTEND Gram
+ GLOBAL: lcpattern;
+ lcpattern: [[ k = ssrtermkind; c = lconstr ->
+ let pattern = mk_term k c in
+ if loc_ofCG pattern <> !@loc && k = '(' then mk_term 'x' c else pattern ]];
+END
+
+let thin id sigma goal =
+ let ids = Id.Set.singleton id in
+ let env = Goal.V82.env sigma goal in
+ let cl = Goal.V82.concl sigma goal in
+ let evdref = ref (Evd.clear_metas sigma) in
+ let ans =
+ try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids)
+ with Evarutil.ClearDependencyError _ -> None
+ in
+ match ans with
+ | None -> sigma
+ | Some (hyps, concl) ->
+ let sigma = !evdref in
+ let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in
+ let sigma = Goal.V82.partial_solution_to sigma goal gl ev in
+ sigma
+
+let pr_ist { lfun= lfun } =
+ prlist_with_sep spc
+ (fun (id, Geninterp.Val.Dyn(ty,_)) ->
+ pr_id id ++ str":" ++ Geninterp.Val.pr ty) (Id.Map.bindings lfun)
+
+let interp_pattern ?wit_ssrpatternarg ist gl red redty =
+ pp(lazy(str"interpreting: " ++ pr_pattern red));
+ pp(lazy(str" in ist: " ++ pr_ist ist));
+ let xInT x y = X_In_T(x,y) and inXInT x y = In_X_In_T(x,y) in
+ let inT x = In_T x and eInXInT e x t = E_In_X_In_T(e,x,t) in
+ let eAsXInT e x t = E_As_X_In_T(e,x,t) in
+ let mkG ?(k=' ') x = k,(x,None) in
+ let decode ist t ?reccall f g =
+ try match (pf_intern_term ist gl t) with
+ | GCast(_,GHole _,CastConv(GLambda(_,Name x,_,_,c))) -> f x (' ',(c,None))
+ | GVar(_,id)
+ when Id.Map.mem id ist.lfun &&
+ not(Option.is_empty reccall) &&
+ not(Option.is_empty wit_ssrpatternarg) ->
+ let v = Id.Map.find id ist.lfun in
+ Option.get reccall
+ (Value.cast (topwit (Option.get wit_ssrpatternarg)) v)
+ | it -> g t with e when CErrors.noncritical e -> g t in
+ let decodeG t f g = decode ist (mkG t) f g in
+ let bad_enc id _ = CErrors.anomaly (str"bad encoding for pattern "++str id) in
+ let cleanup_XinE h x rp sigma =
+ let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in
+ let to_clean, update = (* handle rename if x is already used *)
+ let ctx = pf_hyps gl in
+ let len = Context.Named.length ctx in
+ let name = ref None in
+ try ignore(Context.Named.lookup x ctx); (name, fun k ->
+ if !name = None then
+ let nctx = Evd.evar_context (Evd.find sigma k) in
+ let nlen = Context.Named.length nctx in
+ if nlen > len then begin
+ name := Some (Context.Named.Declaration.get_id (List.nth nctx (nlen - len - 1)))
+ end)
+ with Not_found -> ref (Some x), fun _ -> () in
+ let sigma0 = project gl in
+ let new_evars =
+ let rec aux acc t = match kind_of_term t with
+ | Evar (k,_) ->
+ if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else
+ (update k; k::acc)
+ | _ -> fold_constr aux acc t in
+ aux [] (Evarutil.nf_evar sigma rp) in
+ let sigma =
+ List.fold_left (fun sigma e ->
+ if Evd.is_defined sigma e then sigma else (* clear may be recursive *)
+ if Option.is_empty !to_clean then sigma else
+ let name = Option.get !to_clean in
+ pp(lazy(pr_id name));
+ thin name sigma e)
+ sigma new_evars in
+ sigma in
+ let red = let rec decode_red (ist,red) = match red with
+ | T(k,(GCast (_,GHole _,(CastConv(GLambda (_,Name id,_,_,t)))),None))
+ when let id = string_of_id id in let len = String.length id in
+ (len > 8 && String.sub id 0 8 = "_ssrpat_") ->
+ let id = string_of_id id in let len = String.length id in
+ (match String.sub id 8 (len - 8), t with
+ | "In", GApp(_, _, [t]) -> decodeG t xInT (fun x -> T x)
+ | "In", GApp(_, _, [e; t]) -> decodeG t (eInXInT (mkG e)) (bad_enc id)
+ | "In", GApp(_, _, [e; t; e_in_t]) ->
+ decodeG t (eInXInT (mkG e))
+ (fun _ -> decodeG e_in_t xInT (fun _ -> assert false))
+ | "As", GApp(_, _, [e; t]) -> decodeG t (eAsXInT (mkG e)) (bad_enc id)
+ | _ -> bad_enc id ())
+ | T t -> decode ist ~reccall:decode_red t xInT (fun x -> T x)
+ | In_T t -> decode ist t inXInT inT
+ | X_In_T (e,t) -> decode ist t (eInXInT e) (fun x -> xInT (id_of_Cterm e) x)
+ | In_X_In_T (e,t) -> inXInT (id_of_Cterm e) t
+ | E_In_X_In_T (e,x,rp) -> eInXInT e (id_of_Cterm x) rp
+ | E_As_X_In_T (e,x,rp) -> eAsXInT e (id_of_Cterm x) rp in
+ decode_red (ist,red) in
+ pp(lazy(str"decoded as: " ++ pr_pattern_w_ids red));
+ let red = match redty with None -> red | Some ty -> let ty = ' ', ty in
+ match red with
+ | T t -> T (combineCG t ty (mkCCast (loc_ofCG t)) mkRCast)
+ | X_In_T (x,t) ->
+ let ty = pf_intern_term ist gl ty in
+ E_As_X_In_T (mkG (mkRCast mkRHole ty), x, t)
+ | E_In_X_In_T (e,x,t) ->
+ let ty = mkG (pf_intern_term ist gl ty) in
+ E_In_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t)
+ | E_As_X_In_T (e,x,t) ->
+ let ty = mkG (pf_intern_term ist gl ty) in
+ E_As_X_In_T (combineCG e ty (mkCCast (loc_ofCG t)) mkRCast, x, t)
+ | red -> red in
+ pp(lazy(str"typed as: " ++ pr_pattern_w_ids red));
+ let mkXLetIn loc x (a,(g,c)) = match c with
+ | Some b -> a,(g,Some (mkCLetIn loc x (mkCHole loc) b))
+ | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), g), None) in
+ match red with
+ | T t -> let sigma, t = interp_term ist gl t in sigma, T t
+ | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t
+ | X_In_T (x, rp) | In_X_In_T (x, rp) ->
+ let mk x p = match red with X_In_T _ -> X_In_T(x,p) | _ -> In_X_In_T(x,p) in
+ let rp = mkXLetIn dummy_loc (Name x) rp in
+ let sigma, rp = interp_term ist gl rp in
+ let _, h, _, rp = destLetIn rp in
+ let sigma = cleanup_XinE h x rp sigma in
+ let rp = subst1 h (Evarutil.nf_evar sigma rp) in
+ sigma, mk h rp
+ | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) ->
+ let mk e x p =
+ match red with E_In_X_In_T _ ->E_In_X_In_T(e,x,p)|_->E_As_X_In_T(e,x,p) in
+ let rp = mkXLetIn dummy_loc (Name x) rp in
+ let sigma, rp = interp_term ist gl rp in
+ let _, h, _, rp = destLetIn rp in
+ let sigma = cleanup_XinE h x rp sigma in
+ let rp = subst1 h (Evarutil.nf_evar sigma rp) in
+ let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in
+ sigma, mk e h rp
+;;
+let interp_cpattern ist gl red redty = interp_pattern ist gl (T red) redty;;
+let interp_rpattern ~wit_ssrpatternarg ist gl red = interp_pattern ~wit_ssrpatternarg ist gl red None;;
+
+let id_of_pattern = function
+ | _, T t -> (match kind_of_term t with Var id -> Some id | _ -> None)
+ | _ -> None
+
+(* The full occurrence set *)
+let noindex = Some(false,[])
+
+(* calls do_subst on every sub-term identified by (pattern,occ) *)
+let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst =
+ let fs sigma x = Reductionops.nf_evar sigma x in
+ let pop_evar sigma e p =
+ let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in
+ let e_body = match e_body with Evar_defined c -> c
+ | _ -> errorstrm (str "Matching the pattern " ++ pr_constr p ++
+ str " did not instantiate ?" ++ int (Evar.repr e) ++ spc () ++
+ str "Does the variable bound by the \"in\" construct occur "++
+ str "in the pattern?") in
+ let sigma =
+ Evd.add (Evd.remove sigma e) e {e_def with Evd.evar_body = Evar_empty} in
+ sigma, e_body in
+ let ex_value hole =
+ match kind_of_term hole with Evar (e,_) -> e | _ -> assert false in
+ let mk_upat_for ?hack env sigma0 (sigma, t) ?(p=t) ok =
+ let sigma,pat= mk_tpattern ?hack env sigma0 (sigma,p) ok L2R (fs sigma t) in
+ sigma, [pat] in
+ match pattern with
+ | None -> do_subst env0 concl0 concl0 1
+ | Some (sigma, (T rp | In_T rp)) ->
+ let rp = fs sigma rp in
+ let ise = create_evar_defs sigma in
+ let occ = match pattern with Some (_, T _) -> occ | _ -> noindex in
+ let rp = mk_upat_for env0 sigma0 (ise, rp) all_ok in
+ let find_T, end_T = mk_tpattern_matcher ?raise_NoMatch sigma0 occ rp in
+ let concl = find_T env0 concl0 1 do_subst in
+ let _ = end_T () in
+ concl
+ | Some (sigma, (X_In_T (hole, p) | In_X_In_T (hole, p))) ->
+ let p = fs sigma p in
+ let occ = match pattern with Some (_, X_In_T _) -> occ | _ -> noindex in
+ let ex = ex_value hole in
+ let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in
+ let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in
+ (* we start from sigma, so hole is considered a rigid head *)
+ let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in
+ let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in
+ let concl = find_T env0 concl0 1 (fun env c _ h ->
+ let p_sigma = unify_HO env (create_evar_defs sigma) c p in
+ let sigma, e_body = pop_evar p_sigma ex p in
+ fs p_sigma (find_X env (fs sigma p) h
+ (fun env _ -> do_subst env e_body))) in
+ let _ = end_X () in let _ = end_T () in
+ concl
+ | Some (sigma, E_In_X_In_T (e, hole, p)) ->
+ let p, e = fs sigma p, fs sigma e in
+ let ex = ex_value hole in
+ let rp = mk_upat_for ~hack:true env0 sigma0 (sigma, p) all_ok in
+ let find_T, end_T = mk_tpattern_matcher sigma0 noindex rp in
+ let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in
+ let find_X, end_X = mk_tpattern_matcher sigma noindex holep in
+ let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in
+ let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in
+ let concl = find_T env0 concl0 1 (fun env c _ h ->
+ let p_sigma = unify_HO env (create_evar_defs sigma) c p in
+ let sigma, e_body = pop_evar p_sigma ex p in
+ fs p_sigma (find_X env (fs sigma p) h (fun env c _ h ->
+ find_E env e_body h do_subst))) in
+ let _ = end_E () in let _ = end_X () in let _ = end_T () in
+ concl
+ | Some (sigma, E_As_X_In_T (e, hole, p)) ->
+ let p, e = fs sigma p, fs sigma e in
+ let ex = ex_value hole in
+ let rp =
+ let e_sigma = unify_HO env0 sigma hole e in
+ e_sigma, fs e_sigma p in
+ let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in
+ let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in
+ let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in
+ let find_X, end_X = mk_tpattern_matcher sigma occ holep in
+ let concl = find_TE env0 concl0 1 (fun env c _ h ->
+ let p_sigma = unify_HO env (create_evar_defs sigma) c p in
+ let sigma, e_body = pop_evar p_sigma ex p in
+ fs p_sigma (find_X env (fs sigma p) h (fun env c _ h ->
+ let e_sigma = unify_HO env sigma e_body e in
+ let e_body = fs e_sigma e in
+ do_subst env e_body e_body h))) in
+ let _ = end_X () in let _ = end_TE () in
+ concl
+;;
+
+let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) =
+ let e = match p with
+ | In_T _ | In_X_In_T _ -> CErrors.anomaly (str"pattern without redex")
+ | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in
+ let sigma =
+ if not resolve_typeclasses then sigma
+ else Typeclasses.resolve_typeclasses ~fail:false env sigma in
+ Reductionops.nf_evar sigma e, Evd.evar_universe_context sigma
+
+let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h =
+ let do_make_rel, occ =
+ if occ = Some(true,[]) then false, Some(false,[1]) else true, occ in
+ let find_R, conclude =
+ let r = ref None in
+ (fun env c _ h' ->
+ do_once r (fun () -> c, Evd.empty_evar_universe_context);
+ if do_make_rel then mkRel (h'+h-1) else c),
+ (fun _ -> if !r = None then redex_of_pattern env pat else assert_done r) in
+ let cl = eval_pattern ?raise_NoMatch env sigma cl (Some pat) occ find_R in
+ let e = conclude cl in
+ e, cl
+;;
+
+(* clenup interface for external use *)
+let mk_tpattern ?p_origin env sigma0 sigma_t f dir c =
+ mk_tpattern ?p_origin env sigma0 sigma_t f dir c
+;;
+
+let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h =
+ let ise = create_evar_defs sigma in
+ let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in
+ let find_U, end_U =
+ mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in
+ let concl = find_U env concl h (fun _ _ _ -> mkRel) in
+ let rdx, _, (sigma, uc, p) = end_U () in
+ sigma, uc, p, concl, rdx
+
+let fill_occ_term env cl occ sigma0 (sigma, t) =
+ try
+ let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in
+ if sigma' != sigma0 then CErrors.error "matching impacts evars"
+ else cl, (Evd.merge_universe_context sigma' uc, t')
+ with NoMatch -> try
+ let sigma', uc, t' =
+ unif_end env sigma0 (create_evar_defs sigma) t (fun _ -> true) in
+ if sigma' != sigma0 then raise NoMatch
+ else cl, (Evd.merge_universe_context sigma' uc, t')
+ with _ ->
+ errorstrm (str "partial term " ++ pr_constr_pat t
+ ++ str " does not match any subterm of the goal")
+
+let pf_fill_occ_term gl occ t =
+ let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in
+ let cl,(_,t) = fill_occ_term env concl occ sigma0 t in
+ cl, t
+
+let cpattern_of_id id = ' ', (GRef (dummy_loc, VarRef id, None), None)
+
+let is_wildcard = function
+ | _,(_,Some (CHole _)|GHole _,None) -> true
+ | _ -> false
+
+(* "ssrpattern" *)
+let pr_ssrpatternarg _ _ _ (_,cpat) = pr_rpattern cpat
+let pr_ssrpatternarg_glob _ _ _ cpat = pr_rpattern cpat
+let interp_ssrpatternarg ist gl p = project gl, (ist, p)
+
+ARGUMENT EXTEND ssrpatternarg
+ PRINTED BY pr_ssrpatternarg
+ INTERPRETED BY interp_ssrpatternarg
+ GLOBALIZED BY glob_rpattern
+ RAW_PRINTED BY pr_ssrpatternarg_glob
+ GLOB_PRINTED BY pr_ssrpatternarg_glob
+| [ rpattern(pat) ] -> [ pat ]
+END
+
+let pf_merge_uc uc gl =
+ re_sig (sig_it gl) (Evd.merge_universe_context (project gl) uc)
+
+let pf_unsafe_merge_uc uc gl =
+ re_sig (sig_it gl) (Evd.set_universe_context (project gl) uc)
+
+let interp_rpattern ist gl red = interp_rpattern ~wit_ssrpatternarg ist gl red
+
+let ssrpatterntac _ist (arg_ist,arg) gl =
+ let pat = interp_rpattern arg_ist gl arg in
+ let sigma0 = project gl in
+ let concl0 = pf_concl gl in
+ let (t, uc), concl_x =
+ fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in
+ let gl, tty = pf_type_of gl t in
+ let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in
+ Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl
+
+(* Register "ssrpattern" tactic *)
+let () =
+ let mltac _ ist =
+ let arg =
+ let v = Id.Map.find (Names.Id.of_string "pattern") ist.lfun in
+ Value.cast (topwit wit_ssrpatternarg) v in
+ Proofview.V82.tactic (ssrpatterntac ist arg) in
+ let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in
+ let () = Tacenv.register_ml_tactic name [|mltac|] in
+ let tac =
+ TacFun ([Some (Id.of_string "pattern")],
+ TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in
+ let obj () =
+ Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in
+ Mltop.declare_cache_obj obj "ssrmatching_plugin"
+
+let ssrinstancesof ist arg gl =
+ let ok rhs lhs ise = true in
+(* not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) in *)
+ let env, sigma, concl = pf_env gl, project gl, pf_concl gl in
+ let sigma0, cpat = interp_cpattern ist gl arg None in
+ let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in
+ let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in
+ let find, conclude =
+ mk_tpattern_matcher ~all_instances:true ~raise_NoMatch:true
+ sigma None (etpat,[tpat]) in
+ let print env p c _ = ppnl (hov 1 (str"instance:" ++ spc() ++ pr_constr p ++ spc() ++ str "matches:" ++ spc() ++ pr_constr c)); c in
+ ppnl (str"BEGIN INSTANCES");
+ try
+ while true do
+ ignore(find env concl 1 ~k:print)
+ done; raise NoMatch
+ with NoMatch -> ppnl (str"END INSTANCES"); tclIDTAC gl
+
+TACTIC EXTEND ssrinstoftpat
+| [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof ist arg) ]
+END
+
+(* We wipe out all the keywords generated by the grammar rules we defined. *)
+(* The user is supposed to Require Import ssreflect or Require ssreflect *)
+(* and Import ssreflect.SsrSyntax to obtain these keywords and as a *)
+(* consequence the extended ssreflect grammar. *)
+let () = CLexer.unfreeze frozen_lexer ;;
+
+(* vim: set filetype=ocaml foldmethod=marker: *)
diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli
new file mode 100644
index 00000000..288a04e6
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching.mli
@@ -0,0 +1,241 @@
+(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *)
+(* Distributed under the terms of CeCILL-B. *)
+
+open Genarg
+open Tacexpr
+open Environ
+open Tacmach
+open Evd
+open Proof_type
+open Term
+
+(** ******** Small Scale Reflection pattern matching facilities ************* *)
+
+(** Pattern parsing *)
+
+(** The type of context patterns, the patterns of the [set] tactic and
+ [:] tactical. These are patterns that identify a precise subterm. *)
+type cpattern
+val pr_cpattern : cpattern -> Pp.std_ppcmds
+
+(** CS cpattern: (f _), (X in t), (t in X in t), (t as X in t) *)
+val cpattern : cpattern Pcoq.Gram.entry
+val wit_cpattern : cpattern uniform_genarg_type
+
+(** OS cpattern: f _, (X in t), (t in X in t), (t as X in t) *)
+val lcpattern : cpattern Pcoq.Gram.entry
+val wit_lcpattern : cpattern uniform_genarg_type
+
+(** The type of rewrite patterns, the patterns of the [rewrite] tactic.
+ These patterns also include patterns that identify all the subterms
+ of a context (i.e. "in" prefix) *)
+type rpattern
+val pr_rpattern : rpattern -> Pp.std_ppcmds
+
+(** OS rpattern: f _, in t, X in t, in X in t, t in X in t, t as X in t *)
+val rpattern : rpattern Pcoq.Gram.entry
+val wit_rpattern : rpattern uniform_genarg_type
+
+(** Pattern interpretation and matching *)
+
+exception NoMatch
+exception NoProgress
+
+(** AST for [rpattern] (and consequently [cpattern]) *)
+type ('ident, 'term) ssrpattern =
+ | T of 'term
+ | In_T of 'term
+ | X_In_T of 'ident * 'term
+ | In_X_In_T of 'ident * 'term
+ | E_In_X_In_T of 'term * 'ident * 'term
+ | E_As_X_In_T of 'term * 'ident * 'term
+
+type pattern = evar_map * (constr, constr) ssrpattern
+val pp_pattern : pattern -> Pp.std_ppcmds
+
+(** Extracts the redex and applies to it the substitution part of the pattern.
+ @raise Anomaly if called on [In_T] or [In_X_In_T] *)
+val redex_of_pattern :
+ ?resolve_typeclasses:bool -> env -> pattern ->
+ constr Evd.in_evar_universe_context
+
+(** [interp_rpattern ise gl rpat] "internalizes" and "interprets" [rpat]
+ in the current [Ltac] interpretation signature [ise] and tactic input [gl]*)
+val interp_rpattern :
+ Tacinterp.interp_sign -> goal sigma ->
+ rpattern ->
+ pattern
+
+(** [interp_cpattern ise gl cpat ty] "internalizes" and "interprets" [cpat]
+ in the current [Ltac] interpretation signature [ise] and tactic input [gl].
+ [ty] is an optional type for the redex of [cpat] *)
+val interp_cpattern :
+ Tacinterp.interp_sign -> goal sigma ->
+ cpattern -> glob_constr_and_expr option ->
+ pattern
+
+(** The set of occurrences to be matched. The boolean is set to true
+ * to signal the complement of this set (i.e. {-1 3}) *)
+type occ = (bool * int list) option
+
+(** [subst e p t i]. [i] is the number of binders
+ traversed so far, [p] the term from the pattern, [t] the matched one *)
+type subst = env -> constr -> constr -> int -> constr
+
+(** [eval_pattern b env sigma t pat occ subst] maps [t] calling [subst] on every
+ [occ] occurrence of [pat]. The [int] argument is the number of
+ binders traversed. If [pat] is [None] then then subst is called on [t].
+ [t] must live in [env] and [sigma], [pat] must have been interpreted in
+ (an extension of) [sigma].
+ @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false])
+ @return [t] where all [occ] occurrences of [pat] have been mapped using
+ [subst] *)
+val eval_pattern :
+ ?raise_NoMatch:bool ->
+ env -> evar_map -> constr ->
+ pattern option -> occ -> subst ->
+ constr
+
+(** [fill_occ_pattern b env sigma t pat occ h] is a simplified version of
+ [eval_pattern].
+ It replaces all [occ] occurrences of [pat] in [t] with Rel [h].
+ [t] must live in [env] and [sigma], [pat] must have been interpreted in
+ (an extension of) [sigma].
+ @raise NoMatch if [pat] has no occurrence and [b] is [true] (default [false])
+ @return the instance of the redex of [pat] that was matched and [t]
+ transformed as described above. *)
+val fill_occ_pattern :
+ ?raise_NoMatch:bool ->
+ env -> evar_map -> constr ->
+ pattern -> occ -> int ->
+ constr Evd.in_evar_universe_context * constr
+
+(** *************************** Low level APIs ****************************** *)
+
+(* The primitive matching facility. It matches of a term with holes, like
+ the T pattern above, and calls a continuation on its occurrences. *)
+
+type ssrdir = L2R | R2L
+val pr_dir_side : ssrdir -> Pp.std_ppcmds
+
+(** a pattern for a term with wildcards *)
+type tpattern
+
+(** [mk_tpattern env sigma0 sigma_p ok p_origin dir t] compiles a term [t]
+ living in [env] [sigma] (an extension of [sigma0]) intro a [tpattern].
+ The [tpattern] can hold a (proof) term [p] and a diction [dir]. The [ok]
+ callback is used to filter occurrences.
+ @return the compiled [tpattern] and its [evar_map]
+ @raise UserEerror is the pattern is a wildcard *)
+val mk_tpattern :
+ ?p_origin:ssrdir * constr ->
+ env -> evar_map ->
+ evar_map * constr ->
+ (constr -> evar_map -> bool) ->
+ ssrdir -> constr ->
+ evar_map * tpattern
+
+(** [findP env t i k] is a stateful function that finds the next occurrence
+ of a tpattern and calls the callback [k] to map the subterm matched.
+ The [int] argument passed to [k] is the number of binders traversed so far
+ plus the initial value [i].
+ @return [t] where the subterms identified by the selected occurrences of
+ the patter have been mapped using [k]
+ @raise NoMatch if the raise_NoMatch flag given to [mk_tpattern_matcher] is
+ [true] and if the pattern did not match
+ @raise UserEerror if the raise_NoMatch flag given to [mk_tpattern_matcher] is
+ [false] and if the pattern did not match *)
+type find_P =
+ env -> constr -> int -> k:subst -> constr
+
+(** [conclude ()] asserts that all mentioned ocurrences have been visited.
+ @return the instance of the pattern, the evarmap after the pattern
+ instantiation, the proof term and the ssrdit stored in the tpattern
+ @raise UserEerror if too many occurrences were specified *)
+type conclude =
+ unit -> constr * ssrdir * (evar_map * Evd.evar_universe_context * constr)
+
+(** [mk_tpattern_matcher b o sigma0 occ sigma_tplist] creates a pair
+ a function [find_P] and [conclude] with the behaviour explained above.
+ The flag [b] (default [false]) changes the error reporting behaviour
+ of [find_P] if none of the [tpattern] matches. The argument [o] can
+ be passed to tune the [UserError] eventually raised (useful if the
+ pattern is coming from the LHS/RHS of an equation) *)
+val mk_tpattern_matcher :
+ ?all_instances:bool ->
+ ?raise_NoMatch:bool ->
+ ?upats_origin:ssrdir * constr ->
+ evar_map -> occ -> evar_map * tpattern list ->
+ find_P * conclude
+
+(** Example of [mk_tpattern_matcher] to implement
+ [rewrite \{occ\}\[in t\]rules].
+ It first matches "in t" (called [pat]), then in all matched subterms
+ it matches the LHS of the rules using [find_R].
+ [concl0] is the initial goal, [concl] will be the goal where some terms
+ are replaced by a De Bruijn index. The [rw_progress] extra check
+ selects only occurrences that are not rewritten to themselves (e.g.
+ an occurrence "x + x" rewritten with the commutativity law of addition
+ is skipped) {[
+ let find_R, conclude = match pat with
+ | Some (_, In_T _) ->
+ let aux (sigma, pats) (d, r, lhs, rhs) =
+ let sigma, pat =
+ mk_tpattern env0 sigma0 (sigma, r) (rw_progress rhs) d lhs in
+ sigma, pats @ [pat] in
+ let rpats = List.fold_left aux (r_sigma, []) rules in
+ let find_R, end_R = mk_tpattern_matcher sigma0 occ rpats in
+ find_R ~k:(fun _ _ h -> mkRel h),
+ fun cl -> let rdx, d, r = end_R () in (d,r),rdx
+ | _ -> ... in
+ let concl = eval_pattern env0 sigma0 concl0 pat occ find_R in
+ let (d, r), rdx = conclude concl in ]} *)
+
+(* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns
+ * the conclusion of [gl] where [occ] occurrences of [t] have been replaced
+ * by [Rel 1] and the instance of [t] *)
+val pf_fill_occ_term : goal sigma -> occ -> evar_map * constr -> constr * constr
+
+(* It may be handy to inject a simple term into the first form of cpattern *)
+val cpattern_of_term : char * glob_constr_and_expr -> cpattern
+
+(** Helpers to make stateful closures. Example: a [find_P] function may be
+ called many times, but the pattern instantiation phase is performed only the
+ first time. The corresponding [conclude] has to return the instantiated
+ pattern redex. Since it is up to [find_P] to raise [NoMatch] if the pattern
+ has no instance, [conclude] considers it an anomaly if the pattern did
+ not match *)
+
+(** [do_once r f] calls [f] and updates the ref only once *)
+val do_once : 'a option ref -> (unit -> 'a) -> unit
+(** [assert_done r] return the content of r. @raise Anomaly is r is [None] *)
+val assert_done : 'a option ref -> 'a
+
+(** Very low level APIs.
+ these are calls to evarconv's [the_conv_x] followed by
+ [solve_unif_constraints_with_heuristics] and [resolve_typeclasses].
+ In case of failure they raise [NoMatch] *)
+
+val unify_HO : env -> evar_map -> constr -> constr -> evar_map
+val pf_unify_HO : goal sigma -> constr -> constr -> goal sigma
+
+(** Some more low level functions needed to implement the full SSR language
+ on top of the former APIs *)
+val tag_of_cpattern : cpattern -> char
+val loc_of_cpattern : cpattern -> Loc.t
+val id_of_pattern : pattern -> Names.variable option
+val is_wildcard : cpattern -> bool
+val cpattern_of_id : Names.variable -> cpattern
+val cpattern_of_id : Names.variable -> cpattern
+val pr_constr_pat : constr -> Pp.std_ppcmds
+val pf_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma
+val pf_unsafe_merge_uc : Evd.evar_universe_context -> goal Evd.sigma -> goal Evd.sigma
+
+(* One can also "Set SsrMatchingDebug" from a .v *)
+val debug : bool -> unit
+
+(* One should delimit a snippet with "Set SsrMatchingProfiling" and
+ * "Unset SsrMatchingProfiling" to get timings *)
+val profile : bool -> unit
+
+(* eof *)
diff --git a/plugins/ssrmatching/ssrmatching.v b/plugins/ssrmatching/ssrmatching.v
new file mode 100644
index 00000000..829ee05e
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching.v
@@ -0,0 +1,26 @@
+(* (c) Copyright 2006-2015 Microsoft Corporation and Inria. *)
+(* Distributed under the terms of CeCILL-B. *)
+Declare ML Module "ssrmatching_plugin".
+
+Module SsrMatchingSyntax.
+
+(* Reserve the notation for rewrite patterns so that the user is not allowed *)
+(* to declare it at a different level. *)
+Reserved Notation "( a 'in' b )" (at level 0).
+Reserved Notation "( a 'as' b )" (at level 0).
+Reserved Notation "( a 'in' b 'in' c )" (at level 0).
+Reserved Notation "( a 'as' b 'in' c )" (at level 0).
+
+(* Notation to define shortcuts for the "X in t" part of a pattern. *)
+Notation "( X 'in' t )" := (_ : fun X => t) : ssrpatternscope.
+Delimit Scope ssrpatternscope with pattern.
+
+(* Some shortcuts for recurrent "X in t" parts. *)
+Notation RHS := (X in _ = X)%pattern.
+Notation LHS := (X in X = _)%pattern.
+
+End SsrMatchingSyntax.
+
+Export SsrMatchingSyntax.
+
+Tactic Notation "ssrpattern" ssrpatternarg(p) := ssrpattern p .
diff --git a/plugins/ssrmatching/ssrmatching_plugin.mlpack b/plugins/ssrmatching/ssrmatching_plugin.mlpack
new file mode 100644
index 00000000..5fb1f156
--- /dev/null
+++ b/plugins/ssrmatching/ssrmatching_plugin.mlpack
@@ -0,0 +1 @@
+Ssrmatching
diff --git a/plugins/ssrmatching/vo.itarget b/plugins/ssrmatching/vo.itarget
new file mode 100644
index 00000000..b0eb3883
--- /dev/null
+++ b/plugins/ssrmatching/vo.itarget
@@ -0,0 +1 @@
+ssrmatching.vo
diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml
index 67c9dd0a..e18d19ce 100644
--- a/plugins/syntax/ascii_syntax.ml
+++ b/plugins/syntax/ascii_syntax.ml
@@ -6,8 +6,12 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "ascii_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
open Pp
-open Errors
+open CErrors
open Util
open Names
open Glob_term
diff --git a/plugins/syntax/ascii_syntax_plugin.mllib b/plugins/syntax/ascii_syntax_plugin.mllib
deleted file mode 100644
index b00f9250..00000000
--- a/plugins/syntax/ascii_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Ascii_syntax
-Ascii_syntax_plugin_mod
diff --git a/plugins/syntax/ascii_syntax_plugin.mlpack b/plugins/syntax/ascii_syntax_plugin.mlpack
new file mode 100644
index 00000000..7b9213a0
--- /dev/null
+++ b/plugins/syntax/ascii_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Ascii_syntax
diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml
index 5f44904c..a9eb126b 100644
--- a/plugins/syntax/nat_syntax.ml
+++ b/plugins/syntax/nat_syntax.ml
@@ -6,6 +6,10 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "nat_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
(* This file defines the printer for natural numbers in [nat] *)
(*i*)
@@ -13,7 +17,7 @@ open Glob_term
open Bigint
open Coqlib
open Pp
-open Errors
+open CErrors
(*i*)
(**********************************************************************)
@@ -22,14 +26,16 @@ open Errors
let threshold = of_int 5000
+let warn_large_nat =
+ CWarnings.create ~name:"large-nat" ~category:"numbers"
+ (fun () -> strbrk "Stack overflow or segmentation fault happens when " ++
+ strbrk "working with large numbers in nat (observed threshold " ++
+ strbrk "may vary from 5000 to 70000 depending on your system " ++
+ strbrk "limits and on the command executed).")
+
let nat_of_int dloc n =
if is_pos_or_zero n then begin
- if less_than threshold n then
- msg_warning
- (strbrk "Stack overflow or segmentation fault happens when " ++
- strbrk "working with large numbers in nat (observed threshold " ++
- strbrk "may vary from 5000 to 70000 depending on your system " ++
- strbrk "limits and on the command executed).");
+ if less_than threshold n then warn_large_nat ();
let ref_O = GRef (dloc, glob_O, None) in
let ref_S = GRef (dloc, glob_S, None) in
let rec mk_nat acc n =
diff --git a/plugins/syntax/nat_syntax_plugin.mllib b/plugins/syntax/nat_syntax_plugin.mllib
deleted file mode 100644
index 69b0cb20..00000000
--- a/plugins/syntax/nat_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Nat_syntax
-Nat_syntax_plugin_mod
diff --git a/plugins/syntax/nat_syntax_plugin.mlpack b/plugins/syntax/nat_syntax_plugin.mlpack
new file mode 100644
index 00000000..39bdd62f
--- /dev/null
+++ b/plugins/syntax/nat_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Nat_syntax
diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml
index fe9f1319..f65f9b79 100644
--- a/plugins/syntax/numbers_syntax.ml
+++ b/plugins/syntax/numbers_syntax.ml
@@ -6,6 +6,10 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "numbers_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
(* digit-based syntax for int31, bigN bigZ and bigQ *)
open Bigint
@@ -96,7 +100,7 @@ let int31_of_pos_bigint dloc n =
GApp (dloc, ref_construct, List.rev (args 31 n))
let error_negative dloc =
- Errors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
+ CErrors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.")
let interp_int31 dloc n =
if is_pos_or_zero n then
@@ -180,12 +184,12 @@ let bigN_of_pos_bigint dloc n =
let word = word_of_pos_bigint dloc h n in
let args =
if h < n_inlined then [word]
- else [Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word]
+ else [Nat_syntax_plugin.Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word]
in
GApp (dloc, ref_constructor, args)
let bigN_error_negative dloc =
- Errors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
+ CErrors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.")
let interp_bigN dloc n =
if is_pos_or_zero n then
diff --git a/plugins/syntax/numbers_syntax_plugin.mllib b/plugins/syntax/numbers_syntax_plugin.mllib
deleted file mode 100644
index ebc0bb20..00000000
--- a/plugins/syntax/numbers_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Numbers_syntax
-Numbers_syntax_plugin_mod
diff --git a/plugins/syntax/numbers_syntax_plugin.mlpack b/plugins/syntax/numbers_syntax_plugin.mlpack
new file mode 100644
index 00000000..e48c00a0
--- /dev/null
+++ b/plugins/syntax/numbers_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Numbers_syntax
diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml
index 05d73f9e..3ae2d45f 100644
--- a/plugins/syntax/r_syntax.ml
+++ b/plugins/syntax/r_syntax.ml
@@ -10,6 +10,10 @@ open Util
open Names
open Globnames
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "r_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
exception Non_closed_number
(**********************************************************************)
diff --git a/plugins/syntax/r_syntax_plugin.mllib b/plugins/syntax/r_syntax_plugin.mllib
deleted file mode 100644
index 5c173a14..00000000
--- a/plugins/syntax/r_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-R_syntax
-R_syntax_plugin_mod
diff --git a/plugins/syntax/r_syntax_plugin.mlpack b/plugins/syntax/r_syntax_plugin.mlpack
new file mode 100644
index 00000000..d4ee75ea
--- /dev/null
+++ b/plugins/syntax/r_syntax_plugin.mlpack
@@ -0,0 +1 @@
+R_syntax
diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml
index 2e696f39..de0fa77e 100644
--- a/plugins/syntax/string_syntax.ml
+++ b/plugins/syntax/string_syntax.ml
@@ -7,10 +7,14 @@
(***********************************************************************)
open Globnames
-open Ascii_syntax
+open Ascii_syntax_plugin.Ascii_syntax
open Glob_term
open Coqlib
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "string_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
exception Non_closed_string
(* make a string term from the string s *)
diff --git a/plugins/syntax/string_syntax_plugin.mllib b/plugins/syntax/string_syntax_plugin.mllib
deleted file mode 100644
index b108c9e0..00000000
--- a/plugins/syntax/string_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-String_syntax
-String_syntax_plugin_mod
diff --git a/plugins/syntax/string_syntax_plugin.mlpack b/plugins/syntax/string_syntax_plugin.mlpack
new file mode 100644
index 00000000..45d6e0fa
--- /dev/null
+++ b/plugins/syntax/string_syntax_plugin.mlpack
@@ -0,0 +1 @@
+String_syntax
diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml
index 53c1b5d7..60803a36 100644
--- a/plugins/syntax/z_syntax.ml
+++ b/plugins/syntax/z_syntax.ml
@@ -7,11 +7,15 @@
(************************************************************************)
open Pp
-open Errors
+open CErrors
open Util
open Names
open Bigint
+(* Poor's man DECLARE PLUGIN *)
+let __coq_plugin_name = "z_syntax_plugin"
+let () = Mltop.add_known_module __coq_plugin_name
+
exception Non_closed_number
(**********************************************************************)
diff --git a/plugins/syntax/z_syntax_plugin.mllib b/plugins/syntax/z_syntax_plugin.mllib
deleted file mode 100644
index 36d41acc..00000000
--- a/plugins/syntax/z_syntax_plugin.mllib
+++ /dev/null
@@ -1,2 +0,0 @@
-Z_syntax
-Z_syntax_plugin_mod
diff --git a/plugins/syntax/z_syntax_plugin.mlpack b/plugins/syntax/z_syntax_plugin.mlpack
new file mode 100644
index 00000000..411260c0
--- /dev/null
+++ b/plugins/syntax/z_syntax_plugin.mlpack
@@ -0,0 +1 @@
+Z_syntax