aboutsummaryrefslogtreecommitdiff
path: root/plugins/omega
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/omega')
-rw-r--r--plugins/omega/PreOmega.v7
-rw-r--r--plugins/omega/coq_omega.ml123
-rw-r--r--plugins/omega/g_omega.ml44
-rw-r--r--plugins/omega/vo.itarget5
4 files changed, 86 insertions, 53 deletions
diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v
index 5f5f548f84..6c0e2d776d 100644
--- a/plugins/omega/PreOmega.v
+++ b/plugins/omega/PreOmega.v
@@ -174,12 +174,18 @@ Ltac zify_nat_op :=
match isnat with
| true => simpl (Z.of_nat (S a)) in H
| _ => rewrite (Nat2Z.inj_succ a) in H
+ | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]),
+ hide [Z.of_nat (S a)] in this one hypothesis *)
+ change (Z.of_nat (S a)) with (Z_of_nat' (S a)) in H
end
| |- context [ Z.of_nat (S ?a) ] =>
let isnat := isnatcst a in
match isnat with
| true => simpl (Z.of_nat (S a))
| _ => rewrite (Nat2Z.inj_succ a)
+ | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]),
+ hide [Z.of_nat (S a)] in the goal *)
+ change (Z.of_nat (S a)) with (Z_of_nat' (S a))
end
(* atoms of type nat : we add a positivity condition (if not already there) *)
@@ -401,4 +407,3 @@ Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *.
(** The complete Z-ification tactic *)
Ltac zify := repeat (zify_nat; zify_positive; zify_N); zify_op.
-
diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml
index d7408e88ec..9cb94b68df 100644
--- a/plugins/omega/coq_omega.ml
+++ b/plugins/omega/coq_omega.ml
@@ -13,6 +13,7 @@
(* *)
(**************************************************************************)
+open API
open CErrors
open Util
open Names
@@ -28,7 +29,6 @@ open Globnames
open Nametab
open Contradiction
open Misctypes
-open Proofview.Notations
open Context.Named.Declaration
module NamedDecl = Context.Named.Declaration
@@ -38,12 +38,12 @@ open OmegaSolver
(* Added by JCF, 09/03/98 *)
let elim_id id =
- Proofview.Goal.enter { enter = begin fun gl ->
+ Proofview.Goal.enter begin fun gl ->
simplest_elim (mkVar id)
- end }
-let resolve_id id = Proofview.Goal.enter { enter = begin fun gl ->
+ end
+let resolve_id id = Proofview.Goal.enter begin fun gl ->
apply (mkVar id)
-end }
+end
let timing timer_name f arg = f arg
@@ -362,7 +362,7 @@ let coq_True = lazy (init_constant "True")
let evaluable_ref_of_constr s c = match EConstr.kind Evd.empty (Lazy.force c) with
| Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) ->
EvalConstRef kn
- | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant"))
+ | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant."))
let sp_Zsucc = lazy (evaluable_ref_of_constr "Z.succ" coq_Zsucc)
let sp_Zpred = lazy (evaluable_ref_of_constr "Z.pred" coq_Zpred)
@@ -580,10 +580,10 @@ let abstract_path sigma typ path t =
let focused_simpl path =
let open Tacmach.New in
- Proofview.Goal.nf_enter { enter = begin fun gl ->
+ Proofview.Goal.nf_enter begin fun gl ->
let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in
convert_concl_no_check newc DEFAULTcast
- end }
+ end
let focused_simpl path = focused_simpl path
@@ -630,7 +630,7 @@ let compile name kind =
let id = new_id () in
tag_hypothesis name id;
{kind = kind; body = List.rev accu; constant = n; id = id}
- | _ -> anomaly (Pp.str "compile_equation")
+ | _ -> anomaly (Pp.str "compile_equation.")
in
loop []
@@ -643,17 +643,16 @@ let decompile af =
(** Backward compat to emulate the old Refine: normalize the goal conclusion *)
let new_hole env sigma c =
- let c = Reductionops.nf_betaiota (Sigma.to_evar_map sigma) c in
+ let c = Reductionops.nf_betaiota sigma c in
Evarutil.new_evar env sigma c
let clever_rewrite_base_poly typ p result theorem =
let open Tacmach.New in
- let open Sigma in
- Proofview.Goal.nf_enter { enter = begin fun gl ->
+ Proofview.Goal.nf_enter begin fun gl ->
let full = pf_concl gl in
let env = pf_env gl in
let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in
- Refine.refine { run = begin fun sigma ->
+ Refine.refine begin fun sigma ->
let t =
applist
(mkLambda
@@ -667,10 +666,10 @@ let clever_rewrite_base_poly typ p result theorem =
[abstracted])
in
let argt = mkApp (abstracted, [|result|]) in
- let Sigma (hole, sigma, p) = new_hole env sigma argt in
- Sigma (applist (t, [hole]), sigma, p)
- end }
- end }
+ let (sigma, hole) = new_hole env sigma argt in
+ (sigma, applist (t, [hole]))
+ end
+ end
let clever_rewrite_base p result theorem =
clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem
@@ -689,26 +688,58 @@ let clever_rewrite_gen_nat p result (t,args) =
(** Solve using the term the term [t _] *)
let refine_app gl t =
let open Tacmach.New in
- let open Sigma in
- Refine.refine { run = begin fun sigma ->
+ Refine.refine begin fun sigma ->
let env = pf_env gl in
- let ht = match EConstr.kind (Sigma.to_evar_map sigma) (pf_get_type_of gl t) with
+ let ht = match EConstr.kind sigma (pf_get_type_of gl t) with
| Prod (_, t, _) -> t
| _ -> assert false
in
- let Sigma (hole, sigma, p) = new_hole env sigma ht in
- Sigma (applist (t, [hole]), sigma, p)
- end }
+ let (sigma, hole) = new_hole env sigma ht in
+ (sigma, applist (t, [hole]))
+ end
let clever_rewrite p vpath t =
let open Tacmach.New in
- Proofview.Goal.nf_enter { enter = begin fun gl ->
+ Proofview.Goal.nf_enter begin fun gl ->
let full = pf_concl gl in
let (abstracted,occ) = abstract_path (project gl) (Lazy.force coq_Z) (List.rev p) full in
let vargs = List.map (fun p -> occurrence (project gl) p occ) vpath in
let t' = applist(t, (vargs @ [abstracted])) in
refine_app gl t'
- end }
+ end
+
+(** simpl_coeffs :
+ The subterm at location [path_init] in the current goal should
+ look like [(v1*c1 + (v2*c2 + ... (vn*cn + k)))], and we reduce
+ via "simpl" each [ci] and the final constant [k].
+ The path [path_k] gives the location of constant [k].
+ Earlier, the whole was a mere call to [focused_simpl],
+ leading to reduction inside the atoms [vi], which is bad,
+ for instance when the atom is an evaluable definition
+ (see #4132). *)
+
+let simpl_coeffs path_init path_k =
+ Proofview.Goal.enter begin fun gl ->
+ let sigma = project gl in
+ let rec loop n t =
+ if Int.equal n 0 then pf_nf gl t
+ else
+ (* t should be of the form ((v * c) + ...) *)
+ match EConstr.kind sigma t with
+ | App(f,[|t1;t2|]) ->
+ (match EConstr.kind sigma t1 with
+ | App (g,[|v;c|]) ->
+ let c' = pf_nf gl c in
+ let t2' = loop (pred n) t2 in
+ mkApp (f,[|mkApp (g,[|v;c'|]);t2'|])
+ | _ -> assert false)
+ | _ -> assert false
+ in
+ let n = Pervasives.(-) (List.length path_k) (List.length path_init) in
+ let newc = context sigma (fun _ t -> loop n t) (List.rev path_init) (pf_concl gl)
+ in
+ convert_concl_no_check newc DEFAULTcast
+ end
let rec shuffle p (t1,t2) =
match t1,t2 with
@@ -772,7 +803,7 @@ let shuffle_mult p_init k1 e1 k2 e2 =
let tac' =
clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
(Lazy.force coq_fast_Zred_factor5) in
- tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' ::
+ tac :: focused_simpl (P_APP 2::P_APP 1:: p) :: tac' ::
loop p (l1,l2)
else tac :: loop (P_APP 2 :: p) (l1,l2)
else if v1 > v2 then
@@ -807,7 +838,7 @@ let shuffle_mult p_init k1 e1 k2 e2 =
[P_APP 2; P_APP 2]]
(Lazy.force coq_fast_OMEGA12) ::
loop (P_APP 2 :: p) ([],l2)
- | [],[] -> [focused_simpl p_init]
+ | [],[] -> [simpl_coeffs p_init p]
in
loop p_init (e1,e2)
@@ -830,7 +861,7 @@ let shuffle_mult_right p_init e1 k2 e2 =
clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]]
(Lazy.force coq_fast_Zred_factor5)
in
- tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' ::
+ tac :: focused_simpl (P_APP 2::P_APP 1:: p) :: tac' ::
loop p (l1,l2)
else tac :: loop (P_APP 2 :: p) (l1,l2)
else if v1 > v2 then
@@ -857,7 +888,7 @@ let shuffle_mult_right p_init e1 k2 e2 =
[P_APP 2; P_APP 2]]
(Lazy.force coq_fast_OMEGA12) ::
loop (P_APP 2 :: p) ([],l2)
- | [],[] -> [focused_simpl p_init]
+ | [],[] -> [simpl_coeffs p_init p]
in
loop p_init (e1,e2)
@@ -898,7 +929,7 @@ let rec scalar p n = function
let scalar_norm p_init =
let rec loop p = function
- | [] -> [focused_simpl p_init]
+ | [] -> [simpl_coeffs p_init p]
| (_::l) ->
clever_rewrite p
[[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2];
@@ -909,7 +940,7 @@ let scalar_norm p_init =
let norm_add p_init =
let rec loop p = function
- | [] -> [focused_simpl p_init]
+ | [] -> [simpl_coeffs p_init p]
| _:: l ->
clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]]
(Lazy.force coq_fast_Zplus_assoc_reverse) ::
@@ -919,7 +950,7 @@ let norm_add p_init =
let scalar_norm_add p_init =
let rec loop p = function
- | [] -> [focused_simpl p_init]
+ | [] -> [simpl_coeffs p_init p]
| _ :: l ->
clever_rewrite p
[[P_APP 1; P_APP 1; P_APP 1; P_APP 1];
@@ -1466,7 +1497,7 @@ let reintroduce id =
open Proofview.Notations
let coq_omega =
- Proofview.Goal.enter { enter = begin fun gl ->
+ Proofview.Goal.enter begin fun gl ->
clear_constr_tables ();
let hyps_types = Tacmach.New.pf_hyps_types gl in
let destructure_omega = destructure_omega gl in
@@ -1514,12 +1545,12 @@ let coq_omega =
tclTHEN prelude (replay_history tactic_normalisation path)
with NO_CONTRADICTION -> tclZEROMSG (Pp.str"Omega can't solve this system")
end
- end }
+ end
let coq_omega = coq_omega
let nat_inject =
- Proofview.Goal.enter { enter = begin fun gl ->
+ Proofview.Goal.enter begin fun gl ->
let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in
let rec explore p t : unit Proofview.tactic =
Proofview.tclEVARMAP >>= fun sigma ->
@@ -1655,7 +1686,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
@@ -1729,19 +1760,19 @@ let onClearedName id tac =
(* so renaming may be necessary *)
tclTHEN
(tclTRY (clear [id]))
- (Proofview.Goal.nf_enter { enter = begin fun gl ->
+ (Proofview.Goal.nf_enter begin fun gl ->
let id = fresh_id [] id gl in
tclTHEN (introduction id) (tac id)
- end })
+ end)
let onClearedName2 id tac =
tclTHEN
(tclTRY (clear [id]))
- (Proofview.Goal.nf_enter { enter = begin fun gl ->
+ (Proofview.Goal.nf_enter begin fun gl ->
let id1 = fresh_id [] (add_suffix id "_left") gl in
let id2 = fresh_id [] (add_suffix id "_right") gl in
tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ]
- end })
+ end)
let rec is_Prop sigma c = match EConstr.kind sigma c with
| Sort s -> Sorts.is_prop (ESorts.kind sigma s)
@@ -1749,7 +1780,7 @@ let rec is_Prop sigma c = match EConstr.kind sigma c with
| _ -> false
let destructure_hyps =
- Proofview.Goal.enter { enter = begin fun gl ->
+ Proofview.Goal.enter begin fun gl ->
let type_of = Tacmach.New.pf_unsafe_type_of gl in
let decidability = decidability gl in
let pf_nf = pf_nf gl in
@@ -1888,10 +1919,10 @@ let destructure_hyps =
in
let hyps = Proofview.Goal.hyps gl in
loop hyps
- end }
+ end
let destructure_goal =
- Proofview.Goal.enter { enter = begin fun gl ->
+ Proofview.Goal.enter begin fun gl ->
let concl = Proofview.Goal.concl gl in
let decidability = decidability gl in
let rec loop t =
@@ -1910,9 +1941,9 @@ let destructure_goal =
try
let dec = decidability t in
tclTHEN
- (Proofview.Goal.nf_enter { enter = begin fun gl ->
+ (Proofview.Goal.nf_enter begin fun gl ->
refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |]))
- end })
+ end)
intro
with Undecidable -> Tactics.elim_type (Lazy.force coq_False)
| e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e
@@ -1920,7 +1951,7 @@ let destructure_goal =
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 ce7ffb1e7e..2fcf076f11 100644
--- a/plugins/omega/g_omega.ml4
+++ b/plugins/omega/g_omega.ml4
@@ -15,6 +15,8 @@
(*i camlp4deps: "grammar/grammar.cma" i*)
+open API
+
DECLARE PLUGIN "omega_plugin"
open Ltac_plugin
@@ -24,7 +26,7 @@ open Stdarg
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 kn = KerName.make2 (ModPath.MPfile dp) (Label.make name) in
let tac = Tacenv.interp_ltac kn in
Tacinterp.eval_tactic tac
diff --git a/plugins/omega/vo.itarget b/plugins/omega/vo.itarget
deleted file mode 100644
index 842210e216..0000000000
--- a/plugins/omega/vo.itarget
+++ /dev/null
@@ -1,5 +0,0 @@
-OmegaLemmas.vo
-OmegaPlugin.vo
-OmegaTactic.vo
-Omega.vo
-PreOmega.vo
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-05 05:34:19 +0000